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