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