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(cell_t fam );
 215 static const char *pfSelectFileModeOpen(cell_t fam );
 216
 217 /**************************************************************/
 218 static const char *pfSelectFileModeCreate( cell_t 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( cell_t 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 ThrowCode 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             EMIT_CR;
 506             M_THROW( THROW_BYE );
 507             endcase;
 508
 509         case ID_BAIL:
 510             MSG("Emergency exit.\n");
 511             EXIT(1);
 512             endcase;
 513
 514         case ID_CATCH:
 515             Scratch = TOS;
 516             TOS = M_POP;
 517             SAVE_REGISTERS;
 518             Scratch = pfCatch( Scratch );
 519             LOAD_REGISTERS;
 520             M_PUSH( TOS );
 521             TOS = Scratch;
 522             endcase;
 523
 524         case ID_CALL_C:
 525             SAVE_REGISTERS;
 526             Scratch = READ_CELL_DIC(InsPtr++);
 527             CallUserFunction( Scratch & 0xFFFF,
 528                 (Scratch >> 31) & 1,
 529                 (Scratch >> 24) & 0x7F );
 530             LOAD_REGISTERS;
 531             endcase;
 532
 533         /* Support 32/64 bit operation. */
 534         case ID_CELL:
 535                 M_PUSH( TOS );
 536                 TOS = sizeof(cell_t);
 537                 endcase;
 538
 539         case ID_CELLS:
 540                 TOS = TOS * sizeof(cell_t);
 541                 endcase;
 542
 543         case ID_CFETCH:   TOS = *((uint8_t *) TOS); endcase;
 544
 545         case ID_CMOVE: /* ( src dst n -- ) */
 546             {
 547                 register char *DstPtr = (char *) M_POP; /* dst */
 548                 CharPtr = (char *) M_POP;    /* src */
 549                 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
 550                 {
 551                     *DstPtr++ = *CharPtr++;
 552                 }
 553                 M_DROP;
 554             }
 555             endcase;
 556
 557         case ID_CMOVE_UP: /* ( src dst n -- ) */
 558             {
 559                 register char *DstPtr = ((char *) M_POP) + TOS; /* dst */
 560                 CharPtr = ((char *) M_POP) + TOS;;    /* src */
 561                 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
 562                 {
 563                     *(--DstPtr) = *(--CharPtr);
 564                 }
 565                 M_DROP;
 566             }
 567             endcase;
 568
 569 #ifndef PF_NO_SHELL
 570         case ID_COLON:
 571             SAVE_REGISTERS;
 572             ffColon( );
 573             LOAD_REGISTERS;
 574             endcase;
 575         case ID_COLON_P:  /* ( $name xt -- ) */
 576             CreateDicEntry( TOS, (char *) M_POP, 0 );
 577             M_DROP;
 578             endcase;
 579 #endif  /* !PF_NO_SHELL */
 580
 581         case ID_COMPARE:
 582             {
 583                 const char *s1, *s2;
 584                 cell_t len1;
 585                 s2 = (const char *) M_POP;
 586                 len1 = M_POP;
 587                 s1 = (const char *) M_POP;
 588                 TOS = ffCompare( s1, len1, s2, TOS );
 589             }
 590             endcase;
 591
 592 /* ( a b -- flag , Comparisons ) */
 593         case ID_COMP_EQUAL:
 594             TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;
 595             endcase;
 596         case ID_COMP_NOT_EQUAL:
 597             TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;
 598             endcase;
 599         case ID_COMP_GREATERTHAN:
 600             TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;
 601             endcase;
 602         case ID_COMP_LESSTHAN:
 603             TOS = (  M_POP < TOS ) ? FTRUE : FFALSE ;
 604             endcase;
 605         case ID_COMP_U_GREATERTHAN:
 606             TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
 607             endcase;
 608         case ID_COMP_U_LESSTHAN:
 609             TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
 610             endcase;
 611         case ID_COMP_ZERO_EQUAL:
 612             TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;
 613             endcase;
 614         case ID_COMP_ZERO_NOT_EQUAL:
 615             TOS = ( TOS != 0 ) ? FTRUE : FALSE ;
 616             endcase;
 617         case ID_COMP_ZERO_GREATERTHAN:
 618             TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;
 619             endcase;
 620         case ID_COMP_ZERO_LESSTHAN:
 621             TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;
 622             endcase;
 623
 624         case ID_CR:
 625             EMIT_CR;
 626             endcase;
 627
 628 #ifndef PF_NO_SHELL
 629         case ID_CREATE:
 630             SAVE_REGISTERS;
 631             ffCreate();
 632             LOAD_REGISTERS;
 633             endcase;
 634 #endif  /* !PF_NO_SHELL */
 635
 636         case ID_CREATE_P:
 637             PUSH_TOS;
 638 /* Put address of body on stack.  Insptr points after code start. */
 639             TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );
 640             endcase;
 641
 642         case ID_CSTORE: /* ( c caddr -- ) */
 643             *((uint8_t *) TOS) = (uint8_t) M_POP;
 644             M_DROP;
 645             endcase;
 646
 647 /* Double precision add. */
 648         case ID_D_PLUS:  /* D+ ( al ah bl bh -- sl sh ) */
 649             {
 650                 register ucell_t ah,al,bl,sh,sl;
 651 #define bh TOS
 652                 bl = M_POP;
 653                 ah = M_POP;
 654                 al = M_POP;
 655                 sh = 0;
 656                 sl = al + bl;
 657                 if( sl < bl ) sh = 1; /* Carry */
 658                 sh += ah + bh;
 659                 M_PUSH( sl );
 660                 TOS = sh;
 661 #undef bh
 662             }
 663             endcase;
 664
 665 /* Double precision subtract. */
 666         case ID_D_MINUS:  /* D- ( al ah bl bh -- sl sh ) */
 667             {
 668                 register ucell_t ah,al,bl,sh,sl;
 669 #define bh TOS
 670                 bl = M_POP;
 671                 ah = M_POP;
 672                 al = M_POP;
 673                 sh = 0;
 674                 sl = al - bl;
 675                 if( al < bl ) sh = 1; /* Borrow */
 676                 sh = ah - bh - sh;
 677                 M_PUSH( sl );
 678                 TOS = sh;
 679 #undef bh
 680             }
 681             endcase;
 682
 683 /* Assume 8-bit char and calculate cell width. */
 684 #define NBITS ((sizeof(ucell_t)) * 8)
 685 /* Define half the number of bits in a cell. */
 686 #define HNBITS (NBITS / 2)
 687 /* Assume two-complement arithmetic to calculate lower half. */
 688 #define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))
 689 #define HIGH_BIT ((ucell_t)1 << (NBITS - 1))
 690
 691 /* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.
 692  * Using an improved algorithm suggested by Steve Green.
 693  * Converted to 64-bit by Aleksej Saushev.
 694  */
 695         case ID_D_UMTIMES:  /* UM* ( a b -- lo hi ) */
 696             {
 697                 ucell_t ahi, alo, bhi, blo; /* input parts */
 698                 ucell_t lo, hi, temp;
 699 /* Get values from stack. */
 700                 ahi = M_POP;
 701                 bhi = TOS;
 702 /* Break into hi and lo 16 bit parts. */
 703                 alo = LOWER_HALF(ahi);
 704                 ahi = ahi >> HNBITS;
 705                 blo = LOWER_HALF(bhi);
 706                 bhi = bhi >> HNBITS;
 707
 708                 lo = 0;
 709                 hi = 0;
 710 /* higher part: ahi * bhi */
 711                 hi += ahi * bhi;
 712 /* middle (overlapping) part: ahi * blo */
 713                 temp = ahi * blo;
 714                 lo += LOWER_HALF(temp);
 715                 hi += temp >> HNBITS;
 716 /* middle (overlapping) part: alo * bhi  */
 717                 temp = alo * bhi;
 718                 lo += LOWER_HALF(temp);
 719                 hi += temp >> HNBITS;
 720 /* lower part: alo * blo */
 721                 temp = alo * blo;
 722 /* its higher half overlaps with middle's lower half: */
 723                 lo += temp >> HNBITS;
 724 /* process carry: */
 725                 hi += lo >> HNBITS;
 726                 lo = LOWER_HALF(lo);
 727 /* combine lower part of result: */
 728                 lo = (lo << HNBITS) + LOWER_HALF(temp);
 729
 730                 M_PUSH( lo );
 731                 TOS = hi;
 732             }
 733             endcase;
 734
 735 /* Perform cell*cell bit multiply for 2 cell result, using shift and add. */
 736         case ID_D_MTIMES:  /* M* ( a b -- pl ph ) */
 737             {
 738                 ucell_t ahi, alo, bhi, blo; /* input parts */
 739                 ucell_t lo, hi, temp;
 740                 int sg;
 741 /* Get values from stack. */
 742                 ahi = M_POP;
 743                 bhi = TOS;
 744
 745 /* Calculate product sign: */
 746                 sg = ((cell_t)(ahi ^ bhi) < 0);
 747 /* Take absolute values and reduce to um* */
 748                 if ((cell_t)ahi < 0) ahi = (ucell_t)(-(cell_t)ahi);
 749                 if ((cell_t)bhi < 0) bhi = (ucell_t)(-(cell_t)bhi);
 750
 751 /* Break into hi and lo 16 bit parts. */
 752                 alo = LOWER_HALF(ahi);
 753                 ahi = ahi >> HNBITS;
 754                 blo = LOWER_HALF(bhi);
 755                 bhi = bhi >> HNBITS;
 756
 757                 lo = 0;
 758                 hi = 0;
 759 /* higher part: ahi * bhi */
 760                 hi += ahi * bhi;
 761 /* middle (overlapping) part: ahi * blo */
 762                 temp = ahi * blo;
 763                 lo += LOWER_HALF(temp);
 764                 hi += temp >> HNBITS;
 765 /* middle (overlapping) part: alo * bhi  */
 766                 temp = alo * bhi;
 767                 lo += LOWER_HALF(temp);
 768                 hi += temp >> HNBITS;
 769 /* lower part: alo * blo */
 770                 temp = alo * blo;
 771 /* its higher half overlaps with middle's lower half: */
 772                 lo += temp >> HNBITS;
 773 /* process carry: */
 774                 hi += lo >> HNBITS;
 775                 lo = LOWER_HALF(lo);
 776 /* combine lower part of result: */
 777                 lo = (lo << HNBITS) + LOWER_HALF(temp);
 778
 779 /* Negate product if one operand negative. */
 780                 if(sg)
 781                 {
 782                     /* lo = (ucell_t)(- lo); */
 783                     lo = ~lo + 1;
 784                     hi = ~hi + ((lo == 0) ? 1 : 0);
 785                 }
 786
 787                 M_PUSH( lo );
 788                 TOS = hi;
 789             }
 790             endcase;
 791
 792 #define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
 793 /* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */
 794         case ID_D_UMSMOD:  /* UM/MOD ( al ah bdiv -- rem q ) */
 795             {
 796                 ucell_t ah,al, q,di, bl,bh, sl,sh;
 797                 ah = M_POP;
 798                 al = M_POP;
 799                 bh = TOS;
 800                 bl = 0;
 801                 q = 0;
 802                 for( di=0; di<NBITS; di++ )
 803                 {
 804                     if( !DULT(al,ah,bl,bh) )
 805                     {
 806                         sh = 0;
 807                         sl = al - bl;
 808                         if( al < bl ) sh = 1; /* Borrow */
 809                         sh = ah - bh - sh;
 810                         ah = sh;
 811                         al = sl;
 812                         q |= 1;
 813                     }
 814                     q = q << 1;
 815                     bl = (bl >> 1) | (bh << (NBITS-1));
 816                     bh = bh >> 1;
 817                 }
 818                 if( !DULT(al,ah,bl,bh) )
 819                 {
 820
 821                     al = al - bl;
 822                     q |= 1;
 823                 }
 824                 M_PUSH( al );  /* rem */
 825                 TOS = q;
 826             }
 827             endcase;
 828
 829 /* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */
 830         case ID_D_MUSMOD:  /* MU/MOD ( al am bdiv -- rem ql qh ) */
 831             {
 832                 register ucell_t ah,am,al,ql,qh,di;
 833 #define bdiv ((ucell_t)TOS)
 834                 ah = 0;
 835                 am = M_POP;
 836                 al = M_POP;
 837                 qh = ql = 0;
 838                 for( di=0; di<2*NBITS; di++ )
 839                 {
 840                     if( bdiv <= ah )
 841                     {
 842                         ah = ah - bdiv;
 843                         ql |= 1;
 844                     }
 845                     qh = (qh << 1) | (ql >> (NBITS-1));
 846                     ql = ql << 1;
 847                     ah = (ah << 1) | (am >> (NBITS-1));
 848                     am = (am << 1) | (al >> (NBITS-1));
 849                     al = al << 1;
 850 DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
 851                 }
 852                 if( bdiv <= ah )
 853                 {
 854                     ah = ah - bdiv;
 855                     ql |= 1;
 856                 }
 857                 M_PUSH( ah ); /* rem */
 858                 M_PUSH( ql );
 859                 TOS = qh;
 860 #undef bdiv
 861             }
 862             endcase;
 863
 864 #ifndef PF_NO_SHELL
 865         case ID_DEFER:
 866             ffDefer( );
 867             endcase;
 868 #endif  /* !PF_NO_SHELL */
 869
 870         case ID_DEFER_P:
 871             endcase;
 872
 873         case ID_DEPTH:
 874             PUSH_TOS;
 875             TOS = gCurrentTask->td_StackBase - STKPTR;
 876             endcase;
 877
 878         case ID_DIVIDE:     BINARY_OP( / ); endcase;
 879
 880         case ID_DOT:
 881             ffDot( TOS );
 882             M_DROP;
 883             endcase;
 884
 885         case ID_DOTS:
 886             M_DOTS;
 887             endcase;
 888
 889         case ID_DROP:  M_DROP; endcase;
 890
 891         case ID_DUMP:
 892             Scratch = M_POP;
 893             DumpMemory( (char *) Scratch, TOS );
 894             M_DROP;
 895             endcase;
 896
 897         case ID_DUP:   M_DUP; endcase;
 898
 899         case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */
 900             M_R_PUSH( TOS );
 901             M_R_PUSH( M_POP );
 902             M_DROP;
 903             endcase;
 904
 905         case ID_EOL:    /* ( -- end_of_line_char ) */
 906             PUSH_TOS;
 907             TOS = (cell_t) '\n';
 908             endcase;
 909
 910         case ID_ERRORQ_P:  /* ( flag num -- , quit if flag true ) */
 911             Scratch = TOS;
 912             M_DROP;
 913             if(TOS)
 914             {
 915                 M_THROW(Scratch);
 916             }
 917             else
 918             {
 919                 M_DROP;
 920             }
 921             endcase;
 922
 923         case ID_EMIT_P:
 924             EMIT( (char) TOS );
 925             M_DROP;
 926             endcase;
 927
 928         case ID_EXECUTE:
 929 /* Save IP on return stack like a JSR. */
 930             M_R_PUSH( InsPtr );
 931 #ifdef PF_SUPPORT_TRACE
 932 /* Bump level for trace. */
 933             Level++;
 934 #endif
 935             if( IsTokenPrimitive( TOS ) )
 936             {
 937                 WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS);   /* Build a fake secondary and execute it. */
 938                 InsPtr = &FakeSecondary[0];
 939             }
 940             else
 941             {
 942                 InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);
 943             }
 944             M_DROP;
 945             endcase;
 946
 947         case ID_FETCH:
 948 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
 949             if( IN_DICS( TOS ) )
 950             {
 951                 TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);
 952             }
 953             else
 954             {
 955                 TOS = *((cell_t *)TOS);
 956             }
 957 #else
 958             TOS = *((cell_t *)TOS);
 959 #endif
 960             endcase;
 961
 962         case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */
 963 /* Build NUL terminated name string. */
 964             Scratch = M_POP; /* u */
 965             Temp = M_POP;    /* caddr */
 966             if( Scratch < TIB_SIZE-2 )
 967             {
 968                 const char *famText = pfSelectFileModeCreate( TOS );
 969                 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
 970                 gScratch[Scratch] = '\0';
 971                 DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));
 972                 FileID = sdOpenFile( gScratch, famText );
 973                 TOS = ( FileID == NULL ) ? -1 : 0 ;
 974                 M_PUSH( (cell_t) FileID );
 975             }
 976             else
 977             {
 978                 ERR("Filename too large for name buffer.\n");
 979                 M_PUSH( 0 );
 980                 TOS = -2;
 981             }
 982             endcase;
 983
 984         case ID_FILE_DELETE: /* ( c-addr u -- ior ) */
 985 /* Build NUL terminated name string. */
 986             Temp = M_POP;    /* caddr */
 987             if( TOS < TIB_SIZE-2 )
 988             {
 989                 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS );
 990                 gScratch[TOS] = '\0';
 991                 DBUG(("Delete file = %s\n", gScratch ));
 992                 TOS = sdDeleteFile( gScratch );
 993             }
 994             else
 995             {
 996                 ERR("Filename too large for name buffer.\n");
 997                 TOS = -2;
 998             }
 999             endcase;
