1 /* @(#) pf_inner.c 98/03/16 1.7 */
2 /***************************************************************
3 ** Inner Interpreter for Forth based on 'C'
6 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
8 ** The pForth software code is dedicated to the public domain,
9 ** and any third party may reproduce, distribute and modify
10 ** the pForth software code or any derivative works thereof
11 ** without any compensation or license. The pForth software
12 ** code is provided on an "as is" basis without any warranty
13 ** of any kind, including, without limitation, the implied
14 ** warranties of merchantability and fitness for a particular
15 ** purpose and their equivalents under the laws of any jurisdiction.
17 ****************************************************************
19 ** 940502 PLB Creation.
20 ** 940505 PLB More macros.
21 ** 940509 PLB Moved all stack stuff into pfCatch.
22 ** 941014 PLB Converted to flat secondary strusture.
23 ** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH,
24 ** and ID_HERE for armcc
25 ** 941130 PLB Made w@ unsigned
27 ***************************************************************/
30 #include <sys/types.h>
37 #if defined(WIN32) && !defined(__MINGW32__)
41 #define SYSTEM_LOAD_FILE "system.fth"
43 /***************************************************************
44 ** Macros for data stack access.
45 ** TOS is cached in a register in pfCatch.
46 ***************************************************************/
48 #define STKPTR (DataStackPtr)
49 #define M_POP (*(STKPTR++))
50 #define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);}
51 #define M_STACK(n) (STKPTR[n])
53 #define TOS (TopOfStack)
54 #define PUSH_TOS M_PUSH(TOS)
55 #define M_DUP PUSH_TOS;
56 #define M_DROP { TOS = M_POP; }
59 /***************************************************************
60 ** Macros for Floating Point stack access.
61 ***************************************************************/
63 #define FP_STKPTR (FloatStackPtr)
64 #define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)
65 #define M_FP_POP (*(FP_STKPTR++))
66 #define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}
67 #define M_FP_STACK(n) (FP_STKPTR[n])
69 #define FP_TOS (fpTopOfStack)
70 #define PUSH_FP_TOS M_FP_PUSH(FP_TOS)
71 #define M_FP_DUP PUSH_FP_TOS;
72 #define M_FP_DROP { FP_TOS = M_FP_POP; }
75 /***************************************************************
76 ** Macros for return stack access.
77 ***************************************************************/
79 #define TORPTR (ReturnStackPtr)
80 #define M_R_DROP {TORPTR++;}
81 #define M_R_POP (*(TORPTR++))
82 #define M_R_PICK(n) (TORPTR[n])
83 #define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);}
85 /***************************************************************
87 ***************************************************************/
89 #define M_BRANCH { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); }
91 /* Cache top of data stack like in JForth. */
93 #define LOAD_REGISTERS \
95 STKPTR = gCurrentTask->td_StackPtr; \
97 FP_STKPTR = gCurrentTask->td_FloatStackPtr; \
99 TORPTR = gCurrentTask->td_ReturnPtr; \
102 #define SAVE_REGISTERS \
104 gCurrentTask->td_ReturnPtr = TORPTR; \
106 gCurrentTask->td_StackPtr = STKPTR; \
107 M_FP_PUSH( FP_TOS ); \
108 gCurrentTask->td_FloatStackPtr = FP_STKPTR; \
112 /* Cache top of data stack like in JForth. */
113 #define LOAD_REGISTERS \
115 STKPTR = gCurrentTask->td_StackPtr; \
117 TORPTR = gCurrentTask->td_ReturnPtr; \
120 #define SAVE_REGISTERS \
122 gCurrentTask->td_ReturnPtr = TORPTR; \
124 gCurrentTask->td_StackPtr = STKPTR; \
133 #define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; }
136 #define M_THROW(err) \
138 ExceptionReturnCode = (ThrowCode)(err); \
139 TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
140 STKPTR = InitialDataStack; \
141 FP_STKPTR = InitialFloatStack; \
144 #define M_THROW(err) \
146 ExceptionReturnCode = (err); \
147 TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
148 STKPTR = InitialDataStack; \
152 /***************************************************************
154 ***************************************************************/
156 #define BINARY_OP( op ) { TOS = M_POP op TOS; }
157 #define endcase break
159 #if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)
160 #define TRACENAMES /* no names */
162 /* Display name of executing routine. */
163 static void TraceNames( ExecToken Token, cell_t Level )
168 if( ffTokenToName( Token, &DebugName ) )
171 if( gCurrentTask->td_OUT > 0 ) EMIT_CR;
173 for( i=0; i<Level; i++ )
177 TypeName( DebugName );
178 /* Space out to column N then .S */
179 NumSpaces = 30 - gCurrentTask->td_OUT;
180 for( i=0; i < NumSpaces; i++ )
185 /* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */
190 MSG_NUM_H("Couldn't find Name for ", Token);
195 if( (gVarTraceLevel > Level) ) \
196 { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }
197 #endif /* PF_NO_SHELL */
199 /* Use local copy of CODE_BASE for speed. */
200 #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))
202 static const char *pfSelectFileModeCreate( int fam );
203 static const char *pfSelectFileModeOpen( int fam );
205 /**************************************************************/
206 static const char *pfSelectFileModeCreate( int fam )
208 const char *famText = NULL;
211 case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
212 famText = PF_FAM_BIN_CREATE_WO;
214 case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
215 famText = PF_FAM_BIN_CREATE_RW;
217 case PF_FAM_WRITE_ONLY:
218 famText = PF_FAM_CREATE_WO;
220 case PF_FAM_READ_WRITE:
221 famText = PF_FAM_CREATE_RW;
230 /**************************************************************/
231 static const char *pfSelectFileModeOpen( int fam )
233 const char *famText = NULL;
236 case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG):
237 famText = PF_FAM_BIN_OPEN_RO;
239 case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG):
240 famText = PF_FAM_BIN_CREATE_WO;
242 case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG):
243 famText = PF_FAM_BIN_OPEN_RW;
245 case PF_FAM_READ_ONLY:
246 famText = PF_FAM_OPEN_RO;
248 case PF_FAM_WRITE_ONLY:
249 famText = PF_FAM_CREATE_WO;
251 case PF_FAM_READ_WRITE:
253 famText = PF_FAM_OPEN_RW;
259 /**************************************************************/
260 int pfCatch( ExecToken XT )
262 register cell_t TopOfStack; /* Cache for faster execution. */
263 register cell_t *DataStackPtr;
264 register cell_t *ReturnStackPtr;
265 register cell_t *InsPtr = NULL;
266 register cell_t Token;
270 PF_FLOAT fpTopOfStack;
271 PF_FLOAT *FloatStackPtr;
274 PF_FLOAT *InitialFloatStack;
276 #ifdef PF_SUPPORT_TRACE
279 cell_t *LocalsPtr = NULL;
281 cell_t *InitialReturnStack;
282 cell_t *InitialDataStack;
283 cell_t FakeSecondary[2];
287 uint8_t *CodeBase = (uint8_t *) CODE_BASE;
288 ThrowCode ExceptionReturnCode = 0;
291 gExecutionDepth += 1;
292 PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth ));
296 ** Initialize FakeSecondary this way to avoid having stuff in the data section,
297 ** which is not supported for some embedded system loaders.
299 FakeSecondary[0] = 0;
300 FakeSecondary[1] = ID_EXIT; /* For EXECUTE */
302 /* Move data from task structure to registers for speed. */
305 /* Save initial stack depths for THROW */
306 InitialReturnStack = TORPTR;
307 InitialDataStack = STKPTR ;
309 InitialFloatStack = FP_STKPTR;
316 DBUG(("pfCatch: Token = 0x%x\n", Token ));
318 /* --------------------------------------------------------------- */
319 /* If secondary, thread down code tree until we hit a primitive. */
320 while( !IsTokenPrimitive( Token ) )
322 #ifdef PF_SUPPORT_TRACE
323 if((gVarTraceFlags & TRACE_INNER) )
325 MSG("pfCatch: Secondary Token = 0x");
327 MSG_NUM_H(", InsPtr = 0x", InsPtr);
332 /* Save IP on return stack like a JSR. */
335 /* Convert execution token to absolute address. */
336 InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) );
338 /* Fetch token at IP. */
339 Token = READ_CELL_DIC(InsPtr++);
341 #ifdef PF_SUPPORT_TRACE
342 /* Bump level for trace display */
348 #ifdef PF_SUPPORT_TRACE
352 /* Execute primitive Token. */
356 /* Pop up a level in Forth inner interpreter.
357 ** Used to implement semicolon.
358 ** Put first in switch because ID_EXIT==0 */
360 InsPtr = ( cell_t *) M_R_POP;
361 #ifdef PF_SUPPORT_TRACE
366 case ID_1MINUS: TOS--; endcase;
368 case ID_1PLUS: TOS++; endcase;
372 ff2Literal( TOS, M_POP );
375 #endif /* !PF_NO_SHELL */
378 /* hi part stored first, put on top of stack */
380 TOS = READ_CELL_DIC(InsPtr++);
381 M_PUSH(READ_CELL_DIC(InsPtr++));
384 case ID_2MINUS: TOS -= 2; endcase;
386 case ID_2PLUS: TOS += 2; endcase;
389 case ID_2OVER: /* ( a b c d -- a b c d a b ) */
391 Scratch = M_STACK(3);
396 case ID_2SWAP: /* ( a b c d -- c d a b ) */
397 Scratch = M_STACK(0); /* c */
398 M_STACK(0) = M_STACK(2); /* a */
399 M_STACK(2) = Scratch; /* c */
400 Scratch = TOS; /* d */
401 TOS = M_STACK(1); /* b */
402 M_STACK(1) = Scratch; /* d */
405 case ID_2DUP: /* ( a b -- a b a b ) */
407 Scratch = M_STACK(1);
413 M_PUSH( (*(TORPTR+1)) );
429 case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */
430 CharPtr = (char *) M_POP;
431 TOS = ioAccept( CharPtr, TOS );
436 ffALiteral( ABS_TO_CODEREL(TOS) );
439 #endif /* !PF_NO_SHELL */
443 TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) );
446 /* Allocate some extra and put validation identifier at base */
447 #define PF_MEMORY_VALIDATOR (0xA81B4D69)
449 /* Allocate at least one cell's worth because we clobber first cell. */
450 if ( TOS < sizeof(cell_t) )
452 Temp = sizeof(cell_t);
458 /* Allocate extra cells worth because we store validation info. */
459 CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) );
462 /* This was broken into two steps because different compilers incremented
463 ** CellPtr before or after the XOR step. */
464 Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR;
466 M_PUSH( (cell_t) CellPtr );
472 TOS = -1; /* FIXME Fix error code. */
476 case ID_AND: BINARY_OP( & ); endcase;
478 case ID_ARSHIFT: BINARY_OP( >> ); endcase; /* Arithmetic right shift */
482 TOS = CREATE_BODY_OFFSET;
485 /* Branch is followed by an offset relative to address of offset. */
487 DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));
489 DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
493 M_THROW( THROW_BYE );
497 MSG("Emergency exit.\n");
505 Scratch = pfCatch( Scratch );
513 Scratch = READ_CELL_DIC(InsPtr++);
514 CallUserFunction( Scratch & 0xFFFF,
516 (Scratch >> 24) & 0x7F );
520 /* Support 32/64 bit operation. */
523 TOS = sizeof(cell_t);
527 TOS = TOS * sizeof(cell_t);
530 case ID_CFETCH: TOS = *((uint8_t *) TOS); endcase;
532 case ID_CMOVE: /* ( src dst n -- ) */
534 register char *DstPtr = (char *) M_POP; /* dst */
535 CharPtr = (char *) M_POP; /* src */
536 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
538 *DstPtr++ = *CharPtr++;
544 case ID_CMOVE_UP: /* ( src dst n -- ) */
546 register char *DstPtr = ((char *) M_POP) + TOS; /* dst */
547 CharPtr = ((char *) M_POP) + TOS;; /* src */
548 for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )
550 *(--DstPtr) = *(--CharPtr);
562 case ID_COLON_P: /* ( $name xt -- ) */
563 CreateDicEntry( TOS, (char *) M_POP, 0 );
566 #endif /* !PF_NO_SHELL */
572 s2 = (const char *) M_POP;
574 s1 = (const char *) M_POP;
575 TOS = ffCompare( s1, len1, s2, TOS );
579 /* ( a b -- flag , Comparisons ) */
581 TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;
583 case ID_COMP_NOT_EQUAL:
584 TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;
586 case ID_COMP_GREATERTHAN:
587 TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;
589 case ID_COMP_LESSTHAN:
590 TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ;
592 case ID_COMP_U_GREATERTHAN:
593 TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
595 case ID_COMP_U_LESSTHAN:
596 TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;
598 case ID_COMP_ZERO_EQUAL:
599 TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;
601 case ID_COMP_ZERO_NOT_EQUAL:
602 TOS = ( TOS != 0 ) ? FTRUE : FALSE ;
604 case ID_COMP_ZERO_GREATERTHAN:
605 TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;
607 case ID_COMP_ZERO_LESSTHAN:
608 TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;
621 #endif /* !PF_NO_SHELL */
625 /* Put address of body on stack. Insptr points after code start. */
626 TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );
629 case ID_CSTORE: /* ( c caddr -- ) */
630 *((uint8_t *) TOS) = (uint8_t) M_POP;
634 /* Double precision add. */
635 case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */
637 register ucell_t ah,al,bl,sh,sl;
644 if( sl < bl ) sh = 1; /* Carry */
652 /* Double precision subtract. */
653 case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */
655 register ucell_t ah,al,bl,sh,sl;
662 if( al < bl ) sh = 1; /* Borrow */
670 /* Assume 8-bit char and calculate cell width. */
671 #define NBITS ((sizeof(ucell_t)) * 8)
672 /* Define half the number of bits in a cell. */
673 #define HNBITS (NBITS / 2)
674 /* Assume two-complement arithmetic to calculate lower half. */
675 #define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))
676 #define HIGH_BIT ((ucell_t)1 << (NBITS - 1))
678 /* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.
679 * Using an improved algorithm suggested by Steve Green.
680 * Converted to 64-bit by Aleksej Saushev.
682 case ID_D_UMTIMES: /* UM* ( a b -- lo hi ) */
684 ucell_t ahi, alo, bhi, blo; /* input parts */
685 ucell_t lo, hi, temp;
686 /* Get values from stack. */
689 /* Break into hi and lo 16 bit parts. */
690 alo = LOWER_HALF(ahi);
692 blo = LOWER_HALF(bhi);
697 /* higher part: ahi * bhi */
699 /* middle (overlapping) part: ahi * blo */
701 lo += LOWER_HALF(temp);
702 hi += temp >> HNBITS;
703 /* middle (overlapping) part: alo * bhi */
705 lo += LOWER_HALF(temp);
706 hi += temp >> HNBITS;
707 /* lower part: alo * blo */
709 /* its higher half overlaps with middle's lower half: */
710 lo += temp >> HNBITS;
714 /* combine lower part of result: */
715 lo = (lo << HNBITS) + LOWER_HALF(temp);
722 /* Perform cell*cell bit multiply for 2 cell result, using shift and add. */
723 case ID_D_MTIMES: /* M* ( a b -- pl ph ) */
725 ucell_t ahi, alo, bhi, blo; /* input parts */
726 ucell_t lo, hi, temp;
728 /* Get values from stack. */
732 /* Calculate product sign: */
733 sg = ((cell_t)(ahi ^ bhi) < 0);
734 /* Take absolute values and reduce to um* */
735 if ((cell_t)ahi < 0) ahi = (ucell_t)(-ahi);
736 if ((cell_t)bhi < 0) bhi = (ucell_t)(-bhi);
738 /* Break into hi and lo 16 bit parts. */
739 alo = LOWER_HALF(ahi);
741 blo = LOWER_HALF(bhi);
746 /* higher part: ahi * bhi */
748 /* middle (overlapping) part: ahi * blo */
750 lo += LOWER_HALF(temp);
751 hi += temp >> HNBITS;
752 /* middle (overlapping) part: alo * bhi */
754 lo += LOWER_HALF(temp);
755 hi += temp >> HNBITS;
756 /* lower part: alo * blo */
758 /* its higher half overlaps with middle's lower half: */
759 lo += temp >> HNBITS;
763 /* combine lower part of result: */
764 lo = (lo << HNBITS) + LOWER_HALF(temp);
766 /* Negate product if one operand negative. */
769 /* lo = (ucell_t)(- lo); */
771 hi = ~hi + ((lo == 0) ? 1 : 0);
779 #define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
780 /* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */
781 case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */
783 ucell_t ah,al, q,di, bl,bh, sl,sh;
789 for( di=0; di<NBITS; di++ )
791 if( !DULT(al,ah,bl,bh) )
795 if( al < bl ) sh = 1; /* Borrow */
802 bl = (bl >> 1) | (bh << (NBITS-1));
805 if( !DULT(al,ah,bl,bh) )
811 M_PUSH( al ); /* rem */
816 /* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */
817 case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */
819 register ucell_t ah,am,al,ql,qh,di;
820 #define bdiv ((ucell_t)TOS)
825 for( di=0; di<2*NBITS; di++ )
832 qh = (qh << 1) | (ql >> (NBITS-1));
834 ah = (ah << 1) | (am >> (NBITS-1));
835 am = (am << 1) | (al >> (NBITS-1));
837 DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
844 M_PUSH( ah ); /* rem */
855 #endif /* !PF_NO_SHELL */
862 TOS = gCurrentTask->td_StackBase - STKPTR;
865 case ID_DIVIDE: BINARY_OP( / ); endcase;
876 case ID_DROP: M_DROP; endcase;
880 DumpMemory( (char *) Scratch, TOS );
884 case ID_DUP: M_DUP; endcase;
886 case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */
892 case ID_EOL: /* ( -- end_of_line_char ) */
897 case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */
916 /* Save IP on return stack like a JSR. */
918 #ifdef PF_SUPPORT_TRACE
919 /* Bump level for trace. */
922 if( IsTokenPrimitive( TOS ) )
924 WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */
925 InsPtr = &FakeSecondary[0];
929 InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);
935 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
938 TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);
942 TOS = *((cell_t *)TOS);
945 TOS = *((cell_t *)TOS);
949 case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */
950 /* Build NUL terminated name string. */
951 Scratch = M_POP; /* u */
952 Temp = M_POP; /* caddr */
953 if( Scratch < TIB_SIZE-2 )
955 const char *famText = pfSelectFileModeCreate( TOS );
956 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
957 gScratch[Scratch] = '\0';
958 DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));
959 FileID = sdOpenFile( gScratch, famText );
960 TOS = ( FileID == NULL ) ? -1 : 0 ;
961 M_PUSH( (cell_t) FileID );
965 ERR("Filename too large for name buffer.\n");
971 case ID_FILE_DELETE: /* ( c-addr u -- ior ) */
972 /* Build NUL terminated name string. */
973 Temp = M_POP; /* caddr */
974 if( TOS < TIB_SIZE-2 )
976 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS );
977 gScratch[TOS] = '\0';
978 DBUG(("Delete file = %s\n", gScratch ));
979 TOS = sdDeleteFile( gScratch );
983 ERR("Filename too large for name buffer.\n");
988 case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */
989 /* Build NUL terminated name string. */
990 Scratch = M_POP; /* u */
991 Temp = M_POP; /* caddr */
992 if( Scratch < TIB_SIZE-2 )
994 const char *famText = pfSelectFileModeOpen( TOS );
995 pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );
996 gScratch[Scratch] = '\0';
997 DBUG(("Open file = %s\n", gScratch ));
998 FileID = sdOpenFile( gScratch, famText );
1000 TOS = ( FileID == NULL ) ? -1 : 0 ;
1001 M_PUSH( (cell_t) FileID );
1005 ERR("Filename too large for name buffer.\n");
1011 case ID_FILE_CLOSE: /* ( fid -- ior ) */
1012 TOS = sdCloseFile( (FileStream *) TOS );
1015 case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */
1016 FileID = (FileStream *) TOS;
1018 CharPtr = (char *) M_POP;
1019 Temp = sdReadFile( CharPtr, 1, Scratch, FileID );
1024 case ID_FILE_SIZE: /* ( fid -- ud ior ) */
1025 /* Determine file size by seeking to end and returning position. */
1026 FileID = (FileStream *) TOS;
1028 off_t endposition, offsetHi;
1029 off_t original = sdTellFile( FileID );
1030 sdSeekFile( FileID, 0, PF_SEEK_END );
1031 endposition = sdTellFile( FileID );
1032 M_PUSH(endposition);
1033 /* Just use a 0 if they are the same size. */
1034 offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (endposition >> (8*sizeof(cell_t))) : 0 ;
1036 sdSeekFile( FileID, original, PF_SEEK_SET );
1037 TOS = (original < 0) ? -4 : 0 ; /* !!! err num */
1041 case ID_FILE_WRITE: /* ( addr len fid -- ior ) */
1042 FileID = (FileStream *) TOS;
1044 CharPtr = (char *) M_POP;
1045 Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );
1046 TOS = (Temp != Scratch) ? -3 : 0;
1049 case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */
1052 FileID = (FileStream *) TOS;
1054 /* Avoid compiler warnings on Mac. */
1055 offset = (sizeof(off_t) > sizeof(cell_t)) ? (offset << 8*sizeof(cell_t)) : 0 ;
1057 TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );
1061 case ID_FILE_POSITION: /* ( fid -- ud ior ) */
1065 FileID = (FileStream *) TOS;
1066 position = sdTellFile( FileID );
1068 /* Just use a 0 if they are the same size. */
1069 offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (position >> (8*sizeof(cell_t))) : 0 ;
1071 TOS = (position < 0) ? -4 : 0 ; /* !!! err num */
1075 case ID_FILE_RO: /* ( -- fam ) */
1077 TOS = PF_FAM_READ_ONLY;
1080 case ID_FILE_RW: /* ( -- fam ) */
1082 TOS = PF_FAM_READ_WRITE;
1085 case ID_FILE_WO: /* ( -- fam ) */
1087 TOS = PF_FAM_WRITE_ONLY;
1090 case ID_FILE_BIN: /* ( -- fam ) */
1091 TOS = TOS | PF_FAM_BINARY_FLAG;
1094 case ID_FILL: /* ( caddr num charval -- ) */
1096 register char *DstPtr;
1097 Temp = M_POP; /* num */
1098 DstPtr = (char *) M_POP; /* dst */
1099 for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )
1101 *DstPtr++ = (char) TOS;
1108 case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */
1109 TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
1114 TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
1115 M_PUSH( (cell_t) Temp );
1117 #endif /* !PF_NO_SHELL */
1123 /* Validate memory before freeing. Clobber validator and first word. */
1124 case ID_FREE: /* ( addr -- result ) */
1127 ERR("FREE passed NULL!\n");
1128 TOS = -2; /* FIXME error code */
1132 CellPtr = (cell_t *) TOS;
1134 if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))
1136 TOS = -2; /* FIXME error code */
1140 CellPtr[0] = 0xDeadBeef;
1141 pfFreeMem((char *)CellPtr);
1147 #include "pfinnrfp.h"
1151 TOS = (cell_t)CODE_HERE;
1154 case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */
1155 /* Convert using number converter in 'C'.
1156 ** Only supports single precision for bootstrap.
1158 TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );
1159 if( TOS == NUM_TYPE_SINGLE)
1161 M_PUSH( Temp ); /* Push single number */
1165 case ID_I: /* ( -- i , DO LOOP index ) */
1171 case ID_INCLUDE_FILE:
1172 FileID = (FileStream *) TOS;
1173 M_DROP; /* Drop now so that INCLUDE has a clean stack. */
1175 Scratch = ffIncludeFile( FileID );
1177 if( Scratch ) M_THROW(Scratch)
1179 #endif /* !PF_NO_SHELL */
1184 Scratch = ffInterpret();
1186 if( Scratch ) M_THROW(Scratch)
1188 #endif /* !PF_NO_SHELL */
1190 case ID_J: /* ( -- j , second DO LOOP index ) */
1205 #endif /* !PF_NO_SHELL */
1208 DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
1210 TOS = READ_CELL_DIC(InsPtr++);
1214 case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
1215 #endif /* !PF_NO_SHELL */
1217 case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
1218 TOS = *(LocalsPtr - TOS);
1221 #define LOCAL_FETCH_N(num) \
1222 case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
1224 TOS = *(LocalsPtr -(num)); \
1236 case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */
1237 *(LocalsPtr - TOS) = M_POP;
1241 #define LOCAL_STORE_N(num) \
1242 case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \
1243 *(LocalsPtr - (num)) = TOS; \
1256 case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */
1257 *(LocalsPtr - TOS) += M_POP;
1261 case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
1262 /* create local stack frame */
1266 DBUG(("LocalEntry: n = %d\n", TOS));
1267 /* End of locals. Create stack frame */
1268 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
1269 TORPTR, LocalsPtr));
1270 M_R_PUSH(LocalsPtr);
1273 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
1274 TORPTR, LocalsPtr));
1278 *lp++ = M_POP; /* Load local vars from stack */
1284 case ID_LOCAL_EXIT: /* cleanup up local stack frame */
1285 DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
1286 TORPTR, LocalsPtr));
1288 LocalsPtr = (cell_t *) M_R_POP;
1289 DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
1290 TORPTR, LocalsPtr));
1295 MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
1296 FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
1300 Scratch = ffIncludeFile( FileID ); /* Also closes the file. */
1302 if( Scratch ) M_THROW(Scratch);
1306 ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
1309 #endif /* !PF_NO_SHELL */
1311 case ID_LEAVE_P: /* ( R: index limit -- ) */
1317 case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
1318 Temp = M_R_POP; /* limit */
1319 Scratch = M_R_POP + 1; /* index */
1320 if( Scratch == Temp )
1322 InsPtr++; /* skip branch offset, exit loop */
1326 /* Push index and limit back to R */
1327 M_R_PUSH( Scratch );
1329 /* Branch back to just after (DO) */
1334 case ID_LSHIFT: BINARY_OP( << ); endcase;
1338 TOS = ( TOS > Scratch ) ? TOS : Scratch ;
1343 TOS = ( TOS < Scratch ) ? TOS : Scratch ;
1346 case ID_MINUS: BINARY_OP( - ); endcase;
1349 case ID_NAME_TO_TOKEN:
1350 TOS = (cell_t) NameToToken((ForthString *)TOS);
1353 case ID_NAME_TO_PREVIOUS:
1354 TOS = (cell_t) NameToPrevious((ForthString *)TOS);
1361 case ID_OR: BINARY_OP( | ); endcase;
1368 case ID_PICK: /* ( ... n -- sp(n) ) */
1372 case ID_PLUS: BINARY_OP( + ); endcase;
1374 case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */
1375 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1376 if( IN_DICS( TOS ) )
1378 Scratch = READ_CELL_DIC((cell_t *)TOS);
1380 WRITE_CELL_DIC((cell_t *)TOS,Scratch);
1384 *((cell_t *)TOS) += M_POP;
1387 *((cell_t *)TOS) += M_POP;
1392 case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
1394 cell_t Limit = M_R_POP;
1395 cell_t OldIndex = M_R_POP;
1396 cell_t Delta = TOS; /* add TOS to index, not 1 */
1397 cell_t NewIndex = OldIndex + Delta;
1398 cell_t OldDiff = OldIndex - Limit;
1400 /* This exploits this idea (lifted from Gforth):
1401 (x^y)<0 is equivalent to (x<0) != (y<0) */
1402 if( ((OldDiff ^ (OldDiff + Delta)) /* is the limit crossed? */
1403 & (OldDiff ^ Delta)) /* is it a wrap-around? */
1406 InsPtr++; /* skip branch offset, exit loop */
1410 /* Push index and limit back to R */
1411 M_R_PUSH( NewIndex );
1413 /* Branch back to just after (DO) */
1420 case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
1421 Scratch = M_POP; /* limit */
1422 if( Scratch == TOS )
1424 /* Branch to just after (LOOP) */
1430 M_R_PUSH( Scratch );
1431 InsPtr++; /* skip branch offset, enter loop */
1436 case ID_QDUP: if( TOS ) M_DUP; endcase;
1438 case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */
1440 TOS = sdQueryTerminal();
1443 case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
1444 #ifdef PF_SUPPORT_TRACE
1447 M_THROW(THROW_QUIT);
1466 TOS = (ffRefill() > 0) ? FTRUE : FFALSE;
1469 /* Resize memory allocated by ALLOCATE. */
1470 case ID_RESIZE: /* ( addr1 u -- addr2 result ) */
1472 cell_t *Addr1 = (cell_t *) M_POP;
1473 /* Point to validator below users address. */
1474 cell_t *FreePtr = Addr1 - 1;
1475 if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))
1477 /* 090218 - Fixed bug, was returning zero. */
1483 /* Try to allocate. */
1484 CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );
1487 /* Copy memory including validation. */
1488 pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );
1489 *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);
1490 /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */
1491 /* Increment past validator to user address. */
1492 M_PUSH( (cell_t) (CellPtr + 1) );
1493 TOS = 0; /* Result code. */
1494 /* Mark old cell as dead so we can't free it twice. */
1495 FreePtr[0] = 0xDeadBeef;
1496 pfFreeMem((char *) FreePtr);
1500 /* 090218 - Fixed bug, was returning zero. */
1502 TOS = -4; /* FIXME Fix error code. */
1509 ** RP@ and RP! are called secondaries so we must
1510 ** account for the return address pushed before calling.
1512 case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */
1514 TOS = (cell_t)TORPTR; /* value before calling RP@ */
1517 case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */
1518 TORPTR = (cell_t *) TOS;
1522 case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
1525 cell_t *srcPtr, *dstPtr;
1526 Scratch = M_STACK(TOS);
1527 srcPtr = &M_STACK(TOS-1);
1528 dstPtr = &M_STACK(TOS);
1529 for( ri=0; ri<TOS; ri++ )
1531 *dstPtr-- = *srcPtr--;
1538 case ID_ROT: /* ( a b c -- b c a ) */
1539 Scratch = M_POP; /* b */
1540 Temp = M_POP; /* a */
1541 M_PUSH( Scratch ); /* b */
1546 /* Logical right shift */
1547 case ID_RSHIFT: { TOS = ((ucell_t)M_POP) >> TOS; } endcase;
1550 case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */
1552 cell_t NameSize, CodeSize, EntryPoint;
1556 ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );
1557 TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
1563 ** EVALUATE >IN SourceID=(-1) 1111
1564 ** keyboard >IN SourceID=(0) 2222
1565 ** file >IN lineNumber filePos SourceID=(fileID)
1567 case ID_SAVE_INPUT: /* FIXME - finish */
1572 case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */
1574 TOS = (cell_t)STKPTR;
1577 case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */
1578 STKPTR = (cell_t *) TOS;
1582 case ID_STORE: /* ( n addr -- , write n to addr ) */
1583 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1584 if( IN_DICS( TOS ) )
1586 WRITE_CELL_DIC((cell_t *)TOS,M_POP);
1590 *((cell_t *)TOS) = M_POP;
1593 *((cell_t *)TOS) = M_POP;
1598 case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
1599 Scratch = M_POP; /* cnt */
1600 Temp = M_POP; /* addr */
1601 TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1602 M_PUSH((cell_t) CharPtr);
1608 Scratch = ffSemiColon();
1610 if( Scratch ) M_THROW( Scratch );
1612 #endif /* !PF_NO_SHELL */
1614 case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
1615 Scratch = M_POP; /* cnt */
1616 Temp = M_POP; /* addr */
1617 TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1618 M_PUSH((cell_t) CharPtr);
1621 case ID_SOURCE: /* ( -- c-addr num ) */
1623 M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );
1624 TOS = (cell_t) gCurrentTask->td_SourceNum;
1627 case ID_SOURCE_SET: /* ( c-addr num -- ) */
1628 gCurrentTask->td_SourcePtr = (char *) M_POP;
1629 gCurrentTask->td_SourceNum = TOS;
1635 TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
1638 case ID_SOURCE_ID_POP:
1640 TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
1643 case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */
1644 TOS = (cell_t)ffConvertSourceIDToStream( TOS );
1645 Scratch = ffPushInputStream((FileStream *) TOS );
1669 case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
1680 CharPtr = (char *) ffWord( (char) ' ' );
1681 TOS = ffFind( CharPtr, (ExecToken *) &Temp );
1684 ERR("' could not find ");
1685 ioType( (char *) CharPtr+1, *CharPtr );
1693 #endif /* !PF_NO_SHELL */
1695 case ID_TIMES: BINARY_OP( * ); endcase;
1698 Scratch = M_POP; /* addr */
1699 ioType( (char *) Scratch, TOS );
1708 case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
1709 case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
1710 case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
1711 case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
1712 case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
1713 case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
1714 case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
1715 case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
1716 case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;
1717 case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
1718 case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
1719 case ID_VAR_STATE: DO_VAR(gVarState); endcase;
1720 case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
1721 case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
1722 case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
1723 case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
1724 case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
1727 TOS = (cell_t) ffWord( (char) TOS );
1730 case ID_WORD_FETCH: /* ( waddr -- w ) */
1731 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1732 if( IN_DICS( TOS ) )
1734 TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);
1738 TOS = *((uint16_t *)TOS);
1741 TOS = *((uint16_t *)TOS);
1745 case ID_WORD_STORE: /* ( w waddr -- ) */
1747 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
1748 if( IN_DICS( TOS ) )
1750 WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);
1754 *((uint16_t *)TOS) = (uint16_t) M_POP;
1757 *((uint16_t *)TOS) = (uint16_t) M_POP;
1762 case ID_XOR: BINARY_OP( ^ ); endcase;
1765 /* Branch is followed by an offset relative to address of offset. */
1766 case ID_ZERO_BRANCH:
1767 DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
1774 InsPtr++; /* skip over offset */
1777 DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
1781 ERR("pfCatch: Unrecognised token = 0x");
1784 ffDotHex((cell_t) InsPtr);
1790 if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */
1797 if( _CrtCheckMemory() == 0 )
1799 ERR("_CrtCheckMemory abort: InsPtr = 0x");
1800 ffDotHex((int)InsPtr);
1805 } while( (InitialReturnStack - TORPTR) > 0 );
1809 return ExceptionReturnCode;