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