git.gag.com Git - debian/pforth/blob - csrc/pf_inner.c

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