sys/boot/ficl/words.c

   1 /*******************************************************************
   2 ** w o r d s . c
   3 ** Forth Inspired Command Language
   4 ** ANS Forth CORE word-set written in C
   5 ** Author: John Sadler (john_sadler@alum.mit.edu)
   6 ** Created: 19 July 1997
   7 **
   8 *******************************************************************/
   9
  10 /* $FreeBSD: src/sys/boot/ficl/words.c,v 1.23.2.2 2001/10/10 08:05:43 jkh Exp $ */
  11 /* $DragonFly: src/sys/boot/ficl/words.c,v 1.2 2003/06/17 04:28:17 dillon Exp $ */
  12
  13 #ifdef TESTMAIN
  14 #include <stdlib.h>
  15 #include <stdio.h>
  16 #include <ctype.h>
  17 #include <fcntl.h>
  18 #else
  19 #include <stand.h>
  20 #endif
  21 #include <string.h>
  22 #include "ficl.h"
  23 #include "math64.h"
  24
  25 static void colonParen(FICL_VM *pVM);
  26 static void literalIm(FICL_VM *pVM);
  27 static void interpWord(FICL_VM *pVM, STRINGINFO si);
  28
  29 /*
  30 ** Control structure building words use these
  31 ** strings' addresses as markers on the stack to
  32 ** check for structure completion.
  33 */
  34 static char doTag[]    = "do";
  35 static char colonTag[] = "colon";
  36 static char leaveTag[] = "leave";
  37
  38 static char destTag[]  = "target";
  39 static char origTag[]  = "origin";
  40
  41 /*
  42 ** Pointers to various words in the dictionary
  43 ** -- initialized by ficlCompileCore, below --
  44 ** for use by compiling words. Colon definitions
  45 ** in ficl are lists of pointers to words. A bit
  46 ** simple-minded...
  47 */
  48 static FICL_WORD *pBranchParen  = NULL;
  49 static FICL_WORD *pComma        = NULL;
  50 static FICL_WORD *pDoParen      = NULL;
  51 static FICL_WORD *pDoesParen    = NULL;
  52 static FICL_WORD *pExitParen    = NULL;
  53 static FICL_WORD *pIfParen      = NULL;
  54 static FICL_WORD *pInterpret    = NULL;
  55 static FICL_WORD *pLitParen     = NULL;
  56 static FICL_WORD *pTwoLitParen  = NULL;
  57 static FICL_WORD *pLoopParen    = NULL;
  58 static FICL_WORD *pPLoopParen   = NULL;
  59 static FICL_WORD *pQDoParen     = NULL;
  60 static FICL_WORD *pSemiParen    = NULL;
  61 static FICL_WORD *pStore        = NULL;
  62 static FICL_WORD *pStringLit    = NULL;
  63 static FICL_WORD *pType         = NULL;
  64
  65 #if FICL_WANT_LOCALS
  66 static FICL_WORD *pGetLocalParen= NULL;
  67 static FICL_WORD *pGet2LocalParen= NULL;
  68 static FICL_WORD *pGetLocal0    = NULL;
  69 static FICL_WORD *pGetLocal1    = NULL;
  70 static FICL_WORD *pToLocalParen = NULL;
  71 static FICL_WORD *pTo2LocalParen = NULL;
  72 static FICL_WORD *pToLocal0     = NULL;
  73 static FICL_WORD *pToLocal1     = NULL;
  74 static FICL_WORD *pLinkParen    = NULL;
  75 static FICL_WORD *pUnLinkParen  = NULL;
  76 static int nLocals = 0;
  77 static CELL *pMarkLocals = NULL;
  78
  79 static void doLocalIm(FICL_VM *pVM);
  80 static void do2LocalIm(FICL_VM *pVM);
  81
  82 #endif
  83
  84
  85 /*
  86 ** C O N T R O L   S T R U C T U R E   B U I L D E R S
  87 **
  88 ** Push current dict location for later branch resolution.
  89 ** The location may be either a branch target or a patch address...
  90 */
  91 static void markBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
  92 {
  93     stackPushPtr(pVM->pStack, dp->here);
  94     stackPushPtr(pVM->pStack, tag);
  95     return;
  96 }
  97
  98 static void markControlTag(FICL_VM *pVM, char *tag)
  99 {
 100     stackPushPtr(pVM->pStack, tag);
 101     return;
 102 }
 103
 104 static void matchControlTag(FICL_VM *pVM, char *tag)
 105 {
 106     char *cp = (char *)stackPopPtr(pVM->pStack);
 107     if ( strcmp(cp, tag) )
 108     {
 109         vmThrowErr(pVM, "Error -- unmatched control structure \"%s\"", tag);
 110     }
 111
 112     return;
 113 }
 114
 115 /*
 116 ** Expect a branch target address on the param stack,
 117 ** compile a literal offset from the current dict location
 118 ** to the target address
 119 */
 120 static void resolveBackBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
 121 {
 122     long offset;
 123     CELL *patchAddr;
 124
 125     matchControlTag(pVM, tag);
 126
 127     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
 128     offset = patchAddr - dp->here;
 129     dictAppendCell(dp, LVALUEtoCELL(offset));
 130
 131     return;
 132 }
 133
 134
 135 /*
 136 ** Expect a branch patch address on the param stack,
 137 ** compile a literal offset from the patch location
 138 ** to the current dict location
 139 */
 140 static void resolveForwardBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
 141 {
 142     long offset;
 143     CELL *patchAddr;
 144
 145     matchControlTag(pVM, tag);
 146
 147     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
 148     offset = dp->here - patchAddr;
 149     *patchAddr = LVALUEtoCELL(offset);
 150
 151     return;
 152 }
 153
 154 /*
 155 ** Match the tag to the top of the stack. If success,
 156 ** sopy "here" address into the cell whose address is next
 157 ** on the stack. Used by do..leave..loop.
 158 */
 159 static void resolveAbsBranch(FICL_DICT *dp, FICL_VM *pVM, char *tag)
 160 {
 161     CELL *patchAddr;
 162     char *cp;
 163
 164     cp = stackPopPtr(pVM->pStack);
 165     if (strcmp(cp, tag))
 166     {
 167         vmTextOut(pVM, "Warning -- Unmatched control word: ", 0);
 168         vmTextOut(pVM, tag, 1);
 169     }
 170
 171     patchAddr = (CELL *)stackPopPtr(pVM->pStack);
 172     *patchAddr = LVALUEtoCELL(dp->here);
 173
 174     return;
 175 }
 176
 177
 178 /**************************************************************************
 179                         i s N u m b e r
 180 ** Attempts to convert the NULL terminated string in the VM's pad to
 181 ** a number using the VM's current base. If successful, pushes the number
 182 ** onto the param stack and returns TRUE. Otherwise, returns FALSE.
 183 **************************************************************************/
 184
 185 static int isNumber(FICL_VM *pVM, STRINGINFO si)
 186 {
 187     FICL_INT accum     = 0;
 188     char isNeg      = FALSE;
 189     unsigned base   = pVM->base;
 190     char *cp        = SI_PTR(si);
 191     FICL_COUNT count= (FICL_COUNT)SI_COUNT(si);
 192     unsigned ch;
 193     unsigned digit;
 194
 195     if (*cp == '-')
 196     {
 197         cp++;
 198         count--;
 199         isNeg = TRUE;
 200     }
 201     else if ((cp[0] == '0') && (cp[1] == 'x'))
 202     {               /* detect 0xNNNN format for hex numbers */
 203         cp += 2;
 204         count -= 2;
 205         base = 16;
 206     }
 207
 208     if (count == 0)
 209         return FALSE;
 210
 211     while (count-- && ((ch = *cp++) != '\0'))
 212     {
 213         if (!(isdigit(ch)||isalpha(ch)))
 214             return FALSE;
 215
 216         digit = ch - '0';
 217
 218         if (digit > 9)
 219             digit = tolower(ch) - 'a' + 10;
 220
 221         if (digit >= base)
 222             return FALSE;
 223
 224         accum = accum * base + digit;
 225     }
 226
 227     if (isNeg)
 228         accum = -accum;
 229
 230     stackPushINT(pVM->pStack, accum);
 231
 232     return TRUE;
 233 }
 234
 235
 236 static void ficlIsNum(FICL_VM *pVM)
 237 {
 238         STRINGINFO si;
 239         FICL_INT ret;
 240
 241         SI_SETLEN(si, stackPopINT(pVM->pStack));
 242         SI_SETPTR(si, stackPopPtr(pVM->pStack));
 243         ret = isNumber(pVM, si) ? FICL_TRUE : FICL_FALSE;
 244         stackPushINT(pVM->pStack, ret);
 245         return;
 246 }
 247
 248 /**************************************************************************
 249                         a d d   &   f r i e n d s
 250 **
 251 **************************************************************************/
 252
 253 static void add(FICL_VM *pVM)
 254 {
 255     FICL_INT i;
 256 #if FICL_ROBUST > 1
 257     vmCheckStack(pVM, 2, 1);
 258 #endif
 259     i = stackPopINT(pVM->pStack);
 260     i += stackGetTop(pVM->pStack).i;
 261     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 262     return;
 263 }
 264
 265 static void sub(FICL_VM *pVM)
 266 {
 267     FICL_INT i;
 268 #if FICL_ROBUST > 1
 269     vmCheckStack(pVM, 2, 1);
 270 #endif
 271     i = stackPopINT(pVM->pStack);
 272     i = stackGetTop(pVM->pStack).i - i;
 273     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 274     return;
 275 }
 276
 277 static void mul(FICL_VM *pVM)
 278 {
 279     FICL_INT i;
 280 #if FICL_ROBUST > 1
 281     vmCheckStack(pVM, 2, 1);
 282 #endif
 283     i = stackPopINT(pVM->pStack);
 284     i *= stackGetTop(pVM->pStack).i;
 285     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 286     return;
 287 }
 288
 289 static void negate(FICL_VM *pVM)
 290 {
 291     FICL_INT i;
 292 #if FICL_ROBUST > 1
 293     vmCheckStack(pVM, 1, 1);
 294 #endif
 295     i = -stackPopINT(pVM->pStack);
 296     stackPushINT(pVM->pStack, i);
 297     return;
 298 }
 299
 300 static void ficlDiv(FICL_VM *pVM)
 301 {
 302     FICL_INT i;
 303 #if FICL_ROBUST > 1
 304     vmCheckStack(pVM, 2, 1);
 305 #endif
 306     i = stackPopINT(pVM->pStack);
 307     i = stackGetTop(pVM->pStack).i / i;
 308     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 309     return;
 310 }
 311
 312 /*
 313 ** slash-mod        CORE ( n1 n2 -- n3 n4 )
 314 ** Divide n1 by n2, giving the single-cell remainder n3 and the single-cell
 315 ** quotient n4. An ambiguous condition exists if n2 is zero. If n1 and n2
 316 ** differ in sign, the implementation-defined result returned will be the
 317 ** same as that returned by either the phrase
 318 ** >R S>D R> FM/MOD or the phrase >R S>D R> SM/REM .
 319 ** NOTE: Ficl complies with the second phrase (symmetric division)
 320 */
 321 static void slashMod(FICL_VM *pVM)
 322 {
 323     DPINT n1;
 324     FICL_INT n2;
 325     INTQR qr;
 326
 327 #if FICL_ROBUST > 1
 328     vmCheckStack(pVM, 2, 2);
 329 #endif
 330     n2    = stackPopINT(pVM->pStack);
 331     n1.lo = stackPopINT(pVM->pStack);
 332     i64Extend(n1);
 333
 334     qr = m64SymmetricDivI(n1, n2);
 335     stackPushINT(pVM->pStack, qr.rem);
 336     stackPushINT(pVM->pStack, qr.quot);
 337     return;
 338 }
 339
 340 static void onePlus(FICL_VM *pVM)
 341 {
 342     FICL_INT i;
 343 #if FICL_ROBUST > 1
 344     vmCheckStack(pVM, 1, 1);
 345 #endif
 346     i = stackGetTop(pVM->pStack).i;
 347     i += 1;
 348     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 349     return;
 350 }
 351
 352 static void oneMinus(FICL_VM *pVM)
 353 {
 354     FICL_INT i;
 355 #if FICL_ROBUST > 1
 356     vmCheckStack(pVM, 1, 1);
 357 #endif
 358     i = stackGetTop(pVM->pStack).i;
 359     i -= 1;
 360     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 361     return;
 362 }
 363
 364 static void twoMul(FICL_VM *pVM)
 365 {
 366     FICL_INT i;
 367 #if FICL_ROBUST > 1
 368     vmCheckStack(pVM, 1, 1);
 369 #endif
 370     i = stackGetTop(pVM->pStack).i;
 371     i *= 2;
 372     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 373     return;
 374 }
 375
 376 static void twoDiv(FICL_VM *pVM)
 377 {
 378     FICL_INT i;
 379 #if FICL_ROBUST > 1
 380     vmCheckStack(pVM, 1, 1);
 381 #endif
 382     i = stackGetTop(pVM->pStack).i;
 383     i >>= 1;
 384     stackSetTop(pVM->pStack, LVALUEtoCELL(i));
 385     return;
 386 }
 387
 388 static void mulDiv(FICL_VM *pVM)
 389 {
 390     FICL_INT x, y, z;
 391     DPINT prod;
 392 #if FICL_ROBUST > 1
 393     vmCheckStack(pVM, 3, 1);
 394 #endif
 395     z = stackPopINT(pVM->pStack);
 396     y = stackPopINT(pVM->pStack);
 397     x = stackPopINT(pVM->pStack);
 398
 399     prod = m64MulI(x,y);
 400     x    = m64SymmetricDivI(prod, z).quot;
 401
 402     stackPushINT(pVM->pStack, x);
 403     return;
 404 }
 405
 406
 407 static void mulDivRem(FICL_VM *pVM)
 408 {
 409     FICL_INT x, y, z;
 410     DPINT prod;
 411     INTQR qr;
 412 #if FICL_ROBUST > 1
 413     vmCheckStack(pVM, 3, 2);
 414 #endif
 415     z = stackPopINT(pVM->pStack);
 416     y = stackPopINT(pVM->pStack);
 417     x = stackPopINT(pVM->pStack);
 418
 419     prod = m64MulI(x,y);
 420     qr   = m64SymmetricDivI(prod, z);
 421
 422     stackPushINT(pVM->pStack, qr.rem);
 423     stackPushINT(pVM->pStack, qr.quot);
 424     return;
 425 }
 426
 427
 428 /**************************************************************************
 429                         b y e
 430 ** TOOLS
 431 ** Signal the system to shut down - this causes ficlExec to return
 432 ** VM_USEREXIT. The rest is up to you.
 433 **************************************************************************/
 434
 435 static void bye(FICL_VM *pVM)
 436 {
 437     vmThrow(pVM, VM_USEREXIT);
 438     return;
 439 }
 440
 441
 442 /**************************************************************************
 443                         c o l o n   d e f i n i t i o n s
 444 ** Code to begin compiling a colon definition
 445 ** This function sets the state to COMPILE, then creates a
 446 ** new word whose name is the next word in the input stream
 447 ** and whose code is colonParen.
 448 **************************************************************************/
 449
 450 static void colon(FICL_VM *pVM)
 451 {
 452     FICL_DICT *dp = ficlGetDict();
 453     STRINGINFO si = vmGetWord(pVM);
 454
 455     dictCheckThreshold(dp);
 456
 457     pVM->state = COMPILE;
 458     markControlTag(pVM, colonTag);
 459     dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
 460 #if FICL_WANT_LOCALS
 461     nLocals = 0;
 462 #endif
 463     return;
 464 }
 465
 466
 467 /**************************************************************************
 468                         c o l o n P a r e n
 469 ** This is the code that executes a colon definition. It assumes that the
 470 ** virtual machine is running a "next" loop (See the vm.c
 471 ** for its implementation of member function vmExecute()). The colon
 472 ** code simply copies the address of the first word in the list of words
 473 ** to interpret into IP after saving its old value. When we return to the
 474 ** "next" loop, the virtual machine will call the code for each word in
 475 ** turn.
 476 **
 477 **************************************************************************/
 478
 479 static void colonParen(FICL_VM *pVM)
 480 {
 481     IPTYPE tempIP = (IPTYPE) (pVM->runningWord->param);
 482     vmPushIP(pVM, tempIP);
 483
 484     return;
 485 }
 486
 487
 488 /**************************************************************************
 489                         s e m i c o l o n C o I m
 490 **
 491 ** IMMEDIATE code for ";". This function sets the state to INTERPRET and
 492 ** terminates a word under compilation by appending code for "(;)" to
 493 ** the definition. TO DO: checks for leftover branch target tags on the
 494 ** return stack and complains if any are found.
 495 **************************************************************************/
 496 static void semiParen(FICL_VM *pVM)
 497 {
 498     vmPopIP(pVM);
 499     return;
 500 }
 501
 502
 503 static void semicolonCoIm(FICL_VM *pVM)
 504 {
 505     FICL_DICT *dp = ficlGetDict();
 506
 507     assert(pSemiParen);
 508     matchControlTag(pVM, colonTag);
 509
 510 #if FICL_WANT_LOCALS
 511     assert(pUnLinkParen);
 512     if (nLocals > 0)
 513     {
 514         FICL_DICT *pLoc = ficlGetLoc();
 515         dictEmpty(pLoc, pLoc->pForthWords->size);
 516         dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
 517     }
 518     nLocals = 0;
 519 #endif
 520
 521     dictAppendCell(dp, LVALUEtoCELL(pSemiParen));
 522     pVM->state = INTERPRET;
 523     dictUnsmudge(dp);
 524     return;
 525 }
 526
 527
 528 /**************************************************************************
 529                         e x i t
 530 ** CORE
 531 ** This function simply pops the previous instruction
 532 ** pointer and returns to the "next" loop. Used for exiting from within
 533 ** a definition. Note that exitParen is identical to semiParen - they
 534 ** are in two different functions so that "see" can correctly identify
 535 ** the end of a colon definition, even if it uses "exit".
 536 **************************************************************************/
 537 static void exitParen(FICL_VM *pVM)
 538 {
 539     vmPopIP(pVM);
 540     return;
 541 }
 542
 543 static void exitCoIm(FICL_VM *pVM)
 544 {
 545     FICL_DICT *dp = ficlGetDict();
 546     assert(pExitParen);
 547     IGNORE(pVM);
 548
 549 #if FICL_WANT_LOCALS
 550     if (nLocals > 0)
 551     {
 552         dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
 553     }
 554 #endif
 555     dictAppendCell(dp, LVALUEtoCELL(pExitParen));
 556     return;
 557 }
 558
 559
 560 /**************************************************************************
 561                         c o n s t a n t P a r e n
 562 ** This is the run-time code for "constant". It simply returns the
 563 ** contents of its word's first data cell.
 564 **
 565 **************************************************************************/
 566
 567 void constantParen(FICL_VM *pVM)
 568 {
 569     FICL_WORD *pFW = pVM->runningWord;
 570 #if FICL_ROBUST > 1
 571     vmCheckStack(pVM, 0, 1);
 572 #endif
 573     stackPush(pVM->pStack, pFW->param[0]);
 574     return;
 575 }
 576
 577 void twoConstParen(FICL_VM *pVM)
 578 {
 579     FICL_WORD *pFW = pVM->runningWord;
 580 #if FICL_ROBUST > 1
 581     vmCheckStack(pVM, 0, 2);
 582 #endif
 583     stackPush(pVM->pStack, pFW->param[0]); /* lo */
 584     stackPush(pVM->pStack, pFW->param[1]); /* hi */
 585     return;
 586 }
 587
 588
 589 /**************************************************************************
 590                         c o n s t a n t
 591 ** IMMEDIATE
 592 ** Compiles a constant into the dictionary. Constants return their
 593 ** value when invoked. Expects a value on top of the parm stack.
 594 **************************************************************************/
 595
 596 static void constant(FICL_VM *pVM)
 597 {
 598     FICL_DICT *dp = ficlGetDict();
 599     STRINGINFO si = vmGetWord(pVM);
 600
 601 #if FICL_ROBUST > 1
 602     vmCheckStack(pVM, 1, 0);
 603 #endif
 604     dictAppendWord2(dp, si, constantParen, FW_DEFAULT);
 605     dictAppendCell(dp, stackPop(pVM->pStack));
 606     return;
 607 }
 608
 609
 610 static void twoConstant(FICL_VM *pVM)
 611 {
 612     FICL_DICT *dp = ficlGetDict();
 613     STRINGINFO si = vmGetWord(pVM);
 614     CELL c;
 615
 616 #if FICL_ROBUST > 1
 617     vmCheckStack(pVM, 2, 0);
 618 #endif
 619     c = stackPop(pVM->pStack);
 620     dictAppendWord2(dp, si, twoConstParen, FW_DEFAULT);
 621     dictAppendCell(dp, stackPop(pVM->pStack));
 622     dictAppendCell(dp, c);
 623     return;
 624 }
 625
 626
 627 /**************************************************************************
 628                         d i s p l a y C e l l
 629 ** Drop and print the contents of the cell at the top of the param
 630 ** stack
 631 **************************************************************************/
 632
 633 static void displayCell(FICL_VM *pVM)
 634 {
 635     CELL c;
 636 #if FICL_ROBUST > 1
 637     vmCheckStack(pVM, 1, 0);
 638 #endif
 639     c = stackPop(pVM->pStack);
 640     ltoa((c).i, pVM->pad, pVM->base);
 641     strcat(pVM->pad, " ");
 642     vmTextOut(pVM, pVM->pad, 0);
 643     return;
 644 }
 645
 646 static void displayCellNoPad(FICL_VM *pVM)
 647 {
 648     CELL c;
 649 #if FICL_ROBUST > 1
 650     vmCheckStack(pVM, 1, 0);
 651 #endif
 652     c = stackPop(pVM->pStack);
 653     ltoa((c).i, pVM->pad, pVM->base);
 654     vmTextOut(pVM, pVM->pad, 0);
 655     return;
 656 }
 657
 658 static void uDot(FICL_VM *pVM)
 659 {
 660     FICL_UNS u;
 661 #if FICL_ROBUST > 1
 662     vmCheckStack(pVM, 1, 0);
 663 #endif
 664     u = stackPopUNS(pVM->pStack);
 665     ultoa(u, pVM->pad, pVM->base);
 666     strcat(pVM->pad, " ");
 667     vmTextOut(pVM, pVM->pad, 0);
 668     return;
 669 }
 670
 671
 672 static void hexDot(FICL_VM *pVM)
 673 {
 674     FICL_UNS u;
 675 #if FICL_ROBUST > 1
 676     vmCheckStack(pVM, 1, 0);
 677 #endif
 678     u = stackPopUNS(pVM->pStack);
 679     ultoa(u, pVM->pad, 16);
 680     strcat(pVM->pad, " ");
 681     vmTextOut(pVM, pVM->pad, 0);
 682     return;
 683 }
 684
 685
 686 /**************************************************************************
 687                         d i s p l a y S t a c k
 688 ** Display the parameter stack (code for ".s")
 689 **************************************************************************/
 690
 691 static void displayStack(FICL_VM *pVM)
 692 {
 693     int d = stackDepth(pVM->pStack);
 694     int i;
 695     CELL *pCell;
 696
 697     vmCheckStack(pVM, 0, 0);
 698
 699     if (d == 0)
 700         vmTextOut(pVM, "(Stack Empty)", 1);
 701     else
 702     {
 703         pCell = pVM->pStack->sp;
 704         for (i = 0; i < d; i++)
 705         {
 706             vmTextOut(pVM, ltoa((*--pCell).i, pVM->pad, pVM->base), 1);
 707         }
 708     }
 709 }
 710
 711
 712 /**************************************************************************
 713                         d u p   &   f r i e n d s
 714 **
 715 **************************************************************************/
 716
 717 static void depth(FICL_VM *pVM)
 718 {
 719     int i;
 720 #if FICL_ROBUST > 1
 721     vmCheckStack(pVM, 0, 1);
 722 #endif
 723     i = stackDepth(pVM->pStack);
 724     stackPushINT(pVM->pStack, i);
 725     return;
 726 }
 727
 728
 729 static void drop(FICL_VM *pVM)
 730 {
 731 #if FICL_ROBUST > 1
 732     vmCheckStack(pVM, 1, 0);
 733 #endif
 734     stackDrop(pVM->pStack, 1);
 735     return;
 736 }
 737
 738
 739 static void twoDrop(FICL_VM *pVM)
 740 {
 741 #if FICL_ROBUST > 1
 742     vmCheckStack(pVM, 2, 0);
 743 #endif
 744     stackDrop(pVM->pStack, 2);
 745     return;
 746 }
 747
 748
 749 static void dup(FICL_VM *pVM)
 750 {
 751 #if FICL_ROBUST > 1
 752     vmCheckStack(pVM, 1, 2);
 753 #endif
 754     stackPick(pVM->pStack, 0);
 755     return;
 756 }
 757
 758
 759 static void twoDup(FICL_VM *pVM)
 760 {
 761 #if FICL_ROBUST > 1
 762     vmCheckStack(pVM, 2, 4);
 763 #endif
 764     stackPick(pVM->pStack, 1);
 765     stackPick(pVM->pStack, 1);
 766     return;
 767 }
 768
 769
 770 static void over(FICL_VM *pVM)
 771 {
 772 #if FICL_ROBUST > 1
 773     vmCheckStack(pVM, 2, 3);
 774 #endif
 775     stackPick(pVM->pStack, 1);
 776     return;
 777 }
 778
 779 static void twoOver(FICL_VM *pVM)
 780 {
 781 #if FICL_ROBUST > 1
 782     vmCheckStack(pVM, 4, 6);
 783 #endif
 784     stackPick(pVM->pStack, 3);
 785     stackPick(pVM->pStack, 3);
 786     return;
 787 }
 788
 789
 790 static void pick(FICL_VM *pVM)
 791 {
 792     CELL c = stackPop(pVM->pStack);
 793 #if FICL_ROBUST > 1
 794     vmCheckStack(pVM, c.i+1, c.i+2);
 795 #endif
 796     stackPick(pVM->pStack, c.i);
 797     return;
 798 }
 799
 800
 801 static void questionDup(FICL_VM *pVM)
 802 {
 803     CELL c;
 804 #if FICL_ROBUST > 1
 805     vmCheckStack(pVM, 1, 2);
 806 #endif
 807     c = stackGetTop(pVM->pStack);
 808
 809     if (c.i != 0)
 810         stackPick(pVM->pStack, 0);
 811
 812     return;
 813 }
 814
 815
 816 static void roll(FICL_VM *pVM)
 817 {
 818     int i = stackPop(pVM->pStack).i;
 819     i = (i > 0) ? i : 0;
 820 #if FICL_ROBUST > 1
 821     vmCheckStack(pVM, i+1, i+1);
 822 #endif
 823     stackRoll(pVM->pStack, i);
 824     return;
 825 }
 826
 827
 828 static void minusRoll(FICL_VM *pVM)
 829 {
 830     int i = stackPop(pVM->pStack).i;
 831     i = (i > 0) ? i : 0;
 832 #if FICL_ROBUST > 1
 833     vmCheckStack(pVM, i+1, i+1);
 834 #endif
 835     stackRoll(pVM->pStack, -i);
 836     return;
 837 }
 838
 839
 840 static void rot(FICL_VM *pVM)
 841 {
 842 #if FICL_ROBUST > 1
 843     vmCheckStack(pVM, 3, 3);
 844 #endif
 845     stackRoll(pVM->pStack, 2);
 846     return;
 847 }
 848
 849
 850 static void swap(FICL_VM *pVM)
 851 {
 852 #if FICL_ROBUST > 1
 853     vmCheckStack(pVM, 2, 2);
 854 #endif
 855     stackRoll(pVM->pStack, 1);
 856     return;
 857 }
 858
 859
 860 static void twoSwap(FICL_VM *pVM)
 861 {
 862 #if FICL_ROBUST > 1
 863     vmCheckStack(pVM, 4, 4);
 864 #endif
 865     stackRoll(pVM->pStack, 3);
 866     stackRoll(pVM->pStack, 3);
 867     return;
 868 }
 869
 870
 871 /**************************************************************************
 872                         e m i t   &   f r i e n d s
 873 **
 874 **************************************************************************/
 875
 876 static void emit(FICL_VM *pVM)
 877 {
 878     char *cp = pVM->pad;
 879     int i;
 880
 881 #if FICL_ROBUST > 1
 882     vmCheckStack(pVM, 1, 0);
 883 #endif
 884     i = stackPopINT(pVM->pStack);
 885     cp[0] = (char)i;
 886     cp[1] = '\0';
 887     vmTextOut(pVM, cp, 0);
 888     return;
 889 }
 890
 891
 892 static void cr(FICL_VM *pVM)
 893 {
 894     vmTextOut(pVM, "", 1);
 895     return;
 896 }
 897
 898
 899 static void commentLine(FICL_VM *pVM)
 900 {
 901     char *cp        = vmGetInBuf(pVM);
 902     char *pEnd      = vmGetInBufEnd(pVM);
 903     char ch = *cp;
 904
 905     while ((cp != pEnd) && (ch != '\r') && (ch != '\n'))
 906     {
 907         ch = *++cp;
 908     }
 909
 910     /*
 911     ** Cope with DOS or UNIX-style EOLs -
 912     ** Check for /r, /n, /r/n, or /n/r end-of-line sequences,
 913     ** and point cp to next char. If EOL is \0, we're done.
 914     */
 915     if (cp != pEnd)
 916     {
 917         cp++;
 918
 919         if ( (cp != pEnd) && (ch != *cp)
 920              && ((*cp == '\r') || (*cp == '\n')) )
 921             cp++;
 922     }
 923
 924     vmUpdateTib(pVM, cp);
 925     return;
 926 }
 927
 928
 929 /*
 930 ** paren CORE
 931 ** Compilation: Perform the execution semantics given below.
 932 ** Execution: ( "ccc<paren>" -- )
 933 ** Parse ccc delimited by ) (right parenthesis). ( is an immediate word.
 934 ** The number of characters in ccc may be zero to the number of characters
 935 ** in the parse area.
 936 **
 937 */
 938 static void commentHang(FICL_VM *pVM)
 939 {
 940     vmParseStringEx(pVM, ')', 0);
 941     return;
 942 }
 943
 944
 945 /**************************************************************************
 946                         F E T C H   &   S T O R E
 947 **
 948 **************************************************************************/
 949
 950 static void fetch(FICL_VM *pVM)
 951 {
 952     CELL *pCell;
 953 #if FICL_ROBUST > 1
 954     vmCheckStack(pVM, 1, 1);
 955 #endif
 956     pCell = (CELL *)stackPopPtr(pVM->pStack);
 957     stackPush(pVM->pStack, *pCell);
 958     return;
 959 }
 960
 961 /*
 962 ** two-fetch    CORE ( a-addr -- x1 x2 )
 963 ** Fetch the cell pair x1 x2 stored at a-addr. x2 is stored at a-addr and
 964 ** x1 at the next consecutive cell. It is equivalent to the sequence
 965 ** DUP CELL+ @ SWAP @ .
 966 */
 967 static void twoFetch(FICL_VM *pVM)
 968 {
 969     CELL *pCell;
 970 #if FICL_ROBUST > 1
 971     vmCheckStack(pVM, 1, 2);
 972 #endif
 973     pCell = (CELL *)stackPopPtr(pVM->pStack);
 974     stackPush(pVM->pStack, *pCell++);
 975     stackPush(pVM->pStack, *pCell);
 976     swap(pVM);
 977     return;
 978 }
 979
 980 /*
 981 ** store        CORE ( x a-addr -- )
 982 ** Store x at a-addr.
 983 */
 984 static void store(FICL_VM *pVM)
 985 {
 986     CELL *pCell;
 987 #if FICL_ROBUST > 1
 988     vmCheckStack(pVM, 2, 0);
 989 #endif
 990     pCell = (CELL *)stackPopPtr(pVM->pStack);
 991     *pCell = stackPop(pVM->pStack);
 992 }
 993
 994 /*
 995 ** two-store    CORE ( x1 x2 a-addr -- )
 996 ** Store the cell pair x1 x2 at a-addr, with x2 at a-addr and x1 at the
 997 ** next consecutive cell. It is equivalent to the sequence
 998 ** SWAP OVER ! CELL+ ! .
 999 */
