1/*******************************************************************
2** f i c l . c
3** Forth Inspired Command Language - external interface
4** Author: John Sadler (john_sadler@alum.mit.edu)
5** Created: 19 July 1997
6**
7*******************************************************************/
8/*
9** This is an ANS Forth interpreter written in C.
10** Ficl uses Forth syntax for its commands, but turns the Forth
11** model on its head in other respects.
12** Ficl provides facilities for interoperating
13** with programs written in C: C functions can be exported to Ficl,
14** and Ficl commands can be executed via a C calling interface. The
15** interpreter is re-entrant, so it can be used in multiple instances
16** in a multitasking system. Unlike Forth, Ficl's outer interpreter
17** expects a text block as input, and returns to the caller after each
18** text block, so the data pump is somewhere in external code. This
19** is more like TCL than Forth.
20**
21** Code is written in ANSI C for portability.
22*/
23
24#ifdef TESTMAIN
25#include <stdlib.h>
26#else
27#include <stand.h>
28#endif
29#include <string.h>
30#include "ficl.h"
31
32#ifdef FICL_TRACE
33int ficl_trace = 0;
34#endif
35
36
37/*
38** Local prototypes
39*/
40
41
42/*
43** System statics
44** The system builds a global dictionary during its start
45** sequence. This is shared by all interpreter instances.
46** Therefore only one instance can update the dictionary
47** at a time. The system imports a locking function that
48** you can override in order to control update access to
49** the dictionary. The function is stubbed out by default,
50** but you can insert one: #define FICL_MULTITHREAD 1
51** and supply your own version of ficlLockDictionary.
52*/
53static FICL_DICT *dp = NULL;
54static FICL_DICT *envp = NULL;
55#if FICL_WANT_LOCALS
56static FICL_DICT *localp = NULL;
57#endif
58static FICL_VM *vmList = NULL;
59
60static int defaultStack = FICL_DEFAULT_STACK;
61static int defaultDict = FICL_DEFAULT_DICT;
62
63
64/**************************************************************************
65 f i c l I n i t S y s t e m
66** Binds a global dictionary to the interpreter system.
67** You specify the address and size of the allocated area.
68** After that, ficl manages it.
69** First step is to set up the static pointers to the area.
70** Then write the "precompiled" portion of the dictionary in.
71** The dictionary needs to be at least large enough to hold the
72** precompiled part. Try 1K cells minimum. Use "words" to find
73** out how much of the dictionary is used at any time.
74**************************************************************************/
75void ficlInitSystem(int nDictCells)
76{
77 if (dp)
78 dictDelete(dp);
79
80 if (envp)
81 dictDelete(envp);
82
83#if FICL_WANT_LOCALS
84 if (localp)
85 dictDelete(localp);
86#endif
87
88 if (nDictCells <= 0)
89 nDictCells = defaultDict;
90
91 dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE);
92 envp = dictCreate( (unsigned)FICL_DEFAULT_ENV);
93#if FICL_WANT_LOCALS
94 /*
95 ** The locals dictionary is only searched while compiling,
96 ** but this is where speed is most important. On the other
97 ** hand, the dictionary gets emptied after each use of locals
98 ** The need to balance search speed with the cost of the empty
99 ** operation led me to select a single-threaded list...
100 */
101 localp = dictCreate( (unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD);
102#endif
103
104 ficlCompileCore(dp);
105
106 return;
107}
108
109
110/**************************************************************************
111 f i c l N e w V M
112** Create a new virtual machine and link it into the system list
113** of VMs for later cleanup by ficlTermSystem. If this is the first
114** VM to be created, use it to compile the words in softcore.c
115**************************************************************************/
116FICL_VM *ficlNewVM(void)
117{
118 FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack);
119 pVM->link = vmList;
120
121 /*
122 ** Borrow the first vm to build the soft words in softcore.c
123 */
124 if (vmList == NULL)
125 ficlCompileSoftCore(pVM);
126
127 vmList = pVM;
128 return pVM;
129}
130
131
132/**************************************************************************
133 f i c l B u i l d
134** Builds a word into the dictionary.
135** Preconditions: system must be initialized, and there must
136** be enough space for the new word's header! Operation is
137** controlled by ficlLockDictionary, so any initialization
138** required by your version of the function (if you overrode
139** it) must be complete at this point.
140** Parameters:
141** name -- duh, the name of the word
142** code -- code to execute when the word is invoked - must take a single param
143** pointer to a FICL_VM
144** flags -- 0 or more of F_IMMEDIATE, F_COMPILE, use bitwise OR!
145**
146**************************************************************************/
147int ficlBuild(char *name, FICL_CODE code, char flags)
148{
149 int err = ficlLockDictionary(TRUE);
150 if (err) return err;
151
152 dictAppendWord(dp, name, code, flags);
153
154 ficlLockDictionary(FALSE);
155 return 0;
156}
157
158
159/**************************************************************************
160 f i c l E x e c
161** Evaluates a block of input text in the context of the
162** specified interpreter. Emits any requested output to the
163** interpreter's output function.
164**
165** Contains the "inner interpreter" code in a tight loop
166**
167** Returns one of the VM_XXXX codes defined in ficl.h:
168** VM_OUTOFTEXT is the normal exit condition
169** VM_ERREXIT means that the interp encountered a syntax error
170** and the vm has been reset to recover (some or all
171** of the text block got ignored
172** VM_USEREXIT means that the user executed the "bye" command
173** to shut down the interpreter. This would be a good
174** time to delete the vm, etc -- or you can ignore this
175** signal.
176**************************************************************************/
177int ficlExec(FICL_VM *pVM, char *pText, INT32 size)
178{
179 int except;
180 FICL_WORD *tempFW;
181 jmp_buf vmState;
182 jmp_buf *oldState;
183 TIB saveTib;
184
185 assert(pVM);
186
187 vmPushTib(pVM, pText, size, &saveTib);
188
189 /*
190 ** Save and restore VM's jmp_buf to enable nested calls to ficlExec
191 */
192 oldState = pVM->pState;
193 pVM->pState = &vmState; /* This has to come before the setjmp! */
194 except = setjmp(vmState);
195
196 switch (except)
197 {
198 case 0:
199 if (pVM->fRestart)
200 {
201 pVM->fRestart = 0;
202 pVM->runningWord->code(pVM);
203 }
204
205 /*
206 ** the mysterious inner interpreter...
207 ** vmThrow gets you out of this loop with a longjmp()
208 */
209 for (;;)
210 {
211#ifdef FICL_TRACE
212 char buffer[40];
213 CELL *pc;
214#endif
215 tempFW = *pVM->ip++;
216#ifdef FICL_TRACE
217 if (ficl_trace && isAFiclWord(tempFW))
218 {
219 extern void literalParen(FICL_VM*);
220 extern void stringLit(FICL_VM*);
221 extern void ifParen(FICL_VM*);
222 extern void branchParen(FICL_VM*);
223 extern void qDoParen(FICL_VM*);
224 extern void doParen(FICL_VM*);
225 extern void loopParen(FICL_VM*);
226 extern void plusLoopParen(FICL_VM*);
227
228 if (tempFW->code == literalParen)
229 {
230 CELL v = *++pc;
231 if (isAFiclWord(v.p))
232 {
233 FICL_WORD *pLit = (FICL_WORD *)v.p;
234 sprintf(buffer, " literal %.*s (%#lx)",
235 pLit->nName, pLit->name, v.u);
236 }
237 else
238 sprintf(buffer, " literal %ld (%#lx)", v.i, v.u);
239 }
240 else if (tempFW->code == stringLit)
241 {
242 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
243 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
244 sprintf(buffer, " s\" %.*s\"", sp->count, sp->text);
245 }
246 else if (tempFW->code == ifParen)
247 {
248 CELL c = *++pc;
249 if (c.i > 0)
250 sprintf(buffer, " if / while (branch rel %ld)", c.i);
251 else
252 sprintf(buffer, " until (branch rel %ld)", c.i);
253 }
254 else if (tempFW->code == branchParen)
255 {
256 CELL c = *++pc;
257 if (c.i > 0)
258 sprintf(buffer, " else (branch rel %ld)", c.i);
259 else
260 sprintf(buffer, " repeat (branch rel %ld)", c.i);
261 }
262 else if (tempFW->code == qDoParen)
263 {
264 CELL c = *++pc;
265 sprintf(buffer, " ?do (leave abs %#lx)", c.u);
266 }
267 else if (tempFW->code == doParen)
268 {
269 CELL c = *++pc;
270 sprintf(buffer, " do (leave abs %#lx)", c.u);
271 }
272 else if (tempFW->code == loopParen)
273 {
274 CELL c = *++pc;
275 sprintf(buffer, " loop (branch rel %#ld)", c.i);
276 }
277 else if (tempFW->code == plusLoopParen)
278 {
279 CELL c = *++pc;
280 sprintf(buffer, " +loop (branch rel %#ld)", c.i);
281 }
282 else /* default: print word's name */
283 {
284 sprintf(buffer, " %.*s", tempFW->nName, tempFW->name);
285 }
286
287 vmTextOut(pVM, buffer, 1);
288 }
289 else if (ficl_trace) /* probably not a word - punt and print value */
290 {
291 sprintf(buffer, " %ld (%#lx)", pc->i, pc->u);
292 vmTextOut(pVM, buffer, 1);
293 }
294#endif FICL_TRACE
295 /*
296 ** inline code for
297 ** vmExecute(pVM, tempFW);
298 */
299 pVM->runningWord = tempFW;
300 tempFW->code(pVM);
301 }
302
303 break;
304
305 case VM_RESTART:
306 pVM->fRestart = 1;
307 except = VM_OUTOFTEXT;
308 break;
309
310 case VM_OUTOFTEXT:
311#ifdef TESTMAIN
312 if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0))
313 ficlTextOut(pVM, FICL_PROMPT, 0);
314#endif
315 break;
316
317 case VM_USEREXIT:
318 break;
319
320 case VM_QUIT:
321 if (pVM->state == COMPILE)
322 dictAbortDefinition(dp);
323 vmQuit(pVM);
324 break;
325
326 case VM_ERREXIT:
327 case VM_ABORT:
328 case VM_ABORTQ:
329 default: /* user defined exit code?? */
330 if (pVM->state == COMPILE)
331 {
332 dictAbortDefinition(dp);
333#if FICL_WANT_LOCALS
334 dictEmpty(localp, localp->pForthWords->size);
335#endif
336 }
337 dictResetSearchOrder(dp);
338 vmReset(pVM);
339 break;
340 }
341
342 pVM->pState = oldState;
343 vmPopTib(pVM, &saveTib);
344 return (except);
345}
346
347/**************************************************************************
348 f i c l E x e c F D
349** reads in text from file fd and passes it to ficlExec()
350 * returns VM_OUTOFTEXT on success or the ficlExec() error code on
351 * failure.
352 */
353#define nLINEBUF 256
354int ficlExecFD(FICL_VM *pVM, int fd)
355{
356 char cp[nLINEBUF];
357 int i, nLine = 0, rval = VM_OUTOFTEXT;
358 char ch;
359 CELL id;
360
361 id = pVM->sourceID;
362 pVM->sourceID.i = fd;
363
364 /* feed each line to ficlExec */
365 while (1) {
366 int status, i;
367
368 i = 0;
369 while ((status = read(fd, &ch, 1)) > 0 && ch != '\n')
370 cp[i++] = ch;
371 nLine++;
372 if (!i) {
373 if (status < 1)
374 break;
375 continue;
376 }
377 if ((rval = ficlExec(pVM, cp, i)) >= VM_ERREXIT)
378 {
379 pVM->sourceID = id;
380 vmThrowErr(pVM, "ficlExecFD: Error at line %d", nLine);
381 break;
382 }
383 }
384 /*
385 ** Pass an empty line with SOURCE-ID == 0 to flush
386 ** any pending REFILLs (as required by FILE wordset)
387 */
388 pVM->sourceID.i = -1;
389 ficlExec(pVM, "", 0);
390
391 pVM->sourceID = id;
392 return rval;
393}
394
395/**************************************************************************
396 f i c l L o o k u p
397** Look in the system dictionary for a match to the given name. If
398** found, return the address of the corresponding FICL_WORD. Otherwise
399** return NULL.
400**************************************************************************/
401FICL_WORD *ficlLookup(char *name)
402{
403 STRINGINFO si;
404 SI_PSZ(si, name);
405 return dictLookup(dp, si);
406}
407
408
409/**************************************************************************
410 f i c l G e t D i c t
411** Returns the address of the system dictionary
412**************************************************************************/
413FICL_DICT *ficlGetDict(void)
414{
415 return dp;
416}
417
418
419/**************************************************************************
420 f i c l G e t E n v
421** Returns the address of the system environment space
422**************************************************************************/
423FICL_DICT *ficlGetEnv(void)
424{
425 return envp;
426}
427
428
429/**************************************************************************
430 f i c l S e t E n v
431** Create an environment variable with a one-CELL payload. ficlSetEnvD
432** makes one with a two-CELL payload.
433**************************************************************************/
434void ficlSetEnv(char *name, UNS32 value)
435{
436 STRINGINFO si;
437 FICL_WORD *pFW;
438
439 SI_PSZ(si, name);
440 pFW = dictLookup(envp, si);
441
442 if (pFW == NULL)
443 {
444 dictAppendWord(envp, name, constantParen, FW_DEFAULT);
445 dictAppendCell(envp, LVALUEtoCELL(value));
446 }
447 else
448 {
449 pFW->param[0] = LVALUEtoCELL(value);
450 }
451
452 return;
453}
454
455void ficlSetEnvD(char *name, UNS32 hi, UNS32 lo)
456{
457 FICL_WORD *pFW;
458 STRINGINFO si;
459 SI_PSZ(si, name);
460 pFW = dictLookup(envp, si);
461
462 if (pFW == NULL)
463 {
464 dictAppendWord(envp, name, twoConstParen, FW_DEFAULT);
465 dictAppendCell(envp, LVALUEtoCELL(lo));
466 dictAppendCell(envp, LVALUEtoCELL(hi));
467 }
468 else
469 {
470 pFW->param[0] = LVALUEtoCELL(lo);
471 pFW->param[1] = LVALUEtoCELL(hi);
472 }
473
474 return;
475}
476
477
478/**************************************************************************
479 f i c l G e t L o c
480** Returns the address of the system locals dictionary. This dict is
481** only used during compilation, and is shared by all VMs.
482**************************************************************************/
483#if FICL_WANT_LOCALS
484FICL_DICT *ficlGetLoc(void)
485{
486 return localp;
487}
488#endif
489
490
491/**************************************************************************
492 f i c l T e r m S y s t e m
493** Tear the system down by deleting the dictionaries and all VMs.
494** This saves you from having to keep track of all that stuff.
495**************************************************************************/
496void ficlTermSystem(void)
497{
498 if (dp)
499 dictDelete(dp);
500 dp = NULL;
501
502 if (envp)
503 dictDelete(envp);
504 envp = NULL;
505
506#if FICL_WANT_LOCALS
507 if (localp)
508 dictDelete(localp);
509 localp = NULL;
510#endif
511
512 while (vmList != NULL)
513 {
514 FICL_VM *pVM = vmList;
515 vmList = vmList->link;
516 vmDelete(pVM);
517 }
518
519 return;
520}