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=e14f25331be47e565ff6ae8cd7fb372fd329aff1 Merge branch 'master' into build64 --- diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a20f893 --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +build/unix/*.eo +build/unix/*.o +build/unix/pfdicdat.h +build/unix/pforth +build/unix/pforth.dic +build/unix/pforth_standalone +build/win32/**/.vs +build/win32/**/Debug +build/win32/**/Release +fth/fatest1.txt diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..c349606 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,21 @@ +os: + - linux + - osx +env: + - WIDTHOPT=-m64 + - WIDTHOPT=-m32 +language: c +compiler: + - gcc + - clang +matrix: + exclude: + - os: osx + compiler: gcc # gcc seems to be an symlink to clang +sudo: true +before_install: | + if [ "$TRAVIS_OS_NAME" = linux -a "$WIDTHOPT" = -m32 ]; then + sudo apt-get install -y gcc-multilib + fi +script: # CC is exported by travis + - make WIDTHOPT=$WIDTHOPT -C build/unix/ test diff --git a/build/linux-crossbuild-amiga/Makefile b/build/linux-crossbuild-amiga/Makefile index 1c10eeb..c37f5fe 100644 --- a/build/linux-crossbuild-amiga/Makefile +++ b/build/linux-crossbuild-amiga/Makefile @@ -44,7 +44,7 @@ FULL_WARNINGS = \ CCOPTS = $(WIDTHOPT) -x c -O2 $(FULL_WARNINGS) $(EXTRA_CCOPTS) $(DEBUGOPTS) #IO_SOURCE = pf_io_posix.c -IO_SOURCE = pf_io_stdio.c +IO_SOURCE = pf_io_stdio.c pf_fileio_stdio.c #IO_SOURCE = pf_io_win32_console.c EMBCCOPTS = -DPF_STATIC_DIC diff --git a/build/mingw-crossbuild-linux/Makefile b/build/mingw-crossbuild-linux/Makefile index f6f8d68..a6d3161 100644 --- a/build/mingw-crossbuild-linux/Makefile +++ b/build/mingw-crossbuild-linux/Makefile @@ -45,7 +45,7 @@ CCOPTS = $(WIDTHOPT) -x c -O2 $(FULL_WARNINGS) $(EXTRA_CCOPTS) $(DEBUGOPTS) #IO_SOURCE = pf_io_posix.c #IO_SOURCE = pf_io_stdio.c -IO_SOURCE = pf_io_win32_console.c +IO_SOURCE = pf_io_win32_console.c pf_fileio_stdio.c EMBCCOPTS = -DPF_STATIC_DIC @@ -140,6 +140,7 @@ test: $(PFORTHAPP) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_locals.fth) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_alloc.fth) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_floats.fth) + wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_file.fth) clean: rm -f $(PFOBJS) $(PFEMBOBJS) diff --git a/build/unix/Makefile b/build/unix/Makefile index 141f855..e80b56d 100644 --- a/build/unix/Makefile +++ b/build/unix/Makefile @@ -40,10 +40,10 @@ FULL_WARNINGS = \ DEBUGOPTS = -g CCOPTS = $(WIDTHOPT) -x c -O2 $(FULL_WARNINGS) $(EXTRA_CCOPTS) $(DEBUGOPTS) -IO_SOURCE = pf_io_posix.c +IO_SOURCE = pf_io_posix.c pf_fileio_stdio.c #IO_SOURCE = pf_io_stdio.c -EMBCCOPTS = -DPF_STATIC_DIC +EMBCCOPTS = -DPF_STATIC_DIC #-DPF_NO_FILEIO ####################################### PFINCLUDES = pf_all.h pf_cglue.h pf_clib.h pf_core.h pf_float.h \ @@ -58,7 +58,7 @@ PFSOURCE = $(PFBASESOURCE) $(IO_SOURCE) VPATH = .:$(CSRCDIR):$(CSRCDIR)/posix:$(CSRCDIR)/stdio:$(CSRCDIR)/win32_console:$(CSRCDIR)/win32 XCFLAGS = $(CCOPTS) -XCPPFLAGS = -DPF_SUPPORT_FP -D_GNU_SOURCE +XCPPFLAGS = -DPF_SUPPORT_FP -D_DEFAULT_SOURCE -D_GNU_SOURCE XLDFLAGS = $(WIDTHOPT) CPPFLAGS = -I. $(XCPPFLAGS) @@ -135,6 +135,7 @@ test: $(PFORTHAPP) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_locals.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_alloc.fth) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_floats.fth) + wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFORTHAPP) -q t_file.fth) clean: rm -f $(PFOBJS) $(PFEMBOBJS) diff --git a/build/win32/vs2005/pforth.sln b/build/win32/vs2005/pforth.sln deleted file mode 100644 index 3f81925..0000000 --- a/build/win32/vs2005/pforth.sln +++ /dev/null @@ -1,20 +0,0 @@ - -Microsoft Visual Studio Solution File, Format Version 9.00 -# Visual Studio 2005 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "pforth_main", "pforth_main.vcproj", "{58B76DB8-1985-4B8A-8E71-C012D8F0C518}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Win32 = Debug|Win32 - Release|Win32 = Release|Win32 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|Win32.ActiveCfg = Debug|Win32 - {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|Win32.Build.0 = Debug|Win32 - {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|Win32.ActiveCfg = Release|Win32 - {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|Win32.Build.0 = Release|Win32 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal diff --git a/build/win32/vs2005/pforth_main.vcproj b/build/win32/vs2005/pforth_main.vcproj deleted file mode 100644 index b711d4d..0000000 --- a/build/win32/vs2005/pforth_main.vcproj +++ /dev/null @@ -1,335 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/build/win32/vs2017/pforth.sln b/build/win32/vs2017/pforth.sln new file mode 100644 index 0000000..b35fd9c --- /dev/null +++ b/build/win32/vs2017/pforth.sln @@ -0,0 +1,31 @@ + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 15 +VisualStudioVersion = 15.0.27130.2010 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "pforth_main", "pforth_main.vcxproj", "{58B76DB8-1985-4B8A-8E71-C012D8F0C518}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|Win32.ActiveCfg = Debug|Win32 + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|Win32.Build.0 = Debug|Win32 + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|x64.ActiveCfg = Debug|x64 + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|x64.Build.0 = Debug|x64 + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|Win32.ActiveCfg = Release|Win32 + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|Win32.Build.0 = Release|Win32 + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|x64.ActiveCfg = Release|x64 + {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|x64.Build.0 = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {4FCA3FD0-0EBB-4534-9A49-51A638D09B2F} + EndGlobalSection +EndGlobal diff --git a/build/win32/vs2017/pforth_main.vcxproj b/build/win32/vs2017/pforth_main.vcxproj new file mode 100644 index 0000000..0b6ab8b --- /dev/null +++ b/build/win32/vs2017/pforth_main.vcxproj @@ -0,0 +1,193 @@ + + + + + Debug + Win32 + + + Debug + x64 + + + Release + Win32 + + + Release + x64 + + + + {58B76DB8-1985-4B8A-8E71-C012D8F0C518} + pforth_main + Win32Proj + pforth + + + + Application + v141 + NotSet + true + + + Application + v141 + NotSet + true + + + Application + v141 + Unicode + + + Application + v141 + Unicode + + + + + + + + + + + + + + + + + + + <_ProjectFileVersion>15.0.27130.2010 + + + $(SolutionDir)..\..\..\fth\ + $(Configuration)\ + true + + + true + + + $(SolutionDir)..\..\..\fth\ + $(Configuration)\ + false + + + false + + + + Disabled + WIN32;_DEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + true + EnableFastChecks + MultiThreadedDebugDLL + + Level3 + EditAndContinue + + + true + Console + MachineX86 + + + + + Disabled + WIN32;_DEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + EnableFastChecks + MultiThreadedDebugDLL + + + Level3 + ProgramDatabase + + + true + Console + + + + + WIN32;NDEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + MultiThreadedDLL + + Level3 + ProgramDatabase + + + true + Console + true + true + MachineX86 + + + + + WIN32;NDEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions) + MultiThreadedDLL + + + Level3 + ProgramDatabase + + + true + Console + true + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/build/win32/vs2017/pforth_main.vcxproj.filters b/build/win32/vs2017/pforth_main.vcxproj.filters new file mode 100644 index 0000000..2f6b984 --- /dev/null +++ b/build/win32/vs2017/pforth_main.vcxproj.filters @@ -0,0 +1,123 @@ + + + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + Source + + + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + Include + + + + + {6711f4b0-6d8c-4641-8260-e6d2c953bd3b} + + + {298706eb-f166-4f0b-8404-a52c3fdf5d21} + + + \ No newline at end of file diff --git a/csrc/pf_core.c b/csrc/pf_core.c index 1736aa9..a6d7c26 100644 --- a/csrc/pf_core.c +++ b/csrc/pf_core.c @@ -170,9 +170,9 @@ nomem: ** Dictionary Management ***************************************************************/ -cell_t pfExecIfDefined( const char *CString ) +ThrowCode pfExecIfDefined( const char *CString ) { - int result = 0; + ThrowCode result = 0; if( NAME_BASE != (cell_t)NULL) { ExecToken XT; @@ -427,11 +427,11 @@ void pfMessage( const char *CString ) /************************************************************************** ** Main entry point for pForth. */ -cell_t pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit ) +ThrowCode pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit ) { pfTaskData_t *cftd; pfDictionary_t *dic = NULL; - cell_t Result = 0; + ThrowCode Result = 0; ExecToken EntryPoint = 0; #ifdef PF_USER_INIT diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h index c0180c1..3c5a4cf 100644 --- a/csrc/pf_guts.h +++ b/csrc/pf_guts.h @@ -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 @@ ** 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 @@ enum cforth_primitive_ids 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 @@ enum cforth_primitive_ids 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 @@ enum cforth_primitive_ids 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 @@ enum cforth_primitive_ids 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 @@ enum cforth_primitive_ids #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 @@ typedef struct IncludeFrame extern "C" { #endif -int pfCatch( ExecToken XT ); +ThrowCode pfCatch( ExecToken XT ); #ifdef __cplusplus } diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c index 8a31b0e..97fb004 100644 --- a/csrc/pf_inner.c +++ b/csrc/pf_inner.c @@ -26,12 +26,6 @@ ** ***************************************************************/ -#ifndef AMIGA -#include -#else -typedef long off_t; -#endif - #include "pf_all.h" #if defined(WIN32) && !defined(__MINGW32__) @@ -199,6 +193,24 @@ static void TraceNames( ExecToken Token, cell_t Level ) /* 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 ); @@ -257,7 +269,7 @@ static const char *pfSelectFileModeOpen( cell_t fam ) } /**************************************************************/ -int pfCatch( ExecToken XT ) +ThrowCode pfCatch( ExecToken XT ) { register cell_t TopOfStack; /* Cache for faster execution. */ register cell_t *DataStackPtr; @@ -490,6 +502,7 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); endcase; case ID_BYE: + EMIT_CR; M_THROW( THROW_BYE ); endcase; @@ -732,8 +745,8 @@ DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); /* 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 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); 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 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); 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 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); 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 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); 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 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); 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 @@ DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); 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 --git a/csrc/pf_io.c b/csrc/pf_io.c index 3aedb49..da16a14 100644 --- a/csrc/pf_io.c +++ b/csrc/pf_io.c @@ -194,7 +194,7 @@ cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream TOUCH(Stream); return 0; } -cell_t sdSeekFile( FileStream * Stream, cell_t Position, int32_t Mode ) +cell_t sdSeekFile( FileStream * Stream, file_offset_t Position, int32_t Mode ) { UNIMPLEMENTED("sdSeekFile"); TOUCH(Stream); @@ -202,7 +202,7 @@ cell_t sdSeekFile( FileStream * Stream, cell_t Position, int32_t Mode ) TOUCH(Mode); return 0; } -cell_t sdTellFile( FileStream * Stream ) +file_offset_t sdTellFile( FileStream * Stream ) { UNIMPLEMENTED("sdTellFile"); TOUCH(Stream); @@ -215,11 +215,27 @@ cell_t sdCloseFile( FileStream * Stream ) return 0; } -FileStream *sdDeleteFile( const char *FileName ) +cell_t sdDeleteFile( const char *FileName ) { UNIMPLEMENTED("sdDeleteFile"); TOUCH(FileName); - return NULL; + return -1; +} + +cell_t sdRenameFile( const char *OldName, const char *NewName ) +{ + UNIMPLEMENTED("sdRenameFile"); + TOUCH(OldName); + TOUCH(NewName); + return -1; } + +ThrowCode sdResizeFile( FileStream * File, uint64_t NewSize ) +{ + UNIMPLEMENTED("sdResizeFile"); + TOUCH(NewSize); + return THROW_RESIZE_FILE; +} + #endif diff --git a/csrc/pf_io.h b/csrc/pf_io.h index 8af1667..db8fd92 100644 --- a/csrc/pf_io.h +++ b/csrc/pf_io.h @@ -19,6 +19,8 @@ ** ***************************************************************/ +#include "pf_types.h" + #define PF_CHAR_XON (0x11) #define PF_CHAR_XOFF (0x13) @@ -33,7 +35,6 @@ void sdTerminalTerm( void ); void ioInit( void ); void ioTerm( void ); - #ifdef PF_NO_CHARIO void sdEnableInput( void ); void sdDisableInput( void ); @@ -84,8 +85,11 @@ void ioTerm( void ); cell_t sdFlushFile( FileStream * Stream ); cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ); cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ); - cell_t sdSeekFile( FileStream * Stream, off_t Position, int32_t Mode ); - off_t sdTellFile( FileStream * Stream ); + cell_t sdSeekFile( FileStream * Stream, file_offset_t Position, int32_t Mode ); + cell_t sdRenameFile( const char *OldName, const char *NewName ); + cell_t sdDeleteFile( const char *FileName ); + ThrowCode sdResizeFile( FileStream *, uint64_t Size); + file_offset_t sdTellFile( FileStream * Stream ); cell_t sdCloseFile( FileStream * Stream ); cell_t sdInputChar( FileStream *stream ); @@ -114,19 +118,24 @@ void ioTerm( void ); typedef FILE FileStream; #define sdOpenFile fopen - #define sdDeleteFile remove + #define sdDeleteFile remove #define sdFlushFile fflush #define sdReadFile fread #define sdWriteFile fwrite - #if defined(WIN32) || defined(__NT__) || defined(AMIGA) - /* TODO To support 64-bit file offset we probably need fseeki64(). */ - #define sdSeekFile fseek - #define sdTellFile ftell - #else - #define sdSeekFile fseeko - #define sdTellFile ftello - #endif + + /* + * Note that fseek() and ftell() only support a long file offset. + * So 64-bit offsets may not be supported on some platforms. + * At one point we supported fseeko() and ftello() but they require + * the off_t data type, which is not very portable. + * So we decided to sacrifice vary large file support in + * favor of portability. + */ + #define sdSeekFile fseek + #define sdTellFile ftell + #define sdCloseFile fclose + #define sdRenameFile rename #define sdInputChar fgetc #define PF_STDIN ((FileStream *) stdin) @@ -136,6 +145,9 @@ void ioTerm( void ); #define PF_SEEK_CUR (SEEK_CUR) #define PF_SEEK_END (SEEK_END) + /* TODO review the Size data type. */ + ThrowCode sdResizeFile( FileStream *, uint64_t Size); + /* ** printf() is only used for debugging purposes. ** It is not required for normal operation. diff --git a/csrc/pf_main.c b/csrc/pf_main.c index 5783f0f..1c7ef96 100644 --- a/csrc/pf_main.c +++ b/csrc/pf_main.c @@ -67,7 +67,7 @@ int main( int argc, char **argv ) char IfInit = FALSE; char *s; cell_t i; - int Result; + ThrowCode Result; /* For Metroworks on Mac */ #ifdef __MWERKS__ @@ -140,7 +140,7 @@ int main( int argc, char **argv ) Result = pfDoForth( DicName, SourceName, IfInit); on_error: - return Result; + return (int)Result; } #endif /* PF_EMBEDDED */ diff --git a/csrc/pf_save.c b/csrc/pf_save.c index ac2c85e..830eaee 100644 --- a/csrc/pf_save.c +++ b/csrc/pf_save.c @@ -332,7 +332,9 @@ static cell_t WriteChunkToFile( FileStream *fid, cell_t ID, char *Data, int32_t 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 @@ cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, 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 @@ cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, /* 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 @@ 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 @@ PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPt 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 @@ DBUG(("pfLoadDictionary( %s )\n", FileName )); /* Find special words in dictionary for global XTs. */ if( (Result = FindSpecialXTs()) < 0 ) { - pfReportError("pfLoadDictionary: FindSpecialXTs", Result); + pfReportError("pfLoadDictionary: FindSpecialXTs", (Err)Result); goto error; } } diff --git a/csrc/pf_text.h b/csrc/pf_text.h index 9918fe3..fd71371 100644 --- a/csrc/pf_text.h +++ b/csrc/pf_text.h @@ -54,9 +54,8 @@ void pfReportThrow( ThrowCode code ); char *ForthStringToC( char *dst, const char *FString, cell_t dstSize ); char *CStringToForth( char *dst, const char *CString, cell_t dstSize ); -cell_t ffCompare(const char *s1, cell_t len1, - const char *s2, cell_t len2 ); -cell_t ffCompareText(const char *s1, const char *s2, cell_t len ); +cell_t ffCompare( const char *s1, cell_t len1, const char *s2, cell_t len2 ); +cell_t ffCompareText( const char *s1, const char *s2, cell_t len ); cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len ); void DumpMemory( void *addr, cell_t cnt); diff --git a/csrc/pf_types.h b/csrc/pf_types.h index ac4f33b..619a2c0 100644 --- a/csrc/pf_types.h +++ b/csrc/pf_types.h @@ -23,6 +23,13 @@ ** Type Declarations ***************************************************************/ +#ifndef AMIGA +#include +#endif + +/* file_offset_t is used in place of off_t */ +typedef long file_offset_t; + #ifndef Err typedef long Err; #endif diff --git a/csrc/pf_words.c b/csrc/pf_words.c index 7a753ec..8fe2fd3 100644 --- a/csrc/pf_words.c +++ b/csrc/pf_words.c @@ -158,13 +158,25 @@ static cell_t HexDigitToNumber( char c ) /* Convert a string to the corresponding number using BASE. */ cell_t ffNumberQ( const char *FWord, cell_t *Num ) { - cell_t Len, i, Accum=0, n, Sign=1; + cell_t Len, i, Accum=0, n, Sign=1, Base=gVarBase; const char *s; /* get count */ Len = *FWord++; s = FWord; + switch (*s) { + case '#': Base = 10; s++; Len--; break; + case '$': Base = 16; s++; Len--; break; + case '%': Base = 2; s++; Len--; break; + case '\'': + if( Len == 3 && s[2] == '\'' ) + { + *Num = s[1]; + return NUM_TYPE_SINGLE; + } + } + /* process initial minus sign */ if( *s == '-' ) { @@ -176,12 +188,12 @@ cell_t ffNumberQ( const char *FWord, cell_t *Num ) for( i=0; i= gVarBase) ) + if( (n < 0) || (n >= Base) ) { return NUM_TYPE_BAD; } - Accum = (Accum * gVarBase) + n; + Accum = (Accum * Base) + n; } *Num = Accum * Sign; return NUM_TYPE_SINGLE; @@ -191,8 +203,11 @@ cell_t ffNumberQ( const char *FWord, cell_t *Num ) ** Compiler Support ***************************************************************/ -/* ( char -- c-addr , parse word ) */ -char * ffWord( char c ) +/* Skip whitespace, then parse input delimited by C. If UPCASE is true + * convert the word to upper case. The result is stored in + * gScratch. + */ +static char * Word ( char c, int Upcase ) { char *s1,*s2,*s3; cell_t n1, n2, n3; @@ -201,16 +216,16 @@ char * ffWord( char c ) s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN; n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN; n2 = ffSkip( s1, n1, c, &s2 ); -DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 )); +DBUGX(("Word: s2=%c, %d\n", *s2, n2 )); n3 = ffScan( s2, n2, c, &s3 ); -DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 )); +DBUGX(("Word: s3=%c, %d\n", *s3, n3 )); nc = n2-n3; if (nc > 0) { gScratch[0] = (char) nc; for( i=0; itd_IN += (n1-n3) + 1; return &gScratch[0]; } + +/* ( char -- c-addr , parse word ) */ +char * ffWord( char c ) +{ + return Word( c, TRUE ); +} + +/* ( char -- c-addr , parse word, preserving case ) */ +char * ffLWord( char c ) +{ + return Word( c, FALSE ); +} diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c index 04bc000..937e39e 100644 --- a/csrc/pfcompil.c +++ b/csrc/pfcompil.c @@ -258,6 +258,9 @@ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ) CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE", 0 ); CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION", 0 ); CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE", 0 ); + CreateDicEntryC( ID_FILE_FLUSH, "FLUSH-FILE", 0 ); + CreateDicEntryC( ID_FILE_RENAME, "(RENAME-FILE)", 0 ); + CreateDicEntryC( ID_FILE_RESIZE, "(RESIZE-FILE)", 0 ); CreateDicEntryC( ID_FILE_RO, "R/O", 0 ); CreateDicEntryC( ID_FILE_RW, "R/W", 0 ); CreateDicEntryC( ID_FILE_WO, "W/O", 0 ); @@ -343,6 +346,8 @@ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ) CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID", 0 ); CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID", 0 ); CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID", 0 ); + CreateDicEntryC( ID_SOURCE_LINE_NUMBER_FETCH, "SOURCE-LINE-NUMBER@", 0 ); + CreateDicEntryC( ID_SOURCE_LINE_NUMBER_STORE, "SOURCE-LINE-NUMBER!", 0 ); CreateDicEntryC( ID_SWAP, "SWAP", 0 ); CreateDicEntryC( ID_TEST1, "TEST1", 0 ); CreateDicEntryC( ID_TEST2, "TEST2", 0 ); @@ -831,7 +836,7 @@ ThrowCode ffInterpret( void ) { pfDebugMessage("ffInterpret: calling ffWord(()\n"); - theWord = ffWord( BLANK ); + theWord = ffLWord( BLANK ); DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord )); if( *theWord > 0 ) @@ -976,7 +981,7 @@ ThrowCode ffIncludeFile( FileStream *InputFile ) ***************************************************************/ Err ffPushInputStream( FileStream *InputFile ) { - cell_t Result = 0; + Err Result = 0; IncludeFrame *inf; /* Push current input state onto special include stack. */ diff --git a/csrc/pfcompil.h b/csrc/pfcompil.h index 3ff831c..1323fa5 100644 --- a/csrc/pfcompil.h +++ b/csrc/pfcompil.h @@ -38,6 +38,7 @@ cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr ); cell_t *NameToCode( ForthString *NFA ); PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ); char *ffWord( char c ); +char *ffLWord( char c ); const ForthString *NameToPrevious( const ForthString *NFA ); cell_t FindSpecialCFAs( void ); cell_t FindSpecialXTs( void ); diff --git a/csrc/pfinnrfp.h b/csrc/pfinnrfp.h index 6e2c628..23b379b 100644 --- a/csrc/pfinnrfp.h +++ b/csrc/pfinnrfp.h @@ -23,7 +23,7 @@ #ifdef PF_SUPPORT_FP -#define FP_DHI1 (((PF_FLOAT)(1L<<(sizeof(cell_t)*8-2)))*4.0) +#define FP_DHI1 (((PF_FLOAT)((cell_t)1<<(sizeof(cell_t)*8-2)))*4.0) case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */ PUSH_FP_TOS; @@ -207,7 +207,7 @@ case ID_FP_FROUND: PUSH_TOS; - TOS = fp_round(FP_TOS); + TOS = (cell_t)fp_round(FP_TOS); M_FP_DROP; break; diff --git a/csrc/pforth.h b/csrc/pforth.h index cd74336..96eb93f 100644 --- a/csrc/pforth.h +++ b/csrc/pforth.h @@ -39,7 +39,7 @@ extern "C" { #endif /* Main entry point to pForth. */ -cell_t pfDoForth( const char *DicName, const char *SourceName, cell_t IfInit ); +ThrowCode pfDoForth( const char *DicName, const char *SourceName, cell_t IfInit ); /* Turn off messages. */ void pfSetQuiet( cell_t IfQuiet ); @@ -78,7 +78,7 @@ void pfDeleteDictionary( PForthDictionary dict ); ThrowCode pfQuit( void ); /* Execute a single execution token in the current task and return 0 or an error code. */ -int pfCatch( ExecToken XT ); +ThrowCode pfCatch( ExecToken XT ); /* Include the given pForth source code file. */ ThrowCode pfIncludeFile( const char *FileName ); diff --git a/csrc/stdio/pf_fileio_stdio.c b/csrc/stdio/pf_fileio_stdio.c new file mode 100644 index 0000000..6c688ca --- /dev/null +++ b/csrc/stdio/pf_fileio_stdio.c @@ -0,0 +1,129 @@ +/*************************************************************** +** File access routines based on ANSI C (no Unix stuff). +** +** This file is part of pForth +** +** 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. +** +****************************************************************/ + +#include "../pf_all.h" + +#ifndef PF_NO_FILEIO + +#include /* For LONG_MAX */ + +typedef int bool_t; + +/* Copy SIZE bytes from File FROM to File TO. Return non-FALSE on error. */ +static bool_t CopyFile( FileStream *From, FileStream *To, long Size) +{ + bool_t Error = TRUE; + size_t Diff = Size; + size_t BufSize = 512; + char *Buffer = pfAllocMem( BufSize ); + if( Buffer != 0 ) + { + while( Diff > 0 ) + { + size_t N = MIN( Diff, BufSize ); + if( fread( Buffer, 1, N, From ) < N ) goto cleanup; + if( fwrite( Buffer, 1, N, To ) < N ) goto cleanup; + Diff -= N; + } + Error = FALSE; + + cleanup: + pfFreeMem( Buffer ); + } + return Error; +} + +/* Shrink the file FILE to NEWSIZE. Return non-FALSE on error. + * + * There's no direct way to do this in ANSI C. The closest thing we + * have is freopen(3), which truncates a file to zero length if we use + * "w+b" as mode argument. So we do this: + * + * 1. copy original content to temporary file + * 2. re-open and truncate FILE + * 3. copy the temporary file to FILE + * + * Unfortunately, "w+b" may not be the same mode as the original mode + * of FILE. I don't see a away to avoid this, though. + * + * We call freopen with NULL as path argument, because we don't know + * the actual file-name. It seems that the trick with path=NULL is + * not part of C89 but it's in C99. + */ +static bool_t TruncateFile( FileStream *File, long Newsize ) +{ + bool_t Error = TRUE; + if( fseek( File, 0, SEEK_SET ) == 0) + { + FileStream *TmpFile = tmpfile(); + if( TmpFile != NULL ) + { + if( CopyFile( File, TmpFile, Newsize )) goto cleanup; + if( fseek( TmpFile, 0, SEEK_SET ) != 0 ) goto cleanup; + if( freopen( NULL, "w+b", File ) == NULL ) goto cleanup; + if( CopyFile( TmpFile, File, Newsize )) goto cleanup; + Error = FALSE; + + cleanup: + fclose( TmpFile ); + } + } + return Error; +} + +/* Write DIFF 0 bytes to FILE. Return non-FALSE on error. */ +static bool_t ExtendFile( FileStream *File, size_t Diff ) +{ + bool_t Error = TRUE; + size_t BufSize = 512; + char * Buffer = pfAllocMem( BufSize ); + if( Buffer != 0 ) + { + pfSetMemory( Buffer, 0, BufSize ); + while( Diff > 0 ) + { + size_t N = MIN( Diff, BufSize ); + if( fwrite( Buffer, 1, N, File ) < N ) goto cleanup; + Diff -= N; + } + Error = FALSE; + cleanup: + pfFreeMem( Buffer ); + } + return Error; +} + +ThrowCode sdResizeFile( FileStream *File, uint64_t Size ) +{ + bool_t Error = TRUE; + if( Size <= LONG_MAX ) + { + long Newsize = (long) Size; + if( fseek( File, 0, SEEK_END ) == 0 ) + { + long Oldsize = ftell( File ); + if( Oldsize != -1L ) + { + Error = ( Oldsize <= Newsize + ? ExtendFile( File, Newsize - Oldsize ) + : TruncateFile( File, Newsize )); + } + } + } + return Error ? THROW_RESIZE_FILE : 0; +} + +#endif /* !PF_NO_FILEIO */ diff --git a/fth/ansilocs.fth b/fth/ansilocs.fth index 33c0c71..3423bfc 100644 --- a/fth/ansilocs.fth +++ b/fth/ansilocs.fth @@ -10,7 +10,7 @@ \ local-compiler ( -- addr , variable containing CFA of locals compiler ) \ \ 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 diff --git a/fth/c_struct.fth b/fth/c_struct.fth index 46651ad..bd06a50 100644 --- a/fth/c_struct.fth +++ b/fth/c_struct.fth @@ -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 diff --git a/fth/case.fth b/fth/case.fth index 830dc83..67d924e 100644 --- a/fth/case.fth +++ b/fth/case.fth @@ -5,7 +5,7 @@ \ >MARK >RESOLVE ?BRANCH etc. are not needed if one has IF ELSE THEN etc. \ \ 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 diff --git a/fth/file.fth b/fth/file.fth new file mode 100644 index 0000000..59303f0 --- /dev/null +++ b/fth/file.fth @@ -0,0 +1,160 @@ +\ READ-LINE and WRITE-LINE +\ +\ This code is part of pForth. +\ +\ 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. + +private{ + +10 constant \N +13 constant \R + +\ Unread one char from file FILEID. +: UNREAD { fileid -- ior } + fileid file-position ( ud ior ) + ?dup + IF nip nip \ IO error + ELSE 1 s>d d- fileid reposition-file + THEN +; + +\ Read the next available char from file FILEID and if it is a \n then +\ skip it; otherwise unread it. IOR is non-zero if an error occured. +\ C-ADDR is a buffer that can hold at least one char. +: SKIP-\N { c-addr fileid -- ior } + c-addr 1 fileid read-file ( u ior ) + ?dup + IF \ Read error? + nip + ELSE ( u ) + 0= + IF \ End of file? + 0 + ELSE + c-addr c@ \n = ( is-it-a-\n? ) + IF 0 + ELSE fileid unread + THEN + THEN + THEN +; + +\ This is just s\" \n" but s\" isn't yet available. +create (LINE-TERMINATOR) \n c, +: LINE-TERMINATOR ( -- c-addr u ) (line-terminator) 1 ; + +\ Standard throw code +\ See: http://lars.nocrew.org/forth2012/exception.html#table:throw +-72 constant THROW_RENAME_FILE + +\ Copy the string C-ADDR/U1 to C-ADDR2 and append a NUL. +: PLACE-CSTR ( c-addr1 u1 c-addr2 -- ) + 2dup 2>r ( c-addr1 u1 c-addr2 ) ( r: u1 c-addr2 ) + swap cmove ( ) ( r: u1 c-addr2 ) + 0 2r> + c! ( ) +; + +: MULTI-LINE-COMMENT ( "comment" -- ) + BEGIN + >in @ ')' parse ( >in c-addr len ) + nip + >in @ = ( delimiter-not-found? ) + WHILE ( ) + refill 0= IF EXIT THEN ( ) + REPEAT +; + +}private + +\ This treats \n, \r\n, and \r as line terminator. Reading is done +\ one char at a time with READ-FILE hence READ-FILE should probably do +\ some form of buffering for good efficiency. +: READ-LINE ( c-addr u1 fileid -- u2 flag ior ) + { a u f } + u 0 ?DO + a i chars + 1 f read-file ( u ior' ) + ?dup IF nip i false rot UNLOOP EXIT THEN \ Read error? ( u ) + 0= IF i i 0<> 0 UNLOOP EXIT THEN \ End of file? ( ) + a i chars + c@ + CASE + \n OF i true 0 UNLOOP EXIT ENDOF + \r OF + \ Detect \r\n + a i chars + f skip-\n ( ior ) + ?dup IF i false rot UNLOOP EXIT THEN \ IO Error? ( ) + i true 0 UNLOOP EXIT + ENDOF + ENDCASE + LOOP + \ Line doesn't fit in buffer + u true 0 +; + +: WRITE-LINE ( c-addr u fileid -- ior ) + { f } + f write-file ( ior ) + ?dup + IF \ IO error + ELSE line-terminator f write-file + THEN +; + +: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior ) + { a1 u1 a2 u2 | new } + \ Convert the file-names to C-strings by copying them after HERE. + a1 u1 here place-cstr + here u1 1+ chars + to new + a2 u2 new place-cstr + here new (rename-file) 0= + IF 0 + ELSE throw_rename_file + THEN +; + +\ A limit used to perform a sanity check on the size argument for +\ RESIZE-FILE. +2variable RESIZE-FILE-LIMIT +10000000 0 resize-file-limit 2! \ 10MB is somewhat arbitrarily chosen + +: RESIZE-FILE ( ud fileid -- ior ) + -rot 2dup resize-file-limit 2@ d> ( fileid ud big? ) + IF + ." Argument (" 0 d.r ." ) is larger then RESIZE-FILE-LIMIT." cr + ." (You can increase RESIZE-FILE-LIMIT with 2!)" cr + abort + ELSE + rot (resize-file) + THEN +; + +: ( ( "comment" -- ) + source-id + CASE + -1 OF postpone ( ENDOF + 0 OF postpone ( ENDOF + \ for input from files + multi-line-comment + ENDCASE +; immediate + +\ We basically try to open the file in read-only mode. That seems to +\ be the best that we can do with ANSI C. If we ever want to do +\ something more sophisticated, like calling access(2), we must create +\ a proper primitive. (OTOH, portable programs can't assume much +\ about FILE-STATUS and non-portable programs could create a custom +\ function for access(2).) +: FILE-STATUS ( c-addr u -- 0 ior ) + r/o bin open-file ( fileid ior1 ) + ?dup + IF nip 0 swap ( 0 ior1 ) + ELSE close-file 0 swap ( 0 ior2 ) + THEN +; + +privatize diff --git a/fth/floats.fth b/fth/floats.fth index 650730f..7ac31fd 100644 --- a/fth/floats.fth +++ b/fth/floats.fth @@ -2,7 +2,7 @@ \ High Level Forth support for Floating Point \ \ Author: Phil Burk and Darren Gibbs -\ 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 diff --git a/fth/forget.fth b/fth/forget.fth index 3971100..e4eaf97 100644 --- a/fth/forget.fth +++ b/fth/forget.fth @@ -4,7 +4,7 @@ \ forget part of dictionary \ \ 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 diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth index 2e9c2ad..0973fc9 100644 --- a/fth/loadp4th.fth +++ b/fth/loadp4th.fth @@ -2,7 +2,7 @@ \ Load various files needed by PForth \ \ 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 @@ -24,6 +24,9 @@ include? { locals.fth include? fm/mod math.fth include? task-misc2.fth misc2.fth include? [if] condcomp.fth +include? save-input save-input.fth +include? read-line file.fth +include? require require.fth \ load floating point support if basic support is in kernel exists? F* diff --git a/fth/locals.fth b/fth/locals.fth index a145781..50a96db 100644 --- a/fth/locals.fth +++ b/fth/locals.fth @@ -3,7 +3,7 @@ \ based on ANSI basis words (LOCAL) and TO \ \ 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 diff --git a/fth/math.fth b/fth/math.fth index 891849c..9dd780f 100644 --- a/fth/math.fth +++ b/fth/math.fth @@ -3,7 +3,7 @@ \ FM/MOD SM/REM \ \ 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 diff --git a/fth/member.fth b/fth/member.fth index 7ff61c5..ceccc55 100644 --- a/fth/member.fth +++ b/fth/member.fth @@ -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 diff --git a/fth/misc1.fth b/fth/misc1.fth index da9c154..0738121 100644 --- a/fth/misc1.fth +++ b/fth/misc1.fth @@ -2,7 +2,7 @@ \ miscellaneous words \ \ 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 diff --git a/fth/misc2.fth b/fth/misc2.fth index 09f585f..c0791da 100644 --- a/fth/misc2.fth +++ b/fth/misc2.fth @@ -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 @@ anew task-misc2.fth variable if-debug +: ? ( address -- , fatch from address and print value ) + @ . +; + decimal create msec-delay 10000 , ( default for SUN ) : (MSEC) ( #msecs -- ) @@ -233,3 +237,40 @@ VARIABLE SPAN 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 --git a/fth/numberio.fth b/fth/numberio.fth index 833ca69..05ec4da 100644 --- a/fth/numberio.fth +++ b/fth/numberio.fth @@ -4,7 +4,7 @@ \ numeric conversion \ \ 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 @@ -84,21 +84,43 @@ decimal 1 constant NUM_TYPE_SINGLE 2 constant NUM_TYPE_DOUBLE +\ Like >number, but temporarily switch BASE. +: (>number-with-base) ( ud c-addr u base -- ud' c-addr' u' ) + base @ >r base ! >number r> base ! +; + \ This is similar to the F83 NUMBER? except that it returns a number type \ and then either a single or double precision number. : ((NUMBER?)) ( c-addr u -- 0 | n 1 | d 2 , convert string to number ) dup 0= IF 2drop NUM_TYPE_BAD exit THEN \ any chars? -\ prepare for >number - 0 0 2swap ( 0 0 c-addr cnt ) + base @ -rot ( base c-addr u ) + + \ Recognize prefixes and change base if needed + over c@ >r ( base c-addr u ) ( r: char ) + r@ [char] # = if rot drop 10 -rot 1 /string then + r@ [char] $ = if rot drop 16 -rot 1 /string then + r@ [char] % = if rot drop 2 -rot 1 /string then + r@ [char] ' = if + \ Recognize '' + dup 3 = if + over 2 chars + c@ [char] ' = if + drop nip rdrop + char+ c@ NUM_TYPE_SINGLE exit + then + then + then + r> drop \ check for '-' at beginning, skip if present over c@ ascii - = \ is it a '-' dup >r \ save flag - IF 1- >r 1+ r> ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign ) + IF 1 /string ( -- base c-addr+1 cnt-1 , skip past minus sign ) THEN -\ - >number dup 0= \ convert as much as we can + + ( base c-addr cnt ) ( r: minus-flag ) + rot >r 0 0 2swap r> + (>number-with-base) dup 0= \ convert as much as we can IF 2drop \ drop addr cnt drop \ drop hi part of num diff --git a/fth/require.fth b/fth/require.fth new file mode 100644 index 0000000..18a060a --- /dev/null +++ b/fth/require.fth @@ -0,0 +1,34 @@ +\ REQUIRE and REQUIRED +\ +\ This code is part of pForth. +\ +\ 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. + +private{ + +\ Has the file with name C-ADDR/U already been included? +\ +\ This searches the "::::" marker created by INCLUDED. This +\ works for now, but may break if pForth ever receives wordlists. +: INCLUDED? ( c-addr u -- flag ) + s" ::::" here place ( c-addr u ) + here $append ( ) + here find nip 0<> ( found? ) +; + +\ FIXME: use real PARSE-NAME when available +: (PARSE-NAME) ( "word" -- c-addr u ) bl parse-word ; + +}private + +: REQUIRED ( i*x c-addr u -- j*x ) 2dup included? IF 2drop ELSE included THEN ; +: REQUIRE ( i*x "name" -- i*x ) (parse-name) required ; + +privatize diff --git a/fth/save-input.fth b/fth/save-input.fth new file mode 100644 index 0000000..9654358 --- /dev/null +++ b/fth/save-input.fth @@ -0,0 +1,82 @@ +\ SAVE-INPUT and RESTORE-INPUT +\ +\ This code is part of pForth. +\ +\ 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. + +anew task-save-input.fth + +private{ + +: SAVE-BUFFER ( -- column source-id 2 ) >in @ source-id 2 ; + +\ Restore >IN from COLUMN unless COLUMN is too large. Valid values +\ for COLUMN are from 0 to (including) the length of SOURCE plus one. +: RESTORE-COLUMN ( column -- flag ) + source nip 1+ over u< + IF drop true + ELSE >in ! false + THEN +; + +\ Return the file-position of the beginning of the current line in +\ file SOURCE-ID. Assume that the current line is stored in SOURCE +\ and that the current file-position is at an end-of-line (or +\ end-of-file). +: LINE-START-POSITION ( -- ud ) + source-id file-position throw + \ unless at end-of-file, subtract newline + source-id file-size throw 2over d= 0= IF 1 s>d d- THEN + \ subtract line length + source nip s>d d- +; + +: SAVE-FILE ( column line filepos:ud source-id 5 -- ) + >in @ + source-line-number@ + line-start-position + source-id + 5 +; + +: RESTORE-FILE ( column line filepos:ud -- flag ) + source-id reposition-file IF 2drop true EXIT THEN + refill 0= IF 2drop true EXIT THEN + source-line-number! + restore-column +; + +: NDROP ( n*x n -- ) 0 ?DO drop LOOP ; + +}private + +\ Source Stack +\ EVALUATE >IN SourceID=(-1) 2 +\ keyboard >IN SourceID=(0) 2 +\ file >IN lineNumber filePos SourceID=(fileID) 5 +: SAVE-INPUT ( -- column {line filepos}? source-id n ) + source-id CASE + -1 OF save-buffer ENDOF + 0 OF save-buffer ENDOF + drop save-file EXIT + ENDCASE +; + +: RESTORE-INPUT ( column {line filepos}? source-id n -- flag ) + over source-id <> IF ndrop true EXIT THEN + drop + CASE + -1 OF restore-column ENDOF + 0 OF restore-column ENDOF + drop restore-file EXIT + ENDCASE +; + +privatize diff --git a/fth/smart_if.fth b/fth/smart_if.fth index 2234e18..ab2028e 100644 --- a/fth/smart_if.fth +++ b/fth/smart_if.fth @@ -5,7 +5,7 @@ \ Thanks to Mitch Bradley for the idea. \ \ 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 diff --git a/fth/system.fth b/fth/system.fth index bed4334..c84f08b 100644 --- a/fth/system.fth +++ b/fth/system.fth @@ -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 @@ 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 @@ ustack 0stackp \ -------------- 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 @@ variable TRACE-INCLUDE rdrop ; +: $INCLUDE ( $filename -- ) count included ; + create INCLUDE-SAVE-NAME 128 allot : INCLUDE ( -- ) BL lword diff --git a/fth/t_corex.fth b/fth/t_corex.fth index 33103f4..f2b3f19 100644 --- a/fth/t_corex.fth +++ b/fth/t_corex.fth @@ -9,10 +9,6 @@ ANEW TASK-T_COREX.FTH DECIMAL -\ STUB because missing definition in pForth - FIXME -: SAVE-INPUT ; -: RESTORE-INPUT -1 ; - TEST{ \ ========================================================== @@ -155,7 +151,20 @@ T{ ' QUERY 0<> }T{ TRUE }T T{ ' REFILL 0<> }T{ TRUE }T \ ----------------------------------------------------- RESTORE-INPUT -T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE +T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T + +\ TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +VARIABLE SI_INC 0 SI_INC ! + +: SI1 + SI_INC @ >IN +! + 15 SI_INC ! +; + +: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +T{ S$ EVALUATE SI_INC @ }T{ 0 2345 15 }T \ ----------------------------------------------------- ROLL T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T @@ -222,5 +231,104 @@ T{ 10 -5 10 WITHIN }T{ 0 }T T{ T.[COMPILE] }T{ TRUE }T \ ----------------------------------------------------- \ + +\ .( TESTING DO +LOOP with large and small increments ) + +\ Contributed by Andrew Haley +0 invert CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP +USTEP NEGATE CONSTANT -USTEP +MAX-INT 7 RSHIFT 1+ CONSTANT STEP +STEP NEGATE CONSTANT -STEP + +VARIABLE BUMP + +T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; }T{ }T + +T{ 0 MAX-UINT 0 USTEP GD8 }T{ 256 }T +T{ 0 0 MAX-UINT -USTEP GD8 }T{ 256 }T + +T{ 0 MAX-INT MIN-INT STEP GD8 }T{ 256 }T +T{ 0 MIN-INT MAX-INT -STEP GD8 }T{ 256 }T + +\ Two's complement arithmetic, wraps around modulo wordsize +\ Only tested if the Forth system does wrap around, use of conditional +\ compilation deliberately avoided + +MAX-INT 1+ MIN-INT = CONSTANT +WRAP? +MIN-INT 1- MAX-INT = CONSTANT -WRAP? +MAX-UINT 1+ 0= CONSTANT +UWRAP? +0 1- MAX-UINT = CONSTANT -UWRAP? + +: GD9 ( n limit start step f result -- ) + >R IF GD8 ELSE 2DROP 2DROP R@ THEN }T{ R> }T +; + +T{ 0 0 0 USTEP +UWRAP? 256 GD9 +T{ 0 0 0 -USTEP -UWRAP? 1 GD9 +T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 +T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 + +\ -------------------------------------------------------------------------- +\ .( TESTING DO +LOOP with maximum and minimum increments ) + +: (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; +(-MI) CONSTANT -MAX-INT + +T{ 0 1 0 MAX-INT GD8 }T{ 1 }T +T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 }T{ 2 }T + +T{ 0 MAX-INT 0 MAX-INT GD8 }T{ 1 }T +T{ 0 MAX-INT 1 MAX-INT GD8 }T{ 1 }T +T{ 0 MAX-INT -1 MAX-INT GD8 }T{ 2 }T +T{ 0 MAX-INT DUP 1- MAX-INT GD8 }T{ 1 }T + +T{ 0 MIN-INT 1+ 0 MIN-INT GD8 }T{ 1 }T +T{ 0 MIN-INT 1+ -1 MIN-INT GD8 }T{ 1 }T +T{ 0 MIN-INT 1+ 1 MIN-INT GD8 }T{ 2 }T +T{ 0 MIN-INT 1+ DUP MIN-INT GD8 }T{ 1 }T + +\ ---------------------------------------------------------------------------- +\ .( TESTING number prefixes # $ % and 'c' character input ) +\ Adapted from the Forth 200X Draft 14.5 document + +VARIABLE OLD-BASE +DECIMAL BASE @ OLD-BASE ! +T{ #1289 }T{ 1289 }T +T{ #-1289 }T{ -1289 }T +T{ $12eF }T{ 4847 }T +T{ $-12eF }T{ -4847 }T +T{ %10010110 }T{ 150 }T +T{ %-10010110 }T{ -150 }T +T{ 'z' }T{ 122 }T +T{ 'Z' }T{ 90 }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = }T{ TRUE }T + +\ Repeat in Hex mode +16 OLD-BASE ! 16 BASE ! +T{ #1289 }T{ 509 }T +T{ #-1289 }T{ -509 }T +T{ $12eF }T{ 12EF }T +T{ $-12eF }T{ -12EF }T +T{ %10010110 }T{ 96 }T +T{ %-10010110 }T{ -96 }T +T{ 'z' }T{ 7a }T +T{ 'Z' }T{ 5a }T +\ Check BASE is unchanged +T{ BASE @ OLD-BASE @ = }T{ TRUE }T \ 2 + +DECIMAL +\ Check number prefixes in compile mode +T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T + +\ ----------------------------------------------------- ENVIRONMENT? + +T{ s" unknown-query-string" ENVIRONMENT? }T{ FALSE }T +T{ s" MAX-CHAR" ENVIRONMENT? }T{ 255 TRUE }T +T{ s" ADDRESS-UNITS-BITS" ENVIRONMENT? }T{ 8 TRUE }T + }TEST diff --git a/fth/t_file.fth b/fth/t_file.fth new file mode 100644 index 0000000..297f208 --- /dev/null +++ b/fth/t_file.fth @@ -0,0 +1,344 @@ +\ Test PForth FILE wordset + +\ To test the ANS File Access word set and extension words + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ---------------------------------------------------------------------------- +\ Version 0.13 S" in interpretation mode tested. +\ Added SAVE-INPUT RESTORE-INPUT REFILL in a file, (moved from +\ coreexttest.fth). +\ Calls to COMPARE replaced with S= (in utilities.fth) +\ 0.11 25 April 2015 S\" in interpretation mode test added +\ REQUIRED REQUIRE INCLUDE tests added +\ Two S" and/or S\" buffers availability tested +\ 0.5 1 April 2012 Tests placed in the public domain. +\ 0.4 22 March 2009 { and } replaced with T{ and }T +\ 0.3 20 April 2007 ANS Forth words changed to upper case. +\ Removed directory test from the filenames. +\ 0.2 30 Oct 2006 updated following GForth tests to remove +\ system dependency on file size, to allow for file +\ buffering and to allow for PAD moving around. +\ 0.1 Oct 2006 First version released. + +\ ---------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set +\ and requires those files to have been loaded + +\ Words tested in this file are: +\ ( BIN CLOSE-FILE CREATE-FILE DELETE-FILE FILE-POSITION FILE-SIZE +\ OPEN-FILE R/O R/W READ-FILE READ-LINE REPOSITION-FILE RESIZE-FILE +\ S" S\" SOURCE-ID W/O WRITE-FILE WRITE-LINE +\ FILE-STATUS FLUSH-FILE RENAME-FILE SAVE-INPUT RESTORE-INPUT +\ REFILL + +\ Words not tested: +\ INCLUDED INCLUDE-FILE (as these will likely have been +\ tested in the execution of the test files) +\ ---------------------------------------------------------------------------- +\ Assumptions, dependencies and notes: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set is available and tested +\ - These tests create files in the current directory, if all goes +\ well these will be deleted. If something fails they may not be +\ deleted. If this is a problem ensure you set a suitable +\ directory before running this test. There is no ANS standard +\ way of doing this. Also be aware of the file names used below +\ which are: fatest1.txt, fatest2.txt and fatest3.txt +\ ---------------------------------------------------------------------------- + +include? }T{ t_tools.fth + +true fp-require-e ! + +false value verbose + +: testing + verbose IF + source >in @ /string ." TESTING: " type cr + THEN + source nip >in ! +; immediate + +: -> }T{ ; +: s= compare 0= ; +: $" state IF postpone s" else ['] s" execute THEN ; immediate + +TESTING File Access word set + +DECIMAL + +TEST{ + +\ ---------------------------------------------------------------------------- +TESTING CREATE-FILE CLOSE-FILE + +: FN1 S" fatest1.txt" ; +VARIABLE FID1 + +T{ FN1 R/W CREATE-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING OPEN-FILE W/O WRITE-LINE + +: LINE1 S" Line 1" ; + +T{ FN1 W/O OPEN-FILE SWAP FID1 ! -> 0 }T +T{ LINE1 FID1 @ WRITE-LINE -> 0 }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING R/O FILE-POSITION (simple) READ-LINE + +200 CONSTANT BSIZE +CREATE BUF BSIZE ALLOT +VARIABLE #CHARS + +T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ FILE-POSITION -> 0. 0 }T +T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 SWAP DROP }T +T{ BUF #CHARS @ LINE1 S= -> TRUE }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ Test with buffer shorter than line. +T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ FILE-POSITION -> 0. 0 }T +T{ BUF 0 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 0 }T +T{ BUF 3 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 3 }T +T{ BUF #CHARS @ LINE1 DROP 3 S= -> TRUE }T +T{ BUF 100 FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP 3 - }T +T{ BUF #CHARS @ LINE1 3 /STRING S= -> TRUE }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ Test with buffer exactly as long as the line. +T{ FN1 R/O OPEN-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ FILE-POSITION -> 0. 0 }T +T{ BUF LINE1 NIP FID1 @ READ-LINE ROT DUP #CHARS ! -> TRUE 0 LINE1 NIP }T +T{ BUF #CHARS @ LINE1 S= -> TRUE }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING S" in interpretation mode (compile mode tested in Core tests) + +T{ S" abcdef" $" abcdef" S= -> TRUE }T +T{ S" " $" " S= -> TRUE }T +T{ S" ghi"$" ghi" S= -> TRUE }T + +\ ---------------------------------------------------------------------------- +TESTING R/W WRITE-FILE REPOSITION-FILE READ-FILE FILE-POSITION S" + +: LINE2 S" Line 2 blah blah blah" ; +: RL1 BUF 100 FID1 @ READ-LINE ; +2VARIABLE FP + +T{ FN1 R/W OPEN-FILE SWAP FID1 ! -> 0 }T +T{ FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE -> 0 }T +T{ FID1 @ FILE-SIZE -> FID1 @ FILE-POSITION }T +T{ LINE2 FID1 @ WRITE-FILE -> 0 }T +T{ 10. FID1 @ REPOSITION-FILE -> 0 }T +T{ FID1 @ FILE-POSITION -> 10. 0 }T +T{ 0. FID1 @ REPOSITION-FILE -> 0 }T +T{ RL1 -> LINE1 SWAP DROP TRUE 0 }T +T{ RL1 ROT DUP #CHARS ! -> TRUE 0 LINE2 SWAP DROP }T +T{ BUF #CHARS @ LINE2 S= -> TRUE }T +T{ RL1 -> 0 FALSE 0 }T +T{ FID1 @ FILE-POSITION ROT ROT FP 2! -> 0 }T +T{ FP 2@ FID1 @ FILE-SIZE DROP D= -> TRUE }T +T{ S" " FID1 @ WRITE-LINE -> 0 }T +T{ S" " FID1 @ WRITE-LINE -> 0 }T +T{ FP 2@ FID1 @ REPOSITION-FILE -> 0 }T +T{ RL1 -> 0 TRUE 0 }T +T{ RL1 -> 0 TRUE 0 }T +T{ RL1 -> 0 FALSE 0 }T +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING BIN READ-FILE FILE-SIZE + +: CBUF BUF BSIZE 0 FILL ; +: FN2 S" FATEST2.TXT" ; +VARIABLE FID2 +: SETPAD PAD 50 0 DO I OVER C! CHAR+ LOOP DROP ; + +SETPAD \ If anything else is defined setpad must be called again + \ as pad may move + +T{ FN2 R/W BIN CREATE-FILE SWAP FID2 ! -> 0 }T +T{ PAD 50 FID2 @ WRITE-FILE FID2 @ FLUSH-FILE -> 0 0 }T +T{ FID2 @ FILE-SIZE -> 50. 0 }T +T{ 0. FID2 @ REPOSITION-FILE -> 0 }T +T{ CBUF BUF 29 FID2 @ READ-FILE -> 29 0 }T +T{ PAD 29 BUF 29 S= -> TRUE }T +T{ PAD 30 BUF 30 S= -> FALSE }T +T{ CBUF BUF 29 FID2 @ READ-FILE -> 21 0 }T +T{ PAD 29 + 21 BUF 21 S= -> TRUE }T +T{ FID2 @ FILE-SIZE DROP FID2 @ FILE-POSITION DROP D= -> TRUE }T +T{ BUF 10 FID2 @ READ-FILE -> 0 0 }T +T{ FID2 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING RESIZE-FILE + +T{ FN2 R/W BIN OPEN-FILE SWAP FID2 ! -> 0 }T +T{ 37. FID2 @ RESIZE-FILE -> 0 }T +T{ FID2 @ FILE-SIZE -> 37. 0 }T +T{ 0. FID2 @ REPOSITION-FILE -> 0 }T +T{ CBUF BUF 100 FID2 @ READ-FILE -> 37 0 }T +T{ PAD 37 BUF 37 S= -> TRUE }T +T{ PAD 38 BUF 38 S= -> FALSE }T +T{ 500. FID2 @ RESIZE-FILE -> 0 }T +T{ FID2 @ FILE-SIZE -> 500. 0 }T +T{ 0. FID2 @ REPOSITION-FILE -> 0 }T +T{ CBUF BUF 100 FID2 @ READ-FILE -> 100 0 }T +T{ PAD 37 BUF 37 S= -> TRUE }T +T{ FID2 @ CLOSE-FILE -> 0 }T + +\ ---------------------------------------------------------------------------- +TESTING DELETE-FILE + +T{ FN2 DELETE-FILE -> 0 }T +T{ FN2 R/W BIN OPEN-FILE SWAP DROP 0= -> FALSE }T +T{ FN2 DELETE-FILE 0= -> FALSE }T + +\ ---------------------------------------------------------------------------- +TESTING multi-line ( comments + +T{ ( 1 2 3 +4 5 6 +7 8 9 ) 11 22 33 -> 11 22 33 }T + +\ ---------------------------------------------------------------------------- +TESTING SOURCE-ID (can only test it does not return 0 or -1) + +T{ SOURCE-ID DUP -1 = SWAP 0= OR -> FALSE }T + +\ ---------------------------------------------------------------------------- +TESTING RENAME-FILE FILE-STATUS FLUSH-FILE + +: FN3 S" fatest3.txt" ; +: >END FID1 @ FILE-SIZE DROP FID1 @ REPOSITION-FILE ; + + +T{ FN3 DELETE-FILE DROP -> }T +T{ FN1 FN3 RENAME-FILE 0= -> TRUE }T +T{ FN1 FILE-STATUS SWAP DROP 0= -> FALSE }T +T{ FN3 FILE-STATUS SWAP DROP 0= -> TRUE }T \ Return value is undefined +T{ FN3 R/W OPEN-FILE SWAP FID1 ! -> 0 }T +T{ >END -> 0 }T +T{ S" Final line" fid1 @ WRITE-LINE -> 0 }T + +T{ FID1 @ FLUSH-FILE -> 0 }T \ Can only test FLUSH-FILE doesn't fail +T{ FID1 @ CLOSE-FILE -> 0 }T + +\ Tidy the test folder +T{ fn3 DELETE-FILE DROP -> }T + +\ ------------------------------------------------------------------------------ +TESTING REQUIRED REQUIRE INCLUDED +\ Tests taken from Forth 2012 RfD + +T{ 0 S" t_required_helper1.fth" REQUIRED + REQUIRE t_required_helper1.fth + INCLUDE t_required_helper1.fth + -> 2 }T + +T{ 0 INCLUDE t_required_helper2.fth + S" t_required_helper2.fth" REQUIRED + REQUIRE t_required_helper2.fth + S" t_required_helper2.fth" INCLUDED + -> 2 }T + +\ ---------------------------------------------------------------------------- +TESTING two buffers available for S" and/or S\" (Forth 2012) + +: SSQ12 S" abcd" ; : SSQ13 S" 1234" ; +T{ S" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T +\ nyi T{ S\" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T +\ nyi T{ S" abcd" S\" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T +\ nyi T{ S\" abcd" S" 1234" SSQ13 S= ROT ROT SSQ12 S= -> TRUE TRUE }T + + +\ ----------------------------------------------------------------------------- +TESTING SAVE-INPUT and RESTORE-INPUT with a file source + +VARIABLE SIV -1 SIV ! + +: NEVEREXECUTED + CR ." This should never be executed" CR +; + +T{ 11111 SAVE-INPUT + +SIV @ + +[IF] + TESTING the -[IF]- part is executed + 0 SIV ! + RESTORE-INPUT + NEVEREXECUTED + 33333 +[ELSE] + + TESTING the -[ELSE]- part is executed + 22222 + +[THEN] + + -> 11111 0 22222 }T \ 0 comes from RESTORE-INPUT + +TESTING nested SAVE-INPUT, RESTORE-INPUT and REFILL from a file + +: READ_A_LINE + REFILL 0= + ABORT" REFILL FAILED" +; + +VARIABLE SI_INC 0 SI_INC ! + +: SI1 + SI_INC @ >IN +! + 15 SI_INC ! +; + +: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +CREATE 2RES -1 , -1 , \ Don't use 2VARIABLE from Double number word set + +: SI2 + READ_A_LINE + READ_A_LINE + SAVE-INPUT + READ_A_LINE + READ_A_LINE + S$ EVALUATE 2RES 2! + RESTORE-INPUT +; + +\ WARNING: do not delete or insert lines of text after si2 is called +\ otherwise the next test will fail + +T{ SI2 +33333 \ This line should be ignored +2RES 2@ 44444 \ RESTORE-INPUT should return to this line + +55555 +TESTING the nested results + -> 0 0 2345 44444 55555 }T + +\ End of warning + +\ ---------------------------------------------------------------------------- + +\ CR .( End of File-Access word set tests) CR + +}TEST diff --git a/fth/t_required_helper1.fth b/fth/t_required_helper1.fth new file mode 100644 index 0000000..910cef4 --- /dev/null +++ b/fth/t_required_helper1.fth @@ -0,0 +1,3 @@ +\ For testing REQUIRED etc + +1+ diff --git a/fth/t_required_helper2.fth b/fth/t_required_helper2.fth new file mode 100644 index 0000000..910cef4 --- /dev/null +++ b/fth/t_required_helper2.fth @@ -0,0 +1,3 @@ +\ For testing REQUIRED etc + +1+ diff --git a/fth/wordslik.fth b/fth/wordslik.fth index e5ebd5a..4f2d12a 100644 --- a/fth/wordslik.fth +++ b/fth/wordslik.fth @@ -6,7 +6,7 @@ \ Enter: WORDS.LIKE EMIT \ \ 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 diff --git a/readme.txt b/readme.txt index de7cf90..8793b43 100644 --- a/readme.txt +++ b/readme.txt @@ -4,7 +4,7 @@ by Phil Burk with Larry Polansky, David Rosenboom and Darren Gibbs. Support for 64-bit cells by Aleksej Saushev. -Last updated: December 23, 2014 V27 +Last updated: April 24, 2018 V28 Code for pForth is maintained on GitHub at: https://github.com/philburk/pforth @@ -29,7 +29,6 @@ purpose and their equivalents under the laws of any jurisdiction. -- Contents of SDK -------------------------------------- build - tools for building pForth on various platforms - build/win32/vs2005 - Visual Studio 2005 Project and Solution build/unix - Makefile for unix csrc - pForth kernel in ANSI 'C' diff --git a/releases.txt b/releases.txt index c611579..74c975a 100644 --- a/releases.txt +++ b/releases.txt @@ -2,7 +2,13 @@ Release History for pForth - a Portable ANS-like Forth written in ANSI 'C' Documentation for pForth at http://www.softsynth.com/pforth/ -V28 - unreleased +V29 - unreleased + +V28 - 4/24/2018 + - remove off_t + - too many changes to list, see commit history (TODO add changes) + - fix $ROM + - fix HISTORY - fixes for MinGW build V27 - 11/22/2010