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