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