git.gag.com Git - debian/pforth/blob - csrc/pf_inner.c

   1 /* @(#) pf_inner.c 98/03/16 1.7 */
   2 /***************************************************************
   3 ** Inner Interpreter for Forth based on 'C'
   4 **
   5 ** Author: Phil Burk
   6 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
   7 **
   8 ** Permission to use, copy, modify, and/or distribute this
   9 ** software for any purpose with or without fee is hereby granted.
  10 **
  11 ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  12 ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  13 ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  14 ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  15 ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  16 ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  17 ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  18 ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  19 **
  20 ****************************************************************
  21 **
  22 ** 940502 PLB Creation.
  23 ** 940505 PLB More macros.
  24 ** 940509 PLB Moved all stack stuff into pfCatch.
  25 ** 941014 PLB Converted to flat secondary strusture.
  26 ** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH,
  27 **             and ID_HERE for armcc
  28 ** 941130 PLB Made w@ unsigned
  29 **
  30 ***************************************************************/
  31
  32 #include "pf_all.h"
  33
  34 #if defined(WIN32) && !defined(__MINGW32__)
  35 #include <crtdbg.h>
  36 #endif
  37
  38 #define SYSTEM_LOAD_FILE "system.fth"
  39
  40 /***************************************************************
  41 ** Macros for data stack access.
  42 ** TOS is cached in a register in pfCatch.
  43 ***************************************************************/
  44
  45 #define STKPTR   (DataStackPtr)
  46 #define M_POP    (*(STKPTR++))
  47 #define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);}
  48 #define M_STACK(n) (STKPTR[n])
  49
  50 #define TOS      (TopOfStack)
  51 #define PUSH_TOS M_PUSH(TOS)
  52 #define M_DUP    PUSH_TOS;
  53 #define M_DROP   { TOS = M_POP; }
  54
  55 #define ASCII_EOT   (0x04)
  56
  57 /***************************************************************
  58 ** Macros for Floating Point stack access.
  59 ***************************************************************/
  60 #ifdef PF_SUPPORT_FP
  61 #define FP_STKPTR   (FloatStackPtr)
  62 #define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)
  63 #define M_FP_POP    (*(FP_STKPTR++))
  64 #define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}
  65 #define M_FP_STACK(n) (FP_STKPTR[n])
  66
  67 #define FP_TOS      (fpTopOfStack)
  68 #define PUSH_FP_TOS M_FP_PUSH(FP_TOS)
  69 #define M_FP_DUP    PUSH_FP_TOS;
  70 #define M_FP_DROP   { FP_TOS = M_FP_POP; }
  71 #endif
  72
  73 /***************************************************************
  74 ** Macros for return stack access.
  75 ***************************************************************/
  76
  77 #define TORPTR (ReturnStackPtr)
  78 #define M_R_DROP {TORPTR++;}
  79 #define M_R_POP (*(TORPTR++))
  80 #define M_R_PICK(n) (TORPTR[n])
  81 #define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);}
  82
  83 /***************************************************************
  84 ** Misc Forth macros
  85 ***************************************************************/
  86
  87 #define M_BRANCH   { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); }
  88
  89 /* Cache top of data stack like in JForth. */
  90 #ifdef PF_SUPPORT_FP
  91 #define LOAD_REGISTERS \
  92     { \
  93         STKPTR = gCurrentTask->td_StackPtr; \
  94         TOS = M_POP; \
  95         FP_STKPTR = gCurrentTask->td_FloatStackPtr; \
  96         FP_TOS = M_FP_POP; \
  97         TORPTR = gCurrentTask->td_ReturnPtr; \
  98      }
  99
 100 #define SAVE_REGISTERS \
 101     { \
 102         gCurrentTask->td_ReturnPtr = TORPTR; \
 103         M_PUSH( TOS ); \
 104         gCurrentTask->td_StackPtr = STKPTR; \
 105         M_FP_PUSH( FP_TOS ); \
 106         gCurrentTask->td_FloatStackPtr = FP_STKPTR; \
 107      }
 108
 109 #else
 110 /* Cache top of data stack like in JForth. */
 111 #define LOAD_REGISTERS \
 112     { \
 113         STKPTR = gCurrentTask->td_StackPtr; \
 114         TOS = M_POP; \
 115         TORPTR = gCurrentTask->td_ReturnPtr; \
 116      }
 117
 118 #define SAVE_REGISTERS \
 119     { \
 120         gCurrentTask->td_ReturnPtr = TORPTR; \
 121         M_PUSH( TOS ); \
 122         gCurrentTask->td_StackPtr = STKPTR; \
 123      }
 124 #endif
 125
 126 #define M_DOTS \
 127     SAVE_REGISTERS; \
 128     ffDotS( ); \
 129     LOAD_REGISTERS;
 130
 131 #define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; }
 132
 133 #ifdef PF_SUPPORT_FP
 134 #define M_THROW(err) \
 135     { \
 136         ExceptionReturnCode = (ThrowCode)(err); \
 137         TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
 138         STKPTR = InitialDataStack; \
 139         FP_STKPTR = InitialFloatStack; \
 140     }
 141 #else
 142 #define M_THROW(err) \
 143     { \
 144         ExceptionReturnCode = (err); \
 145         TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
 146         STKPTR = InitialDataStack; \
 147     }
 148 #endif
 149
 150 /***************************************************************
 151 ** Other macros
 152 ***************************************************************/
 153
 154 #define BINARY_OP( op ) { TOS = M_POP op TOS; }
 155 #define endcase break
 156
 157 #if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)
 158     #define TRACENAMES /* no names */
 159 #else
 160 /* Display name of executing routine. */
 161 static void TraceNames( ExecToken Token, cell_t Level )
 162 {
 163     char *DebugName;
 164     cell_t i;
 165
 166     if( ffTokenToName( Token, &DebugName ) )
 167     {
 168         cell_t NumSpaces;
 169         if( gCurrentTask->td_OUT > 0 ) EMIT_CR;
 170         EMIT( '>' );
 171         for( i=0; i<Level; i++ )
 172         {
 173             MSG( "  " );
 174         }
 175         TypeName( DebugName );
 176 /* Space out to column N then .S */
 177         NumSpaces = 30 - gCurrentTask->td_OUT;
 178         for( i=0; i < NumSpaces; i++ )
 179         {
 180             EMIT( ' ' );
 181         }
 182         ffDotS();
 183 /* No longer needed?        gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */
 184
 185     }
 186     else
 187     {
 188         MSG_NUM_H("Couldn't find Name for ", Token);
 189     }
 190 }
 191
 192 #define TRACENAMES \
 193     if( (gVarTraceLevel > Level) ) \
 194     { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }
 195 #endif /* PF_NO_SHELL */
 196
 197 /* Use local copy of CODE_BASE for speed. */
 198 #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))
 199
 200 /* Truncate the unsigned double cell integer LO/HI to an uint64_t. */
 201 static uint64_t UdToUint64( ucell_t Lo, ucell_t Hi )
 202 {
 203     return (( 2 * sizeof(ucell_t) == sizeof(uint64_t) )
 204         ? (((uint64_t)Lo) | (((uint64_t)Hi) >> (sizeof(ucell_t) * 8)))
 205         : Lo);
 206 }
 207
 208 /* Return TRUE if the unsigned double cell integer LO/HI is not greater
 209  * then the greatest uint64_t.
 210  */
 211 static int UdIsUint64( ucell_t Lo, ucell_t Hi )
 212 {
 213     return (( 2 * sizeof(ucell_t) == sizeof(uint64_t) )
 214         ? TRUE
 215         : Hi == 0);
 216 }
 217
 218 static const char *pfSelectFileModeCreate( cell_t fam );
 219 static const char *pfSelectFileModeOpen( cell_t fam );
 220
 221 /**************************************************************/
 222 static const char *pfSelectFileModeCreate( cell_t fam )
 223 {
 224     const char *famText = NULL;
 225     switch( fam )
 226     {
 227     case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
 228         famText = PF_FAM_BIN_CREATE_WO;
 229         break;
 230     case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
 231         famText = PF_FAM_BIN_CREATE_RW;
 232         break;
 233     case PF_FAM_WRITE_ONLY:
 234         famText = PF_FAM_CREATE_WO;
 235         break;
 236     case PF_FAM_READ_WRITE:
 237         famText = PF_FAM_CREATE_RW;
 238         break;
 239     default:
 240         famText = "illegal";
 241         break;
 242     }
 243     return famText;
 244 }
 245
 246 /**************************************************************/
 247 static const char *pfSelectFileModeOpen( cell_t fam )
 248 {
 249     const char *famText = NULL;
 250     switch( fam )
 251     {
 252     case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG):
 253         famText = PF_FAM_BIN_OPEN_RO;
 254         break;
 255     case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
 256         famText = PF_FAM_BIN_CREATE_WO;
 257         break;
 258     case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
 259         famText = PF_FAM_BIN_OPEN_RW;
 260         break;
 261     case PF_FAM_READ_ONLY:
 262         famText = PF_FAM_OPEN_RO;
 263         break;
 264     case PF_FAM_WRITE_ONLY:
 265         famText = PF_FAM_CREATE_WO;
 266         break;
 267     case PF_FAM_READ_WRITE:
 268     default:
 269         famText = PF_FAM_OPEN_RW;
 270         break;
 271     }
 272     return famText;
 273 }
 274
 275 /**************************************************************/
 276 ThrowCode pfCatch( ExecToken XT )
 277 {
 278     register cell_t  TopOfStack;    /* Cache for faster execution. */
 279     register cell_t *DataStackPtr;
 280     register cell_t *ReturnStackPtr;
 281     register cell_t *InsPtr = NULL;
 282     register cell_t  Token;
 283     cell_t           Scratch;
 284
 285 #ifdef PF_SUPPORT_FP
 286     PF_FLOAT       fpTopOfStack;
 287     PF_FLOAT      *FloatStackPtr;
 288     PF_FLOAT       fpScratch;
 289     PF_FLOAT       fpTemp;
 290     PF_FLOAT      *InitialFloatStack;
 291 #endif
 292 #ifdef PF_SUPPORT_TRACE
 293     cell_t Level = 0;
 294 #endif
 295     cell_t        *LocalsPtr = NULL;
 296     cell_t         Temp;
 297     cell_t        *InitialReturnStack;
 298     cell_t        *InitialDataStack;
 299     cell_t         FakeSecondary[2];
 300     char          *CharPtr;
 301     cell_t        *CellPtr;
 302     FileStream    *FileID;
 303     uint8_t       *CodeBase = (uint8_t *) CODE_BASE;
 304     ThrowCode      ExceptionReturnCode = 0;
 305
 306 /* FIXME
 307     gExecutionDepth += 1;
 308     PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth ));
 309 */
 310
 311 /*
 312 ** Initialize FakeSecondary this way to avoid having stuff in the data section,
 313 ** which is not supported for some embedded system loaders.
 314 */
 315     FakeSecondary[0] = 0;
 316     FakeSecondary[1] = ID_EXIT; /* For EXECUTE */
 317
 318 /* Move data from task structure to registers for speed. */
 319     LOAD_REGISTERS;
 320
 321 /* Save initial stack depths for THROW */
 322     InitialReturnStack = TORPTR;
 323     InitialDataStack   = STKPTR ;
 324 #ifdef PF_SUPPORT_FP
 325     InitialFloatStack  = FP_STKPTR;
 326 #endif
 327
 328     Token = XT;
 329
 330     do
 331     {
 332 DBUG(("pfCatch: Token = 0x%x\n", Token ));
 333
 334 /* --------------------------------------------------------------- */
 335 /* If secondary, thread down code tree until we hit a primitive. */
 336         while( !IsTokenPrimitive( Token ) )
 337         {
 338 #ifdef PF_SUPPORT_TRACE
 339             if((gVarTraceFlags & TRACE_INNER) )
 340             {
 341                 MSG("pfCatch: Secondary Token = 0x");
 342                 ffDotHex(Token);
 343                 MSG_NUM_H(", InsPtr = 0x", InsPtr);
 344             }
 345             TRACENAMES;
 346 #endif
 347
 348 /* Save IP on return stack like a JSR. */
 349             M_R_PUSH( InsPtr );
 350
 351 /* Convert execution token to absolute address. */
 352             InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) );
 353
 354 /* Fetch token at IP. */
 355             Token = READ_CELL_DIC(InsPtr++);
 356
 357 #ifdef PF_SUPPORT_TRACE
 358 /* Bump level for trace display */
 359             Level++;
 360 #endif
 361         }
 362
 363
 364 #ifdef PF_SUPPORT_TRACE
 365         TRACENAMES;
 366 #endif
 367
 368 /* Execute primitive Token. */
 369         switch( Token )
 370         {
 371
 372     /* Pop up a level in Forth inner interpreter.
 373     ** Used to implement semicolon.
 374     ** Put first in switch because ID_EXIT==0 */
 375         case ID_EXIT:
 376             InsPtr = ( cell_t *) M_R_POP;
 377 #ifdef PF_SUPPORT_TRACE
 378             Level--;
 379 #endif
 380             endcase;
 381
 382         case ID_1MINUS:  TOS--; endcase;
 383
 384         case ID_1PLUS:   TOS++; endcase;
 385
 386 #ifndef PF_NO_SHELL
 387         case ID_2LITERAL:
 388             ff2Literal( TOS, M_POP );
 389             M_DROP;
 390             endcase;
 391 #endif  /* !PF_NO_SHELL */
 392
 393         case ID_2LITERAL_P:
 394 /* hi part stored first, put on top of stack */
 395             PUSH_TOS;
 396             TOS = READ_CELL_DIC(InsPtr++);
 397             M_PUSH(READ_CELL_DIC(InsPtr++));
 398             endcase;
 399
 400         case ID_2MINUS:  TOS -= 2; endcase;
 401
 402         case ID_2PLUS:   TOS += 2; endcase;
 403
 404
 405         case ID_2OVER:  /* ( a b c d -- a b c d a b ) */
 406             PUSH_TOS;
 407             Scratch = M_STACK(3);
 408             M_PUSH(Scratch);
 409             TOS = M_STACK(3);
 410             endcase;
 411
 412         case ID_2SWAP:  /* ( a b c d -- c d a b ) */
 413             Scratch = M_STACK(0);    /* c */
 414             M_STACK(0) = M_STACK(2); /* a */
 415             M_STACK(2) = Scratch;    /* c */
 416             Scratch = TOS;           /* d */
 417             TOS = M_STACK(1);        /* b */
 418             M_STACK(1) = Scratch;    /* d */
 419             endcase;
 420
 421         case ID_2DUP:   /* ( a b -- a b a b ) */
 422             PUSH_TOS;
 423             Scratch = M_STACK(1);
 424             M_PUSH(Scratch);
 425             endcase;
 426
 427         case ID_2_R_FETCH:
 428             PUSH_TOS;
 429             M_PUSH( (*(TORPTR+1)) );
 430             TOS = (*(TORPTR));
 431             endcase;
 432
 433         case ID_2_R_FROM:
 434             PUSH_TOS;
 435             TOS = M_R_POP;
 436             M_PUSH( M_R_POP );
 437             endcase;
 438
 439         case ID_2_TO_R:
 440             M_R_PUSH( M_POP );
 441             M_R_PUSH( TOS );
 442             M_DROP;
 443             endcase;
 444
 445         case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */
 446             CharPtr = (char *) M_POP;
 447             TOS = ioAccept( CharPtr, TOS );
 448             endcase;
 449
 450 #ifndef PF_NO_SHELL
 451         case ID_ALITERAL:
 452             ffALiteral( ABS_TO_CODEREL(TOS) );
 453             M_DROP;
 454             endcase;
 455 #endif  /* !PF_NO_SHELL */
 456
 457         case ID_ALITERAL_P:
 458             PUSH_TOS;
 459             TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) );
 460             endcase;
 461
 462 /* Allocate some extra and put validation identifier at base */
 463 #define PF_MEMORY_VALIDATOR  (0xA81B4D69)
 464         case ID_ALLOCATE:
 465             /* Allocate at least one cell's worth because we clobber first cell. */
 466             if ( TOS < sizeof(cell_t) )
 467             {
 468                 Temp = sizeof(cell_t);
 469             }
 470             else
 471             {
 472                 Temp = TOS;
 473             }
 474             /* Allocate extra cells worth because we store validation info. */
 475             CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) );
 476             if( CellPtr )
 477             {
 478 /* This was broken into two steps because different compilers incremented
 479 ** CellPtr before or after the XOR step. */
 480                 Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR;
 481                 *CellPtr++ = Temp;
 482                 M_PUSH( (cell_t) CellPtr );
 483                 TOS = 0;
 484             }
 485             else
 486             {
 487                 M_PUSH( 0 );
 488                 TOS = -1;  /* FIXME Fix error code. */
 489             }
 490             endcase;
 491
 492         case ID_AND:     BINARY_OP( & ); endcase;
 493
 494         case ID_ARSHIFT:     BINARY_OP( >> ); endcase;  /* Arithmetic right shift */
 495
 496         case ID_BODY_OFFSET:
 497             PUSH_TOS;
 498             TOS = CREATE_BODY_OFFSET;
 499             endcase;
 500
 501 /* Branch is followed by an offset relative to address of offset. */
 502         case ID_BRANCH:
 503 DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));
 504             M_BRANCH;
 505 DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
 506             endcase;
 507
 508         case ID_BYE:
 509             EMIT_CR;
 510             M_THROW( THROW_BYE );
 511             endcase;
 512
 513         case ID_BAIL:
 514             MSG("Emergency exit.\n");
 515             EXIT(1);
 516             endcase;
 517
 518         case ID_CATCH:
 519             Scratch = TOS;
 520             TOS = M_POP;
 521             SAVE_REGISTERS;
 522             Scratch = pfCatch( Scratch );
 523             LOAD_REGISTERS;
 524             M_PUSH( TOS );
 525             TOS = Scratch;
 526             endcase;
 527
 528         case ID_CALL_C:
 529             SAVE_REGISTERS;
 530             Scratch = READ_CELL_DIC(InsPtr++);
 531             CallUserFunction( Scratch & 0xFFFF,
 532                 (Scratch >> 31) & 1,
 533                 (Scratch >> 24) & 0x7F );
 534             LOAD_REGISTERS;
 535             endcase;
 536
 537         /* Support 32/64 bit operation. */
 538         case ID_CELL:
 539                 M_PUSH( TOS );
 540                 TOS = sizeof(cell_t);
 541                 endcase;
 542
 543         case ID_CELLS:
 544                 TOS = TOS * sizeof(cell_t);
 545                 endcase;
 546
 547         case ID_CFETCH:   TOS = *((uint8_t *) TOS); endcase;
 548
 549         case ID_CMOVE: /* ( src dst n -- ) */
 550             {
 551                 register char *DstPtr = (char *) M_POP; /* dst */
 552                 CharPtr = (char *) M_POP;    /* src */
 553                 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
 554                 {
 555                     *DstPtr++ = *CharPtr++;
 556                 }
 557                 M_DROP;
 558             }
 559             endcase;
 560
 561         case ID_CMOVE_UP: /* ( src dst n -- ) */
 562             {
 563                 register char *DstPtr = ((char *) M_POP) + TOS; /* dst */
 564                 CharPtr = ((char *) M_POP) + TOS;;    /* src */
 565                 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
 566                 {
 567                     *(--DstPtr) = *(--CharPtr);
 568                 }
 569                 M_DROP;
 570             }
 571             endcase;
 572
 573 #ifndef PF_NO_SHELL
 574         case ID_COLON:
 575             SAVE_REGISTERS;
 576             ffColon( );
 577             LOAD_REGISTERS;
 578             endcase;
 579         case ID_COLON_P:  /* ( $name xt -- ) */
 580             CreateDicEntry( TOS, (char *) M_POP, 0 );
 581             M_DROP;
 582             endcase;
 583 #endif  /* !PF_NO_SHELL */
 584
 585         case ID_COMPARE:
 586             {
 587                 const char *s1, *s2;
 588                 cell_t len1;
 589                 s2 = (const char *) M_POP;
 590                 len1 = M_POP;
 591                 s1 = (const char *) M_POP;
 592                 TOS = ffCompare( s1, len1, s2, TOS );
 593             }
 594             endcase;
 595
 596 /* ( a b -- flag , Comparisons ) */
 597         case ID_COMP_EQUAL:
 598             TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;
 599             endcase;
 600         case ID_COMP_NOT_EQUAL:
 601             TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;
 602             endcase;
 603         case ID_COMP_GREATERTHAN:
 604             TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;
 605             endcase;
 606         case ID_COMP_LESSTHAN:
 607             TOS = (  M_POP < TOS ) ? FTRUE : FFALSE ;
 608             endcase;
 609         case ID_COMP_U_GREATERTHAN:
 610             TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
 611             endcase;
 612         case ID_COMP_U_LESSTHAN:
 613             TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
 614             endcase;
 615         case ID_COMP_ZERO_EQUAL:
 616             TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;
 617             endcase;
 618         case ID_COMP_ZERO_NOT_EQUAL:
 619             TOS = ( TOS != 0 ) ? FTRUE : FALSE ;
 620             endcase;
 621         case ID_COMP_ZERO_GREATERTHAN:
 622             TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;
 623             endcase;
 624         case ID_COMP_ZERO_LESSTHAN:
 625             TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;
 626             endcase;
 627
 628         case ID_CR:
 629             EMIT_CR;
 630             endcase;
 631
 632 #ifndef PF_NO_SHELL
 633         case ID_CREATE:
 634             SAVE_REGISTERS;
 635             ffCreate();
 636             LOAD_REGISTERS;
 637             endcase;
 638 #endif  /* !PF_NO_SHELL */
 639
 640         case ID_CREATE_P:
 641             PUSH_TOS;
 642 /* Put address of body on stack.  Insptr points after code start. */
 643             TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );
 644             endcase;
 645
 646         case ID_CSTORE: /* ( c caddr -- ) */
 647             *((uint8_t *) TOS) = (uint8_t) M_POP;
 648             M_DROP;
 649             endcase;
 650
 651 /* Double precision add. */
 652         case ID_D_PLUS:  /* D+ ( al ah bl bh -- sl sh ) */
 653             {
 654                 register ucell_t ah,al,bl,sh,sl;
 655 #define bh TOS
 656                 bl = M_POP;
 657                 ah = M_POP;
 658                 al = M_POP;
 659                 sh = 0;
 660                 sl = al + bl;
 661                 if( sl < bl ) sh = 1; /* Carry */
 662                 sh += ah + bh;
 663                 M_PUSH( sl );
 664                 TOS = sh;
 665 #undef bh
 666             }
 667             endcase;
 668
 669 /* Double precision subtract. */
 670         case ID_D_MINUS:  /* D- ( al ah bl bh -- sl sh ) */
 671             {
 672                 register ucell_t ah,al,bl,sh,sl;
 673 #define bh TOS
 674                 bl = M_POP;
 675                 ah = M_POP;
 676                 al = M_POP;
 677                 sh = 0;
 678                 sl = al - bl;
 679                 if( al < bl ) sh = 1; /* Borrow */
 680                 sh = ah - bh - sh;
 681                 M_PUSH( sl );
 682                 TOS = sh;
 683 #undef bh
 684             }
 685             endcase;
 686
 687 /* Assume 8-bit char and calculate cell width. */
 688 #define NBITS ((sizeof(ucell_t)) * 8)
 689 /* Define half the number of bits in a cell. */
 690 #define HNBITS (NBITS / 2)
 691 /* Assume two-complement arithmetic to calculate lower half. */
 692 #define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))
 693 #define HIGH_BIT ((ucell_t)1 << (NBITS - 1))
 694
 695 /* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.
 696  * Using an improved algorithm suggested by Steve Green.
 697  * Converted to 64-bit by Aleksej Saushev.
 698  */
 699         case ID_D_UMTIMES:  /* UM* ( a b -- lo hi ) */
 700             {
 701                 ucell_t ahi, alo, bhi, blo; /* input parts */
 702                 ucell_t lo, hi, temp;
 703 /* Get values from stack. */
 704                 ahi = M_POP;
 705                 bhi = TOS;
 706 /* Break into hi and lo 16 bit parts. */
 707                 alo = LOWER_HALF(ahi);
 708                 ahi = ahi >> HNBITS;
 709                 blo = LOWER_HALF(bhi);
 710                 bhi = bhi >> HNBITS;
 711
 712                 lo = 0;
 713                 hi = 0;
 714 /* higher part: ahi * bhi */
 715                 hi += ahi * bhi;
 716 /* middle (overlapping) part: ahi * blo */
 717                 temp = ahi * blo;
 718                 lo += LOWER_HALF(temp);
 719                 hi += temp >> HNBITS;
 720 /* middle (overlapping) part: alo * bhi  */
 721                 temp = alo * bhi;
 722                 lo += LOWER_HALF(temp);
 723                 hi += temp >> HNBITS;
 724 /* lower part: alo * blo */
 725                 temp = alo * blo;
 726 /* its higher half overlaps with middle's lower half: */
 727                 lo += temp >> HNBITS;
 728 /* process carry: */
 729                 hi += lo >> HNBITS;
 730                 lo = LOWER_HALF(lo);
 731 /* combine lower part of result: */
 732                 lo = (lo << HNBITS) + LOWER_HALF(temp);
 733
 734                 M_PUSH( lo );
 735                 TOS = hi;
 736             }
 737             endcase;
 738
 739 /* Perform cell*cell bit multiply for 2 cell result, using shift and add. */
 740         case ID_D_MTIMES:  /* M* ( a b -- pl ph ) */
 741             {
 742                 ucell_t ahi, alo, bhi, blo; /* input parts */
 743                 ucell_t lo, hi, temp;
 744                 int sg;
 745 /* Get values from stack. */
 746                 ahi = M_POP;
 747                 bhi = TOS;
 748
 749 /* Calculate product sign: */
 750                 sg = ((cell_t)(ahi ^ bhi) < 0);
 751 /* Take absolute values and reduce to um* */
 752                 if ((cell_t)ahi < 0) ahi = (ucell_t)(-(cell_t)ahi);
 753                 if ((cell_t)bhi < 0) bhi = (ucell_t)(-(cell_t)bhi);
 754
 755 /* Break into hi and lo 16 bit parts. */
 756                 alo = LOWER_HALF(ahi);
 757                 ahi = ahi >> HNBITS;
 758                 blo = LOWER_HALF(bhi);
 759                 bhi = bhi >> HNBITS;
 760
 761                 lo = 0;
 762                 hi = 0;
 763 /* higher part: ahi * bhi */
 764                 hi += ahi * bhi;
 765 /* middle (overlapping) part: ahi * blo */
 766                 temp = ahi * blo;
 767                 lo += LOWER_HALF(temp);
 768                 hi += temp >> HNBITS;
 769 /* middle (overlapping) part: alo * bhi  */
 770                 temp = alo * bhi;
 771                 lo += LOWER_HALF(temp);
 772                 hi += temp >> HNBITS;
 773 /* lower part: alo * blo */
 774                 temp = alo * blo;
 775 /* its higher half overlaps with middle's lower half: */
 776                 lo += temp >> HNBITS;
 777 /* process carry: */
 778                 hi += lo >> HNBITS;
 779                 lo = LOWER_HALF(lo);
 780 /* combine lower part of result: */
 781                 lo = (lo << HNBITS) + LOWER_HALF(temp);
 782
 783 /* Negate product if one operand negative. */
 784                 if(sg)
 785                 {
 786                     /* lo = (ucell_t)(- lo); */
 787                     lo = ~lo + 1;
 788                     hi = ~hi + ((lo == 0) ? 1 : 0);
 789                 }
 790
 791                 M_PUSH( lo );
 792                 TOS = hi;
 793             }
 794             endcase;
 795
 796 #define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
 797 /* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */
 798         case ID_D_UMSMOD:  /* UM/MOD ( al ah bdiv -- rem q ) */
 799             {
 800                 ucell_t ah,al, q,di, bl,bh, sl,sh;
 801                 ah = M_POP;
 802                 al = M_POP;
 803                 bh = TOS;
 804                 bl = 0;
 805                 q = 0;
 806                 for( di=0; di<NBITS; di++ )
 807                 {
 808                     if( !DULT(al,ah,bl,bh) )
 809                     {
 810                         sh = 0;
 811                         sl = al - bl;
 812                         if( al < bl ) sh = 1; /* Borrow */
 813                         sh = ah - bh - sh;
 814                         ah = sh;
 815                         al = sl;
 816                         q |= 1;
 817                     }
 818                     q = q << 1;
 819                     bl = (bl >> 1) | (bh << (NBITS-1));
 820                     bh = bh >> 1;
 821                 }
 822                 if( !DULT(al,ah,bl,bh) )
 823                 {
 824
 825                     al = al - bl;
 826                     q |= 1;
 827                 }
 828                 M_PUSH( al );  /* rem */
 829                 TOS = q;
 830             }
 831             endcase;
 832
 833 /* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */
 834         case ID_D_MUSMOD:  /* MU/MOD ( al am bdiv -- rem ql qh ) */
 835             {
 836                 register ucell_t ah,am,al,ql,qh,di;
 837 #define bdiv ((ucell_t)TOS)
 838                 ah = 0;
 839                 am = M_POP;
 840                 al = M_POP;
 841                 qh = ql = 0;
 842                 for( di=0; di<2*NBITS; di++ )
 843                 {
 844                     if( bdiv <= ah )
 845                     {
 846                         ah = ah - bdiv;
 847                         ql |= 1;
 848                     }
 849                     qh = (qh << 1) | (ql >> (NBITS-1));
 850                     ql = ql << 1;
 851                     ah = (ah << 1) | (am >> (NBITS-1));
 852                     am = (am << 1) | (al >> (NBITS-1));
 853                     al = al << 1;
 854 DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
 855                 }
 856                 if( bdiv <= ah )
 857                 {
 858                     ah = ah - bdiv;
 859                     ql |= 1;
 860                 }
 861                 M_PUSH( ah ); /* rem */
 862                 M_PUSH( ql );
 863                 TOS = qh;
 864 #undef bdiv
 865             }
 866             endcase;
 867
 868 #ifndef PF_NO_SHELL
 869         case ID_DEFER:
 870             ffDefer( );
 871             endcase;
 872 #endif  /* !PF_NO_SHELL */
 873
 874         case ID_DEFER_P:
 875             endcase;
 876
 877         case ID_DEPTH:
 878             PUSH_TOS;
 879             TOS = gCurrentTask->td_StackBase - STKPTR;
 880             endcase;
 881
 882         case ID_DIVIDE:     BINARY_OP( / ); endcase;
 883
 884         case ID_DOT:
 885             ffDot( TOS );
 886             M_DROP;
 887             endcase;
 888
 889         case ID_DOTS:
 890             M_DOTS;
 891             endcase;
 892
 893         case ID_DROP:  M_DROP; endcase;
 894
 895         case ID_DUMP:
 896             Scratch = M_POP;
 897             DumpMemory( (char *) Scratch, TOS );
 898             M_DROP;
 899             endcase;
 900
 901         case ID_DUP:   M_DUP; endcase;
 902
 903         case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */
 904             M_R_PUSH( TOS );
 905             M_R_PUSH( M_POP );
 906             M_DROP;
 907             endcase;
 908
 909         case ID_EOL:    /* ( -- end_of_line_char ) */
 910             PUSH_TOS;
 911             TOS = (cell_t) '\n';
 912             endcase;
 913
 914         case ID_ERRORQ_P:  /* ( flag num -- , quit if flag true ) */
 915             Scratch = TOS;
 916             M_DROP;
 917             if(TOS)
 918             {
 919                 M_THROW(Scratch);
 920             }
 921             else
 922             {
 923                 M_DROP;
 924             }
 925             endcase;
 926
 927         case ID_EMIT_P:
 928             EMIT( (char) TOS );
 929             M_DROP;
 930             endcase;
 931
 932         case ID_EXECUTE:
 933 /* Save IP on return stack like a JSR. */
 934             M_R_PUSH( InsPtr );
 935 #ifdef PF_SUPPORT_TRACE
 936 /* Bump level for trace. */
 937             Level++;
 938 #endif
 939             if( IsTokenPrimitive( TOS ) )
 940             {
 941                 WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS);   /* Build a fake secondary and execute it. */
 942                 InsPtr = &FakeSecondary[0];
 943             }
 944             else
 945             {
 946                 InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);
 947             }
 948             M_DROP;
 949             endcase;
 950
 951         case ID_FETCH:
 952 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
 953             if( IN_DICS( TOS ) )
 954             {
 955                 TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);
 956             }
 957             else
 958             {
 959                 TOS = *((cell_t *)TOS);
 960             }
 961 #else
 962             TOS = *((cell_t *)TOS);
 963 #endif
 964             endcase;
 965
 966         case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */
 967 /* Build NUL terminated name string. */
 968             Scratch = M_POP; /* u */
 969             Temp = M_POP;    /* caddr */
 970             if( Scratch < TIB_SIZE-2 )
 971             {
 972                 const char *famText = pfSelectFileModeCreate( TOS );
 973                 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
 974                 gScratch[Scratch] = '\0';
 975                 DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));
 976                 FileID = sdOpenFile( gScratch, famText );
 977                 TOS = ( FileID == NULL ) ? -1 : 0 ;
 978                 M_PUSH( (cell_t) FileID );
 979             }
 980             else
 981             {
 982                 ERR("Filename too large for name buffer.\n");
 983                 M_PUSH( 0 );
 984                 TOS = -2;
 985             }
 986             endcase;
 987
 988         case ID_FILE_DELETE: /* ( c-addr u -- ior ) */
 989 /* Build NUL terminated name string. */
 990             Temp = M_POP;    /* caddr */
 991             if( TOS < TIB_SIZE-2 )
 992             {
 993                 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS );
 994                 gScratch[TOS] = '\0';
 995                 DBUG(("Delete file = %s\n", gScratch ));
 996                 TOS = sdDeleteFile( gScratch );
 997             }
 998             else
 999             {
1000                 ERR("Filename too large for name buffer.\n");
1001                 TOS = -2;
1002             }
1003             endcase;
1004
1005         case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */
1006 /* Build NUL terminated name string. */
1007             Scratch = M_POP; /* u */
1008             Temp = M_POP;    /* caddr */
1009             if( Scratch < TIB_SIZE-2 )
1010             {
1011                 const char *famText = pfSelectFileModeOpen( TOS );
1012                 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
1013                 gScratch[Scratch] = '\0';
1014                 DBUG(("Open file = %s\n", gScratch ));
1015                 FileID = sdOpenFile( gScratch, famText );
1016
1017                 TOS = ( FileID == NULL ) ? -1 : 0 ;
1018                 M_PUSH( (cell_t) FileID );
1019             }
1020             else
1021             {
1022                 ERR("Filename too large for name buffer.\n");
1023                 M_PUSH( 0 );
1024                 TOS = -2;
1025             }
1026             endcase;
1027
1028         case ID_FILE_CLOSE: /* ( fid -- ior ) */
1029             TOS = sdCloseFile( (FileStream *) TOS );
1030             endcase;
1031
1032         case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */
1033             FileID = (FileStream *) TOS;
1034             Scratch = M_POP;
1035             CharPtr = (char *) M_POP;
1036             Temp = sdReadFile( CharPtr, 1, Scratch, FileID );
1037             /* TODO check feof() or ferror() */
1038             M_PUSH(Temp);
1039             TOS = 0;
1040             endcase;
1041
1042         /* TODO Why does this crash when passed an illegal FID? */
1043         case ID_FILE_SIZE: /* ( fid -- ud ior ) */
1044 /* Determine file size by seeking to end and returning position. */
1045             FileID = (FileStream *) TOS;
1046             {
1047                 file_offset_t endposition = -1;
1048                 file_offset_t original = sdTellFile( FileID );
1049                 if (original >= 0)
1050                 {
1051                     sdSeekFile( FileID, 0, PF_SEEK_END );
1052                     endposition = sdTellFile( FileID );
1053                     /* Restore original position. */
1054                     sdSeekFile( FileID, original, PF_SEEK_SET );
1055                 }
1056                 if (endposition < 0)
1057                 {
1058                     M_PUSH(0); /* low */
1059                     M_PUSH(0); /* high */
1060                     TOS = -4;  /* TODO proper error number */
1061                 }
1062                 else
1063                 {
1064                     M_PUSH(endposition); /* low */
1065                     /* We do not support double precision file offsets.*/
1066                     M_PUSH(0); /* high */
1067                     TOS = 0;   /* OK */
1068                 }
1069             }
1070             endcase;
1071
1072         case ID_FILE_WRITE: /* ( addr len fid -- ior ) */
1073             FileID = (FileStream *) TOS;
1074             Scratch = M_POP;
1075             CharPtr = (char *) M_POP;
1076             Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );
1077             TOS = (Temp != Scratch) ? -3 : 0;
1078             endcase;
1079
1080         case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */
1081             {
1082                 file_offset_t offset;
1083                 cell_t offsetHigh;
1084                 cell_t offsetLow;
1085                 FileID = (FileStream *) TOS;
1086                 offsetHigh = M_POP;
1087                 offsetLow = M_POP;
1088                 /* We do not support double precision file offsets in pForth.
1089                  * So check to make sure the high bits are not used.
1090                  */
1091                 if (offsetHigh != 0)
1092                 {
1093                     TOS = -3; /* TODO err num? */
1094                     break;
1095                 }
1096                 offset = (file_offset_t)offsetLow;
1097                 TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );
1098             }
1099             endcase;
1100
1101         case ID_FILE_POSITION: /* ( fid -- ud ior ) */
1102             {
1103                 file_offset_t position;
1104                 FileID = (FileStream *) TOS;
1105                 position = sdTellFile( FileID );
1106                 if (position < 0)
1107                 {
1108                     M_PUSH(0); /* low */
1109                     M_PUSH(0); /* high */
1110                     TOS = -4;  /* TODO proper error number */
1111                 }
1112                 else
1113                 {
1114                     M_PUSH(position); /* low */
1115                     /* We do not support double precision file offsets.*/
1116                     M_PUSH(0); /* high */
1117                     TOS = 0; /* OK */
1118                 }
1119             }
1120             endcase;
1121
1122         case ID_FILE_RO: /* (  -- fam ) */
1123             PUSH_TOS;
1124             TOS = PF_FAM_READ_ONLY;
1125             endcase;
1126
1127         case ID_FILE_RW: /* ( -- fam ) */
1128             PUSH_TOS;
1129             TOS = PF_FAM_READ_WRITE;
1130             endcase;
1131
1132         case ID_FILE_WO: /* ( -- fam ) */
1133             PUSH_TOS;
1134             TOS = PF_FAM_WRITE_ONLY;
1135             endcase;
1136
1137         case ID_FILE_BIN: /* ( fam1 -- fam2 ) */
1138             TOS = TOS | PF_FAM_BINARY_FLAG;
1139             endcase;
1140
1141         case ID_FILE_FLUSH: /* ( fileid -- ior ) */
1142             {
1143                 FileStream *Stream = (FileStream *) TOS;
1144                 TOS = (sdFlushFile( Stream ) == 0) ? 0 : THROW_FLUSH_FILE;
1145             }
1146             endcase;
1147
1148         case ID_FILE_RENAME: /* ( oldName newName -- ior ) */
1149             {
1150                 char *New = (char *) TOS;
1151                 char *Old = (char *) M_POP;
1152                 TOS = sdRenameFile( Old, New );
1153             }
1154             endcase;
1155
1156         case ID_FILE_RESIZE: /* ( ud fileid -- ior ) */
1157             {
1158                 FileStream *File = (FileStream *) TOS;
1159                 ucell_t SizeHi = (ucell_t) M_POP;
1160                 ucell_t SizeLo = (ucell_t) M_POP;
1161                 TOS = ( UdIsUint64( SizeLo, SizeHi )
1162                         ? sdResizeFile( File, UdToUint64( SizeLo, SizeHi ))
1163                         : THROW_RESIZE_FILE );
1164             }
1165             endcase;
1166
1167         case ID_FILL: /* ( caddr num charval -- ) */
1168             {
1169                 register char *DstPtr;
1170                 Temp = M_POP;    /* num */
1171                 DstPtr = (char *) M_POP; /* dst */
1172                 for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )
1173                 {
1174                     *DstPtr++ = (char) TOS;
1175                 }
1176                 M_DROP;
1177             }
1178             endcase;
1179
1180 #ifndef PF_NO_SHELL
1181         case ID_FIND:  /* ( $addr -- $addr 0 | xt +-1 ) */
1182             TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
1183             M_PUSH( Temp );
1184             endcase;
1185
1186         case ID_FINDNFA:
1187             TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
1188             M_PUSH( (cell_t) Temp );
1189             endcase;
1190 #endif  /* !PF_NO_SHELL */
1191
1192         case ID_FLUSHEMIT:
1193             sdTerminalFlush();
1194             endcase;
1195
1196 /* Validate memory before freeing. Clobber validator and first word. */
1197         case ID_FREE:   /* ( addr -- result ) */
1198             if( TOS == 0 )
1199             {
1200                 ERR("FREE passed NULL!\n");
1201                 TOS = -2; /* FIXME error code */
1202             }
1203             else
1204             {
1205                 CellPtr = (cell_t *) TOS;
1206                 CellPtr--;
1207                 if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))
1208                 {
1209                     TOS = -2; /* FIXME error code */
1210                 }
1211                 else
1212                 {
1213                     CellPtr[0] = 0xDeadBeef;
1214                     pfFreeMem((char *)CellPtr);
1215                     TOS = 0;
1216                 }
1217             }
1218             endcase;
1219
1220 #include "pfinnrfp.h"
1221
1222         case ID_HERE:
1223             PUSH_TOS;
1224             TOS = (cell_t)CODE_HERE;
1225             endcase;
1226
1227         case ID_NUMBERQ_P:   /* ( addr -- 0 | n 1 ) */
1228 /* Convert using number converter in 'C'.
1229 ** Only supports single precision for bootstrap.
1230 */
1231             TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );
1232             if( TOS == NUM_TYPE_SINGLE)
1233             {
1234                 M_PUSH( Temp );   /* Push single number */
1235             }
1236             endcase;
1237
1238         case ID_I:  /* ( -- i , DO LOOP index ) */
1239             PUSH_TOS;
1240             TOS = M_R_PICK(1);
1241             endcase;
1242
1243 #ifndef PF_NO_SHELL
1244         case ID_INCLUDE_FILE:
1245             FileID = (FileStream *) TOS;
1246             M_DROP;    /* Drop now so that INCLUDE has a clean stack. */
1247             SAVE_REGISTERS;
1248             Scratch = ffIncludeFile( FileID );
1249             LOAD_REGISTERS;
1250             if( Scratch ) M_THROW(Scratch)
1251             endcase;
1252 #endif  /* !PF_NO_SHELL */
1253
1254 #ifndef PF_NO_SHELL
1255         case ID_INTERPRET:
1256             SAVE_REGISTERS;
1257             Scratch = ffInterpret();
1258             LOAD_REGISTERS;
1259             if( Scratch ) M_THROW(Scratch)
1260             endcase;
1261 #endif  /* !PF_NO_SHELL */
1262
1263         case ID_J:  /* ( -- j , second DO LOOP index ) */
1264             PUSH_TOS;
1265             TOS = M_R_PICK(3);
1266             endcase;
1267
1268         case ID_KEY:
1269             PUSH_TOS;
1270             TOS = ioKey();
1271             if (TOS == ASCII_EOT) {
1272                 M_THROW(THROW_BYE);
1273             }
1274             endcase;
1275
1276 #ifndef PF_NO_SHELL
1277         case ID_LITERAL:
1278             ffLiteral( TOS );
1279             M_DROP;
1280             endcase;
1281 #endif /* !PF_NO_SHELL */
1282
1283         case ID_LITERAL_P:
1284             DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
1285             PUSH_TOS;
1286             TOS = READ_CELL_DIC(InsPtr++);
1287             endcase;
1288
1289 #ifndef PF_NO_SHELL
1290         case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
1291 #endif /* !PF_NO_SHELL */
1292
1293         case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
1294             TOS = *(LocalsPtr - TOS);
1295             endcase;
1296
1297 #define LOCAL_FETCH_N(num) \
1298         case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
1299             PUSH_TOS; \
1300             TOS = *(LocalsPtr -(num)); \
1301             endcase;
1302
1303         LOCAL_FETCH_N(1);
1304         LOCAL_FETCH_N(2);
1305         LOCAL_FETCH_N(3);
1306         LOCAL_FETCH_N(4);
1307         LOCAL_FETCH_N(5);
1308         LOCAL_FETCH_N(6);
1309         LOCAL_FETCH_N(7);
1310         LOCAL_FETCH_N(8);
1311
1312         case ID_LOCAL_STORE:  /* ( n i <local> -- , store n in local ) */
1313             *(LocalsPtr - TOS) = M_POP;
1314             M_DROP;
1315             endcase;
1316
1317 #define LOCAL_STORE_N(num) \
1318         case ID_LOCAL_STORE_##num:  /* ( n <local> -- , store n in local ) */ \
1319             *(LocalsPtr - (num)) = TOS; \
1320             M_DROP; \
1321             endcase;
1322
1323         LOCAL_STORE_N(1);
1324         LOCAL_STORE_N(2);
1325         LOCAL_STORE_N(3);
1326         LOCAL_STORE_N(4);
1327         LOCAL_STORE_N(5);
1328         LOCAL_STORE_N(6);
1329         LOCAL_STORE_N(7);
1330         LOCAL_STORE_N(8);
1331
1332         case ID_LOCAL_PLUSSTORE:  /* ( n i <local> -- , add n to local ) */
1333             *(LocalsPtr - TOS) += M_POP;
1334             M_DROP;
1335             endcase;
1336
1337         case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
1338         /* create local stack frame */
1339             {
1340                 cell_t i = TOS;
1341                 cell_t *lp;
1342                 DBUG(("LocalEntry: n = %d\n", TOS));
1343                 /* End of locals. Create stack frame */
1344                 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
1345                     TORPTR, LocalsPtr));
1346                 M_R_PUSH(LocalsPtr);
1347                 LocalsPtr = TORPTR;
1348                 TORPTR -= TOS;
1349                 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
1350                     TORPTR, LocalsPtr));
1351                 lp = TORPTR;
1352                 while(i-- > 0)
1353                 {
1354                     *lp++ = M_POP;    /* Load local vars from stack */
1355                 }
1356                 M_DROP;
1357             }
1358             endcase;
1359
1360         case ID_LOCAL_EXIT: /* cleanup up local stack frame */
1361             DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
1362                 TORPTR, LocalsPtr));
1363             TORPTR = LocalsPtr;
1364             LocalsPtr = (cell_t *) M_R_POP;
1365             DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
1366                 TORPTR, LocalsPtr));
1367             endcase;
1368
1369 #ifndef PF_NO_SHELL
1370         case ID_LOADSYS:
1371             MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
1372             FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
1373             if( FileID )
1374             {
1375                 SAVE_REGISTERS;
1376                 Scratch = ffIncludeFile( FileID ); /* Also closes the file. */
1377                 LOAD_REGISTERS;
1378                 if( Scratch ) M_THROW(Scratch);
1379             }
1380             else
1381             {
1382                  ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
1383             }
1384             endcase;
1385 #endif  /* !PF_NO_SHELL */
1386
1387         case ID_LEAVE_P: /* ( R: index limit --  ) */
1388             M_R_DROP;
1389             M_R_DROP;
1390             M_BRANCH;
1391             endcase;
1392
1393         case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
1394             Temp = M_R_POP; /* limit */
1395             Scratch = M_R_POP + 1; /* index */
1396             if( Scratch == Temp )
1397             {
1398                 InsPtr++;   /* skip branch offset, exit loop */
1399             }
1400             else
1401             {
1402 /* Push index and limit back to R */
1403                 M_R_PUSH( Scratch );
1404                 M_R_PUSH( Temp );
1405 /* Branch back to just after (DO) */
1406                 M_BRANCH;
1407             }
1408             endcase;
1409
1410         case ID_LSHIFT:     BINARY_OP( << ); endcase;
1411
1412         case ID_MAX:
1413             Scratch = M_POP;
1414             TOS = ( TOS > Scratch ) ? TOS : Scratch ;
1415             endcase;
1416
1417         case ID_MIN:
1418             Scratch = M_POP;
1419             TOS = ( TOS < Scratch ) ? TOS : Scratch ;
1420             endcase;
1421
1422         case ID_MINUS:     BINARY_OP( - ); endcase;
1423
1424 #ifndef PF_NO_SHELL
1425         case ID_NAME_TO_TOKEN:
1426             TOS = (cell_t) NameToToken((ForthString *)TOS);
1427             endcase;
1428
1429         case ID_NAME_TO_PREVIOUS:
1430             TOS = (cell_t) NameToPrevious((ForthString *)TOS);
1431             endcase;
1432 #endif
1433
1434         case ID_NOOP:
1435             endcase;
1436
1437         case ID_OR:     BINARY_OP( | ); endcase;
1438
1439         case ID_OVER:
1440             PUSH_TOS;
1441             TOS = M_STACK(1);
1442             endcase;
1443
1444         case ID_PICK: /* ( ... n -- sp(n) ) */
1445             TOS = M_STACK(TOS);
1446             endcase;
1447
1448         case ID_PLUS:     BINARY_OP( + ); endcase;
1449
1450         case ID_PLUS_STORE:   /* ( n addr -- , add n to *addr ) */
1451 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1452             if( IN_DICS( TOS ) )
1453             {
1454                 Scratch = READ_CELL_DIC((cell_t *)TOS);
1455                 Scratch += M_POP;
1456                 WRITE_CELL_DIC((cell_t *)TOS,Scratch);
1457             }
1458             else
1459             {
1460                 *((cell_t *)TOS) += M_POP;
1461             }
1462 #else
1463             *((cell_t *)TOS) += M_POP;
1464 #endif
1465             M_DROP;
1466             endcase;
1467
1468         case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
1469             {
1470                 cell_t Limit = M_R_POP;
1471                 cell_t OldIndex = M_R_POP;
1472                 cell_t Delta = TOS; /* add TOS to index, not 1 */
1473                 cell_t NewIndex = OldIndex + Delta;
1474                 cell_t OldDiff = OldIndex - Limit;
1475
1476                 /* This exploits this idea (lifted from Gforth):
1477                    (x^y)<0 is equivalent to (x<0) != (y<0) */
1478                 if( ((OldDiff ^ (OldDiff + Delta)) /* is the limit crossed? */
1479                      & (OldDiff ^ Delta))          /* is it a wrap-around? */
1480                     < 0 )
1481                 {
1482                     InsPtr++;   /* skip branch offset, exit loop */
1483                 }
1484                 else
1485                 {
1486 /* Push index and limit back to R */
1487                     M_R_PUSH( NewIndex );
1488                     M_R_PUSH( Limit );
1489 /* Branch back to just after (DO) */
1490                     M_BRANCH;
1491                 }
1492                 M_DROP;
1493             }
1494             endcase;
1495
1496         case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
1497             Scratch = M_POP;  /* limit */
1498             if( Scratch == TOS )
1499             {
1500 /* Branch to just after (LOOP) */
1501                 M_BRANCH;
1502             }
1503             else
1504             {
1505                 M_R_PUSH( TOS );
1506                 M_R_PUSH( Scratch );
1507                 InsPtr++;   /* skip branch offset, enter loop */
1508             }
1509             M_DROP;
1510             endcase;
1511
1512         case ID_QDUP:     if( TOS ) M_DUP; endcase;
1513
1514         case ID_QTERMINAL:  /* WARNING: Typically not fully implemented! */
1515             PUSH_TOS;
1516             TOS = sdQueryTerminal();
1517             endcase;
1518
1519         case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
1520 #ifdef PF_SUPPORT_TRACE
1521             Level = 0;
1522 #endif
1523             M_THROW(THROW_QUIT);
1524             endcase;
1525
1526         case ID_R_DROP:
1527             M_R_DROP;
1528             endcase;
1529
1530         case ID_R_FETCH:
1531             PUSH_TOS;
1532             TOS = (*(TORPTR));
1533             endcase;
1534
1535         case ID_R_FROM:
1536             PUSH_TOS;
1537             TOS = M_R_POP;
1538             endcase;
1539
1540         case ID_REFILL:
1541             PUSH_TOS;
1542             TOS = (ffRefill() > 0) ? FTRUE : FFALSE;
1543             endcase;
1544
1545 /* Resize memory allocated by ALLOCATE. */
1546         case ID_RESIZE:  /* ( addr1 u -- addr2 result ) */
1547             {
1548                 cell_t *Addr1 = (cell_t *) M_POP;
1549                 /* Point to validator below users address. */
1550                 cell_t *FreePtr = Addr1 - 1;
1551                 if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))
1552                 {
1553                     /* 090218 - Fixed bug, was returning zero. */
1554                     M_PUSH( Addr1 );
1555                     TOS = -3;
1556                 }
1557                 else
1558                 {
1559                     /* Try to allocate. */
1560                     CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );
1561                     if( CellPtr )
1562                     {
1563                         /* Copy memory including validation. */
1564                         pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );
1565                         *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);
1566                         /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */
1567                         /* Increment past validator to user address. */
1568                         M_PUSH( (cell_t) (CellPtr + 1) );
1569                         TOS = 0; /* Result code. */
1570                         /* Mark old cell as dead so we can't free it twice. */
1571                         FreePtr[0] = 0xDeadBeef;
1572                         pfFreeMem((char *) FreePtr);
1573                     }
1574                     else
1575                     {
1576                         /* 090218 - Fixed bug, was returning zero. */
1577                         M_PUSH( Addr1 );
1578                         TOS = -4;  /* FIXME Fix error code. */
1579                     }
1580                 }
1581             }
1582             endcase;
1583
1584 /*
1585 ** RP@ and RP! are called secondaries so we must
1586 ** account for the return address pushed before calling.
1587 */
1588         case ID_RP_FETCH:    /* ( -- rp , address of top of return stack ) */
1589             PUSH_TOS;
1590             TOS = (cell_t)TORPTR;  /* value before calling RP@ */
1591             endcase;
1592
1593         case ID_RP_STORE:    /* ( rp -- , address of top of return stack ) */
1594             TORPTR = (cell_t *) TOS;
1595             M_DROP;
1596             endcase;
1597
1598         case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
1599             {
1600                 cell_t ri;
1601                 cell_t *srcPtr, *dstPtr;
1602                 Scratch = M_STACK(TOS);
1603                 srcPtr = &M_STACK(TOS-1);
1604                 dstPtr = &M_STACK(TOS);
1605                 for( ri=0; ri<TOS; ri++ )
1606                 {
1607                     *dstPtr-- = *srcPtr--;
1608                 }
1609                 TOS = Scratch;
1610                 STKPTR++;
1611             }
1612             endcase;
1613
1614         case ID_ROT:  /* ( a b c -- b c a ) */
1615             Scratch = M_POP;    /* b */
1616             Temp = M_POP;       /* a */
1617             M_PUSH( Scratch );  /* b */
1618             PUSH_TOS;           /* c */
1619             TOS = Temp;         /* a */
1620             endcase;
1621
1622 /* Logical right shift */
1623         case ID_RSHIFT:     { TOS = ((ucell_t)M_POP) >> TOS; } endcase;
1624
1625 #ifndef PF_NO_SHELL
1626         case ID_SAVE_FORTH_P:   /* ( $name Entry NameSize CodeSize -- err ) */
1627             {
1628                 cell_t NameSize, CodeSize, EntryPoint;
1629                 CodeSize = TOS;
1630                 NameSize = M_POP;
1631                 EntryPoint = M_POP;
1632                 ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );
1633                 TOS =  ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
1634             }
1635             endcase;
1636 #endif
1637
1638         case ID_SLEEP_P:
1639             TOS = sdSleepMillis(TOS);
1640             endcase;
1641
1642         case ID_SP_FETCH:    /* ( -- sp , address of top of stack, sorta ) */
1643             PUSH_TOS;
1644             TOS = (cell_t)STKPTR;
1645             endcase;
1646
1647         case ID_SP_STORE:    /* ( sp -- , address of top of stack, sorta ) */
1648             STKPTR = (cell_t *) TOS;
1649             M_DROP;
1650             endcase;
1651
1652         case ID_STORE: /* ( n addr -- , write n to addr ) */
1653 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1654             if( IN_DICS( TOS ) )
1655             {
1656                 WRITE_CELL_DIC((cell_t *)TOS,M_POP);
1657             }
1658             else
1659             {
1660                 *((cell_t *)TOS) = M_POP;
1661             }
1662 #else
1663             *((cell_t *)TOS) = M_POP;
1664 #endif
1665             M_DROP;
1666             endcase;
1667
1668         case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
1669             Scratch = M_POP; /* cnt */
1670             Temp = M_POP;    /* addr */
1671             TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1672             M_PUSH((cell_t) CharPtr);
1673             endcase;
1674
1675 #ifndef PF_NO_SHELL
1676         case ID_SEMICOLON:
1677             SAVE_REGISTERS;
1678             Scratch = ffSemiColon();
1679             LOAD_REGISTERS;
1680             if( Scratch ) M_THROW( Scratch );
1681             endcase;
1682 #endif /* !PF_NO_SHELL */
1683
1684         case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
1685             Scratch = M_POP; /* cnt */
1686             Temp = M_POP;    /* addr */
1687             TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1688             M_PUSH((cell_t) CharPtr);
1689             endcase;
1690
1691         case ID_SOURCE:  /* ( -- c-addr num ) */
1692             PUSH_TOS;
1693             M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );
1694             TOS = (cell_t) gCurrentTask->td_SourceNum;
1695             endcase;
1696
1697         case ID_SOURCE_SET: /* ( c-addr num -- ) */
1698             gCurrentTask->td_SourcePtr = (char *) M_POP;
1699             gCurrentTask->td_SourceNum = TOS;
1700             M_DROP;
1701             endcase;
1702
1703         case ID_SOURCE_ID:
1704             PUSH_TOS;
1705             TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
1706             endcase;
1707
1708         case ID_SOURCE_ID_POP:
1709             PUSH_TOS;
1710             TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
1711             endcase;
1712
1713         case ID_SOURCE_ID_PUSH:  /* ( source-id -- ) */
1714             TOS = (cell_t)ffConvertSourceIDToStream( TOS );
1715             Scratch = ffPushInputStream((FileStream *) TOS );
1716             if( Scratch )
1717             {
1718                 M_THROW(Scratch);
1719             }
1720             else M_DROP;
1721             endcase;
1722
1723         case ID_SOURCE_LINE_NUMBER_FETCH: /* ( -- linenr ) */
1724             PUSH_TOS;
1725             TOS = gCurrentTask->td_LineNumber;
1726             endcase;
1727
1728         case ID_SOURCE_LINE_NUMBER_STORE: /* ( linenr -- ) */
1729             gCurrentTask->td_LineNumber = TOS;
1730             TOS = M_POP;
1731             endcase;
1732
1733         case ID_SWAP:
1734             Scratch = TOS;
1735             TOS = *STKPTR;
1736             *STKPTR = Scratch;
1737             endcase;
1738
1739         case ID_TEST1:
1740             PUSH_TOS;
1741             M_PUSH( 0x11 );
1742             M_PUSH( 0x22 );
1743             TOS = 0x33;
1744             endcase;
1745
1746         case ID_TEST2:
1747             endcase;
1748
1749         case ID_THROW:  /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
1750             if(TOS)
1751             {
1752                 M_THROW(TOS);
1753             }
1754             else M_DROP;
1755             endcase;
1756
1757 #ifndef PF_NO_SHELL
1758         case ID_TICK:
1759             PUSH_TOS;
1760             CharPtr = (char *) ffWord( (char) ' ' );
1761             TOS = ffFind( CharPtr, (ExecToken *) &Temp );
1762             if( TOS == 0 )
1763             {
1764                 ERR("' could not find ");
1765                 ioType( (char *) CharPtr+1, *CharPtr );
1766                 EMIT_CR;
1767                 M_THROW(-13);
1768             }
1769             else
1770             {
1771                 TOS = Temp;
1772             }
1773             endcase;
1774 #endif  /* !PF_NO_SHELL */
1775
1776         case ID_TIMES: BINARY_OP( * ); endcase;
1777
1778         case ID_TYPE:
1779             Scratch = M_POP; /* addr */
1780             ioType( (char *) Scratch, TOS );
1781             M_DROP;
1782             endcase;
1783
1784         case ID_TO_R:
1785             M_R_PUSH( TOS );
1786             M_DROP;
1787             endcase;
1788
1789         case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
1790         case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
1791         case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
1792         case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
1793         case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
1794         case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
1795         case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
1796         case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
1797         case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;
1798         case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
1799         case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
1800         case ID_VAR_STATE: DO_VAR(gVarState); endcase;
1801         case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
1802         case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
1803         case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
1804         case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
1805         case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
1806
1807         case ID_WORD:
1808             TOS = (cell_t) ffWord( (char) TOS );
1809             endcase;
1810
1811         case ID_WORD_FETCH: /* ( waddr -- w ) */
1812 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1813             if( IN_DICS( TOS ) )
1814             {
1815                 TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);
1816             }
1817             else
1818             {
1819                 TOS = *((uint16_t *)TOS);
1820             }
1821 #else
1822             TOS = *((uint16_t *)TOS);
1823 #endif
1824             endcase;
1825
1826         case ID_WORD_STORE: /* ( w waddr -- ) */
1827
1828 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1829             if( IN_DICS( TOS ) )
1830             {
1831                 WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);
1832             }
1833             else
1834             {
1835                 *((uint16_t *)TOS) = (uint16_t) M_POP;
1836             }
1837 #else
1838             *((uint16_t *)TOS) = (uint16_t) M_POP;
1839 #endif
1840             M_DROP;
1841             endcase;
1842
1843         case ID_XOR: BINARY_OP( ^ ); endcase;
1844
1845
1846 /* Branch is followed by an offset relative to address of offset. */
1847         case ID_ZERO_BRANCH:
1848 DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
1849             if( TOS == 0 )
1850             {
1851                 M_BRANCH;
1852             }
1853             else
1854             {
1855                 InsPtr++;      /* skip over offset */
1856             }
1857             M_DROP;
1858 DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
1859             endcase;
1860
1861         default:
1862             ERR("pfCatch: Unrecognised token = 0x");
1863             ffDotHex(Token);
1864             ERR(" at 0x");
1865             ffDotHex((cell_t) InsPtr);
1866             EMIT_CR;
1867             InsPtr = 0;
1868             endcase;
1869         }
1870
1871         if(InsPtr) Token = READ_CELL_DIC(InsPtr++);   /* Traverse to next token in secondary. */
1872
1873 #ifdef PF_DEBUG
1874         M_DOTS;
1875 #endif
1876
1877 #if 0
1878         if( _CrtCheckMemory() == 0 )
1879         {
1880             ERR("_CrtCheckMemory abort: InsPtr = 0x");
1881             ffDotHex((int)InsPtr);
1882             ERR("\n");
1883         }
1884 #endif
1885
1886     } while( (InitialReturnStack - TORPTR) > 0 );
1887
1888     SAVE_REGISTERS;
1889
1890     return ExceptionReturnCode;
1891 }