1000 static void twoStore(FICL_VM *pVM)
1001 {
1002     CELL *pCell;
1003 #if FICL_ROBUST > 1
1004     vmCheckStack(pVM, 3, 0);
1005 #endif
1006     pCell = (CELL *)stackPopPtr(pVM->pStack);
1007     *pCell++    = stackPop(pVM->pStack);
1008     *pCell      = stackPop(pVM->pStack);
1009 }
1010
1011 static void plusStore(FICL_VM *pVM)
1012 {
1013     CELL *pCell;
1014 #if FICL_ROBUST > 1
1015     vmCheckStack(pVM, 2, 0);
1016 #endif
1017     pCell = (CELL *)stackPopPtr(pVM->pStack);
1018     pCell->i += stackPop(pVM->pStack).i;
1019 }
1020
1021
1022 static void iFetch(FICL_VM *pVM)
1023 {
1024     UNS32 *pw;
1025 #if FICL_ROBUST > 1
1026     vmCheckStack(pVM, 1, 1);
1027 #endif
1028     pw = (UNS32 *)stackPopPtr(pVM->pStack);
1029     stackPushUNS(pVM->pStack, (FICL_UNS)*pw);
1030     return;
1031 }
1032
1033 static void iStore(FICL_VM *pVM)
1034 {
1035     UNS32 *pw;
1036 #if FICL_ROBUST > 1
1037     vmCheckStack(pVM, 2, 0);
1038 #endif
1039     pw = (UNS32 *)stackPopPtr(pVM->pStack);
1040     *pw = (UNS32)(stackPop(pVM->pStack).u);
1041 }
1042
1043 static void wFetch(FICL_VM *pVM)
1044 {
1045     UNS16 *pw;
1046 #if FICL_ROBUST > 1
1047     vmCheckStack(pVM, 1, 1);
1048 #endif
1049     pw = (UNS16 *)stackPopPtr(pVM->pStack);
1050     stackPushUNS(pVM->pStack, (FICL_UNS)*pw);
1051     return;
1052 }
1053
1054 static void wStore(FICL_VM *pVM)
1055 {
1056     UNS16 *pw;
1057 #if FICL_ROBUST > 1
1058     vmCheckStack(pVM, 2, 0);
1059 #endif
1060     pw = (UNS16 *)stackPopPtr(pVM->pStack);
1061     *pw = (UNS16)(stackPop(pVM->pStack).u);
1062 }
1063
1064 static void cFetch(FICL_VM *pVM)
1065 {
1066     UNS8 *pc;
1067 #if FICL_ROBUST > 1
1068     vmCheckStack(pVM, 1, 1);
1069 #endif
1070     pc = (UNS8 *)stackPopPtr(pVM->pStack);
1071     stackPushUNS(pVM->pStack, (FICL_UNS)*pc);
1072     return;
1073 }
1074
1075 static void cStore(FICL_VM *pVM)
1076 {
1077     UNS8 *pc;
1078 #if FICL_ROBUST > 1
1079     vmCheckStack(pVM, 2, 0);
1080 #endif
1081     pc = (UNS8 *)stackPopPtr(pVM->pStack);
1082     *pc = (UNS8)(stackPop(pVM->pStack).u);
1083 }
1084
1085
1086 /**************************************************************************
1087                         i f C o I m
1088 ** IMMEDIATE
1089 ** Compiles code for a conditional branch into the dictionary
1090 ** and pushes the branch patch address on the stack for later
1091 ** patching by ELSE or THEN/ENDIF.
1092 **************************************************************************/
1093
1094 static void ifCoIm(FICL_VM *pVM)
1095 {
1096     FICL_DICT *dp = ficlGetDict();
1097
1098     assert(pIfParen);
1099
1100     dictAppendCell(dp, LVALUEtoCELL(pIfParen));
1101     markBranch(dp, pVM, origTag);
1102     dictAppendUNS(dp, 1);
1103     return;
1104 }
1105
1106
1107 /**************************************************************************
1108                         i f P a r e n
1109 ** Runtime code to do "if" or "until": pop a flag from the stack,
1110 ** fall through if true, branch if false. Probably ought to be
1111 ** called (not?branch) since it does "branch if false".
1112 **************************************************************************/
1113
1114 static void ifParen(FICL_VM *pVM)
1115 {
1116     FICL_UNS flag;
1117
1118 #if FICL_ROBUST > 1
1119     vmCheckStack(pVM, 1, 0);
1120 #endif
1121     flag = stackPopUNS(pVM->pStack);
1122
1123     if (flag)
1124     {                           /* fall through */
1125         vmBranchRelative(pVM, 1);
1126     }
1127     else
1128     {                           /* take branch (to else/endif/begin) */
1129         vmBranchRelative(pVM, *(int*)(pVM->ip));
1130     }
1131
1132     return;
1133 }
1134
1135
1136 /**************************************************************************
1137                         e l s e C o I m
1138 **
1139 ** IMMEDIATE -- compiles an "else"...
1140 ** 1) Compile a branch and a patch address; the address gets patched
1141 **    by "endif" to point past the "else" code.
1142 ** 2) Pop the the "if" patch address
1143 ** 3) Patch the "if" branch to point to the current compile address.
1144 ** 4) Push the "else" patch address. ("endif" patches this to jump past
1145 **    the "else" code.
1146 **************************************************************************/
1147
1148 static void elseCoIm(FICL_VM *pVM)
1149 {
1150     CELL *patchAddr;
1151     int offset;
1152     FICL_DICT *dp = ficlGetDict();
1153
1154     assert(pBranchParen);
1155                                             /* (1) compile branch runtime */
1156     dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
1157     matchControlTag(pVM, origTag);
1158     patchAddr =
1159         (CELL *)stackPopPtr(pVM->pStack);   /* (2) pop "if" patch addr */
1160     markBranch(dp, pVM, origTag);           /* (4) push "else" patch addr */
1161     dictAppendUNS(dp, 1);                 /* (1) compile patch placeholder */
1162     offset = dp->here - patchAddr;
1163     *patchAddr = LVALUEtoCELL(offset);      /* (3) Patch "if" */
1164
1165     return;
1166 }
1167
1168
1169 /**************************************************************************
1170                         b r a n c h P a r e n
1171 **
1172 ** Runtime for "(branch)" -- expects a literal offset in the next
1173 ** compilation address, and branches to that location.
1174 **************************************************************************/
1175
1176 static void branchParen(FICL_VM *pVM)
1177 {
1178     vmBranchRelative(pVM, *(int *)(pVM->ip));
1179     return;
1180 }
1181
1182
1183 /**************************************************************************
1184                         e n d i f C o I m
1185 **
1186 **************************************************************************/
1187
1188 static void endifCoIm(FICL_VM *pVM)
1189 {
1190     FICL_DICT *dp = ficlGetDict();
1191     resolveForwardBranch(dp, pVM, origTag);
1192     return;
1193 }
1194
1195
1196 /**************************************************************************
1197                         h a s h
1198 ** hash ( c-addr u -- code)
1199 ** calculates hashcode of specified string and leaves it on the stack
1200 **************************************************************************/
1201
1202 static void hash(FICL_VM *pVM)
1203 {
1204         STRINGINFO si;
1205         SI_SETLEN(si, stackPopUNS(pVM->pStack));
1206         SI_SETPTR(si, stackPopPtr(pVM->pStack));
1207         stackPushUNS(pVM->pStack, hashHashCode(si));
1208     return;
1209 }
1210
1211
1212 /**************************************************************************
1213                         i n t e r p r e t
1214 ** This is the "user interface" of a Forth. It does the following:
1215 **   while there are words in the VM's Text Input Buffer
1216 **     Copy next word into the pad (vmGetWord)
1217 **     Attempt to find the word in the dictionary (dictLookup)
1218 **     If successful, execute the word.
1219 **     Otherwise, attempt to convert the word to a number (isNumber)
1220 **     If successful, push the number onto the parameter stack.
1221 **     Otherwise, print an error message and exit loop...
1222 **   End Loop
1223 **
1224 ** From the standard, section 3.4
1225 ** Text interpretation (see 6.1.1360 EVALUATE and 6.1.2050 QUIT) shall
1226 ** repeat the following steps until either the parse area is empty or an
1227 ** ambiguous condition exists:
1228 ** a) Skip leading spaces and parse a name (see 3.4.1);
1229 **************************************************************************/
1230
1231 static void interpret(FICL_VM *pVM)
1232 {
1233     STRINGINFO si = vmGetWord0(pVM);
1234     assert(pVM);
1235
1236     vmBranchRelative(pVM, -1);
1237
1238     /*
1239     ** Get next word...if out of text, we're done.
1240     */
1241     if (si.count == 0)
1242     {
1243         vmThrow(pVM, VM_OUTOFTEXT);
1244     }
1245
1246     interpWord(pVM, si);
1247
1248
1249     return;                 /* back to inner interpreter */
1250 }
1251
1252 /**************************************************************************
1253 ** From the standard, section 3.4
1254 ** b) Search the dictionary name space (see 3.4.2). If a definition name
1255 ** matching the string is found:
1256 **  1.if interpreting, perform the interpretation semantics of the definition
1257 **  (see 3.4.3.2), and continue at a);
1258 **  2.if compiling, perform the compilation semantics of the definition
1259 **  (see 3.4.3.3), and continue at a).
1260 **
1261 ** c) If a definition name matching the string is not found, attempt to
1262 ** convert the string to a number (see 3.4.1.3). If successful:
1263 **  1.if interpreting, place the number on the data stack, and continue at a);
1264 **  2.if compiling, compile code that when executed will place the number on
1265 **  the stack (see 6.1.1780 LITERAL), and continue at a);
1266 **
1267 ** d) If unsuccessful, an ambiguous condition exists (see 3.4.4).
1268 **************************************************************************/
1269 static void interpWord(FICL_VM *pVM, STRINGINFO si)
1270 {
1271     FICL_DICT *dp = ficlGetDict();
1272     FICL_WORD *tempFW;
1273
1274 #if FICL_ROBUST
1275     dictCheck(dp, pVM, 0);
1276     vmCheckStack(pVM, 0, 0);
1277 #endif
1278
1279 #if FICL_WANT_LOCALS
1280     if (nLocals > 0)
1281     {
1282         tempFW = dictLookupLoc(dp, si);
1283     }
1284     else
1285 #endif
1286     tempFW = dictLookup(dp, si);
1287
1288     if (pVM->state == INTERPRET)
1289     {
1290         if (tempFW != NULL)
1291         {
1292             if (wordIsCompileOnly(tempFW))
1293             {
1294                 vmThrowErr(pVM, "Error: Compile only!");
1295             }
1296
1297             vmExecute(pVM, tempFW);
1298         }
1299
1300         else if (!isNumber(pVM, si))
1301         {
1302             int i = SI_COUNT(si);
1303             vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1304         }
1305     }
1306
1307     else /* (pVM->state == COMPILE) */
1308     {
1309         if (tempFW != NULL)
1310         {
1311             if (wordIsImmediate(tempFW))
1312             {
1313                 vmExecute(pVM, tempFW);
1314             }
1315             else
1316             {
1317                 dictAppendCell(dp, LVALUEtoCELL(tempFW));
1318             }
1319         }
1320         else if (isNumber(pVM, si))
1321         {
1322             literalIm(pVM);
1323         }
1324         else
1325         {
1326             int i = SI_COUNT(si);
1327             vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
1328         }
1329     }
1330
1331     return;
1332 }
1333
1334
1335 /**************************************************************************
1336                         l i t e r a l P a r e n
1337 **
1338 ** This is the runtime for (literal). It assumes that it is part of a colon
1339 ** definition, and that the next CELL contains a value to be pushed on the
1340 ** parameter stack at runtime. This code is compiled by "literal".
1341 **
1342 **************************************************************************/
1343
1344 static void literalParen(FICL_VM *pVM)
1345 {
1346 #if FICL_ROBUST > 1
1347     vmCheckStack(pVM, 0, 1);
1348 #endif
1349     stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip));
1350     vmBranchRelative(pVM, 1);
1351     return;
1352 }
1353
1354 static void twoLitParen(FICL_VM *pVM)
1355 {
1356 #if FICL_ROBUST > 1
1357     vmCheckStack(pVM, 0, 2);
1358 #endif
1359     stackPushINT(pVM->pStack, *((FICL_INT *)(pVM->ip)+1));
1360     stackPushINT(pVM->pStack, *(FICL_INT *)(pVM->ip));
1361     vmBranchRelative(pVM, 2);
1362     return;
1363 }
1364
1365
1366 /**************************************************************************
1367                         l i t e r a l I m
1368 **
1369 ** IMMEDIATE code for "literal". This function gets a value from the stack
1370 ** and compiles it into the dictionary preceded by the code for "(literal)".
1371 ** IMMEDIATE
1372 **************************************************************************/
1373
1374 static void literalIm(FICL_VM *pVM)
1375 {
1376     FICL_DICT *dp = ficlGetDict();
1377     assert(pLitParen);
1378
1379     dictAppendCell(dp, LVALUEtoCELL(pLitParen));
1380     dictAppendCell(dp, stackPop(pVM->pStack));
1381
1382     return;
1383 }
1384
1385
1386 static void twoLiteralIm(FICL_VM *pVM)
1387 {
1388     FICL_DICT *dp = ficlGetDict();
1389     assert(pTwoLitParen);
1390
1391     dictAppendCell(dp, LVALUEtoCELL(pTwoLitParen));
1392     dictAppendCell(dp, stackPop(pVM->pStack));
1393     dictAppendCell(dp, stackPop(pVM->pStack));
1394
1395     return;
1396 }
1397
1398 /**************************************************************************
1399                         l i s t W o r d s
1400 **
1401 **************************************************************************/
1402 #define nCOLWIDTH 8
1403 static void listWords(FICL_VM *pVM)
1404 {
1405     FICL_DICT *dp = ficlGetDict();
1406     FICL_HASH *pHash = dp->pSearch[dp->nLists - 1];
1407     FICL_WORD *wp;
1408     int nChars = 0;
1409     int len;
1410     int y = 0;
1411     unsigned i;
1412     int nWords = 0;
1413     char *cp;
1414     char *pPad = pVM->pad;
1415
1416     for (i = 0; i < pHash->size; i++)
1417     {
1418         for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
1419         {
1420             if (wp->nName == 0) /* ignore :noname defs */
1421                 continue;
1422
1423             cp = wp->name;
1424             nChars += sprintf(pPad + nChars, "%s", cp);
1425
1426             if (nChars > 70)
1427             {
1428                 pPad[nChars] = '\0';
1429                 nChars = 0;
1430                 y++;
1431                 if(y>23) {
1432                         y=0;
1433                         vmTextOut(pVM, "--- Press Enter to continue ---",0);
1434                         getchar();
1435                         vmTextOut(pVM,"\r",0);
1436                 }
1437                 vmTextOut(pVM, pPad, 1);
1438             }
1439             else
1440             {
1441                 len = nCOLWIDTH - nChars % nCOLWIDTH;
1442                 while (len-- > 0)
1443                     pPad[nChars++] = ' ';
1444             }
1445
1446             if (nChars > 70)
1447             {
1448                 pPad[nChars] = '\0';
1449                 nChars = 0;
1450                 y++;
1451                 if(y>23) {
1452                         y=0;
1453                         vmTextOut(pVM, "--- Press Enter to continue ---",0);
1454                         getchar();
1455                         vmTextOut(pVM,"\r",0);
1456                 }
1457                 vmTextOut(pVM, pPad, 1);
1458             }
1459         }
1460     }
1461
1462     if (nChars > 0)
1463     {
1464         pPad[nChars] = '\0';
1465         nChars = 0;
1466         vmTextOut(pVM, pPad, 1);
1467     }
1468
1469     sprintf(pVM->pad, "Dictionary: %d words, %ld cells used of %u total",
1470         nWords, (long) (dp->here - dp->dict), dp->size);
1471     vmTextOut(pVM, pVM->pad, 1);
1472     return;
1473 }
1474
1475
1476 static void listEnv(FICL_VM *pVM)
1477 {
1478     FICL_DICT *dp = ficlGetEnv();
1479     FICL_HASH *pHash = dp->pForthWords;
1480     FICL_WORD *wp;
1481     unsigned i;
1482     int nWords = 0;
1483
1484     for (i = 0; i < pHash->size; i++)
1485     {
1486         for (wp = pHash->table[i]; wp != NULL; wp = wp->link, nWords++)
1487         {
1488             vmTextOut(pVM, wp->name, 1);
1489         }
1490     }
1491
1492     sprintf(pVM->pad, "Environment: %d words, %ld cells used of %u total",
1493         nWords, (long) (dp->here - dp->dict), dp->size);
1494     vmTextOut(pVM, pVM->pad, 1);
1495     return;
1496 }
1497
1498
1499 /**************************************************************************
1500                         l o g i c   a n d   c o m p a r i s o n s
1501 **
1502 **************************************************************************/
1503
1504 static void zeroEquals(FICL_VM *pVM)
1505 {
1506     CELL c;
1507 #if FICL_ROBUST > 1
1508     vmCheckStack(pVM, 1, 1);
1509 #endif
1510     c.i = FICL_BOOL(stackPopINT(pVM->pStack) == 0);
1511     stackPush(pVM->pStack, c);
1512     return;
1513 }
1514
1515 static void zeroLess(FICL_VM *pVM)
1516 {
1517     CELL c;
1518 #if FICL_ROBUST > 1
1519     vmCheckStack(pVM, 1, 1);
1520 #endif
1521     c.i = FICL_BOOL(stackPopINT(pVM->pStack) < 0);
1522     stackPush(pVM->pStack, c);
1523     return;
1524 }
1525
1526 static void zeroGreater(FICL_VM *pVM)
1527 {
1528     CELL c;
1529 #if FICL_ROBUST > 1
1530     vmCheckStack(pVM, 1, 1);
1531 #endif
1532     c.i = FICL_BOOL(stackPopINT(pVM->pStack) > 0);
1533     stackPush(pVM->pStack, c);
1534     return;
1535 }
1536
1537 static void isEqual(FICL_VM *pVM)
1538 {
1539     CELL x, y;
1540
1541 #if FICL_ROBUST > 1
1542     vmCheckStack(pVM, 2, 1);
1543 #endif
1544     x = stackPop(pVM->pStack);
1545     y = stackPop(pVM->pStack);
1546     stackPushINT(pVM->pStack, FICL_BOOL(x.i == y.i));
1547     return;
1548 }
1549
1550 static void isLess(FICL_VM *pVM)
1551 {
1552     CELL x, y;
1553 #if FICL_ROBUST > 1
1554     vmCheckStack(pVM, 2, 1);
1555 #endif
1556     y = stackPop(pVM->pStack);
1557     x = stackPop(pVM->pStack);
1558     stackPushINT(pVM->pStack, FICL_BOOL(x.i < y.i));
1559     return;
1560 }
1561
1562 static void uIsLess(FICL_VM *pVM)
1563 {
1564     FICL_UNS u1, u2;
1565 #if FICL_ROBUST > 1
1566     vmCheckStack(pVM, 2, 1);
1567 #endif
1568     u2 = stackPopUNS(pVM->pStack);
1569     u1 = stackPopUNS(pVM->pStack);
1570     stackPushINT(pVM->pStack, FICL_BOOL(u1 < u2));
1571     return;
1572 }
1573
1574 static void isGreater(FICL_VM *pVM)
1575 {
1576     CELL x, y;
1577 #if FICL_ROBUST > 1
1578     vmCheckStack(pVM, 2, 1);
1579 #endif
1580     y = stackPop(pVM->pStack);
1581     x = stackPop(pVM->pStack);
1582     stackPushINT(pVM->pStack, FICL_BOOL(x.i > y.i));
1583     return;
1584 }
1585
1586 static void bitwiseAnd(FICL_VM *pVM)
1587 {
1588     CELL x, y;
1589 #if FICL_ROBUST > 1
1590     vmCheckStack(pVM, 2, 1);
1591 #endif
1592     x = stackPop(pVM->pStack);
1593     y = stackPop(pVM->pStack);
1594     stackPushINT(pVM->pStack, x.i & y.i);
1595     return;
1596 }
1597
1598 static void bitwiseOr(FICL_VM *pVM)
1599 {
1600     CELL x, y;
1601 #if FICL_ROBUST > 1
1602     vmCheckStack(pVM, 2, 1);
1603 #endif
1604     x = stackPop(pVM->pStack);
1605     y = stackPop(pVM->pStack);
1606     stackPushINT(pVM->pStack, x.i | y.i);
1607     return;
1608 }
1609
1610 static void bitwiseXor(FICL_VM *pVM)
1611 {
1612     CELL x, y;
1613 #if FICL_ROBUST > 1
1614     vmCheckStack(pVM, 2, 1);
1615 #endif
1616     x = stackPop(pVM->pStack);
1617     y = stackPop(pVM->pStack);
1618     stackPushINT(pVM->pStack, x.i ^ y.i);
1619     return;
1620 }
1621
1622 static void bitwiseNot(FICL_VM *pVM)
1623 {
1624     CELL x;
1625 #if FICL_ROBUST > 1
1626     vmCheckStack(pVM, 1, 1);
1627 #endif
1628     x = stackPop(pVM->pStack);
1629     stackPushINT(pVM->pStack, ~x.i);
1630     return;
1631 }
1632
1633
1634 /**************************************************************************
1635                                D o  /  L o o p
1636 ** do -- IMMEDIATE COMPILE ONLY
1637 **    Compiles code to initialize a loop: compile (do),
1638 **    allot space to hold the "leave" address, push a branch
1639 **    target address for the loop.
1640 ** (do) -- runtime for "do"
1641 **    pops index and limit from the p stack and moves them
1642 **    to the r stack, then skips to the loop body.
1643 ** loop -- IMMEDIATE COMPILE ONLY
1644 ** +loop
1645 **    Compiles code for the test part of a loop:
1646 **    compile (loop), resolve forward branch from "do", and
1647 **    copy "here" address to the "leave" address allotted by "do"
1648 ** i,j,k -- COMPILE ONLY
1649 **    Runtime: Push loop indices on param stack (i is innermost loop...)
1650 **    Note: each loop has three values on the return stack:
1651 **    ( R: leave limit index )
1652 **    "leave" is the absolute address of the next cell after the loop
1653 **    limit and index are the loop control variables.
1654 ** leave -- COMPILE ONLY
1655 **    Runtime: pop the loop control variables, then pop the
1656 **    "leave" address and jump (absolute) there.
1657 **************************************************************************/
1658
1659 static void doCoIm(FICL_VM *pVM)
1660 {
1661     FICL_DICT *dp = ficlGetDict();
1662
1663     assert(pDoParen);
1664
1665     dictAppendCell(dp, LVALUEtoCELL(pDoParen));
1666     /*
1667     ** Allot space for a pointer to the end
1668     ** of the loop - "leave" uses this...
1669     */
1670     markBranch(dp, pVM, leaveTag);
1671     dictAppendUNS(dp, 0);
1672     /*
1673     ** Mark location of head of loop...
1674     */
1675     markBranch(dp, pVM, doTag);
1676
1677     return;
1678 }
1679
1680
1681 static void doParen(FICL_VM *pVM)
1682 {
1683     CELL index, limit;
1684 #if FICL_ROBUST > 1
1685     vmCheckStack(pVM, 2, 0);
1686 #endif
1687     index = stackPop(pVM->pStack);
1688     limit = stackPop(pVM->pStack);
1689
1690     /* copy "leave" target addr to stack */
1691     stackPushPtr(pVM->rStack, *(pVM->ip++));
1692     stackPush(pVM->rStack, limit);
1693     stackPush(pVM->rStack, index);
1694
1695     return;
1696 }
1697
1698
1699 static void qDoCoIm(FICL_VM *pVM)
1700 {
1701     FICL_DICT *dp = ficlGetDict();
1702
1703     assert(pQDoParen);
1704
1705     dictAppendCell(dp, LVALUEtoCELL(pQDoParen));
1706     /*
1707     ** Allot space for a pointer to the end
1708     ** of the loop - "leave" uses this...
1709     */
1710     markBranch(dp, pVM, leaveTag);
1711     dictAppendUNS(dp, 0);
1712     /*
1713     ** Mark location of head of loop...
1714     */
1715     markBranch(dp, pVM, doTag);
1716
1717     return;
1718 }
1719
1720
1721 static void qDoParen(FICL_VM *pVM)
1722 {
1723     CELL index, limit;
1724 #if FICL_ROBUST > 1
1725     vmCheckStack(pVM, 2, 0);
1726 #endif
1727     index = stackPop(pVM->pStack);
1728     limit = stackPop(pVM->pStack);
1729
1730     /* copy "leave" target addr to stack */
1731     stackPushPtr(pVM->rStack, *(pVM->ip++));
1732
1733     if (limit.u == index.u)
1734     {
1735         vmPopIP(pVM);
1736     }
1737     else
1738     {
1739         stackPush(pVM->rStack, limit);
1740         stackPush(pVM->rStack, index);
1741     }
1742
1743     return;
1744 }
1745
1746
1747 /*
1748 ** Runtime code to break out of a do..loop construct
1749 ** Drop the loop control variables; the branch address
1750 ** past "loop" is next on the return stack.
1751 */
1752 static void leaveCo(FICL_VM *pVM)
1753 {
1754     /* almost unloop */
1755     stackDrop(pVM->rStack, 2);
1756     /* exit */
1757     vmPopIP(pVM);
1758     return;
1759 }
1760
1761
1762 static void unloopCo(FICL_VM *pVM)
1763 {
1764     stackDrop(pVM->rStack, 3);
1765     return;
1766 }
1767
1768
1769 static void loopCoIm(FICL_VM *pVM)
1770 {
1771     FICL_DICT *dp = ficlGetDict();
1772
1773     assert(pLoopParen);
1774
1775     dictAppendCell(dp, LVALUEtoCELL(pLoopParen));
1776     resolveBackBranch(dp, pVM, doTag);
1777     resolveAbsBranch(dp, pVM, leaveTag);
1778     return;
1779 }
1780
1781
1782 static void plusLoopCoIm(FICL_VM *pVM)
1783 {
1784     FICL_DICT *dp = ficlGetDict();
1785
1786     assert(pPLoopParen);
1787
1788     dictAppendCell(dp, LVALUEtoCELL(pPLoopParen));
1789     resolveBackBranch(dp, pVM, doTag);
1790     resolveAbsBranch(dp, pVM, leaveTag);
1791     return;
1792 }
1793
1794
1795 static void loopParen(FICL_VM *pVM)
1796 {
1797     FICL_INT index = stackGetTop(pVM->rStack).i;
1798     FICL_INT limit = stackFetch(pVM->rStack, 1).i;
1799
1800     index++;
1801
1802     if (index >= limit)
1803     {
1804         stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1805         vmBranchRelative(pVM, 1);  /* fall through the loop */
1806     }
1807     else
1808     {                       /* update index, branch to loop head */
1809         stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1810         vmBranchRelative(pVM, *(int *)(pVM->ip));
1811     }
1812
1813     return;
1814 }
1815
1816
1817 static void plusLoopParen(FICL_VM *pVM)
1818 {
1819     FICL_INT index = stackGetTop(pVM->rStack).i;
1820     FICL_INT limit = stackFetch(pVM->rStack, 1).i;
1821     FICL_INT increment = stackPop(pVM->pStack).i;
1822     int flag;
1823
1824     index += increment;
1825
1826     if (increment < 0)
1827         flag = (index < limit);
1828     else
1829         flag = (index >= limit);
1830
1831     if (flag)
1832     {
1833         stackDrop(pVM->rStack, 3); /* nuke the loop indices & "leave" addr */
1834         vmBranchRelative(pVM, 1);  /* fall through the loop */
1835     }
1836     else
1837     {                       /* update index, branch to loop head */
1838         stackSetTop(pVM->rStack, LVALUEtoCELL(index));
1839         vmBranchRelative(pVM, *(int *)(pVM->ip));
1840     }
1841
1842     return;
1843 }
1844
1845
1846 static void loopICo(FICL_VM *pVM)
1847 {
1848     CELL index = stackGetTop(pVM->rStack);
1849     stackPush(pVM->pStack, index);
1850
1851     return;
1852 }
1853
1854
1855 static void loopJCo(FICL_VM *pVM)
1856 {
1857     CELL index = stackFetch(pVM->rStack, 3);
1858     stackPush(pVM->pStack, index);
1859
1860     return;
1861 }
1862
1863
1864 static void loopKCo(FICL_VM *pVM)
1865 {
1866     CELL index = stackFetch(pVM->rStack, 6);
1867     stackPush(pVM->pStack, index);
1868
1869     return;
1870 }
1871
1872
1873 /**************************************************************************
1874                         r e t u r n   s t a c k
1875 **
1876 **************************************************************************/
1877
1878 static void toRStack(FICL_VM *pVM)
1879 {
1880     stackPush(pVM->rStack, stackPop(pVM->pStack));
1881     return;
1882 }
1883
1884 static void fromRStack(FICL_VM *pVM)
1885 {
1886     stackPush(pVM->pStack, stackPop(pVM->rStack));
1887     return;
1888 }
1889
1890 static void fetchRStack(FICL_VM *pVM)
1891 {
1892     stackPush(pVM->pStack, stackGetTop(pVM->rStack));
1893     return;
1894 }
1895
1896
1897 /**************************************************************************
1898                         v a r i a b l e
1899 **
1900 **************************************************************************/
1901
1902 static void variableParen(FICL_VM *pVM)
1903 {
1904     FICL_WORD *fw = pVM->runningWord;
1905     stackPushPtr(pVM->pStack, fw->param);
1906     return;
1907 }
1908
1909
1910 static void variable(FICL_VM *pVM)
1911 {
1912     FICL_DICT *dp = ficlGetDict();
1913     STRINGINFO si = vmGetWord(pVM);
1914
1915     dictAppendWord2(dp, si, variableParen, FW_DEFAULT);
1916     dictAllotCells(dp, 1);
1917     return;
1918 }
1919
1920
1921
1922 /**************************************************************************
1923                         b a s e   &   f r i e n d s
1924 **
1925 **************************************************************************/
1926
1927 static void base(FICL_VM *pVM)
1928 {
1929     CELL *pBase = (CELL *)(&pVM->base);
1930     stackPush(pVM->pStack, LVALUEtoCELL(pBase));
1931     return;
1932 }
1933
1934
1935 static void decimal(FICL_VM *pVM)
1936 {
1937     pVM->base = 10;
1938     return;
1939 }
1940
1941
1942 static void hex(FICL_VM *pVM)
1943 {
1944     pVM->base = 16;
1945     return;
1946 }
1947
1948
1949 /**************************************************************************
1950                         a l l o t   &   f r i e n d s
1951 **
1952 **************************************************************************/
1953
1954 static void allot(FICL_VM *pVM)
1955 {
1956     FICL_DICT *dp = ficlGetDict();
1957     FICL_INT i = stackPopINT(pVM->pStack);
1958 #if FICL_ROBUST
1959     dictCheck(dp, pVM, i);
1960 #endif
1961     dictAllot(dp, i);
1962     return;
1963 }
1964
1965
1966 static void here(FICL_VM *pVM)
1967 {
1968     FICL_DICT *dp = ficlGetDict();
1969     stackPushPtr(pVM->pStack, dp->here);
1970     return;
1971 }
1972
1973
1974 static void comma(FICL_VM *pVM)
1975 {
1976     FICL_DICT *dp = ficlGetDict();
1977     CELL c = stackPop(pVM->pStack);
1978     dictAppendCell(dp, c);
1979     return;
1980 }
1981
1982
1983 static void cComma(FICL_VM *pVM)
1984 {
1985     FICL_DICT *dp = ficlGetDict();
1986     char c = (char)stackPopINT(pVM->pStack);
1987     dictAppendChar(dp, c);
1988     return;
1989 }
1990
1991
1992 static void cells(FICL_VM *pVM)
1993 {
1994     FICL_INT i = stackPopINT(pVM->pStack);
1995     stackPushINT(pVM->pStack, i * (FICL_INT)sizeof (CELL));
1996     return;
1997 }
1998
1999
2000 static void cellPlus(FICL_VM *pVM)
2001 {
2002     char *cp = stackPopPtr(pVM->pStack);
2003     stackPushPtr(pVM->pStack, cp + sizeof (CELL));
2004     return;
2005 }
2006
2007
2008 /**************************************************************************
2009                         t i c k
2010 ** tick         CORE ( "<spaces>name" -- xt )
2011 ** Skip leading space delimiters. Parse name delimited by a space. Find
2012 ** name and return xt, the execution token for name. An ambiguous condition
2013 ** exists if name is not found.
2014 **************************************************************************/
2015 static void tick(FICL_VM *pVM)
2016 {
2017     FICL_WORD *pFW = NULL;
2018     STRINGINFO si = vmGetWord(pVM);
2019
2020     pFW = dictLookup(ficlGetDict(), si);
2021     if (!pFW)
2022     {
2023         int i = SI_COUNT(si);
2024         vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
2025     }
2026     stackPushPtr(pVM->pStack, pFW);
2027     return;
2028 }
2029
2030
2031 static void bracketTickCoIm(FICL_VM *pVM)
2032 {
2033     tick(pVM);
2034     literalIm(pVM);
2035
2036     return;
2037 }
2038
2039
2040 /**************************************************************************
2041                         p o s t p o n e
2042 ** Lookup the next word in the input stream and compile code to
2043 ** insert it into definitions created by the resulting word
2044 ** (defers compilation, even of immediate words)
2045 **************************************************************************/
2046
2047 static void postponeCoIm(FICL_VM *pVM)
2048 {
2049     FICL_DICT *dp  = ficlGetDict();
2050     FICL_WORD *pFW;
2051     assert(pComma);
2052
2053     tick(pVM);
2054     pFW = stackGetTop(pVM->pStack).p;
2055     if (wordIsImmediate(pFW))
2056     {
2057         dictAppendCell(dp, stackPop(pVM->pStack));
2058     }
2059     else
2060     {
2061         literalIm(pVM);
2062         dictAppendCell(dp, LVALUEtoCELL(pComma));
2063     }
2064
2065     return;
2066 }
2067
2068
2069
2070 /**************************************************************************
2071                         e x e c u t e
2072 ** Pop an execution token (pointer to a word) off the stack and
2073 ** run it
2074 **************************************************************************/
2075
2076 static void execute(FICL_VM *pVM)
2077 {
2078     FICL_WORD *pFW;
2079 #if FICL_ROBUST > 1
2080     vmCheckStack(pVM, 1, 0);
2081 #endif
2082
2083     pFW = stackPopPtr(pVM->pStack);
2084     vmExecute(pVM, pFW);
2085
2086     return;
2087 }
2088
2089
2090 /**************************************************************************
2091                         i m m e d i a t e
2092 ** Make the most recently compiled word IMMEDIATE -- it executes even
2093 ** in compile state (most often used for control compiling words
2094 ** such as IF, THEN, etc)
2095 **************************************************************************/
2096
2097 static void immediate(FICL_VM *pVM)
2098 {
2099     IGNORE(pVM);
2100     dictSetImmediate(ficlGetDict());
2101     return;
2102 }
2103
2104
2105 static void compileOnly(FICL_VM *pVM)
2106 {
2107     IGNORE(pVM);
2108     dictSetFlags(ficlGetDict(), FW_COMPILE, 0);
2109     return;
2110 }
2111
2112
2113 /**************************************************************************
2114                         d o t Q u o t e
2115 ** IMMEDIATE word that compiles a string literal for later display
2116 ** Compile stringLit, then copy the bytes of the string from the TIB
2117 ** to the dictionary. Backpatch the count byte and align the dictionary.
2118 **
2119 ** stringlit: Fetch the count from the dictionary, then push the address
2120 ** and count on the stack. Finally, update ip to point to the first
2121 ** aligned address after the string text.
2122 **************************************************************************/
2123
2124 static void stringLit(FICL_VM *pVM)
2125 {
2126     FICL_STRING *sp = (FICL_STRING *)(pVM->ip);
2127     FICL_COUNT count = sp->count;
2128     char *cp = sp->text;
2129     stackPushPtr(pVM->pStack, cp);
2130     stackPushUNS(pVM->pStack, count);
2131     cp += count + 1;
2132     cp = alignPtr(cp);
2133     pVM->ip = (IPTYPE)(void *)cp;
2134     return;
2135 }
2136
2137 static void dotQuoteCoIm(FICL_VM *pVM)
2138 {
2139     FICL_DICT *dp = ficlGetDict();
2140     dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2141     dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2142     dictAlign(dp);
2143     dictAppendCell(dp, LVALUEtoCELL(pType));
2144     return;
2145 }
2146
2147
2148 static void dotParen(FICL_VM *pVM)
2149 {
2150     char *pSrc      = vmGetInBuf(pVM);
2151     char *pEnd      = vmGetInBufEnd(pVM);
2152     char *pDest     = pVM->pad;
2153     char ch;
2154
2155     for (ch = *pSrc; (pEnd != pSrc) && (ch != ')'); ch = *++pSrc)
2156         *pDest++ = ch;
2157
2158     *pDest = '\0';
2159     if ((pEnd != pSrc) && (ch == ')'))
2160         pSrc++;
2161
2162     vmTextOut(pVM, pVM->pad, 0);
2163     vmUpdateTib(pVM, pSrc);
2164
2165     return;
2166 }
2167
2168
2169 /**************************************************************************
2170                         s l i t e r a l
2171 ** STRING
2172 ** Interpretation: Interpretation semantics for this word are undefined.
2173 ** Compilation: ( c-addr1 u -- )
2174 ** Append the run-time semantics given below to the current definition.
2175 ** Run-time:       ( -- c-addr2 u )
2176 ** Return c-addr2 u describing a string consisting of the characters
2177 ** specified by c-addr1 u during compilation. A program shall not alter
2178 ** the returned string.
2179 **************************************************************************/
2180 static void sLiteralCoIm(FICL_VM *pVM)
2181 {
2182     FICL_DICT *dp = ficlGetDict();
2183     char *cp, *cpDest;
2184     FICL_UNS u;
2185     u  = stackPopUNS(pVM->pStack);
2186     cp = stackPopPtr(pVM->pStack);
2187
2188     dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2189     cpDest    = (char *) dp->here;
2190     *cpDest++ = (char)   u;
2191
2192     for (; u > 0; --u)
2193     {
2194         *cpDest++ = *cp++;
2195     }
2196
2197     *cpDest++ = 0;
2198     dp->here = PTRtoCELL alignPtr(cpDest);
2199     return;
2200 }
2201
2202
2203 /**************************************************************************
2204                         s t a t e
2205 ** Return the address of the VM's state member (must be sized the
2206 ** same as a CELL for this reason)
2207 **************************************************************************/
2208 static void state(FICL_VM *pVM)
2209 {
2210     stackPushPtr(pVM->pStack, &pVM->state);
2211     return;
2212 }
2213
2214
2215 /**************************************************************************
2216                         c r e a t e . . . d o e s >
2217 ** Make a new word in the dictionary with the run-time effect of
2218 ** a variable (push my address), but with extra space allotted
2219 ** for use by does> .
2220 **************************************************************************/
2221
2222 static void createParen(FICL_VM *pVM)
2223 {
2224     CELL *pCell = pVM->runningWord->param;
2225     stackPushPtr(pVM->pStack, pCell+1);
2226     return;
2227 }
2228
2229
2230 static void create(FICL_VM *pVM)
2231 {
2232     FICL_DICT *dp = ficlGetDict();
2233     STRINGINFO si = vmGetWord(pVM);
2234
2235     dictAppendWord2(dp, si, createParen, FW_DEFAULT);
2236     dictAllotCells(dp, 1);
2237     return;
2238 }
2239
2240
2241 static void doDoes(FICL_VM *pVM)
2242 {
2243     CELL *pCell = pVM->runningWord->param;
2244     IPTYPE tempIP = (IPTYPE)((*pCell).p);
2245     stackPushPtr(pVM->pStack, pCell+1);
2246     vmPushIP(pVM, tempIP);
2247     return;
2248 }
2249
2250
2251 static void doesParen(FICL_VM *pVM)
2252 {
2253     FICL_DICT *dp = ficlGetDict();
2254     dp->smudge->code = doDoes;
2255     dp->smudge->param[0] = LVALUEtoCELL(pVM->ip);
2256     vmPopIP(pVM);
2257     return;
2258 }
2259
2260
2261 static void doesCoIm(FICL_VM *pVM)
2262 {
2263     FICL_DICT *dp = ficlGetDict();
2264 #if FICL_WANT_LOCALS
2265     assert(pUnLinkParen);
2266     if (nLocals > 0)
2267     {
2268         FICL_DICT *pLoc = ficlGetLoc();
2269         dictEmpty(pLoc, pLoc->pForthWords->size);
2270         dictAppendCell(dp, LVALUEtoCELL(pUnLinkParen));
2271     }
2272
2273     nLocals = 0;
2274 #endif
2275     IGNORE(pVM);
2276
2277     dictAppendCell(dp, LVALUEtoCELL(pDoesParen));
2278     return;
2279 }
2280
2281
2282 /**************************************************************************
2283                         t o   b o d y
2284 ** to-body      CORE ( xt -- a-addr )
2285 ** a-addr is the data-field address corresponding to xt. An ambiguous
2286 ** condition exists if xt is not for a word defined via CREATE.
2287 **************************************************************************/
2288 static void toBody(FICL_VM *pVM)
2289 {
2290     FICL_WORD *pFW = stackPopPtr(pVM->pStack);
2291     stackPushPtr(pVM->pStack, pFW->param + 1);
2292     return;
2293 }
2294
2295
2296 /*
2297 ** from-body       ficl ( a-addr -- xt )
2298 ** Reverse effect of >body
2299 */
2300 static void fromBody(FICL_VM *pVM)
2301 {
2302     char *ptr = (char *) stackPopPtr(pVM->pStack) - sizeof (FICL_WORD);
2303     stackPushPtr(pVM->pStack, ptr);
2304     return;
2305 }
2306
2307
2308 /*
2309 ** >name        ficl ( xt -- c-addr u )
2310 ** Push the address and length of a word's name given its address
2311 ** xt.
2312 */
2313 static void toName(FICL_VM *pVM)
2314 {
2315     FICL_WORD *pFW = stackPopPtr(pVM->pStack);
2316     stackPushPtr(pVM->pStack, pFW->name);
2317     stackPushUNS(pVM->pStack, pFW->nName);
2318     return;
2319 }
2320
2321
2322 /**************************************************************************
2323                         l b r a c k e t   e t c
2324 **
2325 **************************************************************************/
2326
2327 static void lbracketCoIm(FICL_VM *pVM)
2328 {
2329     pVM->state = INTERPRET;
2330     return;
2331 }
2332
2333
2334 static void rbracket(FICL_VM *pVM)
2335 {
2336     pVM->state = COMPILE;
2337     return;
2338 }
2339
2340
2341 /**************************************************************************
2342                         p i c t u r e d   n u m e r i c   w o r d s
2343 **
2344 ** less-number-sign CORE ( -- )
2345 ** Initialize the pictured numeric output conversion process.
2346 ** (clear the pad)
2347 **************************************************************************/
2348 static void lessNumberSign(FICL_VM *pVM)
2349 {
2350     FICL_STRING *sp = PTRtoSTRING pVM->pad;
2351     sp->count = 0;
2352     return;
2353 }
2354
2355 /*
2356 ** number-sign      CORE ( ud1 -- ud2 )
2357 ** Divide ud1 by the number in BASE giving the quotient ud2 and the remainder
2358 ** n. (n is the least-significant digit of ud1.) Convert n to external form
2359 ** and add the resulting character to the beginning of the pictured numeric
2360 ** output  string. An ambiguous condition exists if # executes outside of a
2361 ** <# #> delimited number conversion.
2362 */
2363 static void numberSign(FICL_VM *pVM)
2364 {
2365     FICL_STRING *sp = PTRtoSTRING pVM->pad;
2366     DPUNS u;
2367     UNS16 rem;
2368
2369     u   = u64Pop(pVM->pStack);
2370     rem = m64UMod(&u, (UNS16)(pVM->base));
2371     sp->text[sp->count++] = digit_to_char(rem);
2372     u64Push(pVM->pStack, u);
2373     return;
2374 }
2375
2376 /*
2377 ** number-sign-greater CORE ( xd -- c-addr u )
2378 ** Drop xd. Make the pictured numeric output string available as a character
2379 ** string. c-addr and u specify the resulting character string. A program
2380 ** may replace characters within the string.
2381 */
2382 static void numberSignGreater(FICL_VM *pVM)
2383 {
2384     FICL_STRING *sp = PTRtoSTRING pVM->pad;
2385     sp->text[sp->count] = '\0';
2386     strrev(sp->text);
2387     stackDrop(pVM->pStack, 2);
2388     stackPushPtr(pVM->pStack, sp->text);
2389     stackPushUNS(pVM->pStack, sp->count);
2390     return;
2391 }
2392
2393 /*
2394 ** number-sign-s    CORE ( ud1 -- ud2 )
2395 ** Convert one digit of ud1 according to the rule for #. Continue conversion
2396 ** until the quotient is zero. ud2 is zero. An ambiguous condition exists if
2397 ** #S executes outside of a <# #> delimited number conversion.
2398 ** TO DO: presently does not use ud1 hi cell - use it!
2399 */
2400 static void numberSignS(FICL_VM *pVM)
2401 {
2402     FICL_STRING *sp = PTRtoSTRING pVM->pad;
2403     DPUNS u;
2404     UNS16 rem;
2405
2406     u = u64Pop(pVM->pStack);
2407
2408     do
2409     {
2410         rem = m64UMod(&u, (UNS16)(pVM->base));
2411         sp->text[sp->count++] = digit_to_char(rem);
2412     }
2413     while (u.hi || u.lo);
2414
2415     u64Push(pVM->pStack, u);
2416     return;
2417 }
2418
2419 /*
2420 ** HOLD             CORE ( char -- )
2421 ** Add char to the beginning of the pictured numeric output string. An ambiguous
2422 ** condition exists if HOLD executes outside of a <# #> delimited number conversion.
2423 */
2424 static void hold(FICL_VM *pVM)
2425 {
2426     FICL_STRING *sp = PTRtoSTRING pVM->pad;
2427     int i = stackPopINT(pVM->pStack);
2428     sp->text[sp->count++] = (char) i;
2429     return;
2430 }
2431
2432 /*
2433 ** SIGN             CORE ( n -- )
2434 ** If n is negative, add a minus sign to the beginning of the pictured
2435 ** numeric output string. An ambiguous condition exists if SIGN
2436 ** executes outside of a <# #> delimited number conversion.
2437 */
2438 static void sign(FICL_VM *pVM)
2439 {
2440     FICL_STRING *sp = PTRtoSTRING pVM->pad;
2441     int i = stackPopINT(pVM->pStack);
2442     if (i < 0)
2443         sp->text[sp->count++] = '-';
2444     return;
2445 }
2446
2447
2448 /**************************************************************************
2449                         t o   N u m b e r
2450 ** to-number CORE ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 )
2451 ** ud2 is the unsigned result of converting the characters within the
2452 ** string specified by c-addr1 u1 into digits, using the number in BASE,
2453 ** and adding each into ud1 after multiplying ud1 by the number in BASE.
2454 ** Conversion continues left-to-right until a character that is not
2455 ** convertible, including any + or -, is encountered or the string is
2456 ** entirely converted. c-addr2 is the location of the first unconverted
2457 ** character or the first character past the end of the string if the string
2458 ** was entirely converted. u2 is the number of unconverted characters in the
2459 ** string. An ambiguous condition exists if ud2 overflows during the
2460 ** conversion.
2461 **************************************************************************/
2462 static void toNumber(FICL_VM *pVM)
2463 {
2464     FICL_UNS count  = stackPopUNS(pVM->pStack);
2465     char *cp        = (char *)stackPopPtr(pVM->pStack);
2466     DPUNS accum;
2467     FICL_UNS base   = pVM->base;
2468     FICL_UNS ch;
2469     FICL_UNS digit;
2470
2471     accum = u64Pop(pVM->pStack);
2472
2473     for (ch = *cp; count > 0; ch = *++cp, count--)
2474     {
2475         if (ch < '0')
2476             break;
2477
2478         digit = ch - '0';
2479
2480         if (digit > 9)
2481             digit = tolower(ch) - 'a' + 10;
2482         /*
2483         ** Note: following test also catches chars between 9 and a
2484         ** because 'digit' is unsigned!
2485         */
2486         if (digit >= base)
2487             break;
2488
2489         accum = m64Mac(accum, base, digit);
2490     }
2491
2492     u64Push(pVM->pStack, accum);
2493     stackPushPtr  (pVM->pStack, cp);
2494     stackPushUNS(pVM->pStack, count);
2495
2496     return;
2497 }
2498
2499
2500
2501 /**************************************************************************
2502                         q u i t   &   a b o r t
2503 ** quit CORE   ( -- )  ( R:  i*x -- )
2504 ** Empty the return stack, store zero in SOURCE-ID if it is present, make
2505 ** the user input device the input source, and enter interpretation state.
2506 ** Do not display a message. Repeat the following:
2507 **
2508 **   Accept a line from the input source into the input buffer, set >IN to
2509 **   zero, and interpret.
2510 **   Display the implementation-defined system prompt if in
2511 **   interpretation state, all processing has been completed, and no
2512 **   ambiguous condition exists.
2513 **************************************************************************/
2514
2515 static void quit(FICL_VM *pVM)
2516 {
2517     vmThrow(pVM, VM_QUIT);
2518     return;
2519 }
2520
2521
2522 static void ficlAbort(FICL_VM *pVM)
2523 {
2524     vmThrow(pVM, VM_ABORT);
2525     return;
2526 }
2527
2528
2529 /**************************************************************************
2530                         a c c e p t
2531 ** accept       CORE ( c-addr +n1 -- +n2 )
2532 ** Receive a string of at most +n1 characters. An ambiguous condition
2533 ** exists if +n1 is zero or greater than 32,767. Display graphic characters
2534 ** as they are received. A program that depends on the presence or absence
2535 ** of non-graphic characters in the string has an environmental dependency.
2536 ** The editing functions, if any, that the system performs in order to
2537 ** construct the string are implementation-defined.
2538 **
2539 ** (Although the standard text doesn't say so, I assume that the intent
2540 ** of 'accept' is to store the string at the address specified on
2541 ** the stack.)
2542 ** Implementation: if there's more text in the TIB, use it. Otherwise
2543 ** throw out for more text. Copy characters up to the max count into the
2544 ** address given, and return the number of actual characters copied.
2545 **
2546 ** Note (sobral) this may not be the behavior you'd expect if you're
2547 ** trying to get user input at load time!
2548 **************************************************************************/
2549 static void accept(FICL_VM *pVM)
2550 {
2551     FICL_INT count;
2552     char *cp;
2553     char *pBuf      = vmGetInBuf(pVM);
2554     char *pEnd      = vmGetInBufEnd(pVM);
2555     FICL_INT len       = pEnd - pBuf;
2556
2557     if (len == 0)
2558         vmThrow(pVM, VM_RESTART);
2559
2560     /*
2561     ** Now we have something in the text buffer - use it
2562     */
2563     count = stackPopINT(pVM->pStack);
2564     cp    = stackPopPtr(pVM->pStack);
2565
2566     len = (count < len) ? count : len;
2567     strncpy(cp, vmGetInBuf(pVM), len);
2568     pBuf += len;
2569     vmUpdateTib(pVM, pBuf);
2570     stackPushINT(pVM->pStack, len);
2571
2572     return;
2573 }
2574
2575
2576 /**************************************************************************
2577                         a l i g n
2578 ** 6.1.0705 ALIGN       CORE ( -- )
2579 ** If the data-space pointer is not aligned, reserve enough space to
2580 ** align it.
2581 **************************************************************************/
2582 static void align(FICL_VM *pVM)
2583 {
2584     FICL_DICT *dp = ficlGetDict();
2585     IGNORE(pVM);
2586     dictAlign(dp);
2587     return;
2588 }
2589
2590
2591 /**************************************************************************
2592                         a l i g n e d
2593 **
2594 **************************************************************************/
2595 static void aligned(FICL_VM *pVM)
2596 {
2597     void *addr = stackPopPtr(pVM->pStack);
2598     stackPushPtr(pVM->pStack, alignPtr(addr));
2599     return;
2600 }
2601
2602
2603 /**************************************************************************
2604                         b e g i n   &   f r i e n d s
2605 ** Indefinite loop control structures
2606 ** A.6.1.0760 BEGIN
2607 ** Typical use:
2608 **      : X ... BEGIN ... test UNTIL ;
2609 ** or
2610 **      : X ... BEGIN ... test WHILE ... REPEAT ;
2611 **************************************************************************/
2612 static void beginCoIm(FICL_VM *pVM)
2613 {
2614     FICL_DICT *dp = ficlGetDict();
2615     markBranch(dp, pVM, destTag);
2616     return;
2617 }
2618
2619 static void untilCoIm(FICL_VM *pVM)
2620 {
2621     FICL_DICT *dp = ficlGetDict();
2622
2623     assert(pIfParen);
2624
2625     dictAppendCell(dp, LVALUEtoCELL(pIfParen));
2626     resolveBackBranch(dp, pVM, destTag);
2627     return;
2628 }
2629
2630 static void whileCoIm(FICL_VM *pVM)
2631 {
2632     FICL_DICT *dp = ficlGetDict();
2633
2634     assert(pIfParen);
2635
2636     dictAppendCell(dp, LVALUEtoCELL(pIfParen));
2637     markBranch(dp, pVM, origTag);
2638     twoSwap(pVM);
2639     dictAppendUNS(dp, 1);
2640     return;
2641 }
2642
2643 static void repeatCoIm(FICL_VM *pVM)
2644 {
2645     FICL_DICT *dp = ficlGetDict();
2646
2647     assert(pBranchParen);
2648     dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
2649
2650     /* expect "begin" branch marker */
2651     resolveBackBranch(dp, pVM, destTag);
2652     /* expect "while" branch marker */
2653     resolveForwardBranch(dp, pVM, origTag);
2654     return;
2655 }
2656
2657
2658 static void againCoIm(FICL_VM *pVM)
2659 {
2660     FICL_DICT *dp = ficlGetDict();
2661
2662     assert(pBranchParen);
2663     dictAppendCell(dp, LVALUEtoCELL(pBranchParen));
2664
2665     /* expect "begin" branch marker */
2666     resolveBackBranch(dp, pVM, destTag);
2667     return;
2668 }
2669
2670
2671 /**************************************************************************
2672                         c h a r   &   f r i e n d s
2673 ** 6.1.0895 CHAR    CORE ( "<spaces>name" -- char )
2674 ** Skip leading space delimiters. Parse name delimited by a space.
2675 ** Put the value of its first character onto the stack.
2676 **
2677 ** bracket-char     CORE
2678 ** Interpretation: Interpretation semantics for this word are undefined.
2679 ** Compilation: ( "<spaces>name" -- )
2680 ** Skip leading space delimiters. Parse name delimited by a space.
2681 ** Append the run-time semantics given below to the current definition.
2682 ** Run-time: ( -- char )
2683 ** Place char, the value of the first character of name, on the stack.
2684 **************************************************************************/
2685 static void ficlChar(FICL_VM *pVM)
2686 {
2687     STRINGINFO si = vmGetWord(pVM);
2688     stackPushUNS(pVM->pStack, (FICL_UNS)(si.cp[0]));
2689
2690     return;
2691 }
2692
2693 static void charCoIm(FICL_VM *pVM)
2694 {
2695     ficlChar(pVM);
2696     literalIm(pVM);
2697     return;
2698 }
2699
2700 /**************************************************************************
2701                         c h a r P l u s
2702 ** char-plus        CORE ( c-addr1 -- c-addr2 )
2703 ** Add the size in address units of a character to c-addr1, giving c-addr2.
2704 **************************************************************************/
2705 static void charPlus(FICL_VM *pVM)
2706 {
2707     char *cp = stackPopPtr(pVM->pStack);
2708     stackPushPtr(pVM->pStack, cp + 1);
2709     return;
2710 }
2711
2712 /**************************************************************************
2713                         c h a r s
2714 ** chars        CORE ( n1 -- n2 )
2715 ** n2 is the size in address units of n1 characters.
2716 ** For most processors, this function can be a no-op. To guarantee
2717 ** portability, we'll multiply by sizeof (char).
2718 **************************************************************************/
2719 #if defined (_M_IX86)
2720 #pragma warning(disable: 4127)
2721 #endif
2722 static void ficlChars(FICL_VM *pVM)
2723 {
2724     if (sizeof (char) > 1)
2725     {
2726         FICL_INT i = stackPopINT(pVM->pStack);
2727         stackPushINT(pVM->pStack, i * sizeof (char));
2728     }
2729     /* otherwise no-op! */
2730     return;
2731 }
2732 #if defined (_M_IX86)
2733 #pragma warning(default: 4127)
2734 #endif
2735
2736
2737 /**************************************************************************
2738                         c o u n t
2739 ** COUNT    CORE ( c-addr1 -- c-addr2 u )
2740 ** Return the character string specification for the counted string stored
2741 ** at c-addr1. c-addr2 is the address of the first character after c-addr1.
2742 ** u is the contents of the character at c-addr1, which is the length in
2743 ** characters of the string at c-addr2.
2744 **************************************************************************/
2745 static void count(FICL_VM *pVM)
2746 {
2747     FICL_STRING *sp = stackPopPtr(pVM->pStack);
2748     stackPushPtr(pVM->pStack, sp->text);
2749     stackPushUNS(pVM->pStack, sp->count);
2750     return;
2751 }
2752
2753 /**************************************************************************
2754                         e n v i r o n m e n t ?
2755 ** environment-query CORE ( c-addr u -- false | i*x true )
2756 ** c-addr is the address of a character string and u is the string's
2757 ** character count. u may have a value in the range from zero to an
2758 ** implementation-defined maximum which shall not be less than 31. The
2759 ** character string should contain a keyword from 3.2.6 Environmental
2760 ** queries or the optional word sets to be checked for correspondence
2761 ** with an attribute of the present environment. If the system treats the
2762 ** attribute as unknown, the returned flag is false; otherwise, the flag
2763 ** is true and the i*x returned is of the type specified in the table for
2764 ** the attribute queried.
2765 **************************************************************************/
2766 static void environmentQ(FICL_VM *pVM)
2767 {
2768     FICL_DICT *envp = ficlGetEnv();
2769     FICL_COUNT  len = (FICL_COUNT)stackPopUNS(pVM->pStack);
2770     char        *cp =  stackPopPtr(pVM->pStack);
2771     FICL_WORD  *pFW;
2772     STRINGINFO si;
2773
2774
2775     &len;       /* silence compiler warning... */
2776     SI_PSZ(si, cp);
2777     pFW = dictLookup(envp, si);
2778
2779     if (pFW != NULL)
2780     {
2781         vmExecute(pVM, pFW);
2782         stackPushINT(pVM->pStack, FICL_TRUE);
2783     }
2784     else
2785     {
2786         stackPushINT(pVM->pStack, FICL_FALSE);
2787     }
2788
2789     return;
2790 }
2791
2792 /**************************************************************************
2793                         e v a l u a t e
2794 ** EVALUATE CORE ( i*x c-addr u -- j*x )
2795 ** Save the current input source specification. Store minus-one (-1) in
2796 ** SOURCE-ID if it is present. Make the string described by c-addr and u
2797 ** both the input source and input buffer, set >IN to zero, and interpret.
2798 ** When the parse area is empty, restore the prior input source
2799 ** specification. Other stack effects are due to the words EVALUATEd.
2800 **
2801 **************************************************************************/
2802 static void evaluate(FICL_VM *pVM)
2803 {
2804     FICL_INT count = stackPopINT(pVM->pStack);
2805     char *cp    = stackPopPtr(pVM->pStack);
2806     CELL id;
2807     int result;
2808
2809     id = pVM->sourceID;
2810     pVM->sourceID.i = -1;
2811     result = ficlExecC(pVM, cp, count);
2812     pVM->sourceID = id;
2813     if (result != VM_OUTOFTEXT)
2814         vmThrow(pVM, result);
2815
2816     return;
2817 }
2818
2819
2820 /**************************************************************************
2821                         s t r i n g   q u o t e
2822 ** Intrpreting: get string delimited by a quote from the input stream,
2823 ** copy to a scratch area, and put its count and address on the stack.
2824 ** Compiling: compile code to push the address and count of a string
2825 ** literal, compile the string from the input stream, and align the dict
2826 ** pointer.
2827 **************************************************************************/
2828 static void stringQuoteIm(FICL_VM *pVM)
2829 {
2830     FICL_DICT *dp = ficlGetDict();
2831
2832     if (pVM->state == INTERPRET)
2833     {
2834         FICL_STRING *sp = (FICL_STRING *) dp->here;
2835         vmGetString(pVM, sp, '\"');
2836         stackPushPtr(pVM->pStack, sp->text);
2837         stackPushUNS(pVM->pStack, sp->count);
2838     }
2839     else    /* COMPILE state */
2840     {
2841         dictAppendCell(dp, LVALUEtoCELL(pStringLit));
2842         dp->here = PTRtoCELL vmGetString(pVM, (FICL_STRING *)dp->here, '\"');
2843         dictAlign(dp);
2844     }
2845
2846     return;
2847 }
2848
2849
2850 /**************************************************************************
2851                         t y p e
2852 ** Pop count and char address from stack and print the designated string.
2853 **************************************************************************/
2854 static void type(FICL_VM *pVM)
2855 {
2856     FICL_UNS count = stackPopUNS(pVM->pStack);
2857     char *cp    = stackPopPtr(pVM->pStack);
2858     char *pDest = (char *)ficlMalloc(count + 1);
2859
2860     /*
2861     ** Since we don't have an output primitive for a counted string
2862     ** (oops), make sure the string is null terminated. If not, copy
2863     ** and terminate it.
2864     */
2865     if (!pDest)
2866         vmThrowErr(pVM, "Error: out of memory");
2867
2868     strncpy(pDest, cp, count);
2869     pDest[count] = '\0';
2870
2871     vmTextOut(pVM, pDest, 0);
2872
2873     ficlFree(pDest);
2874     return;
2875 }
2876
2877 /**************************************************************************
2878                         w o r d
2879 ** word CORE ( char "<chars>ccc<char>" -- c-addr )
2880 ** Skip leading delimiters. Parse characters ccc delimited by char. An
2881 ** ambiguous condition exists if the length of the parsed string is greater
2882 ** than the implementation-defined length of a counted string.
2883 **
2884 ** c-addr is the address of a transient region containing the parsed word
2885 ** as a counted string. If the parse area was empty or contained no
2886 ** characters other than the delimiter, the resulting string has a zero
2887 ** length. A space, not included in the length, follows the string. A
2888 ** program may replace characters within the string.
2889 ** NOTE! Ficl also NULL-terminates the dest string.
2890 **************************************************************************/
2891 static void ficlWord(FICL_VM *pVM)
2892 {
2893     FICL_STRING *sp = (FICL_STRING *)pVM->pad;
2894     char      delim = (char)stackPopINT(pVM->pStack);
2895     STRINGINFO   si;
2896
2897     si = vmParseStringEx(pVM, delim, 1);
2898
2899     if (SI_COUNT(si) > nPAD-1)
2900         SI_SETLEN(si, nPAD-1);
2901
2902     sp->count = (FICL_COUNT)SI_COUNT(si);
2903     strncpy(sp->text, SI_PTR(si), SI_COUNT(si));
2904     strcat(sp->text, " ");
2905
2906     stackPushPtr(pVM->pStack, sp);
2907     return;
2908 }
2909
2910
2911 /**************************************************************************
2912                         p a r s e - w o r d
2913 ** ficl   PARSE-WORD  ( <spaces>name -- c-addr u )
2914 ** Skip leading spaces and parse name delimited by a space. c-addr is the
2915 ** address within the input buffer and u is the length of the selected
2916 ** string. If the parse area is empty, the resulting string has a zero length.
2917 **************************************************************************/
2918 static void parseNoCopy(FICL_VM *pVM)
2919 {
2920     STRINGINFO si = vmGetWord0(pVM);
2921     stackPushPtr(pVM->pStack, SI_PTR(si));
2922     stackPushUNS(pVM->pStack, SI_COUNT(si));
2923     return;
2924 }
2925
2926
2927 /**************************************************************************
2928                         p a r s e
2929 ** CORE EXT  ( char "ccc<char>" -- c-addr u )
2930 ** Parse ccc delimited by the delimiter char.
2931 ** c-addr is the address (within the input buffer) and u is the length of
2932 ** the parsed string. If the parse area was empty, the resulting string has
2933 ** a zero length.
2934 ** NOTE! PARSE differs from WORD: it does not skip leading delimiters.
2935 **************************************************************************/
2936 static void parse(FICL_VM *pVM)
2937 {
2938     STRINGINFO si;
2939         char delim      = (char)stackPopINT(pVM->pStack);
2940
2941         si = vmParseStringEx(pVM, delim, 0);
2942     stackPushPtr(pVM->pStack, SI_PTR(si));
2943     stackPushUNS(pVM->pStack, SI_COUNT(si));
2944     return;
2945 }
2946
2947
2948 /**************************************************************************
2949                         f i l l
2950 ** CORE ( c-addr u char -- )
2951 ** If u is greater than zero, store char in each of u consecutive
2952 ** characters of memory beginning at c-addr.
2953 **************************************************************************/
2954 static void fill(FICL_VM *pVM)
2955 {
2956     char ch  = (char)stackPopINT(pVM->pStack);
2957     FICL_UNS  u = stackPopUNS(pVM->pStack);
2958     char *cp = (char *)stackPopPtr(pVM->pStack);
2959
2960     while (u > 0)
2961     {
2962         *cp++ = ch;
2963         u--;
2964     }
2965
2966     return;
2967 }
2968
2969
2970 /**************************************************************************
2971                         f i n d
2972 ** FIND CORE ( c-addr -- c-addr 0  |  xt 1  |  xt -1 )
2973 ** Find the definition named in the counted string at c-addr. If the
2974 ** definition is not found, return c-addr and zero. If the definition is
2975 ** found, return its execution token xt. If the definition is immediate,
2976 ** also return one (1), otherwise also return minus-one (-1). For a given
2977 ** string, the values returned by FIND while compiling may differ from
2978 ** those returned while not compiling.
2979 **************************************************************************/
2980 static void find(FICL_VM *pVM)
2981 {
2982     FICL_STRING *sp = stackPopPtr(pVM->pStack);
2983     FICL_WORD *pFW;
2984     STRINGINFO si;
2985
2986     SI_PFS(si, sp);
2987     pFW = dictLookup(ficlGetDict(), si);
2988     if (pFW)
2989     {
2990         stackPushPtr(pVM->pStack, pFW);
2991         stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
2992     }
2993     else
2994     {
2995         stackPushPtr(pVM->pStack, sp);
2996         stackPushUNS(pVM->pStack, 0);
2997     }
2998     return;
2999 }
3000
3001
3002
3003 /**************************************************************************
3004                         f m S l a s h M o d
3005 ** f-m-slash-mod CORE ( d1 n1 -- n2 n3 )
3006 ** Divide d1 by n1, giving the floored quotient n3 and the remainder n2.
3007 ** Input and output stack arguments are signed. An ambiguous condition
3008 ** exists if n1 is zero or if the quotient lies outside the range of a
3009 ** single-cell signed integer.
3010 **************************************************************************/
3011 static void fmSlashMod(FICL_VM *pVM)
3012 {
3013     DPINT d1;
3014     FICL_INT n1;
3015     INTQR qr;
3016
3017     n1    = stackPopINT(pVM->pStack);
3018     d1 = i64Pop(pVM->pStack);
3019     qr = m64FlooredDivI(d1, n1);
3020     stackPushINT(pVM->pStack, qr.rem);
3021     stackPushINT(pVM->pStack, qr.quot);
3022     return;
3023 }
3024
3025
3026 /**************************************************************************
3027                         s m S l a s h R e m
3028 ** s-m-slash-rem CORE ( d1 n1 -- n2 n3 )
3029 ** Divide d1 by n1, giving the symmetric quotient n3 and the remainder n2.
3030 ** Input and output stack arguments are signed. An ambiguous condition
3031 ** exists if n1 is zero or if the quotient lies outside the range of a
3032 ** single-cell signed integer.
3033 **************************************************************************/
3034 static void smSlashRem(FICL_VM *pVM)
3035 {
3036     DPINT d1;
3037     FICL_INT n1;
3038     INTQR qr;
3039
3040     n1    = stackPopINT(pVM->pStack);
3041     d1 = i64Pop(pVM->pStack);
3042     qr = m64SymmetricDivI(d1, n1);
3043     stackPushINT(pVM->pStack, qr.rem);
3044     stackPushINT(pVM->pStack, qr.quot);
3045     return;
3046 }
3047
3048
3049 static void ficlMod(FICL_VM *pVM)
3050 {
3051     DPINT d1;
3052     FICL_INT n1;
3053     INTQR qr;
3054
3055     n1    = stackPopINT(pVM->pStack);
3056     d1.lo = stackPopINT(pVM->pStack);
3057     i64Extend(d1);
3058     qr = m64SymmetricDivI(d1, n1);
3059     stackPushINT(pVM->pStack, qr.rem);
3060     return;
3061 }
3062
3063
3064 /**************************************************************************
3065                         u m S l a s h M o d
3066 ** u-m-slash-mod CORE ( ud u1 -- u2 u3 )
3067 ** Divide ud by u1, giving the quotient u3 and the remainder u2.
3068 ** All values and arithmetic are unsigned. An ambiguous condition
3069 ** exists if u1 is zero or if the quotient lies outside the range of a
3070 ** single-cell unsigned integer.
3071 *************************************************************************/
3072 static void umSlashMod(FICL_VM *pVM)
3073 {
3074     DPUNS ud;
3075     FICL_UNS u1;
3076     UNSQR qr;
3077
3078     u1    = stackPopUNS(pVM->pStack);
3079     ud    = u64Pop(pVM->pStack);
3080     qr    = ficlLongDiv(ud, u1);
3081     stackPushUNS(pVM->pStack, qr.rem);
3082     stackPushUNS(pVM->pStack, qr.quot);
3083     return;
3084 }
3085
3086
3087 /**************************************************************************
3088                         l s h i f t
3089 ** l-shift CORE ( x1 u -- x2 )
3090 ** Perform a logical left shift of u bit-places on x1, giving x2.
3091 ** Put zeroes into the least significant bits vacated by the shift.
3092 ** An ambiguous condition exists if u is greater than or equal to the
3093 ** number of bits in a cell.
3094 **
3095 ** r-shift CORE ( x1 u -- x2 )
3096 ** Perform a logical right shift of u bit-places on x1, giving x2.
3097 ** Put zeroes into the most significant bits vacated by the shift. An
3098 ** ambiguous condition exists if u is greater than or equal to the
3099 ** number of bits in a cell.
3100 **************************************************************************/
3101 static void lshift(FICL_VM *pVM)
3102 {
3103     FICL_UNS nBits = stackPopUNS(pVM->pStack);
3104     FICL_UNS x1    = stackPopUNS(pVM->pStack);
3105
3106     stackPushUNS(pVM->pStack, x1 << nBits);
3107     return;
3108 }
3109
3110
3111 static void rshift(FICL_VM *pVM)
3112 {
3113     FICL_UNS nBits = stackPopUNS(pVM->pStack);
3114     FICL_UNS x1    = stackPopUNS(pVM->pStack);
3115
3116     stackPushUNS(pVM->pStack, x1 >> nBits);
3117     return;
3118 }
3119
3120
3121 /**************************************************************************
3122                         m S t a r
3123 ** m-star CORE ( n1 n2 -- d )
3124 ** d is the signed product of n1 times n2.
3125 **************************************************************************/
3126 static void mStar(FICL_VM *pVM)
3127 {
3128     FICL_INT n2 = stackPopINT(pVM->pStack);
3129     FICL_INT n1 = stackPopINT(pVM->pStack);
3130     DPINT d;
3131
3132     d = m64MulI(n1, n2);
3133     i64Push(pVM->pStack, d);
3134     return;
3135 }
3136
3137
3138 static void umStar(FICL_VM *pVM)
3139 {
3140     FICL_UNS u2 = stackPopUNS(pVM->pStack);
3141     FICL_UNS u1 = stackPopUNS(pVM->pStack);
3142     DPUNS ud;
3143
3144     ud = ficlLongMul(u1, u2);
3145     u64Push(pVM->pStack, ud);
3146     return;
3147 }
3148
3149
3150 /**************************************************************************
3151                         m a x   &   m i n
3152 **
3153 **************************************************************************/
3154 static void ficlMax(FICL_VM *pVM)
3155 {
3156     FICL_INT n2 = stackPopINT(pVM->pStack);
3157     FICL_INT n1 = stackPopINT(pVM->pStack);
3158
3159     stackPushINT(pVM->pStack, (n1 > n2) ? n1 : n2);
3160     return;
3161 }
3162
3163 static void ficlMin(FICL_VM *pVM)
3164 {
3165     FICL_INT n2 = stackPopINT(pVM->pStack);
3166     FICL_INT n1 = stackPopINT(pVM->pStack);
3167
3168     stackPushINT(pVM->pStack, (n1 < n2) ? n1 : n2);
3169     return;
3170 }
3171
3172
3173 /**************************************************************************
3174                         m o v e
3175 ** CORE ( addr1 addr2 u -- )
3176 ** If u is greater than zero, copy the contents of u consecutive address
3177 ** units at addr1 to the u consecutive address units at addr2. After MOVE
3178 ** completes, the u consecutive address units at addr2 contain exactly
3179 ** what the u consecutive address units at addr1 contained before the move.
3180 ** NOTE! This implementation assumes that a char is the same size as
3181 **       an address unit.
3182 **************************************************************************/
3183 static void move(FICL_VM *pVM)
3184 {
3185     FICL_UNS u     = stackPopUNS(pVM->pStack);
3186     char *addr2 = stackPopPtr(pVM->pStack);
3187     char *addr1 = stackPopPtr(pVM->pStack);
3188
3189     if (u == 0)
3190         return;
3191     /*
3192     ** Do the copy carefully, so as to be
3193     ** correct even if the two ranges overlap
3194     */
3195     if (addr1 >= addr2)
3196     {
3197         for (; u > 0; u--)
3198             *addr2++ = *addr1++;
3199     }
3200     else
3201     {
3202         addr2 += u-1;
3203         addr1 += u-1;
3204         for (; u > 0; u--)
3205             *addr2-- = *addr1--;
3206     }
3207
3208     return;
3209 }
3210
3211
3212 /**************************************************************************
3213                         r e c u r s e
3214 **
3215 **************************************************************************/
3216 static void recurseCoIm(FICL_VM *pVM)
3217 {
3218     FICL_DICT *pDict = ficlGetDict();
3219
3220     IGNORE(pVM);
3221     dictAppendCell(pDict, LVALUEtoCELL(pDict->smudge));
3222     return;
3223 }
3224
3225
3226 /**************************************************************************
3227                         s t o d
3228 ** s-to-d CORE ( n -- d )
3229 ** Convert the number n to the double-cell number d with the same
3230 ** numerical value.
3231 **************************************************************************/
3232 static void sToD(FICL_VM *pVM)
3233 {
3234     FICL_INT s = stackPopINT(pVM->pStack);
3235
3236     /* sign extend to 64 bits.. */
3237     stackPushINT(pVM->pStack, s);
3238     stackPushINT(pVM->pStack, (s < 0) ? -1 : 0);
3239     return;
3240 }
3241
3242
3243 /**************************************************************************
3244                         s o u r c e
3245 ** CORE ( -- c-addr u )
3246 ** c-addr is the address of, and u is the number of characters in, the
3247 ** input buffer.
3248 **************************************************************************/
3249 static void source(FICL_VM *pVM)
3250 {
3251     stackPushPtr(pVM->pStack, pVM->tib.cp);
3252     stackPushINT(pVM->pStack, vmGetInBufLen(pVM));
3253     return;
3254 }
3255
3256
3257 /**************************************************************************
3258                         v e r s i o n
3259 ** non-standard...
3260 **************************************************************************/
3261 static void ficlVersion(FICL_VM *pVM)
3262 {
3263     vmTextOut(pVM, "ficl Version " FICL_VER, 1);
3264     return;
3265 }
3266
3267
3268 /**************************************************************************
3269                         t o I n
3270 ** to-in CORE
3271 **************************************************************************/
3272 static void toIn(FICL_VM *pVM)
3273 {
3274     stackPushPtr(pVM->pStack, &pVM->tib.index);
3275     return;
3276 }
3277
3278
3279 /**************************************************************************
3280                         d e f i n i t i o n s
3281 ** SEARCH ( -- )
3282 ** Make the compilation word list the same as the first word list in the
3283 ** search order. Specifies that the names of subsequent definitions will
3284 ** be placed in the compilation word list. Subsequent changes in the search
3285 ** order will not affect the compilation word list.
3286 **************************************************************************/
3287 static void definitions(FICL_VM *pVM)
3288 {
3289     FICL_DICT *pDict = ficlGetDict();
3290
3291     assert(pDict);
3292     if (pDict->nLists < 1)
3293     {
3294         vmThrowErr(pVM, "DEFINITIONS error - empty search order");
3295     }
3296
3297     pDict->pCompile = pDict->pSearch[pDict->nLists-1];
3298     return;
3299 }
3300
3301
3302 /**************************************************************************
3303                         f o r t h - w o r d l i s t
3304 ** SEARCH ( -- wid )
3305 ** Return wid, the identifier of the word list that includes all standard
3306 ** words provided by the implementation. This word list is initially the
3307 ** compilation word list and is part of the initial search order.
3308 **************************************************************************/
3309 static void forthWordlist(FICL_VM *pVM)
3310 {
3311     FICL_HASH *pHash = ficlGetDict()->pForthWords;
3312     stackPushPtr(pVM->pStack, pHash);
3313     return;
3314 }
3315
3316
3317 /**************************************************************************
3318                         g e t - c u r r e n t
3319 ** SEARCH ( -- wid )
3320 ** Return wid, the identifier of the compilation word list.
3321 **************************************************************************/
3322 static void getCurrent(FICL_VM *pVM)
3323 {
3324     ficlLockDictionary(TRUE);
3325     stackPushPtr(pVM->pStack, ficlGetDict()->pCompile);
3326     ficlLockDictionary(FALSE);
3327     return;
3328 }
3329
3330
3331 /**************************************************************************
3332                         g e t - o r d e r
3333 ** SEARCH ( -- widn ... wid1 n )
3334 ** Returns the number of word lists n in the search order and the word list
3335 ** identifiers widn ... wid1 identifying these word lists. wid1 identifies
3336 ** the word list that is searched first, and widn the word list that is
3337 ** searched last. The search order is unaffected.
3338 **************************************************************************/
3339 static void getOrder(FICL_VM *pVM)
3340 {
3341     FICL_DICT *pDict = ficlGetDict();
3342     int nLists = pDict->nLists;
3343     int i;
3344
3345     ficlLockDictionary(TRUE);
3346     for (i = 0; i < nLists; i++)
3347     {
3348         stackPushPtr(pVM->pStack, pDict->pSearch[i]);
3349     }
3350
3351     stackPushUNS(pVM->pStack, nLists);
3352     ficlLockDictionary(FALSE);
3353     return;
3354 }
3355
3356
3357 /**************************************************************************
3358                         s e a r c h - w o r d l i s t
3359 ** SEARCH ( c-addr u wid -- 0 | xt 1 | xt -1 )
3360 ** Find the definition identified by the string c-addr u in the word list
3361 ** identified by wid. If the definition is not found, return zero. If the
3362 ** definition is found, return its execution token xt and one (1) if the
3363 ** definition is immediate, minus-one (-1) otherwise.
3364 **************************************************************************/
3365 static void searchWordlist(FICL_VM *pVM)
3366 {
3367     STRINGINFO si;
3368     UNS16 hashCode;
3369     FICL_WORD *pFW;
3370     FICL_HASH *pHash = stackPopPtr(pVM->pStack);
3371
3372     si.count         = (FICL_COUNT)stackPopUNS(pVM->pStack);
3373     si.cp            = stackPopPtr(pVM->pStack);
3374     hashCode         = hashHashCode(si);
3375
3376     ficlLockDictionary(TRUE);
3377     pFW = hashLookup(pHash, si, hashCode);
3378     ficlLockDictionary(FALSE);
3379
3380     if (pFW)
3381     {
3382         stackPushPtr(pVM->pStack, pFW);
3383         stackPushINT(pVM->pStack, (wordIsImmediate(pFW) ? 1 : -1));
3384     }
3385     else
3386     {
3387         stackPushUNS(pVM->pStack, 0);
3388     }
3389
3390     return;
3391 }
3392
3393
3394 /**************************************************************************
3395                         s e t - c u r r e n t
3396 ** SEARCH ( wid -- )
3397 ** Set the compilation word list to the word list identified by wid.
3398 **************************************************************************/
3399 static void setCurrent(FICL_VM *pVM)
3400 {
3401     FICL_HASH *pHash = stackPopPtr(pVM->pStack);
3402     FICL_DICT *pDict = ficlGetDict();
3403     ficlLockDictionary(TRUE);
3404     pDict->pCompile = pHash;
3405     ficlLockDictionary(FALSE);
3406     return;
3407 }
3408
3409
3410 /**************************************************************************
3411                         s e t - o r d e r
3412 ** SEARCH ( widn ... wid1 n -- )
3413 ** Set the search order to the word lists identified by widn ... wid1.
3414 ** Subsequently, word list wid1 will be searched first, and word list
3415 ** widn searched last. If n is zero, empty the search order. If n is minus
3416 ** one, set the search order to the implementation-defined minimum
3417 ** search order. The minimum search order shall include the words
3418 ** FORTH-WORDLIST and SET-ORDER. A system shall allow n to
3419 ** be at least eight.
3420 **************************************************************************/
3421 static void setOrder(FICL_VM *pVM)
3422 {
3423     int i;
3424     int nLists = stackPopINT(pVM->pStack);
3425     FICL_DICT *dp = ficlGetDict();
3426
3427     if (nLists > FICL_DEFAULT_VOCS)
3428     {
3429         vmThrowErr(pVM, "set-order error: list would be too large");
3430     }
3431
3432     ficlLockDictionary(TRUE);
3433
3434     if (nLists >= 0)
3435     {
3436         dp->nLists = nLists;
3437         for (i = nLists-1; i >= 0; --i)
3438         {
3439             dp->pSearch[i] = stackPopPtr(pVM->pStack);
3440         }
3441     }
3442     else
3443     {
3444         dictResetSearchOrder(dp);
3445     }
3446
3447     ficlLockDictionary(FALSE);
3448     return;
3449 }
3450
3451
3452 /**************************************************************************
3453                         w o r d l i s t
3454 ** SEARCH ( -- wid )
3455 ** Create a new empty word list, returning its word list identifier wid.
3456 ** The new word list may be returned from a pool of preallocated word
3457 ** lists or may be dynamically allocated in data space. A system shall
3458 ** allow the creation of at least 8 new word lists in addition to any
3459 ** provided as part of the system.
3460 ** Notes:
3461 ** 1. ficl creates a new single-list hash in the dictionary and returns
3462 **    its address.
3463 ** 2. ficl-wordlist takes an arg off the stack indicating the number of
3464 **    hash entries in the wordlist. Ficl 2.02 and later define WORDLIST as
3465 **    : wordlist 1 ficl-wordlist ;
3466 **************************************************************************/
3467 static void wordlist(FICL_VM *pVM)
3468 {
3469     FICL_DICT *dp = ficlGetDict();
3470     FICL_HASH *pHash;
3471     FICL_UNS nBuckets;
3472
3473 #if FICL_ROBUST > 1
3474     vmCheckStack(pVM, 1, 1);
3475 #endif
3476     nBuckets = stackPopUNS(pVM->pStack);
3477
3478     dictAlign(dp);
3479     pHash    = (FICL_HASH *)dp->here;
3480     dictAllot(dp, sizeof (FICL_HASH)
3481         + (nBuckets-1) * sizeof (FICL_WORD *));
3482
3483     pHash->size = nBuckets;
3484     hashReset(pHash);
3485
3486     stackPushPtr(pVM->pStack, pHash);
3487     return;
3488 }
3489
3490
3491 /**************************************************************************
3492                         S E A R C H >
3493 ** ficl  ( -- wid )
3494 ** Pop wid off the search order. Error if the search order is empty
3495 **************************************************************************/
3496 static void searchPop(FICL_VM *pVM)
3497 {
3498     FICL_DICT *dp = ficlGetDict();
3499     int nLists;
3500
3501     ficlLockDictionary(TRUE);
3502     nLists = dp->nLists;
3503     if (nLists == 0)
3504     {
3505         vmThrowErr(pVM, "search> error: empty search order");
3506     }
3507     stackPushPtr(pVM->pStack, dp->pSearch[--dp->nLists]);
3508     ficlLockDictionary(FALSE);
3509     return;
3510 }
3511
3512
3513 /**************************************************************************
3514                         > S E A R C H
3515 ** ficl  ( wid -- )
3516 ** Push wid onto the search order. Error if the search order is full.
3517 **************************************************************************/
3518 static void searchPush(FICL_VM *pVM)
3519 {
3520     FICL_DICT *dp = ficlGetDict();
3521
3522     ficlLockDictionary(TRUE);
3523     if (dp->nLists > FICL_DEFAULT_VOCS)
3524     {
3525         vmThrowErr(pVM, ">search error: search order overflow");
3526     }
3527     dp->pSearch[dp->nLists++] = stackPopPtr(pVM->pStack);
3528     ficlLockDictionary(FALSE);
3529     return;
3530 }
3531
3532
3533 /**************************************************************************
3534                         c o l o n N o N a m e
3535 ** CORE EXT ( C:  -- colon-sys )  ( S:  -- xt )
3536 ** Create an unnamed colon definition and push its address.
3537 ** Change state to compile.
3538 **************************************************************************/
3539 static void colonNoName(FICL_VM *pVM)
3540 {
3541     FICL_DICT *dp = ficlGetDict();
3542     FICL_WORD *pFW;
3543     STRINGINFO si;
3544
3545     SI_SETLEN(si, 0);
3546     SI_SETPTR(si, NULL);
3547
3548     pVM->state = COMPILE;
3549     pFW = dictAppendWord2(dp, si, colonParen, FW_DEFAULT | FW_SMUDGE);
3550     stackPushPtr(pVM->pStack, pFW);
3551     markControlTag(pVM, colonTag);
3552     return;
3553 }
3554
3555
3556 /**************************************************************************
3557                         u s e r   V a r i a b l e
3558 ** user  ( u -- )  "<spaces>name"
3559 ** Get a name from the input stream and create a user variable
3560 ** with the name and the index supplied. The run-time effect
3561 ** of a user variable is to push the address of the indexed cell
3562 ** in the running vm's user array.
3563 **
3564 ** User variables are vm local cells. Each vm has an array of
3565 ** FICL_USER_CELLS of them when FICL_WANT_USER is nonzero.
3566 ** Ficl's user facility is implemented with two primitives,
3567 ** "user" and "(user)", a variable ("nUser") (in softcore.c) that
3568 ** holds the index of the next free user cell, and a redefinition
3569 ** (also in softcore) of "user" that defines a user word and increments
3570 ** nUser.
3571 **************************************************************************/
3572 #if FICL_WANT_USER
3573 static void userParen(FICL_VM *pVM)
3574 {
3575     FICL_INT i = pVM->runningWord->param[0].i;
3576     stackPushPtr(pVM->pStack, &pVM->user[i]);
3577     return;
3578 }
3579
3580
3581 static void userVariable(FICL_VM *pVM)
3582 {
3583     FICL_DICT *dp = ficlGetDict();
3584     STRINGINFO si = vmGetWord(pVM);
3585     CELL c;
3586
3587     c = stackPop(pVM->pStack);
3588     if (c.i >= FICL_USER_CELLS)
3589     {
3590         vmThrowErr(pVM, "Error - out of user space");
3591     }
3592
3593     dictAppendWord2(dp, si, userParen, FW_DEFAULT);
3594     dictAppendCell(dp, c);
3595     return;
3596 }
3597 #endif
3598
3599
3600 /**************************************************************************
3601                         t o V a l u e
3602 ** CORE EXT
3603 ** Interpretation: ( x "<spaces>name" -- )
3604 ** Skip leading spaces and parse name delimited by a space. Store x in
3605 ** name. An ambiguous condition exists if name was not defined by VALUE.
3606 ** NOTE: In ficl, VALUE is an alias of CONSTANT
3607 **************************************************************************/
3608 static void toValue(FICL_VM *pVM)
3609 {
3610     STRINGINFO si = vmGetWord(pVM);
3611     FICL_DICT *dp = ficlGetDict();
3612     FICL_WORD *pFW;
3613
3614 #if FICL_WANT_LOCALS
3615     if ((nLocals > 0) && (pVM->state == COMPILE))
3616     {
3617         FICL_DICT *pLoc = ficlGetLoc();
3618         pFW = dictLookup(pLoc, si);
3619         if (pFW && (pFW->code == doLocalIm))
3620         {
3621             dictAppendCell(dp, LVALUEtoCELL(pToLocalParen));
3622             dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3623             return;
3624         }
3625                 else if (pFW && pFW->code == do2LocalIm)
3626                 {
3627             dictAppendCell(dp, LVALUEtoCELL(pTo2LocalParen));
3628             dictAppendCell(dp, LVALUEtoCELL(pFW->param[0]));
3629             return;
3630                 }
3631     }
3632 #endif
3633
3634     assert(pStore);
3635
3636     pFW = dictLookup(dp, si);
3637     if (!pFW)
3638     {
3639         int i = SI_COUNT(si);
3640         vmThrowErr(pVM, "%.*s not found", i, SI_PTR(si));
3641     }
3642
3643     if (pVM->state == INTERPRET)
3644         pFW->param[0] = stackPop(pVM->pStack);
3645     else        /* compile code to store to word's param */
3646     {
3647         stackPushPtr(pVM->pStack, &pFW->param[0]);
3648         literalIm(pVM);
3649         dictAppendCell(dp, LVALUEtoCELL(pStore));
3650     }
3651     return;
3652 }
3653
3654
3655 #if FICL_WANT_LOCALS
3656 /**************************************************************************
3657                         l i n k P a r e n
3658 ** ( -- )
3659 ** Link a frame on the return stack, reserving nCells of space for
3660 ** locals - the value of nCells is the next cell in the instruction
3661 ** stream.
3662 **************************************************************************/
3663 static void linkParen(FICL_VM *pVM)
3664 {
3665     FICL_INT nLink = *(FICL_INT *)(pVM->ip);
3666     vmBranchRelative(pVM, 1);
3667     stackLink(pVM->rStack, nLink);
3668     return;
3669 }
3670
3671
3672 static void unlinkParen(FICL_VM *pVM)
3673 {
3674     stackUnlink(pVM->rStack);
3675     return;
3676 }
3677
3678
3679 /**************************************************************************
3680                         d o L o c a l I m
3681 ** Immediate - cfa of a local while compiling - when executed, compiles
3682 ** code to fetch the value of a local given the local's index in the
3683 ** word's pfa
3684 **************************************************************************/
3685 static void getLocalParen(FICL_VM *pVM)
3686 {
3687     FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3688     stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3689     return;
3690 }
3691
3692
3693 static void toLocalParen(FICL_VM *pVM)
3694 {
3695     FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3696     pVM->rStack->pFrame[nLocal] = stackPop(pVM->pStack);
3697     return;
3698 }
3699
3700
3701 static void getLocal0(FICL_VM *pVM)
3702 {
3703     stackPush(pVM->pStack, pVM->rStack->pFrame[0]);
3704     return;
3705 }
3706
3707
3708 static void toLocal0(FICL_VM *pVM)
3709 {
3710     pVM->rStack->pFrame[0] = stackPop(pVM->pStack);
3711     return;
3712 }
3713
3714
3715 static void getLocal1(FICL_VM *pVM)
3716 {
3717     stackPush(pVM->pStack, pVM->rStack->pFrame[1]);
3718     return;
3719 }
3720
3721
3722 static void toLocal1(FICL_VM *pVM)
3723 {
3724     pVM->rStack->pFrame[1] = stackPop(pVM->pStack);
3725     return;
3726 }
3727
3728
3729 /*
3730 ** Each local is recorded in a private locals dictionary as a
3731 ** word that does doLocalIm at runtime. DoLocalIm compiles code
3732 ** into the client definition to fetch the value of the
3733 ** corresponding local variable from the return stack.
3734 ** The private dictionary gets initialized at the end of each block
3735 ** that uses locals (in ; and does> for example).
3736 */
3737 static void doLocalIm(FICL_VM *pVM)
3738 {
3739     FICL_DICT *pDict = ficlGetDict();
3740     int nLocal = pVM->runningWord->param[0].i;
3741
3742     if (pVM->state == INTERPRET)
3743     {
3744         stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3745     }
3746     else
3747     {
3748
3749         if (nLocal == 0)
3750         {
3751             dictAppendCell(pDict, LVALUEtoCELL(pGetLocal0));
3752         }
3753         else if (nLocal == 1)
3754         {
3755             dictAppendCell(pDict, LVALUEtoCELL(pGetLocal1));
3756         }
3757         else
3758         {
3759             dictAppendCell(pDict, LVALUEtoCELL(pGetLocalParen));
3760             dictAppendCell(pDict, LVALUEtoCELL(nLocal));
3761         }
3762     }
3763     return;
3764 }
3765
3766
3767 /**************************************************************************
3768                         l o c a l P a r e n
3769 ** paren-local-paren LOCAL
3770 ** Interpretation: Interpretation semantics for this word are undefined.
3771 ** Execution: ( c-addr u -- )
3772 ** When executed during compilation, (LOCAL) passes a message to the
3773 ** system that has one of two meanings. If u is non-zero,
3774 ** the message identifies a new local whose definition name is given by
3775 ** the string of characters identified by c-addr u. If u is zero,
3776 ** the message is last local and c-addr has no significance.
3777 **
3778 ** The result of executing (LOCAL) during compilation of a definition is
3779 ** to create a set of named local identifiers, each of which is
3780 ** a definition name, that only have execution semantics within the scope
3781 ** of that definition's source.
3782 **
3783 ** local Execution: ( -- x )
3784 **
3785 ** Push the local's value, x, onto the stack. The local's value is
3786 ** initialized as described in 13.3.3 Processing locals and may be
3787 ** changed by preceding the local's name with TO. An ambiguous condition
3788 ** exists when local is executed while in interpretation state.
3789 **************************************************************************/
3790 static void localParen(FICL_VM *pVM)
3791 {
3792     FICL_DICT *pDict = ficlGetDict();
3793     STRINGINFO si;
3794     SI_SETLEN(si, stackPopUNS(pVM->pStack));
3795     SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
3796
3797     if (SI_COUNT(si) > 0)
3798     {   /* add a local to the **locals** dict and update nLocals */
3799         FICL_DICT *pLoc = ficlGetLoc();
3800         if (nLocals >= FICL_MAX_LOCALS)
3801         {
3802             vmThrowErr(pVM, "Error: out of local space");
3803         }
3804
3805         dictAppendWord2(pLoc, si, doLocalIm, FW_COMPIMMED);
3806         dictAppendCell(pLoc,  LVALUEtoCELL(nLocals));
3807
3808         if (nLocals == 0)
3809         {   /* compile code to create a local stack frame */
3810             dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
3811             /* save location in dictionary for #locals */
3812             pMarkLocals = pDict->here;
3813             dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3814             /* compile code to initialize first local */
3815             dictAppendCell(pDict, LVALUEtoCELL(pToLocal0));
3816         }
3817         else if (nLocals == 1)
3818         {
3819             dictAppendCell(pDict, LVALUEtoCELL(pToLocal1));
3820         }
3821         else
3822         {
3823             dictAppendCell(pDict, LVALUEtoCELL(pToLocalParen));
3824             dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3825         }
3826
3827         nLocals++;
3828     }
3829     else if (nLocals > 0)
3830     {       /* write nLocals to (link) param area in dictionary */
3831         *(FICL_INT *)pMarkLocals = nLocals;
3832     }
3833
3834     return;
3835 }
3836
3837
3838 static void get2LocalParen(FICL_VM *pVM)
3839 {
3840     FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3841     stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3842     stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
3843     return;
3844 }
3845
3846
3847 static void do2LocalIm(FICL_VM *pVM)
3848 {
3849     FICL_DICT *pDict = ficlGetDict();
3850     int nLocal = pVM->runningWord->param[0].i;
3851
3852     if (pVM->state == INTERPRET)
3853     {
3854         stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal]);
3855         stackPush(pVM->pStack, pVM->rStack->pFrame[nLocal+1]);
3856     }
3857     else
3858     {
3859         dictAppendCell(pDict, LVALUEtoCELL(pGet2LocalParen));
3860         dictAppendCell(pDict, LVALUEtoCELL(nLocal));
3861     }
3862     return;
3863 }
3864
3865
3866 static void to2LocalParen(FICL_VM *pVM)
3867 {
3868     FICL_INT nLocal = *(FICL_INT *)(pVM->ip++);
3869     pVM->rStack->pFrame[nLocal+1] = stackPop(pVM->pStack);
3870     pVM->rStack->pFrame[nLocal]   = stackPop(pVM->pStack);
3871     return;
3872 }
3873
3874
3875 static void twoLocalParen(FICL_VM *pVM)
3876 {
3877     FICL_DICT *pDict = ficlGetDict();
3878     STRINGINFO si;
3879     SI_SETLEN(si, stackPopUNS(pVM->pStack));
3880     SI_SETPTR(si, (char *)stackPopPtr(pVM->pStack));
3881
3882     if (SI_COUNT(si) > 0)
3883     {   /* add a local to the **locals** dict and update nLocals */
3884         FICL_DICT *pLoc = ficlGetLoc();
3885         if (nLocals >= FICL_MAX_LOCALS)
3886         {
3887             vmThrowErr(pVM, "Error: out of local space");
3888         }
3889
3890         dictAppendWord2(pLoc, si, do2LocalIm, FW_COMPIMMED);
3891         dictAppendCell(pLoc,  LVALUEtoCELL(nLocals));
3892
3893         if (nLocals == 0)
3894         {   /* compile code to create a local stack frame */
3895             dictAppendCell(pDict, LVALUEtoCELL(pLinkParen));
3896             /* save location in dictionary for #locals */
3897             pMarkLocals = pDict->here;
3898             dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3899         }
3900
3901                 dictAppendCell(pDict, LVALUEtoCELL(pTo2LocalParen));
3902         dictAppendCell(pDict, LVALUEtoCELL(nLocals));
3903
3904         nLocals += 2;
3905     }
3906     else if (nLocals > 0)
3907     {       /* write nLocals to (link) param area in dictionary */
3908         *(FICL_INT *)pMarkLocals = nLocals;
3909     }
3910
3911     return;
3912 }
3913
3914
3915 #endif
3916 /**************************************************************************
3917                         setParentWid
3918 ** FICL
3919 ** setparentwid   ( parent-wid wid -- )
3920 ** Set WID's link field to the parent-wid. search-wordlist will
3921 ** iterate through all the links when finding words in the child wid.
3922 **************************************************************************/
3923 static void setParentWid(FICL_VM *pVM)
3924 {
3925     FICL_HASH *parent, *child;
3926 #if FICL_ROBUST > 1
3927     vmCheckStack(pVM, 2, 0);
3928 #endif
3929     child  = (FICL_HASH *)stackPopPtr(pVM->pStack);
3930     parent = (FICL_HASH *)stackPopPtr(pVM->pStack);
3931
3932     child->link = parent;
3933     return;
3934 }
3935
3936
3937 /**************************************************************************
3938                         s e e
3939 ** TOOLS ( "<spaces>name" -- )
3940 ** Display a human-readable representation of the named word's definition.
3941 ** The source of the representation (object-code decompilation, source
3942 ** block, etc.) and the particular form of the display is implementation
3943 ** defined.
3944 ** NOTE: these funcs come late in the file because they reference all
3945 ** of the word-builder funcs without declaring them again. Call me lazy.
3946 **************************************************************************/
3947 /*
3948 ** isAFiclWord
3949 ** Vet a candidate pointer carefully to make sure
3950 ** it's not some chunk o' inline data...
3951 ** It has to have a name, and it has to look
3952 ** like it's in the dictionary address range.
3953 ** NOTE: this excludes :noname words!
3954 */
3955 static int isAFiclWord(FICL_WORD *pFW)
3956 {
3957     FICL_DICT *pd  = ficlGetDict();
3958
3959     if (!dictIncludes(pd, pFW))
3960        return 0;
3961
3962     if (!dictIncludes(pd, pFW->name))
3963         return 0;
3964
3965     return ((pFW->nName > 0) && (pFW->name[pFW->nName] == '\0'));
3966 }
3967
3968 /*
3969 ** seeColon (for proctologists only)
3970 ** Walks a colon definition, decompiling
3971 ** on the fly. Knows about primitive control structures.
3972 */
3973 static void seeColon(FICL_VM *pVM, CELL *pc)
3974 {
3975     for (; pc->p != pSemiParen; pc++)
3976     {
3977         FICL_WORD *pFW = (FICL_WORD *)(pc->p);
3978
3979         if (isAFiclWord(pFW))
3980         {
3981             if      (pFW->code == literalParen)
3982             {
3983                 CELL v = *++pc;
3984                 if (isAFiclWord(v.p))
3985                 {
3986                     FICL_WORD *pLit = (FICL_WORD *)v.p;
3987                     sprintf(pVM->pad, "    literal %.*s (%#lx)",
3988                         pLit->nName, pLit->name, v.u);
3989                 }
3990                 else
3991                     sprintf(pVM->pad, "    literal %ld (%#lx)", v.i, v.u);
3992             }
3993             else if (pFW->code == stringLit)
3994             {
3995                 FICL_STRING *sp = (FICL_STRING *)(void *)++pc;
3996                 pc = (CELL *)alignPtr(sp->text + sp->count + 1) - 1;
3997                 sprintf(pVM->pad, "    s\" %.*s\"", sp->count, sp->text);
3998             }
3999             else if (pFW->code == ifParen)
4000             {
4001                 CELL c = *++pc;
4002                 if (c.i > 0)
4003                     sprintf(pVM->pad, "    if / while (branch rel %ld)", c.i);
4004                 else
4005                     sprintf(pVM->pad, "    until (branch rel %ld)", c.i);
4006             }
4007             else if (pFW->code == branchParen)
4008             {
4009                 CELL c = *++pc;
4010                 if (c.i > 0)
4011                     sprintf(pVM->pad, "    else (branch rel %ld)", c.i);
4012                 else
4013                     sprintf(pVM->pad, "    repeat (branch rel %ld)", c.i);
4014             }
4015             else if (pFW->code == qDoParen)
4016             {
4017                 CELL c = *++pc;
4018                 sprintf(pVM->pad, "    ?do (leave abs %#lx)", c.u);
4019             }
4020             else if (pFW->code == doParen)
4021             {
4022                 CELL c = *++pc;
4023                 sprintf(pVM->pad, "    do (leave abs %#lx)", c.u);
4024             }
4025             else if (pFW->code == loopParen)
4026             {
4027                 CELL c = *++pc;
4028                 sprintf(pVM->pad, "    loop (branch rel %#ld)", c.i);
4029             }
4030             else if (pFW->code == plusLoopParen)
4031             {
4032                 CELL c = *++pc;
4033                 sprintf(pVM->pad, "    +loop (branch rel %#ld)", c.i);
4034             }
4035             else /* default: print word's name */
4036             {
4037                 sprintf(pVM->pad, "    %.*s", pFW->nName, pFW->name);
4038             }
4039
4040             vmTextOut(pVM, pVM->pad, 1);
4041         }
4042         else /* probably not a word - punt and print value */
4043         {
4044             sprintf(pVM->pad, "    %ld (%#lx)", pc->i, pc->u);
4045             vmTextOut(pVM, pVM->pad, 1);
4046         }
4047     }
4048
4049     vmTextOut(pVM, ";", 1);
4050 }
4051
4052 /*
4053 ** Here's the outer part of the decompiler. It's
4054 ** just a big nested conditional that checks the
4055 ** CFA of the word to decompile for each kind of
4056 ** known word-builder code, and tries to do
4057 ** something appropriate. If the CFA is not recognized,
4058 ** just indicate that it is a primitive.
4059 */
4060 static void see(FICL_VM *pVM)
4061 {
4062     FICL_WORD *pFW;
4063
4064     tick(pVM);
4065     pFW = (FICL_WORD *)stackPopPtr(pVM->pStack);
4066
4067     if (pFW->code == colonParen)
4068     {
4069         sprintf(pVM->pad, ": %.*s", pFW->nName, pFW->name);
4070         vmTextOut(pVM, pVM->pad, 1);
4071         seeColon(pVM, pFW->param);
4072     }
4073     else if (pFW->code == doDoes)
4074     {
4075         vmTextOut(pVM, "does>", 1);
4076         seeColon(pVM, (CELL *)pFW->param->p);
4077     }
4078     else if (pFW->code ==  createParen)
4079     {
4080         vmTextOut(pVM, "create", 1);
4081     }
4082     else if (pFW->code == variableParen)
4083     {
4084         sprintf(pVM->pad, "variable = %ld (%#lx)",
4085             pFW->param->i, pFW->param->u);
4086         vmTextOut(pVM, pVM->pad, 1);
4087     }
4088     else if (pFW->code == userParen)
4089     {
4090         sprintf(pVM->pad, "user variable %ld (%#lx)",
4091             pFW->param->i, pFW->param->u);
4092         vmTextOut(pVM, pVM->pad, 1);
4093     }
4094     else if (pFW->code == constantParen)
4095     {
4096         sprintf(pVM->pad, "constant = %ld (%#lx)",
4097             pFW->param->i, pFW->param->u);
4098         vmTextOut(pVM, pVM->pad, 1);
4099     }
4100     else
4101     {
4102         vmTextOut(pVM, "primitive", 1);
4103     }
4104
4105     if (pFW->flags & FW_IMMEDIATE)
4106     {
4107         vmTextOut(pVM, "immediate", 1);
4108     }
4109
4110     return;
4111 }
4112
4113
4114 /**************************************************************************
4115                         c o m p a r e
4116 ** STRING ( c-addr1 u1 c-addr2 u2 -- n )
4117 ** Compare the string specified by c-addr1 u1 to the string specified by
4118 ** c-addr2 u2. The strings are compared, beginning at the given addresses,
4119 ** character by character, up to the length of the shorter string or until a
4120 ** difference is found. If the two strings are identical, n is zero. If the two
4121 ** strings are identical up to the length of the shorter string, n is minus-one
4122 ** (-1) if u1 is less than u2 and one (1) otherwise. If the two strings are not
4123 ** identical up to the length of the shorter string, n is minus-one (-1) if the
4124 ** first non-matching character in the string specified by c-addr1 u1 has a
4125 ** lesser numeric value than the corresponding character in the string specified
4126 ** by c-addr2 u2 and one (1) otherwise.
4127 **************************************************************************/
4128 static void compareString(FICL_VM *pVM)
4129 {
4130     char *cp1, *cp2;
4131     FICL_UNS u1, u2, uMin;
4132     int n = 0;
4133
4134     vmCheckStack(pVM, 4, 1);
4135     u2  = stackPopUNS(pVM->pStack);
4136     cp2 = (char *)stackPopPtr(pVM->pStack);
4137     u1  = stackPopUNS(pVM->pStack);
4138     cp1 = (char *)stackPopPtr(pVM->pStack);
4139
4140     uMin = (u1 < u2)? u1 : u2;
4141     for ( ; (uMin > 0) && (n == 0); uMin--)
4142     {
4143         n = (int)(*cp1++ - *cp2++);
4144     }
4145
4146     if (n == 0)
4147         n = (int)(u1 - u2);
4148
4149     if (n < 0)
4150         n = -1;
4151     else if (n > 0)
4152         n = 1;
4153
4154     stackPushINT(pVM->pStack, n);
4155     return;
4156 }
4157
4158
4159 /**************************************************************************
4160                         s o u r c e - i d
4161 ** CORE EXT, FILE   ( -- 0 | -1 | fileid )
4162 **    Identifies the input source as follows:
4163 **
4164 ** SOURCE-ID       Input source
4165 ** ---------       ------------
4166 ** fileid          Text file fileid
4167 ** -1              String (via EVALUATE)
4168 ** 0               User input device
4169 **************************************************************************/
4170 static void sourceid(FICL_VM *pVM)
4171 {
4172     stackPushINT(pVM->pStack, pVM->sourceID.i);
4173     return;
4174 }
4175
4176
4177 /**************************************************************************
4178                         r e f i l l
4179 ** CORE EXT   ( -- flag )
4180 ** Attempt to fill the input buffer from the input source, returning a true
4181 ** flag if successful.
4182 ** When the input source is the user input device, attempt to receive input
4183 ** into the terminal input buffer. If successful, make the result the input
4184 ** buffer, set >IN to zero, and return true. Receipt of a line containing no
4185 ** characters is considered successful. If there is no input available from
4186 ** the current input source, return false.
4187 ** When the input source is a string from EVALUATE, return false and
4188 ** perform no other action.
4189 **************************************************************************/
4190 static void refill(FICL_VM *pVM)
4191 {
4192     static int tries = 0;
4193
4194     FICL_INT ret = (pVM->sourceID.i == -1) ? FICL_FALSE : FICL_TRUE;
4195     if (ret && tries == 0) {
4196         tries = 1;
4197         vmThrow(pVM, VM_RESTART);
4198     }
4199     if (tries == 1)
4200         tries = 0;
4201     stackPushINT(pVM->pStack, ret);
4202     return;
4203 }
4204
4205
4206 /**************************************************************************
4207                         f o r g e t
4208 ** TOOLS EXT  ( "<spaces>name" -- )
4209 ** Skip leading space delimiters. Parse name delimited by a space.
4210 ** Find name, then delete name from the dictionary along with all
4211 ** words added to the dictionary after name. An ambiguous
4212 ** condition exists if name cannot be found.
4213 **
4214 ** If the Search-Order word set is present, FORGET searches the
4215 ** compilation word list. An ambiguous condition exists if the
4216 ** compilation word list is deleted.
4217 **************************************************************************/
4218 static void forgetWid(FICL_VM *pVM)
4219 {
4220     FICL_DICT *pDict = ficlGetDict();
4221     FICL_HASH *pHash;
4222
4223     pHash = (FICL_HASH *)stackPopPtr(pVM->pStack);
4224     hashForget(pHash, pDict->here);
4225
4226     return;
4227 }
4228
4229
4230 static void forget(FICL_VM *pVM)
4231 {
4232     void *where;
4233     FICL_DICT *pDict = ficlGetDict();
4234     FICL_HASH *pHash = pDict->pCompile;
4235
4236     tick(pVM);
4237     where = ((FICL_WORD *)stackPopPtr(pVM->pStack))->name;
4238     hashForget(pHash, where);
4239     pDict->here = PTRtoCELL where;
4240
4241     return;
4242 }
4243
4244 /************************* freebsd added I/O words **************************/
4245
4246 /*          fopen - open a file and return new fd on stack.
4247  *
4248  * fopen ( count ptr  -- fd )
4249  */
4250 static void pfopen(FICL_VM *pVM)
4251 {
4252     int     fd;
4253     char    *p;
4254
4255 #if FICL_ROBUST > 1
4256     vmCheckStack(pVM, 2, 1);
4257 #endif
4258     (void)stackPopINT(pVM->pStack); /* don't need count value */
4259     p = stackPopPtr(pVM->pStack);
4260     fd = open(p, O_RDWR);
4261     stackPushINT(pVM->pStack, fd);
4262     return;
4263 }
4264
4265 /*          fclose - close a file who's fd is on stack.
4266  *
4267  * fclose ( fd -- )
4268  */
4269 static void pfclose(FICL_VM *pVM)
4270 {
4271     int fd;
4272
4273 #if FICL_ROBUST > 1
4274     vmCheckStack(pVM, 1, 0);
4275 #endif
4276     fd = stackPopINT(pVM->pStack); /* get fd */
4277     if (fd != -1)
4278         close(fd);
4279     return;
4280 }
4281
4282 /*          fread - read file contents
4283  *
4284  * fread  ( fd buf nbytes  -- nread )
4285  */
4286 static void pfread(FICL_VM *pVM)
4287 {
4288     int     fd, len;
4289     char *buf;
4290
4291 #if FICL_ROBUST > 1
4292     vmCheckStack(pVM, 3, 1);
4293 #endif
4294     len = stackPopINT(pVM->pStack); /* get number of bytes to read */
4295     buf = stackPopPtr(pVM->pStack); /* get buffer */
4296     fd = stackPopINT(pVM->pStack); /* get fd */
4297     if (len > 0 && buf && fd != -1)
4298         stackPushINT(pVM->pStack, read(fd, buf, len));
4299     else
4300         stackPushINT(pVM->pStack, -1);
4301     return;
4302 }
4303
4304 /*          fwrite - write file contents
4305  *
4306  * fwrite  ( fd buf nbytes  -- nwritten )
4307  */
4308 static void pfwrite(FICL_VM *pVM)
4309 {
4310     int     fd, len;
4311     char *buf;
4312 #if FICL_ROBUST > 1
4313     vmCheckStack(pVM, 3, 1);
4314 #endif
4315     len = stackPopINT(pVM->pStack); /* get number of bytes to write */
4316     buf = stackPopPtr(pVM->pStack); /* get buffer */
4317     fd = stackPopINT(pVM->pStack); /* get fd */
4318     if (len > 0 && buf && fd != -1)
4319       stackPushINT(pVM->pStack, write(fd, buf, len));
4320     else
4321       stackPushINT(pVM->pStack, -1);
4322     return;
4323 }
4324 /*          flseek - seek to file offset
4325  *
4326  * flseek  ( fd offset whence  -- whence )
4327  */
4328 static void pflseek(FICL_VM *pVM)
4329 {
4330     int     fd, whence, offset;
4331 #if FICL_ROBUST > 1
4332     vmCheckStack(pVM, 3, 1);
4333 #endif
4334     whence = stackPopINT(pVM->pStack); /* get whence */
4335     offset = stackPopINT(pVM->pStack); /* get offset */
4336     fd = stackPopINT(pVM->pStack); /* get fd */
4337     if (whence >= 0 && whence <= 2 && offset >= 0 && fd != -1)
4338       stackPushINT(pVM->pStack, lseek(fd, offset, whence));
4339     else
4340       stackPushINT(pVM->pStack, -1);
4341     return;
4342 }
4343 /*          fload - interpret file contents
4344  *
4345  * fload  ( fd -- )
4346  */
4347 static void pfload(FICL_VM *pVM)
4348 {
4349     int     fd;
4350
4351 #if FICL_ROBUST > 1
4352     vmCheckStack(pVM, 1, 0);
4353 #endif
4354     fd = stackPopINT(pVM->pStack); /* get fd */
4355     if (fd != -1)
4356         ficlExecFD(pVM, fd);
4357     return;
4358 }
4359
4360 /*           key - get a character from stdin
4361  *
4362  * key ( -- char )
4363  */
4364 static void key(FICL_VM *pVM)
4365 {
4366 #if FICL_ROBUST > 1
4367     vmCheckStack(pVM, 0, 1);
4368 #endif
4369     stackPushINT(pVM->pStack, getchar());
4370     return;
4371 }
4372
4373 /*           key? - check for a character from stdin (FACILITY)
4374  *
4375  * key? ( -- flag )
4376  */
4377 static void keyQuestion(FICL_VM *pVM)
4378 {
4379 #if FICL_ROBUST > 1
4380     vmCheckStack(pVM, 0, 1);
4381 #endif
4382 #ifdef TESTMAIN
4383     /* XXX Since we don't fiddle with termios, let it always succeed... */
4384     stackPushINT(pVM->pStack, FICL_TRUE);
4385 #else
4386     /* But here do the right thing. */
4387     stackPushINT(pVM->pStack, ischar()? FICL_TRUE : FICL_FALSE);
4388 #endif
4389     return;
4390 }
4391
4392 /* seconds - gives number of seconds since beginning of time
4393  *
4394  * beginning of time is defined as:
4395  *
4396  *      BTX     - number of seconds since midnight
4397  *      FreeBSD - number of seconds since Jan 1 1970
4398  *
4399  * seconds ( -- u )
4400  */
4401 static void pseconds(FICL_VM *pVM)
4402 {
4403 #if FICL_ROBUST > 1
4404     vmCheckStack(pVM,0,1);
4405 #endif
4406     stackPushUNS(pVM->pStack, (FICL_UNS) time(NULL));
4407     return;
4408 }
4409
4410 /* ms - wait at least that many milliseconds (FACILITY)
4411  *
4412  * ms ( u -- )
4413  *
4414  */
4415 static void ms(FICL_VM *pVM)
4416 {
4417 #if FICL_ROBUST > 1
4418     vmCheckStack(pVM,1,0);
4419 #endif
4420 #ifdef TESTMAIN
4421     usleep(stackPopUNS(pVM->pStack)*1000);
4422 #else
4423     delay(stackPopUNS(pVM->pStack)*1000);
4424 #endif
4425     return;
4426 }
4427
4428 /*           fkey - get a character from a file
4429  *
4430  * fkey ( file -- char )
4431  */
4432 static void fkey(FICL_VM *pVM)
4433 {
4434     int i, fd;
4435     char ch;
4436
4437 #if FICL_ROBUST > 1
4438     vmCheckStack(pVM, 1, 1);
4439 #endif
4440     fd = stackPopINT(pVM->pStack);
4441     i = read(fd, &ch, 1);
4442     stackPushINT(pVM->pStack, i > 0 ? ch : -1);
4443     return;
4444 }
4445
4446 /**************************************************************************
4447                         freebsd exception handling words
4448 ** Catch, from ANS Forth standard. Installs a safety net, then EXECUTE
4449 ** the word in ToS. If an exception happens, restore the state to what
4450 ** it was before, and pushes the exception value on the stack. If not,
4451 ** push zero.
4452 **
4453 ** Notice that Catch implements an inner interpreter. This is ugly,
4454 ** but given how ficl works, it cannot be helped. The problem is that
4455 ** colon definitions will be executed *after* the function returns,
4456 ** while "code" definitions will be executed immediately. I considered
4457 ** other solutions to this problem, but all of them shared the same
4458 ** basic problem (with added disadvantages): if ficl ever changes it's
4459 ** inner thread modus operandi, one would have to fix this word.
4460 **
4461 ** More comments can be found throughout catch's code.
4462 **
4463 ** Daniel C. Sobral Jan 09/1999
4464 ** sadler may 2000 -- revised to follow ficl.c:ficlExecXT.
4465 **************************************************************************/
4466
4467 static void ficlCatch(FICL_VM *pVM)
4468 {
4469     static FICL_WORD *pQuit = NULL;
4470
4471     int         except;
4472     jmp_buf     vmState;
4473     FICL_VM     VM;
4474     FICL_STACK  pStack;
4475     FICL_STACK  rStack;
4476     FICL_WORD   *pFW;
4477
4478     if (!pQuit)
4479         pQuit = ficlLookup("exit-inner");
4480
4481     assert(pVM);
4482     assert(pQuit);
4483
4484
4485     /*
4486     ** Get xt.
4487     ** We need this *before* we save the stack pointer, or
4488     ** we'll have to pop one element out of the stack after
4489     ** an exception. I prefer to get done with it up front. :-)
4490     */
4491 #if FICL_ROBUST > 1
4492     vmCheckStack(pVM, 1, 0);
4493 #endif
4494     pFW = stackPopPtr(pVM->pStack);
4495
4496     /*
4497     ** Save vm's state -- a catch will not back out environmental
4498     ** changes.
4499     **
4500     ** We are *not* saving dictionary state, since it is
4501     ** global instead of per vm, and we are not saving
4502     ** stack contents, since we are not required to (and,
4503     ** thus, it would be useless). We save pVM, and pVM
4504     ** "stacks" (a structure containing general information
4505     ** about it, including the current stack pointer).
4506     */
4507     memcpy((void*)&VM, (void*)pVM, sizeof(FICL_VM));
4508     memcpy((void*)&pStack, (void*)pVM->pStack, sizeof(FICL_STACK));
4509     memcpy((void*)&rStack, (void*)pVM->rStack, sizeof(FICL_STACK));
4510
4511     /*
4512     ** Give pVM a jmp_buf
4513     */
4514     pVM->pState = &vmState;
4515
4516     /*
4517     ** Safety net
4518     */
4519     except = setjmp(vmState);
4520
4521     switch (except)
4522         {
4523                 /*
4524                 ** Setup condition - push poison pill so that the VM throws
4525                 ** VM_INNEREXIT if the XT terminates normally, then execute
4526                 ** the XT
4527                 */
4528         case 0:
4529                 vmPushIP(pVM, &pQuit);                  /* Open mouth, insert emetic */
4530         vmExecute(pVM, pFW);
4531         vmInnerLoop(pVM);
4532                 break;
4533
4534                 /*
4535                 ** Normal exit from XT - lose the poison pill,
4536                 ** restore old setjmp vector and push a zero.
4537                 */
4538         case VM_INNEREXIT:
4539         vmPopIP(pVM);                   /* Gack - hurl poison pill */
4540         pVM->pState = VM.pState;        /* Restore just the setjmp vector */
4541         stackPushINT(pVM->pStack, 0);   /* Push 0 -- everything is ok */
4542                 break;
4543
4544                 /*
4545                 ** Some other exception got thrown - restore pre-existing VM state
4546                 ** and push the exception code
4547                 */
4548         default:
4549         /* Restore vm's state */
4550         memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
4551         memcpy((void*)pVM->pStack, (void*)&pStack, sizeof(FICL_STACK));
4552         memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
4553
4554         stackPushINT(pVM->pStack, except);/* Push error */
4555                 break;
4556         }
4557 }
4558
4559 /*
4560  * Throw --  From ANS Forth standard.
4561  *
4562  * Throw takes the ToS and, if that's different from zero,
4563  * returns to the last executed catch context. Further throws will
4564  * unstack previously executed "catches", in LIFO mode.
4565  *
4566  * Daniel C. Sobral Jan 09/1999
4567  */
4568
4569 static void ficlThrow(FICL_VM *pVM)
4570 {
4571     int except;
4572
4573     except = stackPopINT(pVM->pStack);
4574
4575     if (except)
4576         vmThrow(pVM, except);
4577 }
4578
4579
4580 static void ansAllocate(FICL_VM *pVM)
4581 {
4582     size_t size;
4583     void *p;
4584
4585     size = stackPopINT(pVM->pStack);
4586     p = ficlMalloc(size);
4587     stackPushPtr(pVM->pStack, p);
4588     if (p)
4589         stackPushINT(pVM->pStack, 0);
4590     else
4591         stackPushINT(pVM->pStack, 1);
4592 }
4593
4594
4595 static void ansFree(FICL_VM *pVM)
4596 {
4597     void *p;
4598
4599     p = stackPopPtr(pVM->pStack);
4600     ficlFree(p);
4601     stackPushINT(pVM->pStack, 0);
4602 }
4603
4604
4605 static void ansResize(FICL_VM *pVM)
4606 {
4607     size_t size;
4608     void *new, *old;
4609
4610     size = stackPopINT(pVM->pStack);
4611     old = stackPopPtr(pVM->pStack);
4612     new = ficlRealloc(old, size);
4613     if (new)
4614     {
4615         stackPushPtr(pVM->pStack, new);
4616         stackPushINT(pVM->pStack, 0);
4617     }
4618     else
4619     {
4620         stackPushPtr(pVM->pStack, old);
4621         stackPushINT(pVM->pStack, 1);
4622     }
4623 }
4624
4625 /*
4626 ** Retrieves free space remaining on the dictionary
4627 */
4628
4629 static void freeHeap(FICL_VM *pVM)
4630 {
4631     stackPushINT(pVM->pStack, dictCellsAvail(ficlGetDict()));
4632 }
4633
4634 /*
4635 ** exit-inner
4636 ** Signals execXT that an inner loop has completed
4637 */
4638 static void ficlExitInner(FICL_VM *pVM)
4639 {
4640     vmThrow(pVM, VM_INNEREXIT);
4641 }
4642
4643
4644 /**************************************************************************
4645                         d n e g a t e
4646 ** DOUBLE   ( d1 -- d2 )
4647 ** d2 is the negation of d1.
4648 **************************************************************************/
4649 static void dnegate(FICL_VM *pVM)
4650 {
4651     DPINT i = i64Pop(pVM->pStack);
4652     i = m64Negate(i);
4653     i64Push(pVM->pStack, i);
4654
4655     return;
4656 }
4657
4658 /******************* Increase dictionary size on-demand ******************/
4659
4660 static void ficlDictThreshold(FICL_VM *pVM)
4661 {
4662     stackPushPtr(pVM->pStack, &dictThreshold);
4663 }
4664
4665 static void ficlDictIncrease(FICL_VM *pVM)
4666 {
4667     stackPushPtr(pVM->pStack, &dictIncrease);
4668 }
4669
4670 /************************* freebsd added trace ***************************/
4671
4672 #ifdef FICL_TRACE
4673 static void ficlTrace(FICL_VM *pVM)
4674 {
4675 #if FICL_ROBUST > 1
4676     vmCheckStack(pVM, 1, 1);
4677 #endif
4678
4679     ficl_trace = stackPopINT(pVM->pStack);
4680 }
4681 #endif
4682
4683 /**************************************************************************
4684                         f i c l C o m p i l e C o r e
4685 ** Builds the primitive wordset and the environment-query namespace.
4686 **************************************************************************/
4687
4688 void ficlCompileCore(FICL_DICT *dp)
4689 {
4690     assert (dp);
4691
4692     /*
4693     ** CORE word set
4694     ** see softcore.c for definitions of: abs bl space spaces abort"
4695     */
4696     pStore =
4697     dictAppendWord(dp, "!",         store,          FW_DEFAULT);
4698     dictAppendWord(dp, "#",         numberSign,     FW_DEFAULT);
4699     dictAppendWord(dp, "#>",        numberSignGreater,FW_DEFAULT);
4700     dictAppendWord(dp, "#s",        numberSignS,    FW_DEFAULT);
4701     dictAppendWord(dp, "\'",        tick,           FW_DEFAULT);
4702     dictAppendWord(dp, "(",         commentHang,    FW_IMMEDIATE);
4703     dictAppendWord(dp, "*",         mul,            FW_DEFAULT);
4704     dictAppendWord(dp, "*/",        mulDiv,         FW_DEFAULT);
4705     dictAppendWord(dp, "*/mod",     mulDivRem,      FW_DEFAULT);
4706     dictAppendWord(dp, "+",         add,            FW_DEFAULT);
4707     dictAppendWord(dp, "+!",        plusStore,      FW_DEFAULT);
4708     dictAppendWord(dp, "+loop",     plusLoopCoIm,   FW_COMPIMMED);
4709     pComma =
4710     dictAppendWord(dp, ",",         comma,          FW_DEFAULT);
4711     dictAppendWord(dp, "-",         sub,            FW_DEFAULT);
4712     dictAppendWord(dp, ".",         displayCell,    FW_DEFAULT);
4713     dictAppendWord(dp, ".#",        displayCellNoPad,    FW_DEFAULT);
4714     dictAppendWord(dp, ".\"",       dotQuoteCoIm,   FW_COMPIMMED);
4715     dictAppendWord(dp, "/",         ficlDiv,        FW_DEFAULT);
4716     dictAppendWord(dp, "/mod",      slashMod,       FW_DEFAULT);
4717     dictAppendWord(dp, "0<",        zeroLess,       FW_DEFAULT);
4718     dictAppendWord(dp, "0=",        zeroEquals,     FW_DEFAULT);
4719     dictAppendWord(dp, "0>",        zeroGreater,    FW_DEFAULT);
4720     dictAppendWord(dp, "1+",        onePlus,        FW_DEFAULT);
4721     dictAppendWord(dp, "1-",        oneMinus,       FW_DEFAULT);
4722     dictAppendWord(dp, "2!",        twoStore,       FW_DEFAULT);
4723     dictAppendWord(dp, "2*",        twoMul,         FW_DEFAULT);
4724     dictAppendWord(dp, "2/",        twoDiv,         FW_DEFAULT);
4725     dictAppendWord(dp, "2@",        twoFetch,       FW_DEFAULT);
4726     dictAppendWord(dp, "2drop",     twoDrop,        FW_DEFAULT);
4727     dictAppendWord(dp, "2dup",      twoDup,         FW_DEFAULT);
4728     dictAppendWord(dp, "2over",     twoOver,        FW_DEFAULT);
4729     dictAppendWord(dp, "2swap",     twoSwap,        FW_DEFAULT);
4730     dictAppendWord(dp, ":",         colon,          FW_DEFAULT);
4731     dictAppendWord(dp, ";",         semicolonCoIm,  FW_COMPIMMED);
4732     dictAppendWord(dp, "<",         isLess,         FW_DEFAULT);
4733     dictAppendWord(dp, "<#",        lessNumberSign, FW_DEFAULT);
4734     dictAppendWord(dp, "=",         isEqual,        FW_DEFAULT);
4735     dictAppendWord(dp, ">",         isGreater,      FW_DEFAULT);
4736     dictAppendWord(dp, ">body",     toBody,         FW_DEFAULT);
4737     dictAppendWord(dp, ">in",       toIn,           FW_DEFAULT);
4738     dictAppendWord(dp, ">number",   toNumber,       FW_DEFAULT);
4739     dictAppendWord(dp, ">r",        toRStack,       FW_DEFAULT);
4740     dictAppendWord(dp, "?dup",      questionDup,    FW_DEFAULT);
4741     dictAppendWord(dp, "@",         fetch,          FW_DEFAULT);
4742     dictAppendWord(dp, "abort",     ficlAbort,      FW_DEFAULT);
4743     dictAppendWord(dp, "accept",    accept,         FW_DEFAULT);
4744     dictAppendWord(dp, "align",     align,          FW_DEFAULT);
4745     dictAppendWord(dp, "aligned",   aligned,        FW_DEFAULT);
4746     dictAppendWord(dp, "allot",     allot,          FW_DEFAULT);
4747     dictAppendWord(dp, "and",       bitwiseAnd,     FW_DEFAULT);
4748     dictAppendWord(dp, "base",      base,           FW_DEFAULT);
4749     dictAppendWord(dp, "begin",     beginCoIm,      FW_COMPIMMED);
4750     dictAppendWord(dp, "c!",        cStore,         FW_DEFAULT);
4751     dictAppendWord(dp, "c,",        cComma,         FW_DEFAULT);
4752     dictAppendWord(dp, "c@",        cFetch,         FW_DEFAULT);
4753     dictAppendWord(dp, "cell+",     cellPlus,       FW_DEFAULT);
4754     dictAppendWord(dp, "cells",     cells,          FW_DEFAULT);
4755     dictAppendWord(dp, "char",      ficlChar,       FW_DEFAULT);
4756     dictAppendWord(dp, "char+",     charPlus,       FW_DEFAULT);
4757     dictAppendWord(dp, "chars",     ficlChars,      FW_DEFAULT);
4758     dictAppendWord(dp, "constant",  constant,       FW_DEFAULT);
4759     dictAppendWord(dp, "count",     count,          FW_DEFAULT);
4760     dictAppendWord(dp, "cr",        cr,             FW_DEFAULT);
4761     dictAppendWord(dp, "create",    create,         FW_DEFAULT);
4762     dictAppendWord(dp, "decimal",   decimal,        FW_DEFAULT);
4763     dictAppendWord(dp, "depth",     depth,          FW_DEFAULT);
4764     dictAppendWord(dp, "do",        doCoIm,         FW_COMPIMMED);
4765     dictAppendWord(dp, "does>",     doesCoIm,       FW_COMPIMMED);
4766     dictAppendWord(dp, "drop",      drop,           FW_DEFAULT);
4767     dictAppendWord(dp, "dup",       dup,            FW_DEFAULT);
4768     dictAppendWord(dp, "else",      elseCoIm,       FW_COMPIMMED);
4769     dictAppendWord(dp, "emit",      emit,           FW_DEFAULT);
4770     dictAppendWord(dp, "environment?", environmentQ,FW_DEFAULT);
4771     dictAppendWord(dp, "evaluate",  evaluate,       FW_DEFAULT);
4772     dictAppendWord(dp, "execute",   execute,        FW_DEFAULT);
4773     dictAppendWord(dp, "exit",      exitCoIm,       FW_COMPIMMED);
4774     dictAppendWord(dp, "fill",      fill,           FW_DEFAULT);
4775     dictAppendWord(dp, "find",      find,           FW_DEFAULT);
4776     dictAppendWord(dp, "fm/mod",    fmSlashMod,     FW_DEFAULT);
4777     dictAppendWord(dp, "here",      here,           FW_DEFAULT);
4778     dictAppendWord(dp, "hex",       hex,            FW_DEFAULT);
4779     dictAppendWord(dp, "hold",      hold,           FW_DEFAULT);
4780     dictAppendWord(dp, "i",         loopICo,        FW_COMPILE);
4781     dictAppendWord(dp, "if",        ifCoIm,         FW_COMPIMMED);
4782     dictAppendWord(dp, "immediate", immediate,      FW_DEFAULT);
4783     dictAppendWord(dp, "invert",    bitwiseNot,     FW_DEFAULT);
4784     dictAppendWord(dp, "j",         loopJCo,        FW_COMPILE);
4785     dictAppendWord(dp, "k",         loopKCo,        FW_COMPILE);
4786     dictAppendWord(dp, "leave",     leaveCo,        FW_COMPILE);
4787     dictAppendWord(dp, "literal",   literalIm,      FW_IMMEDIATE);
4788     dictAppendWord(dp, "loop",      loopCoIm,       FW_COMPIMMED);
4789     dictAppendWord(dp, "lshift",    lshift,         FW_DEFAULT);
4790     dictAppendWord(dp, "m*",        mStar,          FW_DEFAULT);
4791     dictAppendWord(dp, "max",       ficlMax,        FW_DEFAULT);
4792     dictAppendWord(dp, "min",       ficlMin,        FW_DEFAULT);
4793     dictAppendWord(dp, "mod",       ficlMod,        FW_DEFAULT);
4794     dictAppendWord(dp, "move",      move,           FW_DEFAULT);
4795     dictAppendWord(dp, "negate",    negate,         FW_DEFAULT);
4796     dictAppendWord(dp, "or",        bitwiseOr,      FW_DEFAULT);
4797     dictAppendWord(dp, "over",      over,           FW_DEFAULT);
4798     dictAppendWord(dp, "postpone",  postponeCoIm,   FW_COMPIMMED);
4799     dictAppendWord(dp, "quit",      quit,           FW_DEFAULT);
4800     dictAppendWord(dp, "r>",        fromRStack,     FW_DEFAULT);
4801     dictAppendWord(dp, "r@",        fetchRStack,    FW_DEFAULT);
4802     dictAppendWord(dp, "recurse",   recurseCoIm,    FW_COMPIMMED);
4803     dictAppendWord(dp, "repeat",    repeatCoIm,     FW_COMPIMMED);
4804     dictAppendWord(dp, "rot",       rot,            FW_DEFAULT);
4805     dictAppendWord(dp, "rshift",    rshift,         FW_DEFAULT);
4806     dictAppendWord(dp, "s\"",       stringQuoteIm,  FW_IMMEDIATE);
4807     dictAppendWord(dp, "s>d",       sToD,           FW_DEFAULT);
4808     dictAppendWord(dp, "sign",      sign,           FW_DEFAULT);
4809     dictAppendWord(dp, "sm/rem",    smSlashRem,     FW_DEFAULT);
4810     dictAppendWord(dp, "source",    source,         FW_DEFAULT);
4811     dictAppendWord(dp, "state",     state,          FW_DEFAULT);
4812     dictAppendWord(dp, "swap",      swap,           FW_DEFAULT);
4813     dictAppendWord(dp, "then",      endifCoIm,      FW_COMPIMMED);
4814     pType =
4815     dictAppendWord(dp, "type",      type,           FW_DEFAULT);
4816     dictAppendWord(dp, "u.",        uDot,           FW_DEFAULT);
4817     dictAppendWord(dp, "u<",        uIsLess,        FW_DEFAULT);
4818     dictAppendWord(dp, "um*",       umStar,         FW_DEFAULT);
4819     dictAppendWord(dp, "um/mod",    umSlashMod,     FW_DEFAULT);
4820     dictAppendWord(dp, "unloop",    unloopCo,       FW_COMPILE);
4821     dictAppendWord(dp, "until",     untilCoIm,      FW_COMPIMMED);
4822     dictAppendWord(dp, "variable",  variable,       FW_DEFAULT);
4823     dictAppendWord(dp, "while",     whileCoIm,      FW_COMPIMMED);
4824     dictAppendWord(dp, "word",      ficlWord,       FW_DEFAULT);
4825     dictAppendWord(dp, "xor",       bitwiseXor,     FW_DEFAULT);
4826     dictAppendWord(dp, "[",         lbracketCoIm,   FW_COMPIMMED);
4827     dictAppendWord(dp, "[\']",      bracketTickCoIm,FW_COMPIMMED);
4828     dictAppendWord(dp, "[char]",    charCoIm,       FW_COMPIMMED);
4829     dictAppendWord(dp, "]",         rbracket,       FW_DEFAULT);
4830     /*
4831     ** CORE EXT word set...
4832     ** see softcore.c for other definitions
4833     */
4834     dictAppendWord(dp, ".(",        dotParen,       FW_DEFAULT);
4835     dictAppendWord(dp, ":noname",   colonNoName,    FW_DEFAULT);
4836     dictAppendWord(dp, "?do",       qDoCoIm,        FW_COMPIMMED);
4837     dictAppendWord(dp, "again",     againCoIm,      FW_COMPIMMED);
4838     dictAppendWord(dp, "parse",     parse,          FW_DEFAULT);
4839     dictAppendWord(dp, "pick",      pick,           FW_DEFAULT);
4840     dictAppendWord(dp, "roll",      roll,           FW_DEFAULT);
4841     dictAppendWord(dp, "refill",    refill,         FW_DEFAULT);
4842     dictAppendWord(dp, "source-id", sourceid,       FW_DEFAULT);
4843     dictAppendWord(dp, "to",        toValue,        FW_IMMEDIATE);
4844     dictAppendWord(dp, "value",     constant,       FW_DEFAULT);
4845     dictAppendWord(dp, "\\",        commentLine,    FW_IMMEDIATE);
4846
4847     /* FreeBSD extension words */
4848     dictAppendWord(dp, "fopen",     pfopen,         FW_DEFAULT);
4849     dictAppendWord(dp, "fclose",    pfclose,        FW_DEFAULT);
4850     dictAppendWord(dp, "fread",     pfread,         FW_DEFAULT);
4851     dictAppendWord(dp, "fwrite",    pfwrite,        FW_DEFAULT);
4852     dictAppendWord(dp, "flseek",    pflseek,        FW_DEFAULT);
4853     dictAppendWord(dp, "fload",     pfload,         FW_DEFAULT);
4854     dictAppendWord(dp, "fkey",      fkey,           FW_DEFAULT);
4855     dictAppendWord(dp, "key",       key,            FW_DEFAULT);
4856     dictAppendWord(dp, "key?",      keyQuestion,    FW_DEFAULT);
4857     dictAppendWord(dp, "ms",        ms,             FW_DEFAULT);
4858     dictAppendWord(dp, "seconds",   pseconds,       FW_DEFAULT);
4859     dictAppendWord(dp, "heap?",     freeHeap,       FW_DEFAULT);
4860     dictAppendWord(dp, "dictthreshold", ficlDictThreshold, FW_DEFAULT);
4861     dictAppendWord(dp, "dictincrease", ficlDictIncrease, FW_DEFAULT);
4862 #ifdef FICL_TRACE
4863     dictAppendWord(dp, "trace!",    ficlTrace,      FW_DEFAULT);
4864 #endif
4865
4866 #ifndef TESTMAIN
4867 #ifdef __i386__
4868     dictAppendWord(dp, "outb",      ficlOutb,       FW_DEFAULT);
4869     dictAppendWord(dp, "inb",       ficlInb,        FW_DEFAULT);
4870 #endif
4871     dictAppendWord(dp, "setenv",    ficlSetenv,     FW_DEFAULT);
4872     dictAppendWord(dp, "setenv?",   ficlSetenvq,    FW_DEFAULT);
4873     dictAppendWord(dp, "getenv",    ficlGetenv,     FW_DEFAULT);
4874     dictAppendWord(dp, "unsetenv",  ficlUnsetenv,   FW_DEFAULT);
4875     dictAppendWord(dp, "copyin",    ficlCopyin,     FW_DEFAULT);
4876     dictAppendWord(dp, "copyout",   ficlCopyout,    FW_DEFAULT);
4877 #endif
4878
4879 #if defined(__i386__)
4880     ficlSetEnv("arch-i386",         FICL_TRUE);
4881     ficlSetEnv("arch-alpha",        FICL_FALSE);
4882 #elif defined(__alpha__)
4883     ficlSetEnv("arch-i386",         FICL_FALSE);
4884     ficlSetEnv("arch-alpha",        FICL_TRUE);
4885 #endif
4886
4887     /*
4888     ** Set CORE environment query values
4889     */
4890     ficlSetEnv("/counted-string",   FICL_STRING_MAX);
4891     ficlSetEnv("/hold",             nPAD);
4892     ficlSetEnv("/pad",              nPAD);
4893     ficlSetEnv("address-unit-bits", 8);
4894     ficlSetEnv("core",              FICL_TRUE);
4895     ficlSetEnv("core-ext",          FICL_FALSE);
4896     ficlSetEnv("floored",           FICL_FALSE);
4897     ficlSetEnv("max-char",          UCHAR_MAX);
4898     ficlSetEnvD("max-d",            0x7fffffff, 0xffffffff );
4899     ficlSetEnv("max-n",             0x7fffffff);
4900     ficlSetEnv("max-u",             0xffffffff);
4901     ficlSetEnvD("max-ud",           0xffffffff, 0xffffffff);
4902     ficlSetEnv("return-stack-cells",FICL_DEFAULT_STACK);
4903     ficlSetEnv("stack-cells",       FICL_DEFAULT_STACK);
4904
4905     /*
4906     ** DOUBLE word set (partial)
4907     */
4908     dictAppendWord(dp, "2constant", twoConstant,    FW_IMMEDIATE);
4909     dictAppendWord(dp, "2literal",  twoLiteralIm,   FW_IMMEDIATE);
4910     dictAppendWord(dp, "dnegate",   dnegate,        FW_DEFAULT);
4911
4912
4913     /*
4914     ** EXCEPTION word set
4915     */
4916     dictAppendWord(dp, "catch",     ficlCatch,      FW_DEFAULT);
4917     dictAppendWord(dp, "throw",     ficlThrow,      FW_DEFAULT);
4918
4919     ficlSetEnv("exception",         FICL_TRUE);
4920     ficlSetEnv("exception-ext",     FICL_TRUE);
4921
4922     /*
4923     ** LOCAL and LOCAL EXT
4924     ** see softcore.c for implementation of locals|
4925     */
4926 #if FICL_WANT_LOCALS
4927     pLinkParen =
4928     dictAppendWord(dp, "(link)",    linkParen,      FW_COMPILE);
4929     pUnLinkParen =
4930     dictAppendWord(dp, "(unlink)",  unlinkParen,    FW_COMPILE);
4931     dictAppendWord(dp, "doLocal",   doLocalIm,      FW_COMPIMMED);
4932     pGetLocalParen =
4933     dictAppendWord(dp, "(@local)",  getLocalParen,  FW_COMPILE);
4934     pToLocalParen =
4935     dictAppendWord(dp, "(toLocal)", toLocalParen,   FW_COMPILE);
4936     pGetLocal0 =
4937     dictAppendWord(dp, "(@local0)", getLocal0,      FW_COMPILE);
4938     pToLocal0 =
4939     dictAppendWord(dp, "(toLocal0)",toLocal0,       FW_COMPILE);
4940     pGetLocal1 =
4941     dictAppendWord(dp, "(@local1)", getLocal1,      FW_COMPILE);
4942     pToLocal1 =
4943     dictAppendWord(dp, "(toLocal1)",toLocal1,       FW_COMPILE);
4944     dictAppendWord(dp, "(local)",   localParen,     FW_COMPILE);
4945
4946     pGet2LocalParen =
4947     dictAppendWord(dp, "(@2local)", get2LocalParen, FW_COMPILE);
4948     pTo2LocalParen =
4949     dictAppendWord(dp, "(to2Local)",to2LocalParen,  FW_COMPILE);
4950     dictAppendWord(dp, "(2local)",  twoLocalParen,  FW_COMPILE);
4951
4952     ficlSetEnv("locals",            FICL_TRUE);
4953     ficlSetEnv("locals-ext",        FICL_TRUE);
4954     ficlSetEnv("#locals",           FICL_MAX_LOCALS);
4955 #endif
4956
4957     /*
4958     ** Optional MEMORY-ALLOC word set
4959     */
4960
4961     dictAppendWord(dp, "allocate",  ansAllocate,    FW_DEFAULT);
4962     dictAppendWord(dp, "free",      ansFree,        FW_DEFAULT);
4963     dictAppendWord(dp, "resize",    ansResize,      FW_DEFAULT);
4964
4965     ficlSetEnv("memory-alloc",      FICL_TRUE);
4966     ficlSetEnv("memory-alloc-ext",  FICL_FALSE);
4967
4968     /*
4969     ** optional SEARCH-ORDER word set
4970     */
4971     dictAppendWord(dp, ">search",   searchPush,     FW_DEFAULT);
4972     dictAppendWord(dp, "search>",   searchPop,      FW_DEFAULT);
4973     dictAppendWord(dp, "definitions",
4974                                     definitions,    FW_DEFAULT);
4975     dictAppendWord(dp, "forth-wordlist",
4976                                     forthWordlist,  FW_DEFAULT);
4977     dictAppendWord(dp, "get-current",
4978                                     getCurrent,     FW_DEFAULT);
4979     dictAppendWord(dp, "get-order", getOrder,       FW_DEFAULT);
4980     dictAppendWord(dp, "search-wordlist",
4981                                     searchWordlist, FW_DEFAULT);
4982     dictAppendWord(dp, "set-current",
4983                                     setCurrent,     FW_DEFAULT);
4984     dictAppendWord(dp, "set-order", setOrder,       FW_DEFAULT);
4985     dictAppendWord(dp, "ficl-wordlist", wordlist,   FW_DEFAULT);
4986
4987     /*
4988     ** Set SEARCH environment query values
4989     */
4990     ficlSetEnv("search-order",      FICL_TRUE);
4991     ficlSetEnv("search-order-ext",  FICL_TRUE);
4992     ficlSetEnv("wordlists",         FICL_DEFAULT_VOCS);
4993
4994     /*
4995     ** TOOLS and TOOLS EXT
4996     */
4997     dictAppendWord(dp, ".s",        displayStack,   FW_DEFAULT);
4998     dictAppendWord(dp, "bye",       bye,            FW_DEFAULT);
4999     dictAppendWord(dp, "forget",    forget,         FW_DEFAULT);
5000     dictAppendWord(dp, "see",       see,            FW_DEFAULT);
5001     dictAppendWord(dp, "words",     listWords,      FW_DEFAULT);
5002
5003     /*
5004     ** Set TOOLS environment query values
5005     */
5006     ficlSetEnv("tools",            FICL_TRUE);
5007     ficlSetEnv("tools-ext",        FICL_FALSE);
5008
5009     /*
5010     ** Ficl extras
5011     */
5012     dictAppendWord(dp, ".env",      listEnv,        FW_DEFAULT);
5013     dictAppendWord(dp, ".ver",      ficlVersion,    FW_DEFAULT);
5014     dictAppendWord(dp, "-roll",     minusRoll,      FW_DEFAULT);
5015     dictAppendWord(dp, ">name",     toName,         FW_DEFAULT);
5016     dictAppendWord(dp, "body>",     fromBody,       FW_DEFAULT);
5017     dictAppendWord(dp, "compare",   compareString,  FW_DEFAULT);   /* STRING */
5018     dictAppendWord(dp, "compile-only",
5019                                     compileOnly,    FW_DEFAULT);
5020     dictAppendWord(dp, "endif",     endifCoIm,      FW_COMPIMMED);
5021     dictAppendWord(dp, "forget-wid",forgetWid,      FW_DEFAULT);
5022         dictAppendWord(dp, "hash",      hash,           FW_DEFAULT);
5023         dictAppendWord(dp, "number?",   ficlIsNum,      FW_DEFAULT);
5024     dictAppendWord(dp, "parse-word",parseNoCopy,    FW_DEFAULT);
5025     dictAppendWord(dp, "sliteral",  sLiteralCoIm,   FW_COMPIMMED); /* STRING */
5026     dictAppendWord(dp, "wid-set-super",
5027                                     setParentWid,   FW_DEFAULT);
5028     dictAppendWord(dp, "i@",        iFetch,         FW_DEFAULT);
5029     dictAppendWord(dp, "i!",        iStore,         FW_DEFAULT);
5030     dictAppendWord(dp, "w@",        wFetch,         FW_DEFAULT);
5031     dictAppendWord(dp, "w!",        wStore,         FW_DEFAULT);
5032     dictAppendWord(dp, "x.",        hexDot,         FW_DEFAULT);
5033 #if FICL_WANT_USER
5034     dictAppendWord(dp, "(user)",    userParen,      FW_DEFAULT);
5035     dictAppendWord(dp, "user",      userVariable,   FW_DEFAULT);
5036 #endif
5037     /*
5038     ** internal support words
5039     */
5040     pExitParen =
5041     dictAppendWord(dp, "(exit)",    exitParen,      FW_COMPILE);
5042     pSemiParen =
5043     dictAppendWord(dp, "(;)",       semiParen,      FW_COMPILE);
5044     pLitParen =
5045     dictAppendWord(dp, "(literal)", literalParen,   FW_COMPILE);
5046     pTwoLitParen =
5047     dictAppendWord(dp, "(2literal)",twoLitParen,    FW_COMPILE);
5048     pStringLit =
5049     dictAppendWord(dp, "(.\")",     stringLit,      FW_COMPILE);
5050     pIfParen =
5051     dictAppendWord(dp, "(if)",      ifParen,        FW_COMPILE);
5052     pBranchParen =
5053     dictAppendWord(dp, "(branch)",  branchParen,    FW_COMPILE);
5054     pDoParen =
5055     dictAppendWord(dp, "(do)",      doParen,        FW_COMPILE);
5056     pDoesParen =
5057     dictAppendWord(dp, "(does>)",   doesParen,      FW_COMPILE);
5058     pQDoParen =
5059     dictAppendWord(dp, "(?do)",     qDoParen,       FW_COMPILE);
5060     pLoopParen =
5061     dictAppendWord(dp, "(loop)",    loopParen,      FW_COMPILE);
5062     pPLoopParen =
5063     dictAppendWord(dp, "(+loop)",   plusLoopParen,  FW_COMPILE);
5064     pInterpret =
5065     dictAppendWord(dp, "interpret", interpret,      FW_DEFAULT);
5066     dictAppendWord(dp, "(variable)",variableParen,  FW_COMPILE);
5067     dictAppendWord(dp, "(constant)",constantParen,  FW_COMPILE);
5068     dictAppendWord(dp, "exit-inner",ficlExitInner,  FW_DEFAULT);
5069
5070     assert(dictCellsAvail(dp) > 0);
5071     return;
5072 }
5073