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

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