/* @(#) pf_inner.c 98/03/16 1.7 */ /*************************************************************** ** Inner Interpreter for Forth based on 'C' ** ** Author: Phil Burk ** 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. ** **************************************************************** ** ** 940502 PLB Creation. ** 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, ** and ID_HERE for armcc ** 941130 PLB Made w@ unsigned ** ***************************************************************/ #include #include "pf_all.h" #ifdef WIN32 #include #endif #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_t) (n);} #define M_STACK(n) (STKPTR[n]) #define TOS (TopOfStack) #define PUSH_TOS M_PUSH(TOS) #define M_DUP PUSH_TOS; #define M_DROP { TOS = M_POP; } /*************************************************************** ** Macros for Floating Point stack access. ***************************************************************/ #ifdef PF_SUPPORT_FP #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; } #endif /*************************************************************** ** 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_t) (n);} /*************************************************************** ** Misc Forth macros ***************************************************************/ #define M_BRANCH { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); } /* Cache top of data stack like in JForth. */ #ifdef PF_SUPPORT_FP #define LOAD_REGISTERS \ { \ STKPTR = gCurrentTask->td_StackPtr; \ TOS = M_POP; \ FP_STKPTR = gCurrentTask->td_FloatStackPtr; \ FP_TOS = M_FP_POP; \ TORPTR = gCurrentTask->td_ReturnPtr; \ } #define SAVE_REGISTERS \ { \ gCurrentTask->td_ReturnPtr = TORPTR; \ M_PUSH( TOS ); \ gCurrentTask->td_StackPtr = STKPTR; \ M_FP_PUSH( FP_TOS ); \ gCurrentTask->td_FloatStackPtr = FP_STKPTR; \ } #else /* Cache top of data stack like in JForth. */ #define LOAD_REGISTERS \ { \ STKPTR = gCurrentTask->td_StackPtr; \ TOS = M_POP; \ TORPTR = gCurrentTask->td_ReturnPtr; \ } #define SAVE_REGISTERS \ { \ gCurrentTask->td_ReturnPtr = TORPTR; \ M_PUSH( TOS ); \ gCurrentTask->td_StackPtr = STKPTR; \ } #endif #define M_DOTS \ SAVE_REGISTERS; \ ffDotS( ); \ LOAD_REGISTERS; #define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; } #ifdef PF_SUPPORT_FP #define M_THROW(err) \ { \ ExceptionReturnCode = (ThrowCode)(err); \ TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \ STKPTR = InitialDataStack; \ FP_STKPTR = InitialFloatStack; \ } #else #define M_THROW(err) \ { \ ExceptionReturnCode = (err); \ TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \ STKPTR = InitialDataStack; \ } #endif /*************************************************************** ** Other macros ***************************************************************/ #define BINARY_OP( op ) { TOS = M_POP op TOS; } #define endcase break #if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE) #define TRACENAMES /* no names */ #else /* Display name of executing routine. */ static void TraceNames( ExecToken Token, cell_t Level ) { char *DebugName; cell_t i; if( ffTokenToName( Token, &DebugName ) ) { cell_t NumSpaces; if( gCurrentTask->td_OUT > 0 ) EMIT_CR; EMIT( '>' ); for( i=0; itd_OUT; for( i=0; i < NumSpaces; i++ ) { EMIT( ' ' ); } ffDotS(); /* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */ } else { MSG_NUM_H("Couldn't find Name for ", Token); } } #define TRACENAMES \ if( (gVarTraceLevel > Level) ) \ { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; } #endif /* PF_NO_SHELL */ /* Use local copy of CODE_BASE for speed. */ #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase)) static const char *pfSelectFileModeCreate( int fam ); static const char *pfSelectFileModeOpen( int fam ); /**************************************************************/ static const char *pfSelectFileModeCreate( int fam ) { const char *famText = NULL; switch( fam ) { case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_CREATE_WO; break; case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_CREATE_RW; break; case PF_FAM_WRITE_ONLY: famText = PF_FAM_CREATE_WO; break; case PF_FAM_READ_WRITE: famText = PF_FAM_CREATE_RW; break; default: famText = "illegal"; break; } return famText; } /**************************************************************/ static const char *pfSelectFileModeOpen( int fam ) { const char *famText = NULL; switch( fam ) { case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_OPEN_RO; break; case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_CREATE_WO; break; case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_OPEN_RW; break; case PF_FAM_READ_ONLY: famText = PF_FAM_OPEN_RO; break; case PF_FAM_WRITE_ONLY: famText = PF_FAM_CREATE_WO; break; case PF_FAM_READ_WRITE: default: famText = PF_FAM_OPEN_RW; break; } return famText; } /**************************************************************/ int pfCatch( ExecToken XT ) { register cell_t TopOfStack; /* Cache for faster execution. */ register cell_t *DataStackPtr; register cell_t *ReturnStackPtr; register cell_t *InsPtr = NULL; register cell_t Token; cell_t Scratch; #ifdef PF_SUPPORT_FP PF_FLOAT fpTopOfStack; PF_FLOAT *FloatStackPtr; PF_FLOAT fpScratch; PF_FLOAT fpTemp; PF_FLOAT *InitialFloatStack; #endif #ifdef PF_SUPPORT_TRACE cell_t Level = 0; #endif cell_t *LocalsPtr = NULL; cell_t Temp; cell_t *InitialReturnStack; cell_t *InitialDataStack; cell_t FakeSecondary[2]; char *CharPtr; cell_t *CellPtr; FileStream *FileID; uint8_t *CodeBase = (uint8_t *) CODE_BASE; ThrowCode ExceptionReturnCode = 0; /* FIXME gExecutionDepth += 1; 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[0] = 0; FakeSecondary[1] = ID_EXIT; /* For EXECUTE */ /* Move data from task structure to registers for speed. */ LOAD_REGISTERS; /* Save initial stack depths for THROW */ InitialReturnStack = TORPTR; InitialDataStack = STKPTR ; #ifdef PF_SUPPORT_FP InitialFloatStack = FP_STKPTR; #endif Token = XT; do { DBUG(("pfCatch: Token = 0x%x\n", Token )); /* --------------------------------------------------------------- */ /* If secondary, thread down code tree until we hit a primitive. */ while( !IsTokenPrimitive( Token ) ) { #ifdef PF_SUPPORT_TRACE if((gVarTraceFlags & TRACE_INNER) ) { MSG("pfCatch: Secondary Token = 0x"); ffDotHex(Token); MSG_NUM_H(", InsPtr = 0x", InsPtr); } TRACENAMES; #endif /* Save IP on return stack like a JSR. */ M_R_PUSH( InsPtr ); /* Convert execution token to absolute address. */ InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) ); /* Fetch token at IP. */ Token = READ_CELL_DIC(InsPtr++); #ifdef PF_SUPPORT_TRACE /* Bump level for trace display */ Level++; #endif } #ifdef PF_SUPPORT_TRACE TRACENAMES; #endif /* Execute primitive Token. */ switch( Token ) { /* Pop up a level in Forth inner interpreter. ** Used to implement semicolon. ** Put first in switch because ID_EXIT==0 */ case ID_EXIT: InsPtr = ( cell_t *) M_R_POP; #ifdef PF_SUPPORT_TRACE Level--; #endif endcase; case ID_1MINUS: TOS--; endcase; case ID_1PLUS: TOS++; endcase; #ifndef PF_NO_SHELL case ID_2LITERAL: ff2Literal( TOS, M_POP ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_2LITERAL_P: /* hi part stored first, put on top of stack */ PUSH_TOS; TOS = READ_CELL_DIC(InsPtr++); M_PUSH(READ_CELL_DIC(InsPtr++)); endcase; 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 ) */ PUSH_TOS; Scratch = M_STACK(3); M_PUSH(Scratch); TOS = M_STACK(3); endcase; 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 */ Scratch = TOS; /* d */ TOS = M_STACK(1); /* b */ M_STACK(1) = Scratch; /* d */ endcase; case ID_2DUP: /* ( a b -- a b a b ) */ PUSH_TOS; Scratch = M_STACK(1); M_PUSH(Scratch); endcase; case ID_2_R_FETCH: PUSH_TOS; M_PUSH( (*(TORPTR+1)) ); TOS = (*(TORPTR)); endcase; case ID_2_R_FROM: PUSH_TOS; TOS = M_R_POP; M_PUSH( M_R_POP ); endcase; case ID_2_TO_R: M_R_PUSH( M_POP ); M_R_PUSH( TOS ); M_DROP; endcase; case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */ CharPtr = (char *) M_POP; TOS = ioAccept( CharPtr, TOS ); endcase; #ifndef PF_NO_SHELL case ID_ALITERAL: ffALiteral( ABS_TO_CODEREL(TOS) ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_ALITERAL_P: PUSH_TOS; TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) ); endcase; /* Allocate some extra and put validation identifier at base */ #define PF_MEMORY_VALIDATOR (0xA81B4D69) case ID_ALLOCATE: /* Allocate at least one cell's worth because we clobber first cell. */ if ( TOS < sizeof(cell_t) ) { Temp = sizeof(cell_t); } else { Temp = TOS; } /* Allocate extra cells worth because we store validation info. */ CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) ); if( CellPtr ) { /* This was broken into two steps because different compilers incremented ** CellPtr before or after the XOR step. */ Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR; *CellPtr++ = Temp; M_PUSH( (cell_t) CellPtr ); TOS = 0; } else { M_PUSH( 0 ); TOS = -1; /* FIXME Fix error code. */ } endcase; case ID_AND: BINARY_OP( & ); endcase; case ID_ARSHIFT: BINARY_OP( >> ); endcase; /* Arithmetic right shift */ case ID_BODY_OFFSET: PUSH_TOS; TOS = CREATE_BODY_OFFSET; endcase; /* Branch is followed by an offset relative to address of offset. */ case ID_BRANCH: DBUGX(("Before Branch: IP = 0x%x\n", InsPtr )); M_BRANCH; DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); endcase; case ID_BYE: M_THROW( THROW_BYE ); endcase; case ID_BAIL: MSG("Emergency exit.\n"); EXIT(1); endcase; case ID_CATCH: Scratch = TOS; TOS = M_POP; SAVE_REGISTERS; Scratch = pfCatch( Scratch ); LOAD_REGISTERS; M_PUSH( TOS ); TOS = Scratch; endcase; case ID_CALL_C: SAVE_REGISTERS; Scratch = READ_CELL_DIC(InsPtr++); CallUserFunction( Scratch & 0xFFFF, (Scratch >> 31) & 1, (Scratch >> 24) & 0x7F ); LOAD_REGISTERS; endcase; /* Support 32/64 bit operation. */ case ID_CELL: M_PUSH( TOS ); TOS = sizeof(cell_t); endcase; case ID_CELLS: TOS = TOS * sizeof(cell_t); endcase; case ID_CFETCH: TOS = *((uint8_t *) TOS); endcase; case ID_CMOVE: /* ( src dst n -- ) */ { register char *DstPtr = (char *) M_POP; /* dst */ CharPtr = (char *) M_POP; /* src */ for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ ) { *DstPtr++ = *CharPtr++; } M_DROP; } endcase; case ID_CMOVE_UP: /* ( src dst n -- ) */ { register char *DstPtr = ((char *) M_POP) + TOS; /* dst */ CharPtr = ((char *) M_POP) + TOS;; /* src */ for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ ) { *(--DstPtr) = *(--CharPtr); } M_DROP; } endcase; #ifndef PF_NO_SHELL case ID_COLON: SAVE_REGISTERS; ffColon( ); LOAD_REGISTERS; endcase; case ID_COLON_P: /* ( $name xt -- ) */ CreateDicEntry( TOS, (char *) M_POP, 0 ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_COMPARE: { const char *s1, *s2; cell_t len1; s2 = (const char *) M_POP; len1 = M_POP; s1 = (const char *) M_POP; TOS = ffCompare( s1, len1, s2, TOS ); } endcase; /* ( a b -- flag , Comparisons ) */ case ID_COMP_EQUAL: TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ; endcase; case ID_COMP_NOT_EQUAL: TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ; endcase; case ID_COMP_GREATERTHAN: TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ; endcase; case ID_COMP_LESSTHAN: TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ; endcase; case ID_COMP_U_GREATERTHAN: TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ; endcase; case ID_COMP_U_LESSTHAN: TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ; endcase; case ID_COMP_ZERO_EQUAL: TOS = ( TOS == 0 ) ? FTRUE : FFALSE ; endcase; case ID_COMP_ZERO_NOT_EQUAL: TOS = ( TOS != 0 ) ? FTRUE : FALSE ; endcase; case ID_COMP_ZERO_GREATERTHAN: TOS = ( TOS > 0 ) ? FTRUE : FFALSE ; endcase; case ID_COMP_ZERO_LESSTHAN: TOS = ( TOS < 0 ) ? FTRUE : FFALSE ; endcase; case ID_CR: EMIT_CR; endcase; #ifndef PF_NO_SHELL case ID_CREATE: SAVE_REGISTERS; ffCreate(); LOAD_REGISTERS; endcase; #endif /* !PF_NO_SHELL */ case ID_CREATE_P: PUSH_TOS; /* Put address of body on stack. Insptr points after code start. */ TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET ); endcase; case ID_CSTORE: /* ( c caddr -- ) */ *((uint8_t *) TOS) = (uint8_t) M_POP; M_DROP; endcase; /* Double precision add. */ case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ { register ucell_t ah,al,bl,sh,sl; #define bh TOS bl = M_POP; ah = M_POP; al = M_POP; sh = 0; sl = al + bl; if( sl < bl ) sh = 1; /* Carry */ sh += ah + bh; M_PUSH( sl ); TOS = sh; #undef bh } endcase; /* Double precision subtract. */ case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */ { register ucell_t ah,al,bl,sh,sl; #define bh TOS bl = M_POP; ah = M_POP; al = M_POP; sh = 0; sl = al - bl; if( al < bl ) sh = 1; /* Borrow */ sh = ah - bh - sh; M_PUSH( sl ); TOS = sh; #undef bh } endcase; /* Assume 8-bit char and calculate cell width. */ #define NBITS ((sizeof(ucell_t)) * 8) /* Define half the number of bits in a cell. */ #define HNBITS (NBITS / 2) /* Assume two-complement arithmetic to calculate lower half. */ #define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1)) #define HIGH_BIT ((ucell_t)1 << (NBITS - 1)) /* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities. * Using an improved algorithm suggested by Steve Green. * Converted to 64-bit by Aleksej Saushev. */ case ID_D_UMTIMES: /* UM* ( a b -- lo hi ) */ { ucell_t ahi, alo, bhi, blo; /* input parts */ ucell_t lo, hi, temp; /* Get values from stack. */ ahi = M_POP; bhi = TOS; /* Break into hi and lo 16 bit parts. */ alo = LOWER_HALF(ahi); ahi = ahi >> HNBITS; blo = LOWER_HALF(bhi); bhi = bhi >> HNBITS; lo = 0; hi = 0; /* higher part: ahi * bhi */ hi += ahi * bhi; /* middle (overlapping) part: ahi * blo */ temp = ahi * blo; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* middle (overlapping) part: alo * bhi */ temp = alo * bhi; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* lower part: alo * blo */ temp = alo * blo; /* its higher half overlaps with middle's lower half: */ lo += temp >> HNBITS; /* process carry: */ hi += lo >> HNBITS; lo = LOWER_HALF(lo); /* combine lower part of result: */ lo = (lo << HNBITS) + LOWER_HALF(temp); M_PUSH( lo ); TOS = hi; } endcase; /* Perform cell*cell bit multiply for 2 cell result, using shift and add. */ case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ { ucell_t ahi, alo, bhi, blo; /* input parts */ ucell_t lo, hi, temp; int sg; /* Get values from stack. */ ahi = M_POP; bhi = TOS; /* Calculate product sign: */ sg = ((cell_t)(ahi ^ bhi) < 0); /* Take absolute values and reduce to um* */ if ((cell_t)ahi < 0) ahi = (ucell_t)(-ahi); if ((cell_t)bhi < 0) bhi = (ucell_t)(-bhi); /* Break into hi and lo 16 bit parts. */ alo = LOWER_HALF(ahi); ahi = ahi >> HNBITS; blo = LOWER_HALF(bhi); bhi = bhi >> HNBITS; lo = 0; hi = 0; /* higher part: ahi * bhi */ hi += ahi * bhi; /* middle (overlapping) part: ahi * blo */ temp = ahi * blo; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* middle (overlapping) part: alo * bhi */ temp = alo * bhi; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* lower part: alo * blo */ temp = alo * blo; /* its higher half overlaps with middle's lower half: */ lo += temp >> HNBITS; /* process carry: */ hi += lo >> HNBITS; lo = LOWER_HALF(lo); /* combine lower part of result: */ lo = (lo << HNBITS) + LOWER_HALF(temp); /* Negate product if one operand negative. */ if(sg) { /* lo = (ucell_t)(- lo); */ lo = ~lo + 1; hi = ~hi + ((lo == 0) ? 1 : 0); } M_PUSH( lo ); TOS = hi; } endcase; #define DULT(du1l,du1h,du2l,du2h) ( (du2h> 1) | (bh << (NBITS-1)); bh = bh >> 1; } if( !DULT(al,ah,bl,bh) ) { al = al - bl; q |= 1; } M_PUSH( al ); /* rem */ TOS = q; } endcase; /* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */ case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ { register ucell_t ah,am,al,ql,qh,di; #define bdiv ((ucell_t)TOS) ah = 0; am = M_POP; al = M_POP; qh = ql = 0; for( di=0; di<2*NBITS; di++ ) { if( bdiv <= ah ) { ah = ah - bdiv; ql |= 1; } qh = (qh << 1) | (ql >> (NBITS-1)); ql = ql << 1; ah = (ah << 1) | (am >> (NBITS-1)); am = (am << 1) | (al >> (NBITS-1)); al = al << 1; DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); } if( bdiv <= ah ) { ah = ah - bdiv; ql |= 1; } M_PUSH( ah ); /* rem */ M_PUSH( ql ); TOS = qh; #undef bdiv } endcase; #ifndef PF_NO_SHELL case ID_DEFER: ffDefer( ); endcase; #endif /* !PF_NO_SHELL */ case ID_DEFER_P: endcase; case ID_DEPTH: PUSH_TOS; TOS = gCurrentTask->td_StackBase - STKPTR; endcase; case ID_DIVIDE: BINARY_OP( / ); endcase; case ID_DOT: ffDot( TOS ); M_DROP; endcase; case ID_DOTS: M_DOTS; endcase; case ID_DROP: M_DROP; endcase; case ID_DUMP: Scratch = M_POP; DumpMemory( (char *) Scratch, TOS ); M_DROP; endcase; case ID_DUP: M_DUP; endcase; case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */ M_R_PUSH( TOS ); M_R_PUSH( M_POP ); M_DROP; endcase; case ID_EOL: /* ( -- end_of_line_char ) */ PUSH_TOS; TOS = (cell_t) '\n'; endcase; case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */ Scratch = TOS; M_DROP; if(TOS) { M_THROW(Scratch); } else { M_DROP; } endcase; case ID_EMIT_P: EMIT( (char) TOS ); M_DROP; endcase; case ID_EXECUTE: /* Save IP on return stack like a JSR. */ M_R_PUSH( InsPtr ); #ifdef PF_SUPPORT_TRACE /* Bump level for trace. */ Level++; #endif if( IsTokenPrimitive( TOS ) ) { WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */ InsPtr = &FakeSecondary[0]; } else { InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS); } M_DROP; endcase; case ID_FETCH: #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS); } else { TOS = *((cell_t *)TOS); } #else TOS = *((cell_t *)TOS); #endif endcase; case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */ /* Build NUL terminated name string. */ Scratch = M_POP; /* u */ Temp = M_POP; /* caddr */ if( Scratch < TIB_SIZE-2 ) { const char *famText = pfSelectFileModeCreate( TOS ); pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch ); gScratch[Scratch] = '\0'; DBUG(("Create file = %s with famTxt %s\n", gScratch, famText )); FileID = sdOpenFile( gScratch, famText ); TOS = ( FileID == NULL ) ? -1 : 0 ; M_PUSH( (cell_t) FileID ); } else { ERR("Filename too large for name buffer.\n"); M_PUSH( 0 ); TOS = -2; } endcase; case ID_FILE_DELETE: /* ( c-addr u -- ior ) */ /* Build NUL terminated name string. */ Temp = M_POP; /* caddr */ if( TOS < TIB_SIZE-2 ) { pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS ); gScratch[TOS] = '\0'; DBUG(("Delete file = %s\n", gScratch )); TOS = sdDeleteFile( gScratch ); } else { ERR("Filename too large for name buffer.\n"); TOS = -2; } endcase; case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */ /* Build NUL terminated name string. */ Scratch = M_POP; /* u */ Temp = M_POP; /* caddr */ if( Scratch < TIB_SIZE-2 ) { const char *famText = pfSelectFileModeOpen( TOS ); pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch ); gScratch[Scratch] = '\0'; DBUG(("Open file = %s\n", gScratch )); FileID = sdOpenFile( gScratch, famText ); TOS = ( FileID == NULL ) ? -1 : 0 ; M_PUSH( (cell_t) FileID ); } else { ERR("Filename too large for name buffer.\n"); M_PUSH( 0 ); TOS = -2; } endcase; case ID_FILE_CLOSE: /* ( fid -- ior ) */ TOS = sdCloseFile( (FileStream *) TOS ); endcase; case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */ FileID = (FileStream *) TOS; Scratch = M_POP; CharPtr = (char *) M_POP; Temp = sdReadFile( CharPtr, 1, Scratch, FileID ); M_PUSH(Temp); TOS = 0; endcase; case ID_FILE_SIZE: /* ( fid -- ud ior ) */ /* Determine file size by seeking to end and returning position. */ FileID = (FileStream *) TOS; { off_t endposition, offsetHi; off_t original = sdTellFile( FileID ); sdSeekFile( FileID, 0, PF_SEEK_END ); endposition = sdTellFile( FileID ); M_PUSH(endposition); /* Just use a 0 if they are the same size. */ offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (endposition >> (8*sizeof(cell_t))) : 0 ; M_PUSH(offsetHi); sdSeekFile( FileID, original, PF_SEEK_SET ); TOS = (original < 0) ? -4 : 0 ; /* !!! err num */ } endcase; case ID_FILE_WRITE: /* ( addr len fid -- ior ) */ FileID = (FileStream *) TOS; Scratch = M_POP; CharPtr = (char *) M_POP; Temp = sdWriteFile( CharPtr, 1, Scratch, FileID ); TOS = (Temp != Scratch) ? -3 : 0; endcase; case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */ { off_t offset; FileID = (FileStream *) TOS; offset = M_POP; /* Avoid compiler warnings on Mac. */ offset = (sizeof(off_t) > sizeof(cell_t)) ? (offset << 8*sizeof(cell_t)) : 0 ; offset += M_POP; TOS = sdSeekFile( FileID, offset, PF_SEEK_SET ); } endcase; case ID_FILE_POSITION: /* ( fid -- ud ior ) */ { off_t position; off_t offsetHi; FileID = (FileStream *) TOS; position = sdTellFile( FileID ); M_PUSH(position); /* Just use a 0 if they are the same size. */ offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (position >> (8*sizeof(cell_t))) : 0 ; M_PUSH(offsetHi); TOS = (position < 0) ? -4 : 0 ; /* !!! err num */ } endcase; case ID_FILE_RO: /* ( -- fam ) */ PUSH_TOS; TOS = PF_FAM_READ_ONLY; endcase; case ID_FILE_RW: /* ( -- fam ) */ PUSH_TOS; TOS = PF_FAM_READ_WRITE; endcase; case ID_FILE_WO: /* ( -- fam ) */ PUSH_TOS; TOS = PF_FAM_WRITE_ONLY; endcase; case ID_FILE_BIN: /* ( -- fam ) */ TOS = TOS | PF_FAM_BINARY_FLAG; endcase; case ID_FILL: /* ( caddr num charval -- ) */ { register char *DstPtr; Temp = M_POP; /* num */ DstPtr = (char *) M_POP; /* dst */ for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ ) { *DstPtr++ = (char) TOS; } M_DROP; } endcase; #ifndef PF_NO_SHELL case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */ TOS = ffFind( (char *) TOS, (ExecToken *) &Temp ); M_PUSH( Temp ); endcase; case ID_FINDNFA: TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp ); M_PUSH( (cell_t) Temp ); endcase; #endif /* !PF_NO_SHELL */ case ID_FLUSHEMIT: sdTerminalFlush(); endcase; /* Validate memory before freeing. Clobber validator and first word. */ case ID_FREE: /* ( addr -- result ) */ if( TOS == 0 ) { ERR("FREE passed NULL!\n"); TOS = -2; /* FIXME error code */ } else { CellPtr = (cell_t *) TOS; CellPtr--; if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR)) { TOS = -2; /* FIXME error code */ } else { CellPtr[0] = 0xDeadBeef; pfFreeMem((char *)CellPtr); TOS = 0; } } endcase; #include "pfinnrfp.h" case ID_HERE: PUSH_TOS; TOS = (cell_t)CODE_HERE; endcase; case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */ /* Convert using number converter in 'C'. ** Only supports single precision for bootstrap. */ TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp ); if( TOS == NUM_TYPE_SINGLE) { M_PUSH( Temp ); /* Push single number */ } endcase; case ID_I: /* ( -- i , DO LOOP index ) */ PUSH_TOS; TOS = M_R_PICK(1); endcase; #ifndef PF_NO_SHELL case ID_INCLUDE_FILE: FileID = (FileStream *) TOS; M_DROP; /* Drop now so that INCLUDE has a clean stack. */ SAVE_REGISTERS; Scratch = ffIncludeFile( FileID ); LOAD_REGISTERS; if( Scratch ) M_THROW(Scratch) endcase; #endif /* !PF_NO_SHELL */ #ifndef PF_NO_SHELL case ID_INTERPRET: SAVE_REGISTERS; Scratch = ffInterpret(); LOAD_REGISTERS; if( Scratch ) M_THROW(Scratch) endcase; #endif /* !PF_NO_SHELL */ case ID_J: /* ( -- j , second DO LOOP index ) */ PUSH_TOS; TOS = M_R_PICK(3); endcase; case ID_KEY: PUSH_TOS; TOS = ioKey(); endcase; #ifndef PF_NO_SHELL case ID_LITERAL: ffLiteral( TOS ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_LITERAL_P: DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr )); PUSH_TOS; TOS = READ_CELL_DIC(InsPtr++); endcase; #ifndef PF_NO_SHELL case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase; #endif /* !PF_NO_SHELL */ case ID_LOCAL_FETCH: /* ( i -- n , fetch from local ) */ TOS = *(LocalsPtr - TOS); endcase; #define LOCAL_FETCH_N(num) \ case ID_LOCAL_FETCH_##num: /* ( -- n , fetch from local ) */ \ PUSH_TOS; \ TOS = *(LocalsPtr -(num)); \ endcase; LOCAL_FETCH_N(1); LOCAL_FETCH_N(2); LOCAL_FETCH_N(3); LOCAL_FETCH_N(4); LOCAL_FETCH_N(5); LOCAL_FETCH_N(6); LOCAL_FETCH_N(7); LOCAL_FETCH_N(8); case ID_LOCAL_STORE: /* ( n i -- , store n in local ) */ *(LocalsPtr - TOS) = M_POP; M_DROP; endcase; #define LOCAL_STORE_N(num) \ case ID_LOCAL_STORE_##num: /* ( n -- , store n in local ) */ \ *(LocalsPtr - (num)) = TOS; \ M_DROP; \ endcase; LOCAL_STORE_N(1); LOCAL_STORE_N(2); LOCAL_STORE_N(3); LOCAL_STORE_N(4); LOCAL_STORE_N(5); LOCAL_STORE_N(6); LOCAL_STORE_N(7); LOCAL_STORE_N(8); case ID_LOCAL_PLUSSTORE: /* ( n i -- , add n to local ) */ *(LocalsPtr - TOS) += M_POP; M_DROP; endcase; case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */ /* create local stack frame */ { cell_t i = TOS; cell_t *lp; DBUG(("LocalEntry: n = %d\n", TOS)); /* End of locals. Create stack frame */ DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); M_R_PUSH(LocalsPtr); LocalsPtr = TORPTR; TORPTR -= TOS; DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); lp = TORPTR; while(i-- > 0) { *lp++ = M_POP; /* Load local vars from stack */ } M_DROP; } endcase; case ID_LOCAL_EXIT: /* cleanup up local stack frame */ DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); TORPTR = LocalsPtr; LocalsPtr = (cell_t *) M_R_POP; DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); endcase; #ifndef PF_NO_SHELL case ID_LOADSYS: MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR; FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r"); if( FileID ) { SAVE_REGISTERS; Scratch = ffIncludeFile( FileID ); /* Also closes the file. */ LOAD_REGISTERS; if( Scratch ) M_THROW(Scratch); } else { ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n"); } endcase; #endif /* !PF_NO_SHELL */ case ID_LEAVE_P: /* ( R: index limit -- ) */ M_R_DROP; M_R_DROP; M_BRANCH; endcase; case ID_LOOP_P: /* ( R: index limit -- | index limit ) */ Temp = M_R_POP; /* limit */ Scratch = M_R_POP + 1; /* index */ if( Scratch == Temp ) { InsPtr++; /* skip branch offset, exit loop */ } else { /* Push index and limit back to R */ M_R_PUSH( Scratch ); M_R_PUSH( Temp ); /* Branch back to just after (DO) */ M_BRANCH; } endcase; case ID_LSHIFT: BINARY_OP( << ); endcase; case ID_MAX: Scratch = M_POP; TOS = ( TOS > Scratch ) ? TOS : Scratch ; endcase; case ID_MIN: Scratch = M_POP; TOS = ( TOS < Scratch ) ? TOS : Scratch ; endcase; case ID_MINUS: BINARY_OP( - ); endcase; #ifndef PF_NO_SHELL case ID_NAME_TO_TOKEN: TOS = (cell_t) NameToToken((ForthString *)TOS); endcase; case ID_NAME_TO_PREVIOUS: TOS = (cell_t) NameToPrevious((ForthString *)TOS); endcase; #endif case ID_NOOP: endcase; case ID_OR: BINARY_OP( | ); endcase; case ID_OVER: PUSH_TOS; TOS = M_STACK(1); endcase; case ID_PICK: /* ( ... n -- sp(n) ) */ TOS = M_STACK(TOS); endcase; 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)) if( IN_DICS( TOS ) ) { Scratch = READ_CELL_DIC((cell_t *)TOS); Scratch += M_POP; WRITE_CELL_DIC((cell_t *)TOS,Scratch); } else { *((cell_t *)TOS) += M_POP; } #else *((cell_t *)TOS) += M_POP; #endif M_DROP; endcase; case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */ { ucell_t OldIndex, NewIndex, Limit; Limit = M_R_POP; OldIndex = M_R_POP; 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 */ } else { /* Push index and limit back to R */ M_R_PUSH( NewIndex ); M_R_PUSH( Limit ); /* Branch back to just after (DO) */ M_BRANCH; } M_DROP; } endcase; case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */ Scratch = M_POP; /* limit */ if( Scratch == TOS ) { /* Branch to just after (LOOP) */ M_BRANCH; } else { M_R_PUSH( TOS ); M_R_PUSH( Scratch ); InsPtr++; /* skip branch offset, enter loop */ } M_DROP; endcase; case ID_QDUP: if( TOS ) M_DUP; endcase; case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */ PUSH_TOS; TOS = sdQueryTerminal(); endcase; case ID_QUIT_P: /* Stop inner interpreter, go back to user. */ #ifdef PF_SUPPORT_TRACE Level = 0; #endif M_THROW(THROW_QUIT); endcase; case ID_R_DROP: M_R_DROP; endcase; case ID_R_FETCH: PUSH_TOS; TOS = (*(TORPTR)); endcase; case ID_R_FROM: PUSH_TOS; TOS = M_R_POP; endcase; case ID_REFILL: PUSH_TOS; TOS = (ffRefill() > 0) ? FTRUE : FFALSE; endcase; /* Resize memory allocated by ALLOCATE. */ case ID_RESIZE: /* ( addr1 u -- addr2 result ) */ { cell_t *Addr1 = (cell_t *) M_POP; /* Point to validator below users address. */ cell_t *FreePtr = Addr1 - 1; if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR)) { /* 090218 - Fixed bug, was returning zero. */ M_PUSH( Addr1 ); TOS = -3; } else { /* Try to allocate. */ CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) ); if( CellPtr ) { /* Copy memory including validation. */ pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) ); *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR); /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */ /* Increment past validator to user address. */ M_PUSH( (cell_t) (CellPtr + 1) ); TOS = 0; /* Result code. */ /* Mark old cell as dead so we can't free it twice. */ FreePtr[0] = 0xDeadBeef; pfFreeMem((char *) FreePtr); } else { /* 090218 - Fixed bug, was returning zero. */ M_PUSH( Addr1 ); TOS = -4; /* FIXME Fix error code. */ } } } endcase; /* ** 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 ) */ PUSH_TOS; TOS = (cell_t)TORPTR; /* value before calling RP@ */ endcase; case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */ TORPTR = (cell_t *) TOS; M_DROP; endcase; case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */ { cell_t ri; cell_t *srcPtr, *dstPtr; Scratch = M_STACK(TOS); srcPtr = &M_STACK(TOS-1); dstPtr = &M_STACK(TOS); for( ri=0; ri> TOS; } endcase; #ifndef PF_NO_SHELL case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */ { cell_t NameSize, CodeSize, EntryPoint; CodeSize = TOS; NameSize = M_POP; EntryPoint = M_POP; ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) ); TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize ); } endcase; #endif /* Source Stack ** EVALUATE >IN SourceID=(-1) 1111 ** keyboard >IN SourceID=(0) 2222 ** file >IN lineNumber filePos SourceID=(fileID) */ case ID_SAVE_INPUT: /* FIXME - finish */ { } endcase; case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */ PUSH_TOS; TOS = (cell_t)STKPTR; endcase; case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */ STKPTR = (cell_t *) TOS; M_DROP; endcase; case ID_STORE: /* ( n addr -- , write n to addr ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { WRITE_CELL_DIC((cell_t *)TOS,M_POP); } else { *((cell_t *)TOS) = M_POP; } #else *((cell_t *)TOS) = M_POP; #endif M_DROP; endcase; case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */ Scratch = M_POP; /* cnt */ Temp = M_POP; /* addr */ TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr ); M_PUSH((cell_t) CharPtr); endcase; #ifndef PF_NO_SHELL case ID_SEMICOLON: SAVE_REGISTERS; Scratch = ffSemiColon(); LOAD_REGISTERS; if( Scratch ) M_THROW( Scratch ); endcase; #endif /* !PF_NO_SHELL */ case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */ Scratch = M_POP; /* cnt */ Temp = M_POP; /* addr */ TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr ); M_PUSH((cell_t) CharPtr); endcase; case ID_SOURCE: /* ( -- c-addr num ) */ PUSH_TOS; M_PUSH( (cell_t) gCurrentTask->td_SourcePtr ); TOS = (cell_t) gCurrentTask->td_SourceNum; endcase; case ID_SOURCE_SET: /* ( c-addr num -- ) */ gCurrentTask->td_SourcePtr = (char *) M_POP; gCurrentTask->td_SourceNum = TOS; M_DROP; endcase; case ID_SOURCE_ID: PUSH_TOS; TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ; endcase; case ID_SOURCE_ID_POP: PUSH_TOS; TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ; endcase; case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */ TOS = (cell_t)ffConvertSourceIDToStream( TOS ); Scratch = ffPushInputStream((FileStream *) TOS ); if( Scratch ) { M_THROW(Scratch); } else M_DROP; endcase; case ID_SWAP: Scratch = TOS; TOS = *STKPTR; *STKPTR = Scratch; endcase; case ID_TEST1: PUSH_TOS; M_PUSH( 0x11 ); M_PUSH( 0x22 ); TOS = 0x33; endcase; case ID_TEST2: endcase; case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */ if(TOS) { M_THROW(TOS); } else M_DROP; endcase; #ifndef PF_NO_SHELL case ID_TICK: PUSH_TOS; CharPtr = (char *) ffWord( (char) ' ' ); TOS = ffFind( CharPtr, (ExecToken *) &Temp ); if( TOS == 0 ) { ERR("' could not find "); ioType( (char *) CharPtr+1, *CharPtr ); M_THROW(-13); } else { TOS = Temp; } endcase; #endif /* !PF_NO_SHELL */ case ID_TIMES: BINARY_OP( * ); endcase; case ID_TYPE: Scratch = M_POP; /* addr */ ioType( (char *) Scratch, TOS ); M_DROP; endcase; case ID_TO_R: M_R_PUSH( TOS ); M_DROP; endcase; 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); 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; case ID_WORD: TOS = (cell_t) ffWord( (char) TOS ); endcase; case ID_WORD_FETCH: /* ( waddr -- w ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS); } else { TOS = *((uint16_t *)TOS); } #else TOS = *((uint16_t *)TOS); #endif endcase; case ID_WORD_STORE: /* ( w waddr -- ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP); } else { *((uint16_t *)TOS) = (uint16_t) M_POP; } #else *((uint16_t *)TOS) = (uint16_t) M_POP; #endif M_DROP; endcase; case ID_XOR: BINARY_OP( ^ ); endcase; /* Branch is followed by an offset relative to address of offset. */ case ID_ZERO_BRANCH: DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr )); if( TOS == 0 ) { M_BRANCH; } else { InsPtr++; /* skip over offset */ } M_DROP; DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr )); endcase; default: ERR("pfCatch: Unrecognised token = 0x"); ffDotHex(Token); ERR(" at 0x"); ffDotHex((cell_t) InsPtr); EMIT_CR; InsPtr = 0; endcase; } if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */ #ifdef PF_DEBUG M_DOTS; #endif #if 0 if( _CrtCheckMemory() == 0 ) { ERR("_CrtCheckMemory abort: InsPtr = 0x"); ffDotHex((int)InsPtr); ERR("\n"); } #endif } while( (InitialReturnStack - TORPTR) > 0 ); SAVE_REGISTERS; return ExceptionReturnCode; }