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 */
ficlGetCWD(FICL_VM * pVM)56 static 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 */
ficlChDir(FICL_VM * pVM)73 static 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 */
ficlSystem(FICL_VM * pVM)101 static 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
ficlLoad(FICL_VM * pVM)131 static 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 */
spewHash(FICL_VM * pVM)212 static 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
ficlBreak(FICL_VM * pVM)257 static void ficlBreak(FICL_VM *pVM)
258 {
259 pVM->state = pVM->state;
260 return;
261 }
262
ficlClock(FICL_VM * pVM)263 static void ficlClock(FICL_VM *pVM)
264 {
265 clock_t now = clock();
266 stackPushUNS(pVM->pStack, (FICL_UNS)now);
267 return;
268 }
269
clocksPerSec(FICL_VM * pVM)270 static void clocksPerSec(FICL_VM *pVM)
271 {
272 stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
273 return;
274 }
275
276
execxt(FICL_VM * pVM)277 static 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
buildTestInterface(FICL_SYSTEM * pSys)291 void 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
main(int argc,char ** argv)308 int 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