words.c revision 43599
149004Sgreen/******************************************************************* 249004Sgreen** w o r d s . c 349004Sgreen** Forth Inspired Command Language 449004Sgreen** ANS Forth CORE word-set written in C 549004Sgreen** Author: John Sadler (john_sadler@alum.mit.edu) 649004Sgreen** Created: 19 July 1997 749004Sgreen** 849004Sgreen*******************************************************************/ 949004Sgreen 1049004Sgreen#ifdef TESTMAIN 1149004Sgreen#include <stdlib.h> 1249004Sgreen#include <stdio.h> 1349004Sgreen#include <ctype.h> 1449004Sgreen#include <fcntl.h> 1549004Sgreen#else 1649004Sgreen#include <stand.h> 1749004Sgreen#endif 1849004Sgreen#include <string.h> 1949004Sgreen#include "ficl.h" 2049004Sgreen#include "math64.h" 2149004Sgreen 2249004Sgreenstatic void colonParen(FICL_VM *pVM); 2349004Sgreenstatic void literalIm(FICL_VM *pVM); 2449004Sgreenstatic void interpWord(FICL_VM *pVM, STRINGINFO si); 2549004Sgreen 2649004Sgreen/* 2798563Sjmallett** Control structure building words use these 2898563Sjmallett** strings' addresses as markers on the stack to 2998563Sjmallett** check for structure completion. 3049004Sgreen*/ 3149004Sgreenstatic char doTag[] = "do"; 3248981Ssheldonhstatic char ifTag[] = "if"; 3348981Ssheldonhstatic char colonTag[] = "colon"; 3448981Ssheldonhstatic char leaveTag[] = "leave"; 3548981Ssheldonhstatic char beginTag[] = "begin"; 3648981Ssheldonhstatic char whileTag[] = "while"; 3748981Ssheldonh 3849004Sgreen/* 3948981Ssheldonh** Pointers to various words in the dictionary 4048981Ssheldonh** -- initialized by ficlCompileCore, below -- 4148981Ssheldonh** for use by compiling words. Colon definitions 4248981Ssheldonh** in ficl are lists of pointers to words. A bit 4369144Sgreen** simple-minded... 4448981Ssheldonh*/ 4548981Ssheldonhstatic FICL_WORD *pBranchParen = NULL; 4648981Ssheldonhstatic FICL_WORD *pComma = NULL; 4749004Sgreenstatic FICL_WORD *pDoParen = NULL; 4848981Ssheldonhstatic FICL_WORD *pDoesParen = NULL; 4949030Ssheldonhstatic FICL_WORD *pExitParen = NULL; 5049030Ssheldonhstatic FICL_WORD *pIfParen = NULL; 5148981Ssheldonhstatic FICL_WORD *pInterpret = NULL; 5248981Ssheldonhstatic FICL_WORD *pLitParen = NULL; 5348981Ssheldonhstatic FICL_WORD *pLoopParen = NULL; 5448981Ssheldonhstatic FICL_WORD *pPLoopParen = NULL; 5598562Sjmallettstatic FICL_WORD *pQDoParen = NULL; 5698562Sjmallettstatic FICL_WORD *pSemiParen = NULL; 5798562Sjmallettstatic FICL_WORD *pStore = NULL; 5898562Sjmallettstatic FICL_WORD *pStringLit = NULL; 5998562Sjmallettstatic FICL_WORD *pType = NULL; 6098562Sjmallett 6198562Sjmallett#if FICL_WANT_LOCALS 6298562Sjmallettstatic FICL_WORD *pGetLocalParen= NULL; 63299356Sbaptstatic FICL_WORD *pGetLocal0 = NULL; 6498562Sjmallettstatic FICL_WORD *pGetLocal1 = NULL; 6598562Sjmallettstatic FICL_WORD *pToLocalParen = NULL; 6698562Sjmallettstatic FICL_WORD *pToLocal0 = NULL; 67157816Sdwmalonestatic FICL_WORD *pToLocal1 = NULL; 6898562Sjmallettstatic FICL_WORD *pLinkParen = NULL; 6998562Sjmallettstatic FICL_WORD *pUnLinkParen = NULL; 7048981Ssheldonhstatic int nLocals = 0; 7148981Ssheldonh#endif 7248981Ssheldonh 7348981Ssheldonh 7448981Ssheldonh/* 7548981Ssheldonh** C O N T R O L S T R U C T U R E B U I L D E R S 7648981Ssheldonh** 7748981Ssheldonh** Push current dict location for later branch resolution. 7848981Ssheldonh** The location may be either a branch target or a patch address... 7948981Ssheldonh*/ 8048981Ssheldonhstatic void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 8148981Ssheldonh{ 8248981Ssheldonh stackPushPtr(pVM->pStack, dp->here); 8348981Ssheldonh stackPushPtr(pVM->pStack, tag); 8477685Sdwmalone return; 8548981Ssheldonh} 8648981Ssheldonh 8748981Ssheldonhstatic void markControlTag(FICL_VM *pVM, char *tag) 8848981Ssheldonh{ 8948981Ssheldonh stackPushPtr(pVM->pStack, tag); 9048981Ssheldonh return; 9148981Ssheldonh} 9248981Ssheldonh 9348981Ssheldonhstatic void matchControlTag(FICL_VM *pVM, char *tag) 9448981Ssheldonh{ 9548981Ssheldonh char *cp = (char *)stackPopPtr(pVM->pStack); 9678694Sdwmalone if ( strcmp(cp, tag) ) 9748981Ssheldonh { 9848981Ssheldonh vmTextOut(pVM, "Warning -- unmatched control word: ", 0); 9948981Ssheldonh vmTextOut(pVM, tag, 1); 10078694Sdwmalone } 10148981Ssheldonh 10248981Ssheldonh return; 10349052Ssheldonh} 10449052Ssheldonh 10549052Ssheldonh/* 10649052Ssheldonh** Expect a branch target address on the param stack, 10749052Ssheldonh** compile a literal offset from the current dict location 10848981Ssheldonh** to the target address 10998558Sjmallett*/ 11048981Ssheldonhstatic void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 11148981Ssheldonh{ 11248981Ssheldonh long offset; 11348981Ssheldonh CELL *patchAddr; 11448981Ssheldonh 11548981Ssheldonh matchControlTag(pVM, tag); 11648981Ssheldonh 11748981Ssheldonh patchAddr = (CELL *)stackPopPtr(pVM->pStack); 11848981Ssheldonh offset = patchAddr - dp->here; 11948981Ssheldonh dictAppendCell(dp, LVALUEtoCELL(offset)); 120157820Sdwmalone 121157820Sdwmalone return; 122157820Sdwmalone} 123157820Sdwmalone 12448981Ssheldonh 12548981Ssheldonh/* 12698559Sjmallett** Expect a branch patch address on the param stack, 12748981Ssheldonh** compile a literal offset from the patch location 12856590Sshin** to the current dict location 12948981Ssheldonh*/ 13057857Sshinstatic void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 13157857Sshin{ 13248981Ssheldonh long offset; 13348981Ssheldonh CELL *patchAddr; 13448981Ssheldonh 13548981Ssheldonh matchControlTag(pVM, tag); 13648981Ssheldonh 13748981Ssheldonh patchAddr = (CELL *)stackPopPtr(pVM->pStack); 13848981Ssheldonh offset = dp->here - patchAddr; 13956590Sshin *patchAddr = LVALUEtoCELL(offset); 14048981Ssheldonh 14156590Sshin return; 14248981Ssheldonh} 14348981Ssheldonh 14456590Sshin/* 14548981Ssheldonh** Match the tag to the top of the stack. If success, 14648981Ssheldonh** sopy "here" address into the cell whose address is next 14748981Ssheldonh** on the stack. Used by do..leave..loop. 14848981Ssheldonh*/ 14948981Ssheldonhstatic void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 15048981Ssheldonh{ 15148981Ssheldonh CELL *patchAddr; 15248981Ssheldonh char *cp; 15348981Ssheldonh 15448981Ssheldonh cp = stackPopPtr(pVM->pStack); 15548981Ssheldonh if (strcmp(cp, tag)) 15648981Ssheldonh { 15757857Sshin vmTextOut(pVM, "Warning -- Unmatched control word: ", 0); 15848981Ssheldonh vmTextOut(pVM, tag, 1); 15948981Ssheldonh } 16098559Sjmallett 16148981Ssheldonh patchAddr = (CELL *)stackPopPtr(pVM->pStack); 16248981Ssheldonh *patchAddr = LVALUEtoCELL(dp->here); 16398559Sjmallett 16448981Ssheldonh return; 16548981Ssheldonh} 16648981Ssheldonh 16748981Ssheldonh 16848981Ssheldonh/************************************************************************** 16948981Ssheldonh i s N u m b e r 17048981Ssheldonh** Attempts to convert the NULL terminated string in the VM's pad to 17148981Ssheldonh** a number using the VM's current base. If successful, pushes the number 17248981Ssheldonh** onto the param stack and returns TRUE. Otherwise, returns FALSE. 17348981Ssheldonh**************************************************************************/ 17448981Ssheldonh 17548981Ssheldonhstatic int isNumber(FICL_VM *pVM, STRINGINFO si) 17648981Ssheldonh{ 17748981Ssheldonh INT32 accum = 0; 17848981Ssheldonh char isNeg = FALSE; 17948981Ssheldonh unsigned base = pVM->base; 18048981Ssheldonh char *cp = SI_PTR(si); 18148981Ssheldonh FICL_COUNT count= (FICL_COUNT)SI_COUNT(si); 18248981Ssheldonh unsigned ch; 18348981Ssheldonh unsigned digit; 18448981Ssheldonh 18548981Ssheldonh if (*cp == '-') 18648981Ssheldonh { 18748981Ssheldonh cp++; 18848981Ssheldonh count--; 18948981Ssheldonh isNeg = TRUE; 19048981Ssheldonh } 19148981Ssheldonh else if ((cp[0] == '0') && (cp[1] == 'x')) 19249052Ssheldonh { /* detect 0xNNNN format for hex numbers */ 19349052Ssheldonh cp += 2; 19449052Ssheldonh count -= 2; 19549052Ssheldonh base = 16; 19649052Ssheldonh } 19798559Sjmallett 19848981Ssheldonh if (count == 0) 19948981Ssheldonh return FALSE; 20098559Sjmallett 20148981Ssheldonh while (count-- && ((ch = *cp++) != '\0')) 20248981Ssheldonh { 20378694Sdwmalone if (ch < '0') 20456590Sshin return FALSE; 20557857Sshin 20648981Ssheldonh digit = ch - '0'; 20778694Sdwmalone 20848981Ssheldonh if (digit > 9) 20956590Sshin digit = tolower(ch) - 'a' + 10; 21048981Ssheldonh /* 21156590Sshin ** Note: following test also catches chars between 9 and a 21248981Ssheldonh ** because 'digit' is unsigned! 21348981Ssheldonh */ 21456590Sshin if (digit >= base) 21548981Ssheldonh return FALSE; 21648981Ssheldonh 21778694Sdwmalone accum = accum * base + digit; 21848981Ssheldonh } 21957857Sshin 22048981Ssheldonh if (isNeg) 22148981Ssheldonh accum = -accum; 22298559Sjmallett 22348981Ssheldonh stackPushINT32(pVM->pStack, accum); 22448981Ssheldonh 22598559Sjmallett return TRUE; 22648981Ssheldonh} 22748981Ssheldonh 22878694Sdwmalone 22948981Ssheldonh/************************************************************************** 23078694Sdwmalone a d d & f r i e n d s 23148981Ssheldonh** 23278694Sdwmalone**************************************************************************/ 23358735Ssheldonh 23448981Ssheldonhstatic void add(FICL_VM *pVM) 23548981Ssheldonh{ 23649052Ssheldonh INT32 i; 23749052Ssheldonh#if FICL_ROBUST > 1 23849052Ssheldonh vmCheckStack(pVM, 2, 1); 23949052Ssheldonh#endif 24049052Ssheldonh i = stackPopINT32(pVM->pStack); 24198559Sjmallett i += stackGetTop(pVM->pStack).i; 24248981Ssheldonh stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 24348981Ssheldonh return; 24498561Sjmallett} 24548981Ssheldonh 24648981Ssheldonhstatic void sub(FICL_VM *pVM) 24748981Ssheldonh{ 24848981Ssheldonh INT32 i; 24948981Ssheldonh#if FICL_ROBUST > 1 25048981Ssheldonh vmCheckStack(pVM, 2, 1); 25198559Sjmallett#endif 25248981Ssheldonh i = stackPopINT32(pVM->pStack); 25348981Ssheldonh i = stackGetTop(pVM->pStack).i - i; 25498559Sjmallett stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 25548981Ssheldonh return; 25648981Ssheldonh} 25748981Ssheldonh 25848981Ssheldonhstatic void mul(FICL_VM *pVM) 25948981Ssheldonh{ 26048981Ssheldonh INT32 i; 26148981Ssheldonh#if FICL_ROBUST > 1 26248981Ssheldonh vmCheckStack(pVM, 2, 1); 26348981Ssheldonh#endif 26448981Ssheldonh i = stackPopINT32(pVM->pStack); 26548981Ssheldonh i *= stackGetTop(pVM->pStack).i; 26648981Ssheldonh stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 26748981Ssheldonh return; 26848981Ssheldonh} 26949052Ssheldonh 27049052Ssheldonhstatic void negate(FICL_VM *pVM) 27149052Ssheldonh{ 27249052Ssheldonh INT32 i; 27349052Ssheldonh#if FICL_ROBUST > 1 27498559Sjmallett vmCheckStack(pVM, 1, 1); 27548981Ssheldonh#endif 27648981Ssheldonh i = -stackPopINT32(pVM->pStack); 27798559Sjmallett stackPushINT32(pVM->pStack, i); 27848981Ssheldonh return; 27977231Sdwmalone} 28057857Sshin 28157857Sshinstatic void ficlDiv(FICL_VM *pVM) 28256590Sshin{ 28348981Ssheldonh INT32 i; 28456590Sshin#if FICL_ROBUST > 1 28548981Ssheldonh vmCheckStack(pVM, 2, 1); 28656590Sshin#endif 28748981Ssheldonh i = stackPopINT32(pVM->pStack); 28848981Ssheldonh i = stackGetTop(pVM->pStack).i / i; 28956590Sshin stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 29048981Ssheldonh return; 29148981Ssheldonh} 29257857Sshin 29348981Ssheldonh/* 29448981Ssheldonh** slash-mod CORE ( n1 n2 -- n3 n4 ) 29598559Sjmallett** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell 29648981Ssheldonh** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 29748981Ssheldonh** differ in sign, the implementation-defined result returned will be the 29898559Sjmallett** same as that returned by either the phrase 29948981Ssheldonh** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM . 30048981Ssheldonh** NOTE: Ficl complies with the second phrase (symmetric division) 30148981Ssheldonh*/ 30248981Ssheldonhstatic void slashMod(FICL_VM *pVM) 30348981Ssheldonh{ 30448981Ssheldonh INT64 n1; 30548981Ssheldonh INT32 n2; 30648981Ssheldonh INTQR qr; 30748981Ssheldonh 30848981Ssheldonh#if FICL_ROBUST > 1 30948981Ssheldonh vmCheckStack(pVM, 2, 2); 31049052Ssheldonh#endif 31149052Ssheldonh n2 = stackPopINT32(pVM->pStack); 31249052Ssheldonh n1.lo = stackPopINT32(pVM->pStack); 31349057Sgreen i64Extend(n1); 31449057Sgreen 31549052Ssheldonh qr = m64SymmetricDivI(n1, n2); 31649052Ssheldonh stackPushINT32(pVM->pStack, qr.rem); 31777684Sdwmalone stackPushINT32(pVM->pStack, qr.quot); 31877684Sdwmalone return; 31977684Sdwmalone} 32077684Sdwmalone 32177684Sdwmalonestatic void onePlus(FICL_VM *pVM) 32277684Sdwmalone{ 32398559Sjmallett INT32 i; 32448981Ssheldonh#if FICL_ROBUST > 1 32548981Ssheldonh vmCheckStack(pVM, 1, 1); 32698559Sjmallett#endif 32748981Ssheldonh i = stackGetTop(pVM->pStack).i; 32849004Sgreen i += 1; 32949004Sgreen stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 33077684Sdwmalone return; 33149030Ssheldonh} 33249057Sgreen 33349030Ssheldonhstatic void oneMinus(FICL_VM *pVM) 33449030Ssheldonh{ 33558735Ssheldonh INT32 i; 33649004Sgreen#if FICL_ROBUST > 1 33748981Ssheldonh vmCheckStack(pVM, 1, 1); 33848981Ssheldonh#endif 33948981Ssheldonh i = stackGetTop(pVM->pStack).i; 34048981Ssheldonh i -= 1; 34198559Sjmallett stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 34248981Ssheldonh return; 34348981Ssheldonh} 34498559Sjmallett 34548981Ssheldonhstatic void twoMul(FICL_VM *pVM) 34649089Sgreen{ 34749089Sgreen INT32 i; 34878694Sdwmalone#if FICL_ROBUST > 1 34957906Sshin vmCheckStack(pVM, 1, 1); 35056590Sshin#endif 35157906Sshin i = stackGetTop(pVM->pStack).i; 35256590Sshin i *= 2; 35372650Sgreen stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 35449004Sgreen return; 35549004Sgreen} 35649004Sgreen 35763045Sdwmalonestatic void twoDiv(FICL_VM *pVM) 35856298Sgreen{ 35949004Sgreen INT32 i; 36077684Sdwmalone#if FICL_ROBUST > 1 36177684Sdwmalone vmCheckStack(pVM, 1, 1); 36261099Sgreen#endif 36361099Sgreen i = stackGetTop(pVM->pStack).i; 36463045Sdwmalone i >>= 1; 36577684Sdwmalone stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 36677684Sdwmalone return; 36748981Ssheldonh} 36848981Ssheldonh 36948981Ssheldonhstatic void mulDiv(FICL_VM *pVM) 37049104Sgreen{ 37149104Sgreen INT32 x, y, z; 37249104Sgreen INT64 prod; 37349104Sgreen#if FICL_ROBUST > 1 37448981Ssheldonh vmCheckStack(pVM, 3, 1); 37548981Ssheldonh#endif 37649104Sgreen z = stackPopINT32(pVM->pStack); 37749104Sgreen y = stackPopINT32(pVM->pStack); 37849104Sgreen x = stackPopINT32(pVM->pStack); 37949104Sgreen 38049104Sgreen prod = m64MulI(x,y); 38148981Ssheldonh x = m64SymmetricDivI(prod, z).quot; 38248981Ssheldonh 38348981Ssheldonh stackPushINT32(pVM->pStack, x); 38449054Sgreen return; 38556298Sgreen} 38678694Sdwmalone 38749054Sgreen 38877684Sdwmalonestatic void mulDivRem(FICL_VM *pVM) 38948981Ssheldonh{ 39056298Sgreen INT32 x, y, z; 39177684Sdwmalone INT64 prod; 39277684Sdwmalone INTQR qr; 39356298Sgreen#if FICL_ROBUST > 1 39448981Ssheldonh vmCheckStack(pVM, 3, 2); 39548981Ssheldonh#endif 39648981Ssheldonh z = stackPopINT32(pVM->pStack); 39769620Sdwmalone y = stackPopINT32(pVM->pStack); 39869620Sdwmalone x = stackPopINT32(pVM->pStack); 39969620Sdwmalone 40069620Sdwmalone prod = m64MulI(x,y); 40156298Sgreen qr = m64SymmetricDivI(prod, z); 40256298Sgreen 40378694Sdwmalone stackPushINT32(pVM->pStack, qr.rem); 40456303Sgreen stackPushINT32(pVM->pStack, qr.quot); 40578694Sdwmalone return; 40656303Sgreen} 40756303Sgreen 40856303Sgreen 40956303Sgreen/************************************************************************** 410100498Sfanf b y e 41177684Sdwmalone** TOOLS 41256303Sgreen** Signal the system to shut down - this causes ficlExec to return 41377684Sdwmalone** VM_USEREXIT. The rest is up to you. 41477684Sdwmalone**************************************************************************/ 41556303Sgreen 41656303Sgreenstatic void bye(FICL_VM *pVM) 41777684Sdwmalone{ 41878694Sdwmalone vmThrow(pVM, VM_USEREXIT); 41978694Sdwmalone return; 42078694Sdwmalone} 42156298Sgreen 42277684Sdwmalone 42356298Sgreen/************************************************************************** 42477684Sdwmalone c o l o n d e f i n i t i o n s 42577684Sdwmalone** Code to begin compiling a colon definition 42677684Sdwmalone** This function sets the state to COMPILE, then creates a 42749057Sgreen** new word whose name is the next word in the input stream 42849057Sgreen** and whose code is colonParen. 42948981Ssheldonh**************************************************************************/ 43049004Sgreen 43149004Sgreenstatic void colon(FICL_VM *pVM) 43249004Sgreen{ 43349057Sgreen FICL_DICT *dp = ficlGetDict(); 43449057Sgreen STRINGINFO si = vmGetWord(pVM); 43549057Sgreen 43649051Ssheldonh pVM->state = COMPILE; 43749030Ssheldonh markControlTag(pVM, colonTag); 43849030Ssheldonh dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 43949030Ssheldonh#if FICL_WANT_LOCALS 44077684Sdwmalone nLocals = 0; 44149030Ssheldonh#endif 44249030Ssheldonh return; 44349030Ssheldonh} 44449030Ssheldonh 44549030Ssheldonh 44649030Ssheldonh/************************************************************************** 44749030Ssheldonh c o l o n P a r e n 44849030Ssheldonh** This is the code that executes a colon definition. It assumes that the 44949054Sgreen** virtual machine is running a "next" loop (See the vm.c 45048981Ssheldonh** for its implementation of member function vmExecute()). The colon 45148981Ssheldonh** code simply copies the address of the first word in the list of words 45248981Ssheldonh** to interpret into IP after saving its old value. When we return to the 45348981Ssheldonh** "next" loop, the virtual machine will call the code for each word in 45449004Sgreen** turn. 45549033Sgreen** 45677684Sdwmalone**************************************************************************/ 45749004Sgreen 45849004Sgreenstatic void colonParen(FICL_VM *pVM) 45977684Sdwmalone{ 46049104Sgreen IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param); 46149104Sgreen vmPushIP(pVM, tempIP); 46249104Sgreen 46349104Sgreen return; 46449104Sgreen} 46549104Sgreen 46663045Sdwmalone 46763045Sdwmalone/************************************************************************** 46869532Sgreen s e m i c o l o n C o I m 46969532Sgreen** 47063045Sdwmalone** IMMEDIATE code for ";". This function sets the state to INTERPRET and 47163045Sdwmalone** terminates a word under compilation by appending code for "(;)" to 47263045Sdwmalone** the definition. TO DO: checks for leftover branch target tags on the 47363045Sdwmalone** return stack and complains if any are found. 47463045Sdwmalone**************************************************************************/ 47563045Sdwmalonestatic void semiParen(FICL_VM *pVM) 47649004Sgreen{ 47774934Sdwmalone vmPopIP(pVM); 47863045Sdwmalone return; 47963045Sdwmalone} 48063045Sdwmalone 48163045Sdwmalone 48263045Sdwmalonestatic void semicolonCoIm(FICL_VM *pVM) 48363045Sdwmalone{ 48463045Sdwmalone FICL_DICT *dp = ficlGetDict(); 48563045Sdwmalone 48663045Sdwmalone assert(pSemiParen); 48763045Sdwmalone matchControlTag(pVM, colonTag); 48863045Sdwmalone 48977684Sdwmalone#if FICL_WANT_LOCALS 49063045Sdwmalone assert(pUnLinkParen); 49177684Sdwmalone if (nLocals > 0) 49278694Sdwmalone { 49363045Sdwmalone FICL_DICT *pLoc = ficlGetLoc(); 49463045Sdwmalone dictEmpty(pLoc, pLoc->pForthWords->size); 49563045Sdwmalone dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 49677684Sdwmalone } 49766543Sdwmalone nLocals = 0; 49866543Sdwmalone#endif 49963045Sdwmalone 50063045Sdwmalone dictAppendCell(dp, LVALUEtoCELL(pSemiParen)); 50174934Sdwmalone pVM->state = INTERPRET; 50274934Sdwmalone dictUnsmudge(dp); 50363045Sdwmalone return; 50463045Sdwmalone} 50563045Sdwmalone 50663045Sdwmalone 50777684Sdwmalone/************************************************************************** 50877684Sdwmalone e x i t 50977684Sdwmalone** CORE 51077684Sdwmalone** This function simply pops the previous instruction 51156298Sgreen** pointer and returns to the "next" loop. Used for exiting from within 51277684Sdwmalone** a definition. Note that exitParen is identical to semiParen - they 51349104Sgreen** are in two different functions so that "see" can correctly identify 51458712Sgreen** the end of a colon definition, even if it uses "exit". 51558712Sgreen**************************************************************************/ 51658712Sgreenstatic void exitParen(FICL_VM *pVM) 51758712Sgreen{ 51858712Sgreen vmPopIP(pVM); 51977684Sdwmalone return; 52077684Sdwmalone} 52177684Sdwmalone 52258712Sgreenstatic void exitCoIm(FICL_VM *pVM) 52377684Sdwmalone{ 52458712Sgreen FICL_DICT *dp = ficlGetDict(); 52549104Sgreen assert(pExitParen); 52649104Sgreen IGNORE(pVM); 52749104Sgreen 52849104Sgreen#if FICL_WANT_LOCALS 52977684Sdwmalone if (nLocals > 0) 53049104Sgreen { 53177684Sdwmalone dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 53277684Sdwmalone } 53377684Sdwmalone#endif 53477684Sdwmalone dictAppendCell(dp, LVALUEtoCELL(pExitParen)); 53577684Sdwmalone return; 53677684Sdwmalone} 53756590Sshin 53877684Sdwmalone 53961099Sgreen/************************************************************************** 54056590Sshin c o n s t a n t P a r e n 54156590Sshin** This is the run-time code for "constant". It simply returns the 54278694Sdwmalone** contents of its word's first data cell. 54378694Sdwmalone** 54478694Sdwmalone**************************************************************************/ 54578694Sdwmalone 54678694Sdwmalonevoid constantParen(FICL_VM *pVM) 54778694Sdwmalone{ 54869532Sgreen FICL_WORD *pFW = pVM->runningWord; 54956590Sshin#if FICL_ROBUST > 1 55056590Sshin vmCheckStack(pVM, 0, 1); 55156590Sshin#endif 55256590Sshin stackPush(pVM->pStack, pFW->param[0]); 55356590Sshin return; 55456590Sshin} 55556590Sshin 55661099Sgreenvoid twoConstParen(FICL_VM *pVM) 55756590Sshin{ 55869532Sgreen FICL_WORD *pFW = pVM->runningWord; 55956590Sshin#if FICL_ROBUST > 1 56056590Sshin vmCheckStack(pVM, 0, 2); 56156590Sshin#endif 56269532Sgreen stackPush(pVM->pStack, pFW->param[0]); /* lo */ 56356590Sshin stackPush(pVM->pStack, pFW->param[1]); /* hi */ 56456590Sshin return; 56591354Sdd} 56677684Sdwmalone 56777684Sdwmalone 56877684Sdwmalone/************************************************************************** 56977684Sdwmalone c o n s t a n t 57056298Sgreen** IMMEDIATE 57177684Sdwmalone** Compiles a constant into the dictionary. Constants return their 57277684Sdwmalone** value when invoked. Expects a value on top of the parm stack. 57377684Sdwmalone**************************************************************************/ 57477684Sdwmalone 57577684Sdwmalonestatic void constant(FICL_VM *pVM) 57677684Sdwmalone{ 57777684Sdwmalone FICL_DICT *dp = ficlGetDict(); 57877684Sdwmalone STRINGINFO si = vmGetWord(pVM); 57977684Sdwmalone 58077684Sdwmalone#if FICL_ROBUST > 1 58177684Sdwmalone vmCheckStack(pVM, 1, 0); 58277684Sdwmalone#endif 58349104Sgreen dictAppendWord2(dp, si, constantParen, FW_DEFAULT); 58449104Sgreen dictAppendCell(dp, stackPop(pVM->pStack)); 58549104Sgreen return; 58649104Sgreen} 58777684Sdwmalone 58849089Sgreen 58977684Sdwmalonestatic void twoConstant(FICL_VM *pVM) 59049089Sgreen{ 59149089Sgreen FICL_DICT *dp = ficlGetDict(); 59277684Sdwmalone STRINGINFO si = vmGetWord(pVM); 59349057Sgreen CELL c; 59449089Sgreen 59549057Sgreen#if FICL_ROBUST > 1 59677684Sdwmalone vmCheckStack(pVM, 2, 0); 59749104Sgreen#endif 59849104Sgreen c = stackPop(pVM->pStack); 59949104Sgreen dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT); 60049104Sgreen dictAppendCell(dp, stackPop(pVM->pStack)); 60149104Sgreen dictAppendCell(dp, c); 60277684Sdwmalone return; 60369144Sgreen} 60449033Sgreen 60549104Sgreen 60649104Sgreen/************************************************************************** 60749104Sgreen d i s p l a y C e l l 60849104Sgreen** Drop and print the contents of the cell at the top of the param 60949104Sgreen** stack 61069144Sgreen**************************************************************************/ 61177684Sdwmalone 61277684Sdwmalonestatic void displayCell(FICL_VM *pVM) 61377684Sdwmalone{ 61449104Sgreen CELL c; 61569532Sgreen#if FICL_ROBUST > 1 61669532Sgreen vmCheckStack(pVM, 1, 0); 61749104Sgreen#endif 61849104Sgreen c = stackPop(pVM->pStack); 61949104Sgreen ltoa((c).i, pVM->pad, pVM->base); 62049104Sgreen strcat(pVM->pad, " "); 62177684Sdwmalone vmTextOut(pVM, pVM->pad, 0); 62277684Sdwmalone return; 62369144Sgreen} 62449089Sgreen 62577684Sdwmalonestatic void displayCellNoPad(FICL_VM *pVM) 62677684Sdwmalone{ 62777684Sdwmalone CELL c; 62877684Sdwmalone#if FICL_ROBUST > 1 62977684Sdwmalone vmCheckStack(pVM, 1, 0); 63077684Sdwmalone#endif 63177684Sdwmalone c = stackPop(pVM->pStack); 63277684Sdwmalone ltoa((c).i, pVM->pad, pVM->base); 63377684Sdwmalone vmTextOut(pVM, pVM->pad, 0); 63477684Sdwmalone return; 63577684Sdwmalone} 63677684Sdwmalone 63777684Sdwmalonestatic void uDot(FICL_VM *pVM) 63877684Sdwmalone{ 63977684Sdwmalone UNS32 u; 64077684Sdwmalone#if FICL_ROBUST > 1 64177684Sdwmalone vmCheckStack(pVM, 1, 0); 64277684Sdwmalone#endif 64377684Sdwmalone u = stackPopUNS32(pVM->pStack); 64477684Sdwmalone ultoa(u, pVM->pad, pVM->base); 64577684Sdwmalone strcat(pVM->pad, " "); 64677684Sdwmalone vmTextOut(pVM, pVM->pad, 0); 64777684Sdwmalone return; 64877684Sdwmalone} 64977684Sdwmalone 65077684Sdwmalone 65177684Sdwmalonestatic void hexDot(FICL_VM *pVM) 65277684Sdwmalone{ 65377684Sdwmalone UNS32 u; 65477684Sdwmalone#if FICL_ROBUST > 1 65577684Sdwmalone vmCheckStack(pVM, 1, 0); 65677684Sdwmalone#endif 65777684Sdwmalone u = stackPopUNS32(pVM->pStack); 65877684Sdwmalone ultoa(u, pVM->pad, 16); 65948981Ssheldonh strcat(pVM->pad, " "); 66077684Sdwmalone vmTextOut(pVM, pVM->pad, 0); 66177684Sdwmalone return; 66277684Sdwmalone} 66377684Sdwmalone 66477684Sdwmalone 66577684Sdwmalone/************************************************************************** 66669144Sgreen d i s p l a y S t a c k 66777684Sdwmalone** Display the parameter stack (code for ".s") 66877684Sdwmalone**************************************************************************/ 66948981Ssheldonh 67049104Sgreenstatic void displayStack(FICL_VM *pVM) 67149004Sgreen{ 67277684Sdwmalone int d = stackDepth(pVM->pStack); 67349057Sgreen int i; 67449051Ssheldonh CELL *pCell; 67549051Ssheldonh 67658735Ssheldonh vmCheckStack(pVM, 0, 0); 67749004Sgreen 67848981Ssheldonh if (d == 0) 67948981Ssheldonh vmTextOut(pVM, "(Stack Empty)", 1); 68048981Ssheldonh else 68148981Ssheldonh { 68248981Ssheldonh pCell = pVM->pStack->sp; 683157820Sdwmalone for (i = 0; i < d; i++) 68448981Ssheldonh { 68548981Ssheldonh vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1); 68648981Ssheldonh } 68748981Ssheldonh } 68848981Ssheldonh} 68948981Ssheldonh 69048981Ssheldonh 691157816Sdwmalone/************************************************************************** 69298558Sjmallett d u p & f r i e n d s 69348981Ssheldonh** 69448981Ssheldonh**************************************************************************/ 695157816Sdwmalone 696239991Sedstatic void depth(FICL_VM *pVM) 69748981Ssheldonh{ 69848981Ssheldonh int i; 69948981Ssheldonh#if FICL_ROBUST > 1 70048981Ssheldonh vmCheckStack(pVM, 0, 1); 70148981Ssheldonh#endif 70298558Sjmallett i = stackDepth(pVM->pStack); 70348981Ssheldonh stackPushINT32(pVM->pStack, i); 704157816Sdwmalone return; 70556590Sshin} 70657857Sshin 70748981Ssheldonh 70856590Sshinstatic void drop(FICL_VM *pVM) 70948981Ssheldonh{ 71056590Sshin#if FICL_ROBUST > 1 71148981Ssheldonh vmCheckStack(pVM, 1, 0); 71248981Ssheldonh#endif 71356590Sshin stackDrop(pVM->pStack, 1); 71448981Ssheldonh return; 71548981Ssheldonh} 71648981Ssheldonh 71748981Ssheldonh 71857857Sshinstatic void twoDrop(FICL_VM *pVM) 71948981Ssheldonh{ 72048981Ssheldonh#if FICL_ROBUST > 1 72148981Ssheldonh vmCheckStack(pVM, 2, 0); 72248981Ssheldonh#endif 72398561Sjmallett stackDrop(pVM->pStack, 2); 72448981Ssheldonh return; 725157816Sdwmalone} 72648981Ssheldonh 72748981Ssheldonh 72858735Ssheldonhstatic void dup(FICL_VM *pVM) 72948981Ssheldonh{ 73048981Ssheldonh#if FICL_ROBUST > 1 73148981Ssheldonh vmCheckStack(pVM, 1, 2); 73249052Ssheldonh#endif 73349052Ssheldonh stackPick(pVM->pStack, 0); 73449052Ssheldonh return; 73548981Ssheldonh} 73648981Ssheldonh 73748981Ssheldonh 73848981Ssheldonhstatic void twoDup(FICL_VM *pVM) 73948981Ssheldonh{ 74048981Ssheldonh#if FICL_ROBUST > 1 74148981Ssheldonh vmCheckStack(pVM, 2, 4); 742228990Suqs#endif 743299356Sbapt stackPick(pVM->pStack, 1); 74448981Ssheldonh stackPick(pVM->pStack, 1); 74548981Ssheldonh return; 74648981Ssheldonh} 74748981Ssheldonh 74848981Ssheldonh 74948981Ssheldonhstatic void over(FICL_VM *pVM) 75048981Ssheldonh{ 75148981Ssheldonh#if FICL_ROBUST > 1 75248981Ssheldonh vmCheckStack(pVM, 2, 3); 75348981Ssheldonh#endif 75448981Ssheldonh stackPick(pVM->pStack, 1); 75548981Ssheldonh return; 75648981Ssheldonh} 75748981Ssheldonh 75848981Ssheldonhstatic void twoOver(FICL_VM *pVM) 75948981Ssheldonh{ 76048981Ssheldonh#if FICL_ROBUST > 1 76148981Ssheldonh vmCheckStack(pVM, 4, 6); 76248981Ssheldonh#endif 76348981Ssheldonh stackPick(pVM->pStack, 3); 76448981Ssheldonh stackPick(pVM->pStack, 3); 76548981Ssheldonh return; 76648981Ssheldonh} 76748981Ssheldonh 76848981Ssheldonh 76948981Ssheldonhstatic void pick(FICL_VM *pVM) 77048981Ssheldonh{ 77198558Sjmallett CELL c = stackPop(pVM->pStack); 77248981Ssheldonh#if FICL_ROBUST > 1 77348981Ssheldonh vmCheckStack(pVM, c.i+1, c.i+2); 77448981Ssheldonh#endif 77548981Ssheldonh stackPick(pVM->pStack, c.i); 77648981Ssheldonh return; 77748981Ssheldonh} 778299356Sbapt 77948981Ssheldonh 78048981Ssheldonhstatic void questionDup(FICL_VM *pVM) 78148981Ssheldonh{ 78248981Ssheldonh CELL c; 78348981Ssheldonh#if FICL_ROBUST > 1 78448981Ssheldonh vmCheckStack(pVM, 1, 2); 78548981Ssheldonh#endif 78648981Ssheldonh c = stackGetTop(pVM->pStack); 78748981Ssheldonh 78848981Ssheldonh if (c.i != 0) 78948981Ssheldonh stackPick(pVM->pStack, 0); 79048981Ssheldonh 79148981Ssheldonh return; 79248981Ssheldonh} 79348981Ssheldonh 79448981Ssheldonh 79548981Ssheldonhstatic void roll(FICL_VM *pVM) 79648981Ssheldonh{ 79748981Ssheldonh int i = stackPop(pVM->pStack).i; 79848981Ssheldonh i = (i > 0) ? i : 0; 79948981Ssheldonh#if FICL_ROBUST > 1 80048981Ssheldonh vmCheckStack(pVM, i+1, i+1); 80148981Ssheldonh#endif 80248981Ssheldonh stackRoll(pVM->pStack, i); 80348981Ssheldonh return; 80448981Ssheldonh} 80548981Ssheldonh 80648981Ssheldonh 80748981Ssheldonhstatic void minusRoll(FICL_VM *pVM) 80848981Ssheldonh{ 80948981Ssheldonh int i = stackPop(pVM->pStack).i; 81048981Ssheldonh i = (i > 0) ? i : 0; 81148981Ssheldonh#if FICL_ROBUST > 1 81248981Ssheldonh vmCheckStack(pVM, i+1, i+1); 81348981Ssheldonh#endif 81448981Ssheldonh stackRoll(pVM->pStack, -i); 815 return; 816} 817 818 819static void rot(FICL_VM *pVM) 820{ 821#if FICL_ROBUST > 1 822 vmCheckStack(pVM, 3, 3); 823#endif 824 stackRoll(pVM->pStack, 2); 825 return; 826} 827 828 829static void swap(FICL_VM *pVM) 830{ 831#if FICL_ROBUST > 1 832 vmCheckStack(pVM, 2, 2); 833#endif 834 stackRoll(pVM->pStack, 1); 835 return; 836} 837 838 839static void twoSwap(FICL_VM *pVM) 840{ 841#if FICL_ROBUST > 1 842 vmCheckStack(pVM, 4, 4); 843#endif 844 stackRoll(pVM->pStack, 3); 845 stackRoll(pVM->pStack, 3); 846 return; 847} 848 849 850/************************************************************************** 851 e m i t & f r i e n d s 852** 853**************************************************************************/ 854 855static void emit(FICL_VM *pVM) 856{ 857 char *cp = pVM->pad; 858 int i; 859 860#if FICL_ROBUST > 1 861 vmCheckStack(pVM, 1, 0); 862#endif 863 i = stackPopINT32(pVM->pStack); 864 cp[0] = (char)i; 865 cp[1] = '\0'; 866 vmTextOut(pVM, cp, 0); 867 return; 868} 869 870 871static void cr(FICL_VM *pVM) 872{ 873 vmTextOut(pVM, "", 1); 874 return; 875} 876 877 878static void commentLine(FICL_VM *pVM) 879{ 880 char *cp = vmGetInBuf(pVM); 881 char ch = *cp; 882 883 while ((pVM->tib.end != cp) && (ch != '\0') && (ch != '\r') && (ch != '\n')) 884 { 885 ch = *++cp; 886 } 887 888 /* 889 ** Cope with DOS or UNIX-style EOLs - 890 ** Check for /r, /n, /r/n, or /n/r end-of-line sequences, 891 ** and point cp to next char. If EOL is \0, we're done. 892 */ 893 if ((pVM->tib.end != cp) && (ch != '\0')) 894 { 895 cp++; 896 897 if ( (pVM->tib.end != cp) && (ch != *cp) 898 && ((*cp == '\r') || (*cp == '\n')) ) 899 cp++; 900 } 901 902 vmUpdateTib(pVM, cp); 903 return; 904} 905 906 907/* 908** paren CORE 909** Compilation: Perform the execution semantics given below. 910** Execution: ( "ccc<paren>" -- ) 911** Parse ccc delimited by ) (right parenthesis). ( is an immediate word. 912** The number of characters in ccc may be zero to the number of characters 913** in the parse area. 914** 915*/ 916static void commentHang(FICL_VM *pVM) 917{ 918 vmParseString(pVM, ')'); 919 return; 920} 921 922 923/************************************************************************** 924 F E T C H & S T O R E 925** 926**************************************************************************/ 927 928static void fetch(FICL_VM *pVM) 929{ 930 CELL *pCell; 931#if FICL_ROBUST > 1 932 vmCheckStack(pVM, 1, 1); 933#endif 934 pCell = (CELL *)stackPopPtr(pVM->pStack); 935 stackPush(pVM->pStack, *pCell); 936 return; 937} 938 939/* 940** two-fetch CORE ( a-addr -- x1 x2 ) 941** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and 942** x1 at the next consecutive cell. It is equivalent to the sequence 943** DUP CELL+ @ SWAP @ . 944*/ 945static void twoFetch(FICL_VM *pVM) 946{ 947 CELL *pCell; 948#if FICL_ROBUST > 1 949 vmCheckStack(pVM, 1, 2); 950#endif 951 pCell = (CELL *)stackPopPtr(pVM->pStack); 952 stackPush(pVM->pStack, *pCell++); 953 stackPush(pVM->pStack, *pCell); 954 swap(pVM); 955 return; 956} 957 958/* 959** store CORE ( x a-addr -- ) 960** Store x at a-addr. 961*/ 962static void store(FICL_VM *pVM) 963{ 964 CELL *pCell; 965#if FICL_ROBUST > 1 966 vmCheckStack(pVM, 2, 0); 967#endif 968 pCell = (CELL *)stackPopPtr(pVM->pStack); 969 *pCell = stackPop(pVM->pStack); 970} 971 972/* 973** two-store CORE ( x1 x2 a-addr -- ) 974** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the 975** next consecutive cell. It is equivalent to the sequence 976** SWAP OVER ! CELL+ ! . 977*/ 978static void twoStore(FICL_VM *pVM) 979{ 980 CELL *pCell; 981#if FICL_ROBUST > 1 982 vmCheckStack(pVM, 3, 0); 983#endif 984 pCell = (CELL *)stackPopPtr(pVM->pStack); 985 *pCell++ = stackPop(pVM->pStack); 986 *pCell = stackPop(pVM->pStack); 987} 988 989static void plusStore(FICL_VM *pVM) 990{ 991 CELL *pCell; 992#if FICL_ROBUST > 1 993 vmCheckStack(pVM, 2, 0); 994#endif 995 pCell = (CELL *)stackPopPtr(pVM->pStack); 996 pCell->i += stackPop(pVM->pStack).i; 997} 998 999 1000static void wFetch(FICL_VM *pVM) 1001{ 1002 UNS16 *pw; 1003#if FICL_ROBUST > 1 1004 vmCheckStack(pVM, 1, 1); 1005#endif 1006 pw = (UNS16 *)stackPopPtr(pVM->pStack); 1007 stackPushUNS32(pVM->pStack, (UNS32)*pw); 1008 return; 1009} 1010 1011static void wStore(FICL_VM *pVM) 1012{ 1013 UNS16 *pw; 1014#if FICL_ROBUST > 1 1015 vmCheckStack(pVM, 2, 0); 1016#endif 1017 pw = (UNS16 *)stackPopPtr(pVM->pStack); 1018 *pw = (UNS16)(stackPop(pVM->pStack).u); 1019} 1020 1021static void cFetch(FICL_VM *pVM) 1022{ 1023 UNS8 *pc; 1024#if FICL_ROBUST > 1 1025 vmCheckStack(pVM, 1, 1); 1026#endif 1027 pc = (UNS8 *)stackPopPtr(pVM->pStack); 1028 stackPushUNS32(pVM->pStack, (UNS32)*pc); 1029 return; 1030} 1031 1032static void cStore(FICL_VM *pVM) 1033{ 1034 UNS8 *pc; 1035#if FICL_ROBUST > 1 1036 vmCheckStack(pVM, 2, 0); 1037#endif 1038 pc = (UNS8 *)stackPopPtr(pVM->pStack); 1039 *pc = (UNS8)(stackPop(pVM->pStack).u); 1040} 1041 1042 1043/************************************************************************** 1044 i f C o I m 1045** IMMEDIATE 1046** Compiles code for a conditional branch into the dictionary 1047** and pushes the branch patch address on the stack for later 1048** patching by ELSE or THEN/ENDIF. 1049**************************************************************************/ 1050 1051static void ifCoIm(FICL_VM *pVM) 1052{ 1053 FICL_DICT *dp = ficlGetDict(); 1054 1055 assert(pIfParen); 1056 1057 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 1058 markBranch(dp, pVM, ifTag); 1059 dictAppendUNS32(dp, 1); 1060 return; 1061} 1062 1063 1064/************************************************************************** 1065 i f P a r e n 1066** Runtime code to do "if" or "until": pop a flag from the stack, 1067** fall through if true, branch if false. Probably ought to be 1068** called (not?branch) since it does "branch if false". 1069**************************************************************************/ 1070 1071#ifdef FICL_TRACE 1072void ifParen(FICL_VM *pVM) 1073#else 1074static void ifParen(FICL_VM *pVM) 1075#endif 1076{ 1077 UNS32 flag; 1078 1079#if FICL_ROBUST > 1 1080 vmCheckStack(pVM, 1, 0); 1081#endif 1082 flag = stackPopUNS32(pVM->pStack); 1083 1084 if (flag) 1085 { /* fall through */ 1086 vmBranchRelative(pVM, 1); 1087 } 1088 else 1089 { /* take branch (to else/endif/begin) */ 1090 vmBranchRelative(pVM, (int)(*pVM->ip)); 1091 } 1092 1093 return; 1094} 1095 1096 1097/************************************************************************** 1098 e l s e C o I m 1099** 1100** IMMEDIATE -- compiles an "else"... 1101** 1) Compile a branch and a patch address; the address gets patched 1102** by "endif" to point past the "else" code. 1103** 2) Pop the the "if" patch address 1104** 3) Patch the "if" branch to point to the current compile address. 1105** 4) Push the "else" patch address. ("endif" patches this to jump past 1106** the "else" code. 1107**************************************************************************/ 1108 1109static void elseCoIm(FICL_VM *pVM) 1110{ 1111 CELL *patchAddr; 1112 int offset; 1113 FICL_DICT *dp = ficlGetDict(); 1114 1115 assert(pBranchParen); 1116 /* (1) compile branch runtime */ 1117 dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); 1118 matchControlTag(pVM, ifTag); 1119 patchAddr = 1120 (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */ 1121 markBranch(dp, pVM, ifTag); /* (4) push "else" patch addr */ 1122 dictAppendUNS32(dp, 1); /* (1) compile patch placeholder */ 1123 offset = dp->here - patchAddr; 1124 *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */ 1125 1126 return; 1127} 1128 1129 1130/************************************************************************** 1131 b r a n c h P a r e n 1132** 1133** Runtime for "(branch)" -- expects a literal offset in the next 1134** compilation address, and branches to that location. 1135**************************************************************************/ 1136 1137#ifdef FICL_TRACE 1138void branchParen(FICL_VM *pVM) 1139#else 1140static void branchParen(FICL_VM *pVM) 1141#endif 1142{ 1143 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1144 return; 1145} 1146 1147 1148/************************************************************************** 1149 e n d i f C o I m 1150** 1151**************************************************************************/ 1152 1153static void endifCoIm(FICL_VM *pVM) 1154{ 1155 FICL_DICT *dp = ficlGetDict(); 1156 resolveForwardBranch(dp, pVM, ifTag); 1157 return; 1158} 1159 1160 1161/************************************************************************** 1162 i n t e r p r e t 1163** This is the "user interface" of a Forth. It does the following: 1164** while there are words in the VM's Text Input Buffer 1165** Copy next word into the pad (vmGetWord) 1166** Attempt to find the word in the dictionary (dictLookup) 1167** If successful, execute the word. 1168** Otherwise, attempt to convert the word to a number (isNumber) 1169** If successful, push the number onto the parameter stack. 1170** Otherwise, print an error message and exit loop... 1171** End Loop 1172** 1173** From the standard, section 3.4 1174** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall 1175** repeat the following steps until either the parse area is empty or an 1176** ambiguous condition exists: 1177** a) Skip leading spaces and parse a name (see 3.4.1); 1178**************************************************************************/ 1179 1180static void interpret(FICL_VM *pVM) 1181{ 1182 STRINGINFO si = vmGetWord0(pVM); 1183 assert(pVM); 1184 1185 vmBranchRelative(pVM, -1); 1186 1187 /* 1188 // Get next word...if out of text, we're done. 1189 */ 1190 if (si.count == 0) 1191 vmThrow(pVM, VM_OUTOFTEXT); 1192 1193 interpWord(pVM, si); 1194 1195 return; /* back to inner interpreter */ 1196} 1197 1198/************************************************************************** 1199** From the standard, section 3.4 1200** b) Search the dictionary name space (see 3.4.2). If a definition name 1201** matching the string is found: 1202** 1.if interpreting, perform the interpretation semantics of the definition 1203** (see 3.4.3.2), and continue at a); 1204** 2.if compiling, perform the compilation semantics of the definition 1205** (see 3.4.3.3), and continue at a). 1206** 1207** c) If a definition name matching the string is not found, attempt to 1208** convert the string to a number (see 3.4.1.3). If successful: 1209** 1.if interpreting, place the number on the data stack, and continue at a); 1210** 2.if compiling, compile code that when executed will place the number on 1211** the stack (see 6.1.1780 LITERAL), and continue at a); 1212** 1213** d) If unsuccessful, an ambiguous condition exists (see 3.4.4). 1214**************************************************************************/ 1215static void interpWord(FICL_VM *pVM, STRINGINFO si) 1216{ 1217 FICL_DICT *dp = ficlGetDict(); 1218 FICL_WORD *tempFW; 1219 1220#if FICL_ROBUST 1221 dictCheck(dp, pVM, 0); 1222 vmCheckStack(pVM, 0, 0); 1223#endif 1224 1225#if FICL_WANT_LOCALS 1226 if (nLocals > 0) 1227 { 1228 tempFW = dictLookupLoc(dp, si); 1229 } 1230 else 1231#endif 1232 tempFW = dictLookup(dp, si); 1233 1234 if (pVM->state == INTERPRET) 1235 { 1236 if (tempFW != NULL) 1237 { 1238 if (wordIsCompileOnly(tempFW)) 1239 { 1240 vmThrowErr(pVM, "Error: Compile only!"); 1241 } 1242 vmExecute(pVM, tempFW); 1243 } 1244 1245 else if (!isNumber(pVM, si)) 1246 { 1247 int i = SI_COUNT(si); 1248 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1249 } 1250 } 1251 1252 else /* (pVM->state == COMPILE) */ 1253 { 1254 if (tempFW != NULL) 1255 { 1256 if (wordIsImmediate(tempFW)) 1257 { 1258 vmExecute(pVM, tempFW); 1259 } 1260 else 1261 { 1262 dictAppendCell(dp, LVALUEtoCELL(tempFW)); 1263 } 1264 } 1265 else if (isNumber(pVM, si)) 1266 { 1267 literalIm(pVM); 1268 } 1269 else 1270 { 1271 int i = SI_COUNT(si); 1272 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1273 } 1274 } 1275 1276 return; 1277} 1278 1279 1280/************************************************************************** 1281 l i t e r a l P a r e n 1282** 1283** This is the runtime for (literal). It assumes that it is part of a colon 1284** definition, and that the next CELL contains a value to be pushed on the 1285** parameter stack at runtime. This code is compiled by "literal". 1286** 1287**************************************************************************/ 1288#ifdef FICL_TRACE 1289void literalParen(FICL_VM *pVM) 1290#else 1291static void literalParen(FICL_VM *pVM) 1292#endif 1293{ 1294#if FICL_ROBUST > 1 1295 vmCheckStack(pVM, 0, 1); 1296#endif 1297 stackPushINT32(pVM->pStack, *(INT32 *)(pVM->ip)); 1298 vmBranchRelative(pVM, 1); 1299 return; 1300} 1301 1302 1303/************************************************************************** 1304 l i t e r a l I m 1305** 1306** IMMEDIATE code for "literal". This function gets a value from the stack 1307** and compiles it into the dictionary preceded by the code for "(literal)". 1308** IMMEDIATE 1309**************************************************************************/ 1310 1311static void literalIm(FICL_VM *pVM) 1312{ 1313 FICL_DICT *dp = ficlGetDict(); 1314 assert(pLitParen); 1315 1316 dictAppendCell(dp, LVALUEtoCELL(pLitParen)); 1317 dictAppendCell(dp, stackPop(pVM->pStack)); 1318 1319 return; 1320} 1321 1322 1323/************************************************************************** 1324 l i s t W o r d s 1325** 1326**************************************************************************/ 1327#define nCOLWIDTH 8 1328static void listWords(FICL_VM *pVM) 1329{ 1330 FICL_DICT *dp = ficlGetDict(); 1331 FICL_HASH *pHash = dp->pSearch[dp->nLists - 1]; 1332 FICL_WORD *wp; 1333 int nChars = 0; 1334 int len; 1335 int y = 0; 1336 unsigned i; 1337 int nWords = 0; 1338 char *cp; 1339 char *pPad = pVM->pad; 1340 1341 for (i = 0; i < pHash->size; i++) 1342 { 1343 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 1344 { 1345 if (wp->nName == 0) /* ignore :noname defs */ 1346 continue; 1347 1348 cp = wp->name; 1349 nChars += sprintf(pPad + nChars, "%s", cp); 1350 1351 if (nChars > 70) 1352 { 1353 pPad[nChars] = '\0'; 1354 nChars = 0; 1355 y++; 1356 if(y>23) { 1357 y=0; 1358 vmTextOut(pVM, "--- Press Enter to continue ---",0); 1359 getchar(); 1360 vmTextOut(pVM,"\r",0); 1361 } 1362 vmTextOut(pVM, pPad, 1); 1363 } 1364 else 1365 { 1366 len = nCOLWIDTH - nChars % nCOLWIDTH; 1367 while (len-- > 0) 1368 pPad[nChars++] = ' '; 1369 } 1370 1371 if (nChars > 70) 1372 { 1373 pPad[nChars] = '\0'; 1374 nChars = 0; 1375 y++; 1376 if(y>23) { 1377 y=0; 1378 vmTextOut(pVM, "--- Press Enter to continue ---",0); 1379 getchar(); 1380 vmTextOut(pVM,"\r",0); 1381 } 1382 vmTextOut(pVM, pPad, 1); 1383 } 1384 } 1385 } 1386 1387 if (nChars > 0) 1388 { 1389 pPad[nChars] = '\0'; 1390 nChars = 0; 1391 vmTextOut(pVM, pPad, 1); 1392 } 1393 1394 sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %lu total", 1395 nWords, dp->here - dp->dict, dp->size); 1396 vmTextOut(pVM, pVM->pad, 1); 1397 return; 1398} 1399 1400 1401static void listEnv(FICL_VM *pVM) 1402{ 1403 FICL_DICT *dp = ficlGetEnv(); 1404 FICL_HASH *pHash = dp->pForthWords; 1405 FICL_WORD *wp; 1406 unsigned i; 1407 int nWords = 0; 1408 1409 for (i = 0; i < pHash->size; i++) 1410 { 1411 for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 1412 { 1413 vmTextOut(pVM, wp->name, 1); 1414 } 1415 } 1416 1417 sprintf(pVM->pad, "Environment: %d words, %ld cells used of %lu total", 1418 nWords, dp->here - dp->dict, dp->size); 1419 vmTextOut(pVM, pVM->pad, 1); 1420 return; 1421} 1422 1423 1424/************************************************************************** 1425 l o g i c a n d c o m p a r i s o n s 1426** 1427**************************************************************************/ 1428 1429static void zeroEquals(FICL_VM *pVM) 1430{ 1431 CELL c; 1432#if FICL_ROBUST > 1 1433 vmCheckStack(pVM, 1, 1); 1434#endif 1435 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) == 0); 1436 stackPush(pVM->pStack, c); 1437 return; 1438} 1439 1440static void zeroLess(FICL_VM *pVM) 1441{ 1442 CELL c; 1443#if FICL_ROBUST > 1 1444 vmCheckStack(pVM, 1, 1); 1445#endif 1446 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) < 0); 1447 stackPush(pVM->pStack, c); 1448 return; 1449} 1450 1451static void zeroGreater(FICL_VM *pVM) 1452{ 1453 CELL c; 1454#if FICL_ROBUST > 1 1455 vmCheckStack(pVM, 1, 1); 1456#endif 1457 c.i = FICL_BOOL(stackPopINT32(pVM->pStack) > 0); 1458 stackPush(pVM->pStack, c); 1459 return; 1460} 1461 1462static void isEqual(FICL_VM *pVM) 1463{ 1464 CELL x, y; 1465 1466#if FICL_ROBUST > 1 1467 vmCheckStack(pVM, 2, 1); 1468#endif 1469 x = stackPop(pVM->pStack); 1470 y = stackPop(pVM->pStack); 1471 stackPushINT32(pVM->pStack, FICL_BOOL(x.i == y.i)); 1472 return; 1473} 1474 1475static void isLess(FICL_VM *pVM) 1476{ 1477 CELL x, y; 1478#if FICL_ROBUST > 1 1479 vmCheckStack(pVM, 2, 1); 1480#endif 1481 y = stackPop(pVM->pStack); 1482 x = stackPop(pVM->pStack); 1483 stackPushINT32(pVM->pStack, FICL_BOOL(x.i < y.i)); 1484 return; 1485} 1486 1487static void uIsLess(FICL_VM *pVM) 1488{ 1489 UNS32 u1, u2; 1490#if FICL_ROBUST > 1 1491 vmCheckStack(pVM, 2, 1); 1492#endif 1493 u2 = stackPopUNS32(pVM->pStack); 1494 u1 = stackPopUNS32(pVM->pStack); 1495 stackPushINT32(pVM->pStack, FICL_BOOL(u1 < u2)); 1496 return; 1497} 1498 1499static void isGreater(FICL_VM *pVM) 1500{ 1501 CELL x, y; 1502#if FICL_ROBUST > 1 1503 vmCheckStack(pVM, 2, 1); 1504#endif 1505 y = stackPop(pVM->pStack); 1506 x = stackPop(pVM->pStack); 1507 stackPushINT32(pVM->pStack, FICL_BOOL(x.i > y.i)); 1508 return; 1509} 1510 1511static void bitwiseAnd(FICL_VM *pVM) 1512{ 1513 CELL x, y; 1514#if FICL_ROBUST > 1 1515 vmCheckStack(pVM, 2, 1); 1516#endif 1517 x = stackPop(pVM->pStack); 1518 y = stackPop(pVM->pStack); 1519 stackPushINT32(pVM->pStack, x.i & y.i); 1520 return; 1521} 1522 1523static void bitwiseOr(FICL_VM *pVM) 1524{ 1525 CELL x, y; 1526#if FICL_ROBUST > 1 1527 vmCheckStack(pVM, 2, 1); 1528#endif 1529 x = stackPop(pVM->pStack); 1530 y = stackPop(pVM->pStack); 1531 stackPushINT32(pVM->pStack, x.i | y.i); 1532 return; 1533} 1534 1535static void bitwiseXor(FICL_VM *pVM) 1536{ 1537 CELL x, y; 1538#if FICL_ROBUST > 1 1539 vmCheckStack(pVM, 2, 1); 1540#endif 1541 x = stackPop(pVM->pStack); 1542 y = stackPop(pVM->pStack); 1543 stackPushINT32(pVM->pStack, x.i ^ y.i); 1544 return; 1545} 1546 1547static void bitwiseNot(FICL_VM *pVM) 1548{ 1549 CELL x; 1550#if FICL_ROBUST > 1 1551 vmCheckStack(pVM, 1, 1); 1552#endif 1553 x = stackPop(pVM->pStack); 1554 stackPushINT32(pVM->pStack, ~x.i); 1555 return; 1556} 1557 1558 1559/************************************************************************** 1560 D o / L o o p 1561** do -- IMMEDIATE COMPILE ONLY 1562** Compiles code to initialize a loop: compile (do), 1563** allot space to hold the "leave" address, push a branch 1564** target address for the loop. 1565** (do) -- runtime for "do" 1566** pops index and limit from the p stack and moves them 1567** to the r stack, then skips to the loop body. 1568** loop -- IMMEDIATE COMPILE ONLY 1569** +loop 1570** Compiles code for the test part of a loop: 1571** compile (loop), resolve forward branch from "do", and 1572** copy "here" address to the "leave" address allotted by "do" 1573** i,j,k -- COMPILE ONLY 1574** Runtime: Push loop indices on param stack (i is innermost loop...) 1575** Note: each loop has three values on the return stack: 1576** ( R: leave limit index ) 1577** "leave" is the absolute address of the next cell after the loop 1578** limit and index are the loop control variables. 1579** leave -- COMPILE ONLY 1580** Runtime: pop the loop control variables, then pop the 1581** "leave" address and jump (absolute) there. 1582**************************************************************************/ 1583 1584static void doCoIm(FICL_VM *pVM) 1585{ 1586 FICL_DICT *dp = ficlGetDict(); 1587 1588 assert(pDoParen); 1589 1590 dictAppendCell(dp, LVALUEtoCELL(pDoParen)); 1591 /* 1592 ** Allot space for a pointer to the end 1593 ** of the loop - "leave" uses this... 1594 */ 1595 markBranch(dp, pVM, leaveTag); 1596 dictAppendUNS32(dp, 0); 1597 /* 1598 ** Mark location of head of loop... 1599 */ 1600 markBranch(dp, pVM, doTag); 1601 1602 return; 1603} 1604 1605#ifdef FICL_TRACE 1606void doParen(FICL_VM *pVM) 1607#else 1608static void doParen(FICL_VM *pVM) 1609#endif 1610{ 1611 CELL index, limit; 1612#if FICL_ROBUST > 1 1613 vmCheckStack(pVM, 2, 0); 1614#endif 1615 index = stackPop(pVM->pStack); 1616 limit = stackPop(pVM->pStack); 1617 1618 /* copy "leave" target addr to stack */ 1619 stackPushPtr(pVM->rStack, *(pVM->ip++)); 1620 stackPush(pVM->rStack, limit); 1621 stackPush(pVM->rStack, index); 1622 1623 return; 1624} 1625 1626 1627static void qDoCoIm(FICL_VM *pVM) 1628{ 1629 FICL_DICT *dp = ficlGetDict(); 1630 1631 assert(pQDoParen); 1632 1633 dictAppendCell(dp, LVALUEtoCELL(pQDoParen)); 1634 /* 1635 ** Allot space for a pointer to the end 1636 ** of the loop - "leave" uses this... 1637 */ 1638 markBranch(dp, pVM, leaveTag); 1639 dictAppendUNS32(dp, 0); 1640 /* 1641 ** Mark location of head of loop... 1642 */ 1643 markBranch(dp, pVM, doTag); 1644 1645 return; 1646} 1647 1648#ifdef FICL_TRACE 1649void qDoParen(FICL_VM *pVM) 1650#else 1651static void qDoParen(FICL_VM *pVM) 1652#endif 1653{ 1654 CELL index, limit; 1655#if FICL_ROBUST > 1 1656 vmCheckStack(pVM, 2, 0); 1657#endif 1658 index = stackPop(pVM->pStack); 1659 limit = stackPop(pVM->pStack); 1660 1661 /* copy "leave" target addr to stack */ 1662 stackPushPtr(pVM->rStack, *(pVM->ip++)); 1663 1664 if (limit.u == index.u) 1665 { 1666 vmPopIP(pVM); 1667 } 1668 else 1669 { 1670 stackPush(pVM->rStack, limit); 1671 stackPush(pVM->rStack, index); 1672 } 1673 1674 return; 1675} 1676 1677 1678/* 1679** Runtime code to break out of a do..loop construct 1680** Drop the loop control variables; the branch address 1681** past "loop" is next on the return stack. 1682*/ 1683static void leaveCo(FICL_VM *pVM) 1684{ 1685 /* almost unloop */ 1686 stackDrop(pVM->rStack, 2); 1687 /* exit */ 1688 vmPopIP(pVM); 1689 return; 1690} 1691 1692 1693static void unloopCo(FICL_VM *pVM) 1694{ 1695 stackDrop(pVM->rStack, 3); 1696 return; 1697} 1698 1699 1700static void loopCoIm(FICL_VM *pVM) 1701{ 1702 FICL_DICT *dp = ficlGetDict(); 1703 1704 assert(pLoopParen); 1705 1706 dictAppendCell(dp, LVALUEtoCELL(pLoopParen)); 1707 resolveBackBranch(dp, pVM, doTag); 1708 resolveAbsBranch(dp, pVM, leaveTag); 1709 return; 1710} 1711 1712 1713static void plusLoopCoIm(FICL_VM *pVM) 1714{ 1715 FICL_DICT *dp = ficlGetDict(); 1716 1717 assert(pPLoopParen); 1718 1719 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen)); 1720 resolveBackBranch(dp, pVM, doTag); 1721 resolveAbsBranch(dp, pVM, leaveTag); 1722 return; 1723} 1724 1725#ifdef FICL_TRACE 1726void loopParen(FICL_VM *pVM) 1727#else 1728static void loopParen(FICL_VM *pVM) 1729#endif 1730{ 1731 INT32 index = stackGetTop(pVM->rStack).i; 1732 INT32 limit = stackFetch(pVM->rStack, 1).i; 1733 1734 index++; 1735 1736 if (index >= limit) 1737 { 1738 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 1739 vmBranchRelative(pVM, 1); /* fall through the loop */ 1740 } 1741 else 1742 { /* update index, branch to loop head */ 1743 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 1744 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1745 } 1746 1747 return; 1748} 1749 1750#ifdef FICL_TRACE 1751void plusLoopParen(FICL_VM *pVM) 1752#else 1753static void plusLoopParen(FICL_VM *pVM) 1754#endif 1755{ 1756 INT32 index = stackGetTop(pVM->rStack).i; 1757 INT32 limit = stackFetch(pVM->rStack, 1).i; 1758 INT32 increment = stackPop(pVM->pStack).i; 1759 int flag; 1760 1761 index += increment; 1762 1763 if (increment < 0) 1764 flag = (index < limit); 1765 else 1766 flag = (index >= limit); 1767 1768 if (flag) 1769 { 1770 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 1771 vmBranchRelative(pVM, 1); /* fall through the loop */ 1772 } 1773 else 1774 { /* update index, branch to loop head */ 1775 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 1776 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1777 } 1778 1779 return; 1780} 1781 1782 1783static void loopICo(FICL_VM *pVM) 1784{ 1785 CELL index = stackGetTop(pVM->rStack); 1786 stackPush(pVM->pStack, index); 1787 1788 return; 1789} 1790 1791 1792static void loopJCo(FICL_VM *pVM) 1793{ 1794 CELL index = stackFetch(pVM->rStack, 3); 1795 stackPush(pVM->pStack, index); 1796 1797 return; 1798} 1799 1800 1801static void loopKCo(FICL_VM *pVM) 1802{ 1803 CELL index = stackFetch(pVM->rStack, 6); 1804 stackPush(pVM->pStack, index); 1805 1806 return; 1807} 1808 1809 1810/************************************************************************** 1811 r e t u r n s t a c k 1812** 1813**************************************************************************/ 1814 1815static void toRStack(FICL_VM *pVM) 1816{ 1817 stackPush(pVM->rStack, stackPop(pVM->pStack)); 1818 return; 1819} 1820 1821static void fromRStack(FICL_VM *pVM) 1822{ 1823 stackPush(pVM->pStack, stackPop(pVM->rStack)); 1824 return; 1825} 1826 1827static void fetchRStack(FICL_VM *pVM) 1828{ 1829 stackPush(pVM->pStack, stackGetTop(pVM->rStack)); 1830 return; 1831} 1832 1833 1834/************************************************************************** 1835 v a r i a b l e 1836** 1837**************************************************************************/ 1838 1839static void variableParen(FICL_VM *pVM) 1840{ 1841 FICL_WORD *fw = pVM->runningWord; 1842 stackPushPtr(pVM->pStack, fw->param); 1843 return; 1844} 1845 1846 1847static void variable(FICL_VM *pVM) 1848{ 1849 FICL_DICT *dp = ficlGetDict(); 1850 STRINGINFO si = vmGetWord(pVM); 1851 1852 dictAppendWord2(dp, si, variableParen, FW_DEFAULT); 1853 dictAllotCells(dp, 1); 1854 return; 1855} 1856 1857 1858 1859/************************************************************************** 1860 b a s e & f r i e n d s 1861** 1862**************************************************************************/ 1863 1864static void base(FICL_VM *pVM) 1865{ 1866 CELL *pBase = (CELL *)(&pVM->base); 1867 stackPush(pVM->pStack, LVALUEtoCELL(pBase)); 1868 return; 1869} 1870 1871 1872static void decimal(FICL_VM *pVM) 1873{ 1874 pVM->base = 10; 1875 return; 1876} 1877 1878 1879static void hex(FICL_VM *pVM) 1880{ 1881 pVM->base = 16; 1882 return; 1883} 1884 1885 1886/************************************************************************** 1887 a l l o t & f r i e n d s 1888** 1889**************************************************************************/ 1890 1891static void allot(FICL_VM *pVM) 1892{ 1893 FICL_DICT *dp = ficlGetDict(); 1894 INT32 i = stackPopINT32(pVM->pStack); 1895#if FICL_ROBUST 1896 dictCheck(dp, pVM, i); 1897#endif 1898 dictAllot(dp, i); 1899 return; 1900} 1901 1902 1903static void here(FICL_VM *pVM) 1904{ 1905 FICL_DICT *dp = ficlGetDict(); 1906 stackPushPtr(pVM->pStack, dp->here); 1907 return; 1908} 1909 1910 1911static void comma(FICL_VM *pVM) 1912{ 1913 FICL_DICT *dp = ficlGetDict(); 1914 CELL c = stackPop(pVM->pStack); 1915 dictAppendCell(dp, c); 1916 return; 1917} 1918 1919 1920static void cComma(FICL_VM *pVM) 1921{ 1922 FICL_DICT *dp = ficlGetDict(); 1923 char c = (char)stackPopINT32(pVM->pStack); 1924 dictAppendChar(dp, c); 1925 return; 1926} 1927 1928 1929static void cells(FICL_VM *pVM) 1930{ 1931 INT32 i = stackPopINT32(pVM->pStack); 1932 stackPushINT32(pVM->pStack, i * (INT32)sizeof (CELL)); 1933 return; 1934} 1935 1936 1937static void cellPlus(FICL_VM *pVM) 1938{ 1939 char *cp = stackPopPtr(pVM->pStack); 1940 stackPushPtr(pVM->pStack, cp + sizeof (CELL)); 1941 return; 1942} 1943 1944 1945/************************************************************************** 1946 t i c k 1947** tick CORE ( "<spaces>name" -- xt ) 1948** Skip leading space delimiters. Parse name delimited by a space. Find 1949** name and return xt, the execution token for name. An ambiguous condition 1950** exists if name is not found. 1951**************************************************************************/ 1952static void tick(FICL_VM *pVM) 1953{ 1954 FICL_WORD *pFW = NULL; 1955 STRINGINFO si = vmGetWord(pVM); 1956 1957 pFW = dictLookup(ficlGetDict(), si); 1958 if (!pFW) 1959 { 1960 int i = SI_COUNT(si); 1961 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1962 } 1963 stackPushPtr(pVM->pStack, pFW); 1964 return; 1965} 1966 1967 1968static void bracketTickCoIm(FICL_VM *pVM) 1969{ 1970 tick(pVM); 1971 literalIm(pVM); 1972 1973 return; 1974} 1975 1976 1977/************************************************************************** 1978 p o s t p o n e 1979** Lookup the next word in the input stream and compile code to 1980** insert it into definitions created by the resulting word 1981** (defers compilation, even of immediate words) 1982**************************************************************************/ 1983 1984static void postponeCoIm(FICL_VM *pVM) 1985{ 1986 FICL_DICT *dp = ficlGetDict(); 1987 FICL_WORD *pFW; 1988 assert(pComma); 1989 1990 tick(pVM); 1991 pFW = stackGetTop(pVM->pStack).p; 1992 if (wordIsImmediate(pFW)) 1993 { 1994 dictAppendCell(dp, stackPop(pVM->pStack)); 1995 } 1996 else 1997 { 1998 literalIm(pVM); 1999 dictAppendCell(dp, LVALUEtoCELL(pComma)); 2000 } 2001 2002 return; 2003} 2004 2005 2006 2007/************************************************************************** 2008 e x e c u t e 2009** Pop an execution token (pointer to a word) off the stack and 2010** run it 2011**************************************************************************/ 2012 2013static void execute(FICL_VM *pVM) 2014{ 2015 FICL_WORD *pFW; 2016#if FICL_ROBUST > 1 2017 vmCheckStack(pVM, 1, 0); 2018#endif 2019 2020 pFW = stackPopPtr(pVM->pStack); 2021 vmExecute(pVM, pFW); 2022 2023 return; 2024} 2025 2026 2027/************************************************************************** 2028 i m m e d i a t e 2029** Make the most recently compiled word IMMEDIATE -- it executes even 2030** in compile state (most often used for control compiling words 2031** such as IF, THEN, etc) 2032**************************************************************************/ 2033 2034static void immediate(FICL_VM *pVM) 2035{ 2036 IGNORE(pVM); 2037 dictSetImmediate(ficlGetDict()); 2038 return; 2039} 2040 2041 2042static void compileOnly(FICL_VM *pVM) 2043{ 2044 IGNORE(pVM); 2045 dictSetFlags(ficlGetDict(), FW_COMPILE, 0); 2046 return; 2047} 2048 2049 2050/************************************************************************** 2051 d o t Q u o t e 2052** IMMEDIATE word that compiles a string literal for later display 2053** Compile stringLit, then copy the bytes of the string from the TIB 2054** to the dictionary. Backpatch the count byte and align the dictionary. 2055** 2056** stringlit: Fetch the count from the dictionary, then push the address 2057** and count on the stack. Finally, update ip to point to the first 2058** aligned address after the string text. 2059**************************************************************************/ 2060#ifdef FICL_TRACE 2061void stringLit(FICL_VM *pVM) 2062#else 2063static void stringLit(FICL_VM *pVM) 2064#endif 2065{ 2066 FICL_STRING *sp = (FICL_STRING *)(pVM->ip); 2067 FICL_COUNT count = sp->count; 2068 char *cp = sp->text; 2069 stackPushPtr(pVM->pStack, cp); 2070 stackPushUNS32(pVM->pStack, count); 2071 cp += count + 1; 2072 cp = alignPtr(cp); 2073 pVM->ip = (IPTYPE)(void *)cp; 2074 return; 2075} 2076 2077static void dotQuoteCoIm(FICL_VM *pVM) 2078{ 2079 FICL_DICT *dp = ficlGetDict(); 2080 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2081 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2082 dictAlign(dp); 2083 dictAppendCell(dp, LVALUEtoCELL(pType)); 2084 return; 2085} 2086 2087 2088static void dotParen(FICL_VM *pVM) 2089{ 2090 char *pSrc = vmGetInBuf(pVM); 2091 char *pDest = pVM->pad; 2092 char ch; 2093 2094 pSrc = skipSpace(pSrc,pVM->tib.end); 2095 2096 for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && (ch != ')'); ch = *++pSrc) 2097 *pDest++ = ch; 2098 2099 *pDest = '\0'; 2100 if ((pVM->tib.end != pSrc) && (ch == ')')) 2101 pSrc++; 2102 2103 vmTextOut(pVM, pVM->pad, 0); 2104 vmUpdateTib(pVM, pSrc); 2105 2106 return; 2107} 2108 2109 2110/************************************************************************** 2111 s l i t e r a l 2112** STRING 2113** Interpretation: Interpretation semantics for this word are undefined. 2114** Compilation: ( c-addr1 u -- ) 2115** Append the run-time semantics given below to the current definition. 2116** Run-time: ( -- c-addr2 u ) 2117** Return c-addr2 u describing a string consisting of the characters 2118** specified by c-addr1 u during compilation. A program shall not alter 2119** the returned string. 2120**************************************************************************/ 2121static void sLiteralCoIm(FICL_VM *pVM) 2122{ 2123 FICL_DICT *dp = ficlGetDict(); 2124 char *cp, *cpDest; 2125 UNS32 u; 2126 u = stackPopUNS32(pVM->pStack); 2127 cp = stackPopPtr(pVM->pStack); 2128 2129 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2130 cpDest = (char *) dp->here; 2131 *cpDest++ = (char) u; 2132 2133 for (; u > 0; --u) 2134 { 2135 *cpDest++ = *cp++; 2136 } 2137 2138 *cpDest++ = 0; 2139 dp->here = PTRtoCELL alignPtr(cpDest); 2140 return; 2141} 2142 2143 2144/************************************************************************** 2145 s t a t e 2146** Return the address of the VM's state member (must be sized the 2147** same as a CELL for this reason) 2148**************************************************************************/ 2149static void state(FICL_VM *pVM) 2150{ 2151 stackPushPtr(pVM->pStack, &pVM->state); 2152 return; 2153} 2154 2155 2156/************************************************************************** 2157 c r e a t e . . . d o e s > 2158** Make a new word in the dictionary with the run-time effect of 2159** a variable (push my address), but with extra space allotted 2160** for use by does> . 2161**************************************************************************/ 2162 2163static void createParen(FICL_VM *pVM) 2164{ 2165 CELL *pCell = pVM->runningWord->param; 2166 stackPushPtr(pVM->pStack, pCell+1); 2167 return; 2168} 2169 2170 2171static void create(FICL_VM *pVM) 2172{ 2173 FICL_DICT *dp = ficlGetDict(); 2174 STRINGINFO si = vmGetWord(pVM); 2175 2176 dictAppendWord2(dp, si, createParen, FW_DEFAULT); 2177 dictAllotCells(dp, 1); 2178 return; 2179} 2180 2181 2182static void doDoes(FICL_VM *pVM) 2183{ 2184 CELL *pCell = pVM->runningWord->param; 2185 IPTYPE tempIP = (IPTYPE)((*pCell).p); 2186 stackPushPtr(pVM->pStack, pCell+1); 2187 vmPushIP(pVM, tempIP); 2188 return; 2189} 2190 2191 2192static void doesParen(FICL_VM *pVM) 2193{ 2194 FICL_DICT *dp = ficlGetDict(); 2195 dp->smudge->code = doDoes; 2196 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); 2197 vmPopIP(pVM); 2198 return; 2199} 2200 2201 2202static void doesCoIm(FICL_VM *pVM) 2203{ 2204 FICL_DICT *dp = ficlGetDict(); 2205#if FICL_WANT_LOCALS 2206 assert(pUnLinkParen); 2207 if (nLocals > 0) 2208 { 2209 FICL_DICT *pLoc = ficlGetLoc(); 2210 dictEmpty(pLoc, pLoc->pForthWords->size); 2211 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 2212 } 2213 2214 nLocals = 0; 2215#endif 2216 IGNORE(pVM); 2217 2218 dictAppendCell(dp, LVALUEtoCELL(pDoesParen)); 2219 return; 2220} 2221 2222 2223/************************************************************************** 2224 t o b o d y 2225** to-body CORE ( xt -- a-addr ) 2226** a-addr is the data-field address corresponding to xt. An ambiguous 2227** condition exists if xt is not for a word defined via CREATE. 2228**************************************************************************/ 2229static void toBody(FICL_VM *pVM) 2230{ 2231 FICL_WORD *pFW = stackPopPtr(pVM->pStack); 2232 stackPushPtr(pVM->pStack, pFW->param + 1); 2233 return; 2234} 2235 2236 2237/* 2238** from-body ficl ( a-addr -- xt ) 2239** Reverse effect of >body 2240*/ 2241static void fromBody(FICL_VM *pVM) 2242{ 2243 char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD); 2244 stackPushPtr(pVM->pStack, ptr); 2245 return; 2246} 2247 2248 2249/* 2250** >name ficl ( xt -- c-addr u ) 2251** Push the address and length of a word's name given its address 2252** xt. 2253*/ 2254static void toName(FICL_VM *pVM) 2255{ 2256 FICL_WORD *pFW = stackPopPtr(pVM->pStack); 2257 stackPushPtr(pVM->pStack, pFW->name); 2258 stackPushUNS32(pVM->pStack, pFW->nName); 2259 return; 2260} 2261 2262 2263/************************************************************************** 2264 l b r a c k e t e t c 2265** 2266**************************************************************************/ 2267 2268static void lbracketCoIm(FICL_VM *pVM) 2269{ 2270 pVM->state = INTERPRET; 2271 return; 2272} 2273 2274 2275static void rbracket(FICL_VM *pVM) 2276{ 2277 pVM->state = COMPILE; 2278 return; 2279} 2280 2281 2282/************************************************************************** 2283 p i c t u r e d n u m e r i c w o r d s 2284** 2285** less-number-sign CORE ( -- ) 2286** Initialize the pictured numeric output conversion process. 2287** (clear the pad) 2288**************************************************************************/ 2289static void lessNumberSign(FICL_VM *pVM) 2290{ 2291 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2292 sp->count = 0; 2293 return; 2294} 2295 2296/* 2297** number-sign CORE ( ud1 -- ud2 ) 2298** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder 2299** n. (n is the least-significant digit of ud1.) Convert n to external form 2300** and add the resulting character to the beginning of the pictured numeric 2301** output string. An ambiguous condition exists if # executes outside of a 2302** <# #> delimited number conversion. 2303*/ 2304static void numberSign(FICL_VM *pVM) 2305{ 2306 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2307 UNS64 u; 2308 UNS16 rem; 2309 2310 u = u64Pop(pVM->pStack); 2311 rem = m64UMod(&u, (UNS16)(pVM->base)); 2312 sp->text[sp->count++] = digit_to_char(rem); 2313 u64Push(pVM->pStack, u); 2314 return; 2315} 2316 2317/* 2318** number-sign-greater CORE ( xd -- c-addr u ) 2319** Drop xd. Make the pictured numeric output string available as a character 2320** string. c-addr and u specify the resulting character string. A program 2321** may replace characters within the string. 2322*/ 2323static void numberSignGreater(FICL_VM *pVM) 2324{ 2325 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2326 sp->text[sp->count] = '\0'; 2327 strrev(sp->text); 2328 stackDrop(pVM->pStack, 2); 2329 stackPushPtr(pVM->pStack, sp->text); 2330 stackPushUNS32(pVM->pStack, sp->count); 2331 return; 2332} 2333 2334/* 2335** number-sign-s CORE ( ud1 -- ud2 ) 2336** Convert one digit of ud1 according to the rule for #. Continue conversion 2337** until the quotient is zero. ud2 is zero. An ambiguous condition exists if 2338** #S executes outside of a <# #> delimited number conversion. 2339** TO DO: presently does not use ud1 hi cell - use it! 2340*/ 2341static void numberSignS(FICL_VM *pVM) 2342{ 2343 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2344 UNS64 u; 2345 UNS16 rem; 2346 2347 u = u64Pop(pVM->pStack); 2348 2349 do 2350 { 2351 rem = m64UMod(&u, (UNS16)(pVM->base)); 2352 sp->text[sp->count++] = digit_to_char(rem); 2353 } 2354 while (u.hi || u.lo); 2355 2356 u64Push(pVM->pStack, u); 2357 return; 2358} 2359 2360/* 2361** HOLD CORE ( char -- ) 2362** Add char to the beginning of the pictured numeric output string. An ambiguous 2363** condition exists if HOLD executes outside of a <# #> delimited number conversion. 2364*/ 2365static void hold(FICL_VM *pVM) 2366{ 2367 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2368 int i = stackPopINT32(pVM->pStack); 2369 sp->text[sp->count++] = (char) i; 2370 return; 2371} 2372 2373/* 2374** SIGN CORE ( n -- ) 2375** If n is negative, add a minus sign to the beginning of the pictured 2376** numeric output string. An ambiguous condition exists if SIGN 2377** executes outside of a <# #> delimited number conversion. 2378*/ 2379static void sign(FICL_VM *pVM) 2380{ 2381 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2382 int i = stackPopINT32(pVM->pStack); 2383 if (i < 0) 2384 sp->text[sp->count++] = '-'; 2385 return; 2386} 2387 2388 2389/************************************************************************** 2390 t o N u m b e r 2391** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 2392** ud2 is the unsigned result of converting the characters within the 2393** string specified by c-addr1 u1 into digits, using the number in BASE, 2394** and adding each into ud1 after multiplying ud1 by the number in BASE. 2395** Conversion continues left-to-right until a character that is not 2396** convertible, including any + or -, is encountered or the string is 2397** entirely converted. c-addr2 is the location of the first unconverted 2398** character or the first character past the end of the string if the string 2399** was entirely converted. u2 is the number of unconverted characters in the 2400** string. An ambiguous condition exists if ud2 overflows during the 2401** conversion. 2402** TO DO: presently does not use ud1 hi cell - use it! 2403**************************************************************************/ 2404static void toNumber(FICL_VM *pVM) 2405{ 2406 UNS32 count = stackPopUNS32(pVM->pStack); 2407 char *cp = (char *)stackPopPtr(pVM->pStack); 2408 UNS64 accum; 2409 UNS32 base = pVM->base; 2410 UNS32 ch; 2411 UNS32 digit; 2412 2413 accum = u64Pop(pVM->pStack); 2414 2415 for (ch = *cp; count > 0; ch = *++cp, count--) 2416 { 2417 if (ch < '0') 2418 break; 2419 2420 digit = ch - '0'; 2421 2422 if (digit > 9) 2423 digit = tolower(ch) - 'a' + 10; 2424 /* 2425 ** Note: following test also catches chars between 9 and a 2426 ** because 'digit' is unsigned! 2427 */ 2428 if (digit >= base) 2429 break; 2430 2431 accum = m64Mac(accum, base, digit); 2432 } 2433 2434 u64Push(pVM->pStack, accum); 2435 stackPushPtr (pVM->pStack, cp); 2436 stackPushUNS32(pVM->pStack, count); 2437 2438 return; 2439} 2440 2441 2442 2443/************************************************************************** 2444 q u i t & a b o r t 2445** quit CORE ( -- ) ( R: i*x -- ) 2446** Empty the return stack, store zero in SOURCE-ID if it is present, make 2447** the user input device the input source, and enter interpretation state. 2448** Do not display a message. Repeat the following: 2449** 2450** Accept a line from the input source into the input buffer, set >IN to 2451** zero, and interpret. 2452** Display the implementation-defined system prompt if in 2453** interpretation state, all processing has been completed, and no 2454** ambiguous condition exists. 2455**************************************************************************/ 2456 2457static void quit(FICL_VM *pVM) 2458{ 2459 vmThrow(pVM, VM_QUIT); 2460 return; 2461} 2462 2463 2464static void ficlAbort(FICL_VM *pVM) 2465{ 2466 vmThrow(pVM, VM_ABORT); 2467 return; 2468} 2469 2470 2471/************************************************************************** 2472 a c c e p t 2473** accept CORE ( c-addr +n1 -- +n2 ) 2474** Receive a string of at most +n1 characters. An ambiguous condition 2475** exists if +n1 is zero or greater than 32,767. Display graphic characters 2476** as they are received. A program that depends on the presence or absence 2477** of non-graphic characters in the string has an environmental dependency. 2478** The editing functions, if any, that the system performs in order to 2479** construct the string are implementation-defined. 2480** 2481** (Although the standard text doesn't say so, I assume that the intent 2482** of 'accept' is to store the string at the address specified on 2483** the stack.) 2484** Implementation: if there's more text in the TIB, use it. Otherwise 2485** throw out for more text. Copy characters up to the max count into the 2486** address given, and return the number of actual characters copied. 2487** 2488** This may not strictly violate the standard, but I'm sure any programs 2489** asking for user input at load time will *not* be expecting this 2490** behavior. (sobral) 2491**************************************************************************/ 2492static void accept(FICL_VM *pVM) 2493{ 2494 UNS32 count, len; 2495 char *cp; 2496 char *pBuf = vmGetInBuf(pVM); 2497 2498 for (len = 0; pVM->tib.end != &pBuf[len] && pBuf[len]; len++); 2499 if (len == 0) 2500 vmThrow(pVM, VM_RESTART); 2501 /* OK - now we have something in the text buffer - use it */ 2502 count = stackPopUNS32(pVM->pStack); 2503 cp = stackPopPtr(pVM->pStack); 2504 2505 strncpy(cp, vmGetInBuf(pVM), count); 2506 len = (count < len) ? count : len; 2507 pBuf += len; 2508 vmUpdateTib(pVM, pBuf); 2509 stackPushUNS32(pVM->pStack, len); 2510 2511 return; 2512} 2513 2514 2515/************************************************************************** 2516 a l i g n 2517** 6.1.0705 ALIGN CORE ( -- ) 2518** If the data-space pointer is not aligned, reserve enough space to 2519** align it. 2520**************************************************************************/ 2521static void align(FICL_VM *pVM) 2522{ 2523 FICL_DICT *dp = ficlGetDict(); 2524 IGNORE(pVM); 2525 dictAlign(dp); 2526 return; 2527} 2528 2529 2530/************************************************************************** 2531 a l i g n e d 2532** 2533**************************************************************************/ 2534static void aligned(FICL_VM *pVM) 2535{ 2536 void *addr = stackPopPtr(pVM->pStack); 2537 stackPushPtr(pVM->pStack, alignPtr(addr)); 2538 return; 2539} 2540 2541 2542/************************************************************************** 2543 b e g i n & f r i e n d s 2544** Indefinite loop control structures 2545** A.6.1.0760 BEGIN 2546** Typical use: 2547** : X ... BEGIN ... test UNTIL ; 2548** or 2549** : X ... BEGIN ... test WHILE ... REPEAT ; 2550**************************************************************************/ 2551static void beginCoIm(FICL_VM *pVM) 2552{ 2553 FICL_DICT *dp = ficlGetDict(); 2554 markBranch(dp, pVM, beginTag); 2555 return; 2556} 2557 2558static void untilCoIm(FICL_VM *pVM) 2559{ 2560 FICL_DICT *dp = ficlGetDict(); 2561 2562 assert(pIfParen); 2563 2564 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 2565 resolveBackBranch(dp, pVM, beginTag); 2566 return; 2567} 2568 2569static void whileCoIm(FICL_VM *pVM) 2570{ 2571 FICL_DICT *dp = ficlGetDict(); 2572 2573 assert(pIfParen); 2574 2575 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 2576 markBranch(dp, pVM, whileTag); 2577 twoSwap(pVM); 2578 dictAppendUNS32(dp, 1); 2579 return; 2580} 2581 2582static void repeatCoIm(FICL_VM *pVM) 2583{ 2584 FICL_DICT *dp = ficlGetDict(); 2585 2586 assert(pBranchParen); 2587 dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); 2588 2589 /* expect "begin" branch marker */ 2590 resolveBackBranch(dp, pVM, beginTag); 2591 /* expect "while" branch marker */ 2592 resolveForwardBranch(dp, pVM, whileTag); 2593 return; 2594} 2595 2596 2597/************************************************************************** 2598 c h a r & f r i e n d s 2599** 6.1.0895 CHAR CORE ( "<spaces>name" -- char ) 2600** Skip leading space delimiters. Parse name delimited by a space. 2601** Put the value of its first character onto the stack. 2602** 2603** bracket-char CORE 2604** Interpretation: Interpretation semantics for this word are undefined. 2605** Compilation: ( "<spaces>name" -- ) 2606** Skip leading space delimiters. Parse name delimited by a space. 2607** Append the run-time semantics given below to the current definition. 2608** Run-time: ( -- char ) 2609** Place char, the value of the first character of name, on the stack. 2610**************************************************************************/ 2611static void ficlChar(FICL_VM *pVM) 2612{ 2613 STRINGINFO si = vmGetWord(pVM); 2614 stackPushUNS32(pVM->pStack, (UNS32)(si.cp[0])); 2615 2616 return; 2617} 2618 2619static void charCoIm(FICL_VM *pVM) 2620{ 2621 ficlChar(pVM); 2622 literalIm(pVM); 2623 return; 2624} 2625 2626/************************************************************************** 2627 c h a r P l u s 2628** char-plus CORE ( c-addr1 -- c-addr2 ) 2629** Add the size in address units of a character to c-addr1, giving c-addr2. 2630**************************************************************************/ 2631static void charPlus(FICL_VM *pVM) 2632{ 2633 char *cp = stackPopPtr(pVM->pStack); 2634 stackPushPtr(pVM->pStack, cp + 1); 2635 return; 2636} 2637 2638/************************************************************************** 2639 c h a r s 2640** chars CORE ( n1 -- n2 ) 2641** n2 is the size in address units of n1 characters. 2642** For most processors, this function can be a no-op. To guarantee 2643** portability, we'll multiply by sizeof (char). 2644**************************************************************************/ 2645#if defined (_M_IX86) 2646#pragma warning(disable: 4127) 2647#endif 2648static void ficlChars(FICL_VM *pVM) 2649{ 2650 if (sizeof (char) > 1) 2651 { 2652 INT32 i = stackPopINT32(pVM->pStack); 2653 stackPushINT32(pVM->pStack, i * sizeof (char)); 2654 } 2655 /* otherwise no-op! */ 2656 return; 2657} 2658#if defined (_M_IX86) 2659#pragma warning(default: 4127) 2660#endif 2661 2662 2663/************************************************************************** 2664 c o u n t 2665** COUNT CORE ( c-addr1 -- c-addr2 u ) 2666** Return the character string specification for the counted string stored 2667** at c-addr1. c-addr2 is the address of the first character after c-addr1. 2668** u is the contents of the character at c-addr1, which is the length in 2669** characters of the string at c-addr2. 2670**************************************************************************/ 2671static void count(FICL_VM *pVM) 2672{ 2673 FICL_STRING *sp = stackPopPtr(pVM->pStack); 2674 stackPushPtr(pVM->pStack, sp->text); 2675 stackPushUNS32(pVM->pStack, sp->count); 2676 return; 2677} 2678 2679/************************************************************************** 2680 e n v i r o n m e n t ? 2681** environment-query CORE ( c-addr u -- false | i*x true ) 2682** c-addr is the address of a character string and u is the string's 2683** character count. u may have a value in the range from zero to an 2684** implementation-defined maximum which shall not be less than 31. The 2685** character string should contain a keyword from 3.2.6 Environmental 2686** queries or the optional word sets to be checked for correspondence 2687** with an attribute of the present environment. If the system treats the 2688** attribute as unknown, the returned flag is false; otherwise, the flag 2689** is true and the i*x returned is of the type specified in the table for 2690** the attribute queried. 2691**************************************************************************/ 2692static void environmentQ(FICL_VM *pVM) 2693{ 2694 FICL_DICT *envp = ficlGetEnv(); 2695 FICL_COUNT len = (FICL_COUNT)stackPopUNS32(pVM->pStack); 2696 char *cp = stackPopPtr(pVM->pStack); 2697 FICL_WORD *pFW; 2698 STRINGINFO si; 2699 2700 SI_PSZ(si, cp); 2701 pFW = dictLookup(envp, si); 2702 2703 if (pFW != NULL) 2704 { 2705 vmExecute(pVM, pFW); 2706 stackPushINT32(pVM->pStack, FICL_TRUE); 2707 } 2708 else 2709 { 2710 stackPushINT32(pVM->pStack, FICL_FALSE); 2711 } 2712 2713 return; 2714} 2715 2716/************************************************************************** 2717 e v a l u a t e 2718** EVALUATE CORE ( i*x c-addr u -- j*x ) 2719** Save the current input source specification. Store minus-one (-1) in 2720** SOURCE-ID if it is present. Make the string described by c-addr and u 2721** both the input source andinput buffer, set >IN to zero, and interpret. 2722** When the parse area is empty, restore the prior input source 2723** specification. Other stack effects are due to the words EVALUATEd. 2724** 2725** DEFICIENCY: this version does not handle restarts. Also, exceptions 2726** are just passed ahead. Is this the Right Thing? I don't know... 2727**************************************************************************/ 2728static void evaluate(FICL_VM *pVM) 2729{ 2730 INT32 count = stackPopINT32(pVM->pStack); 2731 char *cp = stackPopPtr(pVM->pStack); 2732 CELL id; 2733 int result; 2734 2735 id = pVM->sourceID; 2736 pVM->sourceID.i = -1; 2737 vmPushIP(pVM, &pInterpret); 2738 result = ficlExec(pVM, cp, count); 2739 vmPopIP(pVM); 2740 pVM->sourceID = id; 2741 if (result != VM_OUTOFTEXT) 2742 vmThrow(pVM, result); 2743 return; 2744} 2745 2746 2747/************************************************************************** 2748 s t r i n g q u o t e 2749** Intrpreting: get string delimited by a quote from the input stream, 2750** copy to a scratch area, and put its count and address on the stack. 2751** Compiling: compile code to push the address and count of a string 2752** literal, compile the string from the input stream, and align the dict 2753** pointer. 2754**************************************************************************/ 2755static void stringQuoteIm(FICL_VM *pVM) 2756{ 2757 FICL_DICT *dp = ficlGetDict(); 2758 2759 if (pVM->state == INTERPRET) 2760 { 2761 FICL_STRING *sp = (FICL_STRING *) dp->here; 2762 vmGetString(pVM, sp, '\"'); 2763 stackPushPtr(pVM->pStack, sp->text); 2764 stackPushUNS32(pVM->pStack, sp->count); 2765 } 2766 else /* COMPILE state */ 2767 { 2768 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2769 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2770 dictAlign(dp); 2771 } 2772 2773 return; 2774} 2775 2776/************************************************************************** 2777 t y p e 2778** Pop count and char address from stack and print the designated string. 2779**************************************************************************/ 2780static void type(FICL_VM *pVM) 2781{ 2782 UNS32 count = stackPopUNS32(pVM->pStack); 2783 char *cp = stackPopPtr(pVM->pStack); 2784 char *pDest = (char *)ficlMalloc(count + 1); 2785 2786 /* 2787 ** Since we don't have an output primitive for a counted string 2788 ** (oops), make sure the string is null terminated. If not, copy 2789 ** and terminate it. 2790 */ 2791 if (!pDest) 2792 vmThrowErr(pVM, "Error: out of memory"); 2793 2794 strncpy(pDest, cp, count); 2795 pDest[count] = '\0'; 2796 2797 vmTextOut(pVM, pDest, 0); 2798 2799 ficlFree(pDest); 2800 return; 2801} 2802 2803/************************************************************************** 2804 w o r d 2805** word CORE ( char "<chars>ccc<char>" -- c-addr ) 2806** Skip leading delimiters. Parse characters ccc delimited by char. An 2807** ambiguous condition exists if the length of the parsed string is greater 2808** than the implementation-defined length of a counted string. 2809** 2810** c-addr is the address of a transient region containing the parsed word 2811** as a counted string. If the parse area was empty or contained no 2812** characters other than the delimiter, the resulting string has a zero 2813** length. A space, not included in the length, follows the string. A 2814** program may replace characters within the string. 2815** NOTE! Ficl also NULL-terminates the dest string. 2816**************************************************************************/ 2817static void ficlWord(FICL_VM *pVM) 2818{ 2819 FICL_STRING *sp = (FICL_STRING *)pVM->pad; 2820 char delim = (char)stackPopINT32(pVM->pStack); 2821 STRINGINFO si; 2822 2823 si = vmParseString(pVM, delim); 2824 2825 if (SI_COUNT(si) > nPAD-1) 2826 SI_SETLEN(si, nPAD-1); 2827 2828 sp->count = (FICL_COUNT)SI_COUNT(si); 2829 strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); 2830 strcat(sp->text, " "); 2831 2832 stackPushPtr(pVM->pStack, sp); 2833 return; 2834} 2835 2836 2837/************************************************************************** 2838 p a r s e - w o r d 2839** ficl PARSE-WORD ( <spaces>name -- c-addr u ) 2840** Skip leading spaces and parse name delimited by a space. c-addr is the 2841** address within the input buffer and u is the length of the selected 2842** string. If the parse area is empty, the resulting string has a zero length. 2843**************************************************************************/ 2844static void parseNoCopy(FICL_VM *pVM) 2845{ 2846 STRINGINFO si = vmGetWord0(pVM); 2847 stackPushPtr(pVM->pStack, SI_PTR(si)); 2848 stackPushUNS32(pVM->pStack, SI_COUNT(si)); 2849 return; 2850} 2851 2852 2853/************************************************************************** 2854 p a r s e 2855** CORE EXT ( char "ccc<char>" -- c-addr u ) 2856** Parse ccc delimited by the delimiter char. 2857** c-addr is the address (within the input buffer) and u is the length of 2858** the parsed string. If the parse area was empty, the resulting string has 2859** a zero length. 2860** NOTE! PARSE differs from WORD: it does not skip leading delimiters. 2861**************************************************************************/ 2862static void parse(FICL_VM *pVM) 2863{ 2864 char *pSrc = vmGetInBuf(pVM); 2865 char *cp; 2866 UNS32 count; 2867 char delim = (char)stackPopINT32(pVM->pStack); 2868 2869 cp = pSrc; /* mark start of text */ 2870 2871 while ((pVM->tib.end != pSrc) && (*pSrc != delim) && (*pSrc != '\0')) 2872 pSrc++; /* find next delimiter or end */ 2873 2874 count = pSrc - cp; /* set length of result */ 2875 2876 if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */ 2877 pSrc++; 2878 2879 vmUpdateTib(pVM, pSrc); 2880 stackPushPtr(pVM->pStack, cp); 2881 stackPushUNS32(pVM->pStack, count); 2882 return; 2883} 2884 2885 2886/************************************************************************** 2887 f i l l 2888** CORE ( c-addr u char -- ) 2889** If u is greater than zero, store char in each of u consecutive 2890** characters of memory beginning at c-addr. 2891**************************************************************************/ 2892static void fill(FICL_VM *pVM) 2893{ 2894 char ch = (char)stackPopINT32(pVM->pStack); 2895 UNS32 u = stackPopUNS32(pVM->pStack); 2896 char *cp = (char *)stackPopPtr(pVM->pStack); 2897 2898 while (u > 0) 2899 { 2900 *cp++ = ch; 2901 u--; 2902 } 2903 2904 return; 2905} 2906 2907 2908/************************************************************************** 2909 f i n d 2910** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 2911** Find the definition named in the counted string at c-addr. If the 2912** definition is not found, return c-addr and zero. If the definition is 2913** found, return its execution token xt. If the definition is immediate, 2914** also return one (1), otherwise also return minus-one (-1). For a given 2915** string, the values returned by FIND while compiling may differ from 2916** those returned while not compiling. 2917**************************************************************************/ 2918static void find(FICL_VM *pVM) 2919{ 2920 FICL_STRING *sp = stackPopPtr(pVM->pStack); 2921 FICL_WORD *pFW; 2922 STRINGINFO si; 2923 2924 SI_PFS(si, sp); 2925 pFW = dictLookup(ficlGetDict(), si); 2926 if (pFW) 2927 { 2928 stackPushPtr(pVM->pStack, pFW); 2929 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 2930 } 2931 else 2932 { 2933 stackPushPtr(pVM->pStack, sp); 2934 stackPushUNS32(pVM->pStack, 0); 2935 } 2936 return; 2937} 2938 2939 2940/************************************************************************** 2941 f m S l a s h M o d 2942** f-m-slash-mod CORE ( d1 n1 -- n2 n3 ) 2943** Divide d1 by n1, giving the floored quotient n3 and the remainder n2. 2944** Input and output stack arguments are signed. An ambiguous condition 2945** exists if n1 is zero or if the quotient lies outside the range of a 2946** single-cell signed integer. 2947**************************************************************************/ 2948static void fmSlashMod(FICL_VM *pVM) 2949{ 2950 INT64 d1; 2951 INT32 n1; 2952 INTQR qr; 2953 2954 n1 = stackPopINT32(pVM->pStack); 2955 d1 = i64Pop(pVM->pStack); 2956 qr = m64FlooredDivI(d1, n1); 2957 stackPushINT32(pVM->pStack, qr.rem); 2958 stackPushINT32(pVM->pStack, qr.quot); 2959 return; 2960} 2961 2962 2963/************************************************************************** 2964 s m S l a s h R e m 2965** s-m-slash-rem CORE ( d1 n1 -- n2 n3 ) 2966** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. 2967** Input and output stack arguments are signed. An ambiguous condition 2968** exists if n1 is zero or if the quotient lies outside the range of a 2969** single-cell signed integer. 2970**************************************************************************/ 2971static void smSlashRem(FICL_VM *pVM) 2972{ 2973 INT64 d1; 2974 INT32 n1; 2975 INTQR qr; 2976 2977 n1 = stackPopINT32(pVM->pStack); 2978 d1 = i64Pop(pVM->pStack); 2979 qr = m64SymmetricDivI(d1, n1); 2980 stackPushINT32(pVM->pStack, qr.rem); 2981 stackPushINT32(pVM->pStack, qr.quot); 2982 return; 2983} 2984 2985 2986static void ficlMod(FICL_VM *pVM) 2987{ 2988 INT64 d1; 2989 INT32 n1; 2990 INTQR qr; 2991 2992 n1 = stackPopINT32(pVM->pStack); 2993 d1.lo = stackPopINT32(pVM->pStack); 2994 i64Extend(d1); 2995 qr = m64SymmetricDivI(d1, n1); 2996 stackPushINT32(pVM->pStack, qr.rem); 2997 return; 2998} 2999 3000 3001/************************************************************************** 3002 u m S l a s h M o d 3003** u-m-slash-mod CORE ( ud u1 -- u2 u3 ) 3004** Divide ud by u1, giving the quotient u3 and the remainder u2. 3005** All values and arithmetic are unsigned. An ambiguous condition 3006** exists if u1 is zero or if the quotient lies outside the range of a 3007** single-cell unsigned integer. 3008*************************************************************************/ 3009static void umSlashMod(FICL_VM *pVM) 3010{ 3011 UNS64 ud; 3012 UNS32 u1; 3013 UNSQR qr; 3014 3015 u1 = stackPopUNS32(pVM->pStack); 3016 ud = u64Pop(pVM->pStack); 3017 qr = ficlLongDiv(ud, u1); 3018 stackPushUNS32(pVM->pStack, qr.rem); 3019 stackPushUNS32(pVM->pStack, qr.quot); 3020 return; 3021} 3022 3023 3024/************************************************************************** 3025 l s h i f t 3026** l-shift CORE ( x1 u -- x2 ) 3027** Perform a logical left shift of u bit-places on x1, giving x2. 3028** Put zeroes into the least significant bits vacated by the shift. 3029** An ambiguous condition exists if u is greater than or equal to the 3030** number of bits in a cell. 3031** 3032** r-shift CORE ( x1 u -- x2 ) 3033** Perform a logical right shift of u bit-places on x1, giving x2. 3034** Put zeroes into the most significant bits vacated by the shift. An 3035** ambiguous condition exists if u is greater than or equal to the 3036** number of bits in a cell. 3037**************************************************************************/ 3038static void lshift(FICL_VM *pVM) 3039{ 3040 UNS32 nBits = stackPopUNS32(pVM->pStack); 3041 UNS32 x1 = stackPopUNS32(pVM->pStack); 3042 3043 stackPushUNS32(pVM->pStack, x1 << nBits); 3044 return; 3045} 3046 3047 3048static void rshift(FICL_VM *pVM) 3049{ 3050 UNS32 nBits = stackPopUNS32(pVM->pStack); 3051 UNS32 x1 = stackPopUNS32(pVM->pStack); 3052 3053 stackPushUNS32(pVM->pStack, x1 >> nBits); 3054 return; 3055} 3056 3057 3058/************************************************************************** 3059 m S t a r 3060** m-star CORE ( n1 n2 -- d ) 3061** d is the signed product of n1 times n2. 3062**************************************************************************/ 3063static void mStar(FICL_VM *pVM) 3064{ 3065 INT32 n2 = stackPopINT32(pVM->pStack); 3066 INT32 n1 = stackPopINT32(pVM->pStack); 3067 INT64 d; 3068 3069 d = m64MulI(n1, n2); 3070 i64Push(pVM->pStack, d); 3071 return; 3072} 3073 3074 3075static void umStar(FICL_VM *pVM) 3076{ 3077 UNS32 u2 = stackPopUNS32(pVM->pStack); 3078 UNS32 u1 = stackPopUNS32(pVM->pStack); 3079 UNS64 ud; 3080 3081 ud = ficlLongMul(u1, u2); 3082 u64Push(pVM->pStack, ud); 3083 return; 3084} 3085 3086 3087/************************************************************************** 3088 m a x & m i n 3089** 3090**************************************************************************/ 3091static void ficlMax(FICL_VM *pVM) 3092{ 3093 INT32 n2 = stackPopINT32(pVM->pStack); 3094 INT32 n1 = stackPopINT32(pVM->pStack); 3095 3096 stackPushINT32(pVM->pStack, (n1 > n2) ? n1 : n2); 3097 return; 3098} 3099 3100static void ficlMin(FICL_VM *pVM) 3101{ 3102 INT32 n2 = stackPopINT32(pVM->pStack); 3103 INT32 n1 = stackPopINT32(pVM->pStack); 3104 3105 stackPushINT32(pVM->pStack, (n1 < n2) ? n1 : n2); 3106 return; 3107} 3108 3109 3110/************************************************************************** 3111 m o v e 3112** CORE ( addr1 addr2 u -- ) 3113** If u is greater than zero, copy the contents of u consecutive address 3114** units at addr1 to the u consecutive address units at addr2. After MOVE 3115** completes, the u consecutive address units at addr2 contain exactly 3116** what the u consecutive address units at addr1 contained before the move. 3117** NOTE! This implementation assumes that a char is the same size as 3118** an address unit. 3119**************************************************************************/ 3120static void move(FICL_VM *pVM) 3121{ 3122 UNS32 u = stackPopUNS32(pVM->pStack); 3123 char *addr2 = stackPopPtr(pVM->pStack); 3124 char *addr1 = stackPopPtr(pVM->pStack); 3125 3126 if (u == 0) 3127 return; 3128 /* 3129 ** Do the copy carefully, so as to be 3130 ** correct even if the two ranges overlap 3131 */ 3132 if (addr1 >= addr2) 3133 { 3134 for (; u > 0; u--) 3135 *addr2++ = *addr1++; 3136 } 3137 else 3138 { 3139 addr2 += u-1; 3140 addr1 += u-1; 3141 for (; u > 0; u--) 3142 *addr2-- = *addr1--; 3143 } 3144 3145 return; 3146} 3147 3148 3149/************************************************************************** 3150 r e c u r s e 3151** 3152**************************************************************************/ 3153static void recurseCoIm(FICL_VM *pVM) 3154{ 3155 FICL_DICT *pDict = ficlGetDict(); 3156 3157 IGNORE(pVM); 3158 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge)); 3159 return; 3160} 3161 3162 3163/************************************************************************** 3164 s t o d 3165** s-to-d CORE ( n -- d ) 3166** Convert the number n to the double-cell number d with the same 3167** numerical value. 3168**************************************************************************/ 3169static void sToD(FICL_VM *pVM) 3170{ 3171 INT32 s = stackPopINT32(pVM->pStack); 3172 3173 /* sign extend to 64 bits.. */ 3174 stackPushINT32(pVM->pStack, s); 3175 stackPushINT32(pVM->pStack, (s < 0) ? -1 : 0); 3176 return; 3177} 3178 3179 3180/************************************************************************** 3181 s o u r c e 3182** CORE ( -- c-addr u ) 3183** c-addr is the address of, and u is the number of characters in, the 3184** input buffer. 3185**************************************************************************/ 3186static void source(FICL_VM *pVM) 3187{ int i; 3188 3189 stackPushPtr(pVM->pStack, pVM->tib.cp); 3190 for (i = 0; (pVM->tib.end != &pVM->tib.cp[i]) && pVM->tib.cp[i]; i++); 3191 stackPushINT32(pVM->pStack, i); 3192 return; 3193} 3194 3195 3196/************************************************************************** 3197 v e r s i o n 3198** non-standard... 3199**************************************************************************/ 3200static void ficlVersion(FICL_VM *pVM) 3201{ 3202 vmTextOut(pVM, "ficl Version " FICL_VER, 1); 3203 return; 3204} 3205 3206 3207/************************************************************************** 3208 t o I n 3209** to-in CORE 3210**************************************************************************/ 3211static void toIn(FICL_VM *pVM) 3212{ 3213 stackPushPtr(pVM->pStack, &pVM->tib.index); 3214 return; 3215} 3216 3217 3218/************************************************************************** 3219 d e f i n i t i o n s 3220** SEARCH ( -- ) 3221** Make the compilation word list the same as the first word list in the 3222** search order. Specifies that the names of subsequent definitions will 3223** be placed in the compilation word list. Subsequent changes in the search 3224** order will not affect the compilation word list. 3225**************************************************************************/ 3226static void definitions(FICL_VM *pVM) 3227{ 3228 FICL_DICT *pDict = ficlGetDict(); 3229 3230 assert(pDict); 3231 if (pDict->nLists < 1) 3232 { 3233 vmThrowErr(pVM, "DEFINITIONS error - empty search order"); 3234 } 3235 3236 pDict->pCompile = pDict->pSearch[pDict->nLists-1]; 3237 return; 3238} 3239 3240 3241/************************************************************************** 3242 f o r t h - w o r d l i s t 3243** SEARCH ( -- wid ) 3244** Return wid, the identifier of the word list that includes all standard 3245** words provided by the implementation. This word list is initially the 3246** compilation word list and is part of the initial search order. 3247**************************************************************************/ 3248static void forthWordlist(FICL_VM *pVM) 3249{ 3250 FICL_HASH *pHash = ficlGetDict()->pForthWords; 3251 stackPushPtr(pVM->pStack, pHash); 3252 return; 3253} 3254 3255 3256/************************************************************************** 3257 g e t - c u r r e n t 3258** SEARCH ( -- wid ) 3259** Return wid, the identifier of the compilation word list. 3260**************************************************************************/ 3261static void getCurrent(FICL_VM *pVM) 3262{ 3263 ficlLockDictionary(TRUE); 3264 stackPushPtr(pVM->pStack, ficlGetDict()->pCompile); 3265 ficlLockDictionary(FALSE); 3266 return; 3267} 3268 3269 3270/************************************************************************** 3271 g e t - o r d e r 3272** SEARCH ( -- widn ... wid1 n ) 3273** Returns the number of word lists n in the search order and the word list 3274** identifiers widn ... wid1 identifying these word lists. wid1 identifies 3275** the word list that is searched first, and widn the word list that is 3276** searched last. The search order is unaffected. 3277**************************************************************************/ 3278static void getOrder(FICL_VM *pVM) 3279{ 3280 FICL_DICT *pDict = ficlGetDict(); 3281 int nLists = pDict->nLists; 3282 int i; 3283 3284 ficlLockDictionary(TRUE); 3285 for (i = 0; i < nLists; i++) 3286 { 3287 stackPushPtr(pVM->pStack, pDict->pSearch[i]); 3288 } 3289 3290 stackPushUNS32(pVM->pStack, nLists); 3291 ficlLockDictionary(FALSE); 3292 return; 3293} 3294 3295 3296/************************************************************************** 3297 s e a r c h - w o r d l i s t 3298** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) 3299** Find the definition identified by the string c-addr u in the word list 3300** identified by wid. If the definition is not found, return zero. If the 3301** definition is found, return its execution token xt and one (1) if the 3302** definition is immediate, minus-one (-1) otherwise. 3303**************************************************************************/ 3304static void searchWordlist(FICL_VM *pVM) 3305{ 3306 STRINGINFO si; 3307 UNS16 hashCode; 3308 FICL_WORD *pFW; 3309 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 3310 3311 si.count = (FICL_COUNT)stackPopUNS32(pVM->pStack); 3312 si.cp = stackPopPtr(pVM->pStack); 3313 hashCode = hashHashCode(si); 3314 3315 ficlLockDictionary(TRUE); 3316 pFW = hashLookup(pHash, si, hashCode); 3317 ficlLockDictionary(FALSE); 3318 3319 if (pFW) 3320 { 3321 stackPushPtr(pVM->pStack, pFW); 3322 stackPushINT32(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 3323 } 3324 else 3325 { 3326 stackPushUNS32(pVM->pStack, 0); 3327 } 3328 3329 return; 3330} 3331 3332 3333/************************************************************************** 3334 s e t - c u r r e n t 3335** SEARCH ( wid -- ) 3336** Set the compilation word list to the word list identified by wid. 3337**************************************************************************/ 3338static void setCurrent(FICL_VM *pVM) 3339{ 3340 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 3341 FICL_DICT *pDict = ficlGetDict(); 3342 ficlLockDictionary(TRUE); 3343 pDict->pCompile = pHash; 3344 ficlLockDictionary(FALSE); 3345 return; 3346} 3347 3348 3349/************************************************************************** 3350 s e t - o r d e r 3351** SEARCH ( widn ... wid1 n -- ) 3352** Set the search order to the word lists identified by widn ... wid1. 3353** Subsequently, word list wid1 will be searched first, and word list 3354** widn searched last. If n is zero, empty the search order. If n is minus 3355** one, set the search order to the implementation-defined minimum 3356** search order. The minimum search order shall include the words 3357** FORTH-WORDLIST and SET-ORDER. A system shall allow n to 3358** be at least eight. 3359**************************************************************************/ 3360static void setOrder(FICL_VM *pVM) 3361{ 3362 int i; 3363 int nLists = stackPopINT32(pVM->pStack); 3364 FICL_DICT *dp = ficlGetDict(); 3365 3366 if (nLists > FICL_DEFAULT_VOCS) 3367 { 3368 vmThrowErr(pVM, "set-order error: list would be too large"); 3369 } 3370 3371 ficlLockDictionary(TRUE); 3372 3373 if (nLists >= 0) 3374 { 3375 dp->nLists = nLists; 3376 for (i = nLists-1; i >= 0; --i) 3377 { 3378 dp->pSearch[i] = stackPopPtr(pVM->pStack); 3379 } 3380 } 3381 else 3382 { 3383 dictResetSearchOrder(dp); 3384 } 3385 3386 ficlLockDictionary(FALSE); 3387 return; 3388} 3389 3390 3391/************************************************************************** 3392 w o r d l i s t 3393** SEARCH ( -- wid ) 3394** Create a new empty word list, returning its word list identifier wid. 3395** The new word list may be returned from a pool of preallocated word 3396** lists or may be dynamically allocated in data space. A system shall 3397** allow the creation of at least 8 new word lists in addition to any 3398** provided as part of the system. 3399** Notes: 3400** 1. ficl creates a new single-list hash in the dictionary and returns 3401** its address. 3402** 2. ficl-wordlist takes an arg off the stack indicating the number of 3403** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as 3404** : wordlist 1 ficl-wordlist ; 3405**************************************************************************/ 3406static void wordlist(FICL_VM *pVM) 3407{ 3408 FICL_DICT *dp = ficlGetDict(); 3409 FICL_HASH *pHash; 3410 UNS32 nBuckets; 3411 3412#if FICL_ROBUST > 1 3413 vmCheckStack(pVM, 1, 1); 3414#endif 3415 nBuckets = stackPopUNS32(pVM->pStack); 3416 3417 dictAlign(dp); 3418 pHash = (FICL_HASH *)dp->here; 3419 dictAllot(dp, sizeof (FICL_HASH) 3420 + (nBuckets-1) * sizeof (FICL_WORD *)); 3421 3422 pHash->size = nBuckets; 3423 hashReset(pHash); 3424 3425 stackPushPtr(pVM->pStack, pHash); 3426 return; 3427} 3428 3429 3430/************************************************************************** 3431 S E A R C H > 3432** ficl ( -- wid ) 3433** Pop wid off the search order. Error if the search order is empty 3434**************************************************************************/ 3435static void searchPop(FICL_VM *pVM) 3436{ 3437 FICL_DICT *dp = ficlGetDict(); 3438 int nLists; 3439 3440 ficlLockDictionary(TRUE); 3441 nLists = dp->nLists; 3442 if (nLists == 0) 3443 { 3444 vmThrowErr(pVM, "search> error: empty search order"); 3445 } 3446 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); 3447 ficlLockDictionary(FALSE); 3448 return; 3449} 3450 3451 3452/************************************************************************** 3453 > S E A R C H 3454** ficl ( wid -- ) 3455** Push wid onto the search order. Error if the search order is full. 3456**************************************************************************/ 3457static void searchPush(FICL_VM *pVM) 3458{ 3459 FICL_DICT *dp = ficlGetDict(); 3460 3461 ficlLockDictionary(TRUE); 3462 if (dp->nLists > FICL_DEFAULT_VOCS) 3463 { 3464 vmThrowErr(pVM, ">search error: search order overflow"); 3465 } 3466 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); 3467 ficlLockDictionary(FALSE); 3468 return; 3469} 3470 3471 3472/************************************************************************** 3473 c o l o n N o N a m e 3474** CORE EXT ( C: -- colon-sys ) ( S: -- xt ) 3475** Create an unnamed colon definition and push its address. 3476** Change state to compile. 3477**************************************************************************/ 3478static void colonNoName(FICL_VM *pVM) 3479{ 3480 FICL_DICT *dp = ficlGetDict(); 3481 FICL_WORD *pFW; 3482 STRINGINFO si; 3483 3484 SI_SETLEN(si, 0); 3485 SI_SETPTR(si, NULL); 3486 3487 pVM->state = COMPILE; 3488 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 3489 stackPushPtr(pVM->pStack, pFW); 3490 markControlTag(pVM, colonTag); 3491 return; 3492} 3493 3494 3495/************************************************************************** 3496 u s e r V a r i a b l e 3497** user ( u -- ) "<spaces>name" 3498** Get a name from the input stream and create a user variable 3499** with the name and the index supplied. The run-time effect 3500** of a user variable is to push the address of the indexed cell 3501** in the running vm's user array. 3502** 3503** User variables are vm local cells. Each vm has an array of 3504** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero. 3505** Ficl's user facility is implemented with two primitives, 3506** "user" and "(user)", a variable ("nUser") (in softcore.c) that 3507** holds the index of the next free user cell, and a redefinition 3508** (also in softcore) of "user" that defines a user word and increments 3509** nUser. 3510**************************************************************************/ 3511#if FICL_WANT_USER 3512static void userParen(FICL_VM *pVM) 3513{ 3514 INT32 i = pVM->runningWord->param[0].i; 3515 stackPushPtr(pVM->pStack, &pVM->user[i]); 3516 return; 3517} 3518 3519 3520static void userVariable(FICL_VM *pVM) 3521{ 3522 FICL_DICT *dp = ficlGetDict(); 3523 STRINGINFO si = vmGetWord(pVM); 3524 CELL c; 3525 3526 c = stackPop(pVM->pStack); 3527 if (c.i >= FICL_USER_CELLS) 3528 { 3529 vmThrowErr(pVM, "Error - out of user space"); 3530 } 3531 3532 dictAppendWord2(dp, si, userParen, FW_DEFAULT); 3533 dictAppendCell(dp, c); 3534 return; 3535} 3536#endif 3537 3538 3539/************************************************************************** 3540 t o V a l u e 3541** CORE EXT 3542** Interpretation: ( x "<spaces>name" -- ) 3543** Skip leading spaces and parse name delimited by a space. Store x in 3544** name. An ambiguous condition exists if name was not defined by VALUE. 3545** NOTE: In ficl, VALUE is an alias of CONSTANT 3546**************************************************************************/ 3547static void toValue(FICL_VM *pVM) 3548{ 3549 STRINGINFO si = vmGetWord(pVM); 3550 FICL_DICT *dp = ficlGetDict(); 3551 FICL_WORD *pFW; 3552 3553#if FICL_WANT_LOCALS 3554 FICL_DICT *pLoc = ficlGetLoc(); 3555 if ((nLocals > 0) && (pVM->state == COMPILE)) 3556 { 3557 pFW = dictLookup(pLoc, si); 3558 if (pFW) 3559 { 3560 dictAppendCell(dp, LVALUEtoCELL(pToLocalParen)); 3561 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 3562 return; 3563 } 3564 } 3565#endif 3566 3567 assert(pStore); 3568 3569 pFW = dictLookup(dp, si); 3570 if (!pFW) 3571 { 3572 int i = SI_COUNT(si); 3573 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 3574 } 3575 3576 if (pVM->state == INTERPRET) 3577 pFW->param[0] = stackPop(pVM->pStack); 3578 else /* compile code to store to word's param */ 3579 { 3580 stackPushPtr(pVM->pStack, &pFW->param[0]); 3581 literalIm(pVM); 3582 dictAppendCell(dp, LVALUEtoCELL(pStore)); 3583 } 3584 return; 3585} 3586 3587 3588#if FICL_WANT_LOCALS 3589/************************************************************************** 3590 l i n k P a r e n 3591** ( -- ) 3592** Link a frame on the return stack, reserving nCells of space for 3593** locals - the value of nCells is the next cell in the instruction 3594** stream. 3595**************************************************************************/ 3596static void linkParen(FICL_VM *pVM) 3597{ 3598 INT32 nLink = *(INT32 *)(pVM->ip); 3599 vmBranchRelative(pVM, 1); 3600 stackLink(pVM->rStack, nLink); 3601 return; 3602} 3603 3604 3605static void unlinkParen(FICL_VM *pVM) 3606{ 3607 stackUnlink(pVM->rStack); 3608 return; 3609} 3610 3611 3612/************************************************************************** 3613 d o L o c a l I m 3614** Immediate - cfa of a local while compiling - when executed, compiles 3615** code to fetch the value of a local given the local's index in the 3616** word's pfa 3617**************************************************************************/ 3618static void getLocalParen(FICL_VM *pVM) 3619{ 3620 INT32 nLocal = *(INT32 *)(pVM->ip++); 3621 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3622 return; 3623} 3624 3625 3626static void toLocalParen(FICL_VM *pVM) 3627{ 3628 INT32 nLocal = *(INT32 *)(pVM->ip++); 3629 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 3630 return; 3631} 3632 3633 3634static void getLocal0(FICL_VM *pVM) 3635{ 3636 stackPush(pVM->pStack, pVM->rStack->pFrame[0]); 3637 return; 3638} 3639 3640 3641static void toLocal0(FICL_VM *pVM) 3642{ 3643 pVM->rStack->pFrame[0] = stackPop(pVM->pStack); 3644 return; 3645} 3646 3647 3648static void getLocal1(FICL_VM *pVM) 3649{ 3650 stackPush(pVM->pStack, pVM->rStack->pFrame[1]); 3651 return; 3652} 3653 3654 3655static void toLocal1(FICL_VM *pVM) 3656{ 3657 pVM->rStack->pFrame[1] = stackPop(pVM->pStack); 3658 return; 3659} 3660 3661 3662/* 3663** Each local is recorded in a private locals dictionary as a 3664** word that does doLocalIm at runtime. DoLocalIm compiles code 3665** into the client definition to fetch the value of the 3666** corresponding local variable from the return stack. 3667** The private dictionary gets initialized at the end of each block 3668** that uses locals (in ; and does> for example). 3669*/ 3670static void doLocalIm(FICL_VM *pVM) 3671{ 3672 FICL_DICT *pDict = ficlGetDict(); 3673 int nLocal = pVM->runningWord->param[0].i; 3674 3675 if (pVM->state == INTERPRET) 3676 { 3677 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3678 } 3679 else 3680 { 3681 3682 if (nLocal == 0) 3683 { 3684 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0)); 3685 } 3686 else if (nLocal == 1) 3687 { 3688 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1)); 3689 } 3690 else 3691 { 3692 dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen)); 3693 dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 3694 } 3695 } 3696 return; 3697} 3698 3699 3700/************************************************************************** 3701 l o c a l P a r e n 3702** paren-local-paren LOCAL 3703** Interpretation: Interpretation semantics for this word are undefined. 3704** Execution: ( c-addr u -- ) 3705** When executed during compilation, (LOCAL) passes a message to the 3706** system that has one of two meanings. If u is non-zero, 3707** the message identifies a new local whose definition name is given by 3708** the string of characters identified by c-addr u. If u is zero, 3709** the message is last local and c-addr has no significance. 3710** 3711** The result of executing (LOCAL) during compilation of a definition is 3712** to create a set of named local identifiers, each of which is 3713** a definition name, that only have execution semantics within the scope 3714** of that definition's source. 3715** 3716** local Execution: ( -- x ) 3717** 3718** Push the local's value, x, onto the stack. The local's value is 3719** initialized as described in 13.3.3 Processing locals and may be 3720** changed by preceding the local's name with TO. An ambiguous condition 3721** exists when local is executed while in interpretation state. 3722**************************************************************************/ 3723static void localParen(FICL_VM *pVM) 3724{ 3725 static CELL *pMark = NULL; 3726 FICL_DICT *pDict = ficlGetDict(); 3727 STRINGINFO si; 3728 SI_SETLEN(si, stackPopUNS32(pVM->pStack)); 3729 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); 3730 3731 if (SI_COUNT(si) > 0) 3732 { /* add a local to the dict and update nLocals */ 3733 FICL_DICT *pLoc = ficlGetLoc(); 3734 if (nLocals >= FICL_MAX_LOCALS) 3735 { 3736 vmThrowErr(pVM, "Error: out of local space"); 3737 } 3738 3739 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); 3740 dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); 3741 3742 if (nLocals == 0) 3743 { /* compile code to create a local stack frame */ 3744 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); 3745 /* save location in dictionary for #locals */ 3746 pMark = pDict->here; 3747 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3748 /* compile code to initialize first local */ 3749 dictAppendCell(pDict, LVALUEtoCELL(pToLocal0)); 3750 } 3751 else if (nLocals == 1) 3752 { 3753 dictAppendCell(pDict, LVALUEtoCELL(pToLocal1)); 3754 } 3755 else 3756 { 3757 dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen)); 3758 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3759 } 3760 3761 nLocals++; 3762 } 3763 else if (nLocals > 0) 3764 { /* write nLocals to (link) param area in dictionary */ 3765 *(INT32 *)pMark = nLocals; 3766 } 3767 3768 return; 3769} 3770 3771 3772#endif 3773/************************************************************************** 3774 setParentWid 3775** FICL 3776** setparentwid ( parent-wid wid -- ) 3777** Set WID's link field to the parent-wid. search-wordlist will 3778** iterate through all the links when finding words in the child wid. 3779**************************************************************************/ 3780static void setParentWid(FICL_VM *pVM) 3781{ 3782 FICL_HASH *parent, *child; 3783#if FICL_ROBUST > 1 3784 vmCheckStack(pVM, 2, 0); 3785#endif 3786 child = (FICL_HASH *)stackPopPtr(pVM->pStack); 3787 parent = (FICL_HASH *)stackPopPtr(pVM->pStack); 3788 3789 child->link = parent; 3790 return; 3791} 3792 3793 3794/************************************************************************** 3795 s e e 3796** TOOLS ( "<spaces>name" -- ) 3797** Display a human-readable representation of the named word's definition. 3798** The source of the representation (object-code decompilation, source 3799** block, etc.) and the particular form of the display is implementation 3800** defined. 3801** NOTE: these funcs come late in the file because they reference all 3802** of the word-builder funcs without declaring them again. Call me lazy. 3803**************************************************************************/ 3804/* 3805** isAFiclWord 3806** Vet a candidate pointer carefully to make sure 3807** it's not some chunk o' inline data... 3808** It has to have a name, and it has to look 3809** like it's in the dictionary address range. 3810** NOTE: this excludes :noname words! 3811*/ 3812#ifdef FICL_TRACE 3813int isAFiclWord(FICL_WORD *pFW) 3814#else 3815static int isAFiclWord(FICL_WORD *pFW) 3816#endif 3817{ 3818 void *pv = (void *)pFW; 3819 FICL_DICT *pd = ficlGetDict(); 3820 3821 if (!dictIncludes(pd, pFW)) 3822 return 0; 3823 3824 if (!dictIncludes(pd, pFW->name)) 3825 return 0; 3826 3827 return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0')); 3828} 3829 3830/* 3831** seeColon (for proctologists only) 3832** Walks a colon definition, decompiling 3833** on the fly. Knows about primitive control structures. 3834*/ 3835static void seeColon(FICL_VM *pVM, CELL *pc) 3836{ 3837 for (; pc->p != pSemiParen; pc++) 3838 { 3839 FICL_WORD *pFW = (FICL_WORD *)(pc->p); 3840 3841 if (isAFiclWord(pFW)) 3842 { 3843 if (pFW->code == literalParen) 3844 { 3845 CELL v = *++pc; 3846 if (isAFiclWord(v.p)) 3847 { 3848 FICL_WORD *pLit = (FICL_WORD *)v.p; 3849 sprintf(pVM->pad, " literal %.*s (%#lx)", 3850 pLit->nName, pLit->name, v.u); 3851 } 3852 else 3853 sprintf(pVM->pad, " literal %ld (%#lx)", v.i, v.u); 3854 } 3855 else if (pFW->code == stringLit) 3856 { 3857 FICL_STRING *sp = (FICL_STRING *)(void *)++pc; 3858 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; 3859 sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text); 3860 } 3861 else if (pFW->code == ifParen) 3862 { 3863 CELL c = *++pc; 3864 if (c.i > 0) 3865 sprintf(pVM->pad, " if / while (branch rel %ld)", c.i); 3866 else 3867 sprintf(pVM->pad, " until (branch rel %ld)", c.i); 3868 } 3869 else if (pFW->code == branchParen) 3870 { 3871 CELL c = *++pc; 3872 if (c.i > 0) 3873 sprintf(pVM->pad, " else (branch rel %ld)", c.i); 3874 else 3875 sprintf(pVM->pad, " repeat (branch rel %ld)", c.i); 3876 } 3877 else if (pFW->code == qDoParen) 3878 { 3879 CELL c = *++pc; 3880 sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u); 3881 } 3882 else if (pFW->code == doParen) 3883 { 3884 CELL c = *++pc; 3885 sprintf(pVM->pad, " do (leave abs %#lx)", c.u); 3886 } 3887 else if (pFW->code == loopParen) 3888 { 3889 CELL c = *++pc; 3890 sprintf(pVM->pad, " loop (branch rel %#ld)", c.i); 3891 } 3892 else if (pFW->code == plusLoopParen) 3893 { 3894 CELL c = *++pc; 3895 sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i); 3896 } 3897 else /* default: print word's name */ 3898 { 3899 sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name); 3900 } 3901 3902 vmTextOut(pVM, pVM->pad, 1); 3903 } 3904 else /* probably not a word - punt and print value */ 3905 { 3906 sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u); 3907 vmTextOut(pVM, pVM->pad, 1); 3908 } 3909 } 3910 3911 vmTextOut(pVM, ";", 1); 3912} 3913 3914/* 3915** Here's the outer part of the decompiler. It's 3916** just a big nested conditional that checks the 3917** CFA of the word to decompile for each kind of 3918** known word-builder code, and tries to do 3919** something appropriate. If the CFA is not recognized, 3920** just indicate that it is a primitive. 3921*/ 3922static void see(FICL_VM *pVM) 3923{ 3924 FICL_DICT *pd = ficlGetDict(); 3925 FICL_WORD *pFW; 3926 3927 tick(pVM); 3928 pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); 3929 3930 if (pFW->code == colonParen) 3931 { 3932 sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name); 3933 vmTextOut(pVM, pVM->pad, 1); 3934 seeColon(pVM, pFW->param); 3935 } 3936 else if (pFW->code == doDoes) 3937 { 3938 vmTextOut(pVM, "does>", 1); 3939 seeColon(pVM, (CELL *)pFW->param->p); 3940 } 3941 else if (pFW->code == createParen) 3942 { 3943 vmTextOut(pVM, "create", 1); 3944 } 3945 else if (pFW->code == variableParen) 3946 { 3947 sprintf(pVM->pad, "variable = %ld (%#lx)", 3948 pFW->param->i, pFW->param->u); 3949 vmTextOut(pVM, pVM->pad, 1); 3950 } 3951 else if (pFW->code == userParen) 3952 { 3953 sprintf(pVM->pad, "user variable %ld (%#lx)", 3954 pFW->param->i, pFW->param->u); 3955 vmTextOut(pVM, pVM->pad, 1); 3956 } 3957 else if (pFW->code == constantParen) 3958 { 3959 sprintf(pVM->pad, "constant = %ld (%#lx)", 3960 pFW->param->i, pFW->param->u); 3961 vmTextOut(pVM, pVM->pad, 1); 3962 } 3963 else 3964 { 3965 vmTextOut(pVM, "primitive", 1); 3966 } 3967 3968 if (pFW->flags & FW_IMMEDIATE) 3969 { 3970 vmTextOut(pVM, "immediate", 1); 3971 } 3972 3973 return; 3974} 3975 3976 3977/************************************************************************** 3978 c o m p a r e 3979** STRING ( c-addr1 u1 c-addr2 u2 -- n ) 3980** Compare the string specified by c-addr1 u1 to the string specified by 3981** c-addr2 u2. The strings are compared, beginning at the given addresses, 3982** character by character, up to the length of the shorter string or until a 3983** difference is found. If the two strings are identical, n is zero. If the two 3984** strings are identical up to the length of the shorter string, n is minus-one 3985** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not 3986** identical up to the length of the shorter string, n is minus-one (-1) if the 3987** first non-matching character in the string specified by c-addr1 u1 has a 3988** lesser numeric value than the corresponding character in the string specified 3989** by c-addr2 u2 and one (1) otherwise. 3990**************************************************************************/ 3991static void compareString(FICL_VM *pVM) 3992{ 3993 char *cp1, *cp2; 3994 UNS32 u1, u2, uMin; 3995 int n = 0; 3996 3997 vmCheckStack(pVM, 4, 1); 3998 u2 = stackPopUNS32(pVM->pStack); 3999 cp2 = (char *)stackPopPtr(pVM->pStack); 4000 u1 = stackPopUNS32(pVM->pStack); 4001 cp1 = (char *)stackPopPtr(pVM->pStack); 4002 4003 uMin = (u1 < u2)? u1 : u2; 4004 for ( ; (uMin > 0) && (n == 0); uMin--) 4005 { 4006 n = (int)(*cp1++ - *cp2++); 4007 } 4008 4009 if (n == 0) 4010 n = (int)(u1 - u2); 4011 4012 if (n < 0) 4013 n = -1; 4014 else if (n > 0) 4015 n = 1; 4016 4017 stackPushINT32(pVM->pStack, n); 4018 return; 4019} 4020 4021 4022/************************************************************************** 4023 r e f i l l 4024** CORE EXT ( -- flag ) 4025** Attempt to fill the input buffer from the input source, returning a true 4026** flag if successful. 4027** When the input source is the user input device, attempt to receive input 4028** into the terminal input buffer. If successful, make the result the input 4029** buffer, set >IN to zero, and return true. Receipt of a line containing no 4030** characters is considered successful. If there is no input available from 4031** the current input source, return false. 4032** When the input source is a string from EVALUATE, return false and 4033** perform no other action. 4034**************************************************************************/ 4035static void refill(FICL_VM *pVM) 4036{ 4037 INT32 ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; 4038 stackPushINT32(pVM->pStack, ret); 4039 if (ret) 4040 vmThrow(pVM, VM_OUTOFTEXT); 4041 return; 4042} 4043 4044 4045/************************************************************************** 4046 f o r g e t 4047** TOOLS EXT ( "<spaces>name" -- ) 4048** Skip leading space delimiters. Parse name delimited by a space. 4049** Find name, then delete name from the dictionary along with all 4050** words added to the dictionary after name. An ambiguous 4051** condition exists if name cannot be found. 4052** 4053** If the Search-Order word set is present, FORGET searches the 4054** compilation word list. An ambiguous condition exists if the 4055** compilation word list is deleted. 4056**************************************************************************/ 4057static void forgetWid(FICL_VM *pVM) 4058{ 4059 FICL_DICT *pDict = ficlGetDict(); 4060 FICL_HASH *pHash; 4061 4062 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack); 4063 hashForget(pHash, pDict->here); 4064 4065 return; 4066} 4067 4068 4069static void forget(FICL_VM *pVM) 4070{ 4071 void *where; 4072 FICL_DICT *pDict = ficlGetDict(); 4073 FICL_HASH *pHash = pDict->pCompile; 4074 4075 tick(pVM); 4076 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name; 4077 hashForget(pHash, where); 4078 pDict->here = PTRtoCELL where; 4079 4080 return; 4081} 4082 4083/*************** freebsd added memory-alloc handling words ******************/ 4084 4085static void allocate(FICL_VM *pVM) 4086{ 4087 size_t size; 4088 void *p; 4089 4090 size = stackPopINT32(pVM->pStack); 4091 p = ficlMalloc(size); 4092 stackPushPtr(pVM->pStack, p); 4093 if (p) 4094 stackPushINT32(pVM->pStack, 0); 4095 else 4096 stackPushINT32(pVM->pStack, 1); 4097} 4098 4099static void free4th(FICL_VM *pVM) 4100{ 4101 void *p; 4102 4103 p = stackPopPtr(pVM->pStack); 4104 ficlFree(p); 4105 stackPushINT32(pVM->pStack, 0); 4106} 4107 4108static void resize(FICL_VM *pVM) 4109{ 4110 size_t size; 4111 void *new, *old; 4112 4113 size = stackPopINT32(pVM->pStack); 4114 old = stackPopPtr(pVM->pStack); 4115 new = ficlRealloc(old, size); 4116 if (new) { 4117 stackPushPtr(pVM->pStack, new); 4118 stackPushINT32(pVM->pStack, 0); 4119 } else { 4120 stackPushPtr(pVM->pStack, old); 4121 stackPushINT32(pVM->pStack, 1); 4122 } 4123} 4124 4125/***************** freebsd added exception handling words *******************/ 4126 4127/* 4128 * Catch, from ANS Forth standard. Installs a safety net, then EXECUTE 4129 * the word in ToS. If an exception happens, restore the state to what 4130 * it was before, and pushes the exception value on the stack. If not, 4131 * push zero. 4132 * 4133 * Notice that Catch implements an inner interpreter. This is ugly, 4134 * but given how ficl works, it cannot be helped. The problem is that 4135 * colon definitions will be executed *after* the function returns, 4136 * while "code" definitions will be executed immediately. I considered 4137 * other solutions to this problem, but all of them shared the same 4138 * basic problem (with added disadvantages): if ficl ever changes it's 4139 * inner thread modus operandi, one would have to fix this word. 4140 * 4141 * More comments can be found throughout catch's code. 4142 * 4143 * BUGS: do not handle locals unnesting correctly... I think... 4144 * 4145 * Daniel C. Sobral Jan 09/1999 4146 */ 4147 4148static void catch(FICL_VM *pVM) 4149{ 4150 int except; 4151 jmp_buf vmState; 4152 FICL_VM VM; 4153 FICL_STACK pStack; 4154 FICL_STACK rStack; 4155 FICL_WORD *pFW; 4156 IPTYPE exitIP; 4157 4158 /* 4159 * Get xt. 4160 * We need this *before* we save the stack pointer, or 4161 * we'll have to pop one element out of the stack after 4162 * an exception. I prefer to get done with it up front. :-) 4163 */ 4164#if FICL_ROBUST > 1 4165 vmCheckStack(pVM, 1, 0); 4166#endif 4167 pFW = stackPopPtr(pVM->pStack); 4168 4169 /* 4170 * Save vm's state -- a catch will not back out environmental 4171 * changes. 4172 * 4173 * We are *not* saving dictionary state, since it is 4174 * global instead of per vm, and we are not saving 4175 * stack contents, since we are not required to (and, 4176 * thus, it would be useless). We save pVM, and pVM 4177 * "stacks" (a structure containing general information 4178 * about it, including the current stack pointer). 4179 */ 4180 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM)); 4181 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK)); 4182 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK)); 4183 4184 /* 4185 * Give pVM a jmp_buf 4186 */ 4187 pVM->pState = &vmState; 4188 4189 /* 4190 * Safety net 4191 */ 4192 except = setjmp(vmState); 4193 4194 /* 4195 * And now, choose what to do depending on except. 4196 */ 4197 4198 /* Things having gone wrong... */ 4199 if(except) { 4200 /* Restore vm's state */ 4201 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); 4202 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK)); 4203 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); 4204 4205 /* Push error */ 4206 stackPushINT32(pVM->pStack, except); 4207 4208 /* Things being ok... */ 4209 } else { 4210 /* 4211 * We need to know when to exit the inner loop 4212 * Colonp, the "code" for colon words, just pushes 4213 * the word's IP onto the RP, and expect the inner 4214 * interpreter to do the rest. Well, I'd rather have 4215 * it done *before* I return from this function, 4216 * losing the automatic variables I'm using to save 4217 * state. Sure, I could save this on dynamic memory 4218 * and save state on RP, or I could even implement 4219 * the poor man's version of this word in Forth with 4220 * sp@, sp!, rp@ and rp!, but we have a lot of state 4221 * neatly tucked away in pVM, so why not save it? 4222 */ 4223 exitIP = pVM->ip; 4224 4225 /* Execute the xt -- inline code for vmExecute */ 4226 4227 pVM->runningWord = pFW; 4228 pFW->code(pVM); 4229 4230 /* 4231 * Run the inner loop until we get back to exitIP 4232 */ 4233 for (; pVM->ip != exitIP;) { 4234 pFW = *pVM->ip++; 4235 4236 /* Inline code for vmExecute */ 4237 pVM->runningWord = pFW; 4238 pFW->code(pVM); 4239 } 4240 4241 4242 /* Restore just the setjmp vector */ 4243 pVM->pState = VM.pState; 4244 4245 /* Push 0 -- everything is ok */ 4246 stackPushINT32(pVM->pStack, 0); 4247 } 4248} 4249 4250/* 4251 * Throw -- maybe vmThow already do what's required, but I don't really 4252 * know what happens when you longjmp(buf, 0). From ANS Forth standard. 4253 * 4254 * Anyway, throw takes the ToS and, if that's different from zero, 4255 * returns to the last executed catch context. Further throws will 4256 * unstack previously executed "catches", in LIFO mode. 4257 * 4258 * Daniel C. Sobral Jan 09/1999 4259 */ 4260 4261static void throw(FICL_VM *pVM) 4262{ 4263 int except; 4264 4265 except = stackPopINT32(pVM->pStack); 4266 4267 if (except) 4268 vmThrow(pVM, except); 4269} 4270 4271/************************* freebsd added I/O words **************************/ 4272 4273/* fopen - open a file and return new fd on stack. 4274 * 4275 * fopen ( count ptr -- fd ) 4276 */ 4277static void pfopen(FICL_VM *pVM) 4278{ 4279 int fd; 4280 char *p; 4281 4282#if FICL_ROBUST > 1 4283 vmCheckStack(pVM, 2, 1); 4284#endif 4285 (void)stackPopINT32(pVM->pStack); /* don't need count value */ 4286 p = stackPopPtr(pVM->pStack); 4287 fd = open(p, O_RDONLY); 4288 stackPushINT32(pVM->pStack, fd); 4289 return; 4290} 4291 4292/* fclose - close a file who's fd is on stack. 4293 * 4294 * fclose ( fd -- ) 4295 */ 4296static void pfclose(FICL_VM *pVM) 4297{ 4298 int fd; 4299 4300#if FICL_ROBUST > 1 4301 vmCheckStack(pVM, 1, 0); 4302#endif 4303 fd = stackPopINT32(pVM->pStack); /* get fd */ 4304 if (fd != -1) 4305 close(fd); 4306 return; 4307} 4308 4309/* fread - read file contents 4310 * 4311 * fread ( fd buf nbytes -- nread ) 4312 */ 4313static void pfread(FICL_VM *pVM) 4314{ 4315 int fd, len; 4316 char *buf; 4317 4318#if FICL_ROBUST > 1 4319 vmCheckStack(pVM, 3, 1); 4320#endif 4321 len = stackPopINT32(pVM->pStack); /* get number of bytes to read */ 4322 buf = stackPopPtr(pVM->pStack); /* get buffer */ 4323 fd = stackPopINT32(pVM->pStack); /* get fd */ 4324 if (len > 0 && buf && fd != -1) 4325 stackPushINT32(pVM->pStack, read(fd, buf, len)); 4326 else 4327 stackPushINT32(pVM->pStack, -1); 4328 return; 4329} 4330 4331/* fload - interpret file contents 4332 * 4333 * fload ( fd -- ) 4334 */ 4335static void pfload(FICL_VM *pVM) 4336{ 4337 int fd; 4338 4339#if FICL_ROBUST > 1 4340 vmCheckStack(pVM, 1, 0); 4341#endif 4342 fd = stackPopINT32(pVM->pStack); /* get fd */ 4343 if (fd != -1) 4344 ficlExecFD(pVM, fd); 4345 return; 4346} 4347 4348/* key - get a character from stdin 4349 * 4350 * key ( -- char ) 4351 */ 4352static void key(FICL_VM *pVM) 4353{ 4354#if FICL_ROBUST > 1 4355 vmCheckStack(pVM, 0, 1); 4356#endif 4357 stackPushINT32(pVM->pStack, getchar()); 4358 return; 4359} 4360 4361/* key? - check for a character from stdin (FACILITY) 4362 * 4363 * key? ( -- flag ) 4364 */ 4365static void keyQuestion(FICL_VM *pVM) 4366{ 4367#if FICL_ROBUST > 1 4368 vmCheckStack(pVM, 0, 1); 4369#endif 4370#ifdef TESTMAIN 4371 /* XXX Since we don't fiddle with termios, let it always succeed... */ 4372 stackPushINT32(pVM->pStack, FICL_TRUE); 4373#else 4374 /* But here do the right thing. */ 4375 stackPushINT32(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE); 4376#endif 4377 return; 4378} 4379 4380/* seconds - gives number of seconds since beginning of time 4381 * 4382 * beginning of time is defined as: 4383 * 4384 * BTX - number of seconds since midnight 4385 * FreeBSD - number of seconds since Jan 1 1970 4386 * 4387 * seconds ( -- u ) 4388 */ 4389static void pseconds(FICL_VM *pVM) 4390{ 4391#if FICL_ROBUST > 1 4392 vmCheckStack(pVM,0,1); 4393#endif 4394 stackPushUNS32(pVM->pStack, (u_int32_t) time(NULL)); 4395 return; 4396} 4397 4398/* ms - wait at least that many milliseconds (FACILITY) 4399 * 4400 * ms ( u -- ) 4401 * 4402 */ 4403static void ms(FICL_VM *pVM) 4404{ 4405#if FICL_ROBUST > 1 4406 vmCheckStack(pVM,1,0); 4407#endif 4408#ifdef TESTMAIN 4409 usleep(stackPopUNS32(pVM->pStack)*1000); 4410#else 4411 delay(stackPopUNS32(pVM->pStack)*1000); 4412#endif 4413 return; 4414} 4415 4416/* fkey - get a character from a file 4417 * 4418 * fkey ( file -- char ) 4419 */ 4420static void fkey(FICL_VM *pVM) 4421{ 4422 int i, fd; 4423 char ch; 4424 4425#if FICL_ROBUST > 1 4426 vmCheckStack(pVM, 1, 1); 4427#endif 4428 fd = stackPopINT32(pVM->pStack); 4429 i = read(fd, &ch, 1); 4430 stackPushINT32(pVM->pStack, i > 0 ? ch : -1); 4431 return; 4432} 4433 4434/************************* freebsd added trace ***************************/ 4435 4436#ifdef FICL_TRACE 4437static void ficlTrace(FICL_VM *pVM) 4438{ 4439#if FICL_ROBUST > 1 4440 vmCheckStack(pVM, 1, 1); 4441#endif 4442 4443 ficl_trace = stackPopINT32(pVM->pStack); 4444} 4445#endif 4446 4447/************************************************************************** 4448 f i c l C o m p i l e C o r e 4449** Builds the primitive wordset and the environment-query namespace. 4450**************************************************************************/ 4451 4452void ficlCompileCore(FICL_DICT *dp) 4453{ 4454 assert (dp); 4455 4456 /* 4457 ** CORE word set 4458 ** see softcore.c for definitions of: abs bl space spaces abort" 4459 */ 4460 pStore = 4461 dictAppendWord(dp, "!", store, FW_DEFAULT); 4462 dictAppendWord(dp, "#", numberSign, FW_DEFAULT); 4463 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); 4464 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); 4465 dictAppendWord(dp, "\'", tick, FW_DEFAULT); 4466 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE); 4467 dictAppendWord(dp, "*", mul, FW_DEFAULT); 4468 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT); 4469 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT); 4470 dictAppendWord(dp, "+", add, FW_DEFAULT); 4471 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT); 4472 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED); 4473 pComma = 4474 dictAppendWord(dp, ",", comma, FW_DEFAULT); 4475 dictAppendWord(dp, "-", sub, FW_DEFAULT); 4476 dictAppendWord(dp, ".", displayCell, FW_DEFAULT); 4477 dictAppendWord(dp, ".#", displayCellNoPad, FW_DEFAULT); 4478 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED); 4479 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT); 4480 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT); 4481 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT); 4482 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT); 4483 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); 4484 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT); 4485 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT); 4486 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT); 4487 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT); 4488 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT); 4489 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT); 4490 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT); 4491 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT); 4492 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT); 4493 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT); 4494 dictAppendWord(dp, ":", colon, FW_DEFAULT); 4495 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED); 4496 dictAppendWord(dp, "<", isLess, FW_DEFAULT); 4497 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT); 4498 dictAppendWord(dp, "=", isEqual, FW_DEFAULT); 4499 dictAppendWord(dp, ">", isGreater, FW_DEFAULT); 4500 dictAppendWord(dp, ">body", toBody, FW_DEFAULT); 4501 dictAppendWord(dp, ">in", toIn, FW_DEFAULT); 4502 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT); 4503 dictAppendWord(dp, ">r", toRStack, FW_DEFAULT); 4504 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT); 4505 dictAppendWord(dp, "@", fetch, FW_DEFAULT); 4506 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT); 4507 dictAppendWord(dp, "accept", accept, FW_DEFAULT); 4508 dictAppendWord(dp, "align", align, FW_DEFAULT); 4509 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT); 4510 dictAppendWord(dp, "allot", allot, FW_DEFAULT); 4511 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT); 4512 dictAppendWord(dp, "base", base, FW_DEFAULT); 4513 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED); 4514 dictAppendWord(dp, "c!", cStore, FW_DEFAULT); 4515 dictAppendWord(dp, "c,", cComma, FW_DEFAULT); 4516 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT); 4517 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT); 4518 dictAppendWord(dp, "cells", cells, FW_DEFAULT); 4519 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT); 4520 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT); 4521 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT); 4522 dictAppendWord(dp, "constant", constant, FW_DEFAULT); 4523 dictAppendWord(dp, "count", count, FW_DEFAULT); 4524 dictAppendWord(dp, "cr", cr, FW_DEFAULT); 4525 dictAppendWord(dp, "create", create, FW_DEFAULT); 4526 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT); 4527 dictAppendWord(dp, "depth", depth, FW_DEFAULT); 4528 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED); 4529 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED); 4530 dictAppendWord(dp, "drop", drop, FW_DEFAULT); 4531 dictAppendWord(dp, "dup", dup, FW_DEFAULT); 4532 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED); 4533 dictAppendWord(dp, "emit", emit, FW_DEFAULT); 4534 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT); 4535 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); 4536 dictAppendWord(dp, "execute", execute, FW_DEFAULT); 4537 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); 4538 dictAppendWord(dp, "fill", fill, FW_DEFAULT); 4539 dictAppendWord(dp, "find", find, FW_DEFAULT); 4540 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); 4541 dictAppendWord(dp, "here", here, FW_DEFAULT); 4542 dictAppendWord(dp, "hex", hex, FW_DEFAULT); 4543 dictAppendWord(dp, "hold", hold, FW_DEFAULT); 4544 dictAppendWord(dp, "i", loopICo, FW_COMPILE); 4545 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED); 4546 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT); 4547 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT); 4548 dictAppendWord(dp, "j", loopJCo, FW_COMPILE); 4549 dictAppendWord(dp, "k", loopKCo, FW_COMPILE); 4550 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE); 4551 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE); 4552 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED); 4553 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT); 4554 dictAppendWord(dp, "m*", mStar, FW_DEFAULT); 4555 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT); 4556 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT); 4557 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT); 4558 dictAppendWord(dp, "move", move, FW_DEFAULT); 4559 dictAppendWord(dp, "negate", negate, FW_DEFAULT); 4560 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT); 4561 dictAppendWord(dp, "over", over, FW_DEFAULT); 4562 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED); 4563 dictAppendWord(dp, "quit", quit, FW_DEFAULT); 4564 dictAppendWord(dp, "r>", fromRStack, FW_DEFAULT); 4565 dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT); 4566 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED); 4567 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED); 4568 dictAppendWord(dp, "rot", rot, FW_DEFAULT); 4569 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT); 4570 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE); 4571 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT); 4572 dictAppendWord(dp, "sign", sign, FW_DEFAULT); 4573 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT); 4574 dictAppendWord(dp, "source", source, FW_DEFAULT); 4575 dictAppendWord(dp, "state", state, FW_DEFAULT); 4576 dictAppendWord(dp, "swap", swap, FW_DEFAULT); 4577 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED); 4578 pType = 4579 dictAppendWord(dp, "type", type, FW_DEFAULT); 4580 dictAppendWord(dp, "u.", uDot, FW_DEFAULT); 4581 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT); 4582 dictAppendWord(dp, "um*", umStar, FW_DEFAULT); 4583 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT); 4584 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE); 4585 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED); 4586 dictAppendWord(dp, "variable", variable, FW_DEFAULT); 4587 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED); 4588 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT); 4589 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT); 4590 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED); 4591 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED); 4592 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED); 4593 dictAppendWord(dp, "]", rbracket, FW_DEFAULT); 4594 /* 4595 ** CORE EXT word set... 4596 ** see softcore.c for other definitions 4597 */ 4598 dictAppendWord(dp, ".(", dotParen, FW_DEFAULT); 4599 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); 4600 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); 4601 dictAppendWord(dp, "parse", parse, FW_DEFAULT); 4602 dictAppendWord(dp, "pick", pick, FW_DEFAULT); 4603 dictAppendWord(dp, "roll", roll, FW_DEFAULT); 4604 dictAppendWord(dp, "refill", refill, FW_DEFAULT); 4605 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); 4606 dictAppendWord(dp, "value", constant, FW_DEFAULT); 4607 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); 4608 4609 /* FreeBSD extension words */ 4610 dictAppendWord(dp, "fopen", pfopen, FW_DEFAULT); 4611 dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT); 4612 dictAppendWord(dp, "fread", pfread, FW_DEFAULT); 4613 dictAppendWord(dp, "fload", pfload, FW_DEFAULT); 4614 dictAppendWord(dp, "fkey", fkey, FW_DEFAULT); 4615 dictAppendWord(dp, "key", key, FW_DEFAULT); 4616 dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT); 4617 dictAppendWord(dp, "ms", ms, FW_DEFAULT); 4618 dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT); 4619#ifdef FICL_TRACE 4620 dictAppendWord(dp, "trace!", ficlTrace, FW_DEFAULT); 4621#endif 4622 /* 4623 ** EXCEPTION word set 4624 */ 4625 dictAppendWord(dp, "catch", catch, FW_DEFAULT); 4626 dictAppendWord(dp, "throw", throw, FW_DEFAULT); 4627 4628 ficlSetEnv("exception", FICL_TRUE); 4629 ficlSetEnv("exception-ext", FICL_TRUE); 4630 4631 /* 4632 ** MEMORY-ALLOC word set 4633 */ 4634 dictAppendWord(dp, "allocate", allocate, FW_DEFAULT); 4635 dictAppendWord(dp, "free", free4th, FW_DEFAULT); 4636 dictAppendWord(dp, "resize", resize, FW_DEFAULT); 4637 4638 ficlSetEnv("memory-alloc", FICL_TRUE); 4639 4640#ifndef TESTMAIN 4641#ifdef __i386__ 4642 dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT); 4643 dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT); 4644#endif 4645#endif 4646 4647#if defined(__i386__) 4648 ficlSetEnv("arch-i386", FICL_TRUE); 4649 ficlSetEnv("arch-alpha", FICL_FALSE); 4650#elif defined(__alpha__) 4651 ficlSetEnv("arch-i386", FICL_FALSE); 4652 ficlSetEnv("arch-alpha", FICL_TRUE); 4653#endif 4654 4655 /* 4656 ** Set CORE environment query values 4657 */ 4658 ficlSetEnv("/counted-string", FICL_STRING_MAX); 4659 ficlSetEnv("/hold", nPAD); 4660 ficlSetEnv("/pad", nPAD); 4661 ficlSetEnv("address-unit-bits", 8); 4662 ficlSetEnv("core", FICL_TRUE); 4663 ficlSetEnv("core-ext", FICL_FALSE); 4664 ficlSetEnv("floored", FICL_FALSE); 4665 ficlSetEnv("max-char", UCHAR_MAX); 4666 ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff ); 4667 ficlSetEnv("max-n", 0x7fffffff); 4668 ficlSetEnv("max-u", 0xffffffff); 4669 ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff); 4670 ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK); 4671 ficlSetEnv("stack-cells", FICL_DEFAULT_STACK); 4672 4673 /* 4674 ** LOCAL and LOCAL EXT 4675 ** see softcore.c for implementation of locals| 4676 */ 4677#if FICL_WANT_LOCALS 4678 pLinkParen = 4679 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); 4680 pUnLinkParen = 4681 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); 4682 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); 4683 pGetLocalParen = 4684 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); 4685 pToLocalParen = 4686 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); 4687 pGetLocal0 = 4688 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); 4689 pToLocal0 = 4690 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); 4691 pGetLocal1 = 4692 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); 4693 pToLocal1 = 4694 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); 4695 dictAppendWord(dp, "(local)", localParen, FW_COMPILE); 4696 4697 ficlSetEnv("locals", FICL_TRUE); 4698 ficlSetEnv("locals-ext", FICL_TRUE); 4699 ficlSetEnv("#locals", FICL_MAX_LOCALS); 4700#endif 4701 4702 /* 4703 ** optional SEARCH-ORDER word set 4704 */ 4705 dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); 4706 dictAppendWord(dp, "search>", searchPop, FW_DEFAULT); 4707 dictAppendWord(dp, "definitions", 4708 definitions, FW_DEFAULT); 4709 dictAppendWord(dp, "forth-wordlist", 4710 forthWordlist, FW_DEFAULT); 4711 dictAppendWord(dp, "get-current", 4712 getCurrent, FW_DEFAULT); 4713 dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT); 4714 dictAppendWord(dp, "search-wordlist", 4715 searchWordlist, FW_DEFAULT); 4716 dictAppendWord(dp, "set-current", 4717 setCurrent, FW_DEFAULT); 4718 dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT); 4719 dictAppendWord(dp, "ficl-wordlist", wordlist, FW_DEFAULT); 4720 4721 /* 4722 ** Set SEARCH environment query values 4723 */ 4724 ficlSetEnv("search-order", FICL_TRUE); 4725 ficlSetEnv("search-order-ext", FICL_TRUE); 4726 ficlSetEnv("wordlists", FICL_DEFAULT_VOCS); 4727 4728 /* 4729 ** TOOLS and TOOLS EXT 4730 */ 4731 dictAppendWord(dp, ".s", displayStack, FW_DEFAULT); 4732 dictAppendWord(dp, "bye", bye, FW_DEFAULT); 4733 dictAppendWord(dp, "forget", forget, FW_DEFAULT); 4734 dictAppendWord(dp, "see", see, FW_DEFAULT); 4735 dictAppendWord(dp, "words", listWords, FW_DEFAULT); 4736 4737 /* 4738 ** Set TOOLS environment query values 4739 */ 4740 ficlSetEnv("tools", FICL_TRUE); 4741 ficlSetEnv("tools-ext", FICL_FALSE); 4742 4743 /* 4744 ** Ficl extras 4745 */ 4746 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT); 4747 dictAppendWord(dp, ".hash", dictHashSummary,FW_DEFAULT); 4748 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); 4749 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); 4750 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); /* DOUBLE */ 4751 dictAppendWord(dp, ">name", toName, FW_DEFAULT); 4752 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); 4753 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ 4754 dictAppendWord(dp, "compile-only", 4755 compileOnly, FW_DEFAULT); 4756 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); 4757 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); 4758 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); 4759 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ 4760 dictAppendWord(dp, "wid-set-super", 4761 setParentWid, FW_DEFAULT); 4762 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); 4763 dictAppendWord(dp, "w!", wStore, FW_DEFAULT); 4764 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT); 4765#if FICL_WANT_USER 4766 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); 4767 dictAppendWord(dp, "user", userVariable, FW_DEFAULT); 4768#endif 4769 /* 4770 ** internal support words 4771 */ 4772 pExitParen = 4773 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); 4774 pSemiParen = 4775 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); 4776 pLitParen = 4777 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); 4778 pStringLit = 4779 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); 4780 pIfParen = 4781 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE); 4782 pBranchParen = 4783 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); 4784 pDoParen = 4785 dictAppendWord(dp, "(do)", doParen, FW_COMPILE); 4786 pDoesParen = 4787 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); 4788 pQDoParen = 4789 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); 4790 pLoopParen = 4791 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); 4792 pPLoopParen = 4793 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); 4794 pInterpret = 4795 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); 4796 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); 4797 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); 4798 4799 return; 4800} 4801 4802