1000
1001         case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */
1002 /* Build NUL terminated name string. */
1003             Scratch = M_POP; /* u */
1004             Temp = M_POP;    /* caddr */
1005             if( Scratch < TIB_SIZE-2 )
1006             {
1007                 const char *famText = pfSelectFileModeOpen( TOS );
1008                 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
1009                 gScratch[Scratch] = '\0';
1010                 DBUG(("Open file = %s\n", gScratch ));
1011                 FileID = sdOpenFile( gScratch, famText );
1012
1013                 TOS = ( FileID == NULL ) ? -1 : 0 ;
1014                 M_PUSH( (cell_t) FileID );
1015             }
1016             else
1017             {
1018                 ERR("Filename too large for name buffer.\n");
1019                 M_PUSH( 0 );
1020                 TOS = -2;
1021             }
1022             endcase;
1023
1024         case ID_FILE_CLOSE: /* ( fid -- ior ) */
1025             TOS = sdCloseFile( (FileStream *) TOS );
1026             endcase;
1027
1028         case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */
1029             FileID = (FileStream *) TOS;
1030             Scratch = M_POP;
1031             CharPtr = (char *) M_POP;
1032             Temp = sdReadFile( CharPtr, 1, Scratch, FileID );
1033             /* TODO check feof() or ferror() */
1034             M_PUSH(Temp);
1035             TOS = 0;
1036             endcase;
1037
1038         /* TODO Why does this crash when passed an illegal FID? */
1039         case ID_FILE_SIZE: /* ( fid -- ud ior ) */
1040 /* Determine file size by seeking to end and returning position. */
1041             FileID = (FileStream *) TOS;
1042             {
1043                 file_offset_t endposition = -1;
1044                 file_offset_t original = sdTellFile( FileID );
1045                 if (original >= 0)
1046                 {
1047                     sdSeekFile( FileID, 0, PF_SEEK_END );
1048                     endposition = sdTellFile( FileID );
1049                     /* Restore original position. */
1050                     sdSeekFile( FileID, original, PF_SEEK_SET );
1051                 }
1052                 if (endposition < 0)
1053                 {
1054                     M_PUSH(0); /* low */
1055                     M_PUSH(0); /* high */
1056                     TOS = -4;  /* TODO proper error number */
1057                 }
1058                 else
1059                 {
1060                     M_PUSH(endposition); /* low */
1061                     /* We do not support double precision file offsets.*/
1062                     M_PUSH(0); /* high */
1063                     TOS = 0;   /* OK */
1064                 }
1065             }
1066             endcase;
1067
1068         case ID_FILE_WRITE: /* ( addr len fid -- ior ) */
1069             FileID = (FileStream *) TOS;
1070             Scratch = M_POP;
1071             CharPtr = (char *) M_POP;
1072             Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );
1073             TOS = (Temp != Scratch) ? -3 : 0;
1074             endcase;
1075
1076         case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */
1077             {
1078                 file_offset_t offset;
1079                 cell_t offsetHigh;
1080                 cell_t offsetLow;
1081                 FileID = (FileStream *) TOS;
1082                 offsetHigh = M_POP;
1083                 offsetLow = M_POP;
1084                 /* We do not support double precision file offsets in pForth.
1085                  * So check to make sure the high bits are not used.
1086                  */
1087                 if (offsetHigh != 0)
1088                 {
1089                     TOS = -3; /* TODO err num? */
1090                     break;
1091                 }
1092                 offset = (file_offset_t)offsetLow;
1093                 TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );
1094             }
1095             endcase;
1096
1097         case ID_FILE_POSITION: /* ( fid -- ud ior ) */
1098             {
1099                 file_offset_t position;
1100                 FileID = (FileStream *) TOS;
1101                 position = sdTellFile( FileID );
1102                 if (position < 0)
1103                 {
1104                     M_PUSH(0); /* low */
1105                     M_PUSH(0); /* high */
1106                     TOS = -4;  /* TODO proper error number */
1107                 }
1108                 else
1109                 {
1110                     M_PUSH(position); /* low */
1111                     /* We do not support double precision file offsets.*/
1112                     M_PUSH(0); /* high */
1113                     TOS = 0; /* OK */
1114                 }
1115             }
1116             endcase;
1117
1118         case ID_FILE_RO: /* (  -- fam ) */
1119             PUSH_TOS;
1120             TOS = PF_FAM_READ_ONLY;
1121             endcase;
1122
1123         case ID_FILE_RW: /* ( -- fam ) */
1124             PUSH_TOS;
1125             TOS = PF_FAM_READ_WRITE;
1126             endcase;
1127
1128         case ID_FILE_WO: /* ( -- fam ) */
1129             PUSH_TOS;
1130             TOS = PF_FAM_WRITE_ONLY;
1131             endcase;
1132
1133         case ID_FILE_BIN: /* ( -- fam ) */
1134             TOS = TOS | PF_FAM_BINARY_FLAG;
1135             endcase;
1136
1137         case ID_FILE_FLUSH: /* ( fileid -- ior ) */
1138             {
1139                 FileStream *Stream = (FileStream *) TOS;
1140                 TOS = (sdFlushFile( Stream ) == 0) ? 0 : THROW_FLUSH_FILE;
1141             }
1142             endcase;
1143
1144         case ID_FILE_RENAME: /* ( oldName newName -- ior ) */
1145             {
1146                 char *New = (char *) TOS;
1147                 char *Old = (char *) M_POP;
1148                 TOS = sdRenameFile( Old, New );
1149             }
1150             endcase;
1151
1152         case ID_FILE_RESIZE: /* ( ud fileid -- ior ) */
1153             {
1154                 FileStream *File = (FileStream *) TOS;
1155                 ucell_t SizeHi = (ucell_t) M_POP;
1156                 ucell_t SizeLo = (ucell_t) M_POP;
1157                 TOS = ( UdIsUint64( SizeLo, SizeHi )
1158                         ? sdResizeFile( File, UdToUint64( SizeLo, SizeHi ))
1159                         : THROW_RESIZE_FILE );
1160             }
1161             endcase;
1162
1163         case ID_FILL: /* ( caddr num charval -- ) */
1164             {
1165                 register char *DstPtr;
1166                 Temp = M_POP;    /* num */
1167                 DstPtr = (char *) M_POP; /* dst */
1168                 for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )
1169                 {
1170                     *DstPtr++ = (char) TOS;
1171                 }
1172                 M_DROP;
1173             }
1174             endcase;
1175
1176 #ifndef PF_NO_SHELL
1177         case ID_FIND:  /* ( $addr -- $addr 0 | xt +-1 ) */
1178             TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
1179             M_PUSH( Temp );
1180             endcase;
1181
1182         case ID_FINDNFA:
1183             TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
1184             M_PUSH( (cell_t) Temp );
1185             endcase;
1186 #endif  /* !PF_NO_SHELL */
1187
1188         case ID_FLUSHEMIT:
1189             sdTerminalFlush();
1190             endcase;
1191
1192 /* Validate memory before freeing. Clobber validator and first word. */
1193         case ID_FREE:   /* ( addr -- result ) */
1194             if( TOS == 0 )
1195             {
1196                 ERR("FREE passed NULL!\n");
1197                 TOS = -2; /* FIXME error code */
1198             }
1199             else
1200             {
1201                 CellPtr = (cell_t *) TOS;
1202                 CellPtr--;
1203                 if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))
1204                 {
1205                     TOS = -2; /* FIXME error code */
1206                 }
1207                 else
1208                 {
1209                     CellPtr[0] = 0xDeadBeef;
1210                     pfFreeMem((char *)CellPtr);
1211                     TOS = 0;
1212                 }
1213             }
1214             endcase;
1215
1216 #include "pfinnrfp.h"
1217
1218         case ID_HERE:
1219             PUSH_TOS;
1220             TOS = (cell_t)CODE_HERE;
1221             endcase;
1222
1223         case ID_NUMBERQ_P:   /* ( addr -- 0 | n 1 ) */
1224 /* Convert using number converter in 'C'.
1225 ** Only supports single precision for bootstrap.
1226 */
1227             TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );
1228             if( TOS == NUM_TYPE_SINGLE)
1229             {
1230                 M_PUSH( Temp );   /* Push single number */
1231             }
1232             endcase;
1233
1234         case ID_I:  /* ( -- i , DO LOOP index ) */
1235             PUSH_TOS;
1236             TOS = M_R_PICK(1);
1237             endcase;
1238
1239 #ifndef PF_NO_SHELL
1240         case ID_INCLUDE_FILE:
1241             FileID = (FileStream *) TOS;
1242             M_DROP;    /* Drop now so that INCLUDE has a clean stack. */
1243             SAVE_REGISTERS;
1244             Scratch = ffIncludeFile( FileID );
1245             LOAD_REGISTERS;
1246             if( Scratch ) M_THROW(Scratch)
1247             endcase;
1248 #endif  /* !PF_NO_SHELL */
1249
1250 #ifndef PF_NO_SHELL
1251         case ID_INTERPRET:
1252             SAVE_REGISTERS;
1253             Scratch = ffInterpret();
1254             LOAD_REGISTERS;
1255             if( Scratch ) M_THROW(Scratch)
1256             endcase;
1257 #endif  /* !PF_NO_SHELL */
1258
1259         case ID_J:  /* ( -- j , second DO LOOP index ) */
1260             PUSH_TOS;
1261             TOS = M_R_PICK(3);
1262             endcase;
1263
1264         case ID_KEY:
1265             PUSH_TOS;
1266             TOS = ioKey();
1267             endcase;
1268
1269 #ifndef PF_NO_SHELL
1270         case ID_LITERAL:
1271             ffLiteral( TOS );
1272             M_DROP;
1273             endcase;
1274 #endif /* !PF_NO_SHELL */
1275
1276         case ID_LITERAL_P:
1277             DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
1278             PUSH_TOS;
1279             TOS = READ_CELL_DIC(InsPtr++);
1280             endcase;
1281
1282 #ifndef PF_NO_SHELL
1283         case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
1284 #endif /* !PF_NO_SHELL */
1285
1286         case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
1287             TOS = *(LocalsPtr - TOS);
1288             endcase;
1289
1290 #define LOCAL_FETCH_N(num) \
1291         case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
1292             PUSH_TOS; \
1293             TOS = *(LocalsPtr -(num)); \
1294             endcase;
1295
1296         LOCAL_FETCH_N(1);
1297         LOCAL_FETCH_N(2);
1298         LOCAL_FETCH_N(3);
1299         LOCAL_FETCH_N(4);
1300         LOCAL_FETCH_N(5);
1301         LOCAL_FETCH_N(6);
1302         LOCAL_FETCH_N(7);
1303         LOCAL_FETCH_N(8);
1304
1305         case ID_LOCAL_STORE:  /* ( n i <local> -- , store n in local ) */
1306             *(LocalsPtr - TOS) = M_POP;
1307             M_DROP;
1308             endcase;
1309
1310 #define LOCAL_STORE_N(num) \
1311         case ID_LOCAL_STORE_##num:  /* ( n <local> -- , store n in local ) */ \
1312             *(LocalsPtr - (num)) = TOS; \
1313             M_DROP; \
1314             endcase;
1315
1316         LOCAL_STORE_N(1);
1317         LOCAL_STORE_N(2);
1318         LOCAL_STORE_N(3);
1319         LOCAL_STORE_N(4);
1320         LOCAL_STORE_N(5);
1321         LOCAL_STORE_N(6);
1322         LOCAL_STORE_N(7);
1323         LOCAL_STORE_N(8);
1324
1325         case ID_LOCAL_PLUSSTORE:  /* ( n i <local> -- , add n to local ) */
1326             *(LocalsPtr - TOS) += M_POP;
1327             M_DROP;
1328             endcase;
1329
1330         case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
1331         /* create local stack frame */
1332             {
1333                 cell_t i = TOS;
1334                 cell_t *lp;
1335                 DBUG(("LocalEntry: n = %d\n", TOS));
1336                 /* End of locals. Create stack frame */
1337                 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
1338                     TORPTR, LocalsPtr));
1339                 M_R_PUSH(LocalsPtr);
1340                 LocalsPtr = TORPTR;
1341                 TORPTR -= TOS;
1342                 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
1343                     TORPTR, LocalsPtr));
1344                 lp = TORPTR;
1345                 while(i-- > 0)
1346                 {
1347                     *lp++ = M_POP;    /* Load local vars from stack */
1348                 }
1349                 M_DROP;
1350             }
1351             endcase;
1352
1353         case ID_LOCAL_EXIT: /* cleanup up local stack frame */
1354             DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
1355                 TORPTR, LocalsPtr));
1356             TORPTR = LocalsPtr;
1357             LocalsPtr = (cell_t *) M_R_POP;
1358             DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
1359                 TORPTR, LocalsPtr));
1360             endcase;
1361
1362 #ifndef PF_NO_SHELL
1363         case ID_LOADSYS:
1364             MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
1365             FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
1366             if( FileID )
1367             {
1368                 SAVE_REGISTERS;
1369                 Scratch = ffIncludeFile( FileID ); /* Also closes the file. */
1370                 LOAD_REGISTERS;
1371                 if( Scratch ) M_THROW(Scratch);
1372             }
1373             else
1374             {
1375                  ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
1376             }
1377             endcase;
1378 #endif  /* !PF_NO_SHELL */
1379
1380         case ID_LEAVE_P: /* ( R: index limit --  ) */
1381             M_R_DROP;
1382             M_R_DROP;
1383             M_BRANCH;
1384             endcase;
1385
1386         case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
1387             Temp = M_R_POP; /* limit */
1388             Scratch = M_R_POP + 1; /* index */
1389             if( Scratch == Temp )
1390             {
1391                 InsPtr++;   /* skip branch offset, exit loop */
1392             }
1393             else
1394             {
1395 /* Push index and limit back to R */
1396                 M_R_PUSH( Scratch );
1397                 M_R_PUSH( Temp );
1398 /* Branch back to just after (DO) */
1399                 M_BRANCH;
1400             }
1401             endcase;
1402
1403         case ID_LSHIFT:     BINARY_OP( << ); endcase;
1404
1405         case ID_MAX:
1406             Scratch = M_POP;
1407             TOS = ( TOS > Scratch ) ? TOS : Scratch ;
1408             endcase;
1409
1410         case ID_MIN:
1411             Scratch = M_POP;
1412             TOS = ( TOS < Scratch ) ? TOS : Scratch ;
1413             endcase;
1414
1415         case ID_MINUS:     BINARY_OP( - ); endcase;
1416
1417 #ifndef PF_NO_SHELL
1418         case ID_NAME_TO_TOKEN:
1419             TOS = (cell_t) NameToToken((ForthString *)TOS);
1420             endcase;
1421
1422         case ID_NAME_TO_PREVIOUS:
1423             TOS = (cell_t) NameToPrevious((ForthString *)TOS);
1424             endcase;
1425 #endif
1426
1427         case ID_NOOP:
1428             endcase;
1429
1430         case ID_OR:     BINARY_OP( | ); endcase;
1431
1432         case ID_OVER:
1433             PUSH_TOS;
1434             TOS = M_STACK(1);
1435             endcase;
1436
1437         case ID_PICK: /* ( ... n -- sp(n) ) */
1438             TOS = M_STACK(TOS);
1439             endcase;
1440
1441         case ID_PLUS:     BINARY_OP( + ); endcase;
1442
1443         case ID_PLUS_STORE:   /* ( n addr -- , add n to *addr ) */
1444 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1445             if( IN_DICS( TOS ) )
1446             {
1447                 Scratch = READ_CELL_DIC((cell_t *)TOS);
1448                 Scratch += M_POP;
1449                 WRITE_CELL_DIC((cell_t *)TOS,Scratch);
1450             }
1451             else
1452             {
1453                 *((cell_t *)TOS) += M_POP;
1454             }
1455 #else
1456             *((cell_t *)TOS) += M_POP;
1457 #endif
1458             M_DROP;
1459             endcase;
1460
1461         case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
1462             {
1463                 cell_t Limit = M_R_POP;
1464                 cell_t OldIndex = M_R_POP;
1465                 cell_t Delta = TOS; /* add TOS to index, not 1 */
1466                 cell_t NewIndex = OldIndex + Delta;
1467                 cell_t OldDiff = OldIndex - Limit;
1468
1469                 /* This exploits this idea (lifted from Gforth):
1470                    (x^y)<0 is equivalent to (x<0) != (y<0) */
1471                 if( ((OldDiff ^ (OldDiff + Delta)) /* is the limit crossed? */
1472                      & (OldDiff ^ Delta))          /* is it a wrap-around? */
1473                     < 0 )
1474                 {
1475                     InsPtr++;   /* skip branch offset, exit loop */
1476                 }
1477                 else
1478                 {
1479 /* Push index and limit back to R */
1480                     M_R_PUSH( NewIndex );
1481                     M_R_PUSH( Limit );
1482 /* Branch back to just after (DO) */
1483                     M_BRANCH;
1484                 }
1485                 M_DROP;
1486             }
1487             endcase;
1488
1489         case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
1490             Scratch = M_POP;  /* limit */
1491             if( Scratch == TOS )
1492             {
1493 /* Branch to just after (LOOP) */
1494                 M_BRANCH;
1495             }
1496             else
1497             {
1498                 M_R_PUSH( TOS );
1499                 M_R_PUSH( Scratch );
1500                 InsPtr++;   /* skip branch offset, enter loop */
1501             }
1502             M_DROP;
1503             endcase;
1504
1505         case ID_QDUP:     if( TOS ) M_DUP; endcase;
1506
1507         case ID_QTERMINAL:  /* WARNING: Typically not fully implemented! */
1508             PUSH_TOS;
1509             TOS = sdQueryTerminal();
1510             endcase;
1511
1512         case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
1513 #ifdef PF_SUPPORT_TRACE
1514             Level = 0;
1515 #endif
1516             M_THROW(THROW_QUIT);
1517             endcase;
1518
1519         case ID_R_DROP:
1520             M_R_DROP;
1521             endcase;
1522
1523         case ID_R_FETCH:
1524             PUSH_TOS;
1525             TOS = (*(TORPTR));
1526             endcase;
1527
1528         case ID_R_FROM:
1529             PUSH_TOS;
1530             TOS = M_R_POP;
1531             endcase;
1532
1533         case ID_REFILL:
1534             PUSH_TOS;
1535             TOS = (ffRefill() > 0) ? FTRUE : FFALSE;
1536             endcase;
1537
1538 /* Resize memory allocated by ALLOCATE. */
1539         case ID_RESIZE:  /* ( addr1 u -- addr2 result ) */
1540             {
1541                 cell_t *Addr1 = (cell_t *) M_POP;
1542                 /* Point to validator below users address. */
1543                 cell_t *FreePtr = Addr1 - 1;
1544                 if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))
1545                 {
1546                     /* 090218 - Fixed bug, was returning zero. */
1547                     M_PUSH( Addr1 );
1548                     TOS = -3;
1549                 }
1550                 else
1551                 {
1552                     /* Try to allocate. */
1553                     CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );
1554                     if( CellPtr )
1555                     {
1556                         /* Copy memory including validation. */
1557                         pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );
1558                         *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);
1559                         /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */
1560                         /* Increment past validator to user address. */
1561                         M_PUSH( (cell_t) (CellPtr + 1) );
1562                         TOS = 0; /* Result code. */
1563                         /* Mark old cell as dead so we can't free it twice. */
1564                         FreePtr[0] = 0xDeadBeef;
1565                         pfFreeMem((char *) FreePtr);
1566                     }
1567                     else
1568                     {
1569                         /* 090218 - Fixed bug, was returning zero. */
1570                         M_PUSH( Addr1 );
1571                         TOS = -4;  /* FIXME Fix error code. */
1572                     }
1573                 }
1574             }
1575             endcase;
1576
1577 /*
1578 ** RP@ and RP! are called secondaries so we must
1579 ** account for the return address pushed before calling.
1580 */
1581         case ID_RP_FETCH:    /* ( -- rp , address of top of return stack ) */
1582             PUSH_TOS;
1583             TOS = (cell_t)TORPTR;  /* value before calling RP@ */
1584             endcase;
1585
1586         case ID_RP_STORE:    /* ( rp -- , address of top of return stack ) */
1587             TORPTR = (cell_t *) TOS;
1588             M_DROP;
1589             endcase;
1590
1591         case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
1592             {
1593                 cell_t ri;
1594                 cell_t *srcPtr, *dstPtr;
1595                 Scratch = M_STACK(TOS);
1596                 srcPtr = &M_STACK(TOS-1);
1597                 dstPtr = &M_STACK(TOS);
1598                 for( ri=0; ri<TOS; ri++ )
1599                 {
1600                     *dstPtr-- = *srcPtr--;
1601                 }
1602                 TOS = Scratch;
1603                 STKPTR++;
1604             }
1605             endcase;
1606
1607         case ID_ROT:  /* ( a b c -- b c a ) */
1608             Scratch = M_POP;    /* b */
1609             Temp = M_POP;       /* a */
1610             M_PUSH( Scratch );  /* b */
1611             PUSH_TOS;           /* c */
1612             TOS = Temp;         /* a */
1613             endcase;
1614
1615 /* Logical right shift */
1616         case ID_RSHIFT:     { TOS = ((ucell_t)M_POP) >> TOS; } endcase;
1617
1618 #ifndef PF_NO_SHELL
1619         case ID_SAVE_FORTH_P:   /* ( $name Entry NameSize CodeSize -- err ) */
1620             {
1621                 cell_t NameSize, CodeSize, EntryPoint;
1622                 CodeSize = TOS;
1623                 NameSize = M_POP;
1624                 EntryPoint = M_POP;
1625                 ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );
1626                 TOS =  ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
1627             }
1628             endcase;
1629 #endif
1630
1631         case ID_SP_FETCH:    /* ( -- sp , address of top of stack, sorta ) */
1632             PUSH_TOS;
1633             TOS = (cell_t)STKPTR;
1634             endcase;
1635
1636         case ID_SP_STORE:    /* ( sp -- , address of top of stack, sorta ) */
1637             STKPTR = (cell_t *) TOS;
1638             M_DROP;
1639             endcase;
1640
1641         case ID_STORE: /* ( n addr -- , write n to addr ) */
1642 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1643             if( IN_DICS( TOS ) )
1644             {
1645                 WRITE_CELL_DIC((cell_t *)TOS,M_POP);
1646             }
1647             else
1648             {
1649                 *((cell_t *)TOS) = M_POP;
1650             }
1651 #else
1652             *((cell_t *)TOS) = M_POP;
1653 #endif
1654             M_DROP;
1655             endcase;
1656
1657         case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
1658             Scratch = M_POP; /* cnt */
1659             Temp = M_POP;    /* addr */
1660             TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1661             M_PUSH((cell_t) CharPtr);
1662             endcase;
1663
1664 #ifndef PF_NO_SHELL
1665         case ID_SEMICOLON:
1666             SAVE_REGISTERS;
1667             Scratch = ffSemiColon();
1668             LOAD_REGISTERS;
1669             if( Scratch ) M_THROW( Scratch );
1670             endcase;
1671 #endif /* !PF_NO_SHELL */
1672
1673         case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
1674             Scratch = M_POP; /* cnt */
1675             Temp = M_POP;    /* addr */
1676             TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1677             M_PUSH((cell_t) CharPtr);
1678             endcase;
1679
1680         case ID_SOURCE:  /* ( -- c-addr num ) */
1681             PUSH_TOS;
1682             M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );
1683             TOS = (cell_t) gCurrentTask->td_SourceNum;
1684             endcase;
1685
1686         case ID_SOURCE_SET: /* ( c-addr num -- ) */
1687             gCurrentTask->td_SourcePtr = (char *) M_POP;
1688             gCurrentTask->td_SourceNum = TOS;
1689             M_DROP;
1690             endcase;
1691
1692         case ID_SOURCE_ID:
1693             PUSH_TOS;
1694             TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
1695             endcase;
1696
1697         case ID_SOURCE_ID_POP:
1698             PUSH_TOS;
1699             TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
1700             endcase;
1701
1702         case ID_SOURCE_ID_PUSH:  /* ( source-id -- ) */
1703             TOS = (cell_t)ffConvertSourceIDToStream( TOS );
1704             Scratch = ffPushInputStream((FileStream *) TOS );
1705             if( Scratch )
1706             {
1707                 M_THROW(Scratch);
1708             }
1709             else M_DROP;
1710             endcase;
1711
1712         case ID_SOURCE_LINE_NUMBER_FETCH: /* ( -- linenr ) */
1713             PUSH_TOS;
1714             TOS = gCurrentTask->td_LineNumber;
1715             endcase;
1716
1717         case ID_SOURCE_LINE_NUMBER_STORE: /* ( linenr -- ) */
1718             gCurrentTask->td_LineNumber = TOS;
1719             TOS = M_POP;
1720             endcase;
1721
1722         case ID_SWAP:
1723             Scratch = TOS;
1724             TOS = *STKPTR;
1725             *STKPTR = Scratch;
1726             endcase;
1727
1728         case ID_TEST1:
1729             PUSH_TOS;
1730             M_PUSH( 0x11 );
1731             M_PUSH( 0x22 );
1732             TOS = 0x33;
1733             endcase;
1734
1735         case ID_TEST2:
1736             endcase;
1737
1738         case ID_THROW:  /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
1739             if(TOS)
1740             {
1741                 M_THROW(TOS);
1742             }
1743             else M_DROP;
1744             endcase;
1745
1746 #ifndef PF_NO_SHELL
1747         case ID_TICK:
1748             PUSH_TOS;
1749             CharPtr = (char *) ffWord( (char) ' ' );
1750             TOS = ffFind( CharPtr, (ExecToken *) &Temp );
1751             if( TOS == 0 )
1752             {
1753                 ERR("' could not find ");
1754                 ioType( (char *) CharPtr+1, *CharPtr );
1755                 M_THROW(-13);
1756             }
1757             else
1758             {
1759                 TOS = Temp;
1760             }
1761             endcase;
1762 #endif  /* !PF_NO_SHELL */
1763
1764         case ID_TIMES: BINARY_OP( * ); endcase;
1765
1766         case ID_TYPE:
1767             Scratch = M_POP; /* addr */
1768             ioType( (char *) Scratch, TOS );
1769             M_DROP;
1770             endcase;
1771
1772         case ID_TO_R:
1773             M_R_PUSH( TOS );
1774             M_DROP;
1775             endcase;
1776
1777         case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
1778         case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
1779         case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
1780         case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
1781         case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
1782         case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
1783         case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
1784         case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
1785         case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;
1786         case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
1787         case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
1788         case ID_VAR_STATE: DO_VAR(gVarState); endcase;
1789         case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
1790         case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
1791         case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
1792         case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
1793         case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
1794
1795         case ID_WORD:
1796             TOS = (cell_t) ffWord( (char) TOS );
1797             endcase;
1798
1799         case ID_WORD_FETCH: /* ( waddr -- w ) */
1800 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1801             if( IN_DICS( TOS ) )
1802             {
1803                 TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);
1804             }
1805             else
1806             {
1807                 TOS = *((uint16_t *)TOS);
1808             }
1809 #else
1810             TOS = *((uint16_t *)TOS);
1811 #endif
1812             endcase;
1813
1814         case ID_WORD_STORE: /* ( w waddr -- ) */
1815
1816 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1817             if( IN_DICS( TOS ) )
1818             {
1819                 WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);
1820             }
1821             else
1822             {
1823                 *((uint16_t *)TOS) = (uint16_t) M_POP;
1824             }
1825 #else
1826             *((uint16_t *)TOS) = (uint16_t) M_POP;
1827 #endif
1828             M_DROP;
1829             endcase;
1830
1831         case ID_XOR: BINARY_OP( ^ ); endcase;
1832
1833
1834 /* Branch is followed by an offset relative to address of offset. */
1835         case ID_ZERO_BRANCH:
1836 DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
1837             if( TOS == 0 )
1838             {
1839                 M_BRANCH;
1840             }
1841             else
1842             {
1843                 InsPtr++;      /* skip over offset */
1844             }
1845             M_DROP;
1846 DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
1847             endcase;
1848
1849         default:
1850             ERR("pfCatch: Unrecognised token = 0x");
1851             ffDotHex(Token);
1852             ERR(" at 0x");
1853             ffDotHex((cell_t) InsPtr);
1854             EMIT_CR;
1855             InsPtr = 0;
1856             endcase;
1857         }
1858
1859         if(InsPtr) Token = READ_CELL_DIC(InsPtr++);   /* Traverse to next token in secondary. */
1860
1861 #ifdef PF_DEBUG
1862         M_DOTS;
1863 #endif
1864
1865 #if 0
1866         if( _CrtCheckMemory() == 0 )
1867         {
1868             ERR("_CrtCheckMemory abort: InsPtr = 0x");
1869             ffDotHex((int)InsPtr);
1870             ERR("\n");
1871         }
1872 #endif
1873
1874     } while( (InitialReturnStack - TORPTR) > 0 );
1875
1876     SAVE_REGISTERS;
1877
1878     return ExceptionReturnCode;
1879 }