1 /* @(#) pf_inner.c 98/03/16 1.7 */
\r
2 /***************************************************************
\r
3 ** Inner Interpreter for Forth based on 'C'
\r
6 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
\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
17 ****************************************************************
\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
27 ***************************************************************/
\r
35 #define SYSTEM_LOAD_FILE "system.fth"
\r
37 /***************************************************************
\r
38 ** Macros for data stack access.
\r
39 ** TOS is cached in a register in pfCatch.
\r
40 ***************************************************************/
\r
42 #define STKPTR (DataStackPtr)
\r
43 #define M_POP (*(STKPTR++))
\r
44 #define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);}
\r
45 #define M_STACK(n) (STKPTR[n])
\r
47 #define TOS (TopOfStack)
\r
48 #define PUSH_TOS M_PUSH(TOS)
\r
49 #define M_DUP PUSH_TOS;
\r
50 #define M_DROP { TOS = M_POP; }
\r
53 /***************************************************************
\r
54 ** Macros for Floating Point stack access.
\r
55 ***************************************************************/
\r
56 #ifdef PF_SUPPORT_FP
\r
57 #define FP_STKPTR (FloatStackPtr)
\r
58 #define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)
\r
59 #define M_FP_POP (*(FP_STKPTR++))
\r
60 #define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}
\r
61 #define M_FP_STACK(n) (FP_STKPTR[n])
\r
63 #define FP_TOS (fpTopOfStack)
\r
64 #define PUSH_FP_TOS M_FP_PUSH(FP_TOS)
\r
65 #define M_FP_DUP PUSH_FP_TOS;
\r
66 #define M_FP_DROP { FP_TOS = M_FP_POP; }
\r
69 /***************************************************************
\r
70 ** Macros for return stack access.
\r
71 ***************************************************************/
\r
73 #define TORPTR (ReturnStackPtr)
\r
74 #define M_R_DROP {TORPTR++;}
\r
75 #define M_R_POP (*(TORPTR++))
\r
76 #define M_R_PICK(n) (TORPTR[n])
\r
77 #define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);}
\r
79 /***************************************************************
\r
80 ** Misc Forth macros
\r
81 ***************************************************************/
\r
83 #define M_BRANCH { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); }
\r
85 /* Cache top of data stack like in JForth. */
\r
86 #ifdef PF_SUPPORT_FP
\r
87 #define LOAD_REGISTERS \
\r
89 STKPTR = gCurrentTask->td_StackPtr; \
\r
91 FP_STKPTR = gCurrentTask->td_FloatStackPtr; \
\r
92 FP_TOS = M_FP_POP; \
\r
93 TORPTR = gCurrentTask->td_ReturnPtr; \
\r
96 #define SAVE_REGISTERS \
\r
98 gCurrentTask->td_ReturnPtr = TORPTR; \
\r
100 gCurrentTask->td_StackPtr = STKPTR; \
\r
101 M_FP_PUSH( FP_TOS ); \
\r
102 gCurrentTask->td_FloatStackPtr = FP_STKPTR; \
\r
106 /* Cache top of data stack like in JForth. */
\r
107 #define LOAD_REGISTERS \
\r
109 STKPTR = gCurrentTask->td_StackPtr; \
\r
111 TORPTR = gCurrentTask->td_ReturnPtr; \
\r
114 #define SAVE_REGISTERS \
\r
116 gCurrentTask->td_ReturnPtr = TORPTR; \
\r
118 gCurrentTask->td_StackPtr = STKPTR; \
\r
127 #define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; }
\r
129 #ifdef PF_SUPPORT_FP
\r
130 #define M_THROW(err) \
\r
132 ExceptionReturnCode = (ThrowCode)(err); \
\r
133 TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
\r
134 STKPTR = InitialDataStack; \
\r
135 FP_STKPTR = InitialFloatStack; \
\r
138 #define M_THROW(err) \
\r
140 ExceptionReturnCode = (err); \
\r
141 TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
\r
142 STKPTR = InitialDataStack; \
\r
146 /***************************************************************
\r
148 ***************************************************************/
\r
150 #define BINARY_OP( op ) { TOS = M_POP op TOS; }
\r
151 #define endcase break
\r
153 #if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)
\r
154 #define TRACENAMES /* no names */
\r
156 /* Display name of executing routine. */
\r
157 static void TraceNames( ExecToken Token, cell_t Level )
\r
162 if( ffTokenToName( Token, &DebugName ) )
\r
165 if( gCurrentTask->td_OUT > 0 ) EMIT_CR;
\r
167 for( i=0; i<Level; i++ )
\r
171 TypeName( DebugName );
\r
172 /* Space out to column N then .S */
\r
173 NumSpaces = 30 - gCurrentTask->td_OUT;
\r
174 for( i=0; i < NumSpaces; i++ )
\r
179 /* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */
\r
184 MSG_NUM_H("Couldn't find Name for ", Token);
\r
188 #define TRACENAMES \
\r
189 if( (gVarTraceLevel > Level) ) \
\r
190 { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }
\r
191 #endif /* PF_NO_SHELL */
\r
193 /* Use local copy of CODE_BASE for speed. */
\r
194 #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))
\r
196 static const char *pfSelectFileModeCreate( int fam );
\r
197 static const char *pfSelectFileModeOpen( int fam );
\r
199 /**************************************************************/
\r
200 static const char *pfSelectFileModeCreate( int fam )
\r
202 const char *famText = NULL;
\r
205 case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
\r
206 famText = PF_FAM_BIN_CREATE_WO;
\r
208 case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
\r
209 famText = PF_FAM_BIN_CREATE_RW;
\r
211 case PF_FAM_WRITE_ONLY:
\r
212 famText = PF_FAM_CREATE_WO;
\r
214 case PF_FAM_READ_WRITE:
\r
215 famText = PF_FAM_CREATE_RW;
\r
218 famText = "illegal";
\r
224 /**************************************************************/
\r
225 static const char *pfSelectFileModeOpen( int fam )
\r
227 const char *famText = NULL;
\r
230 case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG):
\r
231 famText = PF_FAM_BIN_OPEN_RO;
\r
233 case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
\r
234 famText = PF_FAM_BIN_CREATE_WO;
\r
236 case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
\r
237 famText = PF_FAM_BIN_OPEN_RW;
\r
239 case PF_FAM_READ_ONLY:
\r
240 famText = PF_FAM_OPEN_RO;
\r
242 case PF_FAM_WRITE_ONLY:
\r
243 famText = PF_FAM_CREATE_WO;
\r
245 case PF_FAM_READ_WRITE:
\r
247 famText = PF_FAM_OPEN_RW;
\r
253 /**************************************************************/
\r
254 int pfCatch( ExecToken XT )
\r
256 register cell_t TopOfStack; /* Cache for faster execution. */
\r
257 register cell_t *DataStackPtr;
\r
258 register cell_t *ReturnStackPtr;
\r
259 register cell_t *InsPtr = NULL;
\r
260 register cell_t Token;
\r
263 #ifdef PF_SUPPORT_FP
\r
264 PF_FLOAT fpTopOfStack;
\r
265 PF_FLOAT *FloatStackPtr;
\r
266 PF_FLOAT fpScratch;
\r
268 PF_FLOAT *InitialFloatStack;
\r
270 #ifdef PF_SUPPORT_TRACE
\r
273 cell_t *LocalsPtr = NULL;
\r
275 cell_t *InitialReturnStack;
\r
276 cell_t *InitialDataStack;
\r
277 cell_t FakeSecondary[2];
\r
280 FileStream *FileID;
\r
281 uint8_t *CodeBase = CODE_BASE;
\r
282 ThrowCode ExceptionReturnCode = 0;
\r
285 gExecutionDepth += 1;
\r
286 PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth ));
\r
290 ** Initialize FakeSecondary this way to avoid having stuff in the data section,
\r
291 ** which is not supported for some embedded system loaders.
\r
293 FakeSecondary[0] = 0;
\r
294 FakeSecondary[1] = ID_EXIT; /* For EXECUTE */
\r
296 /* Move data from task structure to registers for speed. */
\r
299 /* Save initial stack depths for THROW */
\r
300 InitialReturnStack = TORPTR;
\r
301 InitialDataStack = STKPTR ;
\r
302 #ifdef PF_SUPPORT_FP
\r
303 InitialFloatStack = FP_STKPTR;
\r
310 DBUG(("pfCatch: Token = 0x%x\n", Token ));
\r
312 /* --------------------------------------------------------------- */
\r
313 /* If secondary, thread down code tree until we hit a primitive. */
\r
314 while( !IsTokenPrimitive( Token ) )
\r
316 #ifdef PF_SUPPORT_TRACE
\r
317 if((gVarTraceFlags & TRACE_INNER) )
\r
319 MSG("pfCatch: Secondary Token = 0x");
\r
321 MSG_NUM_H(", InsPtr = 0x", InsPtr);
\r
326 /* Save IP on return stack like a JSR. */
\r
327 M_R_PUSH( InsPtr );
\r
329 /* Convert execution token to absolute address. */
\r
330 InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) );
\r
332 /* Fetch token at IP. */
\r
333 Token = READ_CELL_DIC(InsPtr++);
\r
335 #ifdef PF_SUPPORT_TRACE
\r
336 /* Bump level for trace display */
\r
342 #ifdef PF_SUPPORT_TRACE
\r
346 /* Execute primitive Token. */
\r
350 /* Pop up a level in Forth inner interpreter.
\r
351 ** Used to implement semicolon.
\r
352 ** Put first in switch because ID_EXIT==0 */
\r
354 InsPtr = ( cell_t *) M_R_POP;
\r
355 #ifdef PF_SUPPORT_TRACE
\r
360 case ID_1MINUS: TOS--; endcase;
\r
362 case ID_1PLUS: TOS++; endcase;
\r
364 #ifndef PF_NO_SHELL
\r
366 ff2Literal( TOS, M_POP );
\r
369 #endif /* !PF_NO_SHELL */
\r
371 case ID_2LITERAL_P:
\r
372 /* hi part stored first, put on top of stack */
\r
374 TOS = READ_CELL_DIC(InsPtr++);
\r
375 M_PUSH(READ_CELL_DIC(InsPtr++));
\r
378 case ID_2MINUS: TOS -= 2; endcase;
\r
380 case ID_2PLUS: TOS += 2; endcase;
\r
383 case ID_2OVER: /* ( a b c d -- a b c d a b ) */
\r
385 Scratch = M_STACK(3);
\r
390 case ID_2SWAP: /* ( a b c d -- c d a b ) */
\r
391 Scratch = M_STACK(0); /* c */
\r
392 M_STACK(0) = M_STACK(2); /* a */
\r
393 M_STACK(2) = Scratch; /* c */
\r
394 Scratch = TOS; /* d */
\r
395 TOS = M_STACK(1); /* b */
\r
396 M_STACK(1) = Scratch; /* d */
\r
399 case ID_2DUP: /* ( a b -- a b a b ) */
\r
401 Scratch = M_STACK(1);
\r
407 M_PUSH( (*(TORPTR+1)) );
\r
423 case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */
\r
424 CharPtr = (char *) M_POP;
\r
425 TOS = ioAccept( CharPtr, TOS );
\r
428 #ifndef PF_NO_SHELL
\r
430 ffALiteral( ABS_TO_CODEREL(TOS) );
\r
433 #endif /* !PF_NO_SHELL */
\r
435 case ID_ALITERAL_P:
\r
437 TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) );
\r
440 /* Allocate some extra and put validation identifier at base */
\r
441 #define PF_MEMORY_VALIDATOR (0xA81B4D69)
\r
443 /* Allocate at least one cell's worth because we clobber first cell. */
\r
444 if ( TOS < sizeof(cell_t) )
\r
446 Temp = sizeof(cell_t);
\r
452 /* Allocate extra cells worth because we store validation info. */
\r
453 CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) );
\r
456 /* This was broken into two steps because different compilers incremented
\r
457 ** CellPtr before or after the XOR step. */
\r
458 Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR;
\r
460 M_PUSH( (cell_t) CellPtr );
\r
466 TOS = -1; /* FIXME Fix error code. */
\r
470 case ID_AND: BINARY_OP( & ); endcase;
\r
472 case ID_ARSHIFT: BINARY_OP( >> ); endcase; /* Arithmetic right shift */
\r
474 case ID_BODY_OFFSET:
\r
476 TOS = CREATE_BODY_OFFSET;
\r
479 /* Branch is followed by an offset relative to address of offset. */
\r
481 DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));
\r
483 DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
\r
487 M_THROW( THROW_BYE );
\r
491 MSG("Emergency exit.\n");
\r
499 Scratch = pfCatch( Scratch );
\r
507 Scratch = READ_CELL_DIC(InsPtr++);
\r
508 CallUserFunction( Scratch & 0xFFFF,
\r
509 (Scratch >> 31) & 1,
\r
510 (Scratch >> 24) & 0x7F );
\r
514 /* Support 32/64 bit operation. */
\r
517 TOS = sizeof(cell_t);
\r
521 TOS = TOS * sizeof(cell_t);
\r
524 case ID_CFETCH: TOS = *((uint8_t *) TOS); endcase;
\r
526 case ID_CMOVE: /* ( src dst n -- ) */
\r
528 register char *DstPtr = (char *) M_POP; /* dst */
\r
529 CharPtr = (char *) M_POP; /* src */
\r
530 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
\r
532 *DstPtr++ = *CharPtr++;
\r
538 case ID_CMOVE_UP: /* ( src dst n -- ) */
\r
540 register char *DstPtr = ((char *) M_POP) + TOS; /* dst */
\r
541 CharPtr = ((char *) M_POP) + TOS;; /* src */
\r
542 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
\r
544 *(--DstPtr) = *(--CharPtr);
\r
550 #ifndef PF_NO_SHELL
\r
556 case ID_COLON_P: /* ( $name xt -- ) */
\r
557 CreateDicEntry( TOS, (char *) M_POP, 0 );
\r
560 #endif /* !PF_NO_SHELL */
\r
564 const char *s1, *s2;
\r
566 s2 = (const char *) M_POP;
\r
568 s1 = (const char *) M_POP;
\r
569 TOS = ffCompare( s1, len1, s2, TOS );
\r
573 /* ( a b -- flag , Comparisons ) */
\r
574 case ID_COMP_EQUAL:
\r
575 TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;
\r
577 case ID_COMP_NOT_EQUAL:
\r
578 TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;
\r
580 case ID_COMP_GREATERTHAN:
\r
581 TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;
\r
583 case ID_COMP_LESSTHAN:
\r
584 TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ;
\r
586 case ID_COMP_U_GREATERTHAN:
\r
587 TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
\r
589 case ID_COMP_U_LESSTHAN:
\r
590 TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
\r
592 case ID_COMP_ZERO_EQUAL:
\r
593 TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;
\r
595 case ID_COMP_ZERO_NOT_EQUAL:
\r
596 TOS = ( TOS != 0 ) ? FTRUE : FALSE ;
\r
598 case ID_COMP_ZERO_GREATERTHAN:
\r
599 TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;
\r
601 case ID_COMP_ZERO_LESSTHAN:
\r
602 TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;
\r
609 #ifndef PF_NO_SHELL
\r
615 #endif /* !PF_NO_SHELL */
\r
619 /* Put address of body on stack. Insptr points after code start. */
\r
620 TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );
\r
623 case ID_CSTORE: /* ( c caddr -- ) */
\r
624 *((uint8_t *) TOS) = (uint8_t) M_POP;
\r
628 /* Double precision add. */
\r
629 case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */
\r
631 register ucell_t ah,al,bl,sh,sl;
\r
638 if( sl < bl ) sh = 1; /* Carry */
\r
646 /* Double precision subtract. */
\r
647 case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */
\r
649 register ucell_t ah,al,bl,sh,sl;
\r
656 if( al < bl ) sh = 1; /* Borrow */
\r
664 /* Assume 8-bit char and calculate cell width. */
\r
665 #define NBITS ((sizeof(ucell_t)) * 8)
\r
666 /* Define half the number of bits in a cell. */
\r
667 #define HNBITS (NBITS / 2)
\r
668 /* Assume two-complement arithmetic to calculate lower half. */
\r
669 #define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))
\r
670 #define HIGH_BIT ((ucell_t)1 << (NBITS - 1))
\r
672 /* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.
\r
673 * Using an improved algorithm suggested by Steve Green.
\r
674 * Converted to 64-bit by Aleksej Saushev.
\r
676 case ID_D_UMTIMES: /* UM* ( a b -- lo hi ) */
\r
678 ucell_t ahi, alo, bhi, blo; /* input parts */
\r
679 ucell_t lo, hi, temp;
\r
680 /* Get values from stack. */
\r
683 /* Break into hi and lo 16 bit parts. */
\r
684 alo = LOWER_HALF(ahi);
\r
685 ahi = ahi >> HNBITS;
\r
686 blo = LOWER_HALF(bhi);
\r
687 bhi = bhi >> HNBITS;
\r
691 /* higher part: ahi * bhi */
\r
693 /* middle (overlapping) part: ahi * blo */
\r
695 lo += LOWER_HALF(temp);
\r
696 hi += temp >> HNBITS;
\r
697 /* middle (overlapping) part: alo * bhi */
\r
699 lo += LOWER_HALF(temp);
\r
700 hi += temp >> HNBITS;
\r
701 /* lower part: alo * blo */
\r
703 /* its higher half overlaps with middle's lower half: */
\r
704 lo += temp >> HNBITS;
\r
705 /* process carry: */
\r
706 hi += lo >> HNBITS;
\r
707 lo = LOWER_HALF(lo);
\r
708 /* combine lower part of result: */
\r
709 lo = (lo << HNBITS) + LOWER_HALF(temp);
\r
716 /* Perform cell*cell bit multiply for 2 cell result, using shift and add. */
\r
717 case ID_D_MTIMES: /* M* ( a b -- pl ph ) */
\r
719 ucell_t ahi, alo, bhi, blo; /* input parts */
\r
720 ucell_t lo, hi, temp;
\r
722 /* Get values from stack. */
\r
726 /* Calculate product sign: */
\r
727 sg = ((cell_t)(ahi ^ bhi) < 0);
\r
728 /* Take absolute values and reduce to um* */
\r
729 if ((cell_t)ahi < 0) ahi = (ucell_t)(-ahi);
\r
730 if ((cell_t)bhi < 0) bhi = (ucell_t)(-bhi);
\r
732 /* Break into hi and lo 16 bit parts. */
\r
733 alo = LOWER_HALF(ahi);
\r
734 ahi = ahi >> HNBITS;
\r
735 blo = LOWER_HALF(bhi);
\r
736 bhi = bhi >> HNBITS;
\r
740 /* higher part: ahi * bhi */
\r
742 /* middle (overlapping) part: ahi * blo */
\r
744 lo += LOWER_HALF(temp);
\r
745 hi += temp >> HNBITS;
\r
746 /* middle (overlapping) part: alo * bhi */
\r
748 lo += LOWER_HALF(temp);
\r
749 hi += temp >> HNBITS;
\r
750 /* lower part: alo * blo */
\r
752 /* its higher half overlaps with middle's lower half: */
\r
753 lo += temp >> HNBITS;
\r
754 /* process carry: */
\r
755 hi += lo >> HNBITS;
\r
756 lo = LOWER_HALF(lo);
\r
757 /* combine lower part of result: */
\r
758 lo = (lo << HNBITS) + LOWER_HALF(temp);
\r
760 /* Negate product if one operand negative. */
\r
763 /* lo = (ucell_t)(- lo); */
\r
765 hi = ~hi + ((lo == 0) ? 1 : 0);
\r
773 #define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
\r
774 /* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */
\r
775 case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */
\r
777 ucell_t ah,al, q,di, bl,bh, sl,sh;
\r
783 for( di=0; di<NBITS; di++ )
\r
785 if( !DULT(al,ah,bl,bh) )
\r
789 if( al < bl ) sh = 1; /* Borrow */
\r
796 bl = (bl >> 1) | (bh << (NBITS-1));
\r
799 if( !DULT(al,ah,bl,bh) )
\r
805 M_PUSH( al ); /* rem */
\r
810 /* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */
\r
811 case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */
\r
813 register ucell_t ah,am,al,ql,qh,di;
\r
814 #define bdiv ((ucell_t)TOS)
\r
819 for( di=0; di<2*NBITS; di++ )
\r
826 qh = (qh << 1) | (ql >> (NBITS-1));
\r
828 ah = (ah << 1) | (am >> (NBITS-1));
\r
829 am = (am << 1) | (al >> (NBITS-1));
\r
831 DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
\r
838 M_PUSH( ah ); /* rem */
\r
845 #ifndef PF_NO_SHELL
\r
849 #endif /* !PF_NO_SHELL */
\r
856 TOS = gCurrentTask->td_StackBase - STKPTR;
\r
859 case ID_DIVIDE: BINARY_OP( / ); endcase;
\r
870 case ID_DROP: M_DROP; endcase;
\r
874 DumpMemory( (char *) Scratch, TOS );
\r
878 case ID_DUP: M_DUP; endcase;
\r
880 case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */
\r
886 case ID_EOL: /* ( -- end_of_line_char ) */
\r
888 TOS = (cell_t) '\n';
\r
891 case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */
\r
905 EMIT( (char) TOS );
\r
910 /* Save IP on return stack like a JSR. */
\r
911 M_R_PUSH( InsPtr );
\r
912 #ifdef PF_SUPPORT_TRACE
\r
913 /* Bump level for trace. */
\r
916 if( IsTokenPrimitive( TOS ) )
\r
918 WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */
\r
919 InsPtr = &FakeSecondary[0];
\r
923 InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);
\r
929 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
930 if( IN_DICS( TOS ) )
\r
932 TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);
\r
936 TOS = *((cell_t *)TOS);
\r
939 TOS = *((cell_t *)TOS);
\r
943 case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */
\r
944 /* Build NUL terminated name string. */
\r
945 Scratch = M_POP; /* u */
\r
946 Temp = M_POP; /* caddr */
\r
947 if( Scratch < TIB_SIZE-2 )
\r
949 const char *famText = pfSelectFileModeCreate( TOS );
\r
950 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
\r
951 gScratch[Scratch] = '\0';
\r
952 DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));
\r
953 FileID = sdOpenFile( gScratch, famText );
\r
954 TOS = ( FileID == NULL ) ? -1 : 0 ;
\r
955 M_PUSH( (cell_t) FileID );
\r
959 ERR("Filename too large for name buffer.\n");
\r
965 case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */
\r
966 /* Build NUL terminated name string. */
\r
967 Scratch = M_POP; /* u */
\r
968 Temp = M_POP; /* caddr */
\r
969 if( Scratch < TIB_SIZE-2 )
\r
971 const char *famText = pfSelectFileModeOpen( TOS );
\r
972 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
\r
973 gScratch[Scratch] = '\0';
\r
974 DBUG(("Open file = %s\n", gScratch ));
\r
975 FileID = sdOpenFile( gScratch, famText );
\r
977 TOS = ( FileID == NULL ) ? -1 : 0 ;
\r
978 M_PUSH( (cell_t) FileID );
\r
982 ERR("Filename too large for name buffer.\n");
\r
988 case ID_FILE_CLOSE: /* ( fid -- ior ) */
\r
989 TOS = sdCloseFile( (FileStream *) TOS );
\r
992 case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */
\r
993 FileID = (FileStream *) TOS;
\r
995 CharPtr = (char *) M_POP;
\r
996 Temp = sdReadFile( CharPtr, 1, Scratch, FileID );
\r
1001 case ID_FILE_SIZE: /* ( fid -- ud ior ) */
\r
1002 /* Determine file size by seeking to end and returning position. */
\r
1003 FileID = (FileStream *) TOS;
\r
1004 Scratch = sdTellFile( FileID );
\r
1005 sdSeekFile( FileID, 0, PF_SEEK_END );
\r
1006 M_PUSH( sdTellFile( FileID ));
\r
1007 sdSeekFile( FileID, Scratch, PF_SEEK_SET );
\r
1008 TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */
\r
1011 case ID_FILE_WRITE: /* ( addr len fid -- ior ) */
\r
1012 FileID = (FileStream *) TOS;
\r
1014 CharPtr = (char *) M_POP;
\r
1015 Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );
\r
1016 TOS = (Temp != Scratch) ? -3 : 0;
\r
1019 case ID_FILE_REPOSITION: /* ( pos fid -- ior ) */
\r
1020 FileID = (FileStream *) TOS;
\r
1022 TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET );
\r
1025 case ID_FILE_POSITION: /* ( pos fid -- ior ) */
\r
1026 M_PUSH( sdTellFile( (FileStream *) TOS ));
\r
1030 case ID_FILE_RO: /* ( -- fam ) */
\r
1032 TOS = PF_FAM_READ_ONLY;
\r
1035 case ID_FILE_RW: /* ( -- fam ) */
\r
1037 TOS = PF_FAM_READ_WRITE;
\r
1040 case ID_FILE_WO: /* ( -- fam ) */
\r
1042 TOS = PF_FAM_WRITE_ONLY;
\r
1045 case ID_FILE_BIN: /* ( -- fam ) */
\r
1046 TOS = TOS | PF_FAM_BINARY_FLAG;
\r
1049 case ID_FILL: /* ( caddr num charval -- ) */
\r
1051 register char *DstPtr;
\r
1052 Temp = M_POP; /* num */
\r
1053 DstPtr = (char *) M_POP; /* dst */
\r
1054 for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )
\r
1056 *DstPtr++ = (char) TOS;
\r
1062 #ifndef PF_NO_SHELL
\r
1063 case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */
\r
1064 TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
\r
1069 TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
\r
1070 M_PUSH( (cell_t) Temp );
\r
1072 #endif /* !PF_NO_SHELL */
\r
1074 case ID_FLUSHEMIT:
\r
1075 sdTerminalFlush();
\r
1078 /* Validate memory before freeing. Clobber validator and first word. */
\r
1079 case ID_FREE: /* ( addr -- result ) */
\r
1082 ERR("FREE passed NULL!\n");
\r
1083 TOS = -2; /* FIXME error code */
\r
1087 CellPtr = (cell_t *) TOS;
\r
1089 if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))
\r
1091 TOS = -2; /* FIXME error code */
\r
1095 CellPtr[0] = 0xDeadBeef;
\r
1096 pfFreeMem((char *)CellPtr);
\r
1102 #include "pfinnrfp.h"
\r
1106 TOS = (cell_t)CODE_HERE;
\r
1109 case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */
\r
1110 /* Convert using number converter in 'C'.
\r
1111 ** Only supports single precision for bootstrap.
\r
1113 TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );
\r
1114 if( TOS == NUM_TYPE_SINGLE)
\r
1116 M_PUSH( Temp ); /* Push single number */
\r
1120 case ID_I: /* ( -- i , DO LOOP index ) */
\r
1122 TOS = M_R_PICK(1);
\r
1125 #ifndef PF_NO_SHELL
\r
1126 case ID_INCLUDE_FILE:
\r
1127 FileID = (FileStream *) TOS;
\r
1128 M_DROP; /* Drop now so that INCLUDE has a clean stack. */
\r
1130 Scratch = ffIncludeFile( FileID );
\r
1132 if( Scratch ) M_THROW(Scratch)
\r
1134 #endif /* !PF_NO_SHELL */
\r
1136 #ifndef PF_NO_SHELL
\r
1137 case ID_INTERPRET:
\r
1139 Scratch = ffInterpret();
\r
1141 if( Scratch ) M_THROW(Scratch)
\r
1143 #endif /* !PF_NO_SHELL */
\r
1145 case ID_J: /* ( -- j , second DO LOOP index ) */
\r
1147 TOS = M_R_PICK(3);
\r
1155 #ifndef PF_NO_SHELL
\r
1160 #endif /* !PF_NO_SHELL */
\r
1162 case ID_LITERAL_P:
\r
1163 DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
\r
1165 TOS = READ_CELL_DIC(InsPtr++);
\r
1168 #ifndef PF_NO_SHELL
\r
1169 case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
\r
1170 #endif /* !PF_NO_SHELL */
\r
1172 case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
\r
1173 TOS = *(LocalsPtr - TOS);
\r
1176 #define LOCAL_FETCH_N(num) \
\r
1177 case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
\r
1179 TOS = *(LocalsPtr -(num)); \
\r
1191 case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */
\r
1192 *(LocalsPtr - TOS) = M_POP;
\r
1196 #define LOCAL_STORE_N(num) \
\r
1197 case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \
\r
1198 *(LocalsPtr - (num)) = TOS; \
\r
1211 case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */
\r
1212 *(LocalsPtr - TOS) += M_POP;
\r
1216 case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
\r
1217 /* create local stack frame */
\r
1221 DBUG(("LocalEntry: n = %d\n", TOS));
\r
1222 /* End of locals. Create stack frame */
\r
1223 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
\r
1224 TORPTR, LocalsPtr));
\r
1225 M_R_PUSH(LocalsPtr);
\r
1226 LocalsPtr = TORPTR;
\r
1228 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
\r
1229 TORPTR, LocalsPtr));
\r
1233 *lp++ = M_POP; /* Load local vars from stack */
\r
1239 case ID_LOCAL_EXIT: /* cleanup up local stack frame */
\r
1240 DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
\r
1241 TORPTR, LocalsPtr));
\r
1242 TORPTR = LocalsPtr;
\r
1243 LocalsPtr = (cell_t *) M_R_POP;
\r
1244 DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
\r
1245 TORPTR, LocalsPtr));
\r
1248 #ifndef PF_NO_SHELL
\r
1250 MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
\r
1251 FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
\r
1255 Scratch = ffIncludeFile( FileID );
\r
1257 sdCloseFile( FileID );
\r
1258 if( Scratch ) M_THROW(Scratch);
\r
1262 ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
\r
1265 #endif /* !PF_NO_SHELL */
\r
1267 case ID_LEAVE_P: /* ( R: index limit -- ) */
\r
1273 case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
\r
1274 Temp = M_R_POP; /* limit */
\r
1275 Scratch = M_R_POP + 1; /* index */
\r
1276 if( Scratch == Temp )
\r
1278 InsPtr++; /* skip branch offset, exit loop */
\r
1282 /* Push index and limit back to R */
\r
1283 M_R_PUSH( Scratch );
\r
1285 /* Branch back to just after (DO) */
\r
1290 case ID_LSHIFT: BINARY_OP( << ); endcase;
\r
1294 TOS = ( TOS > Scratch ) ? TOS : Scratch ;
\r
1299 TOS = ( TOS < Scratch ) ? TOS : Scratch ;
\r
1302 case ID_MINUS: BINARY_OP( - ); endcase;
\r
1304 #ifndef PF_NO_SHELL
\r
1305 case ID_NAME_TO_TOKEN:
\r
1306 TOS = (cell_t) NameToToken((ForthString *)TOS);
\r
1309 case ID_NAME_TO_PREVIOUS:
\r
1310 TOS = (cell_t) NameToPrevious((ForthString *)TOS);
\r
1317 case ID_OR: BINARY_OP( | ); endcase;
\r
1324 case ID_PICK: /* ( ... n -- sp(n) ) */
\r
1325 TOS = M_STACK(TOS);
\r
1328 case ID_PLUS: BINARY_OP( + ); endcase;
\r
1330 case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */
\r
1331 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1332 if( IN_DICS( TOS ) )
\r
1334 Scratch = READ_CELL_DIC((cell_t *)TOS);
\r
1336 WRITE_CELL_DIC((cell_t *)TOS,Scratch);
\r
1340 *((cell_t *)TOS) += M_POP;
\r
1343 *((cell_t *)TOS) += M_POP;
\r
1348 case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
\r
1350 ucell_t OldIndex, NewIndex, Limit;
\r
1353 OldIndex = M_R_POP;
\r
1354 NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */
\r
1355 /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
\r
1356 if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
\r
1357 ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
\r
1359 InsPtr++; /* skip branch offset, exit loop */
\r
1363 /* Push index and limit back to R */
\r
1364 M_R_PUSH( NewIndex );
\r
1365 M_R_PUSH( Limit );
\r
1366 /* Branch back to just after (DO) */
\r
1373 case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
\r
1374 Scratch = M_POP; /* limit */
\r
1375 if( Scratch == TOS )
\r
1377 /* Branch to just after (LOOP) */
\r
1383 M_R_PUSH( Scratch );
\r
1384 InsPtr++; /* skip branch offset, enter loop */
\r
1389 case ID_QDUP: if( TOS ) M_DUP; endcase;
\r
1391 case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */
\r
1393 TOS = sdQueryTerminal();
\r
1396 case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
\r
1397 #ifdef PF_SUPPORT_TRACE
\r
1400 M_THROW(THROW_QUIT);
\r
1409 TOS = (*(TORPTR));
\r
1419 TOS = (ffRefill() > 0) ? FTRUE : FFALSE;
\r
1422 /* Resize memory allocated by ALLOCATE. */
\r
1423 case ID_RESIZE: /* ( addr1 u -- addr2 result ) */
\r
1425 cell_t *Addr1 = (cell_t *) M_POP;
\r
1426 // Point to validator below users address.
\r
1427 cell_t *FreePtr = Addr1 - 1;
\r
1428 if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))
\r
1430 // 090218 - Fixed bug, was returning zero.
\r
1436 /* Try to allocate. */
\r
1437 CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );
\r
1440 /* Copy memory including validation. */
\r
1441 pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );
\r
1442 *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);
\r
1443 // 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub.
\r
1444 // Increment past validator to user address.
\r
1445 M_PUSH( (cell_t) (CellPtr + 1) );
\r
1446 TOS = 0; // Result code.
\r
1447 // Mark old cell as dead so we can't free it twice.
\r
1448 FreePtr[0] = 0xDeadBeef;
\r
1449 pfFreeMem((char *) FreePtr);
\r
1453 // 090218 - Fixed bug, was returning zero.
\r
1455 TOS = -4; /* FIXME Fix error code. */
\r
1462 ** RP@ and RP! are called secondaries so we must
\r
1463 ** account for the return address pushed before calling.
\r
1465 case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */
\r
1467 TOS = (cell_t)TORPTR; /* value before calling RP@ */
\r
1470 case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */
\r
1471 TORPTR = (cell_t *) TOS;
\r
1475 case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
\r
1478 cell_t *srcPtr, *dstPtr;
\r
1479 Scratch = M_STACK(TOS);
\r
1480 srcPtr = &M_STACK(TOS-1);
\r
1481 dstPtr = &M_STACK(TOS);
\r
1482 for( ri=0; ri<TOS; ri++ )
\r
1484 *dstPtr-- = *srcPtr--;
\r
1491 case ID_ROT: /* ( a b c -- b c a ) */
\r
1492 Scratch = M_POP; /* b */
\r
1493 Temp = M_POP; /* a */
\r
1494 M_PUSH( Scratch ); /* b */
\r
1496 TOS = Temp; /* a */
\r
1499 /* Logical right shift */
\r
1500 case ID_RSHIFT: { TOS = ((ucell_t)M_POP) >> TOS; } endcase;
\r
1502 #ifndef PF_NO_SHELL
\r
1503 case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */
\r
1505 cell_t NameSize, CodeSize, EntryPoint;
\r
1508 EntryPoint = M_POP;
\r
1509 ForthStringToC( gScratch, (char *) M_POP );
\r
1510 TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
\r
1516 ** EVALUATE >IN SourceID=(-1) 1111
\r
1517 ** keyboard >IN SourceID=(0) 2222
\r
1518 ** file >IN lineNumber filePos SourceID=(fileID)
\r
1520 case ID_SAVE_INPUT: /* FIXME - finish */
\r
1525 case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */
\r
1527 TOS = (cell_t)STKPTR;
\r
1530 case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */
\r
1531 STKPTR = (cell_t *) TOS;
\r
1535 case ID_STORE: /* ( n addr -- , write n to addr ) */
\r
1536 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1537 if( IN_DICS( TOS ) )
\r
1539 WRITE_CELL_DIC((cell_t *)TOS,M_POP);
\r
1543 *((cell_t *)TOS) = M_POP;
\r
1546 *((cell_t *)TOS) = M_POP;
\r
1551 case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
\r
1552 Scratch = M_POP; /* cnt */
\r
1553 Temp = M_POP; /* addr */
\r
1554 TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
\r
1555 M_PUSH((cell_t) CharPtr);
\r
1558 #ifndef PF_NO_SHELL
\r
1559 case ID_SEMICOLON:
\r
1561 Scratch = ffSemiColon();
\r
1563 if( Scratch ) M_THROW( Scratch );
\r
1565 #endif /* !PF_NO_SHELL */
\r
1567 case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
\r
1568 Scratch = M_POP; /* cnt */
\r
1569 Temp = M_POP; /* addr */
\r
1570 TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
\r
1571 M_PUSH((cell_t) CharPtr);
\r
1574 case ID_SOURCE: /* ( -- c-addr num ) */
\r
1576 M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );
\r
1577 TOS = (cell_t) gCurrentTask->td_SourceNum;
\r
1580 case ID_SOURCE_SET: /* ( c-addr num -- ) */
\r
1581 gCurrentTask->td_SourcePtr = (char *) M_POP;
\r
1582 gCurrentTask->td_SourceNum = TOS;
\r
1586 case ID_SOURCE_ID:
\r
1588 TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
\r
1591 case ID_SOURCE_ID_POP:
\r
1593 TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
\r
1596 case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */
\r
1597 TOS = (cell_t)ffConvertSourceIDToStream( TOS );
\r
1598 Scratch = ffPushInputStream((FileStream *) TOS );
\r
1609 *STKPTR = Scratch;
\r
1622 case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
\r
1630 #ifndef PF_NO_SHELL
\r
1633 CharPtr = (char *) ffWord( (char) ' ' );
\r
1634 TOS = ffFind( CharPtr, (ExecToken *) &Temp );
\r
1637 ERR("' could not find ");
\r
1638 ioType( (char *) CharPtr+1, *CharPtr );
\r
1646 #endif /* !PF_NO_SHELL */
\r
1648 case ID_TIMES: BINARY_OP( * ); endcase;
\r
1651 Scratch = M_POP; /* addr */
\r
1652 ioType( (char *) Scratch, TOS );
\r
1661 case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
\r
1662 case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
\r
1663 case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
\r
1664 case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
\r
1665 case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
\r
1666 case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
\r
1667 case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
\r
1668 case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
\r
1669 case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;
\r
1670 case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
\r
1671 case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
\r
1672 case ID_VAR_STATE: DO_VAR(gVarState); endcase;
\r
1673 case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
\r
1674 case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
\r
1675 case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
\r
1676 case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
\r
1677 case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
\r
1680 TOS = (cell_t) ffWord( (char) TOS );
\r
1683 case ID_WORD_FETCH: /* ( waddr -- w ) */
\r
1684 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1685 if( IN_DICS( TOS ) )
\r
1687 TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);
\r
1691 TOS = *((uint16_t *)TOS);
\r
1694 TOS = *((uint16_t *)TOS);
\r
1698 case ID_WORD_STORE: /* ( w waddr -- ) */
\r
1700 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1701 if( IN_DICS( TOS ) )
\r
1703 WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);
\r
1707 *((uint16_t *)TOS) = (uint16_t) M_POP;
\r
1710 *((uint16_t *)TOS) = (uint16_t) M_POP;
\r
1715 case ID_XOR: BINARY_OP( ^ ); endcase;
\r
1718 /* Branch is followed by an offset relative to address of offset. */
\r
1719 case ID_ZERO_BRANCH:
\r
1720 DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
\r
1727 InsPtr++; /* skip over offset */
\r
1730 DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
\r
1734 ERR("pfCatch: Unrecognised token = 0x");
\r
1737 ffDotHex((cell_t) InsPtr);
\r
1743 if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */
\r
1750 if( _CrtCheckMemory() == 0 )
\r
1752 ERR("_CrtCheckMemory abort: InsPtr = 0x");
\r
1753 ffDotHex((int)InsPtr);
\r
1758 } while( (InitialReturnStack - TORPTR) > 0 );
\r
1762 return ExceptionReturnCode;
\r