X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/blobdiff_plain/1cb310e62eaf4422ee298d9d87c35f9dd6b4c71c..90975d261c7ab39186c75d8700261faab3427de7:/csrc/pf_inner.c diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c index 87c8613..0149da0 100644 --- a/csrc/pf_inner.c +++ b/csrc/pf_inner.c @@ -278,7 +278,7 @@ int pfCatch( ExecToken XT ) char *CharPtr; cell_t *CellPtr; FileStream *FileID; - uint8_t *CodeBase = CODE_BASE; + uint8_t *CodeBase = (uint8_t *) CODE_BASE; ThrowCode ExceptionReturnCode = 0; /* FIXME @@ -661,102 +661,117 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); } endcase; -/* Perform 32*32 bit multiply for 64 bit result, by factoring into 16 bit quantities. */ -/* Using an improved algorithm suggested by Steve Green. */ - case ID_D_UMTIMES: /* UM* ( a b -- pl ph ) */ +/* 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, temp; - ucell_t pl, ph; + 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 = ahi & 0xFFFF; - ahi = ahi>>16; - blo = bhi & 0xFFFF; - bhi = bhi>>16; - ph = 0; -/* ahi * bhi */ - pl = ahi * bhi; - ph = pl >> 16; /* shift 64 bit value by 16 */ - pl = pl << 16; -/* ahi * blo */ + 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; - pl += temp; - if( pl < temp ) ph += 1; /* Carry */ -/* alo * bhi */ + lo += LOWER_HALF(temp); + hi += temp >> HNBITS; +/* middle (overlapping) part: alo * bhi */ temp = alo * bhi; - pl += temp; - if( pl < temp ) ph += 1; /* Carry */ - ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */ - pl = pl << 16; -/* alo * blo */ + lo += LOWER_HALF(temp); + hi += temp >> HNBITS; +/* lower part: alo * blo */ temp = alo * blo; - pl += temp; - if( pl < temp ) ph += 1; /* Carry */ - - M_PUSH( pl ); - TOS = ph; +/* 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 32*32 bit multiply for 64 bit result, using shift and add. */ +/* Perform cell*cell bit multiply for 2 cell result, using shift and add. */ case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ { - cell_t a,b; - ucell_t ap,bp, ahi, alo, bhi, blo, temp; - ucell_t pl, ph; + ucell_t ahi, alo, bhi, blo; /* input parts */ + ucell_t lo, hi, temp; + int sg; /* Get values from stack. */ - a = M_POP; - b = TOS; - ap = (a < 0) ? -a : a ; /* Positive A */ - bp = (b < 0) ? -b : b ; /* Positive B */ + 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 = ap & 0xFFFF; - ahi = ap>>16; - blo = bp & 0xFFFF; - bhi = bp>>16; - ph = 0; -/* ahi * bhi */ - pl = ahi * bhi; - ph = pl >> 16; /* shift 64 bit value by 16 */ - pl = pl << 16; -/* ahi * blo */ + 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; - pl += temp; - if( pl < temp ) ph += 1; /* Carry */ -/* alo * bhi */ + lo += LOWER_HALF(temp); + hi += temp >> HNBITS; +/* middle (overlapping) part: alo * bhi */ temp = alo * bhi; - pl += temp; - if( pl < temp ) ph += 1; /* Carry */ - ph = (ph << 16) | (pl >> 16); /* shift 64 bit value by 16 */ - pl = pl << 16; -/* alo * blo */ + lo += LOWER_HALF(temp); + hi += temp >> HNBITS; +/* lower part: alo * blo */ temp = alo * blo; - pl += temp; - if( pl < temp ) ph += 1; /* Carry */ +/* 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( ((a ^ b) & 0x80000000) ) + if(sg) { - pl = 0-pl; - if( pl & 0x80000000 ) - { - ph = -1 - ph; /* Borrow */ - } - else - { - ph = 0 - ph; - } + /* lo = (ucell_t)(- lo); */ + lo = ~lo + 1; + hi = ~hi + ((lo == 0) ? 1 : 0); } - M_PUSH( pl ); - TOS = ph; + M_PUSH( lo ); + TOS = hi; } endcase; #define DULT(du1l,du1h,du2l,du2h) ( (du2h> 1) | (bh << 31); + bl = (bl >> 1) | (bh << (NBITS-1)); bh = bh >> 1; } if( !DULT(al,ah,bl,bh) ) @@ -792,7 +807,7 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); } endcase; -/* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */ +/* 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; @@ -801,7 +816,6 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); am = M_POP; al = M_POP; qh = ql = 0; -#define NBITS (sizeof(cell_t)*8) for( di=0; di<2*NBITS; di++ ) { if( bdiv <= ah ) @@ -948,6 +962,23 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); } 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 */ @@ -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 ) */ /* Determine file size by seeking to end and returning position. */ FileID = (FileStream *) TOS; - Scratch = sdTellFile( FileID ); - sdSeekFile( FileID, 0, PF_SEEK_END ); - M_PUSH( sdTellFile( FileID )); - sdSeekFile( FileID, Scratch, PF_SEEK_SET ); - TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */ + { + 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 ) */ @@ -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; endcase; - case ID_FILE_REPOSITION: /* ( pos fid -- ior ) */ - FileID = (FileStream *) TOS; - Scratch = M_POP; - TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET ); + case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */ + { + FileID = (FileStream *) TOS; + off_t 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: /* ( pos fid -- ior ) */ - M_PUSH( sdTellFile( (FileStream *) TOS )); - TOS = 0; + case ID_FILE_POSITION: /* ( fid -- ud ior ) */ + { + off_t offsetHi; + FileID = (FileStream *) TOS; + off_t 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 ) */ @@ -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 ) { SAVE_REGISTERS; - Scratch = ffIncludeFile( FileID ); + Scratch = ffIncludeFile( FileID ); /* Also closes the file. */ LOAD_REGISTERS; - sdCloseFile( FileID ); if( Scratch ) M_THROW(Scratch); } else @@ -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)) if( IN_DICS( TOS ) ) { - WRITE_CELL_DIC(TOS,M_POP); + WRITE_CELL_DIC((cell_t *)TOS,M_POP); } else { @@ -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; case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase; case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase; - case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr.Cell); endcase; + case ID_VAR_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; @@ -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)) if( IN_DICS( TOS ) ) { - TOS = (uint16_t) READ_SHORT_DIC((uint8_t *)TOS); + TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS); } else { @@ -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)) if( IN_DICS( TOS ) ) { - WRITE_SHORT_DIC(TOS,M_POP); + WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP); } else {