From: Phil Burk Date: Sun, 19 May 2019 21:55:10 +0000 (-0700) Subject: Merge branch 'master' into build64 X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/commitdiff_plain/c1a87b8298475c3fdd007b14a1413d2a6fd0fa61?hp=-c Merge branch 'master' into build64 --- c1a87b8298475c3fdd007b14a1413d2a6fd0fa61 diff --combined csrc/pf_guts.h index c0180c1,a55d857..3c5a4cf --- a/csrc/pf_guts.h +++ b/csrc/pf_guts.h @@@ -23,7 -23,7 +23,7 @@@ ** PFORTH_VERSION changes when PForth is modified and released. ** See README file for version info. */ - #define PFORTH_VERSION "27" + #define PFORTH_VERSION "28" /* ** PFORTH_FILE_VERSION changes when incompatible changes are made @@@ -36,8 -36,9 +36,9 @@@ ** FV7 - 971203 - Added ID_FILL, (1LOCAL@), etc., ran out of reserved, resorted. ** FV8 - 980818 - Added Endian flag. ** FV9 - 20100503 - Added support for 64-bit CELL. + ** FV10 - 20170103 - Added ID_FILE_FLUSH ID_FILE_RENAME ID_FILE_RESIZE */ - #define PF_FILE_VERSION (9) /* Bump this whenever primitives added. */ + #define PF_FILE_VERSION (10) /* Bump this whenever primitives added. */ #define PF_EARLIEST_FILE_VERSION (9) /* earliest one still compatible */ /*************************************************************** @@@ -216,7 -217,7 +217,7 @@@ enum cforth_primitive_id ID_QUIT_P, ID_REFILL, ID_RESIZE, - ID_RESTORE_INPUT, + ID_SOURCE_LINE_NUMBER_FETCH, /* used to be ID_RESTORE_INPUT */ ID_ROLL, ID_ROT, ID_RP_FETCH, @@@ -226,7 -227,7 +227,7 @@@ ID_R_FETCH, ID_R_FROM, ID_SAVE_FORTH_P, - ID_SAVE_INPUT, + ID_SOURCE_LINE_NUMBER_STORE, /* used to be ID_SAVE_INPUT */ ID_SCAN, ID_SEMICOLON, ID_SKIP, @@@ -281,6 -282,9 +282,9 @@@ ID_CELLS, /* DELETE-FILE */ ID_FILE_DELETE, + ID_FILE_FLUSH, /* FLUSH-FILE */ + ID_FILE_RENAME, /* (RENAME-FILE) */ + ID_FILE_RESIZE, /* RESIZE-FILE */ /* If you add a word here, take away one reserved word below. */ #ifdef PF_SUPPORT_FP /* Only reserve space if we are adding FP so that we can detect @@@ -296,9 -300,6 +300,6 @@@ ID_RESERVED08, ID_RESERVED09, ID_RESERVED10, - ID_RESERVED11, - ID_RESERVED12, - ID_RESERVED13, ID_FP_D_TO_F, ID_FP_FSTORE, ID_FP_FTIMES, @@@ -368,6 -369,8 +369,8 @@@ #define THROW_PAIRS (-22) #define THROW_FLOAT_STACK_UNDERFLOW ( -45) #define THROW_QUIT (-56) + #define THROW_FLUSH_FILE (-68) + #define THROW_RESIZE_FILE (-74) /* THROW codes unique to pForth */ #define THROW_BYE (-256) /* Exit program. */ @@@ -459,7 -462,7 +462,7 @@@ typedef struct IncludeFram extern "C" { #endif - int pfCatch( ExecToken XT ); + ThrowCode pfCatch( ExecToken XT ); #ifdef __cplusplus } @@@ -568,12 -571,9 +571,12 @@@ extern cell_t gIncludeIndex /* Force Quad alignment. */ #define QUADUP(x) (((x)+3)&~3) +#ifndef MIN #define MIN(a,b) ( ((a)<(b)) ? (a) : (b) ) +#endif +#ifndef MAX #define MAX(a,b) ( ((a)>(b)) ? (a) : (b) ) - +#endif #ifndef TOUCH #define TOUCH(argument) ((void)argument) diff --combined csrc/pf_inner.c index 8a31b0e,57559bd..97fb004 --- a/csrc/pf_inner.c +++ b/csrc/pf_inner.c @@@ -26,12 -26,6 +26,6 @@@ ** ***************************************************************/ - #ifndef AMIGA - #include - #else - typedef long off_t; - #endif - #include "pf_all.h" #if defined(WIN32) && !defined(__MINGW32__) @@@ -199,8 -193,26 +193,26 @@@ static void TraceNames( ExecToken Token /* Use local copy of CODE_BASE for speed. */ #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase)) + /* Truncate the unsigned double cell integer LO/HI to an uint64_t. */ + static uint64_t UdToUint64( ucell_t Lo, ucell_t Hi ) + { + return (( 2 * sizeof(ucell_t) == sizeof(uint64_t) ) + ? (((uint64_t)Lo) | (((uint64_t)Hi) >> (sizeof(ucell_t) * 8))) + : Lo); + } + + /* Return TRUE if the unsigned double cell integer LO/HI is not greater + * then the greatest uint64_t. + */ + static int UdIsUint64( ucell_t Lo, ucell_t Hi ) + { + return (( 2 * sizeof(ucell_t) == sizeof(uint64_t) ) + ? TRUE + : Hi == 0); + } + -static const char *pfSelectFileModeCreate(cell_t fam ); -static const char *pfSelectFileModeOpen(cell_t fam ); +static const char *pfSelectFileModeCreate( cell_t fam ); +static const char *pfSelectFileModeOpen( cell_t fam ); /**************************************************************/ static const char *pfSelectFileModeCreate( cell_t fam ) @@@ -257,7 -269,7 +269,7 @@@ static const char *pfSelectFileModeOpen } /**************************************************************/ - int pfCatch( ExecToken XT ) + ThrowCode pfCatch( ExecToken XT ) { register cell_t TopOfStack; /* Cache for faster execution. */ register cell_t *DataStackPtr; @@@ -490,6 -502,7 +502,7 @@@ DBUGX(("After Branch: IP = 0x%x\n", Ins endcase; case ID_BYE: + EMIT_CR; M_THROW( THROW_BYE ); endcase; @@@ -732,8 -745,8 +745,8 @@@ /* 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); + if ((cell_t)ahi < 0) ahi = (ucell_t)(-(cell_t)ahi); + if ((cell_t)bhi < 0) bhi = (ucell_t)(-(cell_t)bhi); /* Break into hi and lo 16 bit parts. */ alo = LOWER_HALF(ahi); @@@ -1017,24 -1030,38 +1030,38 @@@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh, Scratch = M_POP; CharPtr = (char *) M_POP; Temp = sdReadFile( CharPtr, 1, Scratch, FileID ); + /* TODO check feof() or ferror() */ M_PUSH(Temp); TOS = 0; endcase; + /* TODO Why does this crash when passed an illegal FID? */ 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 */ + file_offset_t endposition = -1; + file_offset_t original = sdTellFile( FileID ); + if (original >= 0) + { + sdSeekFile( FileID, 0, PF_SEEK_END ); + endposition = sdTellFile( FileID ); + /* Restore original position. */ + sdSeekFile( FileID, original, PF_SEEK_SET ); + } + if (endposition < 0) + { + M_PUSH(0); /* low */ + M_PUSH(0); /* high */ + TOS = -4; /* TODO proper error number */ + } + else + { + M_PUSH(endposition); /* low */ + /* We do not support double precision file offsets.*/ + M_PUSH(0); /* high */ + TOS = 0; /* OK */ + } } endcase; @@@ -1048,27 -1075,43 +1075,43 @@@ case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */ { - off_t offset; + file_offset_t offset; + cell_t offsetHigh; + cell_t offsetLow; 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; + offsetHigh = M_POP; + offsetLow = M_POP; + /* We do not support double precision file offsets in pForth. + * So check to make sure the high bits are not used. + */ + if (offsetHigh != 0) + { + TOS = -3; /* TODO err num? */ + break; + } + offset = (file_offset_t)offsetLow; TOS = sdSeekFile( FileID, offset, PF_SEEK_SET ); } endcase; case ID_FILE_POSITION: /* ( fid -- ud ior ) */ { - off_t position; - off_t offsetHi; + file_offset_t position; 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 */ + if (position < 0) + { + M_PUSH(0); /* low */ + M_PUSH(0); /* high */ + TOS = -4; /* TODO proper error number */ + } + else + { + M_PUSH(position); /* low */ + /* We do not support double precision file offsets.*/ + M_PUSH(0); /* high */ + TOS = 0; /* OK */ + } } endcase; @@@ -1091,6 -1134,32 +1134,32 @@@ TOS = TOS | PF_FAM_BINARY_FLAG; endcase; + case ID_FILE_FLUSH: /* ( fileid -- ior ) */ + { + FileStream *Stream = (FileStream *) TOS; + TOS = (sdFlushFile( Stream ) == 0) ? 0 : THROW_FLUSH_FILE; + } + endcase; + + case ID_FILE_RENAME: /* ( oldName newName -- ior ) */ + { + char *New = (char *) TOS; + char *Old = (char *) M_POP; + TOS = sdRenameFile( Old, New ); + } + endcase; + + case ID_FILE_RESIZE: /* ( ud fileid -- ior ) */ + { + FileStream *File = (FileStream *) TOS; + ucell_t SizeHi = (ucell_t) M_POP; + ucell_t SizeLo = (ucell_t) M_POP; + TOS = ( UdIsUint64( SizeLo, SizeHi ) + ? sdResizeFile( File, UdToUint64( SizeLo, SizeHi )) + : THROW_RESIZE_FILE ); + } + endcase; + case ID_FILL: /* ( caddr num charval -- ) */ { register char *DstPtr; @@@ -1391,15 -1460,18 +1460,18 @@@ 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 ) ) - { + cell_t Limit = M_R_POP; + cell_t OldIndex = M_R_POP; + cell_t Delta = TOS; /* add TOS to index, not 1 */ + cell_t NewIndex = OldIndex + Delta; + cell_t OldDiff = OldIndex - Limit; + + /* This exploits this idea (lifted from Gforth): + (x^y)<0 is equivalent to (x<0) != (y<0) */ + if( ((OldDiff ^ (OldDiff + Delta)) /* is the limit crossed? */ + & (OldDiff ^ Delta)) /* is it a wrap-around? */ + < 0 ) + { InsPtr++; /* skip branch offset, exit loop */ } else @@@ -1556,16 -1628,6 +1628,6 @@@ 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; @@@ -1647,6 -1709,16 +1709,16 @@@ else M_DROP; endcase; + case ID_SOURCE_LINE_NUMBER_FETCH: /* ( -- linenr ) */ + PUSH_TOS; + TOS = gCurrentTask->td_LineNumber; + endcase; + + case ID_SOURCE_LINE_NUMBER_STORE: /* ( linenr -- ) */ + gCurrentTask->td_LineNumber = TOS; + TOS = M_POP; + endcase; + case ID_SWAP: Scratch = TOS; TOS = *STKPTR; diff --combined csrc/pf_save.c index ac2c85e,f72981e..830eaee --- a/csrc/pf_save.c +++ b/csrc/pf_save.c @@@ -315,7 -315,7 +315,7 @@@ cell_t ffSaveForth( const char *FileNam /***************************************************************/ static int Write32ToFile( FileStream *fid, uint32_t Val ) { - cell_t numw; + size_t numw; uint8_t pad[4]; Write32BigEndian(pad,Val); @@@ -332,7 -332,9 +332,9 @@@ static cell_t WriteChunkToFile( FileStr EvenNumW = EVENUP(NumBytes); + assert(ID <= UINT32_MAX); if( Write32ToFile( fid, (uint32_t)ID ) < 0 ) goto error; + assert(EvenNumW <= UINT32_MAX); if( Write32ToFile( fid, (uint32_t)EvenNumW ) < 0 ) goto error; numw = sdWriteFile( Data, 1, EvenNumW, fid ); @@@ -459,7 -461,7 +461,7 @@@ cell_t ffSaveForth( const char *FileNam NameSize = QUADUP(NameSize); /* Align */ if( NameSize > 0 ) { - NameSize = MAX( NameSize, (NameChunkSize + 1024) ); + NameSize = MAX( (ucell_t)NameSize, (NameChunkSize + 1024) ); } SD.sd_NameSize = NameSize; } @@@ -467,7 -469,7 +469,7 @@@ /* How much real code is there? */ CodeChunkSize = QUADUP(relativeCodePtr); CodeSize = QUADUP(CodeSize); /* Align */ - CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) ); + CodeSize = MAX( (ucell_t)CodeSize, (CodeChunkSize + 2048) ); SD.sd_CodeSize = CodeSize; @@@ -515,7 -517,7 +517,7 @@@ error /***************************************************************/ static int32_t Read32FromFile( FileStream *fid, uint32_t *ValPtr ) { - int32_t numr; + cell_t numr; uint8_t pad[4]; numr = sdReadFile( pad, 1, sizeof(pad), fid ); if( numr != sizeof(pad) ) return -1; @@@ -533,7 -535,7 +535,7 @@@ PForthDictionary pfLoadDictionary( cons uint32_t ChunkSize; uint32_t FormSize; uint32_t BytesLeft; - uint32_t numr; + cell_t numr; int isDicBigEndian; DBUG(("pfLoadDictionary( %s )\n", FileName )); @@@ -726,7 -728,7 +728,7 @@@ /* Find special words in dictionary for global XTs. */ if( (Result = FindSpecialXTs()) < 0 ) { - pfReportError("pfLoadDictionary: FindSpecialXTs", Result); + pfReportError("pfLoadDictionary: FindSpecialXTs", (Err)Result); goto error; } } diff --combined fth/c_struct.fth index 46651ad,330ce38..bd06a50 --- a/fth/c_struct.fth +++ b/fth/c_struct.fth @@@ -5,7 -5,7 +5,7 @@@ \ This file must be loaded before loading any .J files. \ \ Author: Phil Burk - \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom + \ 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 @@@ -94,13 -94,13 +94,13 @@@ decima : (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ; : compile+!bytes ( offset size -- ) -\ ." compile+!bytes ( " over . dup . ." )" cr + ." compile+!bytes ( " over . dup . ." )" cr swap [compile] literal \ compile offset into word CASE cell OF compile (s+!) ENDOF 2 OF compile (s+w!) ENDOF 1 OF compile (s+c!) ENDOF - -4 OF compile (s+rel!) ENDOF \ 00002 + -cell OF compile (s+rel!) ENDOF \ 00002 -2 OF compile (s+w!) ENDOF -1 OF compile (s+c!) ENDOF true abort" s! - illegal size!" @@@ -110,7 -110,7 +110,7 @@@ : !BYTES ( value address size -- ) CASE cell OF ! ENDOF - -4 OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002 + -cell OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002 ABS 2 OF w! ENDOF 1 OF c! ENDOF @@@ -137,7 -137,7 +137,7 @@@ cell OF @ ENDOF 2 OF w@ ENDOF 1 OF c@ ENDOF - -4 OF @ if.rel->use ENDOF \ 00002 + -cell OF @ if.rel->use ENDOF \ 00002 -2 OF w@ w->s ENDOF -1 OF c@ b->s ENDOF true abort" s@ - illegal size!" @@@ -152,13 -152,13 +152,13 @@@ : (S+W@) ( addr offset -- val ) + w@ w->s ; : compile+@bytes ( offset size -- ) -\ ." compile+@bytes ( " over . dup . ." )" cr + ." compile+@bytes ( " over . dup . ." )" cr swap [compile] literal \ compile offset into word CASE cell OF compile (s+@) ENDOF 2 OF compile (s+uw@) ENDOF 1 OF compile (s+uc@) ENDOF - -4 OF compile (s+rel@) ENDOF \ 00002 + -cell OF compile (s+rel@) ENDOF \ 00002 -2 OF compile (s+w@) ENDOF -1 OF compile (s+c@) ENDOF true abort" s@ - illegal size!" @@@ -213,28 -213,21 +213,28 @@@ exists? F* [IF :struct mapper long map_l1 long map_l2 - aptr map_a1 - rptr map_r1 - flpt map_f1 short map_s1 ushort map_s2 byte map_b1 ubyte map_b2 + aptr map_a1 + rptr map_r1 + flpt map_f1 ;struct mapper map1 +." compiling TT" cr : TT + 123456 map1 s! map_l1 + map1 s@ map_l1 123456 - abort" map_l1 failed!" + 987654 map1 s! map_l2 + map1 s@ map_l2 987654 - abort" map_l2 failed!" + -500 map1 s! map_s1 - map1 s@ map_s1 -500 - abort" map_s1 failed!" + map1 s@ map_s1 dup . cr -500 - abort" map_s1 failed!" -500 map1 s! map_s2 map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!" + -89 map1 s! map_b1 map1 s@ map_b1 -89 - abort" map_s1 failed!" here map1 s! map_r1 diff --combined fth/member.fth index 7ff61c5,3ff53d7..ceccc55 --- a/fth/member.fth +++ b/fth/member.fth @@@ -6,7 -6,7 +6,7 @@@ \ the Object Development Environment. \ \ Author: Phil Burk - \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom + \ 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 @@@ -41,18 -41,12 +41,18 @@@ decima ; \ Variables shared with object oriented code. - VARIABLE OB-STATE ( Compilation state. ) - VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class ) - 1 constant OB_DEF_CLASS ( defining a class ) - 2 constant OB_DEF_STRUCT ( defining a structure ) +VARIABLE OB-STATE ( Compilation state. ) +VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class ) +1 constant OB_DEF_CLASS ( defining a class ) +2 constant OB_DEF_STRUCT ( defining a structure ) -4 constant OB_OFFSET_SIZE +\ A member contains: +\ cell size of data in bytes (1, 2, cell) +\ cell offset within structure + +cell 1- constant CELL_MASK +cell negate constant -CELL +cell constant OB_OFFSET_SIZE : OB.OFFSET@ ( member_def -- offset ) @ ; : OB.OFFSET, ( value -- ) , ; @@@ -66,7 -60,7 +66,7 @@@ ABS ( -- |+-b| ) ob-current-class @ ( -- b addr-space) tuck @ ( as #b c , current space needed ) - over 3 and 0= ( multiple of four? ) + over CELL_MASK and 0= ( multiple of cell? ) IF aligned ELSE @@@ -153,7 -147,7 +153,7 @@@ \ Aliases : APTR ( -- ) long ; -: RPTR ( -- ) -4 bytes ; \ relative relocatable pointer 00001 +: RPTR ( -- ) -cell bytes ; \ relative relocatable pointer 00001 : ULONG ( -- ) long ; : STRUCT ( -- , define a structure as an ivar ) diff --combined fth/misc2.fth index 09f585f,c943e82..c0791da --- a/fth/misc2.fth +++ b/fth/misc2.fth @@@ -2,7 -2,7 +2,7 @@@ \ Utilities for PForth extracted from HMSL \ \ Author: Phil Burk - \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom + \ 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 @@@ -41,6 -41,10 +41,10 @@@ anew task-misc2.ft variable if-debug + : ? ( address -- , fatch from address and print value ) + @ . + ; + decimal create msec-delay 10000 , ( default for SUN ) : (MSEC) ( #msecs -- ) @@@ -118,18 -122,18 +122,18 @@@ variable rand-seed here rand-seed : B->S ( c -- c' , sign extend byte ) dup $ 80 and IF - $ FFFFFF00 or + [ $ 0FF invert ] literal or ELSE - $ 000000FF and + $ 0FF and THEN ; -: W->S ( 16bit-signed -- 32bit-signed ) +: W->S ( 16bit-signed -- cell-signed ) dup $ 8000 and - if - $ FFFF0000 or + IF + [ $ 0FFFF invert ] literal or ELSE - $ 0000FFFF and - then + $ 0FFFF and + THEN ; : WITHIN { n1 n2 n3 -- flag } @@@ -233,3 -237,40 +237,40 @@@ VARIABLE SPA addr3 cnt3 flag ; + private{ + + : env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false ) + { x } 2over compare 0= if 2drop x true true else false then + ; + + : 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false ) + { x y } 2over compare 0= if 2drop x y true true else false then + ; + + 0 invert constant max-u + 0 invert 1 rshift constant max-n + + }private + + : ENVIRONMENT? ( c-addr u -- false | i*x true ) + s" /COUNTED-STRING" 255 env= if exit then + s" /HOLD" 128 env= if exit then \ same as PAD + s" /PAD" 128 env= if exit then + s" ADDRESS-UNITS-BITS" 8 env= if exit then + s" FLOORED" false env= if exit then + s" MAX-CHAR" 255 env= if exit then + s" MAX-D" max-n max-u 2env= if exit then + s" MAX-N" max-n env= if exit then + s" MAX-U" max-u env= if exit then + s" MAX-UD" max-u max-u 2env= if exit then + s" RETURN-STACK-CELLS" 512 env= if exit then \ DEFAULT_RETURN_DEPTH + s" STACK-CELLS" 512 env= if exit then \ DEFAULT_USER_DEPTH + \ FIXME: maybe define those: + \ s" FLOATING-STACK" + \ s" MAX-FLOAT" + \ s" #LOCALS" + \ s" WORDLISTS" + 2drop false + ; + + privatize diff --combined fth/system.fth index bed4334,21200fa..c84f08b --- a/fth/system.fth +++ b/fth/system.fth @@@ -26,7 -26,7 +26,7 @@@ \ Based on HMSL Forth \ \ Author: Phil Burk - \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom + \ 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 @@@ -360,6 -360,18 +360,18 @@@ 2* swap ; + : D= ( xd1 xd2 -- flag ) + rot = -rot = and + ; + + : D< ( d1 d2 -- flag ) + d- nip 0< + ; + + : D> ( d1 d2 -- flag ) + 2swap d< + ; + \ define some useful constants ------------------------------ 1 0= constant FALSE 0 0= constant TRUE @@@ -716,29 -728,30 +728,30 @@@ ustack 0stack \ -------------- INCLUDE ------------------------------------------ variable TRACE-INCLUDE - : INCLUDE.MARK.START ( $filename -- , mark start of include for FILE?) - " ::::" pad $MOVE - count pad $APPEND - pad ['] noop (:) + : INCLUDE.MARK.START ( c-addr u -- , mark start of include for FILE?) + dup 5 + allocate throw >r + " ::::" r@ $move + r@ $append + r@ ['] noop (:) + r> free throw ; : INCLUDE.MARK.END ( -- , mark end of include ) " ;;;;" ['] noop (:) ; - : $INCLUDE ( $filename -- ) - \ Print messages. + : INCLUDED ( c-addr u -- ) + \ Print messages. trace-include @ IF - >newline ." Include " dup count type cr + >newline ." Include " 2dup type cr THEN here >r - dup - count r/o open-file - IF ( -- $filename bad-fid ) - drop ." Could not find file " $type cr abort - ELSE ( -- $filename good-fid ) - swap include.mark.start + 2dup r/o open-file + IF ( -- c-addr u bad-fid ) + drop ." Could not find file " type cr abort + ELSE ( -- c-addr u good-fid ) + -rot include.mark.start depth >r include-file \ will also close the file depth 1+ r> - @@@ -757,6 -770,8 +770,8 @@@ rdrop ; + : $INCLUDE ( $filename -- ) count included ; + create INCLUDE-SAVE-NAME 128 allot : INCLUDE ( -- ) BL lword @@@ -821,6 -836,4 +836,6 @@@ decima FREEZE \ prevent forgetting below this point .( Dictionary compiled, save in "pforth.dic".) cr +\ 300000 headers-size ! +\ 700000 code-size ! c" pforth.dic" save-forth