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/* $FreeBSD$ */
41
42#include <stdlib.h>
43#include <stdio.h>
44#include <string.h>
45#include <time.h>
46#include <sys/types.h>
47#include <sys/stat.h>
48#include <unistd.h>
49
50#include "ficl.h"
51
52/*
53** Ficl interface to getcwd
54** Prints the current working directory using the VM's
55** textOut method...
56*/
57static void ficlGetCWD(FICL_VM *pVM)
58{
59    char *cp;
60
61    cp = getcwd(NULL, 80);
62    vmTextOut(pVM, cp, 1);
63    free(cp);
64    return;
65}
66
67/*
68** Ficl interface to chdir
69** Gets a newline (or NULL) delimited string from the input
70** and feeds it to chdir()
71** Example:
72**    cd c:\tmp
73*/
74static void ficlChDir(FICL_VM *pVM)
75{
76    FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
77    vmGetString(pVM, pFS, '\n');
78    if (pFS->count > 0)
79    {
80       int err = chdir(pFS->text);
81       if (err)
82        {
83            vmTextOut(pVM, "Error: path not found", 1);
84            vmThrow(pVM, VM_QUIT);
85        }
86    }
87    else
88    {
89        vmTextOut(pVM, "Warning (chdir): nothing happened", 1);
90    }
91    return;
92}
93
94/*
95** Ficl interface to system (ANSI)
96** Gets a newline (or NULL) delimited string from the input
97** and feeds it to system()
98** Example:
99**    system rm -rf /
100**    \ ouch!
101*/
102static void ficlSystem(FICL_VM *pVM)
103{
104    FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
105
106    vmGetString(pVM, pFS, '\n');
107    if (pFS->count > 0)
108    {
109        int err = system(pFS->text);
110        if (err)
111        {
112            sprintf(pVM->pad, "System call returned %d", err);
113            vmTextOut(pVM, pVM->pad, 1);
114            vmThrow(pVM, VM_QUIT);
115        }
116    }
117    else
118    {
119        vmTextOut(pVM, "Warning (system): nothing happened", 1);
120    }
121    return;
122}
123
124/*
125** Ficl add-in to load a text file and execute it...
126** Cheesy, but illustrative.
127** Line oriented... filename is newline (or NULL) delimited.
128** Example:
129**    load test.ficl
130*/
131#define nLINEBUF 256
132static void ficlLoad(FICL_VM *pVM)
133{
134    char    cp[nLINEBUF];
135    char    filename[nLINEBUF];
136    FICL_STRING *pFilename = (FICL_STRING *)filename;
137    int     nLine = 0;
138    FILE   *fp;
139    int     result;
140    CELL    id;
141    struct stat buf;
142
143
144    vmGetString(pVM, pFilename, '\n');
145
146    if (pFilename->count <= 0)
147    {
148        vmTextOut(pVM, "Warning (load): nothing happened", 1);
149        return;
150    }
151
152    /*
153    ** get the file's size and make sure it exists
154    */
155    result = stat( pFilename->text, &buf );
156
157    if (result != 0)
158    {
159        vmTextOut(pVM, "Unable to stat file: ", 0);
160        vmTextOut(pVM, pFilename->text, 1);
161        vmThrow(pVM, VM_QUIT);
162    }
163
164    fp = fopen(pFilename->text, "r");
165    if (!fp)
166    {
167        vmTextOut(pVM, "Unable to open file ", 0);
168        vmTextOut(pVM, pFilename->text, 1);
169        vmThrow(pVM, VM_QUIT);
170    }
171
172    id = pVM->sourceID;
173    pVM->sourceID.p = (void *)fp;
174
175    /* feed each line to ficlExec */
176    while (fgets(cp, nLINEBUF, fp))
177    {
178        int len = strlen(cp) - 1;
179
180        nLine++;
181        if (len <= 0)
182            continue;
183
184        result = ficlExecC(pVM, cp, len);
185        if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
186        {
187                pVM->sourceID = id;
188                fclose(fp);
189                vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
190                break;
191        }
192    }
193    /*
194    ** Pass an empty line with SOURCE-ID == -1 to flush
195    ** any pending REFILLs (as required by FILE wordset)
196    */
197    pVM->sourceID.i = -1;
198    ficlExec(pVM, "");
199
200    pVM->sourceID = id;
201    fclose(fp);
202
203    /* handle "bye" in loaded files. --lch */
204    if (result == VM_USEREXIT)
205        vmThrow(pVM, VM_USEREXIT);
206    return;
207}
208
209/*
210** Dump a tab delimited file that summarizes the contents of the
211** dictionary hash table by hashcode...
212*/
213static void spewHash(FICL_VM *pVM)
214{
215    FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
216    FICL_WORD *pFW;
217    FILE *pOut;
218    unsigned i;
219    unsigned nHash = pHash->size;
220
221    if (!vmGetWordToPad(pVM))
222        vmThrow(pVM, VM_OUTOFTEXT);
223
224    pOut = fopen(pVM->pad, "w");
225    if (!pOut)
226    {
227        vmTextOut(pVM, "unable to open file", 1);
228        return;
229    }
230
231    for (i=0; i < nHash; i++)
232    {
233        int n = 0;
234
235        pFW = pHash->table[i];
236        while (pFW)
237        {
238            n++;
239            pFW = pFW->link;
240        }
241
242        fprintf(pOut, "%d\t%d", i, n);
243
244        pFW = pHash->table[i];
245        while (pFW)
246        {
247            fprintf(pOut, "\t%s", pFW->name);
248            pFW = pFW->link;
249        }
250
251        fprintf(pOut, "\n");
252    }
253
254    fclose(pOut);
255    return;
256}
257
258static void ficlBreak(FICL_VM *pVM)
259{
260    pVM->state = pVM->state;
261    return;
262}
263
264static void ficlClock(FICL_VM *pVM)
265{
266    clock_t now = clock();
267    stackPushUNS(pVM->pStack, (FICL_UNS)now);
268    return;
269}
270
271static void clocksPerSec(FICL_VM *pVM)
272{
273    stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
274    return;
275}
276
277
278static void execxt(FICL_VM *pVM)
279{
280    FICL_WORD *pFW;
281#if FICL_ROBUST > 1
282    vmCheckStack(pVM, 1, 0);
283#endif
284
285    pFW = stackPopPtr(pVM->pStack);
286    ficlExecXT(pVM, pFW);
287
288    return;
289}
290
291
292void buildTestInterface(FICL_SYSTEM *pSys)
293{
294    ficlBuild(pSys, "break",    ficlBreak,    FW_DEFAULT);
295    ficlBuild(pSys, "clock",    ficlClock,    FW_DEFAULT);
296    ficlBuild(pSys, "cd",       ficlChDir,    FW_DEFAULT);
297    ficlBuild(pSys, "execxt",   execxt,       FW_DEFAULT);
298    ficlBuild(pSys, "load",     ficlLoad,     FW_DEFAULT);
299    ficlBuild(pSys, "pwd",      ficlGetCWD,   FW_DEFAULT);
300    ficlBuild(pSys, "system",   ficlSystem,   FW_DEFAULT);
301    ficlBuild(pSys, "spewhash", spewHash,     FW_DEFAULT);
302    ficlBuild(pSys, "clocks/sec",
303                                clocksPerSec, FW_DEFAULT);
304
305    return;
306}
307
308
309int main(int argc, char **argv)
310{
311    char in[256];
312    FICL_VM *pVM;
313	FICL_SYSTEM *pSys;
314
315    pSys = ficlInitSystem(10000);
316    buildTestInterface(pSys);
317    pVM = ficlNewVM(pSys);
318
319    ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit");
320
321    /*
322    ** load file from cmd line...
323    */
324    if (argc  > 1)
325    {
326        sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
327        ficlEvaluate(pVM, in);
328    }
329
330    for (;;)
331    {
332        int ret;
333        if (fgets(in, sizeof(in) - 1, stdin) == NULL)
334	    break;
335        ret = ficlExec(pVM, in);
336        if (ret == VM_USEREXIT)
337        {
338            ficlTermSystem(pSys);
339            break;
340        }
341    }
342
343    return 0;
344}
345
346