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