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