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: releng/11.0/sys/boot/ficl/ficl.c 94290 2002-04-09 17:45:28Z dcs $ */ 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*/ 80static int defaultStack = FICL_DEFAULT_STACK; 81 82 83static 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**************************************************************************/ 97FICL_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 179FICL_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**************************************************************************/ 194int 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*/ 216void 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*/ 228void 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**************************************************************************/ 254FICL_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**************************************************************************/ 274void 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**************************************************************************/ 315int 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**************************************************************************/ 334int 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**************************************************************************/ 363int ficlExec(FICL_VM *pVM, char *pText) 364{ 365 return ficlExecC(pVM, pText, -1); 366} 367 368int 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**************************************************************************/ 477int 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**************************************************************************/ 543FICL_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**************************************************************************/ 555FICL_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**************************************************************************/ 565FICL_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**************************************************************************/ 576void 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 598void 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 628FICL_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**************************************************************************/ 641int 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**************************************************************************/ 657void 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**************************************************************************/ 690static 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 697