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_FILE_RESIZE: /* ( ud fileid -- ior ) */
1110             {
1111                 FileStream *File = (FileStream *) TOS;
1112                 ucell_t SizeHi = (ucell_t) M_POP;
1113                 ucell_t SizeLo = (ucell_t) M_POP;
1114                 TOS = sdResizeFile( File, SizeLo, SizeHi );
1115             }
1116             endcase;
1117
1118         case ID_FILL: /* ( caddr num charval -- ) */
1119             {
1120                 register char *DstPtr;
1121                 Temp = M_POP;    /* num */
1122                 DstPtr = (char *) M_POP; /* dst */
1123                 for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )
1124                 {
1125                     *DstPtr++ = (char) TOS;
1126                 }
1127                 M_DROP;
1128             }
1129             endcase;
1130
1131 #ifndef PF_NO_SHELL
1132         case ID_FIND:  /* ( $addr -- $addr 0 | xt +-1 ) */
1133             TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
1134             M_PUSH( Temp );
1135             endcase;
1136
1137         case ID_FINDNFA:
1138             TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
1139             M_PUSH( (cell_t) Temp );
1140             endcase;
1141 #endif  /* !PF_NO_SHELL */
1142
1143         case ID_FLUSHEMIT:
1144             sdTerminalFlush();
1145             endcase;
1146
1147 /* Validate memory before freeing. Clobber validator and first word. */
1148         case ID_FREE:   /* ( addr -- result ) */
1149             if( TOS == 0 )
1150             {
1151                 ERR("FREE passed NULL!\n");
1152                 TOS = -2; /* FIXME error code */
1153             }
1154             else
1155             {
1156                 CellPtr = (cell_t *) TOS;
1157                 CellPtr--;
1158                 if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))
1159                 {
1160                     TOS = -2; /* FIXME error code */
1161                 }
1162                 else
1163                 {
1164                     CellPtr[0] = 0xDeadBeef;
1165                     pfFreeMem((char *)CellPtr);
1166                     TOS = 0;
1167                 }
1168             }
1169             endcase;
1170
1171 #include "pfinnrfp.h"
1172
1173         case ID_HERE:
1174             PUSH_TOS;
1175             TOS = (cell_t)CODE_HERE;
1176             endcase;
1177
1178         case ID_NUMBERQ_P:   /* ( addr -- 0 | n 1 ) */
1179 /* Convert using number converter in 'C'.
1180 ** Only supports single precision for bootstrap.
1181 */
1182             TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );
1183             if( TOS == NUM_TYPE_SINGLE)
1184             {
1185                 M_PUSH( Temp );   /* Push single number */
1186             }
1187             endcase;
1188
1189         case ID_I:  /* ( -- i , DO LOOP index ) */
1190             PUSH_TOS;
1191             TOS = M_R_PICK(1);
1192             endcase;
1193
1194 #ifndef PF_NO_SHELL
1195         case ID_INCLUDE_FILE:
1196             FileID = (FileStream *) TOS;
1197             M_DROP;    /* Drop now so that INCLUDE has a clean stack. */
1198             SAVE_REGISTERS;
1199             Scratch = ffIncludeFile( FileID );
1200             LOAD_REGISTERS;
1201             if( Scratch ) M_THROW(Scratch)
1202             endcase;
1203 #endif  /* !PF_NO_SHELL */
1204
1205 #ifndef PF_NO_SHELL
1206         case ID_INTERPRET:
1207             SAVE_REGISTERS;
1208             Scratch = ffInterpret();
1209             LOAD_REGISTERS;
1210             if( Scratch ) M_THROW(Scratch)
1211             endcase;
1212 #endif  /* !PF_NO_SHELL */
1213
1214         case ID_J:  /* ( -- j , second DO LOOP index ) */
1215             PUSH_TOS;
1216             TOS = M_R_PICK(3);
1217             endcase;
1218
1219         case ID_KEY:
1220             PUSH_TOS;
1221             TOS = ioKey();
1222             endcase;
1223
1224 #ifndef PF_NO_SHELL
1225         case ID_LITERAL:
1226             ffLiteral( TOS );
1227             M_DROP;
1228             endcase;
1229 #endif /* !PF_NO_SHELL */
1230
1231         case ID_LITERAL_P:
1232             DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
1233             PUSH_TOS;
1234             TOS = READ_CELL_DIC(InsPtr++);
1235             endcase;
1236
1237 #ifndef PF_NO_SHELL
1238         case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
1239 #endif /* !PF_NO_SHELL */
1240
1241         case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
1242             TOS = *(LocalsPtr - TOS);
1243             endcase;
1244
1245 #define LOCAL_FETCH_N(num) \
1246         case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
1247             PUSH_TOS; \
1248             TOS = *(LocalsPtr -(num)); \
1249             endcase;
1250
1251         LOCAL_FETCH_N(1);
1252         LOCAL_FETCH_N(2);
1253         LOCAL_FETCH_N(3);
1254         LOCAL_FETCH_N(4);
1255         LOCAL_FETCH_N(5);
1256         LOCAL_FETCH_N(6);
1257         LOCAL_FETCH_N(7);
1258         LOCAL_FETCH_N(8);
1259
1260         case ID_LOCAL_STORE:  /* ( n i <local> -- , store n in local ) */
1261             *(LocalsPtr - TOS) = M_POP;
1262             M_DROP;
1263             endcase;
1264
1265 #define LOCAL_STORE_N(num) \
1266         case ID_LOCAL_STORE_##num:  /* ( n <local> -- , store n in local ) */ \
1267             *(LocalsPtr - (num)) = TOS; \
1268             M_DROP; \
1269             endcase;
1270
1271         LOCAL_STORE_N(1);
1272         LOCAL_STORE_N(2);
1273         LOCAL_STORE_N(3);
1274         LOCAL_STORE_N(4);
1275         LOCAL_STORE_N(5);
1276         LOCAL_STORE_N(6);
1277         LOCAL_STORE_N(7);
1278         LOCAL_STORE_N(8);
1279
1280         case ID_LOCAL_PLUSSTORE:  /* ( n i <local> -- , add n to local ) */
1281             *(LocalsPtr - TOS) += M_POP;
1282             M_DROP;
1283             endcase;
1284
1285         case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
1286         /* create local stack frame */
1287             {
1288                 cell_t i = TOS;
1289                 cell_t *lp;
1290                 DBUG(("LocalEntry: n = %d\n", TOS));
1291                 /* End of locals. Create stack frame */
1292                 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
1293                     TORPTR, LocalsPtr));
1294                 M_R_PUSH(LocalsPtr);
1295                 LocalsPtr = TORPTR;
1296                 TORPTR -= TOS;
1297                 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
1298                     TORPTR, LocalsPtr));
1299                 lp = TORPTR;
1300                 while(i-- > 0)
1301                 {
1302                     *lp++ = M_POP;    /* Load local vars from stack */
1303                 }
1304                 M_DROP;
1305             }
1306             endcase;
1307
1308         case ID_LOCAL_EXIT: /* cleanup up local stack frame */
1309             DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
1310                 TORPTR, LocalsPtr));
1311             TORPTR = LocalsPtr;
1312             LocalsPtr = (cell_t *) M_R_POP;
1313             DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
1314                 TORPTR, LocalsPtr));
1315             endcase;
1316
1317 #ifndef PF_NO_SHELL
1318         case ID_LOADSYS:
1319             MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
1320             FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
1321             if( FileID )
1322             {
1323                 SAVE_REGISTERS;
1324                 Scratch = ffIncludeFile( FileID ); /* Also closes the file. */
1325                 LOAD_REGISTERS;
1326                 if( Scratch ) M_THROW(Scratch);
1327             }
1328             else
1329             {
1330                  ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
1331             }
1332             endcase;
1333 #endif  /* !PF_NO_SHELL */
1334
1335         case ID_LEAVE_P: /* ( R: index limit --  ) */
1336             M_R_DROP;
1337             M_R_DROP;
1338             M_BRANCH;
1339             endcase;
1340
1341         case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
1342             Temp = M_R_POP; /* limit */
1343             Scratch = M_R_POP + 1; /* index */
1344             if( Scratch == Temp )
1345             {
1346                 InsPtr++;   /* skip branch offset, exit loop */
1347             }
1348             else
1349             {
1350 /* Push index and limit back to R */
1351                 M_R_PUSH( Scratch );
1352                 M_R_PUSH( Temp );
1353 /* Branch back to just after (DO) */
1354                 M_BRANCH;
1355             }
1356             endcase;
1357
1358         case ID_LSHIFT:     BINARY_OP( << ); endcase;
1359
1360         case ID_MAX:
1361             Scratch = M_POP;
1362             TOS = ( TOS > Scratch ) ? TOS : Scratch ;
1363             endcase;
1364
1365         case ID_MIN:
1366             Scratch = M_POP;
1367             TOS = ( TOS < Scratch ) ? TOS : Scratch ;
1368             endcase;
1369
1370         case ID_MINUS:     BINARY_OP( - ); endcase;
1371
1372 #ifndef PF_NO_SHELL
1373         case ID_NAME_TO_TOKEN:
1374             TOS = (cell_t) NameToToken((ForthString *)TOS);
1375             endcase;
1376
1377         case ID_NAME_TO_PREVIOUS:
1378             TOS = (cell_t) NameToPrevious((ForthString *)TOS);
1379             endcase;
1380 #endif
1381
1382         case ID_NOOP:
1383             endcase;
1384
1385         case ID_OR:     BINARY_OP( | ); endcase;
1386
1387         case ID_OVER:
1388             PUSH_TOS;
1389             TOS = M_STACK(1);
1390             endcase;
1391
1392         case ID_PICK: /* ( ... n -- sp(n) ) */
1393             TOS = M_STACK(TOS);
1394             endcase;
1395
1396         case ID_PLUS:     BINARY_OP( + ); endcase;
1397
1398         case ID_PLUS_STORE:   /* ( n addr -- , add n to *addr ) */
1399 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1400             if( IN_DICS( TOS ) )
1401             {
1402                 Scratch = READ_CELL_DIC((cell_t *)TOS);
1403                 Scratch += M_POP;
1404                 WRITE_CELL_DIC((cell_t *)TOS,Scratch);
1405             }
1406             else
1407             {
1408                 *((cell_t *)TOS) += M_POP;
1409             }
1410 #else
1411             *((cell_t *)TOS) += M_POP;
1412 #endif
1413             M_DROP;
1414             endcase;
1415
1416         case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
1417             {
1418                 cell_t Limit = M_R_POP;
1419                 cell_t OldIndex = M_R_POP;
1420                 cell_t Delta = TOS; /* add TOS to index, not 1 */
1421                 cell_t NewIndex = OldIndex + Delta;
1422                 cell_t OldDiff = OldIndex - Limit;
1423
1424                 /* This exploits this idea (lifted from Gforth):
1425                    (x^y)<0 is equivalent to (x<0) != (y<0) */
1426                 if( ((OldDiff ^ (OldDiff + Delta)) /* is the limit crossed? */
1427                      & (OldDiff ^ Delta))          /* is it a wrap-around? */
1428                     < 0 )
1429                 {
1430                     InsPtr++;   /* skip branch offset, exit loop */
1431                 }
1432                 else
1433                 {
1434 /* Push index and limit back to R */
1435                     M_R_PUSH( NewIndex );
1436                     M_R_PUSH( Limit );
1437 /* Branch back to just after (DO) */
1438                     M_BRANCH;
1439                 }
1440                 M_DROP;
1441             }
1442             endcase;
1443
1444         case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
1445             Scratch = M_POP;  /* limit */
1446             if( Scratch == TOS )
1447             {
1448 /* Branch to just after (LOOP) */
1449                 M_BRANCH;
1450             }
1451             else
1452             {
1453                 M_R_PUSH( TOS );
1454                 M_R_PUSH( Scratch );
1455                 InsPtr++;   /* skip branch offset, enter loop */
1456             }
1457             M_DROP;
1458             endcase;
1459
1460         case ID_QDUP:     if( TOS ) M_DUP; endcase;
1461
1462         case ID_QTERMINAL:  /* WARNING: Typically not fully implemented! */
1463             PUSH_TOS;
1464             TOS = sdQueryTerminal();
1465             endcase;
1466
1467         case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
1468 #ifdef PF_SUPPORT_TRACE
1469             Level = 0;
1470 #endif
1471             M_THROW(THROW_QUIT);
1472             endcase;
1473
1474         case ID_R_DROP:
1475             M_R_DROP;
1476             endcase;
1477
1478         case ID_R_FETCH:
1479             PUSH_TOS;
1480             TOS = (*(TORPTR));
1481             endcase;
1482
1483         case ID_R_FROM:
1484             PUSH_TOS;
1485             TOS = M_R_POP;
1486             endcase;
1487
1488         case ID_REFILL:
1489             PUSH_TOS;
1490             TOS = (ffRefill() > 0) ? FTRUE : FFALSE;
1491             endcase;
1492
1493 /* Resize memory allocated by ALLOCATE. */
1494         case ID_RESIZE:  /* ( addr1 u -- addr2 result ) */
1495             {
1496                 cell_t *Addr1 = (cell_t *) M_POP;
1497                 /* Point to validator below users address. */
1498                 cell_t *FreePtr = Addr1 - 1;
1499                 if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))
1500                 {
1501                     /* 090218 - Fixed bug, was returning zero. */
1502                     M_PUSH( Addr1 );
1503                     TOS = -3;
1504                 }
1505                 else
1506                 {
1507                     /* Try to allocate. */
1508                     CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );
1509                     if( CellPtr )
1510                     {
1511                         /* Copy memory including validation. */
1512                         pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );
1513                         *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);
1514                         /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */
1515                         /* Increment past validator to user address. */
1516                         M_PUSH( (cell_t) (CellPtr + 1) );
1517                         TOS = 0; /* Result code. */
1518                         /* Mark old cell as dead so we can't free it twice. */
1519                         FreePtr[0] = 0xDeadBeef;
1520                         pfFreeMem((char *) FreePtr);
1521                     }
1522                     else
1523                     {
1524                         /* 090218 - Fixed bug, was returning zero. */
1525                         M_PUSH( Addr1 );
1526                         TOS = -4;  /* FIXME Fix error code. */
1527                     }
1528                 }
1529             }
1530             endcase;
1531
1532 /*
1533 ** RP@ and RP! are called secondaries so we must
1534 ** account for the return address pushed before calling.
1535 */
1536         case ID_RP_FETCH:    /* ( -- rp , address of top of return stack ) */
1537             PUSH_TOS;
1538             TOS = (cell_t)TORPTR;  /* value before calling RP@ */
1539             endcase;
1540
1541         case ID_RP_STORE:    /* ( rp -- , address of top of return stack ) */
1542             TORPTR = (cell_t *) TOS;
1543             M_DROP;
1544             endcase;
1545
1546         case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
1547             {
1548                 cell_t ri;
1549                 cell_t *srcPtr, *dstPtr;
1550                 Scratch = M_STACK(TOS);
1551                 srcPtr = &M_STACK(TOS-1);
1552                 dstPtr = &M_STACK(TOS);
1553                 for( ri=0; ri<TOS; ri++ )
1554                 {
1555                     *dstPtr-- = *srcPtr--;
1556                 }
1557                 TOS = Scratch;
1558                 STKPTR++;
1559             }
1560             endcase;
1561
1562         case ID_ROT:  /* ( a b c -- b c a ) */
1563             Scratch = M_POP;    /* b */
1564             Temp = M_POP;       /* a */
1565             M_PUSH( Scratch );  /* b */
1566             PUSH_TOS;           /* c */
1567             TOS = Temp;         /* a */
1568             endcase;
1569
1570 /* Logical right shift */
1571         case ID_RSHIFT:     { TOS = ((ucell_t)M_POP) >> TOS; } endcase;
1572
1573 #ifndef PF_NO_SHELL
1574         case ID_SAVE_FORTH_P:   /* ( $name Entry NameSize CodeSize -- err ) */
1575             {
1576                 cell_t NameSize, CodeSize, EntryPoint;
1577                 CodeSize = TOS;
1578                 NameSize = M_POP;
1579                 EntryPoint = M_POP;
1580                 ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );
1581                 TOS =  ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
1582             }
1583             endcase;
1584 #endif
1585
1586         case ID_SP_FETCH:    /* ( -- sp , address of top of stack, sorta ) */
1587             PUSH_TOS;
1588             TOS = (cell_t)STKPTR;
1589             endcase;
1590
1591         case ID_SP_STORE:    /* ( sp -- , address of top of stack, sorta ) */
1592             STKPTR = (cell_t *) TOS;
1593             M_DROP;
1594             endcase;
1595
1596         case ID_STORE: /* ( n addr -- , write n to addr ) */
1597 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1598             if( IN_DICS( TOS ) )
1599             {
1600                 WRITE_CELL_DIC((cell_t *)TOS,M_POP);
1601             }
1602             else
1603             {
1604                 *((cell_t *)TOS) = M_POP;
1605             }
1606 #else
1607             *((cell_t *)TOS) = M_POP;
1608 #endif
1609             M_DROP;
1610             endcase;
1611
1612         case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
1613             Scratch = M_POP; /* cnt */
1614             Temp = M_POP;    /* addr */
1615             TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1616             M_PUSH((cell_t) CharPtr);
1617             endcase;
1618
1619 #ifndef PF_NO_SHELL
1620         case ID_SEMICOLON:
1621             SAVE_REGISTERS;
1622             Scratch = ffSemiColon();
1623             LOAD_REGISTERS;
1624             if( Scratch ) M_THROW( Scratch );
1625             endcase;
1626 #endif /* !PF_NO_SHELL */
1627
1628         case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
1629             Scratch = M_POP; /* cnt */
1630             Temp = M_POP;    /* addr */
1631             TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1632             M_PUSH((cell_t) CharPtr);
1633             endcase;
1634
1635         case ID_SOURCE:  /* ( -- c-addr num ) */
1636             PUSH_TOS;
1637             M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );
1638             TOS = (cell_t) gCurrentTask->td_SourceNum;
1639             endcase;
1640
1641         case ID_SOURCE_SET: /* ( c-addr num -- ) */
1642             gCurrentTask->td_SourcePtr = (char *) M_POP;
1643             gCurrentTask->td_SourceNum = TOS;
1644             M_DROP;
1645             endcase;
1646
1647         case ID_SOURCE_ID:
1648             PUSH_TOS;
1649             TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
1650             endcase;
1651
1652         case ID_SOURCE_ID_POP:
1653             PUSH_TOS;
1654             TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
1655             endcase;
1656
1657         case ID_SOURCE_ID_PUSH:  /* ( source-id -- ) */
1658             TOS = (cell_t)ffConvertSourceIDToStream( TOS );
1659             Scratch = ffPushInputStream((FileStream *) TOS );
1660             if( Scratch )
1661             {
1662                 M_THROW(Scratch);
1663             }
1664             else M_DROP;
1665             endcase;
1666
1667         case ID_SOURCE_LINE_NUMBER_FETCH: /* ( -- linenr ) */
1668             PUSH_TOS;
1669             TOS = gCurrentTask->td_LineNumber;
1670             endcase;
1671
1672         case ID_SOURCE_LINE_NUMBER_STORE: /* ( linenr -- ) */
1673             gCurrentTask->td_LineNumber = TOS;
1674             TOS = M_POP;
1675             endcase;
1676
1677         case ID_SWAP:
1678             Scratch = TOS;
1679             TOS = *STKPTR;
1680             *STKPTR = Scratch;
1681             endcase;
1682
1683         case ID_TEST1:
1684             PUSH_TOS;
1685             M_PUSH( 0x11 );
1686             M_PUSH( 0x22 );
1687             TOS = 0x33;
1688             endcase;
1689
1690         case ID_TEST2:
1691             endcase;
1692
1693         case ID_THROW:  /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
1694             if(TOS)
1695             {
1696                 M_THROW(TOS);
1697             }
1698             else M_DROP;
1699             endcase;
1700
1701 #ifndef PF_NO_SHELL
1702         case ID_TICK:
1703             PUSH_TOS;
1704             CharPtr = (char *) ffWord( (char) ' ' );
1705             TOS = ffFind( CharPtr, (ExecToken *) &Temp );
1706             if( TOS == 0 )
1707             {
1708                 ERR("' could not find ");
1709                 ioType( (char *) CharPtr+1, *CharPtr );
1710                 M_THROW(-13);
1711             }
1712             else
1713             {
1714                 TOS = Temp;
1715             }
1716             endcase;
1717 #endif  /* !PF_NO_SHELL */
1718
1719         case ID_TIMES: BINARY_OP( * ); endcase;
1720
1721         case ID_TYPE:
1722             Scratch = M_POP; /* addr */
1723             ioType( (char *) Scratch, TOS );
1724             M_DROP;
1725             endcase;
1726
1727         case ID_TO_R:
1728             M_R_PUSH( TOS );
1729             M_DROP;
1730             endcase;
1731
1732         case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
1733         case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
1734         case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
1735         case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
1736         case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
1737         case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
1738         case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
1739         case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
1740         case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;
1741         case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
1742         case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
1743         case ID_VAR_STATE: DO_VAR(gVarState); endcase;
1744         case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
1745         case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
1746         case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
1747         case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
1748         case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
1749
1750         case ID_WORD:
1751             TOS = (cell_t) ffWord( (char) TOS );
1752             endcase;
1753
1754         case ID_WORD_FETCH: /* ( waddr -- w ) */
1755 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1756             if( IN_DICS( TOS ) )
1757             {
1758                 TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);
1759             }
1760             else
1761             {
1762                 TOS = *((uint16_t *)TOS);
1763             }
1764 #else
1765             TOS = *((uint16_t *)TOS);
1766 #endif
1767             endcase;
1768
1769         case ID_WORD_STORE: /* ( w waddr -- ) */
1770
1771 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1772             if( IN_DICS( TOS ) )
1773             {
1774                 WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);
1775             }
1776             else
1777             {
1778                 *((uint16_t *)TOS) = (uint16_t) M_POP;
1779             }
1780 #else
1781             *((uint16_t *)TOS) = (uint16_t) M_POP;
1782 #endif
1783             M_DROP;
1784             endcase;
1785
1786         case ID_XOR: BINARY_OP( ^ ); endcase;
1787
1788
1789 /* Branch is followed by an offset relative to address of offset. */
1790         case ID_ZERO_BRANCH:
1791 DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
1792             if( TOS == 0 )
1793             {
1794                 M_BRANCH;
1795             }
1796             else
1797             {
1798                 InsPtr++;      /* skip over offset */
1799             }
1800             M_DROP;
1801 DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
1802             endcase;
1803
1804         default:
1805             ERR("pfCatch: Unrecognised token = 0x");
1806             ffDotHex(Token);
1807             ERR(" at 0x");
1808             ffDotHex((cell_t) InsPtr);
1809             EMIT_CR;
1810             InsPtr = 0;
1811             endcase;
1812         }
1813
1814         if(InsPtr) Token = READ_CELL_DIC(InsPtr++);   /* Traverse to next token in secondary. */
1815
1816 #ifdef PF_DEBUG
1817         M_DOTS;
1818 #endif
1819
1820 #if 0
1821         if( _CrtCheckMemory() == 0 )
1822         {
1823             ERR("_CrtCheckMemory abort: InsPtr = 0x");
1824             ffDotHex((int)InsPtr);
1825             ERR("\n");
1826         }
1827 #endif
1828
1829     } while( (InitialReturnStack - TORPTR) > 0 );
1830
1831     SAVE_REGISTERS;
1832
1833     return ExceptionReturnCode;
1834 }