stand/ficl/words.c

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