1/*
2** stub main for testing FICL under userland
3** $Id: testmain.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $
4*/
5/*
6** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
7** All rights reserved.
8**
9** Get the latest Ficl release at http://ficl.sourceforge.net
10**
11** I am interested in hearing from anyone who uses ficl. If you have
12** a problem, a success story, a defect, an enhancement request, or
13** if you would like to contribute to the ficl release, please
14** contact me by email at the address above.
15**
16** L I C E N S E  and  D I S C L A I M E R
17**
18** Redistribution and use in source and binary forms, with or without
19** modification, are permitted provided that the following conditions
20** are met:
21** 1. Redistributions of source code must retain the above copyright
22**    notice, this list of conditions and the following disclaimer.
23** 2. Redistributions in binary form must reproduce the above copyright
24**    notice, this list of conditions and the following disclaimer in the
25**    documentation and/or other materials provided with the distribution.
26**
27** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
28** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
29** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
30** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
31** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
32** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
33** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
34** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
35** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
36** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
37** SUCH DAMAGE.
38*/
39
40
41#include <stdlib.h>
42#include <stdio.h>
43#include <string.h>
44#include <time.h>
45#include <sys/types.h>
46#include <sys/stat.h>
47#include <unistd.h>
48
49#include "ficl.h"
50
51/*
52** Ficl interface to getcwd
53** Prints the current working directory using the VM's
54** textOut method...
55*/
56static void ficlGetCWD(FICL_VM *pVM)
57{
58    char *cp;
59
60    cp = getcwd(NULL, 80);
61    vmTextOut(pVM, cp, 1);
62    free(cp);
63    return;
64}
65
66/*
67** Ficl interface to chdir
68** Gets a newline (or NULL) delimited string from the input
69** and feeds it to chdir()
70** Example:
71**    cd c:\tmp
72*/
73static void ficlChDir(FICL_VM *pVM)
74{
75    FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
76    vmGetString(pVM, pFS, '\n');
77    if (pFS->count > 0)
78    {
79       int err = chdir(pFS->text);
80       if (err)
81        {
82            vmTextOut(pVM, "Error: path not found", 1);
83            vmThrow(pVM, VM_QUIT);
84        }
85    }
86    else
87    {
88        vmTextOut(pVM, "Warning (chdir): nothing happened", 1);
89    }
90    return;
91}
92
93/*
94** Ficl interface to system (ANSI)
95** Gets a newline (or NULL) delimited string from the input
96** and feeds it to system()
97** Example:
98**    system rm -rf /
99**    \ ouch!
100*/
101static void ficlSystem(FICL_VM *pVM)
102{
103    FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
104
105    vmGetString(pVM, pFS, '\n');
106    if (pFS->count > 0)
107    {
108        int err = system(pFS->text);
109        if (err)
110        {
111            sprintf(pVM->pad, "System call returned %d", err);
112            vmTextOut(pVM, pVM->pad, 1);
113            vmThrow(pVM, VM_QUIT);
114        }
115    }
116    else
117    {
118        vmTextOut(pVM, "Warning (system): nothing happened", 1);
119    }
120    return;
121}
122
123/*
124** Ficl add-in to load a text file and execute it...
125** Cheesy, but illustrative.
126** Line oriented... filename is newline (or NULL) delimited.
127** Example:
128**    load test.ficl
129*/
130#define nLINEBUF 256
131static void ficlLoad(FICL_VM *pVM)
132{
133    char    cp[nLINEBUF];
134    char    filename[nLINEBUF];
135    FICL_STRING *pFilename = (FICL_STRING *)filename;
136    int     nLine = 0;
137    FILE   *fp;
138    int     result;
139    CELL    id;
140    struct stat buf;
141
142
143    vmGetString(pVM, pFilename, '\n');
144
145    if (pFilename->count <= 0)
146    {
147        vmTextOut(pVM, "Warning (load): nothing happened", 1);
148        return;
149    }
150
151    /*
152    ** get the file's size and make sure it exists
153    */
154    result = stat( pFilename->text, &buf );
155
156    if (result != 0)
157    {
158        vmTextOut(pVM, "Unable to stat file: ", 0);
159        vmTextOut(pVM, pFilename->text, 1);
160        vmThrow(pVM, VM_QUIT);
161    }
162
163    fp = fopen(pFilename->text, "r");
164    if (!fp)
165    {
166        vmTextOut(pVM, "Unable to open file ", 0);
167        vmTextOut(pVM, pFilename->text, 1);
168        vmThrow(pVM, VM_QUIT);
169    }
170
171    id = pVM->sourceID;
172    pVM->sourceID.p = (void *)fp;
173
174    /* feed each line to ficlExec */
175    while (fgets(cp, nLINEBUF, fp))
176    {
177        int len = strlen(cp) - 1;
178
179        nLine++;
180        if (len <= 0)
181            continue;
182
183        result = ficlExecC(pVM, cp, len);
184        if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
185        {
186                pVM->sourceID = id;
187                fclose(fp);
188                vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
189                break;
190        }
191    }
192    /*
193    ** Pass an empty line with SOURCE-ID == -1 to flush
194    ** any pending REFILLs (as required by FILE wordset)
195    */
196    pVM->sourceID.i = -1;
197    ficlExec(pVM, "");
198
199    pVM->sourceID = id;
200    fclose(fp);
201
202    /* handle "bye" in loaded files. --lch */
203    if (result == VM_USEREXIT)
204        vmThrow(pVM, VM_USEREXIT);
205    return;
206}
207
208/*
209** Dump a tab delimited file that summarizes the contents of the
210** dictionary hash table by hashcode...
211*/
212static void spewHash(FICL_VM *pVM)
213{
214    FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
215    FICL_WORD *pFW;
216    FILE *pOut;
217    unsigned i;
218    unsigned nHash = pHash->size;
219
220    if (!vmGetWordToPad(pVM))
221        vmThrow(pVM, VM_OUTOFTEXT);
222
223    pOut = fopen(pVM->pad, "w");
224    if (!pOut)
225    {
226        vmTextOut(pVM, "unable to open file", 1);
227        return;
228    }
229
230    for (i=0; i < nHash; i++)
231    {
232        int n = 0;
233
234        pFW = pHash->table[i];
235        while (pFW)
236        {
237            n++;
238            pFW = pFW->link;
239        }
240
241        fprintf(pOut, "%d\t%d", i, n);
242
243        pFW = pHash->table[i];
244        while (pFW)
245        {
246            fprintf(pOut, "\t%s", pFW->name);
247            pFW = pFW->link;
248        }
249
250        fprintf(pOut, "\n");
251    }
252
253    fclose(pOut);
254    return;
255}
256
257static void ficlBreak(FICL_VM *pVM)
258{
259    pVM->state = pVM->state;
260    return;
261}
262
263static void ficlClock(FICL_VM *pVM)
264{
265    clock_t now = clock();
266    stackPushUNS(pVM->pStack, (FICL_UNS)now);
267    return;
268}
269
270static void clocksPerSec(FICL_VM *pVM)
271{
272    stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
273    return;
274}
275
276
277static void execxt(FICL_VM *pVM)
278{
279    FICL_WORD *pFW;
280#if FICL_ROBUST > 1
281    vmCheckStack(pVM, 1, 0);
282#endif
283
284    pFW = stackPopPtr(pVM->pStack);
285    ficlExecXT(pVM, pFW);
286
287    return;
288}
289
290
291void buildTestInterface(FICL_SYSTEM *pSys)
292{
293    ficlBuild(pSys, "break",    ficlBreak,    FW_DEFAULT);
294    ficlBuild(pSys, "clock",    ficlClock,    FW_DEFAULT);
295    ficlBuild(pSys, "cd",       ficlChDir,    FW_DEFAULT);
296    ficlBuild(pSys, "execxt",   execxt,       FW_DEFAULT);
297    ficlBuild(pSys, "load",     ficlLoad,     FW_DEFAULT);
298    ficlBuild(pSys, "pwd",      ficlGetCWD,   FW_DEFAULT);
299    ficlBuild(pSys, "system",   ficlSystem,   FW_DEFAULT);
300    ficlBuild(pSys, "spewhash", spewHash,     FW_DEFAULT);
301    ficlBuild(pSys, "clocks/sec",
302                                clocksPerSec, FW_DEFAULT);
303
304    return;
305}
306
307
308int main(int argc, char **argv)
309{
310    char in[256];
311    FICL_VM *pVM;
312	FICL_SYSTEM *pSys;
313
314    pSys = ficlInitSystem(10000);
315    buildTestInterface(pSys);
316    pVM = ficlNewVM(pSys);
317
318    ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit");
319
320    /*
321    ** load file from cmd line...
322    */
323    if (argc  > 1)
324    {
325        sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
326        ficlEvaluate(pVM, in);
327    }
328
329    for (;;)
330    {
331        int ret;
332        if (fgets(in, sizeof(in) - 1, stdin) == NULL)
333	    break;
334        ret = ficlExec(pVM, in);
335        if (ret == VM_USEREXIT)
336        {
337            ficlTermSystem(pSys);
338            break;
339        }
340    }
341
342    return 0;
343}
344
345