2 ** stub main for testing FICL under userland
3 ** $Id: testmain.c,v 1.13 2001/12/05 07:21:34 jsadler Exp $
6 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
7 ** All rights reserved.
9 ** Get the latest Ficl release at http://ficl.sourceforge.net
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.
16 ** L I C E N S E and D I S C L A I M E R
18 ** Redistribution and use in source and binary forms, with or without
19 ** modification, are permitted provided that the following conditions
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.
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
46 #include <sys/types.h>
53 ** Ficl interface to getcwd
54 ** Prints the current working directory using the VM's
57 static void ficlGetCWD(FICL_VM *pVM)
61 cp = getcwd(NULL, 80);
62 vmTextOut(pVM, cp, 1);
68 ** Ficl interface to chdir
69 ** Gets a newline (or NULL) delimited string from the input
70 ** and feeds it to chdir()
74 static void ficlChDir(FICL_VM *pVM)
76 FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
77 vmGetString(pVM, pFS, '\n');
80 int err = chdir(pFS->text);
83 vmTextOut(pVM, "Error: path not found", 1);
84 vmThrow(pVM, VM_QUIT);
89 vmTextOut(pVM, "Warning (chdir): nothing happened", 1);
95 ** Ficl interface to system (ANSI)
96 ** Gets a newline (or NULL) delimited string from the input
97 ** and feeds it to system()
102 static void ficlSystem(FICL_VM *pVM)
104 FICL_STRING *pFS = (FICL_STRING *)pVM->pad;
106 vmGetString(pVM, pFS, '\n');
109 int err = system(pFS->text);
112 sprintf(pVM->pad, "System call returned %d", err);
113 vmTextOut(pVM, pVM->pad, 1);
114 vmThrow(pVM, VM_QUIT);
119 vmTextOut(pVM, "Warning (system): nothing happened", 1);
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.
132 static void ficlLoad(FICL_VM *pVM)
135 char filename[nLINEBUF];
136 FICL_STRING *pFilename = (FICL_STRING *)filename;
144 vmGetString(pVM, pFilename, '\n');
146 if (pFilename->count <= 0)
148 vmTextOut(pVM, "Warning (load): nothing happened", 1);
153 ** get the file's size and make sure it exists
155 result = stat( pFilename->text, &buf );
159 vmTextOut(pVM, "Unable to stat file: ", 0);
160 vmTextOut(pVM, pFilename->text, 1);
161 vmThrow(pVM, VM_QUIT);
164 fp = fopen(pFilename->text, "r");
167 vmTextOut(pVM, "Unable to open file ", 0);
168 vmTextOut(pVM, pFilename->text, 1);
169 vmThrow(pVM, VM_QUIT);
173 pVM->sourceID.p = (void *)fp;
175 /* feed each line to ficlExec */
176 while (fgets(cp, nLINEBUF, fp))
178 int len = strlen(cp) - 1;
184 result = ficlExecC(pVM, cp, len);
185 if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
189 vmThrowErr(pVM, "Error loading file <%s> line %d", pFilename->text, nLine);
194 ** Pass an empty line with SOURCE-ID == -1 to flush
195 ** any pending REFILLs (as required by FILE wordset)
197 pVM->sourceID.i = -1;
203 /* handle "bye" in loaded files. --lch */
204 if (result == VM_USEREXIT)
205 vmThrow(pVM, VM_USEREXIT);
210 ** Dump a tab delimited file that summarizes the contents of the
211 ** dictionary hash table by hashcode...
213 static void spewHash(FICL_VM *pVM)
215 FICL_HASH *pHash = vmGetDict(pVM)->pForthWords;
219 unsigned nHash = pHash->size;
221 if (!vmGetWordToPad(pVM))
222 vmThrow(pVM, VM_OUTOFTEXT);
224 pOut = fopen(pVM->pad, "w");
227 vmTextOut(pVM, "unable to open file", 1);
231 for (i=0; i < nHash; i++)
235 pFW = pHash->table[i];
242 fprintf(pOut, "%d\t%d", i, n);
244 pFW = pHash->table[i];
247 fprintf(pOut, "\t%s", pFW->name);
258 static void ficlBreak(FICL_VM *pVM)
260 pVM->state = pVM->state;
264 static void ficlClock(FICL_VM *pVM)
266 clock_t now = clock();
267 stackPushUNS(pVM->pStack, (FICL_UNS)now);
271 static void clocksPerSec(FICL_VM *pVM)
273 stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
278 static void execxt(FICL_VM *pVM)
282 vmCheckStack(pVM, 1, 0);
285 pFW = stackPopPtr(pVM->pStack);
286 ficlExecXT(pVM, pFW);
292 void buildTestInterface(FICL_SYSTEM *pSys)
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);
309 int main(int argc, char **argv)
315 pSys = ficlInitSystem(10000);
316 buildTestInterface(pSys);
317 pVM = ficlNewVM(pSys);
319 ficlEvaluate(pVM, ".ver .( " __DATE__ " ) cr quit");
322 ** load file from cmd line...
326 sprintf(in, ".( loading %s ) cr load %s\n cr", argv[1], argv[1]);
327 ficlEvaluate(pVM, in);
333 if (fgets(in, sizeof(in) - 1, stdin) == NULL)
335 ret = ficlExec(pVM, in);
336 if (ret == VM_USEREXIT)
338 ficlTermSystem(pSys);