projects / pforth / blobdiff
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Fix REPOSITION-FILE, HISTORY, locked file handle and other problems.
[pforth] / csrc / pf_inner.c
diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c
index 87c8613..0149da0 100644 (file)
--- a/csrc/pf_inner.c
+++ b/csrc/pf_inner.c
@@ -278,7 +278,7 @@ int pfCatch( ExecToken XT )
        char          *CharPtr;\r
        cell_t        *CellPtr;\r
        FileStream    *FileID;\r
        char          *CharPtr;\r
        cell_t        *CellPtr;\r
        FileStream    *FileID;\r
-       uint8_t         *CodeBase = CODE_BASE;\r
+       uint8_t       *CodeBase = (uint8_t *) CODE_BASE;\r
        ThrowCode      ExceptionReturnCode = 0;\r
        \r
 /* FIXME\r
        ThrowCode      ExceptionReturnCode = 0;\r
        \r
 /* FIXME\r
@@ -661,102 +661,117 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
                        }\r
                        endcase;\r
                        \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:  /* UM* ( 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
                        {\r
-                               ucell_t ahi, alo, bhi, blo, temp;\r
-                               ucell_t 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
 /* 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
                                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
                                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
                                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
                        }\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
                case ID_D_MTIMES:  /* M* ( a b -- pl ph ) */ \r
                        {\r
-                               cell_t a,b;\r
-                               ucell_t ap,bp, ahi, alo, bhi, blo, temp;\r
-                               ucell_t 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
 /* 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
 /* 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
                                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
                                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
                                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
 \r
 /* Negate product if one operand negative. */\r
-                               if( ((a ^ b) & 0x80000000) )\r
+                               if(sg)\r
                                {\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
                                }\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
                        }\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_t ah,al, q,di, bl,bh, sl,sh;\r
                case ID_D_UMSMOD:  /* UM/MOD ( al ah bdiv -- rem q ) */ \r
                        {\r
                                ucell_t ah,al, q,di, bl,bh, sl,sh;\r
@@ -765,7 +780,7 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
                                bh = TOS;\r
                                bl = 0;\r
                                q = 0;\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
                                {\r
                                        if( !DULT(al,ah,bl,bh) )\r
                                        {\r
@@ -778,7 +793,7 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
                                                q |= 1;\r
                                        }\r
                                        q = q << 1;\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
                                        bh = bh >> 1;\r
                                }\r
                                if( !DULT(al,ah,bl,bh) )\r
@@ -792,7 +807,7 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
                        }\r
                        endcase;\r
 \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_t ah,am,al,ql,qh,di;\r
                case ID_D_MUSMOD:  /* MU/MOD ( al am bdiv -- rem ql qh ) */ \r
                        {\r
                                register ucell_t ah,am,al,ql,qh,di;\r
@@ -801,7 +816,6 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr ));
                                am = M_POP;\r
                                al = M_POP;\r
                                qh = ql = 0;\r
                                am = M_POP;\r
                                al = M_POP;\r
                                qh = ql = 0;\r
-#define NBITS (sizeof(cell_t)*8)\r
                                for( di=0; di<2*NBITS; di++ )\r
                                {\r
                                        if( bdiv <= ah )\r
                                for( di=0; di<2*NBITS; di++ )\r
                                {\r
                                        if( bdiv <= ah )\r
@@ -948,6 +962,23 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
                        }\r
                        endcase;\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
                case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */\r
 /* Build NUL terminated name string. */\r
                        Scratch = M_POP; /* u */\r
@@ -987,11 +1018,18 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
                case ID_FILE_SIZE: /* ( fid -- ud ior ) */\r
 /* Determine file size by seeking to end and returning position. */\r
                        FileID = (FileStream *) TOS;\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
                        endcase;\r
 \r
                case ID_FILE_WRITE: /* ( addr len fid -- ior ) */\r
@@ -1002,15 +1040,28 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
                        TOS = (Temp != Scratch) ? -3 : 0;\r
                        endcase;\r
 \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
+                               FileID = (FileStream *) TOS;\r
+                               off_t 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
                        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 offsetHi;\r
+                               FileID = (FileStream *) TOS;\r
+                               off_t 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
                        endcase;\r
 \r
                case ID_FILE_RO: /* (  -- fam ) */\r
@@ -1238,9 +1289,8 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
                        if( FileID )\r
                        {\r
                                SAVE_REGISTERS;\r
                        if( FileID )\r
                        {\r
                                SAVE_REGISTERS;\r
-                               Scratch = ffIncludeFile( FileID );\r
+                               Scratch = ffIncludeFile( FileID ); /* Also closes the file. */\r
                                LOAD_REGISTERS;\r
                                LOAD_REGISTERS;\r
-                               sdCloseFile( FileID );\r
                                if( Scratch ) M_THROW(Scratch);\r
                        }\r
                        else\r
                                if( Scratch ) M_THROW(Scratch);\r
                        }\r
                        else\r
@@ -1522,7 +1572,7 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
                        if( IN_DICS( TOS ) )\r
                        {\r
 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
                        if( IN_DICS( TOS ) )\r
                        {\r
-                               WRITE_CELL_DIC(TOS,M_POP);\r
+                               WRITE_CELL_DIC((cell_t *)TOS,M_POP);\r
                        }\r
                        else\r
                        {\r
                        }\r
                        else\r
                        {\r
@@ -1652,7 +1702,7 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
                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_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_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
@@ -1670,7 +1720,7 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
                        if( IN_DICS( TOS ) )\r
                        {\r
 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
                        if( IN_DICS( TOS ) )\r
                        {\r
-                               TOS = (uint16_t) READ_SHORT_DIC((uint8_t *)TOS);\r
+                               TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS);\r
                        }\r
                        else\r
                        {\r
                        }\r
                        else\r
                        {\r
@@ -1686,7 +1736,7 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql ));
 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
                        if( IN_DICS( TOS ) )\r
                        {\r
 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
                        if( IN_DICS( TOS ) )\r
                        {\r
-                               WRITE_SHORT_DIC(TOS,M_POP);\r
+                               WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP);\r
                        }\r
                        else\r
                        {\r
                        }\r
                        else\r
                        {\r
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.