initial commit
[freebsd-arm:freebsd-arm.git] / boot / ficl / ficl.c
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 ** $Id: ficl.c,v 1.16 2001/12/05 07:21:34 jsadler Exp $
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 in the 
19 ** style of TCL.
20 **
21 ** Code is written in ANSI C for portability. 
22 */
23 /*
24 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
25 ** All rights reserved.
26 **
27 ** Get the latest Ficl release at http://ficl.sourceforge.net
28 **
29 ** I am interested in hearing from anyone who uses ficl. If you have
30 ** a problem, a success story, a defect, an enhancement request, or
31 ** if you would like to contribute to the ficl release, please
32 ** contact me by email at the address above.
33 **
34 ** L I C E N S E  and  D I S C L A I M E R
35 ** 
36 ** Redistribution and use in source and binary forms, with or without
37 ** modification, are permitted provided that the following conditions
38 ** are met:
39 ** 1. Redistributions of source code must retain the above copyright
40 **    notice, this list of conditions and the following disclaimer.
41 ** 2. Redistributions in binary form must reproduce the above copyright
42 **    notice, this list of conditions and the following disclaimer in the
43 **    documentation and/or other materials provided with the distribution.
44 **
45 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
46 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
47 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
48 ** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
49 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
50 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
51 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
52 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
53 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
54 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
55 ** SUCH DAMAGE.
56 */
57
58 /* $FreeBSD$ */
59
60 #ifdef TESTMAIN
61 #include <stdlib.h>
62 #else
63 #include <stand.h>
64 #endif
65 #include <string.h>
66 #include "ficl.h"
67
68
69 /*
70 ** System statics
71 ** Each FICL_SYSTEM builds a global dictionary during its start
72 ** sequence. This is shared by all virtual machines of that system.
73 ** Therefore only one VM can update the dictionary
74 ** at a time. The system imports a locking function that
75 ** you can override in order to control update access to
76 ** the dictionary. The function is stubbed out by default,
77 ** but you can insert one: #define FICL_MULTITHREAD 1
78 ** and supply your own version of ficlLockDictionary.
79 */
80 static int defaultStack = FICL_DEFAULT_STACK;
81
82
83 static void ficlSetVersionEnv(FICL_SYSTEM *pSys);
84
85
86 /**************************************************************************
87                         f i c l I n i t S y s t e m
88 ** Binds a global dictionary to the interpreter system. 
89 ** You specify the address and size of the allocated area.
90 ** After that, ficl manages it.
91 ** First step is to set up the static pointers to the area.
92 ** Then write the "precompiled" portion of the dictionary in.
93 ** The dictionary needs to be at least large enough to hold the
94 ** precompiled part. Try 1K cells minimum. Use "words" to find
95 ** out how much of the dictionary is used at any time.
96 **************************************************************************/
97 FICL_SYSTEM *ficlInitSystemEx(FICL_SYSTEM_INFO *fsi)
98 {
99     int nDictCells;
100     int nEnvCells;
101     FICL_SYSTEM *pSys = ficlMalloc(sizeof (FICL_SYSTEM));
102
103     assert(pSys);
104     assert(fsi->size == sizeof (FICL_SYSTEM_INFO));
105
106     memset(pSys, 0, sizeof (FICL_SYSTEM));
107
108     nDictCells = fsi->nDictCells;
109     if (nDictCells <= 0)
110         nDictCells = FICL_DEFAULT_DICT;
111
112     nEnvCells = fsi->nEnvCells;
113     if (nEnvCells <= 0)
114         nEnvCells = FICL_DEFAULT_DICT;
115
116     pSys->dp = dictCreateHashed((unsigned)nDictCells, HASHSIZE);
117     pSys->dp->pForthWords->name = "forth-wordlist";
118
119     pSys->envp = dictCreate((unsigned)nEnvCells);
120     pSys->envp->pForthWords->name = "environment";
121
122     pSys->textOut = fsi->textOut;
123     pSys->pExtend = fsi->pExtend;
124
125 #if FICL_WANT_LOCALS
126     /*
127     ** The locals dictionary is only searched while compiling,
128     ** but this is where speed is most important. On the other
129     ** hand, the dictionary gets emptied after each use of locals
130     ** The need to balance search speed with the cost of the 'empty'
131     ** operation led me to select a single-threaded list...
132     */
133     pSys->localp = dictCreate((unsigned)FICL_MAX_LOCALS * CELLS_PER_WORD);
134 #endif
135
136     /*
137     ** Build the precompiled dictionary and load softwords. We need a temporary
138     ** VM to do this - ficlNewVM links one to the head of the system VM list.
139     ** ficlCompilePlatform (defined in win32.c, for example) adds platform specific words.
140     */
141     ficlCompileCore(pSys);
142     ficlCompilePrefix(pSys);
143 #if FICL_WANT_FLOAT
144     ficlCompileFloat(pSys);
145 #endif
146 #if FICL_PLATFORM_EXTEND
147     ficlCompilePlatform(pSys);
148 #endif
149     ficlSetVersionEnv(pSys);
150
151     /*
152     ** Establish the parse order. Note that prefixes precede numbers -
153     ** this allows constructs like "0b101010" which might parse as a
154     ** hex value otherwise.
155     */
156     ficlAddPrecompiledParseStep(pSys, "?prefix", ficlParsePrefix);
157     ficlAddPrecompiledParseStep(pSys, "?number", ficlParseNumber);
158 #if FICL_WANT_FLOAT
159     ficlAddPrecompiledParseStep(pSys, ">float", ficlParseFloatNumber);
160 #endif
161
162     /*
163     ** Now create a temporary VM to compile the softwords. Since all VMs are
164     ** linked into the vmList of FICL_SYSTEM, we don't have to pass the VM
165     ** to ficlCompileSoftCore -- it just hijacks whatever it finds in the VM list.
166     ** ficl 2.05: vmCreate no longer depends on the presence of INTERPRET in the
167     ** dictionary, so a VM can be created before the dictionary is built. It just
168     ** can't do much...
169     */
170     ficlNewVM(pSys);
171     ficlCompileSoftCore(pSys);
172     ficlFreeVM(pSys->vmList);
173
174
175     return pSys;
176 }
177
178
179 FICL_SYSTEM *ficlInitSystem(int nDictCells)
180 {
181     FICL_SYSTEM_INFO fsi;
182     ficlInitInfo(&fsi);
183     fsi.nDictCells = nDictCells;
184     return ficlInitSystemEx(&fsi);
185 }
186
187
188 /**************************************************************************
189                         f i c l A d d P a r s e S t e p
190 ** Appends a parse step function to the end of the parse list (see 
191 ** FICL_PARSE_STEP notes in ficl.h for details). Returns 0 if successful,
192 ** nonzero if there's no more room in the list.
193 **************************************************************************/
194 int ficlAddParseStep(FICL_SYSTEM *pSys, FICL_WORD *pFW)
195 {
196     int i;
197     for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
198     {
199         if (pSys->parseList[i] == NULL)
200         {
201             pSys->parseList[i] = pFW;
202             return 0;
203         }
204     }
205
206     return 1;
207 }
208
209
210 /*
211 ** Compile a word into the dictionary that invokes the specified FICL_PARSE_STEP
212 ** function. It is up to the user (as usual in Forth) to make sure the stack 
213 ** preconditions are valid (there needs to be a counted string on top of the stack)
214 ** before using the resulting word.
215 */
216 void ficlAddPrecompiledParseStep(FICL_SYSTEM *pSys, char *name, FICL_PARSE_STEP pStep)
217 {
218     FICL_DICT *dp = pSys->dp;
219     FICL_WORD *pFW = dictAppendWord(dp, name, parseStepParen, FW_DEFAULT);
220     dictAppendCell(dp, LVALUEtoCELL(pStep));
221     ficlAddParseStep(pSys, pFW);
222 }
223
224
225 /*
226 ** This word lists the parse steps in order
227 */
228 void ficlListParseSteps(FICL_VM *pVM)
229 {
230     int i;
231     FICL_SYSTEM *pSys = pVM->pSys;
232     assert(pSys);
233
234     vmTextOut(pVM, "Parse steps:", 1);
235     vmTextOut(pVM, "lookup", 1);
236
237     for (i = 0; i < FICL_MAX_PARSE_STEPS; i++)
238     {
239         if (pSys->parseList[i] != NULL)
240         {
241             vmTextOut(pVM, pSys->parseList[i]->name, 1);
242         }
243         else break;
244     }
245     return;
246 }
247
248
249 /**************************************************************************
250                         f i c l N e w V M
251 ** Create a new virtual machine and link it into the system list
252 ** of VMs for later cleanup by ficlTermSystem.
253 **************************************************************************/
254 FICL_VM *ficlNewVM(FICL_SYSTEM *pSys)
255 {
256     FICL_VM *pVM = vmCreate(NULL, defaultStack, defaultStack);
257     pVM->link = pSys->vmList;
258     pVM->pSys = pSys;
259     pVM->pExtend = pSys->pExtend;
260     vmSetTextOut(pVM, pSys->textOut);
261
262     pSys->vmList = pVM;
263     return pVM;
264 }
265
266
267 /**************************************************************************
268                         f i c l F r e e V M
269 ** Removes the VM in question from the system VM list and deletes the
270 ** memory allocated to it. This is an optional call, since ficlTermSystem
271 ** will do this cleanup for you. This function is handy if you're going to
272 ** do a lot of dynamic creation of VMs.
273 **************************************************************************/
274 void ficlFreeVM(FICL_VM *pVM)
275 {
276     FICL_SYSTEM *pSys = pVM->pSys;
277     FICL_VM *pList = pSys->vmList;
278
279     assert(pVM != 0);
280
281     if (pSys->vmList == pVM)
282     {
283         pSys->vmList = pSys->vmList->link;
284     }
285     else for (; pList != NULL; pList = pList->link)
286     {
287         if (pList->link == pVM)
288         {
289             pList->link = pVM->link;
290             break;
291         }
292     }
293
294     if (pList)
295         vmDelete(pVM);
296     return;
297 }
298
299
300 /**************************************************************************
301                         f i c l B u i l d
302 ** Builds a word into the dictionary.
303 ** Preconditions: system must be initialized, and there must
304 ** be enough space for the new word's header! Operation is
305 ** controlled by ficlLockDictionary, so any initialization
306 ** required by your version of the function (if you overrode
307 ** it) must be complete at this point.
308 ** Parameters:
309 ** name  -- duh, the name of the word
310 ** code  -- code to execute when the word is invoked - must take a single param
311 **          pointer to a FICL_VM
312 ** flags -- 0 or more of F_IMMEDIATE, F_COMPILE, use bitwise OR!
313 ** 
314 **************************************************************************/
315 int ficlBuild(FICL_SYSTEM *pSys, char *name, FICL_CODE code, char flags)
316 {
317 #if FICL_MULTITHREAD
318     int err = ficlLockDictionary(TRUE);
319     if (err) return err;
320 #endif /* FICL_MULTITHREAD */
321
322     assert(dictCellsAvail(pSys->dp) > sizeof (FICL_WORD) / sizeof (CELL));
323     dictAppendWord(pSys->dp, name, code, flags);
324
325     ficlLockDictionary(FALSE);
326     return 0;
327 }
328
329
330 /**************************************************************************
331                     f i c l E v a l u a t e
332 ** Wrapper for ficlExec() which sets SOURCE-ID to -1.
333 **************************************************************************/
334 int ficlEvaluate(FICL_VM *pVM, char *pText)
335 {
336     int returnValue;
337     CELL id = pVM->sourceID;
338     pVM->sourceID.i = -1;
339     returnValue = ficlExecC(pVM, pText, -1);
340     pVM->sourceID = id;
341     return returnValue;
342 }
343
344
345 /**************************************************************************
346                         f i c l E x e c
347 ** Evaluates a block of input text in the context of the
348 ** specified interpreter. Emits any requested output to the
349 ** interpreter's output function.
350 **
351 ** Contains the "inner interpreter" code in a tight loop
352 **
353 ** Returns one of the VM_XXXX codes defined in ficl.h:
354 ** VM_OUTOFTEXT is the normal exit condition
355 ** VM_ERREXIT means that the interp encountered a syntax error
356 **      and the vm has been reset to recover (some or all
357 **      of the text block got ignored
358 ** VM_USEREXIT means that the user executed the "bye" command
359 **      to shut down the interpreter. This would be a good
360 **      time to delete the vm, etc -- or you can ignore this
361 **      signal.
362 **************************************************************************/
363 int ficlExec(FICL_VM *pVM, char *pText)
364 {
365     return ficlExecC(pVM, pText, -1);
366 }
367
368 int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
369 {
370     FICL_SYSTEM *pSys = pVM->pSys;
371     FICL_DICT   *dp   = pSys->dp;
372
373     int        except;
374     jmp_buf    vmState;
375     jmp_buf   *oldState;
376     TIB        saveTib;
377
378     assert(pVM);
379     assert(pSys->pInterp[0]);
380
381     if (size < 0)
382         size = strlen(pText);
383
384     vmPushTib(pVM, pText, size, &saveTib);
385
386     /*
387     ** Save and restore VM's jmp_buf to enable nested calls to ficlExec 
388     */
389     oldState = pVM->pState;
390     pVM->pState = &vmState; /* This has to come before the setjmp! */
391     except = setjmp(vmState);
392
393     switch (except)
394     {
395     case 0:
396         if (pVM->fRestart)
397         {
398             pVM->runningWord->code(pVM);
399             pVM->fRestart = 0;
400         }
401         else
402         {   /* set VM up to interpret text */
403             vmPushIP(pVM, &(pSys->pInterp[0]));
404         }
405
406         vmInnerLoop(pVM);
407         break;
408
409     case VM_RESTART:
410         pVM->fRestart = 1;
411         except = VM_OUTOFTEXT;
412         break;
413
414     case VM_OUTOFTEXT:
415         vmPopIP(pVM);
416 #ifdef TESTMAIN
417         if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0))
418             ficlTextOut(pVM, FICL_PROMPT, 0);
419 #endif
420         break;
421
422     case VM_USEREXIT:
423     case VM_INNEREXIT:
424     case VM_BREAK:
425         break;
426
427     case VM_QUIT:
428         if (pVM->state == COMPILE)
429         {
430             dictAbortDefinition(dp);
431 #if FICL_WANT_LOCALS
432             dictEmpty(pSys->localp, pSys->localp->pForthWords->size);
433 #endif
434         }
435         vmQuit(pVM);
436         break;
437
438     case VM_ERREXIT:
439     case VM_ABORT:
440     case VM_ABORTQ:
441     default:    /* user defined exit code?? */
442         if (pVM->state == COMPILE)
443         {
444             dictAbortDefinition(dp);
445 #if FICL_WANT_LOCALS
446             dictEmpty(pSys->localp, pSys->localp->pForthWords->size);
447 #endif
448         }
449         dictResetSearchOrder(dp);
450         vmReset(pVM);
451         break;
452    }
453
454     pVM->pState    = oldState;
455     vmPopTib(pVM, &saveTib);
456     return (except);
457 }
458
459
460 /**************************************************************************
461                         f i c l E x e c X T
462 ** Given a pointer to a FICL_WORD, push an inner interpreter and
463 ** execute the word to completion. This is in contrast with vmExecute,
464 ** which does not guarantee that the word will have completed when
465 ** the function returns (ie in the case of colon definitions, which
466 ** need an inner interpreter to finish)
467 **
468 ** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
469 ** exit condition is VM_INNEREXIT, ficl's private signal to exit the
470 ** inner loop under normal circumstances. If another code is thrown to
471 ** exit the loop, this function will re-throw it if it's nested under
472 ** itself or ficlExec.
473 **
474 ** NOTE: this function is intended so that C code can execute ficlWords
475 ** given their address in the dictionary (xt).
476 **************************************************************************/
477 int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord)
478 {
479     int        except;
480     jmp_buf    vmState;
481     jmp_buf   *oldState;
482     FICL_WORD *oldRunningWord;
483
484     assert(pVM);
485     assert(pVM->pSys->pExitInner);
486     
487     /* 
488     ** Save the runningword so that RESTART behaves correctly
489     ** over nested calls.
490     */
491     oldRunningWord = pVM->runningWord;
492     /*
493     ** Save and restore VM's jmp_buf to enable nested calls
494     */
495     oldState = pVM->pState;
496     pVM->pState = &vmState; /* This has to come before the setjmp! */
497     except = setjmp(vmState);
498
499     if (except)
500         vmPopIP(pVM);
501     else
502         vmPushIP(pVM, &(pVM->pSys->pExitInner));
503
504     switch (except)
505     {
506     case 0:
507         vmExecute(pVM, pWord);
508         vmInnerLoop(pVM);
509         break;
510
511     case VM_INNEREXIT:
512     case VM_BREAK:
513         break;
514
515     case VM_RESTART:
516     case VM_OUTOFTEXT:
517     case VM_USEREXIT:
518     case VM_QUIT:
519     case VM_ERREXIT:
520     case VM_ABORT:
521     case VM_ABORTQ:
522     default:    /* user defined exit code?? */
523         if (oldState)
524         {
525             pVM->pState = oldState;
526             vmThrow(pVM, except);
527         }
528         break;
529     }
530
531     pVM->pState    = oldState;
532     pVM->runningWord = oldRunningWord;
533     return (except);
534 }
535
536
537 /**************************************************************************
538                         f i c l L o o k u p
539 ** Look in the system dictionary for a match to the given name. If
540 ** found, return the address of the corresponding FICL_WORD. Otherwise
541 ** return NULL.
542 **************************************************************************/
543 FICL_WORD *ficlLookup(FICL_SYSTEM *pSys, char *name)
544 {
545     STRINGINFO si;
546     SI_PSZ(si, name);
547     return dictLookup(pSys->dp, si);
548 }
549
550
551 /**************************************************************************
552                         f i c l G e t D i c t
553 ** Returns the address of the system dictionary
554 **************************************************************************/
555 FICL_DICT *ficlGetDict(FICL_SYSTEM *pSys)
556 {
557     return pSys->dp;
558 }
559
560
561 /**************************************************************************
562                         f i c l G e t E n v
563 ** Returns the address of the system environment space
564 **************************************************************************/
565 FICL_DICT *ficlGetEnv(FICL_SYSTEM *pSys)
566 {
567     return pSys->envp;
568 }
569
570
571 /**************************************************************************
572                         f i c l S e t E n v
573 ** Create an environment variable with a one-CELL payload. ficlSetEnvD
574 ** makes one with a two-CELL payload.
575 **************************************************************************/
576 void ficlSetEnv(FICL_SYSTEM *pSys, char *name, FICL_UNS value)
577 {
578     STRINGINFO si;
579     FICL_WORD *pFW;
580     FICL_DICT *envp = pSys->envp;
581
582     SI_PSZ(si, name);
583     pFW = dictLookup(envp, si);
584
585     if (pFW == NULL)
586     {
587         dictAppendWord(envp, name, constantParen, FW_DEFAULT);
588         dictAppendCell(envp, LVALUEtoCELL(value));
589     }
590     else
591     {
592         pFW->param[0] = LVALUEtoCELL(value);
593     }
594
595     return;
596 }
597
598 void ficlSetEnvD(FICL_SYSTEM *pSys, char *name, FICL_UNS hi, FICL_UNS lo)
599 {
600     FICL_WORD *pFW;
601     STRINGINFO si;
602     FICL_DICT *envp = pSys->envp;
603     SI_PSZ(si, name);
604     pFW = dictLookup(envp, si);
605
606     if (pFW == NULL)
607     {
608         dictAppendWord(envp, name, twoConstParen, FW_DEFAULT);
609         dictAppendCell(envp, LVALUEtoCELL(lo));
610         dictAppendCell(envp, LVALUEtoCELL(hi));
611     }
612     else
613     {
614         pFW->param[0] = LVALUEtoCELL(lo);
615         pFW->param[1] = LVALUEtoCELL(hi);
616     }
617
618     return;
619 }
620
621
622 /**************************************************************************
623                         f i c l G e t L o c
624 ** Returns the address of the system locals dictionary. This dict is
625 ** only used during compilation, and is shared by all VMs.
626 **************************************************************************/
627 #if FICL_WANT_LOCALS
628 FICL_DICT *ficlGetLoc(FICL_SYSTEM *pSys)
629 {
630     return pSys->localp;
631 }
632 #endif
633
634
635
636 /**************************************************************************
637                         f i c l S e t S t a c k S i z e
638 ** Set the stack sizes (return and parameter) to be used for all
639 ** subsequently created VMs. Returns actual stack size to be used.
640 **************************************************************************/
641 int ficlSetStackSize(int nStackCells)
642 {
643     if (nStackCells >= FICL_DEFAULT_STACK)
644         defaultStack = nStackCells;
645     else
646         defaultStack = FICL_DEFAULT_STACK;
647
648     return defaultStack;
649 }
650
651
652 /**************************************************************************
653                         f i c l T e r m S y s t e m
654 ** Tear the system down by deleting the dictionaries and all VMs.
655 ** This saves you from having to keep track of all that stuff.
656 **************************************************************************/
657 void ficlTermSystem(FICL_SYSTEM *pSys)
658 {
659     if (pSys->dp)
660         dictDelete(pSys->dp);
661     pSys->dp = NULL;
662
663     if (pSys->envp)
664         dictDelete(pSys->envp);
665     pSys->envp = NULL;
666
667 #if FICL_WANT_LOCALS
668     if (pSys->localp)
669         dictDelete(pSys->localp);
670     pSys->localp = NULL;
671 #endif
672
673     while (pSys->vmList != NULL)
674     {
675         FICL_VM *pVM = pSys->vmList;
676         pSys->vmList = pSys->vmList->link;
677         vmDelete(pVM);
678     }
679
680     ficlFree(pSys);
681     pSys = NULL;
682     return;
683 }
684
685
686 /**************************************************************************
687                         f i c l S e t V e r s i o n E n v
688 ** Create a double cell environment constant for the version ID
689 **************************************************************************/
690 static void ficlSetVersionEnv(FICL_SYSTEM *pSys)
691 {
692     ficlSetEnvD(pSys, "ficl-version", FICL_VER_MAJOR, FICL_VER_MINOR);
693     ficlSetEnv (pSys, "ficl-robust",  FICL_ROBUST);
694     return;
695 }
696