sys/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 **
   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: src/sys/boot/ficl/ficl.c,v 1.13.2.1 2000/07/06 23:51:45 obrien Exp $ */
  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
  35 int 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 */
  55 static FICL_DICT *dp     = NULL;
  56 static FICL_DICT *envp   = NULL;
  57 #if FICL_WANT_LOCALS
  58 static FICL_DICT *localp = NULL;
  59 #endif
  60 static FICL_VM   *vmList = NULL;
  61
  62 static int defaultStack = FICL_DEFAULT_STACK;
  63 static 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 **************************************************************************/
  77 void 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 **************************************************************************/
 118 FICL_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 F r e e V M
 136 ** Removes the VM in question from the system VM list and deletes the
 137 ** memory allocated to it. This is an optional call, since ficlTermSystem
 138 ** will do this cleanup for you. This function is handy if you're going to
 139 ** do a lot of dynamic creation of VMs.
 140 **************************************************************************/
 141 void ficlFreeVM(FICL_VM *pVM)
 142 {
 143         FICL_VM *pList = vmList;
 144
 145         assert(pVM != 0);
 146
 147         if (vmList == pVM)
 148         {
 149                 vmList = vmList->link;
 150         }
 151         else for (pList; pList != 0; pList = pList->link)
 152         {
 153                 if (pList->link == pVM)
 154                 {
 155                         pList->link = pVM->link;
 156                         break;
 157                 }
 158         }
 159
 160         if (pList)
 161                 vmDelete(pVM);
 162         return;
 163 }
 164
 165
 166 /**************************************************************************
 167                         f i c l B u i l d
 168 ** Builds a word into the dictionary.
 169 ** Preconditions: system must be initialized, and there must
 170 ** be enough space for the new word's header! Operation is
 171 ** controlled by ficlLockDictionary, so any initialization
 172 ** required by your version of the function (if you overrode
 173 ** it) must be complete at this point.
 174 ** Parameters:
 175 ** name  -- duh, the name of the word
 176 ** code  -- code to execute when the word is invoked - must take a single param
 177 **          pointer to a FICL_VM
 178 ** flags -- 0 or more of F_IMMEDIATE, F_COMPILE, use bitwise OR!
 179 **
 180 **************************************************************************/
 181 int ficlBuild(char *name, FICL_CODE code, char flags)
 182 {
 183         int err = ficlLockDictionary(TRUE);
 184         if (err) return err;
 185
 186         assert(dictCellsAvail(dp) > sizeof (FICL_WORD) / sizeof (CELL));
 187     dictAppendWord(dp, name, code, flags);
 188
 189         ficlLockDictionary(FALSE);
 190         return 0;
 191 }
 192
 193
 194 /**************************************************************************
 195                         f i c l E x e c
 196 ** Evaluates a block of input text in the context of the
 197 ** specified interpreter. Emits any requested output to the
 198 ** interpreter's output function.
 199 **
 200 ** Contains the "inner interpreter" code in a tight loop
 201 **
 202 ** Returns one of the VM_XXXX codes defined in ficl.h:
 203 ** VM_OUTOFTEXT is the normal exit condition
 204 ** VM_ERREXIT means that the interp encountered a syntax error
 205 **      and the vm has been reset to recover (some or all
 206 **      of the text block got ignored
 207 ** VM_USEREXIT means that the user executed the "bye" command
 208 **      to shut down the interpreter. This would be a good
 209 **      time to delete the vm, etc -- or you can ignore this
 210 **      signal.
 211 **************************************************************************/
 212 int ficlExec(FICL_VM *pVM, char *pText)
 213 {
 214     return ficlExecC(pVM, pText, -1);
 215 }
 216
 217 int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
 218 {
 219     static FICL_WORD *pInterp = NULL;
 220
 221     int        except;
 222     jmp_buf    vmState;
 223     jmp_buf   *oldState;
 224     TIB        saveTib;
 225
 226     if (!pInterp)
 227         pInterp = ficlLookup("interpret");
 228
 229     assert(pInterp);
 230     assert(pVM);
 231
 232     if (size < 0)
 233         size = strlen(pText);
 234
 235     vmPushTib(pVM, pText, size, &saveTib);
 236
 237     /*
 238     ** Save and restore VM's jmp_buf to enable nested calls to ficlExec
 239     */
 240     oldState = pVM->pState;
 241     pVM->pState = &vmState; /* This has to come before the setjmp! */
 242     except = setjmp(vmState);
 243
 244     switch (except)
 245     {
 246     case 0:
 247         if (pVM->fRestart)
 248         {
 249             pVM->fRestart = 0;
 250             pVM->runningWord->code(pVM);
 251         }
 252         else
 253         {   /* set VM up to interpret text */
 254             vmPushIP(pVM, &pInterp);
 255         }
 256
 257         vmInnerLoop(pVM);
 258         break;
 259
 260     case VM_RESTART:
 261         pVM->fRestart = 1;
 262         except = VM_OUTOFTEXT;
 263         break;
 264
 265     case VM_OUTOFTEXT:
 266         vmPopIP(pVM);
 267 #ifdef TESTMAIN
 268         if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0))
 269             ficlTextOut(pVM, FICL_PROMPT, 0);
 270 #endif
 271         break;
 272
 273     case VM_USEREXIT:
 274     case VM_INNEREXIT:
 275         break;
 276
 277     case VM_QUIT:
 278         if (pVM->state == COMPILE)
 279         {
 280             dictAbortDefinition(dp);
 281 #if FICL_WANT_LOCALS
 282             dictEmpty(localp, localp->pForthWords->size);
 283 #endif
 284         }
 285         vmQuit(pVM);
 286         break;
 287
 288     case VM_ERREXIT:
 289     case VM_ABORT:
 290     case VM_ABORTQ:
 291     default:    /* user defined exit code?? */
 292         if (pVM->state == COMPILE)
 293         {
 294             dictAbortDefinition(dp);
 295 #if FICL_WANT_LOCALS
 296             dictEmpty(localp, localp->pForthWords->size);
 297 #endif
 298         }
 299         dictResetSearchOrder(dp);
 300         vmReset(pVM);
 301         break;
 302    }
 303
 304     pVM->pState    = oldState;
 305     vmPopTib(pVM, &saveTib);
 306     return (except);
 307 }
 308
 309 /**************************************************************************
 310                         f i c l E x e c F D
 311 ** reads in text from file fd and passes it to ficlExec()
 312  * returns VM_OUTOFTEXT on success or the ficlExec() error code on
 313  * failure.
 314  */
 315 #define nLINEBUF 256
 316 int ficlExecFD(FICL_VM *pVM, int fd)
 317 {
 318     char    cp[nLINEBUF];
 319     int     nLine = 0, rval = VM_OUTOFTEXT;
 320     char    ch;
 321     CELL    id;
 322
 323     id = pVM->sourceID;
 324     pVM->sourceID.i = fd;
 325
 326     /* feed each line to ficlExec */
 327     while (1) {
 328         int status, i;
 329
 330         i = 0;
 331         while ((status = read(fd, &ch, 1)) > 0 && ch != '\n')
 332             cp[i++] = ch;
 333         nLine++;
 334         if (!i) {
 335             if (status < 1)
 336                 break;
 337             continue;
 338         }
 339         rval = ficlExecC(pVM, cp, i);
 340         if(rval != VM_QUIT && rval != VM_USEREXIT && rval != VM_OUTOFTEXT)
 341         {
 342             pVM->sourceID = id;
 343             return rval;
 344         }
 345     }
 346     /*
 347     ** Pass an empty line with SOURCE-ID == -1 to flush
 348     ** any pending REFILLs (as required by FILE wordset)
 349     */
 350     pVM->sourceID.i = -1;
 351     ficlExec(pVM, "");
 352
 353     pVM->sourceID = id;
 354     return rval;
 355 }
 356
 357 /**************************************************************************
 358                         f i c l E x e c X T
 359 ** Given a pointer to a FICL_WORD, push an inner interpreter and
 360 ** execute the word to completion. This is in contrast with vmExecute,
 361 ** which does not guarantee that the word will have completed when
 362 ** the function returns (ie in the case of colon definitions, which
 363 ** need an inner interpreter to finish)
 364 **
 365 ** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
 366 ** exit condition is VM_INNEREXIT, ficl's private signal to exit the
 367 ** inner loop under normal circumstances. If another code is thrown to
 368 ** exit the loop, this function will re-throw it if it's nested under
 369 ** itself or ficlExec.
 370 **
 371 ** NOTE: this function is intended so that C code can execute ficlWords
 372 ** given their address in the dictionary (xt).
 373 **************************************************************************/
 374 int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord)
 375 {
 376     static FICL_WORD *pQuit = NULL;
 377     int        except;
 378     jmp_buf    vmState;
 379     jmp_buf   *oldState;
 380
 381     if (!pQuit)
 382         pQuit = ficlLookup("exit-inner");
 383
 384     assert(pVM);
 385     assert(pQuit);
 386
 387     /*
 388     ** Save and restore VM's jmp_buf to enable nested calls
 389     */
 390     oldState = pVM->pState;
 391     pVM->pState = &vmState; /* This has to come before the setjmp! */
 392     except = setjmp(vmState);
 393
 394     if (except)
 395         vmPopIP(pVM);
 396     else
 397         vmPushIP(pVM, &pQuit);
 398
 399     switch (except)
 400     {
 401     case 0:
 402         vmExecute(pVM, pWord);
 403         vmInnerLoop(pVM);
 404         break;
 405
 406     case VM_INNEREXIT:
 407         break;
 408
 409     case VM_RESTART:
 410     case VM_OUTOFTEXT:
 411     case VM_USEREXIT:
 412     case VM_QUIT:
 413     case VM_ERREXIT:
 414     case VM_ABORT:
 415     case VM_ABORTQ:
 416     default:    /* user defined exit code?? */
 417         if (oldState)
 418         {
 419             pVM->pState = oldState;
 420             vmThrow(pVM, except);
 421         }
 422         break;
 423     }
 424
 425     pVM->pState    = oldState;
 426     return (except);
 427 }
 428
 429
 430 /**************************************************************************
 431                         f i c l L o o k u p
 432 ** Look in the system dictionary for a match to the given name. If
 433 ** found, return the address of the corresponding FICL_WORD. Otherwise
 434 ** return NULL.
 435 **************************************************************************/
 436 FICL_WORD *ficlLookup(char *name)
 437 {
 438     STRINGINFO si;
 439     SI_PSZ(si, name);
 440     return dictLookup(dp, si);
 441 }
 442
 443
 444 /**************************************************************************
 445                         f i c l G e t D i c t
 446 ** Returns the address of the system dictionary
 447 **************************************************************************/
 448 FICL_DICT *ficlGetDict(void)
 449 {
 450     return dp;
 451 }
 452
 453
 454 /**************************************************************************
 455                         f i c l G e t E n v
 456 ** Returns the address of the system environment space
 457 **************************************************************************/
 458 FICL_DICT *ficlGetEnv(void)
 459 {
 460     return envp;
 461 }
 462
 463
 464 /**************************************************************************
 465                         f i c l S e t E n v
 466 ** Create an environment variable with a one-CELL payload. ficlSetEnvD
 467 ** makes one with a two-CELL payload.
 468 **************************************************************************/
 469 void ficlSetEnv(char *name, FICL_UNS value)
 470 {
 471     STRINGINFO si;
 472     FICL_WORD *pFW;
 473
 474     SI_PSZ(si, name);
 475     pFW = dictLookup(envp, si);
 476
 477     if (pFW == NULL)
 478     {
 479         dictAppendWord(envp, name, constantParen, FW_DEFAULT);
 480         dictAppendCell(envp, LVALUEtoCELL(value));
 481     }
 482     else
 483     {
 484         pFW->param[0] = LVALUEtoCELL(value);
 485     }
 486
 487     return;
 488 }
 489
 490 void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo)
 491 {
 492     FICL_WORD *pFW;
 493     STRINGINFO si;
 494     SI_PSZ(si, name);
 495     pFW = dictLookup(envp, si);
 496
 497     if (pFW == NULL)
 498     {
 499         dictAppendWord(envp, name, twoConstParen, FW_DEFAULT);
 500         dictAppendCell(envp, LVALUEtoCELL(lo));
 501         dictAppendCell(envp, LVALUEtoCELL(hi));
 502     }
 503     else
 504     {
 505         pFW->param[0] = LVALUEtoCELL(lo);
 506         pFW->param[1] = LVALUEtoCELL(hi);
 507     }
 508
 509     return;
 510 }
 511
 512
 513 /**************************************************************************
 514                         f i c l G e t L o c
 515 ** Returns the address of the system locals dictionary. This dict is
 516 ** only used during compilation, and is shared by all VMs.
 517 **************************************************************************/
 518 #if FICL_WANT_LOCALS
 519 FICL_DICT *ficlGetLoc(void)
 520 {
 521     return localp;
 522 }
 523 #endif
 524
 525
 526
 527 /**************************************************************************
 528                         f i c l S e t S t a c k S i z e
 529 ** Set the stack sizes (return and parameter) to be used for all
 530 ** subsequently created VMs. Returns actual stack size to be used.
 531 **************************************************************************/
 532 int ficlSetStackSize(int nStackCells)
 533 {
 534     if (nStackCells >= FICL_DEFAULT_STACK)
 535         defaultStack = nStackCells;
 536     else
 537         defaultStack = FICL_DEFAULT_STACK;
 538
 539     return defaultStack;
 540 }
 541
 542
 543 /**************************************************************************
 544                         f i c l T e r m S y s t e m
 545 ** Tear the system down by deleting the dictionaries and all VMs.
 546 ** This saves you from having to keep track of all that stuff.
 547 **************************************************************************/
 548 void ficlTermSystem(void)
 549 {
 550     if (dp)
 551         dictDelete(dp);
 552     dp = NULL;
 553
 554     if (envp)
 555         dictDelete(envp);
 556     envp = NULL;
 557
 558 #if FICL_WANT_LOCALS
 559     if (localp)
 560         dictDelete(localp);
 561     localp = NULL;
 562 #endif
 563
 564     while (vmList != NULL)
 565     {
 566         FICL_VM *pVM = vmList;
 567         vmList = vmList->link;
 568         vmDelete(pVM);
 569     }
 570
 571     return;
 572 }
 573
 574