**\r
***************************************************************/\r
\r
+#include <sys/types.h>\r
+\r
#include "pf_all.h"\r
\r
-#ifdef WIN32\r
+#if defined(WIN32) && !defined(__MINGW32__)\r
#include <crtdbg.h>\r
#endif\r
\r
\r
#define STKPTR (DataStackPtr)\r
#define M_POP (*(STKPTR++))\r
-#define M_PUSH(n) {*(--(STKPTR)) = (cell) (n);}\r
+#define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);}\r
#define M_STACK(n) (STKPTR[n])\r
\r
#define TOS (TopOfStack)\r
#define M_R_DROP {TORPTR++;}\r
#define M_R_POP (*(TORPTR++))\r
#define M_R_PICK(n) (TORPTR[n])\r
-#define M_R_PUSH(n) {*(--(TORPTR)) = (cell) (n);}\r
+#define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);}\r
\r
/***************************************************************\r
** Misc Forth macros\r
***************************************************************/\r
\r
-#define M_BRANCH { InsPtr = (cell *) (((uint8 *) InsPtr) + READ_LONG_DIC(InsPtr)); }\r
+#define M_BRANCH { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); }\r
\r
/* Cache top of data stack like in JForth. */\r
#ifdef PF_SUPPORT_FP\r
ffDotS( ); \\r
LOAD_REGISTERS;\r
\r
-#define DO_VAR(varname) { PUSH_TOS; TOS = (cell) &varname; }\r
+#define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; }\r
\r
#ifdef PF_SUPPORT_FP\r
#define M_THROW(err) \\r
#define TRACENAMES /* no names */\r
#else\r
/* Display name of executing routine. */\r
-static void TraceNames( ExecToken Token, int32 Level )\r
+static void TraceNames( ExecToken Token, cell_t Level )\r
{\r
char *DebugName;\r
- int32 i;\r
+ cell_t i;\r
\r
if( ffTokenToName( Token, &DebugName ) )\r
{\r
- cell NumSpaces;\r
+ cell_t NumSpaces;\r
if( gCurrentTask->td_OUT > 0 ) EMIT_CR;\r
EMIT( '>' );\r
for( i=0; i<Level; i++ )\r
#endif /* PF_NO_SHELL */\r
\r
/* Use local copy of CODE_BASE for speed. */\r
-#define LOCAL_CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CodeBase))\r
+#define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))\r
\r
static const char *pfSelectFileModeCreate( int fam );\r
static const char *pfSelectFileModeOpen( int fam );\r
/**************************************************************/\r
int pfCatch( ExecToken XT )\r
{\r
- register cell TopOfStack; /* Cache for faster execution. */\r
- register cell *DataStackPtr;\r
- register cell *ReturnStackPtr;\r
- register cell *InsPtr = NULL;\r
- register cell Token;\r
- cell Scratch;\r
+ register cell_t TopOfStack; /* Cache for faster execution. */\r
+ register cell_t *DataStackPtr;\r
+ register cell_t *ReturnStackPtr;\r
+ register cell_t *InsPtr = NULL;\r
+ register cell_t Token;\r
+ cell_t Scratch;\r
\r
#ifdef PF_SUPPORT_FP\r
PF_FLOAT fpTopOfStack;\r
PF_FLOAT *InitialFloatStack;\r
#endif\r
#ifdef PF_SUPPORT_TRACE\r
- int32 Level = 0;\r
+ cell_t Level = 0;\r
#endif\r
- cell *LocalsPtr = NULL;\r
- cell Temp;\r
- cell *InitialReturnStack;\r
- cell *InitialDataStack;\r
- cell FakeSecondary[2];\r
+ cell_t *LocalsPtr = NULL;\r
+ cell_t Temp;\r
+ cell_t *InitialReturnStack;\r
+ cell_t *InitialDataStack;\r
+ cell_t FakeSecondary[2];\r
char *CharPtr;\r
- cell *CellPtr;\r
+ cell_t *CellPtr;\r
FileStream *FileID;\r
- uint8 *CodeBase = CODE_BASE;\r
+ uint8_t *CodeBase = (uint8_t *) CODE_BASE;\r
ThrowCode ExceptionReturnCode = 0;\r
\r
/* FIXME\r
M_R_PUSH( InsPtr );\r
\r
/* Convert execution token to absolute address. */\r
- InsPtr = (cell *) ( LOCAL_CODEREL_TO_ABS(Token) );\r
+ InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) );\r
\r
/* Fetch token at IP. */\r
- Token = READ_LONG_DIC(InsPtr++);\r
+ Token = READ_CELL_DIC(InsPtr++);\r
\r
#ifdef PF_SUPPORT_TRACE\r
/* Bump level for trace display */\r
** Used to implement semicolon.\r
** Put first in switch because ID_EXIT==0 */\r
case ID_EXIT:\r
- InsPtr = ( cell *) M_R_POP;\r
+ InsPtr = ( cell_t *) M_R_POP;\r
#ifdef PF_SUPPORT_TRACE\r
Level--;\r
#endif\r
case ID_2LITERAL_P:\r
/* hi part stored first, put on top of stack */\r
PUSH_TOS;\r
- TOS = READ_LONG_DIC(InsPtr++);\r
- M_PUSH(READ_LONG_DIC(InsPtr++));\r
+ TOS = READ_CELL_DIC(InsPtr++);\r
+ M_PUSH(READ_CELL_DIC(InsPtr++));\r
endcase;\r
\r
case ID_2MINUS: TOS -= 2; endcase;\r
\r
case ID_ALITERAL_P:\r
PUSH_TOS;\r
- TOS = (cell) LOCAL_CODEREL_TO_ABS( READ_LONG_DIC(InsPtr++) );\r
+ TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) );\r
endcase;\r
\r
/* Allocate some extra and put validation identifier at base */\r
#define PF_MEMORY_VALIDATOR (0xA81B4D69)\r
case ID_ALLOCATE:\r
/* Allocate at least one cell's worth because we clobber first cell. */\r
- if ( TOS < sizeof(cell) )\r
+ if ( TOS < sizeof(cell_t) )\r
{\r
- Temp = sizeof(cell);\r
+ Temp = sizeof(cell_t);\r
}\r
else\r
{\r
Temp = TOS;\r
}\r
/* Allocate extra cells worth because we store validation info. */\r
- CellPtr = (cell *) pfAllocMem( Temp + sizeof(cell) );\r
+ CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) );\r
if( CellPtr )\r
{\r
/* This was broken into two steps because different compilers incremented\r
** CellPtr before or after the XOR step. */\r
- Temp = (int32)CellPtr ^ PF_MEMORY_VALIDATOR;\r
+ Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR;\r
*CellPtr++ = Temp;\r
- M_PUSH( (cell) CellPtr );\r
+ M_PUSH( (cell_t) CellPtr );\r
TOS = 0;\r
}\r
else\r
\r
case ID_CALL_C:\r
SAVE_REGISTERS;\r
- Scratch = READ_LONG_DIC(InsPtr++);\r
+ Scratch = READ_CELL_DIC(InsPtr++);\r
CallUserFunction( Scratch & 0xFFFF,\r
(Scratch >> 31) & 1,\r
(Scratch >> 24) & 0x7F );\r
LOAD_REGISTERS;\r
endcase;\r
-\r
- case ID_CFETCH: TOS = *((uint8 *) TOS); endcase;\r
+ \r
+ /* Support 32/64 bit operation. */\r
+ case ID_CELL:\r
+ M_PUSH( TOS );\r
+ TOS = sizeof(cell_t);\r
+ endcase;\r
+ \r
+ case ID_CELLS:\r
+ TOS = TOS * sizeof(cell_t);\r
+ endcase;\r
+ \r
+ case ID_CFETCH: TOS = *((uint8_t *) TOS); endcase;\r
\r
case ID_CMOVE: /* ( src dst n -- ) */\r
{\r
register char *DstPtr = (char *) M_POP; /* dst */\r
CharPtr = (char *) M_POP; /* src */\r
- for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ )\r
+ for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )\r
{\r
*DstPtr++ = *CharPtr++;\r
}\r
{\r
register char *DstPtr = ((char *) M_POP) + TOS; /* dst */\r
CharPtr = ((char *) M_POP) + TOS;; /* src */\r
- for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ )\r
+ for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ )\r
{\r
*(--DstPtr) = *(--CharPtr);\r
}\r
case ID_COMPARE:\r
{\r
const char *s1, *s2;\r
- int32 len1;\r
+ cell_t len1;\r
s2 = (const char *) M_POP;\r
len1 = M_POP;\r
s1 = (const char *) M_POP;\r
TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ;\r
endcase;\r
case ID_COMP_U_GREATERTHAN:\r
- TOS = ( ((uint32)M_POP) > ((uint32)TOS) ) ? FTRUE : FFALSE ;\r
+ TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ;\r
endcase;\r
case ID_COMP_U_LESSTHAN:\r
- TOS = ( ((uint32)M_POP) < ((uint32)TOS) ) ? FTRUE : FFALSE ;\r
+ TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ;\r
endcase;\r
case ID_COMP_ZERO_EQUAL:\r
TOS = ( TOS == 0 ) ? FTRUE : FFALSE ;\r
case ID_CREATE_P:\r
PUSH_TOS;\r
/* Put address of body on stack. Insptr points after code start. */\r
- TOS = (cell) ((char *)InsPtr - sizeof(cell) + CREATE_BODY_OFFSET );\r
+ TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET );\r
endcase;\r
\r
case ID_CSTORE: /* ( c caddr -- ) */\r
- *((uint8 *) TOS) = (uint8) M_POP;\r
+ *((uint8_t *) TOS) = (uint8_t) M_POP;\r
M_DROP;\r
endcase;\r
\r
/* Double precision add. */\r
case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ \r
{\r
- register ucell ah,al,bl,sh,sl;\r
+ register ucell_t ah,al,bl,sh,sl;\r
#define bh TOS\r
bl = M_POP;\r
ah = M_POP;\r
/* Double precision subtract. */\r
case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */ \r
{\r
- register ucell ah,al,bl,sh,sl;\r
+ register ucell_t ah,al,bl,sh,sl;\r
#define bh TOS\r
bl = M_POP;\r
ah = M_POP;\r
}\r
endcase;\r
\r
-/* Perform 32*32 bit multiply for 64 bit result, by factoring into 16 bit quantities. */\r
-/* Using an improved algorithm suggested by Steve Green. */\r
- case ID_D_UMTIMES: /* M* ( a b -- pl ph ) */ \r
+/* Assume 8-bit char and calculate cell width. */\r
+#define NBITS ((sizeof(ucell_t)) * 8)\r
+/* Define half the number of bits in a cell. */\r
+#define HNBITS (NBITS / 2)\r
+/* Assume two-complement arithmetic to calculate lower half. */\r
+#define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1))\r
+#define HIGH_BIT ((ucell_t)1 << (NBITS - 1))\r
+\r
+/* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities.\r
+ * Using an improved algorithm suggested by Steve Green.\r
+ * Converted to 64-bit by Aleksej Saushev.\r
+ */\r
+ case ID_D_UMTIMES: /* UM* ( a b -- lo hi ) */ \r
{\r
- ucell ahi, alo, bhi, blo, temp;\r
- ucell pl, ph;\r
+ ucell_t ahi, alo, bhi, blo; /* input parts */\r
+ ucell_t lo, hi, temp;\r
/* Get values from stack. */\r
ahi = M_POP;\r
bhi = TOS;\r
/* Break into hi and lo 16 bit parts. */\r
- alo = ahi & 0xFFFF;\r
- ahi = ahi>>16;\r
- blo = bhi & 0xFFFF;\r
- bhi = bhi>>16;\r
- ph = 0;\r
-/* ahi * bhi */\r
- pl = ahi * bhi;\r
- ph = pl >> 16; /* shift 64 bit value by 16 */\r
- pl = pl << 16;\r
-/* ahi * blo */\r
+ alo = LOWER_HALF(ahi);\r
+ ahi = ahi >> HNBITS;\r
+ blo = LOWER_HALF(bhi);\r
+ bhi = bhi >> HNBITS;\r
+\r
+ lo = 0;\r
+ hi = 0;\r
+/* higher part: ahi * bhi */\r
+ hi += ahi * bhi;\r
+/* middle (overlapping) part: ahi * blo */\r
temp = ahi * blo;\r
- pl += temp;\r
- if( pl < temp ) ph += 1; /* Carry */\r
-/* alo * bhi */\r
+ lo += LOWER_HALF(temp);\r
+ hi += temp >> HNBITS;\r
+/* middle (overlapping) part: alo * bhi */\r
temp = alo * bhi;\r
- pl += temp;\r
- if( pl < temp ) ph += 1; /* Carry */\r
- ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */\r
- pl = pl << 16;\r
-/* alo * blo */\r
+ lo += LOWER_HALF(temp);\r
+ hi += temp >> HNBITS;\r
+/* lower part: alo * blo */\r
temp = alo * blo;\r
- pl += temp;\r
- if( pl < temp ) ph += 1; /* Carry */\r
-\r
- M_PUSH( pl );\r
- TOS = ph;\r
+/* its higher half overlaps with middle's lower half: */\r
+ lo += temp >> HNBITS;\r
+/* process carry: */\r
+ hi += lo >> HNBITS;\r
+ lo = LOWER_HALF(lo);\r
+/* combine lower part of result: */\r
+ lo = (lo << HNBITS) + LOWER_HALF(temp);\r
+\r
+ M_PUSH( lo );\r
+ TOS = hi;\r
}\r
endcase;\r
\r
-/* Perform 32*32 bit multiply for 64 bit result, using shift and add. */\r
+/* Perform cell*cell bit multiply for 2 cell result, using shift and add. */\r
case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ \r
{\r
- cell a,b;\r
- ucell ap,bp, ahi, alo, bhi, blo, temp;\r
- ucell pl, ph;\r
+ ucell_t ahi, alo, bhi, blo; /* input parts */\r
+ ucell_t lo, hi, temp;\r
+ int sg;\r
/* Get values from stack. */\r
- a = M_POP;\r
- b = TOS;\r
- ap = (a < 0) ? -a : a ; /* Positive A */\r
- bp = (b < 0) ? -b : b ; /* Positive B */\r
+ ahi = M_POP;\r
+ bhi = TOS;\r
+\r
+/* Calculate product sign: */\r
+ sg = ((cell_t)(ahi ^ bhi) < 0);\r
+/* Take absolute values and reduce to um* */\r
+ if ((cell_t)ahi < 0) ahi = (ucell_t)(-ahi);\r
+ if ((cell_t)bhi < 0) bhi = (ucell_t)(-bhi);\r
+\r
/* Break into hi and lo 16 bit parts. */\r
- alo = ap & 0xFFFF;\r
- ahi = ap>>16;\r
- blo = bp & 0xFFFF;\r
- bhi = bp>>16;\r
- ph = 0;\r
-/* ahi * bhi */\r
- pl = ahi * bhi;\r
- ph = pl >> 16; /* shift 64 bit value by 16 */\r
- pl = pl << 16;\r
-/* ahi * blo */\r
+ alo = LOWER_HALF(ahi);\r
+ ahi = ahi >> HNBITS;\r
+ blo = LOWER_HALF(bhi);\r
+ bhi = bhi >> HNBITS;\r
+\r
+ lo = 0;\r
+ hi = 0;\r
+/* higher part: ahi * bhi */\r
+ hi += ahi * bhi;\r
+/* middle (overlapping) part: ahi * blo */\r
temp = ahi * blo;\r
- pl += temp;\r
- if( pl < temp ) ph += 1; /* Carry */\r
-/* alo * bhi */\r
+ lo += LOWER_HALF(temp);\r
+ hi += temp >> HNBITS;\r
+/* middle (overlapping) part: alo * bhi */\r
temp = alo * bhi;\r
- pl += temp;\r
- if( pl < temp ) ph += 1; /* Carry */\r
- ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */\r
- pl = pl << 16;\r
-/* alo * blo */\r
+ lo += LOWER_HALF(temp);\r
+ hi += temp >> HNBITS;\r
+/* lower part: alo * blo */\r
temp = alo * blo;\r
- pl += temp;\r
- if( pl < temp ) ph += 1; /* Carry */\r
+/* its higher half overlaps with middle's lower half: */\r
+ lo += temp >> HNBITS;\r
+/* process carry: */\r
+ hi += lo >> HNBITS;\r
+ lo = LOWER_HALF(lo);\r
+/* combine lower part of result: */\r
+ lo = (lo << HNBITS) + LOWER_HALF(temp);\r
\r
/* Negate product if one operand negative. */\r
- if( ((a ^ b) & 0x80000000) )\r
+ if(sg)\r
{\r
- pl = 0-pl;\r
- if( pl & 0x80000000 )\r
- {\r
- ph = -1 - ph; /* Borrow */\r
- }\r
- else\r
- {\r
- ph = 0 - ph;\r
- }\r
+ /* lo = (ucell_t)(- lo); */\r
+ lo = ~lo + 1;\r
+ hi = ~hi + ((lo == 0) ? 1 : 0);\r
}\r
\r
- M_PUSH( pl );\r
- TOS = ph;\r
+ M_PUSH( lo );\r
+ TOS = hi;\r
}\r
endcase;\r
\r
#define DULT(du1l,du1h,du2l,du2h) ( (du2h<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )\r
-/* Perform 64/32 bit divide for 32 bit result, using shift and subtract. */\r
+/* Perform 2 cell by 1 cell divide for 1 cell result and remainder, using shift and subtract. */\r
case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */ \r
{\r
- ucell ah,al, q,di, bl,bh, sl,sh;\r
+ ucell_t ah,al, q,di, bl,bh, sl,sh;\r
ah = M_POP;\r
al = M_POP;\r
bh = TOS;\r
bl = 0;\r
q = 0;\r
- for( di=0; di<32; di++ )\r
+ for( di=0; di<NBITS; di++ )\r
{\r
if( !DULT(al,ah,bl,bh) )\r
{\r
q |= 1;\r
}\r
q = q << 1;\r
- bl = (bl >> 1) | (bh << 31);\r
+ bl = (bl >> 1) | (bh << (NBITS-1));\r
bh = bh >> 1;\r
}\r
if( !DULT(al,ah,bl,bh) )\r
}\r
endcase;\r
\r
-/* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */\r
+/* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */\r
case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ \r
{\r
- register ucell ah,am,al,ql,qh,di;\r
-#define bdiv ((ucell)TOS)\r
+ register ucell_t ah,am,al,ql,qh,di;\r
+#define bdiv ((ucell_t)TOS)\r
ah = 0;\r
am = M_POP;\r
al = M_POP;\r
qh = ql = 0;\r
- for( di=0; di<64; di++ )\r
+ for( di=0; di<2*NBITS; di++ )\r
{\r
if( bdiv <= ah )\r
{\r
ah = ah - bdiv;\r
ql |= 1;\r
}\r
- qh = (qh << 1) | (ql >> 31);\r
+ qh = (qh << 1) | (ql >> (NBITS-1));\r
ql = ql << 1;\r
- ah = (ah << 1) | (am >> 31);\r
- am = (am << 1) | (al >> 31);\r
+ ah = (ah << 1) | (am >> (NBITS-1));\r
+ am = (am << 1) | (al >> (NBITS-1));\r
al = al << 1;\r
DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));\r
}\r
\r
case ID_EOL: /* ( -- end_of_line_char ) */\r
PUSH_TOS;\r
- TOS = (cell) '\n';\r
+ TOS = (cell_t) '\n';\r
endcase;\r
\r
case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */\r
#endif\r
if( IsTokenPrimitive( TOS ) )\r
{\r
- WRITE_LONG_DIC( (cell *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */\r
+ WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */\r
InsPtr = &FakeSecondary[0];\r
}\r
else\r
{\r
- InsPtr = (cell *) LOCAL_CODEREL_TO_ABS(TOS);\r
+ InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS);\r
}\r
M_DROP;\r
endcase;\r
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
if( IN_DICS( TOS ) )\r
{\r
- TOS = (cell) READ_LONG_DIC((cell *)TOS);\r
+ TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS);\r
}\r
else\r
{\r
- TOS = *((cell *)TOS);\r
+ TOS = *((cell_t *)TOS);\r
}\r
#else\r
- TOS = *((cell *)TOS);\r
+ TOS = *((cell_t *)TOS);\r
#endif\r
endcase;\r
\r
if( Scratch < TIB_SIZE-2 )\r
{\r
const char *famText = pfSelectFileModeCreate( TOS );\r
- pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch );\r
+ pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r
gScratch[Scratch] = '\0';\r
- PRT(("Create file = %s with famTxt %s\n", gScratch, famText ));\r
+ DBUG(("Create file = %s with famTxt %s\n", gScratch, famText ));\r
FileID = sdOpenFile( gScratch, famText );\r
TOS = ( FileID == NULL ) ? -1 : 0 ;\r
- M_PUSH( (cell) FileID );\r
+ M_PUSH( (cell_t) FileID );\r
}\r
else\r
{\r
}\r
endcase;\r
\r
+ case ID_FILE_DELETE: /* ( c-addr u -- ior ) */\r
+/* Build NUL terminated name string. */\r
+ Temp = M_POP; /* caddr */\r
+ if( TOS < TIB_SIZE-2 )\r
+ {\r
+ pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS );\r
+ gScratch[TOS] = '\0';\r
+ DBUG(("Delete file = %s\n", gScratch ));\r
+ TOS = sdDeleteFile( gScratch );\r
+ }\r
+ else\r
+ {\r
+ ERR("Filename too large for name buffer.\n");\r
+ TOS = -2;\r
+ }\r
+ endcase;\r
+\r
case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */\r
/* Build NUL terminated name string. */\r
Scratch = M_POP; /* u */\r
if( Scratch < TIB_SIZE-2 )\r
{\r
const char *famText = pfSelectFileModeOpen( TOS );\r
- pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch );\r
+ pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch );\r
gScratch[Scratch] = '\0';\r
DBUG(("Open file = %s\n", gScratch ));\r
FileID = sdOpenFile( gScratch, famText );\r
\r
TOS = ( FileID == NULL ) ? -1 : 0 ;\r
- M_PUSH( (cell) FileID );\r
+ M_PUSH( (cell_t) FileID );\r
}\r
else\r
{\r
case ID_FILE_SIZE: /* ( fid -- ud ior ) */\r
/* Determine file size by seeking to end and returning position. */\r
FileID = (FileStream *) TOS;\r
- Scratch = sdTellFile( FileID );\r
- sdSeekFile( FileID, 0, PF_SEEK_END );\r
- M_PUSH( sdTellFile( FileID ));\r
- sdSeekFile( FileID, Scratch, PF_SEEK_SET );\r
- TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */\r
+ {\r
+ off_t endposition, offsetHi;\r
+ off_t original = sdTellFile( FileID );\r
+ sdSeekFile( FileID, 0, PF_SEEK_END );\r
+ endposition = sdTellFile( FileID );\r
+ M_PUSH(endposition);\r
+ /* Just use a 0 if they are the same size. */\r
+ offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (endposition >> (8*sizeof(cell_t))) : 0 ;\r
+ M_PUSH(offsetHi);\r
+ sdSeekFile( FileID, original, PF_SEEK_SET );\r
+ TOS = (original < 0) ? -4 : 0 ; /* !!! err num */\r
+ }\r
endcase;\r
\r
case ID_FILE_WRITE: /* ( addr len fid -- ior ) */\r
TOS = (Temp != Scratch) ? -3 : 0;\r
endcase;\r
\r
- case ID_FILE_REPOSITION: /* ( pos fid -- ior ) */\r
- FileID = (FileStream *) TOS;\r
- Scratch = M_POP;\r
- TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET );\r
+ case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */ \r
+ {\r
+ off_t offset;\r
+ FileID = (FileStream *) TOS;\r
+ offset = M_POP;\r
+ /* Avoid compiler warnings on Mac. */\r
+ offset = (sizeof(off_t) > sizeof(cell_t)) ? (offset << 8*sizeof(cell_t)) : 0 ;\r
+ offset += M_POP;\r
+ TOS = sdSeekFile( FileID, offset, PF_SEEK_SET );\r
+ }\r
endcase;\r
\r
- case ID_FILE_POSITION: /* ( pos fid -- ior ) */\r
- M_PUSH( sdTellFile( (FileStream *) TOS ));\r
- TOS = 0;\r
+ case ID_FILE_POSITION: /* ( fid -- ud ior ) */\r
+ {\r
+ off_t position;\r
+ off_t offsetHi;\r
+ FileID = (FileStream *) TOS;\r
+ position = sdTellFile( FileID );\r
+ M_PUSH(position);\r
+ /* Just use a 0 if they are the same size. */\r
+ offsetHi = (sizeof(off_t) > sizeof(cell_t)) ? (position >> (8*sizeof(cell_t))) : 0 ;\r
+ M_PUSH(offsetHi);\r
+ TOS = (position < 0) ? -4 : 0 ; /* !!! err num */\r
+ }\r
endcase;\r
\r
case ID_FILE_RO: /* ( -- fam ) */\r
register char *DstPtr;\r
Temp = M_POP; /* num */\r
DstPtr = (char *) M_POP; /* dst */\r
- for( Scratch=0; (uint32) Scratch < (uint32) Temp ; Scratch++ )\r
+ for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ )\r
{\r
*DstPtr++ = (char) TOS;\r
}\r
\r
case ID_FINDNFA:\r
TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp );\r
- M_PUSH( (cell) Temp );\r
+ M_PUSH( (cell_t) Temp );\r
endcase;\r
#endif /* !PF_NO_SHELL */\r
\r
}\r
else\r
{\r
- CellPtr = (cell *) TOS;\r
+ CellPtr = (cell_t *) TOS;\r
CellPtr--;\r
- if( ((uint32)*CellPtr) != ((uint32)CellPtr ^ PF_MEMORY_VALIDATOR))\r
+ if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR))\r
{\r
TOS = -2; /* FIXME error code */\r
}\r
\r
case ID_HERE:\r
PUSH_TOS;\r
- TOS = (cell)CODE_HERE;\r
+ TOS = (cell_t)CODE_HERE;\r
endcase;\r
\r
case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */\r
/* Convert using number converter in 'C'.\r
** Only supports single precision for bootstrap.\r
*/\r
- TOS = (cell) ffNumberQ( (char *) TOS, &Temp );\r
+ TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp );\r
if( TOS == NUM_TYPE_SINGLE)\r
{\r
M_PUSH( Temp ); /* Push single number */\r
case ID_LITERAL_P:\r
DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr ));\r
PUSH_TOS;\r
- TOS = READ_LONG_DIC(InsPtr++);\r
+ TOS = READ_CELL_DIC(InsPtr++);\r
endcase;\r
\r
#ifndef PF_NO_SHELL\r
case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */\r
/* create local stack frame */\r
{\r
- int32 i = TOS;\r
- cell *lp;\r
+ cell_t i = TOS;\r
+ cell_t *lp;\r
DBUG(("LocalEntry: n = %d\n", TOS));\r
/* End of locals. Create stack frame */\r
DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n",\r
DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n",\r
TORPTR, LocalsPtr));\r
TORPTR = LocalsPtr;\r
- LocalsPtr = (cell *) M_R_POP;\r
+ LocalsPtr = (cell_t *) M_R_POP;\r
DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n",\r
TORPTR, LocalsPtr));\r
endcase;\r
if( FileID )\r
{\r
SAVE_REGISTERS;\r
- Scratch = ffIncludeFile( FileID );\r
+ Scratch = ffIncludeFile( FileID ); /* Also closes the file. */\r
LOAD_REGISTERS;\r
- sdCloseFile( FileID );\r
if( Scratch ) M_THROW(Scratch);\r
}\r
else\r
\r
#ifndef PF_NO_SHELL\r
case ID_NAME_TO_TOKEN:\r
- TOS = (cell) NameToToken((ForthString *)TOS);\r
+ TOS = (cell_t) NameToToken((ForthString *)TOS);\r
endcase;\r
\r
case ID_NAME_TO_PREVIOUS:\r
- TOS = (cell) NameToPrevious((ForthString *)TOS);\r
+ TOS = (cell_t) NameToPrevious((ForthString *)TOS);\r
endcase;\r
#endif\r
\r
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
if( IN_DICS( TOS ) )\r
{\r
- Scratch = READ_LONG_DIC((cell *)TOS);\r
+ Scratch = READ_CELL_DIC((cell_t *)TOS);\r
Scratch += M_POP;\r
- WRITE_LONG_DIC((cell *)TOS,Scratch);\r
+ WRITE_CELL_DIC((cell_t *)TOS,Scratch);\r
}\r
else\r
{\r
- *((cell *)TOS) += M_POP;\r
+ *((cell_t *)TOS) += M_POP;\r
}\r
#else\r
- *((cell *)TOS) += M_POP;\r
+ *((cell_t *)TOS) += M_POP;\r
#endif\r
M_DROP;\r
endcase;\r
\r
case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */\r
{\r
- ucell OldIndex, NewIndex, Limit;\r
+ ucell_t OldIndex, NewIndex, Limit;\r
\r
Limit = M_R_POP;\r
OldIndex = M_R_POP;\r
/* Resize memory allocated by ALLOCATE. */\r
case ID_RESIZE: /* ( addr1 u -- addr2 result ) */\r
{\r
- cell *FreePtr;\r
- \r
- FreePtr = (cell *) ( M_POP - sizeof(cell) );\r
- if( ((uint32)*FreePtr) != ((uint32)FreePtr ^ PF_MEMORY_VALIDATOR))\r
+ cell_t *Addr1 = (cell_t *) M_POP;\r
+ /* Point to validator below users address. */\r
+ cell_t *FreePtr = Addr1 - 1;\r
+ if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR))\r
{\r
- M_PUSH( 0 );\r
+ /* 090218 - Fixed bug, was returning zero. */\r
+ M_PUSH( Addr1 );\r
TOS = -3;\r
}\r
else\r
{\r
/* Try to allocate. */\r
- CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) );\r
+ CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) );\r
if( CellPtr )\r
{\r
/* Copy memory including validation. */\r
- pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell) );\r
- *CellPtr = (cell)(((uint32)CellPtr) ^ (uint32)PF_MEMORY_VALIDATOR);\r
- CellPtr++;\r
- M_PUSH( (cell) ++CellPtr );\r
- TOS = 0;\r
+ pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) );\r
+ *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR);\r
+ /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */\r
+ /* Increment past validator to user address. */\r
+ M_PUSH( (cell_t) (CellPtr + 1) );\r
+ TOS = 0; /* Result code. */\r
+ /* Mark old cell as dead so we can't free it twice. */\r
FreePtr[0] = 0xDeadBeef;\r
pfFreeMem((char *) FreePtr);\r
}\r
else\r
{\r
- M_PUSH( 0 );\r
+ /* 090218 - Fixed bug, was returning zero. */\r
+ M_PUSH( Addr1 );\r
TOS = -4; /* FIXME Fix error code. */\r
}\r
}\r
*/\r
case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */\r
PUSH_TOS;\r
- TOS = (cell)TORPTR; /* value before calling RP@ */\r
+ TOS = (cell_t)TORPTR; /* value before calling RP@ */\r
endcase;\r
\r
case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */\r
- TORPTR = (cell *) TOS;\r
+ TORPTR = (cell_t *) TOS;\r
M_DROP;\r
endcase;\r
\r
case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */\r
{\r
- int32 ri;\r
- cell *srcPtr, *dstPtr;\r
+ cell_t ri;\r
+ cell_t *srcPtr, *dstPtr;\r
Scratch = M_STACK(TOS);\r
srcPtr = &M_STACK(TOS-1);\r
dstPtr = &M_STACK(TOS);\r
endcase;\r
\r
/* Logical right shift */\r
- case ID_RSHIFT: { TOS = ((uint32)M_POP) >> TOS; } endcase; \r
+ case ID_RSHIFT: { TOS = ((ucell_t)M_POP) >> TOS; } endcase; \r
\r
#ifndef PF_NO_SHELL\r
case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */\r
{\r
- int32 NameSize, CodeSize, EntryPoint;\r
+ cell_t NameSize, CodeSize, EntryPoint;\r
CodeSize = TOS;\r
NameSize = M_POP;\r
EntryPoint = M_POP;\r
- ForthStringToC( gScratch, (char *) M_POP );\r
+ ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) );\r
TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize );\r
}\r
endcase;\r
\r
case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */\r
PUSH_TOS;\r
- TOS = (cell)STKPTR;\r
+ TOS = (cell_t)STKPTR;\r
endcase;\r
\r
case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */\r
- STKPTR = (cell *) TOS;\r
+ STKPTR = (cell_t *) TOS;\r
M_DROP;\r
endcase;\r
\r
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
if( IN_DICS( TOS ) )\r
{\r
- WRITE_LONG_DIC((cell *)TOS,M_POP);\r
+ WRITE_CELL_DIC((cell_t *)TOS,M_POP);\r
}\r
else\r
{\r
- *((cell *)TOS) = M_POP;\r
+ *((cell_t *)TOS) = M_POP;\r
}\r
#else\r
- *((cell *)TOS) = M_POP;\r
+ *((cell_t *)TOS) = M_POP;\r
#endif\r
M_DROP;\r
endcase;\r
Scratch = M_POP; /* cnt */\r
Temp = M_POP; /* addr */\r
TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
- M_PUSH((cell) CharPtr);\r
+ M_PUSH((cell_t) CharPtr);\r
endcase;\r
\r
#ifndef PF_NO_SHELL\r
Scratch = M_POP; /* cnt */\r
Temp = M_POP; /* addr */\r
TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr );\r
- M_PUSH((cell) CharPtr);\r
+ M_PUSH((cell_t) CharPtr);\r
endcase;\r
\r
case ID_SOURCE: /* ( -- c-addr num ) */\r
PUSH_TOS;\r
- M_PUSH( (cell) gCurrentTask->td_SourcePtr );\r
- TOS = (cell) gCurrentTask->td_SourceNum;\r
+ M_PUSH( (cell_t) gCurrentTask->td_SourcePtr );\r
+ TOS = (cell_t) gCurrentTask->td_SourceNum;\r
endcase;\r
\r
case ID_SOURCE_SET: /* ( c-addr num -- ) */\r
endcase;\r
\r
case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */\r
- TOS = (cell)ffConvertSourceIDToStream( TOS );\r
+ TOS = (cell_t)ffConvertSourceIDToStream( TOS );\r
Scratch = ffPushInputStream((FileStream *) TOS );\r
if( Scratch )\r
{\r
case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase;\r
case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase;\r
case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase;\r
- case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr.Cell); endcase;\r
+ case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase;\r
case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase;\r
case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase;\r
case ID_VAR_STATE: DO_VAR(gVarState); endcase;\r
case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase;\r
\r
case ID_WORD:\r
- TOS = (cell) ffWord( (char) TOS );\r
+ TOS = (cell_t) ffWord( (char) TOS );\r
endcase;\r
\r
case ID_WORD_FETCH: /* ( waddr -- w ) */\r
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
if( IN_DICS( TOS ) )\r
{\r
- TOS = (uint16) READ_SHORT_DIC((uint16 *)TOS);\r
+ TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);\r
}\r
else\r
{\r
- TOS = *((uint16 *)TOS);\r
+ TOS = *((uint16_t *)TOS);\r
}\r
#else\r
- TOS = *((uint16 *)TOS);\r
+ TOS = *((uint16_t *)TOS);\r
#endif\r
endcase;\r
\r
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
if( IN_DICS( TOS ) )\r
{\r
- WRITE_SHORT_DIC((uint16 *)TOS,(uint16)M_POP);\r
+ WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);\r
}\r
else\r
{\r
- *((uint16 *)TOS) = (uint16) M_POP;\r
+ *((uint16_t *)TOS) = (uint16_t) M_POP;\r
}\r
#else\r
- *((uint16 *)TOS) = (uint16) M_POP;\r
+ *((uint16_t *)TOS) = (uint16_t) M_POP;\r
#endif\r
M_DROP;\r
endcase;\r
ERR("pfCatch: Unrecognised token = 0x");\r
ffDotHex(Token);\r
ERR(" at 0x");\r
- ffDotHex((int32) InsPtr);\r
+ ffDotHex((cell_t) InsPtr);\r
EMIT_CR;\r
InsPtr = 0;\r
endcase;\r
}\r
\r
- if(InsPtr) Token = READ_LONG_DIC(InsPtr++); /* Traverse to next token in secondary. */\r
+ if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */\r
\r
#ifdef PF_DEBUG\r
M_DOTS;\r