--- /dev/null
+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
--- /dev/null
+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
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
#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
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)
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 \
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)
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)
+++ /dev/null
-\r
-Microsoft Visual Studio Solution File, Format Version 9.00\r
-# Visual Studio 2005\r
-Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "pforth_main", "pforth_main.vcproj", "{58B76DB8-1985-4B8A-8E71-C012D8F0C518}"\r
-EndProject\r
-Global\r
- GlobalSection(SolutionConfigurationPlatforms) = preSolution\r
- Debug|Win32 = Debug|Win32\r
- Release|Win32 = Release|Win32\r
- EndGlobalSection\r
- GlobalSection(ProjectConfigurationPlatforms) = postSolution\r
- {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|Win32.ActiveCfg = Debug|Win32\r
- {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Debug|Win32.Build.0 = Debug|Win32\r
- {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|Win32.ActiveCfg = Release|Win32\r
- {58B76DB8-1985-4B8A-8E71-C012D8F0C518}.Release|Win32.Build.0 = Release|Win32\r
- EndGlobalSection\r
- GlobalSection(SolutionProperties) = preSolution\r
- HideSolutionNode = FALSE\r
- EndGlobalSection\r
-EndGlobal\r
+++ /dev/null
-<?xml version="1.0" encoding="Windows-1252"?>\r
-<VisualStudioProject\r
- ProjectType="Visual C++"\r
- Version="8.00"\r
- Name="pforth_main"\r
- ProjectGUID="{58B76DB8-1985-4B8A-8E71-C012D8F0C518}"\r
- RootNamespace="pforth_main"\r
- Keyword="Win32Proj"\r
- >\r
- <Platforms>\r
- <Platform\r
- Name="Win32"\r
- />\r
- </Platforms>\r
- <ToolFiles>\r
- </ToolFiles>\r
- <Configurations>\r
- <Configuration\r
- Name="Debug|Win32"\r
- OutputDirectory="$(SolutionDir)../../../fth/"\r
- IntermediateDirectory="$(ConfigurationName)"\r
- ConfigurationType="1"\r
- CharacterSet="1"\r
- >\r
- <Tool\r
- Name="VCPreBuildEventTool"\r
- />\r
- <Tool\r
- Name="VCCustomBuildTool"\r
- />\r
- <Tool\r
- Name="VCXMLDataGeneratorTool"\r
- />\r
- <Tool\r
- Name="VCWebServiceProxyGeneratorTool"\r
- />\r
- <Tool\r
- Name="VCMIDLTool"\r
- />\r
- <Tool\r
- Name="VCCLCompilerTool"\r
- Optimization="0"\r
- PreprocessorDefinitions="WIN32;_DEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE"\r
- MinimalRebuild="true"\r
- BasicRuntimeChecks="3"\r
- RuntimeLibrary="3"\r
- UsePrecompiledHeader="0"\r
- WarningLevel="3"\r
- Detect64BitPortabilityProblems="false"\r
- DebugInformationFormat="4"\r
- />\r
- <Tool\r
- Name="VCManagedResourceCompilerTool"\r
- />\r
- <Tool\r
- Name="VCResourceCompilerTool"\r
- />\r
- <Tool\r
- Name="VCPreLinkEventTool"\r
- />\r
- <Tool\r
- Name="VCLinkerTool"\r
- OutputFile="$(OutDir)\pforth.exe"\r
- LinkIncremental="2"\r
- GenerateDebugInformation="true"\r
- SubSystem="1"\r
- TargetMachine="1"\r
- />\r
- <Tool\r
- Name="VCALinkTool"\r
- />\r
- <Tool\r
- Name="VCManifestTool"\r
- />\r
- <Tool\r
- Name="VCXDCMakeTool"\r
- />\r
- <Tool\r
- Name="VCBscMakeTool"\r
- />\r
- <Tool\r
- Name="VCFxCopTool"\r
- />\r
- <Tool\r
- Name="VCAppVerifierTool"\r
- />\r
- <Tool\r
- Name="VCWebDeploymentTool"\r
- />\r
- <Tool\r
- Name="VCPostBuildEventTool"\r
- />\r
- </Configuration>\r
- <Configuration\r
- Name="Release|Win32"\r
- OutputDirectory="$(SolutionDir)/../../../fth/"\r
- IntermediateDirectory="$(ConfigurationName)"\r
- ConfigurationType="1"\r
- CharacterSet="0"\r
- WholeProgramOptimization="1"\r
- >\r
- <Tool\r
- Name="VCPreBuildEventTool"\r
- />\r
- <Tool\r
- Name="VCCustomBuildTool"\r
- />\r
- <Tool\r
- Name="VCXMLDataGeneratorTool"\r
- />\r
- <Tool\r
- Name="VCWebServiceProxyGeneratorTool"\r
- />\r
- <Tool\r
- Name="VCMIDLTool"\r
- />\r
- <Tool\r
- Name="VCCLCompilerTool"\r
- PreprocessorDefinitions="WIN32;NDEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE"\r
- RuntimeLibrary="2"\r
- UsePrecompiledHeader="0"\r
- WarningLevel="3"\r
- Detect64BitPortabilityProblems="false"\r
- DebugInformationFormat="3"\r
- />\r
- <Tool\r
- Name="VCManagedResourceCompilerTool"\r
- />\r
- <Tool\r
- Name="VCResourceCompilerTool"\r
- />\r
- <Tool\r
- Name="VCPreLinkEventTool"\r
- />\r
- <Tool\r
- Name="VCLinkerTool"\r
- OutputFile="$(OutDir)\pforth.exe"\r
- LinkIncremental="1"\r
- GenerateDebugInformation="true"\r
- SubSystem="1"\r
- OptimizeReferences="2"\r
- EnableCOMDATFolding="2"\r
- TargetMachine="1"\r
- />\r
- <Tool\r
- Name="VCALinkTool"\r
- />\r
- <Tool\r
- Name="VCManifestTool"\r
- />\r
- <Tool\r
- Name="VCXDCMakeTool"\r
- />\r
- <Tool\r
- Name="VCBscMakeTool"\r
- />\r
- <Tool\r
- Name="VCFxCopTool"\r
- />\r
- <Tool\r
- Name="VCAppVerifierTool"\r
- />\r
- <Tool\r
- Name="VCWebDeploymentTool"\r
- />\r
- <Tool\r
- Name="VCPostBuildEventTool"\r
- />\r
- </Configuration>\r
- </Configurations>\r
- <References>\r
- </References>\r
- <Files>\r
- <Filter\r
- Name="Source Files"\r
- Filter="cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx"\r
- UniqueIdentifier="{4FC737F1-C7A5-4376-A066-2A32D752A2FF}"\r
- >\r
- <File\r
- RelativePath="..\..\..\csrc\pf_cglue.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_clib.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_core.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_inner.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_io.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_io_none.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\win32_console\pf_io_win32_console.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_main.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_mem.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_save.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_text.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_words.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pfcompil.c"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pfcustom.c"\r
- >\r
- </File>\r
- </Filter>\r
- <Filter\r
- Name="Header Files"\r
- Filter="h;hpp;hxx;hm;inl;inc;xsd"\r
- UniqueIdentifier="{93995380-89BD-4b04-88EB-625FBE52EBFB}"\r
- >\r
- <File\r
- RelativePath="..\..\..\csrc\pf_all.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_cglue.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_clib.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_core.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_float.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_guts.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_host.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_inc1.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_io.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_mem.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_save.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_text.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_types.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_win32.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pf_words.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pfcompfp.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pfcompil.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pfdicdat.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pfdicdat_arm.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pfinnrfp.h"\r
- >\r
- </File>\r
- <File\r
- RelativePath="..\..\..\csrc\pforth.h"\r
- >\r
- </File>\r
- </Filter>\r
- <Filter\r
- Name="Resource Files"\r
- Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav"\r
- UniqueIdentifier="{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}"\r
- >\r
- </Filter>\r
- </Files>\r
- <Globals>\r
- </Globals>\r
-</VisualStudioProject>\r
--- /dev/null
+
+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
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+<Project DefaultTargets="Build" ToolsVersion="15.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
+ <ItemGroup Label="ProjectConfigurations">
+ <ProjectConfiguration Include="Debug|Win32">
+ <Configuration>Debug</Configuration>
+ <Platform>Win32</Platform>
+ </ProjectConfiguration>
+ <ProjectConfiguration Include="Debug|x64">
+ <Configuration>Debug</Configuration>
+ <Platform>x64</Platform>
+ </ProjectConfiguration>
+ <ProjectConfiguration Include="Release|Win32">
+ <Configuration>Release</Configuration>
+ <Platform>Win32</Platform>
+ </ProjectConfiguration>
+ <ProjectConfiguration Include="Release|x64">
+ <Configuration>Release</Configuration>
+ <Platform>x64</Platform>
+ </ProjectConfiguration>
+ </ItemGroup>
+ <PropertyGroup Label="Globals">
+ <ProjectGuid>{58B76DB8-1985-4B8A-8E71-C012D8F0C518}</ProjectGuid>
+ <RootNamespace>pforth_main</RootNamespace>
+ <Keyword>Win32Proj</Keyword>
+ <TargetName>pforth</TargetName>
+ </PropertyGroup>
+ <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" />
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration">
+ <ConfigurationType>Application</ConfigurationType>
+ <PlatformToolset>v141</PlatformToolset>
+ <CharacterSet>NotSet</CharacterSet>
+ <WholeProgramOptimization>true</WholeProgramOptimization>
+ </PropertyGroup>
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration">
+ <ConfigurationType>Application</ConfigurationType>
+ <PlatformToolset>v141</PlatformToolset>
+ <CharacterSet>NotSet</CharacterSet>
+ <WholeProgramOptimization>true</WholeProgramOptimization>
+ </PropertyGroup>
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration">
+ <ConfigurationType>Application</ConfigurationType>
+ <PlatformToolset>v141</PlatformToolset>
+ <CharacterSet>Unicode</CharacterSet>
+ </PropertyGroup>
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration">
+ <ConfigurationType>Application</ConfigurationType>
+ <PlatformToolset>v141</PlatformToolset>
+ <CharacterSet>Unicode</CharacterSet>
+ </PropertyGroup>
+ <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" />
+ <ImportGroup Label="ExtensionSettings">
+ </ImportGroup>
+ <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets">
+ <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
+ </ImportGroup>
+ <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets">
+ <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
+ </ImportGroup>
+ <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets">
+ <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
+ </ImportGroup>
+ <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets">
+ <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" />
+ </ImportGroup>
+ <PropertyGroup Label="UserMacros" />
+ <PropertyGroup>
+ <_ProjectFileVersion>15.0.27130.2010</_ProjectFileVersion>
+ </PropertyGroup>
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">
+ <OutDir>$(SolutionDir)..\..\..\fth\</OutDir>
+ <IntDir>$(Configuration)\</IntDir>
+ <LinkIncremental>true</LinkIncremental>
+ </PropertyGroup>
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">
+ <LinkIncremental>true</LinkIncremental>
+ </PropertyGroup>
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">
+ <OutDir>$(SolutionDir)..\..\..\fth\</OutDir>
+ <IntDir>$(Configuration)\</IntDir>
+ <LinkIncremental>false</LinkIncremental>
+ </PropertyGroup>
+ <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'">
+ <LinkIncremental>false</LinkIncremental>
+ </PropertyGroup>
+ <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">
+ <ClCompile>
+ <Optimization>Disabled</Optimization>
+ <PreprocessorDefinitions>WIN32;_DEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
+ <MinimalRebuild>true</MinimalRebuild>
+ <BasicRuntimeChecks>EnableFastChecks</BasicRuntimeChecks>
+ <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary>
+ <PrecompiledHeader />
+ <WarningLevel>Level3</WarningLevel>
+ <DebugInformationFormat>EditAndContinue</DebugInformationFormat>
+ </ClCompile>
+ <Link>
+ <GenerateDebugInformation>true</GenerateDebugInformation>
+ <SubSystem>Console</SubSystem>
+ <TargetMachine>MachineX86</TargetMachine>
+ </Link>
+ </ItemDefinitionGroup>
+ <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">
+ <ClCompile>
+ <Optimization>Disabled</Optimization>
+ <PreprocessorDefinitions>WIN32;_DEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
+ <BasicRuntimeChecks>EnableFastChecks</BasicRuntimeChecks>
+ <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary>
+ <PrecompiledHeader>
+ </PrecompiledHeader>
+ <WarningLevel>Level3</WarningLevel>
+ <DebugInformationFormat>ProgramDatabase</DebugInformationFormat>
+ </ClCompile>
+ <Link>
+ <GenerateDebugInformation>true</GenerateDebugInformation>
+ <SubSystem>Console</SubSystem>
+ </Link>
+ </ItemDefinitionGroup>
+ <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">
+ <ClCompile>
+ <PreprocessorDefinitions>WIN32;NDEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
+ <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary>
+ <PrecompiledHeader />
+ <WarningLevel>Level3</WarningLevel>
+ <DebugInformationFormat>ProgramDatabase</DebugInformationFormat>
+ </ClCompile>
+ <Link>
+ <GenerateDebugInformation>true</GenerateDebugInformation>
+ <SubSystem>Console</SubSystem>
+ <OptimizeReferences>true</OptimizeReferences>
+ <EnableCOMDATFolding>true</EnableCOMDATFolding>
+ <TargetMachine>MachineX86</TargetMachine>
+ </Link>
+ </ItemDefinitionGroup>
+ <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'">
+ <ClCompile>
+ <PreprocessorDefinitions>WIN32;NDEBUG;_CONSOLE;PF_SUPPORT_FP;_CRT_SECURE_NO_DEPRECATE;%(PreprocessorDefinitions)</PreprocessorDefinitions>
+ <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary>
+ <PrecompiledHeader>
+ </PrecompiledHeader>
+ <WarningLevel>Level3</WarningLevel>
+ <DebugInformationFormat>ProgramDatabase</DebugInformationFormat>
+ </ClCompile>
+ <Link>
+ <GenerateDebugInformation>true</GenerateDebugInformation>
+ <SubSystem>Console</SubSystem>
+ <OptimizeReferences>true</OptimizeReferences>
+ <EnableCOMDATFolding>true</EnableCOMDATFolding>
+ </Link>
+ </ItemDefinitionGroup>
+ <ItemGroup>
+ <ClCompile Include="..\..\..\csrc\pfcompil.c" />
+ <ClCompile Include="..\..\..\csrc\pfcustom.c" />
+ <ClCompile Include="..\..\..\csrc\pf_cglue.c" />
+ <ClCompile Include="..\..\..\csrc\pf_clib.c" />
+ <ClCompile Include="..\..\..\csrc\pf_core.c" />
+ <ClCompile Include="..\..\..\csrc\pf_inner.c" />
+ <ClCompile Include="..\..\..\csrc\pf_io.c" />
+ <ClCompile Include="..\..\..\csrc\pf_io_none.c" />
+ <ClCompile Include="..\..\..\csrc\pf_main.c" />
+ <ClCompile Include="..\..\..\csrc\pf_mem.c" />
+ <ClCompile Include="..\..\..\csrc\pf_save.c" />
+ <ClCompile Include="..\..\..\csrc\pf_text.c" />
+ <ClCompile Include="..\..\..\csrc\pf_words.c" />
+ <ClCompile Include="..\..\..\csrc\stdio\pf_fileio_stdio.c" />
+ <ClCompile Include="..\..\..\csrc\win32_console\pf_io_win32_console.c" />
+ </ItemGroup>
+ <ItemGroup>
+ <ClInclude Include="..\..\..\csrc\pfcompfp.h" />
+ <ClInclude Include="..\..\..\csrc\pfcompil.h" />
+ <ClInclude Include="..\..\..\csrc\pfdicdat.h" />
+ <ClInclude Include="..\..\..\csrc\pfdicdat_arm.h" />
+ <ClInclude Include="..\..\..\csrc\pfinnrfp.h" />
+ <ClInclude Include="..\..\..\csrc\pforth.h" />
+ <ClInclude Include="..\..\..\csrc\pf_all.h" />
+ <ClInclude Include="..\..\..\csrc\pf_cglue.h" />
+ <ClInclude Include="..\..\..\csrc\pf_clib.h" />
+ <ClInclude Include="..\..\..\csrc\pf_core.h" />
+ <ClInclude Include="..\..\..\csrc\pf_float.h" />
+ <ClInclude Include="..\..\..\csrc\pf_guts.h" />
+ <ClInclude Include="..\..\..\csrc\pf_host.h" />
+ <ClInclude Include="..\..\..\csrc\pf_inc1.h" />
+ <ClInclude Include="..\..\..\csrc\pf_io.h" />
+ <ClInclude Include="..\..\..\csrc\pf_mem.h" />
+ <ClInclude Include="..\..\..\csrc\pf_save.h" />
+ <ClInclude Include="..\..\..\csrc\pf_text.h" />
+ <ClInclude Include="..\..\..\csrc\pf_types.h" />
+ <ClInclude Include="..\..\..\csrc\pf_win32.h" />
+ <ClInclude Include="..\..\..\csrc\pf_words.h" />
+ </ItemGroup>
+ <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" />
+ <ImportGroup Label="ExtensionTargets">
+ </ImportGroup>
+</Project>
\ No newline at end of file
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
+ <ItemGroup>
+ <ClCompile Include="..\..\..\csrc\pf_cglue.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_clib.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_core.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\stdio\pf_fileio_stdio.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_inner.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_io.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_io_none.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\win32_console\pf_io_win32_console.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_mem.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_main.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_save.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_text.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pf_words.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pfcompil.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ <ClCompile Include="..\..\..\csrc\pfcustom.c">
+ <Filter>Source</Filter>
+ </ClCompile>
+ </ItemGroup>
+ <ItemGroup>
+ <ClInclude Include="..\..\..\csrc\pf_all.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_cglue.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_clib.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_core.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_float.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_guts.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_host.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_inc1.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_io.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_mem.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_save.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_text.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_types.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_win32.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pf_words.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pfcompfp.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pfcompil.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pfdicdat_arm.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pfdicdat.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pfinnrfp.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ <ClInclude Include="..\..\..\csrc\pforth.h">
+ <Filter>Include</Filter>
+ </ClInclude>
+ </ItemGroup>
+ <ItemGroup>
+ <Filter Include="Include">
+ <UniqueIdentifier>{6711f4b0-6d8c-4641-8260-e6d2c953bd3b}</UniqueIdentifier>
+ </Filter>
+ <Filter Include="Source">
+ <UniqueIdentifier>{298706eb-f166-4f0b-8404-a52c3fdf5d21}</UniqueIdentifier>
+ </Filter>
+ </ItemGroup>
+</Project>
\ No newline at end of file
** 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;
/**************************************************************************
** 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
** 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
** 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 */
/***************************************************************
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,
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,
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
ID_RESERVED08,
ID_RESERVED09,
ID_RESERVED10,
- ID_RESERVED11,
- ID_RESERVED12,
- ID_RESERVED13,
ID_FP_D_TO_F,
ID_FP_FSTORE,
ID_FP_FTIMES,
#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. */
extern "C" {
#endif
-int pfCatch( ExecToken XT );
+ThrowCode pfCatch( ExecToken XT );
#ifdef __cplusplus
}
**
***************************************************************/
-#ifndef AMIGA
-#include <sys/types.h>
-#else
-typedef long off_t;
-#endif
-
#include "pf_all.h"
#if defined(WIN32) && !defined(__MINGW32__)
/* 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 );
}
/**************************************************************/
-int pfCatch( ExecToken XT )
+ThrowCode pfCatch( ExecToken XT )
{
register cell_t TopOfStack; /* Cache for faster execution. */
register cell_t *DataStackPtr;
endcase;
case ID_BYE:
+ EMIT_CR;
M_THROW( THROW_BYE );
endcase;
/* 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);
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;
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;
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;
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
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;
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;
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);
TOUCH(Mode);
return 0;
}
-cell_t sdTellFile( FileStream * Stream )
+file_offset_t sdTellFile( FileStream * Stream )
{
UNIMPLEMENTED("sdTellFile");
TOUCH(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
**
***************************************************************/
+#include "pf_types.h"
+
#define PF_CHAR_XON (0x11)
#define PF_CHAR_XOFF (0x13)
void ioInit( void );
void ioTerm( void );
-
#ifdef PF_NO_CHARIO
void sdEnableInput( void );
void sdDisableInput( 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 );
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)
#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.
char IfInit = FALSE;
char *s;
cell_t i;
- int Result;
+ ThrowCode Result;
/* For Metroworks on Mac */
#ifdef __MWERKS__
Result = pfDoForth( DicName, SourceName, IfInit);
on_error:
- return Result;
+ return (int)Result;
}
#endif /* PF_EMBEDDED */
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 );
NameSize = QUADUP(NameSize); /* Align */
if( NameSize > 0 )
{
- NameSize = MAX( NameSize, (NameChunkSize + 1024) );
+ NameSize = MAX( (ucell_t)NameSize, (NameChunkSize + 1024) );
}
SD.sd_NameSize = 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;
/***************************************************************/
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;
uint32_t ChunkSize;
uint32_t FormSize;
uint32_t BytesLeft;
- uint32_t numr;
+ cell_t numr;
int isDicBigEndian;
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;
}
}
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);
** Type Declarations
***************************************************************/
+#ifndef AMIGA
+#include <sys/types.h>
+#endif
+
+/* file_offset_t is used in place of off_t */
+typedef long file_offset_t;
+
#ifndef Err
typedef long Err;
#endif
/* 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 == '-' )
{
for( i=0; i<Len; i++)
{
n = HexDigitToNumber( *s++ );
- if( (n < 0) || (n >= 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;
** 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;
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; i<nc; i++ )
{
- gScratch[i+1] = pfCharToUpper( s2[i] );
+ gScratch[i+1] = Upcase ? pfCharToUpper( s2[i] ) : s2[i] ;
}
}
else
gCurrentTask->td_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 );
+}
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 );
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 );
{
pfDebugMessage("ffInterpret: calling ffWord(()\n");
- theWord = ffWord( BLANK );
+ theWord = ffLWord( BLANK );
DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord ));
if( *theWord > 0 )
***************************************************************/
Err ffPushInputStream( FileStream *InputFile )
{
- cell_t Result = 0;
+ Err Result = 0;
IncludeFrame *inf;
/* Push current input state onto special include stack. */
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 );
#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;
case ID_FP_FROUND:
PUSH_TOS;
- TOS = fp_round(FP_TOS);
+ TOS = (cell_t)fp_round(FP_TOS);
M_FP_DROP;
break;
#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 );
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 );
--- /dev/null
+/***************************************************************
+** 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 <limits.h> /* 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 */
\ 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
\ 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
\ >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
--- /dev/null
+\ 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<rparen>" -- )
+ 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<rparen>" -- )
+ 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
\ 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
\ 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
\ 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
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*
\ 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
\ 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
\ 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
\ 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
\ 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
variable if-debug
+: ? ( address -- , fatch from address and print value )
+ @ .
+;
+
decimal
create msec-delay 10000 , ( default for SUN )
: (MSEC) ( #msecs -- )
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
\ 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
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 '<char>'
+ 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
--- /dev/null
+\ 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 "::::<filename>" 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
--- /dev/null
+\ 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
\ 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
\ 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
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
\ -------------- 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> -
rdrop
;
+: $INCLUDE ( $filename -- ) count included ;
+
create INCLUDE-SAVE-NAME 128 allot
: INCLUDE ( <fname> -- )
BL lword
DECIMAL
-\ STUB because missing definition in pForth - FIXME
-: SAVE-INPUT ;
-: RESTORE-INPUT -1 ;
-
TEST{
\ ==========================================================
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
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
--- /dev/null
+\ 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
--- /dev/null
+\ For testing REQUIRED etc
+
+1+
--- /dev/null
+\ For testing REQUIRED etc
+
+1+
\ 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
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
-- 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'
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