sys/boot/ficl/words.c

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