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

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