/* @(#) 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 <sys/types.h>

#include "pf_all.h"

#ifdef WIN32
#include <crtdbg.h>
#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; i<Level; i++ )
		{
			MSG( "  " );
		}
		TypeName( DebugName );
/* Space out to column N then .S */
		NumSpaces = 30 - gCurrentTask->td_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<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
/* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */
		case ID_D_UMSMOD:  /* UM/MOD ( al ah bdiv -- rem q ) */ 
			{
				ucell_t ah,al, q,di, bl,bh, sl,sh;
				ah = M_POP;
				al = M_POP;
				bh = TOS;
				bl = 0;
				q = 0;
				for( di=0; di<NBITS; di++ )
				{
					if( !DULT(al,ah,bl,bh) )
					{
						sh = 0;
						sl = al - bl;
						if( al < bl ) sh = 1; /* Borrow */
						sh = ah - bh - sh;
						ah = sh;
						al = sl;
						q |= 1;
					}
					q = q << 1;
					bl = (bl >> 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 <local> -- n , fetch from local ) */
			TOS = *(LocalsPtr - TOS);
			endcase;

#define LOCAL_FETCH_N(num) \
		case ID_LOCAL_FETCH_##num: /* ( <local> -- 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 <local> -- , store n in local ) */
			*(LocalsPtr - TOS) = M_POP;
			M_DROP;
			endcase;

#define LOCAL_STORE_N(num) \
		case ID_LOCAL_STORE_##num:  /* ( n <local> -- , 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 <local> -- , 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; ri++ )
				{
					*dstPtr-- = *srcPtr--;
				}
				TOS = Scratch;
				STKPTR++;
			}
			endcase;

		case ID_ROT:  /* ( a b c -- b c a ) */
			Scratch = M_POP;    /* b */
			Temp = M_POP;       /* a */
			M_PUSH( Scratch );  /* b */
			PUSH_TOS;           /* c */
			TOS = Temp;         /* a */
			endcase;

/* Logical right shift */
		case ID_RSHIFT:     { TOS = ((ucell_t)M_POP) >> 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;
}
