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