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