/* @(#) pf_inner.c 98/03/16 1.7 */
/***************************************************************
** Inner Interpreter for Forth based on 'C'
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
** The pForth software code is dedicated to the public domain,
** and any third party may reproduce, distribute and modify
** the pForth software code or any derivative works thereof
** without any compensation or license. The pForth software
** code is provided on an "as is" basis without any warranty
** of any kind, including, without limitation, the implied
** warranties of merchantability and fitness for a particular
** purpose and their equivalents under the laws of any jurisdiction.
****************************************************************
** 940505 PLB More macros.
** 940509 PLB Moved all stack stuff into pfCatch.
** 941014 PLB Converted to flat secondary strusture.
** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH,
** 941130 PLB Made w@ unsigned
***************************************************************/
#define SYSTEM_LOAD_FILE "system.fth"
/***************************************************************
** Macros for data stack access.
** TOS is cached in a register in pfCatch.
***************************************************************/
#define STKPTR (DataStackPtr)
#define M_POP (*(STKPTR++))
#define M_PUSH(n) {*(--(STKPTR)) = (cell) (n);}
#define M_STACK(n) (STKPTR[n])
#define PUSH_TOS M_PUSH(TOS)
#define M_DROP { TOS = M_POP; }
/***************************************************************
** Macros for Floating Point stack access.
***************************************************************/
#define FP_STKPTR (FloatStackPtr)
#define M_FP_SPZERO (gCurrentTask->td_FloatStackBase)
#define M_FP_POP (*(FP_STKPTR++))
#define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);}
#define M_FP_STACK(n) (FP_STKPTR[n])
#define FP_TOS (fpTopOfStack)
#define PUSH_FP_TOS M_FP_PUSH(FP_TOS)
#define M_FP_DUP PUSH_FP_TOS;
#define M_FP_DROP { FP_TOS = M_FP_POP; }
/***************************************************************
** Macros for return stack access.
***************************************************************/
#define TORPTR (ReturnStackPtr)
#define M_R_DROP {TORPTR++;}
#define M_R_POP (*(TORPTR++))
#define M_R_PICK(n) (TORPTR[n])
#define M_R_PUSH(n) {*(--(TORPTR)) = (cell) (n);}
/***************************************************************
***************************************************************/
#define M_BRANCH { InsPtr = (cell *) (((uint8 *) InsPtr) + READ_LONG_DIC(InsPtr)); }
/* Cache top of data stack like in JForth. */
STKPTR = gCurrentTask->td_StackPtr; \
FP_STKPTR = gCurrentTask->td_FloatStackPtr; \
TORPTR = gCurrentTask->td_ReturnPtr; \
gCurrentTask->td_ReturnPtr = TORPTR; \
gCurrentTask->td_StackPtr = STKPTR; \
gCurrentTask->td_FloatStackPtr = FP_STKPTR; \
/* Cache top of data stack like in JForth. */
STKPTR = gCurrentTask->td_StackPtr; \
TORPTR = gCurrentTask->td_ReturnPtr; \
gCurrentTask->td_ReturnPtr = TORPTR; \
gCurrentTask->td_StackPtr = STKPTR; \
#define DO_VAR(varname) { PUSH_TOS; TOS = (cell) &varname; }
ExceptionReturnCode = (ThrowCode)(err); \
TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
STKPTR = InitialDataStack; \
FP_STKPTR = InitialFloatStack; \
ExceptionReturnCode = (err); \
TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \
STKPTR = InitialDataStack; \
/***************************************************************
***************************************************************/
#define BINARY_OP( op ) { TOS = M_POP op TOS; }
#if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE)
#define TRACENAMES /* no names */
/* Display name of executing routine. */
static void TraceNames( ExecToken Token
, int32 Level
)
if( ffTokenToName( Token
, &DebugName
) )
if( gCurrentTask
->td_OUT
> 0 ) EMIT_CR
;
/* Space out to column N then .S */
NumSpaces
= 30 - gCurrentTask
->td_OUT
;
for( i
=0; i
< NumSpaces
; i
++ )
/* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */
MSG_NUM_H("Couldn't find Name for ", Token
);
if( (gVarTraceLevel > Level) ) \
{ SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; }
/* Use local copy of CODE_BASE for speed. */
#define LOCAL_CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CodeBase))
/**************************************************************/
const char *pfSelectFileMode( int fam
)
case (PF_FAM_READ_ONLY
+ PF_FAM_BINARY_FLAG
):
famText
= PF_FAM_BIN_OPEN_RO
;
case (PF_FAM_WRITE_ONLY
+ PF_FAM_BINARY_FLAG
):
famText
= PF_FAM_BIN_CREATE_WO
;
case (PF_FAM_READ_WRITE
+ PF_FAM_BINARY_FLAG
):
famText
= PF_FAM_BIN_OPEN_RW
;
famText
= PF_FAM_OPEN_RO
;
famText
= PF_FAM_CREATE_WO
;
famText
= PF_FAM_OPEN_RW
;
/**************************************************************/
int pfCatch( ExecToken XT
)
register cell TopOfStack
; /* Cache for faster execution. */
register cell
*DataStackPtr
;
register cell
*ReturnStackPtr
;
register cell
*InsPtr
= NULL
;
PF_FLOAT
*InitialFloatStack
;
cell
*InitialReturnStack
;
uint8
*CodeBase
= CODE_BASE
;
ThrowCode ExceptionReturnCode
= 0;
PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth ));
** Initialize FakeSecondary this way to avoid having stuff in the data section,
** which is not supported for some embedded system loaders.
FakeSecondary
[1] = ID_EXIT
; /* For EXECUTE */
/* Move data from task structure to registers for speed. */
/* Save initial stack depths for THROW */
InitialReturnStack
= TORPTR
;
InitialDataStack
= STKPTR
;
InitialFloatStack
= FP_STKPTR
;
DBUG(("pfCatch: Token = 0x%x\n", Token
));
/* --------------------------------------------------------------- */
/* If secondary, thread down code tree until we hit a primitive. */
while( !IsTokenPrimitive( Token
) )
if((gVarTraceFlags
& TRACE_INNER
) )
MSG("pfCatch: Secondary Token = 0x");
MSG_NUM_H(", InsPtr = 0x", InsPtr
);
/* Save IP on return stack like a JSR. */
/* Convert execution token to absolute address. */
InsPtr
= (cell
*) ( LOCAL_CODEREL_TO_ABS(Token
) );
Token
= READ_LONG_DIC(InsPtr
++);
/* Bump level for trace display */
/* Execute primitive Token. */
/* Pop up a level in Forth inner interpreter.
** Used to implement semicolon.
** Put first in switch because ID_EXIT==0 */
InsPtr
= ( cell
*) M_R_POP
;
case ID_1MINUS
: TOS
--; endcase
;
case ID_1PLUS
: TOS
++; endcase
;
ff2Literal( TOS
, M_POP
);
#endif /* !PF_NO_SHELL */
/* hi part stored first, put on top of stack */
TOS
= READ_LONG_DIC(InsPtr
++);
M_PUSH(READ_LONG_DIC(InsPtr
++));
case ID_2MINUS
: TOS
-= 2; endcase
;
case ID_2PLUS
: TOS
+= 2; endcase
;
case ID_2OVER
: /* ( a b c d -- a b c d a b ) */
case ID_2SWAP
: /* ( a b c d -- c d a b ) */
Scratch
= M_STACK(0); /* c */
M_STACK(0) = M_STACK(2); /* a */
M_STACK(2) = Scratch
; /* c */
TOS
= M_STACK(1); /* b */
M_STACK(1) = Scratch
; /* d */
case ID_2DUP
: /* ( a b -- a b a b ) */
case ID_ACCEPT_P
: /* ( c-addr +n1 -- +n2 ) */
CharPtr
= (char *) M_POP
;
TOS
= ioAccept( CharPtr
, TOS
);
ffALiteral( ABS_TO_CODEREL(TOS
) );
#endif /* !PF_NO_SHELL */
TOS
= (cell
) LOCAL_CODEREL_TO_ABS( READ_LONG_DIC(InsPtr
++) );
/* Allocate some extra and put validation identifier at base */
#define PF_MEMORY_VALIDATOR (0xA81B4D69)
/* Allocate at least one cell's worth because we clobber first cell. */
if ( TOS
< sizeof(cell
) )
/* Allocate extra cells worth because we store validation info. */
CellPtr
= (cell
*) pfAllocMem( Temp
+ sizeof(cell
) );
/* This was broken into two steps because different compilers incremented
** CellPtr before or after the XOR step. */
Temp
= (int32
)CellPtr
^ PF_MEMORY_VALIDATOR
;
M_PUSH( (cell
) CellPtr
);
TOS
= -1; /* FIXME Fix error code. */
case ID_AND
: BINARY_OP( & ); endcase
;
case ID_ARSHIFT
: BINARY_OP( >> ); endcase
; /* Arithmetic right shift */
TOS
= CREATE_BODY_OFFSET
;
/* Branch is followed by an offset relative to address of offset. */
DBUGX(("Before Branch: IP = 0x%x\n", InsPtr
));
DBUGX(("After Branch: IP = 0x%x\n", InsPtr
));
MSG("Emergency exit.\n");
Scratch
= pfCatch( Scratch
);
Scratch
= READ_LONG_DIC(InsPtr
++);
CallUserFunction( Scratch
& 0xFFFF,
(Scratch
>> 24) & 0x7F );
case ID_CFETCH
: TOS
= *((uint8
*) TOS
); endcase
;
case ID_CMOVE
: /* ( src dst n -- ) */
register char *DstPtr
= (char *) M_POP
; /* dst */
CharPtr
= (char *) M_POP
; /* src */
for( Scratch
=0; (uint32
) Scratch
< (uint32
) TOS
; Scratch
++ )
case ID_CMOVE_UP
: /* ( src dst n -- ) */
register char *DstPtr
= ((char *) M_POP
) + TOS
; /* dst */
CharPtr
= ((char *) M_POP
) + TOS
;; /* src */
for( Scratch
=0; (uint32
) Scratch
< (uint32
) TOS
; Scratch
++ )
*(--DstPtr
) = *(--CharPtr
);
case ID_COLON_P
: /* ( $name xt -- ) */
CreateDicEntry( TOS
, (char *) M_POP
, 0 );
#endif /* !PF_NO_SHELL */
s2
= (const char *) M_POP
;
s1
= (const char *) M_POP
;
TOS
= ffCompare( s1
, len1
, s2
, TOS
);
/* ( a b -- flag , Comparisons ) */
TOS
= ( TOS
== M_POP
) ? FTRUE
: FFALSE
;
TOS
= ( TOS
!= M_POP
) ? FTRUE
: FFALSE
;
case ID_COMP_GREATERTHAN
:
TOS
= ( M_POP
> TOS
) ? FTRUE
: FFALSE
;
TOS
= ( M_POP
< TOS
) ? FTRUE
: FFALSE
;
case ID_COMP_U_GREATERTHAN
:
TOS
= ( ((uint32
)M_POP
) > ((uint32
)TOS
) ) ? FTRUE
: FFALSE
;
TOS
= ( ((uint32
)M_POP
) < ((uint32
)TOS
) ) ? FTRUE
: FFALSE
;
TOS
= ( TOS
== 0 ) ? FTRUE
: FFALSE
;
case ID_COMP_ZERO_NOT_EQUAL
:
TOS
= ( TOS
!= 0 ) ? FTRUE
: FALSE
;
case ID_COMP_ZERO_GREATERTHAN
:
TOS
= ( TOS
> 0 ) ? FTRUE
: FFALSE
;
case ID_COMP_ZERO_LESSTHAN
:
TOS
= ( TOS
< 0 ) ? FTRUE
: FFALSE
;
#endif /* !PF_NO_SHELL */
/* Put address of body on stack. Insptr points after code start. */
TOS
= (cell
) ((char *)InsPtr
- sizeof(cell
) + CREATE_BODY_OFFSET
);
case ID_CSTORE
: /* ( c caddr -- ) */
*((uint8
*) TOS
) = (uint8
) M_POP
;
/* Double precision add. */
case ID_D_PLUS
: /* D+ ( al ah bl bh -- sl sh ) */
register ucell ah
,al
,bl
,sh
,sl
;
if( sl
< bl
) sh
= 1; /* Carry */
/* Double precision subtract. */
case ID_D_MINUS
: /* D- ( al ah bl bh -- sl sh ) */
register ucell ah
,al
,bl
,sh
,sl
;
if( al
< bl
) sh
= 1; /* Borrow */
/* Perform 32*32 bit multiply for 64 bit result, by factoring into 16 bit quantities. */
/* Using an improved algorithm suggested by Steve Green. */
case ID_D_UMTIMES
: /* M* ( a b -- pl ph ) */
ucell ahi
, alo
, bhi
, blo
, temp
;
/* Get values from stack. */
/* Break into hi and lo 16 bit parts. */
ph
= pl
>> 16; /* shift 64 bit value by 16 */
if( pl
< temp
) ph
+= 1; /* Carry */
if( pl
< temp
) ph
+= 1; /* Carry */
ph
= (ph
<< 16) | (pl
>> 16); /* shift 64 bit value by 16 */
if( pl
< temp
) ph
+= 1; /* Carry */
/* Perform 32*32 bit multiply for 64 bit result, using shift and add. */
case ID_D_MTIMES
: /* M* ( a b -- pl ph ) */
ucell ap
,bp
, ahi
, alo
, bhi
, blo
, temp
;
/* Get values from stack. */
ap
= (a
< 0) ? -a
: a
; /* Positive A */
bp
= (b
< 0) ? -b
: b
; /* Positive B */
/* Break into hi and lo 16 bit parts. */
ph
= pl
>> 16; /* shift 64 bit value by 16 */
if( pl
< temp
) ph
+= 1; /* Carry */
if( pl
< temp
) ph
+= 1; /* Carry */
ph
= (ph
<< 16) | (pl
>> 16); /* shift 64 bit value by 16 */
if( pl
< temp
) ph
+= 1; /* Carry */
/* Negate product if one operand negative. */
if( ((a
^ b
) & 0x80000000) )
ph
= -1 - ph
; /* Borrow */
#define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
/* Perform 64/32 bit divide for 32 bit result, using shift and subtract. */
case ID_D_UMSMOD
: /* UM/MOD ( al ah bdiv -- rem q ) */
ucell ah
,al
, q
,di
, bl
,bh
, sl
,sh
;
if( al
< bl
) sh
= 1; /* Borrow */
bl
= (bl
>> 1) | (bh
<< 31);
/* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */
case ID_D_MUSMOD
: /* MU/MOD ( al am bdiv -- rem ql qh ) */
register ucell ah
,am
,al
,ql
,qh
,di
;
#define bdiv ((ucell)TOS)
qh
= (qh
<< 1) | (ql
>> 31);
ah
= (ah
<< 1) | (am
>> 31);
am
= (am
<< 1) | (al
>> 31);
DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah
,am
,al
, qh
,ql
));
#endif /* !PF_NO_SHELL */
TOS
= gCurrentTask
->td_StackBase
- STKPTR
;
case ID_DIVIDE
: BINARY_OP( / ); endcase
;
case ID_DROP
: M_DROP
; endcase
;
DumpMemory( (char *) Scratch
, TOS
);
case ID_DUP
: M_DUP
; endcase
;
case ID_DO_P
: /* ( limit start -- ) ( R: -- start limit ) */
case ID_EOL
: /* ( -- end_of_line_char ) */
case ID_ERRORQ_P
: /* ( flag num -- , quit if flag true ) */
/* Save IP on return stack like a JSR. */
/* Bump level for trace. */
if( IsTokenPrimitive( TOS
) )
WRITE_LONG_DIC( (cell
*) &FakeSecondary
[0], TOS
); /* Build a fake secondary and execute it. */
InsPtr
= &FakeSecondary
[0];
InsPtr
= (cell
*) LOCAL_CODEREL_TO_ABS(TOS
);
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
TOS
= (cell
) READ_LONG_DIC((cell
*)TOS
);
case ID_FILE_CREATE
: /* ( c-addr u fam -- fid ior ) */
/* Build NUL terminated name string. */
Temp
= M_POP
; /* caddr */
if( Scratch
< TIB_SIZE
-2 )
const char *famText
= pfSelectFileMode( TOS
);
pfCopyMemory( gScratch
, (char *) Temp
, (uint32
) Scratch
);
gScratch
[Scratch
] = '\0';
DBUG(("Create file = %s\n", gScratch
));
FileID
= sdOpenFile( gScratch
, famText
);
TOS
= ( FileID
== NULL
) ? -1 : 0 ;
ERR("Filename too large for name buffer.\n");
case ID_FILE_OPEN
: /* ( c-addr u fam -- fid ior ) */
/* Build NUL terminated name string. */
Temp
= M_POP
; /* caddr */
if( Scratch
< TIB_SIZE
-2 )
const char *famText
= pfSelectFileMode( TOS
);
pfCopyMemory( gScratch
, (char *) Temp
, (uint32
) Scratch
);
gScratch
[Scratch
] = '\0';
DBUG(("Open file = %s\n", gScratch
));
FileID
= sdOpenFile( gScratch
, famText
);
TOS
= ( FileID
== NULL
) ? -1 : 0 ;
ERR("Filename too large for name buffer.\n");
case ID_FILE_CLOSE
: /* ( fid -- ior ) */
TOS
= sdCloseFile( (FileStream
*) TOS
);
case ID_FILE_READ
: /* ( addr len fid -- u2 ior ) */
FileID
= (FileStream
*) TOS
;
CharPtr
= (char *) M_POP
;
Temp
= sdReadFile( CharPtr
, 1, Scratch
, FileID
);
case ID_FILE_SIZE
: /* ( fid -- ud ior ) */
/* Determine file size by seeking to end and returning position. */
FileID
= (FileStream
*) TOS
;
Scratch
= sdTellFile( FileID
);
sdSeekFile( FileID
, 0, PF_SEEK_END
);
M_PUSH( sdTellFile( FileID
));
sdSeekFile( FileID
, Scratch
, PF_SEEK_SET
);
TOS
= (Scratch
< 0) ? -4 : 0 ; /* !!! err num */
case ID_FILE_WRITE
: /* ( addr len fid -- ior ) */
FileID
= (FileStream
*) TOS
;
CharPtr
= (char *) M_POP
;
Temp
= sdWriteFile( CharPtr
, 1, Scratch
, FileID
);
TOS
= (Temp
!= Scratch
) ? -3 : 0;
case ID_FILE_REPOSITION
: /* ( pos fid -- ior ) */
FileID
= (FileStream
*) TOS
;
TOS
= sdSeekFile( FileID
, Scratch
, PF_SEEK_SET
);
case ID_FILE_POSITION
: /* ( pos fid -- ior ) */
M_PUSH( sdTellFile( (FileStream
*) TOS
));
case ID_FILE_RO
: /* ( -- fam ) */
case ID_FILE_RW
: /* ( -- fam ) */
case ID_FILE_WO
: /* ( -- fam ) */
case ID_FILE_BIN
: /* ( -- fam ) */
TOS
= TOS
| PF_FAM_BINARY_FLAG
;
case ID_FILL
: /* ( caddr num charval -- ) */
DstPtr
= (char *) M_POP
; /* dst */
for( Scratch
=0; (uint32
) Scratch
< (uint32
) Temp
; Scratch
++ )
case ID_FIND
: /* ( $addr -- $addr 0 | xt +-1 ) */
TOS
= ffFind( (char *) TOS
, (ExecToken
*) &Temp
);
TOS
= ffFindNFA( (const ForthString
*) TOS
, (const ForthString
**) &Temp
);
#endif /* !PF_NO_SHELL */
/* Validate memory before freeing. Clobber validator and first word. */
case ID_FREE
: /* ( addr -- result ) */
ERR("FREE passed NULL!\n");
TOS
= -2; /* FIXME error code */
if( ((uint32
)*CellPtr
) != ((uint32
)CellPtr
^ PF_MEMORY_VALIDATOR
))
TOS
= -2; /* FIXME error code */
pfFreeMem((char *)CellPtr
);
case ID_NUMBERQ_P
: /* ( addr -- 0 | n 1 ) */
/* Convert using number converter in 'C'.
** Only supports single precision for bootstrap.
TOS
= (cell
) ffNumberQ( (char *) TOS
, &Temp
);
if( TOS
== NUM_TYPE_SINGLE
)
M_PUSH( Temp
); /* Push single number */
case ID_I
: /* ( -- i , DO LOOP index ) */
FileID
= (FileStream
*) TOS
;
M_DROP
; /* Drop now so that INCLUDE has a clean stack. */
Scratch
= ffIncludeFile( FileID
);
if( Scratch
) M_THROW(Scratch
)
#endif /* !PF_NO_SHELL */
if( Scratch
) M_THROW(Scratch
)
#endif /* !PF_NO_SHELL */
case ID_J
: /* ( -- j , second DO LOOP index ) */
#endif /* !PF_NO_SHELL */
DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr
, *InsPtr
));
TOS
= READ_LONG_DIC(InsPtr
++);
case ID_LOCAL_COMPILER
: DO_VAR(gLocalCompiler_XT
); endcase
;
#endif /* !PF_NO_SHELL */
case ID_LOCAL_FETCH
: /* ( i <local> -- n , fetch from local ) */
TOS
= *(LocalsPtr
- TOS
);
#define LOCAL_FETCH_N(num) \
case ID_LOCAL_FETCH_##num: /* ( <local> -- n , fetch from local ) */ \
TOS = *(LocalsPtr -(num)); \
case ID_LOCAL_STORE
: /* ( n i <local> -- , store n in local ) */
*(LocalsPtr
- TOS
) = M_POP
;
#define LOCAL_STORE_N(num) \
case ID_LOCAL_STORE_##num: /* ( n <local> -- , store n in local ) */ \
*(LocalsPtr - (num)) = TOS; \
case ID_LOCAL_PLUSSTORE
: /* ( n i <local> -- , add n to local ) */
*(LocalsPtr
- TOS
) += M_POP
;
case ID_LOCAL_ENTRY
: /* ( x0 x1 ... xn n -- ) */
/* create local stack frame */
DBUG(("LocalEntry: n = %d\n", TOS
));
/* End of locals. Create stack frame */
DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",
DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n",
*lp
++ = M_POP
; /* Load local vars from stack */
case ID_LOCAL_EXIT
: /* cleanup up local stack frame */
DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",
LocalsPtr
= (cell
*) M_R_POP
;
DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",
MSG("Load "); MSG(SYSTEM_LOAD_FILE
); EMIT_CR
;
FileID
= sdOpenFile(SYSTEM_LOAD_FILE
, "r");
Scratch
= ffIncludeFile( FileID
);
if( Scratch
) M_THROW(Scratch
);
ERR(SYSTEM_LOAD_FILE
); ERR(" could not be opened!\n");
#endif /* !PF_NO_SHELL */
case ID_LEAVE_P
: /* ( R: index limit -- ) */
case ID_LOOP_P
: /* ( R: index limit -- | index limit ) */
Temp
= M_R_POP
; /* limit */
Scratch
= M_R_POP
+ 1; /* index */
InsPtr
++; /* skip branch offset, exit loop */
/* Push index and limit back to R */
/* Branch back to just after (DO) */
case ID_LSHIFT
: BINARY_OP( << ); endcase
;
TOS
= ( TOS
> Scratch
) ? TOS
: Scratch
;
TOS
= ( TOS
< Scratch
) ? TOS
: Scratch
;
case ID_MINUS
: BINARY_OP( - ); endcase
;
TOS
= (cell
) NameToToken((ForthString
*)TOS
);
case ID_NAME_TO_PREVIOUS
:
TOS
= (cell
) NameToPrevious((ForthString
*)TOS
);
case ID_OR
: BINARY_OP( | ); endcase
;
case ID_PICK
: /* ( ... n -- sp(n) ) */
case ID_PLUS
: BINARY_OP( + ); endcase
;
case ID_PLUS_STORE
: /* ( n addr -- , add n to *addr ) */
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
Scratch
= READ_LONG_DIC((cell
*)TOS
);
WRITE_LONG_DIC((cell
*)TOS
,Scratch
);
case ID_PLUSLOOP_P
: /* ( delta -- ) ( R: index limit -- | index limit ) */
ucell OldIndex
, NewIndex
, Limit
;
NewIndex
= OldIndex
+ TOS
; /* add TOS to index, not 1 */
/* Do indices cross boundary between LIMIT-1 and LIMIT ? */
if( ( (OldIndex
- Limit
) & ((Limit
-1) - NewIndex
) & 0x80000000 ) ||
( (NewIndex
- Limit
) & ((Limit
-1) - OldIndex
) & 0x80000000 ) )
InsPtr
++; /* skip branch offset, exit loop */
/* Push index and limit back to R */
/* Branch back to just after (DO) */
case ID_QDO_P
: /* (?DO) ( limit start -- ) ( R: -- start limit ) */
Scratch
= M_POP
; /* limit */
/* Branch to just after (LOOP) */
InsPtr
++; /* skip branch offset, enter loop */
case ID_QDUP
: if( TOS
) M_DUP
; endcase
;
case ID_QTERMINAL
: /* WARNING: Typically not fully implemented! */
case ID_QUIT_P
: /* Stop inner interpreter, go back to user. */
TOS
= (ffRefill() > 0) ? FTRUE
: FFALSE
;
/* Resize memory allocated by ALLOCATE. */
case ID_RESIZE
: /* ( addr1 u -- addr2 result ) */
FreePtr
= (cell
*) ( M_POP
- sizeof(cell
) );
if( ((uint32
)*FreePtr
) != ((uint32
)FreePtr
^ PF_MEMORY_VALIDATOR
))
CellPtr
= (cell
*) pfAllocMem( TOS
+ sizeof(cell
) );
/* Copy memory including validation. */
pfCopyMemory( (char *) CellPtr
, (char *) FreePtr
, TOS
+ sizeof(cell
) );
*CellPtr
= (cell
)(((uint32
)CellPtr
) ^ (uint32
)PF_MEMORY_VALIDATOR
);
M_PUSH( (cell
) ++CellPtr
);
pfFreeMem((char *) FreePtr
);
TOS
= -4; /* FIXME Fix error code. */
** RP@ and RP! are called secondaries so we must
** account for the return address pushed before calling.
case ID_RP_FETCH
: /* ( -- rp , address of top of return stack ) */
TOS
= (cell
)TORPTR
; /* value before calling RP@ */
case ID_RP_STORE
: /* ( rp -- , address of top of return stack ) */
case ID_ROLL
: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */
srcPtr
= &M_STACK(TOS
-1);
for( ri
=0; ri
<TOS
; ri
++ )
case ID_ROT
: /* ( a b c -- b c a ) */
M_PUSH( Scratch
); /* b */
/* Logical right shift */
case ID_RSHIFT
: { TOS
= ((uint32
)M_POP
) >> TOS
; } endcase
;
case ID_SAVE_FORTH_P
: /* ( $name Entry NameSize CodeSize -- err ) */
int32 NameSize
, CodeSize
, EntryPoint
;
ForthStringToC( gScratch
, (char *) M_POP
);
TOS
= ffSaveForth( gScratch
, EntryPoint
, NameSize
, CodeSize
);
** EVALUATE >IN SourceID=(-1) 1111
** keyboard >IN SourceID=(0) 2222
** file >IN lineNumber filePos SourceID=(fileID)
case ID_SAVE_INPUT
: /* FIXME - finish */
case ID_SP_FETCH
: /* ( -- sp , address of top of stack, sorta ) */
case ID_SP_STORE
: /* ( sp -- , address of top of stack, sorta ) */
case ID_STORE
: /* ( n addr -- , write n to addr ) */
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
WRITE_LONG_DIC((cell
*)TOS
,M_POP
);
case ID_SCAN
: /* ( addr cnt char -- addr' cnt' ) */
Scratch
= M_POP
; /* cnt */
TOS
= ffScan( (char *) Temp
, Scratch
, (char) TOS
, &CharPtr
);
if( Scratch
) M_THROW( Scratch
);
#endif /* !PF_NO_SHELL */
case ID_SKIP
: /* ( addr cnt char -- addr' cnt' ) */
Scratch
= M_POP
; /* cnt */
TOS
= ffSkip( (char *) Temp
, Scratch
, (char) TOS
, &CharPtr
);
case ID_SOURCE
: /* ( -- c-addr num ) */
M_PUSH( (cell
) gCurrentTask
->td_SourcePtr
);
TOS
= (cell
) gCurrentTask
->td_SourceNum
;
case ID_SOURCE_SET
: /* ( c-addr num -- ) */
gCurrentTask
->td_SourcePtr
= (char *) M_POP
;
gCurrentTask
->td_SourceNum
= TOS
;
TOS
= ffConvertStreamToSourceID( gCurrentTask
->td_InputStream
) ;
TOS
= ffConvertStreamToSourceID( ffPopInputStream() ) ;
case ID_SOURCE_ID_PUSH
: /* ( source-id -- ) */
TOS
= (cell
)ffConvertSourceIDToStream( TOS
);
Scratch
= ffPushInputStream((FileStream
*) TOS
);
case ID_THROW
: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */
CharPtr
= (char *) ffWord( (char) ' ' );
TOS
= ffFind( CharPtr
, (ExecToken
*) &Temp
);
ERR("' could not find ");
ioType( (char *) CharPtr
+1, *CharPtr
);
#endif /* !PF_NO_SHELL */
case ID_TIMES
: BINARY_OP( * ); endcase
;
Scratch
= M_POP
; /* addr */
ioType( (char *) Scratch
, TOS
);
case ID_VAR_BASE
: DO_VAR(gVarBase
); endcase
;
case ID_VAR_CODE_BASE
: DO_VAR(gCurrentDictionary
->dic_CodeBase
); endcase
;
case ID_VAR_CODE_LIMIT
: DO_VAR(gCurrentDictionary
->dic_CodeLimit
); endcase
;
case ID_VAR_CONTEXT
: DO_VAR(gVarContext
); endcase
;
case ID_VAR_DP
: DO_VAR(gCurrentDictionary
->dic_CodePtr
.Cell
); endcase
;
case ID_VAR_ECHO
: DO_VAR(gVarEcho
); endcase
;
case ID_VAR_HEADERS_BASE
: DO_VAR(gCurrentDictionary
->dic_HeaderBase
); endcase
;
case ID_VAR_HEADERS_LIMIT
: DO_VAR(gCurrentDictionary
->dic_HeaderLimit
); endcase
;
case ID_VAR_HEADERS_PTR
: DO_VAR(gCurrentDictionary
->dic_HeaderPtr
.Cell
); endcase
;
case ID_VAR_NUM_TIB
: DO_VAR(gCurrentTask
->td_SourceNum
); endcase
;
case ID_VAR_OUT
: DO_VAR(gCurrentTask
->td_OUT
); endcase
;
case ID_VAR_STATE
: DO_VAR(gVarState
); endcase
;
case ID_VAR_TO_IN
: DO_VAR(gCurrentTask
->td_IN
); endcase
;
case ID_VAR_TRACE_FLAGS
: DO_VAR(gVarTraceFlags
); endcase
;
case ID_VAR_TRACE_LEVEL
: DO_VAR(gVarTraceLevel
); endcase
;
case ID_VAR_TRACE_STACK
: DO_VAR(gVarTraceStack
); endcase
;
case ID_VAR_RETURN_CODE
: DO_VAR(gVarReturnCode
); endcase
;
TOS
= (cell
) ffWord( (char) TOS
);
case ID_WORD_FETCH
: /* ( waddr -- w ) */
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
TOS
= (uint16
) READ_SHORT_DIC((uint16
*)TOS
);
case ID_WORD_STORE
: /* ( w waddr -- ) */
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
WRITE_SHORT_DIC((uint16
*)TOS
,(uint16
)M_POP
);
*((uint16
*)TOS
) = (uint16
) M_POP
;
*((uint16
*)TOS
) = (uint16
) M_POP
;
case ID_XOR
: BINARY_OP( ^ ); endcase
;
/* Branch is followed by an offset relative to address of offset. */
DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr
));
InsPtr
++; /* skip over offset */
DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr
));
ERR("pfCatch: Unrecognised token = 0x");
ffDotHex((int32
) InsPtr
);
if(InsPtr
) Token
= READ_LONG_DIC(InsPtr
++); /* Traverse to next token in secondary. */
if( _CrtCheckMemory() == 0 )
ERR("_CrtCheckMemory abort: InsPtr = 0x");
} while( (InitialReturnStack
- TORPTR
) > 0 );
return ExceptionReturnCode
;