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