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