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