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, Devid 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 pfExecuteToken.
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 ***************************************************************/
31 #define SYSTEM_LOAD_FILE "system.fth"
33 /***************************************************************
34 ** Macros for data stack access.
35 ** TOS is cached in a register in pfExecuteToken.
36 ***************************************************************/
38 #define STKPTR (DataStackPtr)
39 #define M_POP (*(STKPTR++))
40 #define M_PUSH(n) {*(--(STKPTR)) = (cell) (n);}
41 #define M_STACK(n) (STKPTR[n])
43 #define TOS (TopOfStack)
44 #define PUSH_TOS M_PUSH(TOS)
45 #define M_DUP PUSH_TOS;
46 #define M_DROP { TOS = M_POP; }
49 /***************************************************************
50 ** Macros for Floating Point stack access.
51 ***************************************************************/
53 #define FP_STKPTR (FloatStackPtr)
54 #define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)
55 #define M_FP_POP (*(FP_STKPTR++))
56 #define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}
57 #define M_FP_STACK(n) (FP_STKPTR[n])
59 #define FP_TOS (fpTopOfStack)
60 #define PUSH_FP_TOS M_FP_PUSH(FP_TOS)
61 #define M_FP_DUP PUSH_FP_TOS;
62 #define M_FP_DROP { FP_TOS = M_FP_POP; }
65 /***************************************************************
66 ** Macros for return stack access.
67 ***************************************************************/
69 #define TORPTR (ReturnStackPtr)
70 #define M_R_DROP {TORPTR++;}
71 #define M_R_POP (*(TORPTR++))
72 #define M_R_PICK(n) (TORPTR[n])
73 #define M_R_PUSH(n) {*(--(TORPTR)) = (cell) (n);}
75 /***************************************************************
77 ***************************************************************/
79 #define M_BRANCH { InsPtr = (cell *) (((uint8 *) InsPtr) + READ_LONG_DIC(InsPtr)); }
81 /* Cache top of data stack like in JForth. */
83 #define LOAD_REGISTERS \
85 STKPTR = gCurrentTask->td_StackPtr; \
87 FP_STKPTR = gCurrentTask->td_FloatStackPtr; \
89 TORPTR = gCurrentTask->td_ReturnPtr; \
92 #define SAVE_REGISTERS \
94 gCurrentTask->td_ReturnPtr = TORPTR; \
96 gCurrentTask->td_StackPtr = STKPTR; \
97 M_FP_PUSH( FP_TOS ); \
98 gCurrentTask->td_FloatStackPtr = FP_STKPTR; \
102 /* Cache top of data stack like in JForth. */
103 #define LOAD_REGISTERS \
105 STKPTR = gCurrentTask->td_StackPtr; \
107 TORPTR = gCurrentTask->td_ReturnPtr; \
110 #define SAVE_REGISTERS \
112 gCurrentTask->td_ReturnPtr = TORPTR; \
114 gCurrentTask->td_StackPtr = STKPTR; \
123 #define DO_VAR(varname) { PUSH_TOS; TOS = (cell) &varname; }
131 /***************************************************************
133 ***************************************************************/
135 #define BINARY_OP( op ) { TOS = M_POP op TOS; }
137 #define endcase break
139 #if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)
140 #define TRACENAMES /* no names */
142 /* Display name of executing routine. */
143 static void TraceNames( ExecToken Token, int32 Level )
148 if( ffTokenToName( Token, &DebugName ) )
151 if( gCurrentTask->td_OUT > 0 ) EMIT_CR;
153 for( i=0; i<Level; i++ )
157 TypeName( DebugName );
158 /* Space out to column N then .S */
159 NumSpaces = 30 - gCurrentTask->td_OUT;
160 for( i=0; i < NumSpaces; i++ )
165 /* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */
170 MSG_NUM_H("Couldn't find Name for ", Token);
175 if( (gVarTraceLevel > Level) ) \
176 { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }
177 #endif /* PF_NO_SHELL */
179 /* Use local copy of CODE_BASE for speed. */
180 #define LOCAL_CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CodeBase))
182 /**************************************************************/
183 void pfExecuteToken( ExecToken XT )
185 register cell TopOfStack; /* Cache for faster execution. */
186 register cell *DataStackPtr;
187 register cell *ReturnStackPtr;
189 register PF_FLOAT fpTopOfStack;
190 PF_FLOAT *FloatStackPtr;
191 register PF_FLOAT fpScratch;
192 register PF_FLOAT fpTemp;
194 register cell *InsPtr = NULL;
196 register cell Scratch;
197 #ifdef PF_SUPPORT_TRACE
198 register int32 Level = 0;
200 cell *LocalsPtr = NULL;
202 cell *InitialReturnStack;
203 cell FakeSecondary[2];
207 uint8 *CodeBase = CODE_BASE;
210 ** Initialize FakeSecondary this way to avoid having stuff in the data section,
211 ** which is not supported for some embedded system loaders.
213 FakeSecondary[0] = 0;
214 FakeSecondary[1] = ID_EXIT; /* For EXECUTE */
216 /* Move data from task structure to registers for speed. */
218 InitialReturnStack = TORPTR;
223 DBUG(("pfExecuteToken: Token = 0x%x\n", Token ));
226 /* --------------------------------------------------------------- */
227 /* If secondary, thread down code tree until we hit a primitive. */
228 while( !IsTokenPrimitive( Token ) )
230 #ifdef PF_SUPPORT_TRACE
231 if((gVarTraceFlags & TRACE_INNER) )
233 MSG("pfExecuteToken: Secondary Token = 0x");
235 MSG_NUM_H(", InsPtr = 0x", InsPtr);
240 /* Save IP on return stack like a JSR. */
243 /* Convert execution token to absolute address. */
244 InsPtr = (cell *) ( LOCAL_CODEREL_TO_ABS(Token) );
246 /* Fetch token at IP. */
247 Token = READ_LONG_DIC(InsPtr++);
249 #ifdef PF_SUPPORT_TRACE
250 /* Bump level for trace display */
256 #ifdef PF_SUPPORT_TRACE
260 /* Execute primitive Token. */
264 /* Pop up a level. Put first in switch because ID_EXIT==0 */
266 InsPtr = ( cell *) M_R_POP;
267 #ifdef PF_SUPPORT_TRACE
272 case ID_1MINUS: TOS--; endcase;
274 case ID_1PLUS: TOS++; endcase;
278 ff2Literal( TOS, M_POP );
281 #endif /* !PF_NO_SHELL */
284 /* hi part stored first, put on top of stack */
286 TOS = READ_LONG_DIC(InsPtr++);
287 M_PUSH(READ_LONG_DIC(InsPtr++));
290 case ID_2MINUS: TOS -= 2; endcase;
292 case ID_2PLUS: TOS += 2; endcase;
295 case ID_2OVER: /* ( a b c d -- a b c d a b ) */
297 Scratch = M_STACK(3);
302 case ID_2SWAP: /* ( a b c d -- c d a b ) */
303 Scratch = M_STACK(0); /* c */
304 M_STACK(0) = M_STACK(2); /* a */
305 M_STACK(2) = Scratch; /* c */
306 Scratch = TOS; /* d */
307 TOS = M_STACK(1); /* b */
308 M_STACK(1) = Scratch; /* d */
311 case ID_2DUP: /* ( a b -- a b a b ) */
313 Scratch = M_STACK(1);
319 M_PUSH( (*(TORPTR+1)) );
335 case ID_ACCEPT: /* ( c-addr +n1 -- +n2 ) */
336 CharPtr = (char *) M_POP;
337 TOS = ioAccept( CharPtr, TOS, PF_STDIN );
342 ffALiteral( ABS_TO_CODEREL(TOS) );
345 #endif /* !PF_NO_SHELL */
349 TOS = (cell) LOCAL_CODEREL_TO_ABS( READ_LONG_DIC(InsPtr++) );
352 /* Allocate some extra and put validation identifier at base */
353 #define PF_MEMORY_VALIDATOR (0xA81B4D69)
355 CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) );
358 /* This was broken into two steps because different compilers incremented
359 ** CellPtr before or after the XOR step. */
360 Temp = (int32)CellPtr ^ PF_MEMORY_VALIDATOR;
362 M_PUSH( (cell) CellPtr );
368 TOS = -1; /* FIXME Fix error code. */
372 case ID_AND: BINARY_OP( & ); endcase;
374 case ID_ARSHIFT: BINARY_OP( >> ); endcase; /* Arithmetic right shift */
378 TOS = CREATE_BODY_OFFSET;
381 /* Branch is followed by an offset relative to address of offset. */
383 DBUGX(("Before Branch: IP = 0x%x\n", InsPtr ));
385 DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
388 /* Clear GO flag to tell QUIT to return. */
390 gCurrentTask->td_Flags &= ~CFTD_FLAG_GO;
394 MSG("Emergency exit.\n");
400 Scratch = READ_LONG_DIC(InsPtr++);
401 CallUserFunction( Scratch & 0xFFFF,
403 (Scratch >> 24) & 0x7F );
407 case ID_CFETCH: TOS = *((uint8 *) TOS); endcase;
409 case ID_CMOVE: /* ( src dst n -- ) */
411 register char *DstPtr = (char *) M_POP; /* dst */
412 CharPtr = (char *) M_POP; /* src */
413 for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ )
415 *DstPtr++ = *CharPtr++;
421 case ID_CMOVE_UP: /* ( src dst n -- ) */
423 register char *DstPtr = ((char *) M_POP) + TOS; /* dst */
424 CharPtr = ((char *) M_POP) + TOS;; /* src */
425 for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ )
427 *(--DstPtr) = *(--CharPtr);
437 case ID_COLON_P: /* ( $name xt -- ) */
438 CreateDicEntry( TOS, (char *) M_POP, 0 );
441 #endif /* !PF_NO_SHELL */
447 s2 = (const char *) M_POP;
449 s1 = (const char *) M_POP;
450 TOS = ffCompare( s1, len1, s2, TOS );
454 /* ( a b -- flag , Comparisons ) */
456 TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ;
458 case ID_COMP_NOT_EQUAL:
459 TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ;
461 case ID_COMP_GREATERTHAN:
462 TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ;
464 case ID_COMP_LESSTHAN:
465 TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ;
467 case ID_COMP_U_GREATERTHAN:
468 TOS = ( ((uint32)M_POP) > ((uint32)TOS) ) ? FTRUE : FFALSE ;
470 case ID_COMP_U_LESSTHAN:
471 TOS = ( ((uint32)M_POP) < ((uint32)TOS) ) ? FTRUE : FFALSE ;
473 case ID_COMP_ZERO_EQUAL:
474 TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;
476 case ID_COMP_ZERO_NOT_EQUAL:
477 TOS = ( TOS != 0 ) ? FTRUE : FALSE ;
479 case ID_COMP_ZERO_GREATERTHAN:
480 TOS = ( TOS > 0 ) ? FTRUE : FFALSE ;
482 case ID_COMP_ZERO_LESSTHAN:
483 TOS = ( TOS < 0 ) ? FTRUE : FFALSE ;
494 #endif /* !PF_NO_SHELL */
498 /* Put address of body on stack. Insptr points after code start. */
499 TOS = (cell) ((char *)InsPtr - sizeof(cell) + CREATE_BODY_OFFSET );
502 case ID_CSTORE: /* ( c caddr -- ) */
503 *((uint8 *) TOS) = (uint8) M_POP;
507 /* Double precision add. */
508 case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */
510 register ucell ah,al,bl,sh,sl;
517 if( sl < bl ) sh = 1; /* Carry */
525 /* Double precision subtract. */
526 case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */
528 register ucell ah,al,bl,sh,sl;
535 if( al < bl ) sh = 1; /* Borrow */
543 /* Perform 32*32 bit multiply for 64 bit result, using shift and add. */
544 /* This seems crazy. There must be an easier way. !!! */
545 case ID_D_UMTIMES: /* M* ( a b -- pl ph ) */
548 register ucell pl, ph, mi;
552 for( mi=0; mi<32; mi++ )
554 /* Shift B to left, checking bits. */
555 /* Shift Product to left and add AP. */
556 ph = (ph << 1) | (pl >> 31); /* 64 bit shift */
562 if( (temp < pl) || (temp < a) ) ph += 1; /* Carry */
566 DBUG(("UM* : mi = %d, a = 0x%08x, b = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, a, b, ph, pl ));
573 /* Perform 32*32 bit multiply for 64 bit result, using shift and add. */
574 /* This seems crazy. There must be an easier way. !!! */
575 case ID_D_MTIMES: /* M* ( a b -- pl ph ) */
578 register ucell pl, ph, mi, ap, bp;
580 ap = (a < 0) ? -a : a ; /* Positive A */
582 bp = (b < 0) ? -b : b ; /* Positive B */
584 for( mi=0; mi<32; mi++ )
586 /* Shift B to left, checking bits. */
587 /* Shift Product to left and add AP. */
588 ph = (ph << 1) | (pl >> 31); /* 64 bit shift */
590 if( bp & 0x80000000 )
594 if( (temp < pl) && (temp < ap) ) ph += 1; /* Carry */
598 DBUG(("M* : mi = %d, ap = 0x%08x, bp = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, ap, bp, ph, pl ));
600 /* Negate product if one operand negative. */
601 if( ((a ^ b) & 0x80000000) )
604 DBUG(("M* : -pl = 0x%08x\n", pl ));
605 if( pl & 0x80000000 )
607 ph = -1 - ph; /* Borrow */
613 DBUG(("M* : -ph = 0x%08x\n", ph ));
620 #define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
621 /* Perform 64/32 bit divide for 32 bit result, using shift and subtract. */
622 case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */
624 ucell ah,al, q,di, bl,bh, sl,sh;
630 for( di=0; di<32; di++ )
632 if( !DULT(al,ah,bl,bh) )
636 if( al < bl ) sh = 1; /* Borrow */
643 bl = (bl >> 1) | (bh << 31);
646 if( !DULT(al,ah,bl,bh) )
652 M_PUSH( al ); /* rem */
657 /* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */
658 case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */
660 register ucell ah,am,al,ql,qh,di;
661 #define bdiv ((ucell)TOS)
666 for( di=0; di<64; di++ )
673 qh = (qh << 1) | (ql >> 31);
675 ah = (ah << 1) | (am >> 31);
676 am = (am << 1) | (al >> 31);
678 DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
685 M_PUSH( ah ); /* rem */
696 #endif /* !PF_NO_SHELL */
703 TOS = gCurrentTask->td_StackBase - STKPTR;
706 case ID_DIVIDE: BINARY_OP( / ); endcase;
717 case ID_DROP: M_DROP; endcase;
721 DumpMemory( (char *) Scratch, TOS );
725 case ID_DUP: M_DUP; endcase;
727 case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */
733 case ID_EOL: /* ( -- end_of_line_char ) */
738 case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */
743 MSG_NUM_D("Error: ", (int32) Scratch);
758 /* Save IP on return stack like a JSR. */
760 #ifdef PF_SUPPORT_TRACE
761 /* Bump level for trace. */
764 if( IsTokenPrimitive( TOS ) )
766 WRITE_LONG_DIC( (cell *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */
767 InsPtr = &FakeSecondary[0];
771 InsPtr = (cell *) LOCAL_CODEREL_TO_ABS(TOS);
777 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
778 if( IN_DICS( TOS ) )
\r
780 TOS = (cell) READ_LONG_DIC((cell *)TOS);
\r
784 TOS = *((cell *)TOS);
\r
787 TOS = *((cell *)TOS);
\r
791 case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */
792 /* Build NUL terminated name string. */
793 Scratch = M_POP; /* u */
794 Temp = M_POP; /* caddr */
795 if( Scratch < TIB_SIZE-2 )
797 pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch );
798 gScratch[Scratch] = '\0';
799 DBUG(("Create file = %s\n", gScratch ));
800 FileID = sdOpenFile( gScratch, PF_FAM_CREATE );
801 TOS = ( FileID == NULL ) ? -1 : 0 ;
802 M_PUSH( (cell) FileID );
806 ERR("Filename too large for name buffer.\n");
812 case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */
813 /* Build NUL terminated name string. */
814 Scratch = M_POP; /* u */
815 Temp = M_POP; /* caddr */
816 if( Scratch < TIB_SIZE-2 )
820 pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch );
821 gScratch[Scratch] = '\0';
822 DBUG(("Open file = %s\n", gScratch ));
823 fam = ( TOS == PF_FAM_READ_ONLY ) ? PF_FAM_OPEN_RO : PF_FAM_OPEN_RW ;
824 FileID = sdOpenFile( gScratch, fam );
825 TOS = ( FileID == NULL ) ? -1 : 0 ;
826 M_PUSH( (cell) FileID );
830 ERR("Filename too large for name buffer.\n");
836 case ID_FILE_CLOSE: /* ( fid -- ior ) */
837 TOS = sdCloseFile( (FileStream *) TOS );
840 case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */
841 FileID = (FileStream *) TOS;
843 CharPtr = (char *) M_POP;
844 Temp = sdReadFile( CharPtr, 1, Scratch, FileID );
849 case ID_FILE_SIZE: /* ( fid -- ud ior ) */
850 /* Determine file size by seeking to end and returning position. */
851 FileID = (FileStream *) TOS;
852 Scratch = sdTellFile( FileID );
853 sdSeekFile( FileID, 0, PF_SEEK_END );
854 M_PUSH( sdTellFile( FileID ));
855 sdSeekFile( FileID, Scratch, PF_SEEK_SET );
856 TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */
859 case ID_FILE_WRITE: /* ( addr len fid -- ior ) */
860 FileID = (FileStream *) TOS;
862 CharPtr = (char *) M_POP;
863 Temp = sdWriteFile( CharPtr, 1, Scratch, FileID );
864 TOS = (Temp != Scratch) ? -3 : 0;
867 case ID_FILE_REPOSITION: /* ( pos fid -- ior ) */
868 FileID = (FileStream *) TOS;
870 TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET );
873 case ID_FILE_POSITION: /* ( pos fid -- ior ) */
874 M_PUSH( sdTellFile( (FileStream *) TOS ));
878 case ID_FILE_RO: /* ( -- fam ) */
880 TOS = PF_FAM_READ_ONLY;
883 case ID_FILE_RW: /* ( -- fam ) */
885 TOS = PF_FAM_READ_WRITE;
888 case ID_FILL: /* ( caddr num charval -- ) */
890 register char *DstPtr;
891 Temp = M_POP; /* num */
892 DstPtr = (char *) M_POP; /* dst */
893 for( Scratch=0; (uint32) Scratch < (uint32) Temp ; Scratch++ )
895 *DstPtr++ = (char) TOS;
902 case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */
903 TOS = ffFind( (char *) TOS, (ExecToken *) &Temp );
908 TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );
909 M_PUSH( (cell) Temp );
911 #endif /* !PF_NO_SHELL */
917 /* Validate memory before freeing. Clobber validator and first word. */
918 case ID_FREE: /* ( addr -- result ) */
921 ERR("FREE passed NULL!\n");
922 TOS = -2; /* FIXME error code */
926 CellPtr = (cell *) TOS;
928 if( ((uint32)*CellPtr) != ((uint32)CellPtr ^ PF_MEMORY_VALIDATOR))
930 TOS = -2; /* FIXME error code */
934 CellPtr[0] = 0xDeadBeef;
935 CellPtr[1] = 0xDeadBeef;
936 pfFreeMem((char *)CellPtr);
942 #include "pfinnrfp.h"
946 TOS = (cell)CODE_HERE;
949 case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */
950 /* Convert using number converter in 'C'.
951 ** Only supports single precision for bootstrap.
953 TOS = (cell) ffNumberQ( (char *) TOS, &Temp );
954 if( TOS == NUM_TYPE_SINGLE)
956 M_PUSH( Temp ); /* Push single number */
960 case ID_I: /* ( -- i , DO LOOP index ) */
966 case ID_INCLUDE_FILE:
967 FileID = (FileStream *) TOS;
968 M_DROP; /* Drop now so that INCLUDE has a clean stack. */
970 ffIncludeFile( FileID );
972 #endif /* !PF_NO_SHELL */
975 case ID_J: /* ( -- j , second DO LOOP index ) */
990 #endif /* !PF_NO_SHELL */
993 DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));
995 TOS = READ_LONG_DIC(InsPtr++);
999 case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase;
1000 #endif /* !PF_NO_SHELL */
1002 case ID_LOCAL_FETCH: /* ( i <local> -- n , fetch from local ) */
1003 TOS = *(LocalsPtr - TOS);
1006 #define LOCAL_FETCH_N(num) \
1007 case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
1009 TOS = *(LocalsPtr -(num)); \
1021 case ID_LOCAL_STORE: /* ( n i <local> -- , store n in local ) */
1022 *(LocalsPtr - TOS) = M_POP;
1026 #define LOCAL_STORE_N(num) \
1027 case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \
1028 *(LocalsPtr - (num)) = TOS; \
1041 case ID_LOCAL_PLUSSTORE: /* ( n i <local> -- , add n to local ) */
\r
1042 *(LocalsPtr - TOS) += M_POP;
1046 case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */
1047 /* create local stack frame */
1051 DBUG(("LocalEntry: n = %d\n", TOS));
1052 /* End of locals. Create stack frame */
1053 DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
1054 TORPTR, LocalsPtr));
1055 M_R_PUSH(LocalsPtr);
1058 DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
1059 TORPTR, LocalsPtr));
1063 *lp++ = M_POP; /* Load local vars from stack */
1069 case ID_LOCAL_EXIT: /* cleanup up local stack frame */
1070 DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
1071 TORPTR, LocalsPtr));
1073 LocalsPtr = (cell *) M_R_POP;
1074 DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
1075 TORPTR, LocalsPtr));
1080 MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR;
1081 FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r");
1085 ffIncludeFile( FileID );
1087 sdCloseFile( FileID );
1091 ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n");
1094 #endif /* !PF_NO_SHELL */
1096 case ID_LEAVE_P: /* ( R: index limit -- ) */
1102 case ID_LOOP_P: /* ( R: index limit -- | index limit ) */
1103 Temp = M_R_POP; /* limit */
1104 Scratch = M_R_POP + 1; /* index */
1105 if( Scratch == Temp )
1107 InsPtr++; /* skip branch offset, exit loop */
1111 /* Push index and limit back to R */
1112 M_R_PUSH( Scratch );
1114 /* Branch back to just after (DO) */
1119 case ID_LSHIFT: BINARY_OP( << ); endcase;
1123 TOS = ( TOS > Scratch ) ? TOS : Scratch ;
1128 TOS = ( TOS < Scratch ) ? TOS : Scratch ;
1131 case ID_MINUS: BINARY_OP( - ); endcase;
1134 case ID_NAME_TO_TOKEN:
1135 TOS = (cell) NameToToken((ForthString *)TOS);
1138 case ID_NAME_TO_PREVIOUS:
1139 TOS = (cell) NameToPrevious((ForthString *)TOS);
1146 case ID_OR: BINARY_OP( | ); endcase;
1153 case ID_PICK: /* ( ... n -- sp(n) ) */
1157 case ID_PLUS: BINARY_OP( + ); endcase;
1159 case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */
\r
1160 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1161 if( IN_DICS( TOS ) )
\r
1163 Scratch = READ_LONG_DIC((cell *)TOS);
\r
1165 WRITE_LONG_DIC((cell *)TOS,Scratch);
\r
1169 *((cell *)TOS) += M_POP;
\r
1172 *((cell *)TOS) += M_POP;
\r
1177 case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */
1179 ucell OldIndex, NewIndex, Limit;
1183 NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */
1184 /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
1185 if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
1186 ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
1188 InsPtr++; /* skip branch offset, exit loop */
1192 /* Push index and limit back to R */
1193 M_R_PUSH( NewIndex );
1195 /* Branch back to just after (DO) */
1202 case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
1203 Scratch = M_POP; /* limit */
1204 if( Scratch == TOS )
1206 /* Branch to just after (LOOP) */
1212 M_R_PUSH( Scratch );
1213 InsPtr++; /* skip branch offset, enter loop */
1218 case ID_QDUP: if( TOS ) M_DUP; endcase;
1220 case ID_QTERMINAL: /* WARNING: Typically not implemented! */
1222 TOS = sdQueryTerminal();
1225 case ID_QUIT_P: /* Stop inner interpreter, go back to user. */
1226 #ifdef PF_SUPPORT_TRACE
1251 /* Resize memory allocated by ALLOCATE. */
1252 case ID_RESIZE: /* ( addr1 u -- addr2 result ) */
1256 FreePtr = (cell *) ( M_POP - sizeof(cell) );
1257 if( ((uint32)*FreePtr) != ((uint32)FreePtr ^ PF_MEMORY_VALIDATOR))
1264 /* Try to allocate. */
1265 CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) );
1268 /* Copy memory including validation. */
1269 pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell) );
1270 *CellPtr++ = ((int32)CellPtr ^ PF_MEMORY_VALIDATOR);
1271 M_PUSH( (cell) ++CellPtr );
1273 FreePtr[0] = 0xDeadBeef;
1274 FreePtr[1] = 0xDeadBeef;
1275 pfFreeMem((char *) FreePtr);
1280 TOS = -4; /* FIXME Fix error code. */
1287 ** RP@ and RP! are called secondaries so we must
1288 ** account for the return address pushed before calling.
1290 case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */
1292 TOS = (cell)TORPTR; /* value before calling RP@ */
1295 case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */
1296 TORPTR = (cell *) TOS;
1300 case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
1303 cell *srcPtr, *dstPtr;
1304 Scratch = M_STACK(TOS);
1305 srcPtr = &M_STACK(TOS-1);
1306 dstPtr = &M_STACK(TOS);
1307 for( ri=0; ri<TOS; ri++ )
1309 *dstPtr-- = *srcPtr--;
1316 case ID_ROT: /* ( a b c -- b c a ) */
1317 Scratch = M_POP; /* b */
1318 Temp = M_POP; /* a */
1319 M_PUSH( Scratch ); /* b */
1324 /* Logical right shift */
1325 case ID_RSHIFT: { TOS = ((uint32)M_POP) >> TOS; } endcase;
1328 case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */
1330 int32 NameSize, CodeSize, EntryPoint;
1334 ForthStringToC( gScratch, (char *) M_POP );
1335 TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );
1341 ** EVALUATE >IN SourceID=(-1) 1111
1342 ** keyboard >IN SourceID=(0) 2222
1343 ** file >IN lineNumber filePos SourceID=(fileID)
1345 case ID_SAVE_INPUT: /* FIXME - finish */
1350 case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */
1355 case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */
1356 STKPTR = (cell *) TOS;
1360 case ID_STORE: /* ( n addr -- , write n to addr ) */
\r
1361 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1362 if( IN_DICS( TOS ) )
\r
1364 WRITE_LONG_DIC((cell *)TOS,M_POP);
\r
1368 *((cell *)TOS) = M_POP;
\r
1371 *((cell *)TOS) = M_POP;
\r
1376 case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */
1377 Scratch = M_POP; /* cnt */
1378 Temp = M_POP; /* addr */
1379 TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1380 M_PUSH((cell) CharPtr);
1387 #endif /* !PF_NO_SHELL */
1389 case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */
1390 Scratch = M_POP; /* cnt */
1391 Temp = M_POP; /* addr */
1392 TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );
1393 M_PUSH((cell) CharPtr);
1396 case ID_SOURCE: /* ( -- c-addr num ) */
1398 M_PUSH( (cell) gCurrentTask->td_SourcePtr );
1399 TOS = (cell) gCurrentTask->td_SourceNum;
1402 case ID_SOURCE_SET: /* ( c-addr num -- ) */
1403 gCurrentTask->td_SourcePtr = (char *) M_POP;
1404 gCurrentTask->td_SourceNum = TOS;
1410 TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ;
1413 case ID_SOURCE_ID_POP:
1415 TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ;
1418 case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */
1419 TOS = (cell)ffConvertSourceIDToStream( TOS );
1420 if( ffPushInputStream((FileStream *) TOS ) )
1444 CharPtr = (char *) ffWord( (char) ' ' );
1445 TOS = ffFind( CharPtr, (ExecToken *) &Temp );
1448 ERR("' could not find ");
1449 ioType( (char *) CharPtr+1, *CharPtr );
1457 #endif /* !PF_NO_SHELL */
1459 case ID_TIMES: BINARY_OP( * ); endcase;
1462 Scratch = M_POP; /* addr */
1463 ioType( (char *) Scratch, TOS );
1472 case ID_VAR_BASE: DO_VAR(gVarBase); endcase;
1473 case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase;
1474 case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase;
1475 case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase;
1476 case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase;
1477 case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;
1478 case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;
1479 case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;
1480 case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr.Cell); endcase;
1481 case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;
1482 case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;
1483 case ID_VAR_STATE: DO_VAR(gVarState); endcase;
1484 case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase;
1485 case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase;
1486 case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase;
1487 case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase;
1488 case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;
1491 TOS = (cell) ffWord( (char) TOS );
1494 case ID_WORD_FETCH: /* ( waddr -- w ) */
\r
1495 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1496 if( IN_DICS( TOS ) )
\r
1498 TOS = (uint16) READ_SHORT_DIC((uint16 *)TOS);
\r
1502 TOS = *((uint16 *)TOS);
\r
1505 TOS = *((uint16 *)TOS);
\r
1509 case ID_WORD_STORE: /* ( w waddr -- ) */
\r
1511 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
1512 if( IN_DICS( TOS ) )
\r
1514 WRITE_SHORT_DIC((uint16 *)TOS,(uint16)M_POP);
\r
1518 *((uint16 *)TOS) = (uint16) M_POP;
\r
1521 *((uint16 *)TOS) = (uint16) M_POP;
\r
1526 case ID_XOR: BINARY_OP( ^ ); endcase;
1529 /* Branch is followed by an offset relative to address of offset. */
1530 case ID_ZERO_BRANCH:
1531 DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr ));
1538 InsPtr++; /* skip over offset */
1541 DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr ));
1545 ERR("pfExecuteToken: Unrecognised token = 0x");
1548 ffDotHex((int32) InsPtr);
1554 if(InsPtr) Token = READ_LONG_DIC(InsPtr++); /* Traverse to next token in secondary. */
1560 } while( (( InitialReturnStack - TORPTR) > 0 ) && (!CHECK_ABORT) );