words.c revision 65617
1169695Skan/******************************************************************* 2169695Skan** w o r d s . c 3169695Skan** Forth Inspired Command Language 4169695Skan** ANS Forth CORE word-set written in C 5169695Skan** Author: John Sadler (john_sadler@alum.mit.edu) 6169695Skan** Created: 19 July 1997 7169695Skan** 8169695Skan*******************************************************************/ 9169695Skan 10169695Skan/* $FreeBSD: head/sys/boot/ficl/words.c 65617 2000-09-08 17:03:53Z dcs $ */ 11169695Skan 12169695Skan#ifdef TESTMAIN 13169695Skan#include <stdlib.h> 14169695Skan#include <stdio.h> 15169695Skan#include <ctype.h> 16169695Skan#include <fcntl.h> 17169695Skan#else 18169695Skan#include <stand.h> 19169695Skan#endif 20169695Skan#include <string.h> 21169695Skan#include "ficl.h" 22169695Skan#include "math64.h" 23169695Skan 24169695Skanstatic void colonParen(FICL_VM *pVM); 25169695Skanstatic void literalIm(FICL_VM *pVM); 26169695Skanstatic void interpWord(FICL_VM *pVM, STRINGINFO si); 27169695Skan 28169695Skan/* 29169695Skan** Control structure building words use these 30169695Skan** strings' addresses as markers on the stack to 31169695Skan** check for structure completion. 32169695Skan*/ 33169695Skanstatic char doTag[] = "do"; 34169695Skanstatic char colonTag[] = "colon"; 35169695Skanstatic char leaveTag[] = "leave"; 36169695Skan 37169695Skanstatic char destTag[] = "target"; 38169695Skanstatic char origTag[] = "origin"; 39169695Skan 40169695Skan/* 41169695Skan** Pointers to various words in the dictionary 42169695Skan** -- initialized by ficlCompileCore, below -- 43169695Skan** for use by compiling words. Colon definitions 44169695Skan** in ficl are lists of pointers to words. A bit 45169695Skan** simple-minded... 46169695Skan*/ 47169695Skanstatic FICL_WORD *pBranchParen = NULL; 48169695Skanstatic FICL_WORD *pComma = NULL; 49169695Skanstatic FICL_WORD *pDoParen = NULL; 50169695Skanstatic FICL_WORD *pDoesParen = NULL; 51169695Skanstatic FICL_WORD *pExitParen = NULL; 52169695Skanstatic FICL_WORD *pIfParen = NULL; 53169695Skanstatic FICL_WORD *pInterpret = NULL; 54169695Skanstatic FICL_WORD *pLitParen = NULL; 55169695Skanstatic FICL_WORD *pTwoLitParen = NULL; 56169695Skanstatic FICL_WORD *pLoopParen = NULL; 57169695Skanstatic FICL_WORD *pPLoopParen = NULL; 58169695Skanstatic FICL_WORD *pQDoParen = NULL; 59169695Skanstatic FICL_WORD *pSemiParen = NULL; 60169695Skanstatic FICL_WORD *pStore = NULL; 61169695Skanstatic FICL_WORD *pStringLit = NULL; 62169695Skanstatic FICL_WORD *pType = NULL; 63169695Skan 64169695Skan#if FICL_WANT_LOCALS 65169695Skanstatic FICL_WORD *pGetLocalParen= NULL; 66169695Skanstatic FICL_WORD *pGet2LocalParen= NULL; 67169695Skanstatic FICL_WORD *pGetLocal0 = NULL; 68169695Skanstatic FICL_WORD *pGetLocal1 = NULL; 69169695Skanstatic FICL_WORD *pToLocalParen = NULL; 70169695Skanstatic FICL_WORD *pTo2LocalParen = NULL; 71169695Skanstatic FICL_WORD *pToLocal0 = NULL; 72169695Skanstatic FICL_WORD *pToLocal1 = NULL; 73169695Skanstatic FICL_WORD *pLinkParen = NULL; 74169695Skanstatic FICL_WORD *pUnLinkParen = NULL; 75169695Skanstatic int nLocals = 0; 76169695Skanstatic CELL *pMarkLocals = NULL; 77169695Skan 78169695Skanstatic void doLocalIm(FICL_VM *pVM); 79169695Skanstatic void do2LocalIm(FICL_VM *pVM); 80169695Skan 81169695Skan#endif 82169695Skan 83169695Skan 84169695Skan/* 85169695Skan** C O N T R O L S T R U C T U R E B U I L D E R S 86169695Skan** 87169695Skan** Push current dict location for later branch resolution. 88169695Skan** The location may be either a branch target or a patch address... 89169695Skan*/ 90169695Skanstatic void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 91169695Skan{ 92169695Skan stackPushPtr(pVM->pStack, dp->here); 93169695Skan stackPushPtr(pVM->pStack, tag); 94169695Skan return; 95169695Skan} 96169695Skan 97169695Skanstatic void markControlTag(FICL_VM *pVM, char *tag) 98169695Skan{ 99169695Skan stackPushPtr(pVM->pStack, tag); 100169695Skan return; 101169695Skan} 102169695Skan 103169695Skanstatic void matchControlTag(FICL_VM *pVM, char *tag) 104169695Skan{ 105169695Skan char *cp = (char *)stackPopPtr(pVM->pStack); 106169695Skan if ( strcmp(cp, tag) ) 107169695Skan { 108169695Skan vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag); 109169695Skan } 110169695Skan 111169695Skan return; 112169695Skan} 113169695Skan 114169695Skan/* 115169695Skan** Expect a branch target address on the param stack, 116169695Skan** compile a literal offset from the current dict location 117169695Skan** to the target address 118169695Skan*/ 119169695Skanstatic void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 120169695Skan{ 121169695Skan long offset; 122169695Skan CELL *patchAddr; 123169695Skan 124169695Skan matchControlTag(pVM, tag); 125169695Skan 126169695Skan patchAddr = (CELL *)stackPopPtr(pVM->pStack); 127169695Skan offset = patchAddr - dp->here; 128169695Skan dictAppendCell(dp, LVALUEtoCELL(offset)); 129169695Skan 130169695Skan return; 131169695Skan} 132169695Skan 133169695Skan 134169695Skan/* 135169695Skan** Expect a branch patch address on the param stack, 136169695Skan** compile a literal offset from the patch location 137169695Skan** to the current dict location 138169695Skan*/ 139169695Skanstatic void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 140169695Skan{ 141169695Skan long offset; 142169695Skan CELL *patchAddr; 143169695Skan 144169695Skan matchControlTag(pVM, tag); 145169695Skan 146169695Skan patchAddr = (CELL *)stackPopPtr(pVM->pStack); 147169695Skan offset = dp->here - patchAddr; 148169695Skan *patchAddr = LVALUEtoCELL(offset); 149169695Skan 150169695Skan return; 151169695Skan} 152169695Skan 153169695Skan/* 154169695Skan** Match the tag to the top of the stack. If success, 155169695Skan** sopy "here" address into the cell whose address is next 156169695Skan** on the stack. Used by do..leave..loop. 157169695Skan*/ 158169695Skanstatic void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag) 159169695Skan{ 160169695Skan CELL *patchAddr; 161169695Skan char *cp; 162169695Skan 163169695Skan cp = stackPopPtr(pVM->pStack); 164169695Skan if (strcmp(cp, tag)) 165169695Skan { 166169695Skan vmTextOut(pVM, "Warning -- Unmatched control word: ", 0); 167169695Skan vmTextOut(pVM, tag, 1); 168169695Skan } 169169695Skan 170169695Skan patchAddr = (CELL *)stackPopPtr(pVM->pStack); 171169695Skan *patchAddr = LVALUEtoCELL(dp->here); 172169695Skan 173169695Skan return; 174169695Skan} 175169695Skan 176169695Skan 177169695Skan/************************************************************************** 178169695Skan i s N u m b e r 179169695Skan** Attempts to convert the NULL terminated string in the VM's pad to 180169695Skan** a number using the VM's current base. If successful, pushes the number 181169695Skan** onto the param stack and returns TRUE. Otherwise, returns FALSE. 182169695Skan**************************************************************************/ 183169695Skan 184169695Skanstatic int isNumber(FICL_VM *pVM, STRINGINFO si) 185169695Skan{ 186169695Skan FICL_INT accum = 0; 187169695Skan char isNeg = FALSE; 188169695Skan unsigned base = pVM->base; 189169695Skan char *cp = SI_PTR(si); 190169695Skan FICL_COUNT count= (FICL_COUNT)SI_COUNT(si); 191169695Skan unsigned ch; 192169695Skan unsigned digit; 193169695Skan 194169695Skan if (*cp == '-') 195169695Skan { 196169695Skan cp++; 197169695Skan count--; 198169695Skan isNeg = TRUE; 199169695Skan } 200169695Skan else if ((cp[0] == '0') && (cp[1] == 'x')) 201169695Skan { /* detect 0xNNNN format for hex numbers */ 202169695Skan cp += 2; 203169695Skan count -= 2; 204169695Skan base = 16; 205169695Skan } 206169695Skan 207169695Skan if (count == 0) 208169695Skan return FALSE; 209169695Skan 210169695Skan while (count-- && ((ch = *cp++) != '\0')) 211169695Skan { 212169695Skan if (!(isdigit(ch)||isalpha(ch))) 213169695Skan return FALSE; 214169695Skan 215169695Skan digit = ch - '0'; 216169695Skan 217169695Skan if (digit > 9) 218169695Skan digit = tolower(ch) - 'a' + 10; 219169695Skan 220169695Skan if (digit >= base) 221169695Skan return FALSE; 222169695Skan 223169695Skan accum = accum * base + digit; 224169695Skan } 225169695Skan 226169695Skan if (isNeg) 227169695Skan accum = -accum; 228169695Skan 229169695Skan stackPushINT(pVM->pStack, accum); 230169695Skan 231169695Skan return TRUE; 232169695Skan} 233169695Skan 234169695Skan 235169695Skanstatic void ficlIsNum(FICL_VM *pVM) 236169695Skan{ 237169695Skan STRINGINFO si; 238169695Skan FICL_INT ret; 239169695Skan 240169695Skan SI_SETLEN(si, stackPopINT(pVM->pStack)); 241169695Skan SI_SETPTR(si, stackPopPtr(pVM->pStack)); 242169695Skan ret = isNumber(pVM, si) ? FICL_TRUE : FICL_FALSE; 243169695Skan stackPushINT(pVM->pStack, ret); 244169695Skan return; 245169695Skan} 246169695Skan 247169695Skan/************************************************************************** 248169695Skan a d d & f r i e n d s 249169695Skan** 250169695Skan**************************************************************************/ 251169695Skan 252169695Skanstatic void add(FICL_VM *pVM) 253169695Skan{ 254169695Skan FICL_INT i; 255169695Skan#if FICL_ROBUST > 1 256169695Skan vmCheckStack(pVM, 2, 1); 257169695Skan#endif 258169695Skan i = stackPopINT(pVM->pStack); 259169695Skan i += stackGetTop(pVM->pStack).i; 260169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 261169695Skan return; 262169695Skan} 263169695Skan 264169695Skanstatic void sub(FICL_VM *pVM) 265169695Skan{ 266169695Skan FICL_INT i; 267169695Skan#if FICL_ROBUST > 1 268169695Skan vmCheckStack(pVM, 2, 1); 269169695Skan#endif 270169695Skan i = stackPopINT(pVM->pStack); 271169695Skan i = stackGetTop(pVM->pStack).i - i; 272169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 273169695Skan return; 274169695Skan} 275169695Skan 276169695Skanstatic void mul(FICL_VM *pVM) 277169695Skan{ 278169695Skan FICL_INT i; 279169695Skan#if FICL_ROBUST > 1 280169695Skan vmCheckStack(pVM, 2, 1); 281169695Skan#endif 282169695Skan i = stackPopINT(pVM->pStack); 283169695Skan i *= stackGetTop(pVM->pStack).i; 284169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 285169695Skan return; 286169695Skan} 287169695Skan 288169695Skanstatic void negate(FICL_VM *pVM) 289169695Skan{ 290169695Skan FICL_INT i; 291169695Skan#if FICL_ROBUST > 1 292169695Skan vmCheckStack(pVM, 1, 1); 293169695Skan#endif 294169695Skan i = -stackPopINT(pVM->pStack); 295169695Skan stackPushINT(pVM->pStack, i); 296169695Skan return; 297169695Skan} 298169695Skan 299169695Skanstatic void ficlDiv(FICL_VM *pVM) 300169695Skan{ 301169695Skan FICL_INT i; 302169695Skan#if FICL_ROBUST > 1 303169695Skan vmCheckStack(pVM, 2, 1); 304169695Skan#endif 305169695Skan i = stackPopINT(pVM->pStack); 306169695Skan i = stackGetTop(pVM->pStack).i / i; 307169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 308169695Skan return; 309169695Skan} 310169695Skan 311169695Skan/* 312169695Skan** slash-mod CORE ( n1 n2 -- n3 n4 ) 313169695Skan** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell 314169695Skan** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2 315169695Skan** differ in sign, the implementation-defined result returned will be the 316169695Skan** same as that returned by either the phrase 317169695Skan** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM . 318169695Skan** NOTE: Ficl complies with the second phrase (symmetric division) 319169695Skan*/ 320169695Skanstatic void slashMod(FICL_VM *pVM) 321169695Skan{ 322169695Skan DPINT n1; 323169695Skan FICL_INT n2; 324169695Skan INTQR qr; 325169695Skan 326169695Skan#if FICL_ROBUST > 1 327169695Skan vmCheckStack(pVM, 2, 2); 328169695Skan#endif 329169695Skan n2 = stackPopINT(pVM->pStack); 330169695Skan n1.lo = stackPopINT(pVM->pStack); 331169695Skan i64Extend(n1); 332169695Skan 333169695Skan qr = m64SymmetricDivI(n1, n2); 334169695Skan stackPushINT(pVM->pStack, qr.rem); 335169695Skan stackPushINT(pVM->pStack, qr.quot); 336169695Skan return; 337169695Skan} 338169695Skan 339169695Skanstatic void onePlus(FICL_VM *pVM) 340169695Skan{ 341169695Skan FICL_INT i; 342169695Skan#if FICL_ROBUST > 1 343169695Skan vmCheckStack(pVM, 1, 1); 344169695Skan#endif 345169695Skan i = stackGetTop(pVM->pStack).i; 346169695Skan i += 1; 347169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 348169695Skan return; 349169695Skan} 350169695Skan 351169695Skanstatic void oneMinus(FICL_VM *pVM) 352169695Skan{ 353169695Skan FICL_INT i; 354169695Skan#if FICL_ROBUST > 1 355169695Skan vmCheckStack(pVM, 1, 1); 356169695Skan#endif 357169695Skan i = stackGetTop(pVM->pStack).i; 358169695Skan i -= 1; 359169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 360169695Skan return; 361169695Skan} 362169695Skan 363169695Skanstatic void twoMul(FICL_VM *pVM) 364169695Skan{ 365169695Skan FICL_INT i; 366169695Skan#if FICL_ROBUST > 1 367169695Skan vmCheckStack(pVM, 1, 1); 368169695Skan#endif 369169695Skan i = stackGetTop(pVM->pStack).i; 370169695Skan i *= 2; 371169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 372169695Skan return; 373169695Skan} 374169695Skan 375169695Skanstatic void twoDiv(FICL_VM *pVM) 376169695Skan{ 377169695Skan FICL_INT i; 378169695Skan#if FICL_ROBUST > 1 379169695Skan vmCheckStack(pVM, 1, 1); 380169695Skan#endif 381169695Skan i = stackGetTop(pVM->pStack).i; 382169695Skan i >>= 1; 383169695Skan stackSetTop(pVM->pStack, LVALUEtoCELL(i)); 384169695Skan return; 385169695Skan} 386169695Skan 387169695Skanstatic void mulDiv(FICL_VM *pVM) 388169695Skan{ 389169695Skan FICL_INT x, y, z; 390169695Skan DPINT prod; 391169695Skan#if FICL_ROBUST > 1 392169695Skan vmCheckStack(pVM, 3, 1); 393169695Skan#endif 394169695Skan z = stackPopINT(pVM->pStack); 395169695Skan y = stackPopINT(pVM->pStack); 396169695Skan x = stackPopINT(pVM->pStack); 397169695Skan 398169695Skan prod = m64MulI(x,y); 399169695Skan x = m64SymmetricDivI(prod, z).quot; 400169695Skan 401169695Skan stackPushINT(pVM->pStack, x); 402169695Skan return; 403169695Skan} 404169695Skan 405169695Skan 406169695Skanstatic void mulDivRem(FICL_VM *pVM) 407169695Skan{ 408169695Skan FICL_INT x, y, z; 409169695Skan DPINT prod; 410169695Skan INTQR qr; 411169695Skan#if FICL_ROBUST > 1 412169695Skan vmCheckStack(pVM, 3, 2); 413169695Skan#endif 414169695Skan z = stackPopINT(pVM->pStack); 415169695Skan y = stackPopINT(pVM->pStack); 416169695Skan x = stackPopINT(pVM->pStack); 417169695Skan 418169695Skan prod = m64MulI(x,y); 419169695Skan qr = m64SymmetricDivI(prod, z); 420169695Skan 421169695Skan stackPushINT(pVM->pStack, qr.rem); 422169695Skan stackPushINT(pVM->pStack, qr.quot); 423169695Skan return; 424169695Skan} 425169695Skan 426169695Skan 427169695Skan/************************************************************************** 428169695Skan b y e 429169695Skan** TOOLS 430169695Skan** Signal the system to shut down - this causes ficlExec to return 431169695Skan** VM_USEREXIT. The rest is up to you. 432169695Skan**************************************************************************/ 433169695Skan 434169695Skanstatic void bye(FICL_VM *pVM) 435169695Skan{ 436169695Skan vmThrow(pVM, VM_USEREXIT); 437169695Skan return; 438169695Skan} 439169695Skan 440169695Skan 441169695Skan/************************************************************************** 442169695Skan c o l o n d e f i n i t i o n s 443169695Skan** Code to begin compiling a colon definition 444169695Skan** This function sets the state to COMPILE, then creates a 445169695Skan** new word whose name is the next word in the input stream 446169695Skan** and whose code is colonParen. 447169695Skan**************************************************************************/ 448169695Skan 449169695Skanstatic void colon(FICL_VM *pVM) 450169695Skan{ 451169695Skan FICL_DICT *dp = ficlGetDict(); 452169695Skan STRINGINFO si = vmGetWord(pVM); 453169695Skan 454169695Skan dictCheckThreshold(dp); 455169695Skan 456169695Skan pVM->state = COMPILE; 457169695Skan markControlTag(pVM, colonTag); 458169695Skan dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 459169695Skan#if FICL_WANT_LOCALS 460169695Skan nLocals = 0; 461169695Skan#endif 462169695Skan return; 463169695Skan} 464169695Skan 465169695Skan 466169695Skan/************************************************************************** 467169695Skan c o l o n P a r e n 468169695Skan** This is the code that executes a colon definition. It assumes that the 469169695Skan** virtual machine is running a "next" loop (See the vm.c 470169695Skan** for its implementation of member function vmExecute()). The colon 471169695Skan** code simply copies the address of the first word in the list of words 472169695Skan** to interpret into IP after saving its old value. When we return to the 473169695Skan** "next" loop, the virtual machine will call the code for each word in 474169695Skan** turn. 475169695Skan** 476169695Skan**************************************************************************/ 477169695Skan 478169695Skanstatic void colonParen(FICL_VM *pVM) 479169695Skan{ 480169695Skan IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param); 481169695Skan vmPushIP(pVM, tempIP); 482169695Skan 483169695Skan return; 484169695Skan} 485169695Skan 486169695Skan 487169695Skan/************************************************************************** 488169695Skan s e m i c o l o n C o I m 489169695Skan** 490169695Skan** IMMEDIATE code for ";". This function sets the state to INTERPRET and 491169695Skan** terminates a word under compilation by appending code for "(;)" to 492169695Skan** the definition. TO DO: checks for leftover branch target tags on the 493169695Skan** return stack and complains if any are found. 494169695Skan**************************************************************************/ 495169695Skanstatic void semiParen(FICL_VM *pVM) 496169695Skan{ 497169695Skan vmPopIP(pVM); 498169695Skan return; 499169695Skan} 500169695Skan 501169695Skan 502169695Skanstatic void semicolonCoIm(FICL_VM *pVM) 503169695Skan{ 504169695Skan FICL_DICT *dp = ficlGetDict(); 505169695Skan 506169695Skan assert(pSemiParen); 507169695Skan matchControlTag(pVM, colonTag); 508169695Skan 509169695Skan#if FICL_WANT_LOCALS 510169695Skan assert(pUnLinkParen); 511169695Skan if (nLocals > 0) 512169695Skan { 513169695Skan FICL_DICT *pLoc = ficlGetLoc(); 514169695Skan dictEmpty(pLoc, pLoc->pForthWords->size); 515169695Skan dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 516169695Skan } 517169695Skan nLocals = 0; 518169695Skan#endif 519169695Skan 520169695Skan dictAppendCell(dp, LVALUEtoCELL(pSemiParen)); 521169695Skan pVM->state = INTERPRET; 522169695Skan dictUnsmudge(dp); 523169695Skan return; 524169695Skan} 525169695Skan 526169695Skan 527169695Skan/************************************************************************** 528169695Skan e x i t 529169695Skan** CORE 530169695Skan** This function simply pops the previous instruction 531169695Skan** pointer and returns to the "next" loop. Used for exiting from within 532169695Skan** a definition. Note that exitParen is identical to semiParen - they 533169695Skan** are in two different functions so that "see" can correctly identify 534169695Skan** the end of a colon definition, even if it uses "exit". 535169695Skan**************************************************************************/ 536169695Skanstatic void exitParen(FICL_VM *pVM) 537169695Skan{ 538169695Skan vmPopIP(pVM); 539169695Skan return; 540169695Skan} 541169695Skan 542169695Skanstatic void exitCoIm(FICL_VM *pVM) 543169695Skan{ 544169695Skan FICL_DICT *dp = ficlGetDict(); 545169695Skan assert(pExitParen); 546169695Skan IGNORE(pVM); 547169695Skan 548169695Skan#if FICL_WANT_LOCALS 549169695Skan if (nLocals > 0) 550169695Skan { 551169695Skan dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 552169695Skan } 553169695Skan#endif 554169695Skan dictAppendCell(dp, LVALUEtoCELL(pExitParen)); 555169695Skan return; 556169695Skan} 557169695Skan 558169695Skan 559169695Skan/************************************************************************** 560169695Skan c o n s t a n t P a r e n 561169695Skan** This is the run-time code for "constant". It simply returns the 562169695Skan** contents of its word's first data cell. 563169695Skan** 564169695Skan**************************************************************************/ 565169695Skan 566169695Skanvoid constantParen(FICL_VM *pVM) 567169695Skan{ 568169695Skan FICL_WORD *pFW = pVM->runningWord; 569169695Skan#if FICL_ROBUST > 1 570169695Skan vmCheckStack(pVM, 0, 1); 571169695Skan#endif 572169695Skan stackPush(pVM->pStack, pFW->param[0]); 573169695Skan return; 574169695Skan} 575169695Skan 576169695Skanvoid twoConstParen(FICL_VM *pVM) 577169695Skan{ 578169695Skan FICL_WORD *pFW = pVM->runningWord; 579169695Skan#if FICL_ROBUST > 1 580169695Skan vmCheckStack(pVM, 0, 2); 581169695Skan#endif 582169695Skan stackPush(pVM->pStack, pFW->param[0]); /* lo */ 583169695Skan stackPush(pVM->pStack, pFW->param[1]); /* hi */ 584169695Skan return; 585169695Skan} 586169695Skan 587169695Skan 588169695Skan/************************************************************************** 589169695Skan c o n s t a n t 590169695Skan** IMMEDIATE 591169695Skan** Compiles a constant into the dictionary. Constants return their 592169695Skan** value when invoked. Expects a value on top of the parm stack. 593169695Skan**************************************************************************/ 594169695Skan 595169695Skanstatic void constant(FICL_VM *pVM) 596169695Skan{ 597169695Skan FICL_DICT *dp = ficlGetDict(); 598169695Skan STRINGINFO si = vmGetWord(pVM); 599169695Skan 600169695Skan#if FICL_ROBUST > 1 601169695Skan vmCheckStack(pVM, 1, 0); 602169695Skan#endif 603169695Skan dictAppendWord2(dp, si, constantParen, FW_DEFAULT); 604169695Skan dictAppendCell(dp, stackPop(pVM->pStack)); 605169695Skan return; 606169695Skan} 607169695Skan 608169695Skan 609169695Skanstatic void twoConstant(FICL_VM *pVM) 610169695Skan{ 611169695Skan FICL_DICT *dp = ficlGetDict(); 612169695Skan STRINGINFO si = vmGetWord(pVM); 613169695Skan CELL c; 614169695Skan 615169695Skan#if FICL_ROBUST > 1 616169695Skan vmCheckStack(pVM, 2, 0); 617169695Skan#endif 618169695Skan c = stackPop(pVM->pStack); 619169695Skan dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT); 620169695Skan dictAppendCell(dp, stackPop(pVM->pStack)); 621169695Skan dictAppendCell(dp, c); 622169695Skan return; 623169695Skan} 624169695Skan 625169695Skan 626169695Skan/************************************************************************** 627169695Skan d i s p l a y C e l l 628169695Skan** Drop and print the contents of the cell at the top of the param 629169695Skan** stack 630169695Skan**************************************************************************/ 631169695Skan 632169695Skanstatic void displayCell(FICL_VM *pVM) 633169695Skan{ 634169695Skan CELL c; 635169695Skan#if FICL_ROBUST > 1 636169695Skan vmCheckStack(pVM, 1, 0); 637169695Skan#endif 638169695Skan c = stackPop(pVM->pStack); 639169695Skan ltoa((c).i, pVM->pad, pVM->base); 640169695Skan strcat(pVM->pad, " "); 641169695Skan vmTextOut(pVM, pVM->pad, 0); 642169695Skan return; 643169695Skan} 644169695Skan 645169695Skanstatic void displayCellNoPad(FICL_VM *pVM) 646169695Skan{ 647169695Skan CELL c; 648169695Skan#if FICL_ROBUST > 1 649169695Skan vmCheckStack(pVM, 1, 0); 650169695Skan#endif 651169695Skan c = stackPop(pVM->pStack); 652169695Skan ltoa((c).i, pVM->pad, pVM->base); 653169695Skan vmTextOut(pVM, pVM->pad, 0); 654169695Skan return; 655169695Skan} 656169695Skan 657169695Skanstatic void uDot(FICL_VM *pVM) 658169695Skan{ 659169695Skan FICL_UNS u; 660169695Skan#if FICL_ROBUST > 1 661169695Skan vmCheckStack(pVM, 1, 0); 662169695Skan#endif 663169695Skan u = stackPopUNS(pVM->pStack); 664169695Skan ultoa(u, pVM->pad, pVM->base); 665169695Skan strcat(pVM->pad, " "); 666169695Skan vmTextOut(pVM, pVM->pad, 0); 667169695Skan return; 668169695Skan} 669169695Skan 670169695Skan 671169695Skanstatic void hexDot(FICL_VM *pVM) 672169695Skan{ 673169695Skan FICL_UNS u; 674169695Skan#if FICL_ROBUST > 1 675169695Skan vmCheckStack(pVM, 1, 0); 676169695Skan#endif 677169695Skan u = stackPopUNS(pVM->pStack); 678169695Skan ultoa(u, pVM->pad, 16); 679169695Skan strcat(pVM->pad, " "); 680169695Skan vmTextOut(pVM, pVM->pad, 0); 681169695Skan return; 682169695Skan} 683169695Skan 684169695Skan 685169695Skan/************************************************************************** 686169695Skan d i s p l a y S t a c k 687169695Skan** Display the parameter stack (code for ".s") 688169695Skan**************************************************************************/ 689169695Skan 690169695Skanstatic void displayStack(FICL_VM *pVM) 691169695Skan{ 692169695Skan int d = stackDepth(pVM->pStack); 693169695Skan int i; 694169695Skan CELL *pCell; 695169695Skan 696169695Skan vmCheckStack(pVM, 0, 0); 697169695Skan 698169695Skan if (d == 0) 699169695Skan vmTextOut(pVM, "(Stack Empty)", 1); 700169695Skan else 701169695Skan { 702169695Skan pCell = pVM->pStack->sp; 703169695Skan for (i = 0; i < d; i++) 704169695Skan { 705169695Skan vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1); 706169695Skan } 707169695Skan } 708169695Skan} 709169695Skan 710169695Skan 711169695Skan/************************************************************************** 712169695Skan d u p & f r i e n d s 713169695Skan** 714169695Skan**************************************************************************/ 715169695Skan 716169695Skanstatic void depth(FICL_VM *pVM) 717169695Skan{ 718169695Skan int i; 719169695Skan#if FICL_ROBUST > 1 720169695Skan vmCheckStack(pVM, 0, 1); 721169695Skan#endif 722169695Skan i = stackDepth(pVM->pStack); 723169695Skan stackPushINT(pVM->pStack, i); 724169695Skan return; 725169695Skan} 726169695Skan 727169695Skan 728169695Skanstatic void drop(FICL_VM *pVM) 729169695Skan{ 730169695Skan#if FICL_ROBUST > 1 731169695Skan vmCheckStack(pVM, 1, 0); 732169695Skan#endif 733169695Skan stackDrop(pVM->pStack, 1); 734169695Skan return; 735169695Skan} 736169695Skan 737169695Skan 738169695Skanstatic void twoDrop(FICL_VM *pVM) 739169695Skan{ 740169695Skan#if FICL_ROBUST > 1 741169695Skan vmCheckStack(pVM, 2, 0); 742169695Skan#endif 743169695Skan stackDrop(pVM->pStack, 2); 744169695Skan return; 745169695Skan} 746169695Skan 747169695Skan 748169695Skanstatic void dup(FICL_VM *pVM) 749169695Skan{ 750169695Skan#if FICL_ROBUST > 1 751169695Skan vmCheckStack(pVM, 1, 2); 752169695Skan#endif 753169695Skan stackPick(pVM->pStack, 0); 754169695Skan return; 755169695Skan} 756169695Skan 757169695Skan 758169695Skanstatic void twoDup(FICL_VM *pVM) 759169695Skan{ 760169695Skan#if FICL_ROBUST > 1 761169695Skan vmCheckStack(pVM, 2, 4); 762169695Skan#endif 763169695Skan stackPick(pVM->pStack, 1); 764169695Skan stackPick(pVM->pStack, 1); 765169695Skan return; 766169695Skan} 767169695Skan 768169695Skan 769169695Skanstatic void over(FICL_VM *pVM) 770169695Skan{ 771169695Skan#if FICL_ROBUST > 1 772169695Skan vmCheckStack(pVM, 2, 3); 773169695Skan#endif 774169695Skan stackPick(pVM->pStack, 1); 775169695Skan return; 776169695Skan} 777169695Skan 778169695Skanstatic void twoOver(FICL_VM *pVM) 779169695Skan{ 780169695Skan#if FICL_ROBUST > 1 781169695Skan vmCheckStack(pVM, 4, 6); 782169695Skan#endif 783169695Skan stackPick(pVM->pStack, 3); 784169695Skan stackPick(pVM->pStack, 3); 785169695Skan return; 786169695Skan} 787169695Skan 788169695Skan 789169695Skanstatic void pick(FICL_VM *pVM) 790169695Skan{ 791169695Skan CELL c = stackPop(pVM->pStack); 792169695Skan#if FICL_ROBUST > 1 793169695Skan vmCheckStack(pVM, c.i+1, c.i+2); 794169695Skan#endif 795169695Skan stackPick(pVM->pStack, c.i); 796169695Skan return; 797169695Skan} 798169695Skan 799169695Skan 800169695Skanstatic void questionDup(FICL_VM *pVM) 801169695Skan{ 802169695Skan CELL c; 803169695Skan#if FICL_ROBUST > 1 804169695Skan vmCheckStack(pVM, 1, 2); 805169695Skan#endif 806169695Skan c = stackGetTop(pVM->pStack); 807169695Skan 808169695Skan if (c.i != 0) 809169695Skan stackPick(pVM->pStack, 0); 810169695Skan 811169695Skan return; 812169695Skan} 813169695Skan 814169695Skan 815169695Skanstatic void roll(FICL_VM *pVM) 816169695Skan{ 817169695Skan int i = stackPop(pVM->pStack).i; 818169695Skan i = (i > 0) ? i : 0; 819169695Skan#if FICL_ROBUST > 1 820169695Skan vmCheckStack(pVM, i+1, i+1); 821169695Skan#endif 822169695Skan stackRoll(pVM->pStack, i); 823169695Skan return; 824169695Skan} 825169695Skan 826169695Skan 827169695Skanstatic void minusRoll(FICL_VM *pVM) 828169695Skan{ 829169695Skan int i = stackPop(pVM->pStack).i; 830169695Skan i = (i > 0) ? i : 0; 831169695Skan#if FICL_ROBUST > 1 832169695Skan vmCheckStack(pVM, i+1, i+1); 833169695Skan#endif 834169695Skan stackRoll(pVM->pStack, -i); 835169695Skan return; 836169695Skan} 837169695Skan 838169695Skan 839169695Skanstatic void rot(FICL_VM *pVM) 840169695Skan{ 841169695Skan#if FICL_ROBUST > 1 842169695Skan vmCheckStack(pVM, 3, 3); 843169695Skan#endif 844169695Skan stackRoll(pVM->pStack, 2); 845169695Skan return; 846169695Skan} 847169695Skan 848169695Skan 849169695Skanstatic void swap(FICL_VM *pVM) 850169695Skan{ 851169695Skan#if FICL_ROBUST > 1 852169695Skan vmCheckStack(pVM, 2, 2); 853169695Skan#endif 854169695Skan stackRoll(pVM->pStack, 1); 855169695Skan return; 856169695Skan} 857169695Skan 858169695Skan 859169695Skanstatic void twoSwap(FICL_VM *pVM) 860169695Skan{ 861169695Skan#if FICL_ROBUST > 1 862169695Skan vmCheckStack(pVM, 4, 4); 863169695Skan#endif 864169695Skan stackRoll(pVM->pStack, 3); 865169695Skan stackRoll(pVM->pStack, 3); 866169695Skan return; 867169695Skan} 868169695Skan 869169695Skan 870169695Skan/************************************************************************** 871169695Skan e m i t & f r i e n d s 872169695Skan** 873169695Skan**************************************************************************/ 874169695Skan 875169695Skanstatic void emit(FICL_VM *pVM) 876169695Skan{ 877169695Skan char *cp = pVM->pad; 878169695Skan int i; 879169695Skan 880169695Skan#if FICL_ROBUST > 1 881169695Skan vmCheckStack(pVM, 1, 0); 882169695Skan#endif 883169695Skan i = stackPopINT(pVM->pStack); 884169695Skan cp[0] = (char)i; 885169695Skan cp[1] = '\0'; 886169695Skan vmTextOut(pVM, cp, 0); 887169695Skan return; 888169695Skan} 889169695Skan 890169695Skan 891169695Skanstatic void cr(FICL_VM *pVM) 892169695Skan{ 893169695Skan vmTextOut(pVM, "", 1); 894169695Skan return; 895169695Skan} 896169695Skan 897169695Skan 898169695Skanstatic void commentLine(FICL_VM *pVM) 899169695Skan{ 900169695Skan char *cp = vmGetInBuf(pVM); 901169695Skan char *pEnd = vmGetInBufEnd(pVM); 902169695Skan char ch = *cp; 903169695Skan 904169695Skan while ((cp != pEnd) && (ch != '\r') && (ch != '\n')) 905169695Skan { 906169695Skan ch = *++cp; 907169695Skan } 908169695Skan 909169695Skan /* 910169695Skan ** Cope with DOS or UNIX-style EOLs - 911169695Skan ** Check for /r, /n, /r/n, or /n/r end-of-line sequences, 912169695Skan ** and point cp to next char. If EOL is \0, we're done. 913169695Skan */ 914169695Skan if (cp != pEnd) 915169695Skan { 916169695Skan cp++; 917169695Skan 918169695Skan if ( (cp != pEnd) && (ch != *cp) 919169695Skan && ((*cp == '\r') || (*cp == '\n')) ) 920169695Skan cp++; 921169695Skan } 922169695Skan 923169695Skan vmUpdateTib(pVM, cp); 924169695Skan return; 925169695Skan} 926169695Skan 927169695Skan 928169695Skan/* 929169695Skan** paren CORE 930169695Skan** Compilation: Perform the execution semantics given below. 931169695Skan** Execution: ( "ccc<paren>" -- ) 932169695Skan** Parse ccc delimited by ) (right parenthesis). ( is an immediate word. 933169695Skan** The number of characters in ccc may be zero to the number of characters 934169695Skan** in the parse area. 935169695Skan** 936169695Skan*/ 937169695Skanstatic void commentHang(FICL_VM *pVM) 938169695Skan{ 939169695Skan vmParseStringEx(pVM, ')', 0); 940169695Skan return; 941169695Skan} 942169695Skan 943169695Skan 944169695Skan/************************************************************************** 945169695Skan F E T C H & S T O R E 946169695Skan** 947169695Skan**************************************************************************/ 948169695Skan 949169695Skanstatic void fetch(FICL_VM *pVM) 950169695Skan{ 951169695Skan CELL *pCell; 952169695Skan#if FICL_ROBUST > 1 953169695Skan vmCheckStack(pVM, 1, 1); 954169695Skan#endif 955169695Skan pCell = (CELL *)stackPopPtr(pVM->pStack); 956169695Skan stackPush(pVM->pStack, *pCell); 957169695Skan return; 958169695Skan} 959169695Skan 960169695Skan/* 961169695Skan** two-fetch CORE ( a-addr -- x1 x2 ) 962169695Skan** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and 963169695Skan** x1 at the next consecutive cell. It is equivalent to the sequence 964169695Skan** DUP CELL+ @ SWAP @ . 965169695Skan*/ 966169695Skanstatic void twoFetch(FICL_VM *pVM) 967169695Skan{ 968169695Skan CELL *pCell; 969169695Skan#if FICL_ROBUST > 1 970169695Skan vmCheckStack(pVM, 1, 2); 971169695Skan#endif 972169695Skan pCell = (CELL *)stackPopPtr(pVM->pStack); 973169695Skan stackPush(pVM->pStack, *pCell++); 974169695Skan stackPush(pVM->pStack, *pCell); 975169695Skan swap(pVM); 976169695Skan return; 977169695Skan} 978169695Skan 979169695Skan/* 980169695Skan** store CORE ( x a-addr -- ) 981169695Skan** Store x at a-addr. 982169695Skan*/ 983169695Skanstatic void store(FICL_VM *pVM) 984169695Skan{ 985169695Skan CELL *pCell; 986169695Skan#if FICL_ROBUST > 1 987169695Skan vmCheckStack(pVM, 2, 0); 988169695Skan#endif 989169695Skan pCell = (CELL *)stackPopPtr(pVM->pStack); 990169695Skan *pCell = stackPop(pVM->pStack); 991169695Skan} 992169695Skan 993169695Skan/* 994169695Skan** two-store CORE ( x1 x2 a-addr -- ) 995169695Skan** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the 996169695Skan** next consecutive cell. It is equivalent to the sequence 997169695Skan** SWAP OVER ! CELL+ ! . 998169695Skan*/ 999169695Skanstatic void twoStore(FICL_VM *pVM) 1000169695Skan{ 1001169695Skan CELL *pCell; 1002169695Skan#if FICL_ROBUST > 1 1003169695Skan vmCheckStack(pVM, 3, 0); 1004169695Skan#endif 1005169695Skan pCell = (CELL *)stackPopPtr(pVM->pStack); 1006169695Skan *pCell++ = stackPop(pVM->pStack); 1007169695Skan *pCell = stackPop(pVM->pStack); 1008169695Skan} 1009169695Skan 1010169695Skanstatic void plusStore(FICL_VM *pVM) 1011169695Skan{ 1012169695Skan CELL *pCell; 1013169695Skan#if FICL_ROBUST > 1 1014169695Skan vmCheckStack(pVM, 2, 0); 1015169695Skan#endif 1016169695Skan pCell = (CELL *)stackPopPtr(pVM->pStack); 1017169695Skan pCell->i += stackPop(pVM->pStack).i; 1018169695Skan} 1019169695Skan 1020169695Skan 1021169695Skanstatic void iFetch(FICL_VM *pVM) 1022169695Skan{ 1023169695Skan UNS32 *pw; 1024169695Skan#if FICL_ROBUST > 1 1025169695Skan vmCheckStack(pVM, 1, 1); 1026169695Skan#endif 1027169695Skan pw = (UNS32 *)stackPopPtr(pVM->pStack); 1028169695Skan stackPushUNS(pVM->pStack, (FICL_UNS)*pw); 1029169695Skan return; 1030169695Skan} 1031169695Skan 1032169695Skanstatic void iStore(FICL_VM *pVM) 1033169695Skan{ 1034169695Skan UNS32 *pw; 1035169695Skan#if FICL_ROBUST > 1 1036169695Skan vmCheckStack(pVM, 2, 0); 1037169695Skan#endif 1038169695Skan pw = (UNS32 *)stackPopPtr(pVM->pStack); 1039169695Skan *pw = (UNS32)(stackPop(pVM->pStack).u); 1040169695Skan} 1041169695Skan 1042169695Skanstatic void wFetch(FICL_VM *pVM) 1043169695Skan{ 1044169695Skan UNS16 *pw; 1045169695Skan#if FICL_ROBUST > 1 1046169695Skan vmCheckStack(pVM, 1, 1); 1047169695Skan#endif 1048169695Skan pw = (UNS16 *)stackPopPtr(pVM->pStack); 1049169695Skan stackPushUNS(pVM->pStack, (FICL_UNS)*pw); 1050169695Skan return; 1051169695Skan} 1052169695Skan 1053169695Skanstatic void wStore(FICL_VM *pVM) 1054169695Skan{ 1055169695Skan UNS16 *pw; 1056169695Skan#if FICL_ROBUST > 1 1057169695Skan vmCheckStack(pVM, 2, 0); 1058169695Skan#endif 1059169695Skan pw = (UNS16 *)stackPopPtr(pVM->pStack); 1060169695Skan *pw = (UNS16)(stackPop(pVM->pStack).u); 1061169695Skan} 1062169695Skan 1063169695Skanstatic void cFetch(FICL_VM *pVM) 1064169695Skan{ 1065169695Skan UNS8 *pc; 1066169695Skan#if FICL_ROBUST > 1 1067169695Skan vmCheckStack(pVM, 1, 1); 1068169695Skan#endif 1069169695Skan pc = (UNS8 *)stackPopPtr(pVM->pStack); 1070169695Skan stackPushUNS(pVM->pStack, (FICL_UNS)*pc); 1071169695Skan return; 1072169695Skan} 1073169695Skan 1074169695Skanstatic void cStore(FICL_VM *pVM) 1075169695Skan{ 1076169695Skan UNS8 *pc; 1077169695Skan#if FICL_ROBUST > 1 1078169695Skan vmCheckStack(pVM, 2, 0); 1079169695Skan#endif 1080169695Skan pc = (UNS8 *)stackPopPtr(pVM->pStack); 1081169695Skan *pc = (UNS8)(stackPop(pVM->pStack).u); 1082169695Skan} 1083169695Skan 1084169695Skan 1085169695Skan/************************************************************************** 1086169695Skan i f C o I m 1087169695Skan** IMMEDIATE 1088169695Skan** Compiles code for a conditional branch into the dictionary 1089169695Skan** and pushes the branch patch address on the stack for later 1090169695Skan** patching by ELSE or THEN/ENDIF. 1091169695Skan**************************************************************************/ 1092169695Skan 1093169695Skanstatic void ifCoIm(FICL_VM *pVM) 1094169695Skan{ 1095169695Skan FICL_DICT *dp = ficlGetDict(); 1096169695Skan 1097169695Skan assert(pIfParen); 1098169695Skan 1099169695Skan dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 1100169695Skan markBranch(dp, pVM, origTag); 1101169695Skan dictAppendUNS(dp, 1); 1102169695Skan return; 1103169695Skan} 1104169695Skan 1105169695Skan 1106169695Skan/************************************************************************** 1107169695Skan i f P a r e n 1108169695Skan** Runtime code to do "if" or "until": pop a flag from the stack, 1109169695Skan** fall through if true, branch if false. Probably ought to be 1110169695Skan** called (not?branch) since it does "branch if false". 1111169695Skan**************************************************************************/ 1112169695Skan 1113169695Skanstatic void ifParen(FICL_VM *pVM) 1114169695Skan{ 1115169695Skan FICL_UNS flag; 1116169695Skan 1117169695Skan#if FICL_ROBUST > 1 1118169695Skan vmCheckStack(pVM, 1, 0); 1119169695Skan#endif 1120169695Skan flag = stackPopUNS(pVM->pStack); 1121169695Skan 1122169695Skan if (flag) 1123169695Skan { /* fall through */ 1124169695Skan vmBranchRelative(pVM, 1); 1125169695Skan } 1126169695Skan else 1127169695Skan { /* take branch (to else/endif/begin) */ 1128169695Skan vmBranchRelative(pVM, *(int*)(pVM->ip)); 1129169695Skan } 1130169695Skan 1131169695Skan return; 1132169695Skan} 1133169695Skan 1134169695Skan 1135169695Skan/************************************************************************** 1136169695Skan e l s e C o I m 1137169695Skan** 1138169695Skan** IMMEDIATE -- compiles an "else"... 1139169695Skan** 1) Compile a branch and a patch address; the address gets patched 1140169695Skan** by "endif" to point past the "else" code. 1141169695Skan** 2) Pop the the "if" patch address 1142169695Skan** 3) Patch the "if" branch to point to the current compile address. 1143169695Skan** 4) Push the "else" patch address. ("endif" patches this to jump past 1144169695Skan** the "else" code. 1145169695Skan**************************************************************************/ 1146169695Skan 1147169695Skanstatic void elseCoIm(FICL_VM *pVM) 1148169695Skan{ 1149169695Skan CELL *patchAddr; 1150169695Skan int offset; 1151169695Skan FICL_DICT *dp = ficlGetDict(); 1152169695Skan 1153169695Skan assert(pBranchParen); 1154169695Skan /* (1) compile branch runtime */ 1155169695Skan dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); 1156169695Skan matchControlTag(pVM, origTag); 1157169695Skan patchAddr = 1158169695Skan (CELL *)stackPopPtr(pVM->pStack); /* (2) pop "if" patch addr */ 1159169695Skan markBranch(dp, pVM, origTag); /* (4) push "else" patch addr */ 1160169695Skan dictAppendUNS(dp, 1); /* (1) compile patch placeholder */ 1161169695Skan offset = dp->here - patchAddr; 1162169695Skan *patchAddr = LVALUEtoCELL(offset); /* (3) Patch "if" */ 1163169695Skan 1164169695Skan return; 1165169695Skan} 1166169695Skan 1167169695Skan 1168169695Skan/************************************************************************** 1169169695Skan b r a n c h P a r e n 1170169695Skan** 1171169695Skan** Runtime for "(branch)" -- expects a literal offset in the next 1172169695Skan** compilation address, and branches to that location. 1173169695Skan**************************************************************************/ 1174169695Skan 1175169695Skanstatic void branchParen(FICL_VM *pVM) 1176169695Skan{ 1177169695Skan vmBranchRelative(pVM, *(int *)(pVM->ip)); 1178169695Skan return; 1179169695Skan} 1180169695Skan 1181169695Skan 1182169695Skan/************************************************************************** 1183169695Skan e n d i f C o I m 1184169695Skan** 1185169695Skan**************************************************************************/ 1186169695Skan 1187169695Skanstatic void endifCoIm(FICL_VM *pVM) 1188169695Skan{ 1189169695Skan FICL_DICT *dp = ficlGetDict(); 1190169695Skan resolveForwardBranch(dp, pVM, origTag); 1191169695Skan return; 1192169695Skan} 1193169695Skan 1194169695Skan 1195169695Skan/************************************************************************** 1196169695Skan h a s h 1197169695Skan** hash ( c-addr u -- code) 1198169695Skan** calculates hashcode of specified string and leaves it on the stack 1199169695Skan**************************************************************************/ 1200169695Skan 1201169695Skanstatic void hash(FICL_VM *pVM) 1202169695Skan{ 1203169695Skan STRINGINFO si; 1204169695Skan SI_SETLEN(si, stackPopUNS(pVM->pStack)); 1205169695Skan SI_SETPTR(si, stackPopPtr(pVM->pStack)); 1206169695Skan stackPushUNS(pVM->pStack, hashHashCode(si)); 1207169695Skan return; 1208169695Skan} 1209169695Skan 1210169695Skan 1211169695Skan/************************************************************************** 1212169695Skan i n t e r p r e t 1213169695Skan** This is the "user interface" of a Forth. It does the following: 1214169695Skan** while there are words in the VM's Text Input Buffer 1215169695Skan** Copy next word into the pad (vmGetWord) 1216169695Skan** Attempt to find the word in the dictionary (dictLookup) 1217169695Skan** If successful, execute the word. 1218169695Skan** Otherwise, attempt to convert the word to a number (isNumber) 1219169695Skan** If successful, push the number onto the parameter stack. 1220169695Skan** Otherwise, print an error message and exit loop... 1221169695Skan** End Loop 1222169695Skan** 1223169695Skan** From the standard, section 3.4 1224169695Skan** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall 1225169695Skan** repeat the following steps until either the parse area is empty or an 1226169695Skan** ambiguous condition exists: 1227169695Skan** a) Skip leading spaces and parse a name (see 3.4.1); 1228169695Skan**************************************************************************/ 1229169695Skan 1230169695Skanstatic void interpret(FICL_VM *pVM) 1231169695Skan{ 1232169695Skan STRINGINFO si = vmGetWord0(pVM); 1233169695Skan assert(pVM); 1234169695Skan 1235169695Skan vmBranchRelative(pVM, -1); 1236169695Skan 1237169695Skan /* 1238169695Skan ** Get next word...if out of text, we're done. 1239169695Skan */ 1240169695Skan if (si.count == 0) 1241169695Skan { 1242169695Skan vmThrow(pVM, VM_OUTOFTEXT); 1243169695Skan } 1244169695Skan 1245169695Skan interpWord(pVM, si); 1246169695Skan 1247169695Skan 1248169695Skan return; /* back to inner interpreter */ 1249169695Skan} 1250169695Skan 1251169695Skan/************************************************************************** 1252169695Skan** From the standard, section 3.4 1253169695Skan** b) Search the dictionary name space (see 3.4.2). If a definition name 1254169695Skan** matching the string is found: 1255169695Skan** 1.if interpreting, perform the interpretation semantics of the definition 1256169695Skan** (see 3.4.3.2), and continue at a); 1257169695Skan** 2.if compiling, perform the compilation semantics of the definition 1258169695Skan** (see 3.4.3.3), and continue at a). 1259169695Skan** 1260169695Skan** c) If a definition name matching the string is not found, attempt to 1261169695Skan** convert the string to a number (see 3.4.1.3). If successful: 1262169695Skan** 1.if interpreting, place the number on the data stack, and continue at a); 1263169695Skan** 2.if compiling, compile code that when executed will place the number on 1264169695Skan** the stack (see 6.1.1780 LITERAL), and continue at a); 1265169695Skan** 1266169695Skan** d) If unsuccessful, an ambiguous condition exists (see 3.4.4). 1267169695Skan**************************************************************************/ 1268169695Skanstatic void interpWord(FICL_VM *pVM, STRINGINFO si) 1269169695Skan{ 1270169695Skan FICL_DICT *dp = ficlGetDict(); 1271169695Skan FICL_WORD *tempFW; 1272169695Skan 1273169695Skan#if FICL_ROBUST 1274169695Skan dictCheck(dp, pVM, 0); 1275169695Skan vmCheckStack(pVM, 0, 0); 1276169695Skan#endif 1277169695Skan 1278169695Skan#if FICL_WANT_LOCALS 1279169695Skan if (nLocals > 0) 1280169695Skan { 1281169695Skan tempFW = dictLookupLoc(dp, si); 1282169695Skan } 1283169695Skan else 1284169695Skan#endif 1285169695Skan tempFW = dictLookup(dp, si); 1286169695Skan 1287169695Skan if (pVM->state == INTERPRET) 1288169695Skan { 1289169695Skan if (tempFW != NULL) 1290169695Skan { 1291169695Skan if (wordIsCompileOnly(tempFW)) 1292169695Skan { 1293169695Skan vmThrowErr(pVM, "Error: Compile only!"); 1294169695Skan } 1295169695Skan 1296169695Skan vmExecute(pVM, tempFW); 1297169695Skan } 1298169695Skan 1299169695Skan else if (!isNumber(pVM, si)) 1300169695Skan { 1301169695Skan int i = SI_COUNT(si); 1302169695Skan vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1303169695Skan } 1304169695Skan } 1305169695Skan 1306169695Skan else /* (pVM->state == COMPILE) */ 1307169695Skan { 1308169695Skan if (tempFW != NULL) 1309169695Skan { 1310169695Skan if (wordIsImmediate(tempFW)) 1311169695Skan { 1312169695Skan vmExecute(pVM, tempFW); 1313169695Skan } 1314169695Skan else 1315169695Skan { 1316169695Skan dictAppendCell(dp, LVALUEtoCELL(tempFW)); 1317169695Skan } 1318169695Skan } 1319169695Skan else if (isNumber(pVM, si)) 1320169695Skan { 1321169695Skan literalIm(pVM); 1322169695Skan } 1323169695Skan else 1324169695Skan { 1325169695Skan int i = SI_COUNT(si); 1326169695Skan vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 1327169695Skan } 1328169695Skan } 1329169695Skan 1330169695Skan return; 1331169695Skan} 1332169695Skan 1333169695Skan 1334169695Skan/************************************************************************** 1335169695Skan l i t e r a l P a r e n 1336169695Skan** 1337169695Skan** This is the runtime for (literal). It assumes that it is part of a colon 1338169695Skan** definition, and that the next CELL contains a value to be pushed on the 1339169695Skan** parameter stack at runtime. This code is compiled by "literal". 1340169695Skan** 1341169695Skan**************************************************************************/ 1342169695Skan 1343169695Skanstatic void literalParen(FICL_VM *pVM) 1344169695Skan{ 1345169695Skan#if FICL_ROBUST > 1 1346169695Skan vmCheckStack(pVM, 0, 1); 1347169695Skan#endif 1348169695Skan stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip)); 1349169695Skan vmBranchRelative(pVM, 1); 1350169695Skan return; 1351169695Skan} 1352169695Skan 1353169695Skanstatic void twoLitParen(FICL_VM *pVM) 1354169695Skan{ 1355169695Skan#if FICL_ROBUST > 1 1356169695Skan vmCheckStack(pVM, 0, 2); 1357169695Skan#endif 1358169695Skan stackPushINT(pVM->pStack, *((FICL_INT *)(pVM->ip)+1)); 1359169695Skan stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip)); 1360169695Skan vmBranchRelative(pVM, 2); 1361169695Skan return; 1362169695Skan} 1363169695Skan 1364169695Skan 1365169695Skan/************************************************************************** 1366169695Skan l i t e r a l I m 1367169695Skan** 1368169695Skan** IMMEDIATE code for "literal". This function gets a value from the stack 1369169695Skan** and compiles it into the dictionary preceded by the code for "(literal)". 1370169695Skan** IMMEDIATE 1371169695Skan**************************************************************************/ 1372169695Skan 1373169695Skanstatic void literalIm(FICL_VM *pVM) 1374169695Skan{ 1375169695Skan FICL_DICT *dp = ficlGetDict(); 1376169695Skan assert(pLitParen); 1377169695Skan 1378169695Skan dictAppendCell(dp, LVALUEtoCELL(pLitParen)); 1379169695Skan dictAppendCell(dp, stackPop(pVM->pStack)); 1380169695Skan 1381169695Skan return; 1382169695Skan} 1383169695Skan 1384169695Skan 1385169695Skanstatic void twoLiteralIm(FICL_VM *pVM) 1386169695Skan{ 1387169695Skan FICL_DICT *dp = ficlGetDict(); 1388169695Skan assert(pTwoLitParen); 1389169695Skan 1390169695Skan dictAppendCell(dp, LVALUEtoCELL(pTwoLitParen)); 1391169695Skan dictAppendCell(dp, stackPop(pVM->pStack)); 1392169695Skan dictAppendCell(dp, stackPop(pVM->pStack)); 1393169695Skan 1394169695Skan return; 1395169695Skan} 1396169695Skan 1397169695Skan/************************************************************************** 1398169695Skan l i s t W o r d s 1399169695Skan** 1400169695Skan**************************************************************************/ 1401169695Skan#define nCOLWIDTH 8 1402169695Skanstatic void listWords(FICL_VM *pVM) 1403169695Skan{ 1404169695Skan FICL_DICT *dp = ficlGetDict(); 1405169695Skan FICL_HASH *pHash = dp->pSearch[dp->nLists - 1]; 1406169695Skan FICL_WORD *wp; 1407169695Skan int nChars = 0; 1408169695Skan int len; 1409169695Skan int y = 0; 1410169695Skan unsigned i; 1411169695Skan int nWords = 0; 1412169695Skan char *cp; 1413169695Skan char *pPad = pVM->pad; 1414169695Skan 1415169695Skan for (i = 0; i < pHash->size; i++) 1416169695Skan { 1417169695Skan for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 1418169695Skan { 1419169695Skan if (wp->nName == 0) /* ignore :noname defs */ 1420169695Skan continue; 1421169695Skan 1422169695Skan cp = wp->name; 1423169695Skan nChars += sprintf(pPad + nChars, "%s", cp); 1424169695Skan 1425169695Skan if (nChars > 70) 1426169695Skan { 1427169695Skan pPad[nChars] = '\0'; 1428169695Skan nChars = 0; 1429169695Skan y++; 1430169695Skan if(y>23) { 1431169695Skan y=0; 1432169695Skan vmTextOut(pVM, "--- Press Enter to continue ---",0); 1433169695Skan getchar(); 1434169695Skan vmTextOut(pVM,"\r",0); 1435169695Skan } 1436169695Skan vmTextOut(pVM, pPad, 1); 1437169695Skan } 1438169695Skan else 1439169695Skan { 1440169695Skan len = nCOLWIDTH - nChars % nCOLWIDTH; 1441169695Skan while (len-- > 0) 1442169695Skan pPad[nChars++] = ' '; 1443169695Skan } 1444169695Skan 1445169695Skan if (nChars > 70) 1446169695Skan { 1447169695Skan pPad[nChars] = '\0'; 1448169695Skan nChars = 0; 1449169695Skan y++; 1450169695Skan if(y>23) { 1451169695Skan y=0; 1452169695Skan vmTextOut(pVM, "--- Press Enter to continue ---",0); 1453169695Skan getchar(); 1454169695Skan vmTextOut(pVM,"\r",0); 1455169695Skan } 1456169695Skan vmTextOut(pVM, pPad, 1); 1457169695Skan } 1458169695Skan } 1459169695Skan } 1460169695Skan 1461169695Skan if (nChars > 0) 1462169695Skan { 1463169695Skan pPad[nChars] = '\0'; 1464169695Skan nChars = 0; 1465169695Skan vmTextOut(pVM, pPad, 1); 1466169695Skan } 1467169695Skan 1468169695Skan sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total", 1469169695Skan nWords, (long) (dp->here - dp->dict), dp->size); 1470169695Skan vmTextOut(pVM, pVM->pad, 1); 1471169695Skan return; 1472169695Skan} 1473169695Skan 1474169695Skan 1475169695Skanstatic void listEnv(FICL_VM *pVM) 1476169695Skan{ 1477169695Skan FICL_DICT *dp = ficlGetEnv(); 1478169695Skan FICL_HASH *pHash = dp->pForthWords; 1479169695Skan FICL_WORD *wp; 1480169695Skan unsigned i; 1481169695Skan int nWords = 0; 1482169695Skan 1483169695Skan for (i = 0; i < pHash->size; i++) 1484169695Skan { 1485169695Skan for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++) 1486169695Skan { 1487169695Skan vmTextOut(pVM, wp->name, 1); 1488169695Skan } 1489169695Skan } 1490169695Skan 1491169695Skan sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total", 1492169695Skan nWords, (long) (dp->here - dp->dict), dp->size); 1493169695Skan vmTextOut(pVM, pVM->pad, 1); 1494169695Skan return; 1495169695Skan} 1496169695Skan 1497169695Skan 1498169695Skan/************************************************************************** 1499169695Skan l o g i c a n d c o m p a r i s o n s 1500169695Skan** 1501169695Skan**************************************************************************/ 1502169695Skan 1503169695Skanstatic void zeroEquals(FICL_VM *pVM) 1504169695Skan{ 1505169695Skan CELL c; 1506169695Skan#if FICL_ROBUST > 1 1507169695Skan vmCheckStack(pVM, 1, 1); 1508169695Skan#endif 1509169695Skan c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0); 1510169695Skan stackPush(pVM->pStack, c); 1511169695Skan return; 1512169695Skan} 1513169695Skan 1514169695Skanstatic void zeroLess(FICL_VM *pVM) 1515169695Skan{ 1516169695Skan CELL c; 1517169695Skan#if FICL_ROBUST > 1 1518169695Skan vmCheckStack(pVM, 1, 1); 1519169695Skan#endif 1520169695Skan c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0); 1521169695Skan stackPush(pVM->pStack, c); 1522169695Skan return; 1523169695Skan} 1524169695Skan 1525169695Skanstatic void zeroGreater(FICL_VM *pVM) 1526169695Skan{ 1527169695Skan CELL c; 1528169695Skan#if FICL_ROBUST > 1 1529169695Skan vmCheckStack(pVM, 1, 1); 1530169695Skan#endif 1531169695Skan c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0); 1532169695Skan stackPush(pVM->pStack, c); 1533169695Skan return; 1534169695Skan} 1535169695Skan 1536169695Skanstatic void isEqual(FICL_VM *pVM) 1537169695Skan{ 1538169695Skan CELL x, y; 1539169695Skan 1540169695Skan#if FICL_ROBUST > 1 1541169695Skan vmCheckStack(pVM, 2, 1); 1542169695Skan#endif 1543169695Skan x = stackPop(pVM->pStack); 1544169695Skan y = stackPop(pVM->pStack); 1545169695Skan stackPushINT(pVM->pStack, FICL_BOOL(x.i == y.i)); 1546169695Skan return; 1547169695Skan} 1548169695Skan 1549169695Skanstatic void isLess(FICL_VM *pVM) 1550169695Skan{ 1551169695Skan CELL x, y; 1552169695Skan#if FICL_ROBUST > 1 1553169695Skan vmCheckStack(pVM, 2, 1); 1554169695Skan#endif 1555169695Skan y = stackPop(pVM->pStack); 1556169695Skan x = stackPop(pVM->pStack); 1557169695Skan stackPushINT(pVM->pStack, FICL_BOOL(x.i < y.i)); 1558169695Skan return; 1559169695Skan} 1560169695Skan 1561169695Skanstatic void uIsLess(FICL_VM *pVM) 1562169695Skan{ 1563169695Skan FICL_UNS u1, u2; 1564169695Skan#if FICL_ROBUST > 1 1565169695Skan vmCheckStack(pVM, 2, 1); 1566169695Skan#endif 1567169695Skan u2 = stackPopUNS(pVM->pStack); 1568169695Skan u1 = stackPopUNS(pVM->pStack); 1569169695Skan stackPushINT(pVM->pStack, FICL_BOOL(u1 < u2)); 1570169695Skan return; 1571169695Skan} 1572169695Skan 1573169695Skanstatic void isGreater(FICL_VM *pVM) 1574169695Skan{ 1575169695Skan CELL x, y; 1576169695Skan#if FICL_ROBUST > 1 1577169695Skan vmCheckStack(pVM, 2, 1); 1578169695Skan#endif 1579169695Skan y = stackPop(pVM->pStack); 1580169695Skan x = stackPop(pVM->pStack); 1581169695Skan stackPushINT(pVM->pStack, FICL_BOOL(x.i > y.i)); 1582169695Skan return; 1583169695Skan} 1584169695Skan 1585169695Skanstatic void bitwiseAnd(FICL_VM *pVM) 1586169695Skan{ 1587169695Skan CELL x, y; 1588169695Skan#if FICL_ROBUST > 1 1589169695Skan vmCheckStack(pVM, 2, 1); 1590169695Skan#endif 1591169695Skan x = stackPop(pVM->pStack); 1592169695Skan y = stackPop(pVM->pStack); 1593169695Skan stackPushINT(pVM->pStack, x.i & y.i); 1594169695Skan return; 1595169695Skan} 1596169695Skan 1597169695Skanstatic void bitwiseOr(FICL_VM *pVM) 1598169695Skan{ 1599169695Skan CELL x, y; 1600169695Skan#if FICL_ROBUST > 1 1601169695Skan vmCheckStack(pVM, 2, 1); 1602169695Skan#endif 1603169695Skan x = stackPop(pVM->pStack); 1604169695Skan y = stackPop(pVM->pStack); 1605169695Skan stackPushINT(pVM->pStack, x.i | y.i); 1606169695Skan return; 1607169695Skan} 1608169695Skan 1609169695Skanstatic void bitwiseXor(FICL_VM *pVM) 1610169695Skan{ 1611169695Skan CELL x, y; 1612169695Skan#if FICL_ROBUST > 1 1613169695Skan vmCheckStack(pVM, 2, 1); 1614169695Skan#endif 1615169695Skan x = stackPop(pVM->pStack); 1616169695Skan y = stackPop(pVM->pStack); 1617169695Skan stackPushINT(pVM->pStack, x.i ^ y.i); 1618169695Skan return; 1619169695Skan} 1620169695Skan 1621169695Skanstatic void bitwiseNot(FICL_VM *pVM) 1622169695Skan{ 1623169695Skan CELL x; 1624169695Skan#if FICL_ROBUST > 1 1625169695Skan vmCheckStack(pVM, 1, 1); 1626169695Skan#endif 1627169695Skan x = stackPop(pVM->pStack); 1628169695Skan stackPushINT(pVM->pStack, ~x.i); 1629169695Skan return; 1630169695Skan} 1631169695Skan 1632169695Skan 1633169695Skan/************************************************************************** 1634169695Skan D o / L o o p 1635169695Skan** do -- IMMEDIATE COMPILE ONLY 1636169695Skan** Compiles code to initialize a loop: compile (do), 1637169695Skan** allot space to hold the "leave" address, push a branch 1638169695Skan** target address for the loop. 1639169695Skan** (do) -- runtime for "do" 1640169695Skan** pops index and limit from the p stack and moves them 1641169695Skan** to the r stack, then skips to the loop body. 1642169695Skan** loop -- IMMEDIATE COMPILE ONLY 1643169695Skan** +loop 1644169695Skan** Compiles code for the test part of a loop: 1645169695Skan** compile (loop), resolve forward branch from "do", and 1646169695Skan** copy "here" address to the "leave" address allotted by "do" 1647169695Skan** i,j,k -- COMPILE ONLY 1648169695Skan** Runtime: Push loop indices on param stack (i is innermost loop...) 1649169695Skan** Note: each loop has three values on the return stack: 1650169695Skan** ( R: leave limit index ) 1651169695Skan** "leave" is the absolute address of the next cell after the loop 1652169695Skan** limit and index are the loop control variables. 1653169695Skan** leave -- COMPILE ONLY 1654169695Skan** Runtime: pop the loop control variables, then pop the 1655169695Skan** "leave" address and jump (absolute) there. 1656169695Skan**************************************************************************/ 1657169695Skan 1658169695Skanstatic void doCoIm(FICL_VM *pVM) 1659169695Skan{ 1660169695Skan FICL_DICT *dp = ficlGetDict(); 1661169695Skan 1662169695Skan assert(pDoParen); 1663169695Skan 1664169695Skan dictAppendCell(dp, LVALUEtoCELL(pDoParen)); 1665169695Skan /* 1666169695Skan ** Allot space for a pointer to the end 1667169695Skan ** of the loop - "leave" uses this... 1668169695Skan */ 1669169695Skan markBranch(dp, pVM, leaveTag); 1670169695Skan dictAppendUNS(dp, 0); 1671169695Skan /* 1672169695Skan ** Mark location of head of loop... 1673 */ 1674 markBranch(dp, pVM, doTag); 1675 1676 return; 1677} 1678 1679 1680static void doParen(FICL_VM *pVM) 1681{ 1682 CELL index, limit; 1683#if FICL_ROBUST > 1 1684 vmCheckStack(pVM, 2, 0); 1685#endif 1686 index = stackPop(pVM->pStack); 1687 limit = stackPop(pVM->pStack); 1688 1689 /* copy "leave" target addr to stack */ 1690 stackPushPtr(pVM->rStack, *(pVM->ip++)); 1691 stackPush(pVM->rStack, limit); 1692 stackPush(pVM->rStack, index); 1693 1694 return; 1695} 1696 1697 1698static void qDoCoIm(FICL_VM *pVM) 1699{ 1700 FICL_DICT *dp = ficlGetDict(); 1701 1702 assert(pQDoParen); 1703 1704 dictAppendCell(dp, LVALUEtoCELL(pQDoParen)); 1705 /* 1706 ** Allot space for a pointer to the end 1707 ** of the loop - "leave" uses this... 1708 */ 1709 markBranch(dp, pVM, leaveTag); 1710 dictAppendUNS(dp, 0); 1711 /* 1712 ** Mark location of head of loop... 1713 */ 1714 markBranch(dp, pVM, doTag); 1715 1716 return; 1717} 1718 1719 1720static void qDoParen(FICL_VM *pVM) 1721{ 1722 CELL index, limit; 1723#if FICL_ROBUST > 1 1724 vmCheckStack(pVM, 2, 0); 1725#endif 1726 index = stackPop(pVM->pStack); 1727 limit = stackPop(pVM->pStack); 1728 1729 /* copy "leave" target addr to stack */ 1730 stackPushPtr(pVM->rStack, *(pVM->ip++)); 1731 1732 if (limit.u == index.u) 1733 { 1734 vmPopIP(pVM); 1735 } 1736 else 1737 { 1738 stackPush(pVM->rStack, limit); 1739 stackPush(pVM->rStack, index); 1740 } 1741 1742 return; 1743} 1744 1745 1746/* 1747** Runtime code to break out of a do..loop construct 1748** Drop the loop control variables; the branch address 1749** past "loop" is next on the return stack. 1750*/ 1751static void leaveCo(FICL_VM *pVM) 1752{ 1753 /* almost unloop */ 1754 stackDrop(pVM->rStack, 2); 1755 /* exit */ 1756 vmPopIP(pVM); 1757 return; 1758} 1759 1760 1761static void unloopCo(FICL_VM *pVM) 1762{ 1763 stackDrop(pVM->rStack, 3); 1764 return; 1765} 1766 1767 1768static void loopCoIm(FICL_VM *pVM) 1769{ 1770 FICL_DICT *dp = ficlGetDict(); 1771 1772 assert(pLoopParen); 1773 1774 dictAppendCell(dp, LVALUEtoCELL(pLoopParen)); 1775 resolveBackBranch(dp, pVM, doTag); 1776 resolveAbsBranch(dp, pVM, leaveTag); 1777 return; 1778} 1779 1780 1781static void plusLoopCoIm(FICL_VM *pVM) 1782{ 1783 FICL_DICT *dp = ficlGetDict(); 1784 1785 assert(pPLoopParen); 1786 1787 dictAppendCell(dp, LVALUEtoCELL(pPLoopParen)); 1788 resolveBackBranch(dp, pVM, doTag); 1789 resolveAbsBranch(dp, pVM, leaveTag); 1790 return; 1791} 1792 1793 1794static void loopParen(FICL_VM *pVM) 1795{ 1796 FICL_INT index = stackGetTop(pVM->rStack).i; 1797 FICL_INT limit = stackFetch(pVM->rStack, 1).i; 1798 1799 index++; 1800 1801 if (index >= limit) 1802 { 1803 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 1804 vmBranchRelative(pVM, 1); /* fall through the loop */ 1805 } 1806 else 1807 { /* update index, branch to loop head */ 1808 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 1809 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1810 } 1811 1812 return; 1813} 1814 1815 1816static void plusLoopParen(FICL_VM *pVM) 1817{ 1818 FICL_INT index = stackGetTop(pVM->rStack).i; 1819 FICL_INT limit = stackFetch(pVM->rStack, 1).i; 1820 FICL_INT increment = stackPop(pVM->pStack).i; 1821 int flag; 1822 1823 index += increment; 1824 1825 if (increment < 0) 1826 flag = (index < limit); 1827 else 1828 flag = (index >= limit); 1829 1830 if (flag) 1831 { 1832 stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */ 1833 vmBranchRelative(pVM, 1); /* fall through the loop */ 1834 } 1835 else 1836 { /* update index, branch to loop head */ 1837 stackSetTop(pVM->rStack, LVALUEtoCELL(index)); 1838 vmBranchRelative(pVM, *(int *)(pVM->ip)); 1839 } 1840 1841 return; 1842} 1843 1844 1845static void loopICo(FICL_VM *pVM) 1846{ 1847 CELL index = stackGetTop(pVM->rStack); 1848 stackPush(pVM->pStack, index); 1849 1850 return; 1851} 1852 1853 1854static void loopJCo(FICL_VM *pVM) 1855{ 1856 CELL index = stackFetch(pVM->rStack, 3); 1857 stackPush(pVM->pStack, index); 1858 1859 return; 1860} 1861 1862 1863static void loopKCo(FICL_VM *pVM) 1864{ 1865 CELL index = stackFetch(pVM->rStack, 6); 1866 stackPush(pVM->pStack, index); 1867 1868 return; 1869} 1870 1871 1872/************************************************************************** 1873 r e t u r n s t a c k 1874** 1875**************************************************************************/ 1876 1877static void toRStack(FICL_VM *pVM) 1878{ 1879 stackPush(pVM->rStack, stackPop(pVM->pStack)); 1880 return; 1881} 1882 1883static void fromRStack(FICL_VM *pVM) 1884{ 1885 stackPush(pVM->pStack, stackPop(pVM->rStack)); 1886 return; 1887} 1888 1889static void fetchRStack(FICL_VM *pVM) 1890{ 1891 stackPush(pVM->pStack, stackGetTop(pVM->rStack)); 1892 return; 1893} 1894 1895 1896/************************************************************************** 1897 v a r i a b l e 1898** 1899**************************************************************************/ 1900 1901static void variableParen(FICL_VM *pVM) 1902{ 1903 FICL_WORD *fw = pVM->runningWord; 1904 stackPushPtr(pVM->pStack, fw->param); 1905 return; 1906} 1907 1908 1909static void variable(FICL_VM *pVM) 1910{ 1911 FICL_DICT *dp = ficlGetDict(); 1912 STRINGINFO si = vmGetWord(pVM); 1913 1914 dictAppendWord2(dp, si, variableParen, FW_DEFAULT); 1915 dictAllotCells(dp, 1); 1916 return; 1917} 1918 1919 1920 1921/************************************************************************** 1922 b a s e & f r i e n d s 1923** 1924**************************************************************************/ 1925 1926static void base(FICL_VM *pVM) 1927{ 1928 CELL *pBase = (CELL *)(&pVM->base); 1929 stackPush(pVM->pStack, LVALUEtoCELL(pBase)); 1930 return; 1931} 1932 1933 1934static void decimal(FICL_VM *pVM) 1935{ 1936 pVM->base = 10; 1937 return; 1938} 1939 1940 1941static void hex(FICL_VM *pVM) 1942{ 1943 pVM->base = 16; 1944 return; 1945} 1946 1947 1948/************************************************************************** 1949 a l l o t & f r i e n d s 1950** 1951**************************************************************************/ 1952 1953static void allot(FICL_VM *pVM) 1954{ 1955 FICL_DICT *dp = ficlGetDict(); 1956 FICL_INT i = stackPopINT(pVM->pStack); 1957#if FICL_ROBUST 1958 dictCheck(dp, pVM, i); 1959#endif 1960 dictAllot(dp, i); 1961 return; 1962} 1963 1964 1965static void here(FICL_VM *pVM) 1966{ 1967 FICL_DICT *dp = ficlGetDict(); 1968 stackPushPtr(pVM->pStack, dp->here); 1969 return; 1970} 1971 1972 1973static void comma(FICL_VM *pVM) 1974{ 1975 FICL_DICT *dp = ficlGetDict(); 1976 CELL c = stackPop(pVM->pStack); 1977 dictAppendCell(dp, c); 1978 return; 1979} 1980 1981 1982static void cComma(FICL_VM *pVM) 1983{ 1984 FICL_DICT *dp = ficlGetDict(); 1985 char c = (char)stackPopINT(pVM->pStack); 1986 dictAppendChar(dp, c); 1987 return; 1988} 1989 1990 1991static void cells(FICL_VM *pVM) 1992{ 1993 FICL_INT i = stackPopINT(pVM->pStack); 1994 stackPushINT(pVM->pStack, i * (FICL_INT)sizeof (CELL)); 1995 return; 1996} 1997 1998 1999static void cellPlus(FICL_VM *pVM) 2000{ 2001 char *cp = stackPopPtr(pVM->pStack); 2002 stackPushPtr(pVM->pStack, cp + sizeof (CELL)); 2003 return; 2004} 2005 2006 2007/************************************************************************** 2008 t i c k 2009** tick CORE ( "<spaces>name" -- xt ) 2010** Skip leading space delimiters. Parse name delimited by a space. Find 2011** name and return xt, the execution token for name. An ambiguous condition 2012** exists if name is not found. 2013**************************************************************************/ 2014static void tick(FICL_VM *pVM) 2015{ 2016 FICL_WORD *pFW = NULL; 2017 STRINGINFO si = vmGetWord(pVM); 2018 2019 pFW = dictLookup(ficlGetDict(), si); 2020 if (!pFW) 2021 { 2022 int i = SI_COUNT(si); 2023 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 2024 } 2025 stackPushPtr(pVM->pStack, pFW); 2026 return; 2027} 2028 2029 2030static void bracketTickCoIm(FICL_VM *pVM) 2031{ 2032 tick(pVM); 2033 literalIm(pVM); 2034 2035 return; 2036} 2037 2038 2039/************************************************************************** 2040 p o s t p o n e 2041** Lookup the next word in the input stream and compile code to 2042** insert it into definitions created by the resulting word 2043** (defers compilation, even of immediate words) 2044**************************************************************************/ 2045 2046static void postponeCoIm(FICL_VM *pVM) 2047{ 2048 FICL_DICT *dp = ficlGetDict(); 2049 FICL_WORD *pFW; 2050 assert(pComma); 2051 2052 tick(pVM); 2053 pFW = stackGetTop(pVM->pStack).p; 2054 if (wordIsImmediate(pFW)) 2055 { 2056 dictAppendCell(dp, stackPop(pVM->pStack)); 2057 } 2058 else 2059 { 2060 literalIm(pVM); 2061 dictAppendCell(dp, LVALUEtoCELL(pComma)); 2062 } 2063 2064 return; 2065} 2066 2067 2068 2069/************************************************************************** 2070 e x e c u t e 2071** Pop an execution token (pointer to a word) off the stack and 2072** run it 2073**************************************************************************/ 2074 2075static void execute(FICL_VM *pVM) 2076{ 2077 FICL_WORD *pFW; 2078#if FICL_ROBUST > 1 2079 vmCheckStack(pVM, 1, 0); 2080#endif 2081 2082 pFW = stackPopPtr(pVM->pStack); 2083 vmExecute(pVM, pFW); 2084 2085 return; 2086} 2087 2088 2089/************************************************************************** 2090 i m m e d i a t e 2091** Make the most recently compiled word IMMEDIATE -- it executes even 2092** in compile state (most often used for control compiling words 2093** such as IF, THEN, etc) 2094**************************************************************************/ 2095 2096static void immediate(FICL_VM *pVM) 2097{ 2098 IGNORE(pVM); 2099 dictSetImmediate(ficlGetDict()); 2100 return; 2101} 2102 2103 2104static void compileOnly(FICL_VM *pVM) 2105{ 2106 IGNORE(pVM); 2107 dictSetFlags(ficlGetDict(), FW_COMPILE, 0); 2108 return; 2109} 2110 2111 2112/************************************************************************** 2113 d o t Q u o t e 2114** IMMEDIATE word that compiles a string literal for later display 2115** Compile stringLit, then copy the bytes of the string from the TIB 2116** to the dictionary. Backpatch the count byte and align the dictionary. 2117** 2118** stringlit: Fetch the count from the dictionary, then push the address 2119** and count on the stack. Finally, update ip to point to the first 2120** aligned address after the string text. 2121**************************************************************************/ 2122 2123static void stringLit(FICL_VM *pVM) 2124{ 2125 FICL_STRING *sp = (FICL_STRING *)(pVM->ip); 2126 FICL_COUNT count = sp->count; 2127 char *cp = sp->text; 2128 stackPushPtr(pVM->pStack, cp); 2129 stackPushUNS(pVM->pStack, count); 2130 cp += count + 1; 2131 cp = alignPtr(cp); 2132 pVM->ip = (IPTYPE)(void *)cp; 2133 return; 2134} 2135 2136static void dotQuoteCoIm(FICL_VM *pVM) 2137{ 2138 FICL_DICT *dp = ficlGetDict(); 2139 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2140 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2141 dictAlign(dp); 2142 dictAppendCell(dp, LVALUEtoCELL(pType)); 2143 return; 2144} 2145 2146 2147static void dotParen(FICL_VM *pVM) 2148{ 2149 char *pSrc = vmGetInBuf(pVM); 2150 char *pEnd = vmGetInBufEnd(pVM); 2151 char *pDest = pVM->pad; 2152 char ch; 2153 2154 for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc) 2155 *pDest++ = ch; 2156 2157 *pDest = '\0'; 2158 if ((pEnd != pSrc) && (ch == ')')) 2159 pSrc++; 2160 2161 vmTextOut(pVM, pVM->pad, 0); 2162 vmUpdateTib(pVM, pSrc); 2163 2164 return; 2165} 2166 2167 2168/************************************************************************** 2169 s l i t e r a l 2170** STRING 2171** Interpretation: Interpretation semantics for this word are undefined. 2172** Compilation: ( c-addr1 u -- ) 2173** Append the run-time semantics given below to the current definition. 2174** Run-time: ( -- c-addr2 u ) 2175** Return c-addr2 u describing a string consisting of the characters 2176** specified by c-addr1 u during compilation. A program shall not alter 2177** the returned string. 2178**************************************************************************/ 2179static void sLiteralCoIm(FICL_VM *pVM) 2180{ 2181 FICL_DICT *dp = ficlGetDict(); 2182 char *cp, *cpDest; 2183 FICL_UNS u; 2184 u = stackPopUNS(pVM->pStack); 2185 cp = stackPopPtr(pVM->pStack); 2186 2187 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2188 cpDest = (char *) dp->here; 2189 *cpDest++ = (char) u; 2190 2191 for (; u > 0; --u) 2192 { 2193 *cpDest++ = *cp++; 2194 } 2195 2196 *cpDest++ = 0; 2197 dp->here = PTRtoCELL alignPtr(cpDest); 2198 return; 2199} 2200 2201 2202/************************************************************************** 2203 s t a t e 2204** Return the address of the VM's state member (must be sized the 2205** same as a CELL for this reason) 2206**************************************************************************/ 2207static void state(FICL_VM *pVM) 2208{ 2209 stackPushPtr(pVM->pStack, &pVM->state); 2210 return; 2211} 2212 2213 2214/************************************************************************** 2215 c r e a t e . . . d o e s > 2216** Make a new word in the dictionary with the run-time effect of 2217** a variable (push my address), but with extra space allotted 2218** for use by does> . 2219**************************************************************************/ 2220 2221static void createParen(FICL_VM *pVM) 2222{ 2223 CELL *pCell = pVM->runningWord->param; 2224 stackPushPtr(pVM->pStack, pCell+1); 2225 return; 2226} 2227 2228 2229static void create(FICL_VM *pVM) 2230{ 2231 FICL_DICT *dp = ficlGetDict(); 2232 STRINGINFO si = vmGetWord(pVM); 2233 2234 dictAppendWord2(dp, si, createParen, FW_DEFAULT); 2235 dictAllotCells(dp, 1); 2236 return; 2237} 2238 2239 2240static void doDoes(FICL_VM *pVM) 2241{ 2242 CELL *pCell = pVM->runningWord->param; 2243 IPTYPE tempIP = (IPTYPE)((*pCell).p); 2244 stackPushPtr(pVM->pStack, pCell+1); 2245 vmPushIP(pVM, tempIP); 2246 return; 2247} 2248 2249 2250static void doesParen(FICL_VM *pVM) 2251{ 2252 FICL_DICT *dp = ficlGetDict(); 2253 dp->smudge->code = doDoes; 2254 dp->smudge->param[0] = LVALUEtoCELL(pVM->ip); 2255 vmPopIP(pVM); 2256 return; 2257} 2258 2259 2260static void doesCoIm(FICL_VM *pVM) 2261{ 2262 FICL_DICT *dp = ficlGetDict(); 2263#if FICL_WANT_LOCALS 2264 assert(pUnLinkParen); 2265 if (nLocals > 0) 2266 { 2267 FICL_DICT *pLoc = ficlGetLoc(); 2268 dictEmpty(pLoc, pLoc->pForthWords->size); 2269 dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen)); 2270 } 2271 2272 nLocals = 0; 2273#endif 2274 IGNORE(pVM); 2275 2276 dictAppendCell(dp, LVALUEtoCELL(pDoesParen)); 2277 return; 2278} 2279 2280 2281/************************************************************************** 2282 t o b o d y 2283** to-body CORE ( xt -- a-addr ) 2284** a-addr is the data-field address corresponding to xt. An ambiguous 2285** condition exists if xt is not for a word defined via CREATE. 2286**************************************************************************/ 2287static void toBody(FICL_VM *pVM) 2288{ 2289 FICL_WORD *pFW = stackPopPtr(pVM->pStack); 2290 stackPushPtr(pVM->pStack, pFW->param + 1); 2291 return; 2292} 2293 2294 2295/* 2296** from-body ficl ( a-addr -- xt ) 2297** Reverse effect of >body 2298*/ 2299static void fromBody(FICL_VM *pVM) 2300{ 2301 char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD); 2302 stackPushPtr(pVM->pStack, ptr); 2303 return; 2304} 2305 2306 2307/* 2308** >name ficl ( xt -- c-addr u ) 2309** Push the address and length of a word's name given its address 2310** xt. 2311*/ 2312static void toName(FICL_VM *pVM) 2313{ 2314 FICL_WORD *pFW = stackPopPtr(pVM->pStack); 2315 stackPushPtr(pVM->pStack, pFW->name); 2316 stackPushUNS(pVM->pStack, pFW->nName); 2317 return; 2318} 2319 2320 2321/************************************************************************** 2322 l b r a c k e t e t c 2323** 2324**************************************************************************/ 2325 2326static void lbracketCoIm(FICL_VM *pVM) 2327{ 2328 pVM->state = INTERPRET; 2329 return; 2330} 2331 2332 2333static void rbracket(FICL_VM *pVM) 2334{ 2335 pVM->state = COMPILE; 2336 return; 2337} 2338 2339 2340/************************************************************************** 2341 p i c t u r e d n u m e r i c w o r d s 2342** 2343** less-number-sign CORE ( -- ) 2344** Initialize the pictured numeric output conversion process. 2345** (clear the pad) 2346**************************************************************************/ 2347static void lessNumberSign(FICL_VM *pVM) 2348{ 2349 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2350 sp->count = 0; 2351 return; 2352} 2353 2354/* 2355** number-sign CORE ( ud1 -- ud2 ) 2356** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder 2357** n. (n is the least-significant digit of ud1.) Convert n to external form 2358** and add the resulting character to the beginning of the pictured numeric 2359** output string. An ambiguous condition exists if # executes outside of a 2360** <# #> delimited number conversion. 2361*/ 2362static void numberSign(FICL_VM *pVM) 2363{ 2364 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2365 DPUNS u; 2366 UNS16 rem; 2367 2368 u = u64Pop(pVM->pStack); 2369 rem = m64UMod(&u, (UNS16)(pVM->base)); 2370 sp->text[sp->count++] = digit_to_char(rem); 2371 u64Push(pVM->pStack, u); 2372 return; 2373} 2374 2375/* 2376** number-sign-greater CORE ( xd -- c-addr u ) 2377** Drop xd. Make the pictured numeric output string available as a character 2378** string. c-addr and u specify the resulting character string. A program 2379** may replace characters within the string. 2380*/ 2381static void numberSignGreater(FICL_VM *pVM) 2382{ 2383 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2384 sp->text[sp->count] = '\0'; 2385 strrev(sp->text); 2386 stackDrop(pVM->pStack, 2); 2387 stackPushPtr(pVM->pStack, sp->text); 2388 stackPushUNS(pVM->pStack, sp->count); 2389 return; 2390} 2391 2392/* 2393** number-sign-s CORE ( ud1 -- ud2 ) 2394** Convert one digit of ud1 according to the rule for #. Continue conversion 2395** until the quotient is zero. ud2 is zero. An ambiguous condition exists if 2396** #S executes outside of a <# #> delimited number conversion. 2397** TO DO: presently does not use ud1 hi cell - use it! 2398*/ 2399static void numberSignS(FICL_VM *pVM) 2400{ 2401 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2402 DPUNS u; 2403 UNS16 rem; 2404 2405 u = u64Pop(pVM->pStack); 2406 2407 do 2408 { 2409 rem = m64UMod(&u, (UNS16)(pVM->base)); 2410 sp->text[sp->count++] = digit_to_char(rem); 2411 } 2412 while (u.hi || u.lo); 2413 2414 u64Push(pVM->pStack, u); 2415 return; 2416} 2417 2418/* 2419** HOLD CORE ( char -- ) 2420** Add char to the beginning of the pictured numeric output string. An ambiguous 2421** condition exists if HOLD executes outside of a <# #> delimited number conversion. 2422*/ 2423static void hold(FICL_VM *pVM) 2424{ 2425 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2426 int i = stackPopINT(pVM->pStack); 2427 sp->text[sp->count++] = (char) i; 2428 return; 2429} 2430 2431/* 2432** SIGN CORE ( n -- ) 2433** If n is negative, add a minus sign to the beginning of the pictured 2434** numeric output string. An ambiguous condition exists if SIGN 2435** executes outside of a <# #> delimited number conversion. 2436*/ 2437static void sign(FICL_VM *pVM) 2438{ 2439 FICL_STRING *sp = PTRtoSTRING pVM->pad; 2440 int i = stackPopINT(pVM->pStack); 2441 if (i < 0) 2442 sp->text[sp->count++] = '-'; 2443 return; 2444} 2445 2446 2447/************************************************************************** 2448 t o N u m b e r 2449** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) 2450** ud2 is the unsigned result of converting the characters within the 2451** string specified by c-addr1 u1 into digits, using the number in BASE, 2452** and adding each into ud1 after multiplying ud1 by the number in BASE. 2453** Conversion continues left-to-right until a character that is not 2454** convertible, including any + or -, is encountered or the string is 2455** entirely converted. c-addr2 is the location of the first unconverted 2456** character or the first character past the end of the string if the string 2457** was entirely converted. u2 is the number of unconverted characters in the 2458** string. An ambiguous condition exists if ud2 overflows during the 2459** conversion. 2460**************************************************************************/ 2461static void toNumber(FICL_VM *pVM) 2462{ 2463 FICL_UNS count = stackPopUNS(pVM->pStack); 2464 char *cp = (char *)stackPopPtr(pVM->pStack); 2465 DPUNS accum; 2466 FICL_UNS base = pVM->base; 2467 FICL_UNS ch; 2468 FICL_UNS digit; 2469 2470 accum = u64Pop(pVM->pStack); 2471 2472 for (ch = *cp; count > 0; ch = *++cp, count--) 2473 { 2474 if (ch < '0') 2475 break; 2476 2477 digit = ch - '0'; 2478 2479 if (digit > 9) 2480 digit = tolower(ch) - 'a' + 10; 2481 /* 2482 ** Note: following test also catches chars between 9 and a 2483 ** because 'digit' is unsigned! 2484 */ 2485 if (digit >= base) 2486 break; 2487 2488 accum = m64Mac(accum, base, digit); 2489 } 2490 2491 u64Push(pVM->pStack, accum); 2492 stackPushPtr (pVM->pStack, cp); 2493 stackPushUNS(pVM->pStack, count); 2494 2495 return; 2496} 2497 2498 2499 2500/************************************************************************** 2501 q u i t & a b o r t 2502** quit CORE ( -- ) ( R: i*x -- ) 2503** Empty the return stack, store zero in SOURCE-ID if it is present, make 2504** the user input device the input source, and enter interpretation state. 2505** Do not display a message. Repeat the following: 2506** 2507** Accept a line from the input source into the input buffer, set >IN to 2508** zero, and interpret. 2509** Display the implementation-defined system prompt if in 2510** interpretation state, all processing has been completed, and no 2511** ambiguous condition exists. 2512**************************************************************************/ 2513 2514static void quit(FICL_VM *pVM) 2515{ 2516 vmThrow(pVM, VM_QUIT); 2517 return; 2518} 2519 2520 2521static void ficlAbort(FICL_VM *pVM) 2522{ 2523 vmThrow(pVM, VM_ABORT); 2524 return; 2525} 2526 2527 2528/************************************************************************** 2529 a c c e p t 2530** accept CORE ( c-addr +n1 -- +n2 ) 2531** Receive a string of at most +n1 characters. An ambiguous condition 2532** exists if +n1 is zero or greater than 32,767. Display graphic characters 2533** as they are received. A program that depends on the presence or absence 2534** of non-graphic characters in the string has an environmental dependency. 2535** The editing functions, if any, that the system performs in order to 2536** construct the string are implementation-defined. 2537** 2538** (Although the standard text doesn't say so, I assume that the intent 2539** of 'accept' is to store the string at the address specified on 2540** the stack.) 2541** Implementation: if there's more text in the TIB, use it. Otherwise 2542** throw out for more text. Copy characters up to the max count into the 2543** address given, and return the number of actual characters copied. 2544** 2545** Note (sobral) this may not be the behavior you'd expect if you're 2546** trying to get user input at load time! 2547**************************************************************************/ 2548static void accept(FICL_VM *pVM) 2549{ 2550 FICL_INT count; 2551 char *cp; 2552 char *pBuf = vmGetInBuf(pVM); 2553 char *pEnd = vmGetInBufEnd(pVM); 2554 FICL_INT len = pEnd - pBuf; 2555 2556 if (len == 0) 2557 vmThrow(pVM, VM_RESTART); 2558 2559 /* 2560 ** Now we have something in the text buffer - use it 2561 */ 2562 count = stackPopINT(pVM->pStack); 2563 cp = stackPopPtr(pVM->pStack); 2564 2565 len = (count < len) ? count : len; 2566 strncpy(cp, vmGetInBuf(pVM), len); 2567 pBuf += len; 2568 vmUpdateTib(pVM, pBuf); 2569 stackPushINT(pVM->pStack, len); 2570 2571 return; 2572} 2573 2574 2575/************************************************************************** 2576 a l i g n 2577** 6.1.0705 ALIGN CORE ( -- ) 2578** If the data-space pointer is not aligned, reserve enough space to 2579** align it. 2580**************************************************************************/ 2581static void align(FICL_VM *pVM) 2582{ 2583 FICL_DICT *dp = ficlGetDict(); 2584 IGNORE(pVM); 2585 dictAlign(dp); 2586 return; 2587} 2588 2589 2590/************************************************************************** 2591 a l i g n e d 2592** 2593**************************************************************************/ 2594static void aligned(FICL_VM *pVM) 2595{ 2596 void *addr = stackPopPtr(pVM->pStack); 2597 stackPushPtr(pVM->pStack, alignPtr(addr)); 2598 return; 2599} 2600 2601 2602/************************************************************************** 2603 b e g i n & f r i e n d s 2604** Indefinite loop control structures 2605** A.6.1.0760 BEGIN 2606** Typical use: 2607** : X ... BEGIN ... test UNTIL ; 2608** or 2609** : X ... BEGIN ... test WHILE ... REPEAT ; 2610**************************************************************************/ 2611static void beginCoIm(FICL_VM *pVM) 2612{ 2613 FICL_DICT *dp = ficlGetDict(); 2614 markBranch(dp, pVM, destTag); 2615 return; 2616} 2617 2618static void untilCoIm(FICL_VM *pVM) 2619{ 2620 FICL_DICT *dp = ficlGetDict(); 2621 2622 assert(pIfParen); 2623 2624 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 2625 resolveBackBranch(dp, pVM, destTag); 2626 return; 2627} 2628 2629static void whileCoIm(FICL_VM *pVM) 2630{ 2631 FICL_DICT *dp = ficlGetDict(); 2632 2633 assert(pIfParen); 2634 2635 dictAppendCell(dp, LVALUEtoCELL(pIfParen)); 2636 markBranch(dp, pVM, origTag); 2637 twoSwap(pVM); 2638 dictAppendUNS(dp, 1); 2639 return; 2640} 2641 2642static void repeatCoIm(FICL_VM *pVM) 2643{ 2644 FICL_DICT *dp = ficlGetDict(); 2645 2646 assert(pBranchParen); 2647 dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); 2648 2649 /* expect "begin" branch marker */ 2650 resolveBackBranch(dp, pVM, destTag); 2651 /* expect "while" branch marker */ 2652 resolveForwardBranch(dp, pVM, origTag); 2653 return; 2654} 2655 2656 2657static void againCoIm(FICL_VM *pVM) 2658{ 2659 FICL_DICT *dp = ficlGetDict(); 2660 2661 assert(pBranchParen); 2662 dictAppendCell(dp, LVALUEtoCELL(pBranchParen)); 2663 2664 /* expect "begin" branch marker */ 2665 resolveBackBranch(dp, pVM, destTag); 2666 return; 2667} 2668 2669 2670/************************************************************************** 2671 c h a r & f r i e n d s 2672** 6.1.0895 CHAR CORE ( "<spaces>name" -- char ) 2673** Skip leading space delimiters. Parse name delimited by a space. 2674** Put the value of its first character onto the stack. 2675** 2676** bracket-char CORE 2677** Interpretation: Interpretation semantics for this word are undefined. 2678** Compilation: ( "<spaces>name" -- ) 2679** Skip leading space delimiters. Parse name delimited by a space. 2680** Append the run-time semantics given below to the current definition. 2681** Run-time: ( -- char ) 2682** Place char, the value of the first character of name, on the stack. 2683**************************************************************************/ 2684static void ficlChar(FICL_VM *pVM) 2685{ 2686 STRINGINFO si = vmGetWord(pVM); 2687 stackPushUNS(pVM->pStack, (FICL_UNS)(si.cp[0])); 2688 2689 return; 2690} 2691 2692static void charCoIm(FICL_VM *pVM) 2693{ 2694 ficlChar(pVM); 2695 literalIm(pVM); 2696 return; 2697} 2698 2699/************************************************************************** 2700 c h a r P l u s 2701** char-plus CORE ( c-addr1 -- c-addr2 ) 2702** Add the size in address units of a character to c-addr1, giving c-addr2. 2703**************************************************************************/ 2704static void charPlus(FICL_VM *pVM) 2705{ 2706 char *cp = stackPopPtr(pVM->pStack); 2707 stackPushPtr(pVM->pStack, cp + 1); 2708 return; 2709} 2710 2711/************************************************************************** 2712 c h a r s 2713** chars CORE ( n1 -- n2 ) 2714** n2 is the size in address units of n1 characters. 2715** For most processors, this function can be a no-op. To guarantee 2716** portability, we'll multiply by sizeof (char). 2717**************************************************************************/ 2718#if defined (_M_IX86) 2719#pragma warning(disable: 4127) 2720#endif 2721static void ficlChars(FICL_VM *pVM) 2722{ 2723 if (sizeof (char) > 1) 2724 { 2725 FICL_INT i = stackPopINT(pVM->pStack); 2726 stackPushINT(pVM->pStack, i * sizeof (char)); 2727 } 2728 /* otherwise no-op! */ 2729 return; 2730} 2731#if defined (_M_IX86) 2732#pragma warning(default: 4127) 2733#endif 2734 2735 2736/************************************************************************** 2737 c o u n t 2738** COUNT CORE ( c-addr1 -- c-addr2 u ) 2739** Return the character string specification for the counted string stored 2740** at c-addr1. c-addr2 is the address of the first character after c-addr1. 2741** u is the contents of the character at c-addr1, which is the length in 2742** characters of the string at c-addr2. 2743**************************************************************************/ 2744static void count(FICL_VM *pVM) 2745{ 2746 FICL_STRING *sp = stackPopPtr(pVM->pStack); 2747 stackPushPtr(pVM->pStack, sp->text); 2748 stackPushUNS(pVM->pStack, sp->count); 2749 return; 2750} 2751 2752/************************************************************************** 2753 e n v i r o n m e n t ? 2754** environment-query CORE ( c-addr u -- false | i*x true ) 2755** c-addr is the address of a character string and u is the string's 2756** character count. u may have a value in the range from zero to an 2757** implementation-defined maximum which shall not be less than 31. The 2758** character string should contain a keyword from 3.2.6 Environmental 2759** queries or the optional word sets to be checked for correspondence 2760** with an attribute of the present environment. If the system treats the 2761** attribute as unknown, the returned flag is false; otherwise, the flag 2762** is true and the i*x returned is of the type specified in the table for 2763** the attribute queried. 2764**************************************************************************/ 2765static void environmentQ(FICL_VM *pVM) 2766{ 2767 FICL_DICT *envp = ficlGetEnv(); 2768 FICL_COUNT len = (FICL_COUNT)stackPopUNS(pVM->pStack); 2769 char *cp = stackPopPtr(pVM->pStack); 2770 FICL_WORD *pFW; 2771 STRINGINFO si; 2772 2773 2774 &len; /* silence compiler warning... */ 2775 SI_PSZ(si, cp); 2776 pFW = dictLookup(envp, si); 2777 2778 if (pFW != NULL) 2779 { 2780 vmExecute(pVM, pFW); 2781 stackPushINT(pVM->pStack, FICL_TRUE); 2782 } 2783 else 2784 { 2785 stackPushINT(pVM->pStack, FICL_FALSE); 2786 } 2787 2788 return; 2789} 2790 2791/************************************************************************** 2792 e v a l u a t e 2793** EVALUATE CORE ( i*x c-addr u -- j*x ) 2794** Save the current input source specification. Store minus-one (-1) in 2795** SOURCE-ID if it is present. Make the string described by c-addr and u 2796** both the input source and input buffer, set >IN to zero, and interpret. 2797** When the parse area is empty, restore the prior input source 2798** specification. Other stack effects are due to the words EVALUATEd. 2799** 2800**************************************************************************/ 2801static void evaluate(FICL_VM *pVM) 2802{ 2803 FICL_INT count = stackPopINT(pVM->pStack); 2804 char *cp = stackPopPtr(pVM->pStack); 2805 CELL id; 2806 int result; 2807 2808 id = pVM->sourceID; 2809 pVM->sourceID.i = -1; 2810 result = ficlExecC(pVM, cp, count); 2811 pVM->sourceID = id; 2812 if (result != VM_OUTOFTEXT) 2813 vmThrow(pVM, result); 2814 2815 return; 2816} 2817 2818 2819/************************************************************************** 2820 s t r i n g q u o t e 2821** Intrpreting: get string delimited by a quote from the input stream, 2822** copy to a scratch area, and put its count and address on the stack. 2823** Compiling: compile code to push the address and count of a string 2824** literal, compile the string from the input stream, and align the dict 2825** pointer. 2826**************************************************************************/ 2827static void stringQuoteIm(FICL_VM *pVM) 2828{ 2829 FICL_DICT *dp = ficlGetDict(); 2830 2831 if (pVM->state == INTERPRET) 2832 { 2833 FICL_STRING *sp = (FICL_STRING *) dp->here; 2834 vmGetString(pVM, sp, '\"'); 2835 stackPushPtr(pVM->pStack, sp->text); 2836 stackPushUNS(pVM->pStack, sp->count); 2837 } 2838 else /* COMPILE state */ 2839 { 2840 dictAppendCell(dp, LVALUEtoCELL(pStringLit)); 2841 dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"'); 2842 dictAlign(dp); 2843 } 2844 2845 return; 2846} 2847 2848 2849/************************************************************************** 2850 t y p e 2851** Pop count and char address from stack and print the designated string. 2852**************************************************************************/ 2853static void type(FICL_VM *pVM) 2854{ 2855 FICL_UNS count = stackPopUNS(pVM->pStack); 2856 char *cp = stackPopPtr(pVM->pStack); 2857 char *pDest = (char *)ficlMalloc(count + 1); 2858 2859 /* 2860 ** Since we don't have an output primitive for a counted string 2861 ** (oops), make sure the string is null terminated. If not, copy 2862 ** and terminate it. 2863 */ 2864 if (!pDest) 2865 vmThrowErr(pVM, "Error: out of memory"); 2866 2867 strncpy(pDest, cp, count); 2868 pDest[count] = '\0'; 2869 2870 vmTextOut(pVM, pDest, 0); 2871 2872 ficlFree(pDest); 2873 return; 2874} 2875 2876/************************************************************************** 2877 w o r d 2878** word CORE ( char "<chars>ccc<char>" -- c-addr ) 2879** Skip leading delimiters. Parse characters ccc delimited by char. An 2880** ambiguous condition exists if the length of the parsed string is greater 2881** than the implementation-defined length of a counted string. 2882** 2883** c-addr is the address of a transient region containing the parsed word 2884** as a counted string. If the parse area was empty or contained no 2885** characters other than the delimiter, the resulting string has a zero 2886** length. A space, not included in the length, follows the string. A 2887** program may replace characters within the string. 2888** NOTE! Ficl also NULL-terminates the dest string. 2889**************************************************************************/ 2890static void ficlWord(FICL_VM *pVM) 2891{ 2892 FICL_STRING *sp = (FICL_STRING *)pVM->pad; 2893 char delim = (char)stackPopINT(pVM->pStack); 2894 STRINGINFO si; 2895 2896 si = vmParseStringEx(pVM, delim, 1); 2897 2898 if (SI_COUNT(si) > nPAD-1) 2899 SI_SETLEN(si, nPAD-1); 2900 2901 sp->count = (FICL_COUNT)SI_COUNT(si); 2902 strncpy(sp->text, SI_PTR(si), SI_COUNT(si)); 2903 strcat(sp->text, " "); 2904 2905 stackPushPtr(pVM->pStack, sp); 2906 return; 2907} 2908 2909 2910/************************************************************************** 2911 p a r s e - w o r d 2912** ficl PARSE-WORD ( <spaces>name -- c-addr u ) 2913** Skip leading spaces and parse name delimited by a space. c-addr is the 2914** address within the input buffer and u is the length of the selected 2915** string. If the parse area is empty, the resulting string has a zero length. 2916**************************************************************************/ 2917static void parseNoCopy(FICL_VM *pVM) 2918{ 2919 STRINGINFO si = vmGetWord0(pVM); 2920 stackPushPtr(pVM->pStack, SI_PTR(si)); 2921 stackPushUNS(pVM->pStack, SI_COUNT(si)); 2922 return; 2923} 2924 2925 2926/************************************************************************** 2927 p a r s e 2928** CORE EXT ( char "ccc<char>" -- c-addr u ) 2929** Parse ccc delimited by the delimiter char. 2930** c-addr is the address (within the input buffer) and u is the length of 2931** the parsed string. If the parse area was empty, the resulting string has 2932** a zero length. 2933** NOTE! PARSE differs from WORD: it does not skip leading delimiters. 2934**************************************************************************/ 2935static void parse(FICL_VM *pVM) 2936{ 2937 STRINGINFO si; 2938 char delim = (char)stackPopINT(pVM->pStack); 2939 2940 si = vmParseStringEx(pVM, delim, 0); 2941 stackPushPtr(pVM->pStack, SI_PTR(si)); 2942 stackPushUNS(pVM->pStack, SI_COUNT(si)); 2943 return; 2944} 2945 2946 2947/************************************************************************** 2948 f i l l 2949** CORE ( c-addr u char -- ) 2950** If u is greater than zero, store char in each of u consecutive 2951** characters of memory beginning at c-addr. 2952**************************************************************************/ 2953static void fill(FICL_VM *pVM) 2954{ 2955 char ch = (char)stackPopINT(pVM->pStack); 2956 FICL_UNS u = stackPopUNS(pVM->pStack); 2957 char *cp = (char *)stackPopPtr(pVM->pStack); 2958 2959 while (u > 0) 2960 { 2961 *cp++ = ch; 2962 u--; 2963 } 2964 2965 return; 2966} 2967 2968 2969/************************************************************************** 2970 f i n d 2971** FIND CORE ( c-addr -- c-addr 0 | xt 1 | xt -1 ) 2972** Find the definition named in the counted string at c-addr. If the 2973** definition is not found, return c-addr and zero. If the definition is 2974** found, return its execution token xt. If the definition is immediate, 2975** also return one (1), otherwise also return minus-one (-1). For a given 2976** string, the values returned by FIND while compiling may differ from 2977** those returned while not compiling. 2978**************************************************************************/ 2979static void find(FICL_VM *pVM) 2980{ 2981 FICL_STRING *sp = stackPopPtr(pVM->pStack); 2982 FICL_WORD *pFW; 2983 STRINGINFO si; 2984 2985 SI_PFS(si, sp); 2986 pFW = dictLookup(ficlGetDict(), si); 2987 if (pFW) 2988 { 2989 stackPushPtr(pVM->pStack, pFW); 2990 stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 2991 } 2992 else 2993 { 2994 stackPushPtr(pVM->pStack, sp); 2995 stackPushUNS(pVM->pStack, 0); 2996 } 2997 return; 2998} 2999 3000 3001 3002/************************************************************************** 3003 f m S l a s h M o d 3004** f-m-slash-mod CORE ( d1 n1 -- n2 n3 ) 3005** Divide d1 by n1, giving the floored quotient n3 and the remainder n2. 3006** Input and output stack arguments are signed. An ambiguous condition 3007** exists if n1 is zero or if the quotient lies outside the range of a 3008** single-cell signed integer. 3009**************************************************************************/ 3010static void fmSlashMod(FICL_VM *pVM) 3011{ 3012 DPINT d1; 3013 FICL_INT n1; 3014 INTQR qr; 3015 3016 n1 = stackPopINT(pVM->pStack); 3017 d1 = i64Pop(pVM->pStack); 3018 qr = m64FlooredDivI(d1, n1); 3019 stackPushINT(pVM->pStack, qr.rem); 3020 stackPushINT(pVM->pStack, qr.quot); 3021 return; 3022} 3023 3024 3025/************************************************************************** 3026 s m S l a s h R e m 3027** s-m-slash-rem CORE ( d1 n1 -- n2 n3 ) 3028** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2. 3029** Input and output stack arguments are signed. An ambiguous condition 3030** exists if n1 is zero or if the quotient lies outside the range of a 3031** single-cell signed integer. 3032**************************************************************************/ 3033static void smSlashRem(FICL_VM *pVM) 3034{ 3035 DPINT d1; 3036 FICL_INT n1; 3037 INTQR qr; 3038 3039 n1 = stackPopINT(pVM->pStack); 3040 d1 = i64Pop(pVM->pStack); 3041 qr = m64SymmetricDivI(d1, n1); 3042 stackPushINT(pVM->pStack, qr.rem); 3043 stackPushINT(pVM->pStack, qr.quot); 3044 return; 3045} 3046 3047 3048static void ficlMod(FICL_VM *pVM) 3049{ 3050 DPINT d1; 3051 FICL_INT n1; 3052 INTQR qr; 3053 3054 n1 = stackPopINT(pVM->pStack); 3055 d1.lo = stackPopINT(pVM->pStack); 3056 i64Extend(d1); 3057 qr = m64SymmetricDivI(d1, n1); 3058 stackPushINT(pVM->pStack, qr.rem); 3059 return; 3060} 3061 3062 3063/************************************************************************** 3064 u m S l a s h M o d 3065** u-m-slash-mod CORE ( ud u1 -- u2 u3 ) 3066** Divide ud by u1, giving the quotient u3 and the remainder u2. 3067** All values and arithmetic are unsigned. An ambiguous condition 3068** exists if u1 is zero or if the quotient lies outside the range of a 3069** single-cell unsigned integer. 3070*************************************************************************/ 3071static void umSlashMod(FICL_VM *pVM) 3072{ 3073 DPUNS ud; 3074 FICL_UNS u1; 3075 UNSQR qr; 3076 3077 u1 = stackPopUNS(pVM->pStack); 3078 ud = u64Pop(pVM->pStack); 3079 qr = ficlLongDiv(ud, u1); 3080 stackPushUNS(pVM->pStack, qr.rem); 3081 stackPushUNS(pVM->pStack, qr.quot); 3082 return; 3083} 3084 3085 3086/************************************************************************** 3087 l s h i f t 3088** l-shift CORE ( x1 u -- x2 ) 3089** Perform a logical left shift of u bit-places on x1, giving x2. 3090** Put zeroes into the least significant bits vacated by the shift. 3091** An ambiguous condition exists if u is greater than or equal to the 3092** number of bits in a cell. 3093** 3094** r-shift CORE ( x1 u -- x2 ) 3095** Perform a logical right shift of u bit-places on x1, giving x2. 3096** Put zeroes into the most significant bits vacated by the shift. An 3097** ambiguous condition exists if u is greater than or equal to the 3098** number of bits in a cell. 3099**************************************************************************/ 3100static void lshift(FICL_VM *pVM) 3101{ 3102 FICL_UNS nBits = stackPopUNS(pVM->pStack); 3103 FICL_UNS x1 = stackPopUNS(pVM->pStack); 3104 3105 stackPushUNS(pVM->pStack, x1 << nBits); 3106 return; 3107} 3108 3109 3110static void rshift(FICL_VM *pVM) 3111{ 3112 FICL_UNS nBits = stackPopUNS(pVM->pStack); 3113 FICL_UNS x1 = stackPopUNS(pVM->pStack); 3114 3115 stackPushUNS(pVM->pStack, x1 >> nBits); 3116 return; 3117} 3118 3119 3120/************************************************************************** 3121 m S t a r 3122** m-star CORE ( n1 n2 -- d ) 3123** d is the signed product of n1 times n2. 3124**************************************************************************/ 3125static void mStar(FICL_VM *pVM) 3126{ 3127 FICL_INT n2 = stackPopINT(pVM->pStack); 3128 FICL_INT n1 = stackPopINT(pVM->pStack); 3129 DPINT d; 3130 3131 d = m64MulI(n1, n2); 3132 i64Push(pVM->pStack, d); 3133 return; 3134} 3135 3136 3137static void umStar(FICL_VM *pVM) 3138{ 3139 FICL_UNS u2 = stackPopUNS(pVM->pStack); 3140 FICL_UNS u1 = stackPopUNS(pVM->pStack); 3141 DPUNS ud; 3142 3143 ud = ficlLongMul(u1, u2); 3144 u64Push(pVM->pStack, ud); 3145 return; 3146} 3147 3148 3149/************************************************************************** 3150 m a x & m i n 3151** 3152**************************************************************************/ 3153static void ficlMax(FICL_VM *pVM) 3154{ 3155 FICL_INT n2 = stackPopINT(pVM->pStack); 3156 FICL_INT n1 = stackPopINT(pVM->pStack); 3157 3158 stackPushINT(pVM->pStack, (n1 > n2) ? n1 : n2); 3159 return; 3160} 3161 3162static void ficlMin(FICL_VM *pVM) 3163{ 3164 FICL_INT n2 = stackPopINT(pVM->pStack); 3165 FICL_INT n1 = stackPopINT(pVM->pStack); 3166 3167 stackPushINT(pVM->pStack, (n1 < n2) ? n1 : n2); 3168 return; 3169} 3170 3171 3172/************************************************************************** 3173 m o v e 3174** CORE ( addr1 addr2 u -- ) 3175** If u is greater than zero, copy the contents of u consecutive address 3176** units at addr1 to the u consecutive address units at addr2. After MOVE 3177** completes, the u consecutive address units at addr2 contain exactly 3178** what the u consecutive address units at addr1 contained before the move. 3179** NOTE! This implementation assumes that a char is the same size as 3180** an address unit. 3181**************************************************************************/ 3182static void move(FICL_VM *pVM) 3183{ 3184 FICL_UNS u = stackPopUNS(pVM->pStack); 3185 char *addr2 = stackPopPtr(pVM->pStack); 3186 char *addr1 = stackPopPtr(pVM->pStack); 3187 3188 if (u == 0) 3189 return; 3190 /* 3191 ** Do the copy carefully, so as to be 3192 ** correct even if the two ranges overlap 3193 */ 3194 if (addr1 >= addr2) 3195 { 3196 for (; u > 0; u--) 3197 *addr2++ = *addr1++; 3198 } 3199 else 3200 { 3201 addr2 += u-1; 3202 addr1 += u-1; 3203 for (; u > 0; u--) 3204 *addr2-- = *addr1--; 3205 } 3206 3207 return; 3208} 3209 3210 3211/************************************************************************** 3212 r e c u r s e 3213** 3214**************************************************************************/ 3215static void recurseCoIm(FICL_VM *pVM) 3216{ 3217 FICL_DICT *pDict = ficlGetDict(); 3218 3219 IGNORE(pVM); 3220 dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge)); 3221 return; 3222} 3223 3224 3225/************************************************************************** 3226 s t o d 3227** s-to-d CORE ( n -- d ) 3228** Convert the number n to the double-cell number d with the same 3229** numerical value. 3230**************************************************************************/ 3231static void sToD(FICL_VM *pVM) 3232{ 3233 FICL_INT s = stackPopINT(pVM->pStack); 3234 3235 /* sign extend to 64 bits.. */ 3236 stackPushINT(pVM->pStack, s); 3237 stackPushINT(pVM->pStack, (s < 0) ? -1 : 0); 3238 return; 3239} 3240 3241 3242/************************************************************************** 3243 s o u r c e 3244** CORE ( -- c-addr u ) 3245** c-addr is the address of, and u is the number of characters in, the 3246** input buffer. 3247**************************************************************************/ 3248static void source(FICL_VM *pVM) 3249{ 3250 stackPushPtr(pVM->pStack, pVM->tib.cp); 3251 stackPushINT(pVM->pStack, vmGetInBufLen(pVM)); 3252 return; 3253} 3254 3255 3256/************************************************************************** 3257 v e r s i o n 3258** non-standard... 3259**************************************************************************/ 3260static void ficlVersion(FICL_VM *pVM) 3261{ 3262 vmTextOut(pVM, "ficl Version " FICL_VER, 1); 3263 return; 3264} 3265 3266 3267/************************************************************************** 3268 t o I n 3269** to-in CORE 3270**************************************************************************/ 3271static void toIn(FICL_VM *pVM) 3272{ 3273 stackPushPtr(pVM->pStack, &pVM->tib.index); 3274 return; 3275} 3276 3277 3278/************************************************************************** 3279 d e f i n i t i o n s 3280** SEARCH ( -- ) 3281** Make the compilation word list the same as the first word list in the 3282** search order. Specifies that the names of subsequent definitions will 3283** be placed in the compilation word list. Subsequent changes in the search 3284** order will not affect the compilation word list. 3285**************************************************************************/ 3286static void definitions(FICL_VM *pVM) 3287{ 3288 FICL_DICT *pDict = ficlGetDict(); 3289 3290 assert(pDict); 3291 if (pDict->nLists < 1) 3292 { 3293 vmThrowErr(pVM, "DEFINITIONS error - empty search order"); 3294 } 3295 3296 pDict->pCompile = pDict->pSearch[pDict->nLists-1]; 3297 return; 3298} 3299 3300 3301/************************************************************************** 3302 f o r t h - w o r d l i s t 3303** SEARCH ( -- wid ) 3304** Return wid, the identifier of the word list that includes all standard 3305** words provided by the implementation. This word list is initially the 3306** compilation word list and is part of the initial search order. 3307**************************************************************************/ 3308static void forthWordlist(FICL_VM *pVM) 3309{ 3310 FICL_HASH *pHash = ficlGetDict()->pForthWords; 3311 stackPushPtr(pVM->pStack, pHash); 3312 return; 3313} 3314 3315 3316/************************************************************************** 3317 g e t - c u r r e n t 3318** SEARCH ( -- wid ) 3319** Return wid, the identifier of the compilation word list. 3320**************************************************************************/ 3321static void getCurrent(FICL_VM *pVM) 3322{ 3323 ficlLockDictionary(TRUE); 3324 stackPushPtr(pVM->pStack, ficlGetDict()->pCompile); 3325 ficlLockDictionary(FALSE); 3326 return; 3327} 3328 3329 3330/************************************************************************** 3331 g e t - o r d e r 3332** SEARCH ( -- widn ... wid1 n ) 3333** Returns the number of word lists n in the search order and the word list 3334** identifiers widn ... wid1 identifying these word lists. wid1 identifies 3335** the word list that is searched first, and widn the word list that is 3336** searched last. The search order is unaffected. 3337**************************************************************************/ 3338static void getOrder(FICL_VM *pVM) 3339{ 3340 FICL_DICT *pDict = ficlGetDict(); 3341 int nLists = pDict->nLists; 3342 int i; 3343 3344 ficlLockDictionary(TRUE); 3345 for (i = 0; i < nLists; i++) 3346 { 3347 stackPushPtr(pVM->pStack, pDict->pSearch[i]); 3348 } 3349 3350 stackPushUNS(pVM->pStack, nLists); 3351 ficlLockDictionary(FALSE); 3352 return; 3353} 3354 3355 3356/************************************************************************** 3357 s e a r c h - w o r d l i s t 3358** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 ) 3359** Find the definition identified by the string c-addr u in the word list 3360** identified by wid. If the definition is not found, return zero. If the 3361** definition is found, return its execution token xt and one (1) if the 3362** definition is immediate, minus-one (-1) otherwise. 3363**************************************************************************/ 3364static void searchWordlist(FICL_VM *pVM) 3365{ 3366 STRINGINFO si; 3367 UNS16 hashCode; 3368 FICL_WORD *pFW; 3369 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 3370 3371 si.count = (FICL_COUNT)stackPopUNS(pVM->pStack); 3372 si.cp = stackPopPtr(pVM->pStack); 3373 hashCode = hashHashCode(si); 3374 3375 ficlLockDictionary(TRUE); 3376 pFW = hashLookup(pHash, si, hashCode); 3377 ficlLockDictionary(FALSE); 3378 3379 if (pFW) 3380 { 3381 stackPushPtr(pVM->pStack, pFW); 3382 stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1)); 3383 } 3384 else 3385 { 3386 stackPushUNS(pVM->pStack, 0); 3387 } 3388 3389 return; 3390} 3391 3392 3393/************************************************************************** 3394 s e t - c u r r e n t 3395** SEARCH ( wid -- ) 3396** Set the compilation word list to the word list identified by wid. 3397**************************************************************************/ 3398static void setCurrent(FICL_VM *pVM) 3399{ 3400 FICL_HASH *pHash = stackPopPtr(pVM->pStack); 3401 FICL_DICT *pDict = ficlGetDict(); 3402 ficlLockDictionary(TRUE); 3403 pDict->pCompile = pHash; 3404 ficlLockDictionary(FALSE); 3405 return; 3406} 3407 3408 3409/************************************************************************** 3410 s e t - o r d e r 3411** SEARCH ( widn ... wid1 n -- ) 3412** Set the search order to the word lists identified by widn ... wid1. 3413** Subsequently, word list wid1 will be searched first, and word list 3414** widn searched last. If n is zero, empty the search order. If n is minus 3415** one, set the search order to the implementation-defined minimum 3416** search order. The minimum search order shall include the words 3417** FORTH-WORDLIST and SET-ORDER. A system shall allow n to 3418** be at least eight. 3419**************************************************************************/ 3420static void setOrder(FICL_VM *pVM) 3421{ 3422 int i; 3423 int nLists = stackPopINT(pVM->pStack); 3424 FICL_DICT *dp = ficlGetDict(); 3425 3426 if (nLists > FICL_DEFAULT_VOCS) 3427 { 3428 vmThrowErr(pVM, "set-order error: list would be too large"); 3429 } 3430 3431 ficlLockDictionary(TRUE); 3432 3433 if (nLists >= 0) 3434 { 3435 dp->nLists = nLists; 3436 for (i = nLists-1; i >= 0; --i) 3437 { 3438 dp->pSearch[i] = stackPopPtr(pVM->pStack); 3439 } 3440 } 3441 else 3442 { 3443 dictResetSearchOrder(dp); 3444 } 3445 3446 ficlLockDictionary(FALSE); 3447 return; 3448} 3449 3450 3451/************************************************************************** 3452 w o r d l i s t 3453** SEARCH ( -- wid ) 3454** Create a new empty word list, returning its word list identifier wid. 3455** The new word list may be returned from a pool of preallocated word 3456** lists or may be dynamically allocated in data space. A system shall 3457** allow the creation of at least 8 new word lists in addition to any 3458** provided as part of the system. 3459** Notes: 3460** 1. ficl creates a new single-list hash in the dictionary and returns 3461** its address. 3462** 2. ficl-wordlist takes an arg off the stack indicating the number of 3463** hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as 3464** : wordlist 1 ficl-wordlist ; 3465**************************************************************************/ 3466static void wordlist(FICL_VM *pVM) 3467{ 3468 FICL_DICT *dp = ficlGetDict(); 3469 FICL_HASH *pHash; 3470 FICL_UNS nBuckets; 3471 3472#if FICL_ROBUST > 1 3473 vmCheckStack(pVM, 1, 1); 3474#endif 3475 nBuckets = stackPopUNS(pVM->pStack); 3476 3477 dictAlign(dp); 3478 pHash = (FICL_HASH *)dp->here; 3479 dictAllot(dp, sizeof (FICL_HASH) 3480 + (nBuckets-1) * sizeof (FICL_WORD *)); 3481 3482 pHash->size = nBuckets; 3483 hashReset(pHash); 3484 3485 stackPushPtr(pVM->pStack, pHash); 3486 return; 3487} 3488 3489 3490/************************************************************************** 3491 S E A R C H > 3492** ficl ( -- wid ) 3493** Pop wid off the search order. Error if the search order is empty 3494**************************************************************************/ 3495static void searchPop(FICL_VM *pVM) 3496{ 3497 FICL_DICT *dp = ficlGetDict(); 3498 int nLists; 3499 3500 ficlLockDictionary(TRUE); 3501 nLists = dp->nLists; 3502 if (nLists == 0) 3503 { 3504 vmThrowErr(pVM, "search> error: empty search order"); 3505 } 3506 stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]); 3507 ficlLockDictionary(FALSE); 3508 return; 3509} 3510 3511 3512/************************************************************************** 3513 > S E A R C H 3514** ficl ( wid -- ) 3515** Push wid onto the search order. Error if the search order is full. 3516**************************************************************************/ 3517static void searchPush(FICL_VM *pVM) 3518{ 3519 FICL_DICT *dp = ficlGetDict(); 3520 3521 ficlLockDictionary(TRUE); 3522 if (dp->nLists > FICL_DEFAULT_VOCS) 3523 { 3524 vmThrowErr(pVM, ">search error: search order overflow"); 3525 } 3526 dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack); 3527 ficlLockDictionary(FALSE); 3528 return; 3529} 3530 3531 3532/************************************************************************** 3533 c o l o n N o N a m e 3534** CORE EXT ( C: -- colon-sys ) ( S: -- xt ) 3535** Create an unnamed colon definition and push its address. 3536** Change state to compile. 3537**************************************************************************/ 3538static void colonNoName(FICL_VM *pVM) 3539{ 3540 FICL_DICT *dp = ficlGetDict(); 3541 FICL_WORD *pFW; 3542 STRINGINFO si; 3543 3544 SI_SETLEN(si, 0); 3545 SI_SETPTR(si, NULL); 3546 3547 pVM->state = COMPILE; 3548 pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE); 3549 stackPushPtr(pVM->pStack, pFW); 3550 markControlTag(pVM, colonTag); 3551 return; 3552} 3553 3554 3555/************************************************************************** 3556 u s e r V a r i a b l e 3557** user ( u -- ) "<spaces>name" 3558** Get a name from the input stream and create a user variable 3559** with the name and the index supplied. The run-time effect 3560** of a user variable is to push the address of the indexed cell 3561** in the running vm's user array. 3562** 3563** User variables are vm local cells. Each vm has an array of 3564** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero. 3565** Ficl's user facility is implemented with two primitives, 3566** "user" and "(user)", a variable ("nUser") (in softcore.c) that 3567** holds the index of the next free user cell, and a redefinition 3568** (also in softcore) of "user" that defines a user word and increments 3569** nUser. 3570**************************************************************************/ 3571#if FICL_WANT_USER 3572static void userParen(FICL_VM *pVM) 3573{ 3574 FICL_INT i = pVM->runningWord->param[0].i; 3575 stackPushPtr(pVM->pStack, &pVM->user[i]); 3576 return; 3577} 3578 3579 3580static void userVariable(FICL_VM *pVM) 3581{ 3582 FICL_DICT *dp = ficlGetDict(); 3583 STRINGINFO si = vmGetWord(pVM); 3584 CELL c; 3585 3586 c = stackPop(pVM->pStack); 3587 if (c.i >= FICL_USER_CELLS) 3588 { 3589 vmThrowErr(pVM, "Error - out of user space"); 3590 } 3591 3592 dictAppendWord2(dp, si, userParen, FW_DEFAULT); 3593 dictAppendCell(dp, c); 3594 return; 3595} 3596#endif 3597 3598 3599/************************************************************************** 3600 t o V a l u e 3601** CORE EXT 3602** Interpretation: ( x "<spaces>name" -- ) 3603** Skip leading spaces and parse name delimited by a space. Store x in 3604** name. An ambiguous condition exists if name was not defined by VALUE. 3605** NOTE: In ficl, VALUE is an alias of CONSTANT 3606**************************************************************************/ 3607static void toValue(FICL_VM *pVM) 3608{ 3609 STRINGINFO si = vmGetWord(pVM); 3610 FICL_DICT *dp = ficlGetDict(); 3611 FICL_WORD *pFW; 3612 3613#if FICL_WANT_LOCALS 3614 if ((nLocals > 0) && (pVM->state == COMPILE)) 3615 { 3616 FICL_DICT *pLoc = ficlGetLoc(); 3617 pFW = dictLookup(pLoc, si); 3618 if (pFW && (pFW->code == doLocalIm)) 3619 { 3620 dictAppendCell(dp, LVALUEtoCELL(pToLocalParen)); 3621 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 3622 return; 3623 } 3624 else if (pFW && pFW->code == do2LocalIm) 3625 { 3626 dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen)); 3627 dictAppendCell(dp, LVALUEtoCELL(pFW->param[0])); 3628 return; 3629 } 3630 } 3631#endif 3632 3633 assert(pStore); 3634 3635 pFW = dictLookup(dp, si); 3636 if (!pFW) 3637 { 3638 int i = SI_COUNT(si); 3639 vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si)); 3640 } 3641 3642 if (pVM->state == INTERPRET) 3643 pFW->param[0] = stackPop(pVM->pStack); 3644 else /* compile code to store to word's param */ 3645 { 3646 stackPushPtr(pVM->pStack, &pFW->param[0]); 3647 literalIm(pVM); 3648 dictAppendCell(dp, LVALUEtoCELL(pStore)); 3649 } 3650 return; 3651} 3652 3653 3654#if FICL_WANT_LOCALS 3655/************************************************************************** 3656 l i n k P a r e n 3657** ( -- ) 3658** Link a frame on the return stack, reserving nCells of space for 3659** locals - the value of nCells is the next cell in the instruction 3660** stream. 3661**************************************************************************/ 3662static void linkParen(FICL_VM *pVM) 3663{ 3664 FICL_INT nLink = *(FICL_INT *)(pVM->ip); 3665 vmBranchRelative(pVM, 1); 3666 stackLink(pVM->rStack, nLink); 3667 return; 3668} 3669 3670 3671static void unlinkParen(FICL_VM *pVM) 3672{ 3673 stackUnlink(pVM->rStack); 3674 return; 3675} 3676 3677 3678/************************************************************************** 3679 d o L o c a l I m 3680** Immediate - cfa of a local while compiling - when executed, compiles 3681** code to fetch the value of a local given the local's index in the 3682** word's pfa 3683**************************************************************************/ 3684static void getLocalParen(FICL_VM *pVM) 3685{ 3686 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 3687 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3688 return; 3689} 3690 3691 3692static void toLocalParen(FICL_VM *pVM) 3693{ 3694 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 3695 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 3696 return; 3697} 3698 3699 3700static void getLocal0(FICL_VM *pVM) 3701{ 3702 stackPush(pVM->pStack, pVM->rStack->pFrame[0]); 3703 return; 3704} 3705 3706 3707static void toLocal0(FICL_VM *pVM) 3708{ 3709 pVM->rStack->pFrame[0] = stackPop(pVM->pStack); 3710 return; 3711} 3712 3713 3714static void getLocal1(FICL_VM *pVM) 3715{ 3716 stackPush(pVM->pStack, pVM->rStack->pFrame[1]); 3717 return; 3718} 3719 3720 3721static void toLocal1(FICL_VM *pVM) 3722{ 3723 pVM->rStack->pFrame[1] = stackPop(pVM->pStack); 3724 return; 3725} 3726 3727 3728/* 3729** Each local is recorded in a private locals dictionary as a 3730** word that does doLocalIm at runtime. DoLocalIm compiles code 3731** into the client definition to fetch the value of the 3732** corresponding local variable from the return stack. 3733** The private dictionary gets initialized at the end of each block 3734** that uses locals (in ; and does> for example). 3735*/ 3736static void doLocalIm(FICL_VM *pVM) 3737{ 3738 FICL_DICT *pDict = ficlGetDict(); 3739 int nLocal = pVM->runningWord->param[0].i; 3740 3741 if (pVM->state == INTERPRET) 3742 { 3743 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3744 } 3745 else 3746 { 3747 3748 if (nLocal == 0) 3749 { 3750 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0)); 3751 } 3752 else if (nLocal == 1) 3753 { 3754 dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1)); 3755 } 3756 else 3757 { 3758 dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen)); 3759 dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 3760 } 3761 } 3762 return; 3763} 3764 3765 3766/************************************************************************** 3767 l o c a l P a r e n 3768** paren-local-paren LOCAL 3769** Interpretation: Interpretation semantics for this word are undefined. 3770** Execution: ( c-addr u -- ) 3771** When executed during compilation, (LOCAL) passes a message to the 3772** system that has one of two meanings. If u is non-zero, 3773** the message identifies a new local whose definition name is given by 3774** the string of characters identified by c-addr u. If u is zero, 3775** the message is last local and c-addr has no significance. 3776** 3777** The result of executing (LOCAL) during compilation of a definition is 3778** to create a set of named local identifiers, each of which is 3779** a definition name, that only have execution semantics within the scope 3780** of that definition's source. 3781** 3782** local Execution: ( -- x ) 3783** 3784** Push the local's value, x, onto the stack. The local's value is 3785** initialized as described in 13.3.3 Processing locals and may be 3786** changed by preceding the local's name with TO. An ambiguous condition 3787** exists when local is executed while in interpretation state. 3788**************************************************************************/ 3789static void localParen(FICL_VM *pVM) 3790{ 3791 FICL_DICT *pDict = ficlGetDict(); 3792 STRINGINFO si; 3793 SI_SETLEN(si, stackPopUNS(pVM->pStack)); 3794 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); 3795 3796 if (SI_COUNT(si) > 0) 3797 { /* add a local to the **locals** dict and update nLocals */ 3798 FICL_DICT *pLoc = ficlGetLoc(); 3799 if (nLocals >= FICL_MAX_LOCALS) 3800 { 3801 vmThrowErr(pVM, "Error: out of local space"); 3802 } 3803 3804 dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED); 3805 dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); 3806 3807 if (nLocals == 0) 3808 { /* compile code to create a local stack frame */ 3809 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); 3810 /* save location in dictionary for #locals */ 3811 pMarkLocals = pDict->here; 3812 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3813 /* compile code to initialize first local */ 3814 dictAppendCell(pDict, LVALUEtoCELL(pToLocal0)); 3815 } 3816 else if (nLocals == 1) 3817 { 3818 dictAppendCell(pDict, LVALUEtoCELL(pToLocal1)); 3819 } 3820 else 3821 { 3822 dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen)); 3823 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3824 } 3825 3826 nLocals++; 3827 } 3828 else if (nLocals > 0) 3829 { /* write nLocals to (link) param area in dictionary */ 3830 *(FICL_INT *)pMarkLocals = nLocals; 3831 } 3832 3833 return; 3834} 3835 3836 3837static void get2LocalParen(FICL_VM *pVM) 3838{ 3839 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 3840 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3841 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); 3842 return; 3843} 3844 3845 3846static void do2LocalIm(FICL_VM *pVM) 3847{ 3848 FICL_DICT *pDict = ficlGetDict(); 3849 int nLocal = pVM->runningWord->param[0].i; 3850 3851 if (pVM->state == INTERPRET) 3852 { 3853 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]); 3854 stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]); 3855 } 3856 else 3857 { 3858 dictAppendCell(pDict, LVALUEtoCELL(pGet2LocalParen)); 3859 dictAppendCell(pDict, LVALUEtoCELL(nLocal)); 3860 } 3861 return; 3862} 3863 3864 3865static void to2LocalParen(FICL_VM *pVM) 3866{ 3867 FICL_INT nLocal = *(FICL_INT *)(pVM->ip++); 3868 pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack); 3869 pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack); 3870 return; 3871} 3872 3873 3874static void twoLocalParen(FICL_VM *pVM) 3875{ 3876 FICL_DICT *pDict = ficlGetDict(); 3877 STRINGINFO si; 3878 SI_SETLEN(si, stackPopUNS(pVM->pStack)); 3879 SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack)); 3880 3881 if (SI_COUNT(si) > 0) 3882 { /* add a local to the **locals** dict and update nLocals */ 3883 FICL_DICT *pLoc = ficlGetLoc(); 3884 if (nLocals >= FICL_MAX_LOCALS) 3885 { 3886 vmThrowErr(pVM, "Error: out of local space"); 3887 } 3888 3889 dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED); 3890 dictAppendCell(pLoc, LVALUEtoCELL(nLocals)); 3891 3892 if (nLocals == 0) 3893 { /* compile code to create a local stack frame */ 3894 dictAppendCell(pDict, LVALUEtoCELL(pLinkParen)); 3895 /* save location in dictionary for #locals */ 3896 pMarkLocals = pDict->here; 3897 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3898 } 3899 3900 dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen)); 3901 dictAppendCell(pDict, LVALUEtoCELL(nLocals)); 3902 3903 nLocals += 2; 3904 } 3905 else if (nLocals > 0) 3906 { /* write nLocals to (link) param area in dictionary */ 3907 *(FICL_INT *)pMarkLocals = nLocals; 3908 } 3909 3910 return; 3911} 3912 3913 3914#endif 3915/************************************************************************** 3916 setParentWid 3917** FICL 3918** setparentwid ( parent-wid wid -- ) 3919** Set WID's link field to the parent-wid. search-wordlist will 3920** iterate through all the links when finding words in the child wid. 3921**************************************************************************/ 3922static void setParentWid(FICL_VM *pVM) 3923{ 3924 FICL_HASH *parent, *child; 3925#if FICL_ROBUST > 1 3926 vmCheckStack(pVM, 2, 0); 3927#endif 3928 child = (FICL_HASH *)stackPopPtr(pVM->pStack); 3929 parent = (FICL_HASH *)stackPopPtr(pVM->pStack); 3930 3931 child->link = parent; 3932 return; 3933} 3934 3935 3936/************************************************************************** 3937 s e e 3938** TOOLS ( "<spaces>name" -- ) 3939** Display a human-readable representation of the named word's definition. 3940** The source of the representation (object-code decompilation, source 3941** block, etc.) and the particular form of the display is implementation 3942** defined. 3943** NOTE: these funcs come late in the file because they reference all 3944** of the word-builder funcs without declaring them again. Call me lazy. 3945**************************************************************************/ 3946/* 3947** isAFiclWord 3948** Vet a candidate pointer carefully to make sure 3949** it's not some chunk o' inline data... 3950** It has to have a name, and it has to look 3951** like it's in the dictionary address range. 3952** NOTE: this excludes :noname words! 3953*/ 3954static int isAFiclWord(FICL_WORD *pFW) 3955{ 3956 FICL_DICT *pd = ficlGetDict(); 3957 3958 if (!dictIncludes(pd, pFW)) 3959 return 0; 3960 3961 if (!dictIncludes(pd, pFW->name)) 3962 return 0; 3963 3964 return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0')); 3965} 3966 3967/* 3968** seeColon (for proctologists only) 3969** Walks a colon definition, decompiling 3970** on the fly. Knows about primitive control structures. 3971*/ 3972static void seeColon(FICL_VM *pVM, CELL *pc) 3973{ 3974 for (; pc->p != pSemiParen; pc++) 3975 { 3976 FICL_WORD *pFW = (FICL_WORD *)(pc->p); 3977 3978 if (isAFiclWord(pFW)) 3979 { 3980 if (pFW->code == literalParen) 3981 { 3982 CELL v = *++pc; 3983 if (isAFiclWord(v.p)) 3984 { 3985 FICL_WORD *pLit = (FICL_WORD *)v.p; 3986 sprintf(pVM->pad, " literal %.*s (%#lx)", 3987 pLit->nName, pLit->name, v.u); 3988 } 3989 else 3990 sprintf(pVM->pad, " literal %ld (%#lx)", v.i, v.u); 3991 } 3992 else if (pFW->code == stringLit) 3993 { 3994 FICL_STRING *sp = (FICL_STRING *)(void *)++pc; 3995 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1; 3996 sprintf(pVM->pad, " s\" %.*s\"", sp->count, sp->text); 3997 } 3998 else if (pFW->code == ifParen) 3999 { 4000 CELL c = *++pc; 4001 if (c.i > 0) 4002 sprintf(pVM->pad, " if / while (branch rel %ld)", c.i); 4003 else 4004 sprintf(pVM->pad, " until (branch rel %ld)", c.i); 4005 } 4006 else if (pFW->code == branchParen) 4007 { 4008 CELL c = *++pc; 4009 if (c.i > 0) 4010 sprintf(pVM->pad, " else (branch rel %ld)", c.i); 4011 else 4012 sprintf(pVM->pad, " repeat (branch rel %ld)", c.i); 4013 } 4014 else if (pFW->code == qDoParen) 4015 { 4016 CELL c = *++pc; 4017 sprintf(pVM->pad, " ?do (leave abs %#lx)", c.u); 4018 } 4019 else if (pFW->code == doParen) 4020 { 4021 CELL c = *++pc; 4022 sprintf(pVM->pad, " do (leave abs %#lx)", c.u); 4023 } 4024 else if (pFW->code == loopParen) 4025 { 4026 CELL c = *++pc; 4027 sprintf(pVM->pad, " loop (branch rel %#ld)", c.i); 4028 } 4029 else if (pFW->code == plusLoopParen) 4030 { 4031 CELL c = *++pc; 4032 sprintf(pVM->pad, " +loop (branch rel %#ld)", c.i); 4033 } 4034 else /* default: print word's name */ 4035 { 4036 sprintf(pVM->pad, " %.*s", pFW->nName, pFW->name); 4037 } 4038 4039 vmTextOut(pVM, pVM->pad, 1); 4040 } 4041 else /* probably not a word - punt and print value */ 4042 { 4043 sprintf(pVM->pad, " %ld (%#lx)", pc->i, pc->u); 4044 vmTextOut(pVM, pVM->pad, 1); 4045 } 4046 } 4047 4048 vmTextOut(pVM, ";", 1); 4049} 4050 4051/* 4052** Here's the outer part of the decompiler. It's 4053** just a big nested conditional that checks the 4054** CFA of the word to decompile for each kind of 4055** known word-builder code, and tries to do 4056** something appropriate. If the CFA is not recognized, 4057** just indicate that it is a primitive. 4058*/ 4059static void see(FICL_VM *pVM) 4060{ 4061 FICL_WORD *pFW; 4062 4063 tick(pVM); 4064 pFW = (FICL_WORD *)stackPopPtr(pVM->pStack); 4065 4066 if (pFW->code == colonParen) 4067 { 4068 sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name); 4069 vmTextOut(pVM, pVM->pad, 1); 4070 seeColon(pVM, pFW->param); 4071 } 4072 else if (pFW->code == doDoes) 4073 { 4074 vmTextOut(pVM, "does>", 1); 4075 seeColon(pVM, (CELL *)pFW->param->p); 4076 } 4077 else if (pFW->code == createParen) 4078 { 4079 vmTextOut(pVM, "create", 1); 4080 } 4081 else if (pFW->code == variableParen) 4082 { 4083 sprintf(pVM->pad, "variable = %ld (%#lx)", 4084 pFW->param->i, pFW->param->u); 4085 vmTextOut(pVM, pVM->pad, 1); 4086 } 4087 else if (pFW->code == userParen) 4088 { 4089 sprintf(pVM->pad, "user variable %ld (%#lx)", 4090 pFW->param->i, pFW->param->u); 4091 vmTextOut(pVM, pVM->pad, 1); 4092 } 4093 else if (pFW->code == constantParen) 4094 { 4095 sprintf(pVM->pad, "constant = %ld (%#lx)", 4096 pFW->param->i, pFW->param->u); 4097 vmTextOut(pVM, pVM->pad, 1); 4098 } 4099 else 4100 { 4101 vmTextOut(pVM, "primitive", 1); 4102 } 4103 4104 if (pFW->flags & FW_IMMEDIATE) 4105 { 4106 vmTextOut(pVM, "immediate", 1); 4107 } 4108 4109 return; 4110} 4111 4112 4113/************************************************************************** 4114 c o m p a r e 4115** STRING ( c-addr1 u1 c-addr2 u2 -- n ) 4116** Compare the string specified by c-addr1 u1 to the string specified by 4117** c-addr2 u2. The strings are compared, beginning at the given addresses, 4118** character by character, up to the length of the shorter string or until a 4119** difference is found. If the two strings are identical, n is zero. If the two 4120** strings are identical up to the length of the shorter string, n is minus-one 4121** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not 4122** identical up to the length of the shorter string, n is minus-one (-1) if the 4123** first non-matching character in the string specified by c-addr1 u1 has a 4124** lesser numeric value than the corresponding character in the string specified 4125** by c-addr2 u2 and one (1) otherwise. 4126**************************************************************************/ 4127static void compareString(FICL_VM *pVM) 4128{ 4129 char *cp1, *cp2; 4130 FICL_UNS u1, u2, uMin; 4131 int n = 0; 4132 4133 vmCheckStack(pVM, 4, 1); 4134 u2 = stackPopUNS(pVM->pStack); 4135 cp2 = (char *)stackPopPtr(pVM->pStack); 4136 u1 = stackPopUNS(pVM->pStack); 4137 cp1 = (char *)stackPopPtr(pVM->pStack); 4138 4139 uMin = (u1 < u2)? u1 : u2; 4140 for ( ; (uMin > 0) && (n == 0); uMin--) 4141 { 4142 n = (int)(*cp1++ - *cp2++); 4143 } 4144 4145 if (n == 0) 4146 n = (int)(u1 - u2); 4147 4148 if (n < 0) 4149 n = -1; 4150 else if (n > 0) 4151 n = 1; 4152 4153 stackPushINT(pVM->pStack, n); 4154 return; 4155} 4156 4157 4158/************************************************************************** 4159 s o u r c e - i d 4160** CORE EXT, FILE ( -- 0 | -1 | fileid ) 4161** Identifies the input source as follows: 4162** 4163** SOURCE-ID Input source 4164** --------- ------------ 4165** fileid Text file fileid 4166** -1 String (via EVALUATE) 4167** 0 User input device 4168**************************************************************************/ 4169static void sourceid(FICL_VM *pVM) 4170{ 4171 stackPushINT(pVM->pStack, pVM->sourceID.i); 4172 return; 4173} 4174 4175 4176/************************************************************************** 4177 r e f i l l 4178** CORE EXT ( -- flag ) 4179** Attempt to fill the input buffer from the input source, returning a true 4180** flag if successful. 4181** When the input source is the user input device, attempt to receive input 4182** into the terminal input buffer. If successful, make the result the input 4183** buffer, set >IN to zero, and return true. Receipt of a line containing no 4184** characters is considered successful. If there is no input available from 4185** the current input source, return false. 4186** When the input source is a string from EVALUATE, return false and 4187** perform no other action. 4188**************************************************************************/ 4189static void refill(FICL_VM *pVM) 4190{ 4191 static int tries = 0; 4192 4193 FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE; 4194 if (ret && tries == 0) { 4195 tries = 1; 4196 vmThrow(pVM, VM_RESTART); 4197 } 4198 if (tries == 1) 4199 tries = 0; 4200 stackPushINT(pVM->pStack, ret); 4201 return; 4202} 4203 4204 4205/************************************************************************** 4206 f o r g e t 4207** TOOLS EXT ( "<spaces>name" -- ) 4208** Skip leading space delimiters. Parse name delimited by a space. 4209** Find name, then delete name from the dictionary along with all 4210** words added to the dictionary after name. An ambiguous 4211** condition exists if name cannot be found. 4212** 4213** If the Search-Order word set is present, FORGET searches the 4214** compilation word list. An ambiguous condition exists if the 4215** compilation word list is deleted. 4216**************************************************************************/ 4217static void forgetWid(FICL_VM *pVM) 4218{ 4219 FICL_DICT *pDict = ficlGetDict(); 4220 FICL_HASH *pHash; 4221 4222 pHash = (FICL_HASH *)stackPopPtr(pVM->pStack); 4223 hashForget(pHash, pDict->here); 4224 4225 return; 4226} 4227 4228 4229static void forget(FICL_VM *pVM) 4230{ 4231 void *where; 4232 FICL_DICT *pDict = ficlGetDict(); 4233 FICL_HASH *pHash = pDict->pCompile; 4234 4235 tick(pVM); 4236 where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name; 4237 hashForget(pHash, where); 4238 pDict->here = PTRtoCELL where; 4239 4240 return; 4241} 4242 4243/************************* freebsd added I/O words **************************/ 4244 4245/* fopen - open a file and return new fd on stack. 4246 * 4247 * fopen ( count ptr -- fd ) 4248 */ 4249static void pfopen(FICL_VM *pVM) 4250{ 4251 int fd; 4252 char *p; 4253 4254#if FICL_ROBUST > 1 4255 vmCheckStack(pVM, 2, 1); 4256#endif 4257 (void)stackPopINT(pVM->pStack); /* don't need count value */ 4258 p = stackPopPtr(pVM->pStack); 4259 fd = open(p, O_RDONLY); 4260 stackPushINT(pVM->pStack, fd); 4261 return; 4262} 4263 4264/* fclose - close a file who's fd is on stack. 4265 * 4266 * fclose ( fd -- ) 4267 */ 4268static void pfclose(FICL_VM *pVM) 4269{ 4270 int fd; 4271 4272#if FICL_ROBUST > 1 4273 vmCheckStack(pVM, 1, 0); 4274#endif 4275 fd = stackPopINT(pVM->pStack); /* get fd */ 4276 if (fd != -1) 4277 close(fd); 4278 return; 4279} 4280 4281/* fread - read file contents 4282 * 4283 * fread ( fd buf nbytes -- nread ) 4284 */ 4285static void pfread(FICL_VM *pVM) 4286{ 4287 int fd, len; 4288 char *buf; 4289 4290#if FICL_ROBUST > 1 4291 vmCheckStack(pVM, 3, 1); 4292#endif 4293 len = stackPopINT(pVM->pStack); /* get number of bytes to read */ 4294 buf = stackPopPtr(pVM->pStack); /* get buffer */ 4295 fd = stackPopINT(pVM->pStack); /* get fd */ 4296 if (len > 0 && buf && fd != -1) 4297 stackPushINT(pVM->pStack, read(fd, buf, len)); 4298 else 4299 stackPushINT(pVM->pStack, -1); 4300 return; 4301} 4302 4303/* fload - interpret file contents 4304 * 4305 * fload ( fd -- ) 4306 */ 4307static void pfload(FICL_VM *pVM) 4308{ 4309 int fd; 4310 4311#if FICL_ROBUST > 1 4312 vmCheckStack(pVM, 1, 0); 4313#endif 4314 fd = stackPopINT(pVM->pStack); /* get fd */ 4315 if (fd != -1) 4316 ficlExecFD(pVM, fd); 4317 return; 4318} 4319 4320/* key - get a character from stdin 4321 * 4322 * key ( -- char ) 4323 */ 4324static void key(FICL_VM *pVM) 4325{ 4326#if FICL_ROBUST > 1 4327 vmCheckStack(pVM, 0, 1); 4328#endif 4329 stackPushINT(pVM->pStack, getchar()); 4330 return; 4331} 4332 4333/* key? - check for a character from stdin (FACILITY) 4334 * 4335 * key? ( -- flag ) 4336 */ 4337static void keyQuestion(FICL_VM *pVM) 4338{ 4339#if FICL_ROBUST > 1 4340 vmCheckStack(pVM, 0, 1); 4341#endif 4342#ifdef TESTMAIN 4343 /* XXX Since we don't fiddle with termios, let it always succeed... */ 4344 stackPushINT(pVM->pStack, FICL_TRUE); 4345#else 4346 /* But here do the right thing. */ 4347 stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE); 4348#endif 4349 return; 4350} 4351 4352/* seconds - gives number of seconds since beginning of time 4353 * 4354 * beginning of time is defined as: 4355 * 4356 * BTX - number of seconds since midnight 4357 * FreeBSD - number of seconds since Jan 1 1970 4358 * 4359 * seconds ( -- u ) 4360 */ 4361static void pseconds(FICL_VM *pVM) 4362{ 4363#if FICL_ROBUST > 1 4364 vmCheckStack(pVM,0,1); 4365#endif 4366 stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL)); 4367 return; 4368} 4369 4370/* ms - wait at least that many milliseconds (FACILITY) 4371 * 4372 * ms ( u -- ) 4373 * 4374 */ 4375static void ms(FICL_VM *pVM) 4376{ 4377#if FICL_ROBUST > 1 4378 vmCheckStack(pVM,1,0); 4379#endif 4380#ifdef TESTMAIN 4381 usleep(stackPopUNS(pVM->pStack)*1000); 4382#else 4383 delay(stackPopUNS(pVM->pStack)*1000); 4384#endif 4385 return; 4386} 4387 4388/* fkey - get a character from a file 4389 * 4390 * fkey ( file -- char ) 4391 */ 4392static void fkey(FICL_VM *pVM) 4393{ 4394 int i, fd; 4395 char ch; 4396 4397#if FICL_ROBUST > 1 4398 vmCheckStack(pVM, 1, 1); 4399#endif 4400 fd = stackPopINT(pVM->pStack); 4401 i = read(fd, &ch, 1); 4402 stackPushINT(pVM->pStack, i > 0 ? ch : -1); 4403 return; 4404} 4405 4406/************************************************************************** 4407 freebsd exception handling words 4408** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE 4409** the word in ToS. If an exception happens, restore the state to what 4410** it was before, and pushes the exception value on the stack. If not, 4411** push zero. 4412** 4413** Notice that Catch implements an inner interpreter. This is ugly, 4414** but given how ficl works, it cannot be helped. The problem is that 4415** colon definitions will be executed *after* the function returns, 4416** while "code" definitions will be executed immediately. I considered 4417** other solutions to this problem, but all of them shared the same 4418** basic problem (with added disadvantages): if ficl ever changes it's 4419** inner thread modus operandi, one would have to fix this word. 4420** 4421** More comments can be found throughout catch's code. 4422** 4423** Daniel C. Sobral Jan 09/1999 4424** sadler may 2000 -- revised to follow ficl.c:ficlExecXT. 4425**************************************************************************/ 4426 4427static void ficlCatch(FICL_VM *pVM) 4428{ 4429 static FICL_WORD *pQuit = NULL; 4430 4431 int except; 4432 jmp_buf vmState; 4433 FICL_VM VM; 4434 FICL_STACK pStack; 4435 FICL_STACK rStack; 4436 FICL_WORD *pFW; 4437 4438 if (!pQuit) 4439 pQuit = ficlLookup("exit-inner"); 4440 4441 assert(pVM); 4442 assert(pQuit); 4443 4444 4445 /* 4446 ** Get xt. 4447 ** We need this *before* we save the stack pointer, or 4448 ** we'll have to pop one element out of the stack after 4449 ** an exception. I prefer to get done with it up front. :-) 4450 */ 4451#if FICL_ROBUST > 1 4452 vmCheckStack(pVM, 1, 0); 4453#endif 4454 pFW = stackPopPtr(pVM->pStack); 4455 4456 /* 4457 ** Save vm's state -- a catch will not back out environmental 4458 ** changes. 4459 ** 4460 ** We are *not* saving dictionary state, since it is 4461 ** global instead of per vm, and we are not saving 4462 ** stack contents, since we are not required to (and, 4463 ** thus, it would be useless). We save pVM, and pVM 4464 ** "stacks" (a structure containing general information 4465 ** about it, including the current stack pointer). 4466 */ 4467 memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM)); 4468 memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK)); 4469 memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK)); 4470 4471 /* 4472 ** Give pVM a jmp_buf 4473 */ 4474 pVM->pState = &vmState; 4475 4476 /* 4477 ** Safety net 4478 */ 4479 except = setjmp(vmState); 4480 4481 switch (except) 4482 { 4483 /* 4484 ** Setup condition - push poison pill so that the VM throws 4485 ** VM_INNEREXIT if the XT terminates normally, then execute 4486 ** the XT 4487 */ 4488 case 0: 4489 vmPushIP(pVM, &pQuit); /* Open mouth, insert emetic */ 4490 vmExecute(pVM, pFW); 4491 vmInnerLoop(pVM); 4492 break; 4493 4494 /* 4495 ** Normal exit from XT - lose the poison pill, 4496 ** restore old setjmp vector and push a zero. 4497 */ 4498 case VM_INNEREXIT: 4499 vmPopIP(pVM); /* Gack - hurl poison pill */ 4500 pVM->pState = VM.pState; /* Restore just the setjmp vector */ 4501 stackPushINT(pVM->pStack, 0); /* Push 0 -- everything is ok */ 4502 break; 4503 4504 /* 4505 ** Some other exception got thrown - restore pre-existing VM state 4506 ** and push the exception code 4507 */ 4508 default: 4509 /* Restore vm's state */ 4510 memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM)); 4511 memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK)); 4512 memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK)); 4513 4514 stackPushINT(pVM->pStack, except);/* Push error */ 4515 break; 4516 } 4517} 4518 4519/* 4520 * Throw -- From ANS Forth standard. 4521 * 4522 * Throw takes the ToS and, if that's different from zero, 4523 * returns to the last executed catch context. Further throws will 4524 * unstack previously executed "catches", in LIFO mode. 4525 * 4526 * Daniel C. Sobral Jan 09/1999 4527 */ 4528 4529static void ficlThrow(FICL_VM *pVM) 4530{ 4531 int except; 4532 4533 except = stackPopINT(pVM->pStack); 4534 4535 if (except) 4536 vmThrow(pVM, except); 4537} 4538 4539 4540static void ansAllocate(FICL_VM *pVM) 4541{ 4542 size_t size; 4543 void *p; 4544 4545 size = stackPopINT(pVM->pStack); 4546 p = ficlMalloc(size); 4547 stackPushPtr(pVM->pStack, p); 4548 if (p) 4549 stackPushINT(pVM->pStack, 0); 4550 else 4551 stackPushINT(pVM->pStack, 1); 4552} 4553 4554 4555static void ansFree(FICL_VM *pVM) 4556{ 4557 void *p; 4558 4559 p = stackPopPtr(pVM->pStack); 4560 ficlFree(p); 4561 stackPushINT(pVM->pStack, 0); 4562} 4563 4564 4565static void ansResize(FICL_VM *pVM) 4566{ 4567 size_t size; 4568 void *new, *old; 4569 4570 size = stackPopINT(pVM->pStack); 4571 old = stackPopPtr(pVM->pStack); 4572 new = ficlRealloc(old, size); 4573 if (new) 4574 { 4575 stackPushPtr(pVM->pStack, new); 4576 stackPushINT(pVM->pStack, 0); 4577 } 4578 else 4579 { 4580 stackPushPtr(pVM->pStack, old); 4581 stackPushINT(pVM->pStack, 1); 4582 } 4583} 4584 4585/* 4586** Retrieves free space remaining on the dictionary 4587*/ 4588 4589static void freeHeap(FICL_VM *pVM) 4590{ 4591 stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict())); 4592} 4593 4594/* 4595** exit-inner 4596** Signals execXT that an inner loop has completed 4597*/ 4598static void ficlExitInner(FICL_VM *pVM) 4599{ 4600 vmThrow(pVM, VM_INNEREXIT); 4601} 4602 4603 4604/************************************************************************** 4605 d n e g a t e 4606** DOUBLE ( d1 -- d2 ) 4607** d2 is the negation of d1. 4608**************************************************************************/ 4609static void dnegate(FICL_VM *pVM) 4610{ 4611 DPINT i = i64Pop(pVM->pStack); 4612 i = m64Negate(i); 4613 i64Push(pVM->pStack, i); 4614 4615 return; 4616} 4617 4618/******************* Increase dictionary size on-demand ******************/ 4619 4620static void ficlDictThreshold(FICL_VM *pVM) 4621{ 4622 stackPushPtr(pVM->pStack, &dictThreshold); 4623} 4624 4625static void ficlDictIncrease(FICL_VM *pVM) 4626{ 4627 stackPushPtr(pVM->pStack, &dictIncrease); 4628} 4629 4630/************************* freebsd added trace ***************************/ 4631 4632#ifdef FICL_TRACE 4633static void ficlTrace(FICL_VM *pVM) 4634{ 4635#if FICL_ROBUST > 1 4636 vmCheckStack(pVM, 1, 1); 4637#endif 4638 4639 ficl_trace = stackPopINT(pVM->pStack); 4640} 4641#endif 4642 4643/************************************************************************** 4644 f i c l C o m p i l e C o r e 4645** Builds the primitive wordset and the environment-query namespace. 4646**************************************************************************/ 4647 4648void ficlCompileCore(FICL_DICT *dp) 4649{ 4650 assert (dp); 4651 4652 /* 4653 ** CORE word set 4654 ** see softcore.c for definitions of: abs bl space spaces abort" 4655 */ 4656 pStore = 4657 dictAppendWord(dp, "!", store, FW_DEFAULT); 4658 dictAppendWord(dp, "#", numberSign, FW_DEFAULT); 4659 dictAppendWord(dp, "#>", numberSignGreater,FW_DEFAULT); 4660 dictAppendWord(dp, "#s", numberSignS, FW_DEFAULT); 4661 dictAppendWord(dp, "\'", tick, FW_DEFAULT); 4662 dictAppendWord(dp, "(", commentHang, FW_IMMEDIATE); 4663 dictAppendWord(dp, "*", mul, FW_DEFAULT); 4664 dictAppendWord(dp, "*/", mulDiv, FW_DEFAULT); 4665 dictAppendWord(dp, "*/mod", mulDivRem, FW_DEFAULT); 4666 dictAppendWord(dp, "+", add, FW_DEFAULT); 4667 dictAppendWord(dp, "+!", plusStore, FW_DEFAULT); 4668 dictAppendWord(dp, "+loop", plusLoopCoIm, FW_COMPIMMED); 4669 pComma = 4670 dictAppendWord(dp, ",", comma, FW_DEFAULT); 4671 dictAppendWord(dp, "-", sub, FW_DEFAULT); 4672 dictAppendWord(dp, ".", displayCell, FW_DEFAULT); 4673 dictAppendWord(dp, ".#", displayCellNoPad, FW_DEFAULT); 4674 dictAppendWord(dp, ".\"", dotQuoteCoIm, FW_COMPIMMED); 4675 dictAppendWord(dp, "/", ficlDiv, FW_DEFAULT); 4676 dictAppendWord(dp, "/mod", slashMod, FW_DEFAULT); 4677 dictAppendWord(dp, "0<", zeroLess, FW_DEFAULT); 4678 dictAppendWord(dp, "0=", zeroEquals, FW_DEFAULT); 4679 dictAppendWord(dp, "0>", zeroGreater, FW_DEFAULT); 4680 dictAppendWord(dp, "1+", onePlus, FW_DEFAULT); 4681 dictAppendWord(dp, "1-", oneMinus, FW_DEFAULT); 4682 dictAppendWord(dp, "2!", twoStore, FW_DEFAULT); 4683 dictAppendWord(dp, "2*", twoMul, FW_DEFAULT); 4684 dictAppendWord(dp, "2/", twoDiv, FW_DEFAULT); 4685 dictAppendWord(dp, "2@", twoFetch, FW_DEFAULT); 4686 dictAppendWord(dp, "2drop", twoDrop, FW_DEFAULT); 4687 dictAppendWord(dp, "2dup", twoDup, FW_DEFAULT); 4688 dictAppendWord(dp, "2over", twoOver, FW_DEFAULT); 4689 dictAppendWord(dp, "2swap", twoSwap, FW_DEFAULT); 4690 dictAppendWord(dp, ":", colon, FW_DEFAULT); 4691 dictAppendWord(dp, ";", semicolonCoIm, FW_COMPIMMED); 4692 dictAppendWord(dp, "<", isLess, FW_DEFAULT); 4693 dictAppendWord(dp, "<#", lessNumberSign, FW_DEFAULT); 4694 dictAppendWord(dp, "=", isEqual, FW_DEFAULT); 4695 dictAppendWord(dp, ">", isGreater, FW_DEFAULT); 4696 dictAppendWord(dp, ">body", toBody, FW_DEFAULT); 4697 dictAppendWord(dp, ">in", toIn, FW_DEFAULT); 4698 dictAppendWord(dp, ">number", toNumber, FW_DEFAULT); 4699 dictAppendWord(dp, ">r", toRStack, FW_DEFAULT); 4700 dictAppendWord(dp, "?dup", questionDup, FW_DEFAULT); 4701 dictAppendWord(dp, "@", fetch, FW_DEFAULT); 4702 dictAppendWord(dp, "abort", ficlAbort, FW_DEFAULT); 4703 dictAppendWord(dp, "accept", accept, FW_DEFAULT); 4704 dictAppendWord(dp, "align", align, FW_DEFAULT); 4705 dictAppendWord(dp, "aligned", aligned, FW_DEFAULT); 4706 dictAppendWord(dp, "allot", allot, FW_DEFAULT); 4707 dictAppendWord(dp, "and", bitwiseAnd, FW_DEFAULT); 4708 dictAppendWord(dp, "base", base, FW_DEFAULT); 4709 dictAppendWord(dp, "begin", beginCoIm, FW_COMPIMMED); 4710 dictAppendWord(dp, "c!", cStore, FW_DEFAULT); 4711 dictAppendWord(dp, "c,", cComma, FW_DEFAULT); 4712 dictAppendWord(dp, "c@", cFetch, FW_DEFAULT); 4713 dictAppendWord(dp, "cell+", cellPlus, FW_DEFAULT); 4714 dictAppendWord(dp, "cells", cells, FW_DEFAULT); 4715 dictAppendWord(dp, "char", ficlChar, FW_DEFAULT); 4716 dictAppendWord(dp, "char+", charPlus, FW_DEFAULT); 4717 dictAppendWord(dp, "chars", ficlChars, FW_DEFAULT); 4718 dictAppendWord(dp, "constant", constant, FW_DEFAULT); 4719 dictAppendWord(dp, "count", count, FW_DEFAULT); 4720 dictAppendWord(dp, "cr", cr, FW_DEFAULT); 4721 dictAppendWord(dp, "create", create, FW_DEFAULT); 4722 dictAppendWord(dp, "decimal", decimal, FW_DEFAULT); 4723 dictAppendWord(dp, "depth", depth, FW_DEFAULT); 4724 dictAppendWord(dp, "do", doCoIm, FW_COMPIMMED); 4725 dictAppendWord(dp, "does>", doesCoIm, FW_COMPIMMED); 4726 dictAppendWord(dp, "drop", drop, FW_DEFAULT); 4727 dictAppendWord(dp, "dup", dup, FW_DEFAULT); 4728 dictAppendWord(dp, "else", elseCoIm, FW_COMPIMMED); 4729 dictAppendWord(dp, "emit", emit, FW_DEFAULT); 4730 dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT); 4731 dictAppendWord(dp, "evaluate", evaluate, FW_DEFAULT); 4732 dictAppendWord(dp, "execute", execute, FW_DEFAULT); 4733 dictAppendWord(dp, "exit", exitCoIm, FW_COMPIMMED); 4734 dictAppendWord(dp, "fill", fill, FW_DEFAULT); 4735 dictAppendWord(dp, "find", find, FW_DEFAULT); 4736 dictAppendWord(dp, "fm/mod", fmSlashMod, FW_DEFAULT); 4737 dictAppendWord(dp, "here", here, FW_DEFAULT); 4738 dictAppendWord(dp, "hex", hex, FW_DEFAULT); 4739 dictAppendWord(dp, "hold", hold, FW_DEFAULT); 4740 dictAppendWord(dp, "i", loopICo, FW_COMPILE); 4741 dictAppendWord(dp, "if", ifCoIm, FW_COMPIMMED); 4742 dictAppendWord(dp, "immediate", immediate, FW_DEFAULT); 4743 dictAppendWord(dp, "invert", bitwiseNot, FW_DEFAULT); 4744 dictAppendWord(dp, "j", loopJCo, FW_COMPILE); 4745 dictAppendWord(dp, "k", loopKCo, FW_COMPILE); 4746 dictAppendWord(dp, "leave", leaveCo, FW_COMPILE); 4747 dictAppendWord(dp, "literal", literalIm, FW_IMMEDIATE); 4748 dictAppendWord(dp, "loop", loopCoIm, FW_COMPIMMED); 4749 dictAppendWord(dp, "lshift", lshift, FW_DEFAULT); 4750 dictAppendWord(dp, "m*", mStar, FW_DEFAULT); 4751 dictAppendWord(dp, "max", ficlMax, FW_DEFAULT); 4752 dictAppendWord(dp, "min", ficlMin, FW_DEFAULT); 4753 dictAppendWord(dp, "mod", ficlMod, FW_DEFAULT); 4754 dictAppendWord(dp, "move", move, FW_DEFAULT); 4755 dictAppendWord(dp, "negate", negate, FW_DEFAULT); 4756 dictAppendWord(dp, "or", bitwiseOr, FW_DEFAULT); 4757 dictAppendWord(dp, "over", over, FW_DEFAULT); 4758 dictAppendWord(dp, "postpone", postponeCoIm, FW_COMPIMMED); 4759 dictAppendWord(dp, "quit", quit, FW_DEFAULT); 4760 dictAppendWord(dp, "r>", fromRStack, FW_DEFAULT); 4761 dictAppendWord(dp, "r@", fetchRStack, FW_DEFAULT); 4762 dictAppendWord(dp, "recurse", recurseCoIm, FW_COMPIMMED); 4763 dictAppendWord(dp, "repeat", repeatCoIm, FW_COMPIMMED); 4764 dictAppendWord(dp, "rot", rot, FW_DEFAULT); 4765 dictAppendWord(dp, "rshift", rshift, FW_DEFAULT); 4766 dictAppendWord(dp, "s\"", stringQuoteIm, FW_IMMEDIATE); 4767 dictAppendWord(dp, "s>d", sToD, FW_DEFAULT); 4768 dictAppendWord(dp, "sign", sign, FW_DEFAULT); 4769 dictAppendWord(dp, "sm/rem", smSlashRem, FW_DEFAULT); 4770 dictAppendWord(dp, "source", source, FW_DEFAULT); 4771 dictAppendWord(dp, "state", state, FW_DEFAULT); 4772 dictAppendWord(dp, "swap", swap, FW_DEFAULT); 4773 dictAppendWord(dp, "then", endifCoIm, FW_COMPIMMED); 4774 pType = 4775 dictAppendWord(dp, "type", type, FW_DEFAULT); 4776 dictAppendWord(dp, "u.", uDot, FW_DEFAULT); 4777 dictAppendWord(dp, "u<", uIsLess, FW_DEFAULT); 4778 dictAppendWord(dp, "um*", umStar, FW_DEFAULT); 4779 dictAppendWord(dp, "um/mod", umSlashMod, FW_DEFAULT); 4780 dictAppendWord(dp, "unloop", unloopCo, FW_COMPILE); 4781 dictAppendWord(dp, "until", untilCoIm, FW_COMPIMMED); 4782 dictAppendWord(dp, "variable", variable, FW_DEFAULT); 4783 dictAppendWord(dp, "while", whileCoIm, FW_COMPIMMED); 4784 dictAppendWord(dp, "word", ficlWord, FW_DEFAULT); 4785 dictAppendWord(dp, "xor", bitwiseXor, FW_DEFAULT); 4786 dictAppendWord(dp, "[", lbracketCoIm, FW_COMPIMMED); 4787 dictAppendWord(dp, "[\']", bracketTickCoIm,FW_COMPIMMED); 4788 dictAppendWord(dp, "[char]", charCoIm, FW_COMPIMMED); 4789 dictAppendWord(dp, "]", rbracket, FW_DEFAULT); 4790 /* 4791 ** CORE EXT word set... 4792 ** see softcore.c for other definitions 4793 */ 4794 dictAppendWord(dp, ".(", dotParen, FW_DEFAULT); 4795 dictAppendWord(dp, ":noname", colonNoName, FW_DEFAULT); 4796 dictAppendWord(dp, "?do", qDoCoIm, FW_COMPIMMED); 4797 dictAppendWord(dp, "again", againCoIm, FW_COMPIMMED); 4798 dictAppendWord(dp, "parse", parse, FW_DEFAULT); 4799 dictAppendWord(dp, "pick", pick, FW_DEFAULT); 4800 dictAppendWord(dp, "roll", roll, FW_DEFAULT); 4801 dictAppendWord(dp, "refill", refill, FW_DEFAULT); 4802 dictAppendWord(dp, "source-id", sourceid, FW_DEFAULT); 4803 dictAppendWord(dp, "to", toValue, FW_IMMEDIATE); 4804 dictAppendWord(dp, "value", constant, FW_DEFAULT); 4805 dictAppendWord(dp, "\\", commentLine, FW_IMMEDIATE); 4806 4807 /* FreeBSD extension words */ 4808 dictAppendWord(dp, "fopen", pfopen, FW_DEFAULT); 4809 dictAppendWord(dp, "fclose", pfclose, FW_DEFAULT); 4810 dictAppendWord(dp, "fread", pfread, FW_DEFAULT); 4811 dictAppendWord(dp, "fload", pfload, FW_DEFAULT); 4812 dictAppendWord(dp, "fkey", fkey, FW_DEFAULT); 4813 dictAppendWord(dp, "key", key, FW_DEFAULT); 4814 dictAppendWord(dp, "key?", keyQuestion, FW_DEFAULT); 4815 dictAppendWord(dp, "ms", ms, FW_DEFAULT); 4816 dictAppendWord(dp, "seconds", pseconds, FW_DEFAULT); 4817 dictAppendWord(dp, "heap?", freeHeap, FW_DEFAULT); 4818 dictAppendWord(dp, "dictthreshold", ficlDictThreshold, FW_DEFAULT); 4819 dictAppendWord(dp, "dictincrease", ficlDictIncrease, FW_DEFAULT); 4820#ifdef FICL_TRACE 4821 dictAppendWord(dp, "trace!", ficlTrace, FW_DEFAULT); 4822#endif 4823 4824#ifndef TESTMAIN 4825#ifdef __i386__ 4826 dictAppendWord(dp, "outb", ficlOutb, FW_DEFAULT); 4827 dictAppendWord(dp, "inb", ficlInb, FW_DEFAULT); 4828#endif 4829 dictAppendWord(dp, "setenv", ficlSetenv, FW_DEFAULT); 4830 dictAppendWord(dp, "setenv?", ficlSetenvq, FW_DEFAULT); 4831 dictAppendWord(dp, "getenv", ficlGetenv, FW_DEFAULT); 4832 dictAppendWord(dp, "unsetenv", ficlUnsetenv, FW_DEFAULT); 4833 dictAppendWord(dp, "copyin", ficlCopyin, FW_DEFAULT); 4834 dictAppendWord(dp, "copyout", ficlCopyout, FW_DEFAULT); 4835 dictAppendWord(dp, "findfile", ficlFindfile, FW_DEFAULT); 4836 dictAppendWord(dp, "pnpdevices",ficlPnpdevices, FW_DEFAULT); 4837 dictAppendWord(dp, "pnphandlers",ficlPnphandlers, FW_DEFAULT); 4838 dictAppendWord(dp, "ccall", ficlCcall, FW_DEFAULT); 4839#endif 4840 4841#if defined(__i386__) 4842 ficlSetEnv("arch-i386", FICL_TRUE); 4843 ficlSetEnv("arch-alpha", FICL_FALSE); 4844#elif defined(__alpha__) 4845 ficlSetEnv("arch-i386", FICL_FALSE); 4846 ficlSetEnv("arch-alpha", FICL_TRUE); 4847#endif 4848 4849 /* 4850 ** Set CORE environment query values 4851 */ 4852 ficlSetEnv("/counted-string", FICL_STRING_MAX); 4853 ficlSetEnv("/hold", nPAD); 4854 ficlSetEnv("/pad", nPAD); 4855 ficlSetEnv("address-unit-bits", 8); 4856 ficlSetEnv("core", FICL_TRUE); 4857 ficlSetEnv("core-ext", FICL_FALSE); 4858 ficlSetEnv("floored", FICL_FALSE); 4859 ficlSetEnv("max-char", UCHAR_MAX); 4860 ficlSetEnvD("max-d", 0x7fffffff, 0xffffffff ); 4861 ficlSetEnv("max-n", 0x7fffffff); 4862 ficlSetEnv("max-u", 0xffffffff); 4863 ficlSetEnvD("max-ud", 0xffffffff, 0xffffffff); 4864 ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK); 4865 ficlSetEnv("stack-cells", FICL_DEFAULT_STACK); 4866 4867 /* 4868 ** DOUBLE word set (partial) 4869 */ 4870 dictAppendWord(dp, "2constant", twoConstant, FW_IMMEDIATE); 4871 dictAppendWord(dp, "2literal", twoLiteralIm, FW_IMMEDIATE); 4872 dictAppendWord(dp, "dnegate", dnegate, FW_DEFAULT); 4873 4874 4875 /* 4876 ** EXCEPTION word set 4877 */ 4878 dictAppendWord(dp, "catch", ficlCatch, FW_DEFAULT); 4879 dictAppendWord(dp, "throw", ficlThrow, FW_DEFAULT); 4880 4881 ficlSetEnv("exception", FICL_TRUE); 4882 ficlSetEnv("exception-ext", FICL_TRUE); 4883 4884 /* 4885 ** LOCAL and LOCAL EXT 4886 ** see softcore.c for implementation of locals| 4887 */ 4888#if FICL_WANT_LOCALS 4889 pLinkParen = 4890 dictAppendWord(dp, "(link)", linkParen, FW_COMPILE); 4891 pUnLinkParen = 4892 dictAppendWord(dp, "(unlink)", unlinkParen, FW_COMPILE); 4893 dictAppendWord(dp, "doLocal", doLocalIm, FW_COMPIMMED); 4894 pGetLocalParen = 4895 dictAppendWord(dp, "(@local)", getLocalParen, FW_COMPILE); 4896 pToLocalParen = 4897 dictAppendWord(dp, "(toLocal)", toLocalParen, FW_COMPILE); 4898 pGetLocal0 = 4899 dictAppendWord(dp, "(@local0)", getLocal0, FW_COMPILE); 4900 pToLocal0 = 4901 dictAppendWord(dp, "(toLocal0)",toLocal0, FW_COMPILE); 4902 pGetLocal1 = 4903 dictAppendWord(dp, "(@local1)", getLocal1, FW_COMPILE); 4904 pToLocal1 = 4905 dictAppendWord(dp, "(toLocal1)",toLocal1, FW_COMPILE); 4906 dictAppendWord(dp, "(local)", localParen, FW_COMPILE); 4907 4908 pGet2LocalParen = 4909 dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE); 4910 pTo2LocalParen = 4911 dictAppendWord(dp, "(to2Local)",to2LocalParen, FW_COMPILE); 4912 dictAppendWord(dp, "(2local)", twoLocalParen, FW_COMPILE); 4913 4914 ficlSetEnv("locals", FICL_TRUE); 4915 ficlSetEnv("locals-ext", FICL_TRUE); 4916 ficlSetEnv("#locals", FICL_MAX_LOCALS); 4917#endif 4918 4919 /* 4920 ** Optional MEMORY-ALLOC word set 4921 */ 4922 4923 dictAppendWord(dp, "allocate", ansAllocate, FW_DEFAULT); 4924 dictAppendWord(dp, "free", ansFree, FW_DEFAULT); 4925 dictAppendWord(dp, "resize", ansResize, FW_DEFAULT); 4926 4927 ficlSetEnv("memory-alloc", FICL_TRUE); 4928 ficlSetEnv("memory-alloc-ext", FICL_FALSE); 4929 4930 /* 4931 ** optional SEARCH-ORDER word set 4932 */ 4933 dictAppendWord(dp, ">search", searchPush, FW_DEFAULT); 4934 dictAppendWord(dp, "search>", searchPop, FW_DEFAULT); 4935 dictAppendWord(dp, "definitions", 4936 definitions, FW_DEFAULT); 4937 dictAppendWord(dp, "forth-wordlist", 4938 forthWordlist, FW_DEFAULT); 4939 dictAppendWord(dp, "get-current", 4940 getCurrent, FW_DEFAULT); 4941 dictAppendWord(dp, "get-order", getOrder, FW_DEFAULT); 4942 dictAppendWord(dp, "search-wordlist", 4943 searchWordlist, FW_DEFAULT); 4944 dictAppendWord(dp, "set-current", 4945 setCurrent, FW_DEFAULT); 4946 dictAppendWord(dp, "set-order", setOrder, FW_DEFAULT); 4947 dictAppendWord(dp, "ficl-wordlist", wordlist, FW_DEFAULT); 4948 4949 /* 4950 ** Set SEARCH environment query values 4951 */ 4952 ficlSetEnv("search-order", FICL_TRUE); 4953 ficlSetEnv("search-order-ext", FICL_TRUE); 4954 ficlSetEnv("wordlists", FICL_DEFAULT_VOCS); 4955 4956 /* 4957 ** TOOLS and TOOLS EXT 4958 */ 4959 dictAppendWord(dp, ".s", displayStack, FW_DEFAULT); 4960 dictAppendWord(dp, "bye", bye, FW_DEFAULT); 4961 dictAppendWord(dp, "forget", forget, FW_DEFAULT); 4962 dictAppendWord(dp, "see", see, FW_DEFAULT); 4963 dictAppendWord(dp, "words", listWords, FW_DEFAULT); 4964 4965 /* 4966 ** Set TOOLS environment query values 4967 */ 4968 ficlSetEnv("tools", FICL_TRUE); 4969 ficlSetEnv("tools-ext", FICL_FALSE); 4970 4971 /* 4972 ** Ficl extras 4973 */ 4974 dictAppendWord(dp, ".env", listEnv, FW_DEFAULT); 4975 dictAppendWord(dp, ".ver", ficlVersion, FW_DEFAULT); 4976 dictAppendWord(dp, "-roll", minusRoll, FW_DEFAULT); 4977 dictAppendWord(dp, ">name", toName, FW_DEFAULT); 4978 dictAppendWord(dp, "body>", fromBody, FW_DEFAULT); 4979 dictAppendWord(dp, "compare", compareString, FW_DEFAULT); /* STRING */ 4980 dictAppendWord(dp, "compile-only", 4981 compileOnly, FW_DEFAULT); 4982 dictAppendWord(dp, "endif", endifCoIm, FW_COMPIMMED); 4983 dictAppendWord(dp, "forget-wid",forgetWid, FW_DEFAULT); 4984 dictAppendWord(dp, "hash", hash, FW_DEFAULT); 4985 dictAppendWord(dp, "number?", ficlIsNum, FW_DEFAULT); 4986 dictAppendWord(dp, "parse-word",parseNoCopy, FW_DEFAULT); 4987 dictAppendWord(dp, "sliteral", sLiteralCoIm, FW_COMPIMMED); /* STRING */ 4988 dictAppendWord(dp, "wid-set-super", 4989 setParentWid, FW_DEFAULT); 4990 dictAppendWord(dp, "i@", iFetch, FW_DEFAULT); 4991 dictAppendWord(dp, "i!", iStore, FW_DEFAULT); 4992 dictAppendWord(dp, "w@", wFetch, FW_DEFAULT); 4993 dictAppendWord(dp, "w!", wStore, FW_DEFAULT); 4994 dictAppendWord(dp, "x.", hexDot, FW_DEFAULT); 4995#if FICL_WANT_USER 4996 dictAppendWord(dp, "(user)", userParen, FW_DEFAULT); 4997 dictAppendWord(dp, "user", userVariable, FW_DEFAULT); 4998#endif 4999 /* 5000 ** internal support words 5001 */ 5002 pExitParen = 5003 dictAppendWord(dp, "(exit)", exitParen, FW_COMPILE); 5004 pSemiParen = 5005 dictAppendWord(dp, "(;)", semiParen, FW_COMPILE); 5006 pLitParen = 5007 dictAppendWord(dp, "(literal)", literalParen, FW_COMPILE); 5008 pTwoLitParen = 5009 dictAppendWord(dp, "(2literal)",twoLitParen, FW_COMPILE); 5010 pStringLit = 5011 dictAppendWord(dp, "(.\")", stringLit, FW_COMPILE); 5012 pIfParen = 5013 dictAppendWord(dp, "(if)", ifParen, FW_COMPILE); 5014 pBranchParen = 5015 dictAppendWord(dp, "(branch)", branchParen, FW_COMPILE); 5016 pDoParen = 5017 dictAppendWord(dp, "(do)", doParen, FW_COMPILE); 5018 pDoesParen = 5019 dictAppendWord(dp, "(does>)", doesParen, FW_COMPILE); 5020 pQDoParen = 5021 dictAppendWord(dp, "(?do)", qDoParen, FW_COMPILE); 5022 pLoopParen = 5023 dictAppendWord(dp, "(loop)", loopParen, FW_COMPILE); 5024 pPLoopParen = 5025 dictAppendWord(dp, "(+loop)", plusLoopParen, FW_COMPILE); 5026 pInterpret = 5027 dictAppendWord(dp, "interpret", interpret, FW_DEFAULT); 5028 dictAppendWord(dp, "(variable)",variableParen, FW_COMPILE); 5029 dictAppendWord(dp, "(constant)",constantParen, FW_COMPILE); 5030 dictAppendWord(dp, "exit-inner",ficlExitInner, FW_DEFAULT); 5031 5032 assert(dictCellsAvail(dp) > 0); 5033 return; 5034} 5035 5036