pax_global_header00006660000000000000000000000064143566146430014526gustar00rootroot0000000000000052 comment=3956a7fd77845a04006973a7ba97a4b65d437e7e pforth-2.0.1/000077500000000000000000000000001435661464300130305ustar00rootroot00000000000000pforth-2.0.1/.gitattributes000066400000000000000000000012301435661464300157170ustar00rootroot00000000000000# Set the default behavior, in case people don't have core.autocrlf set. * text=auto # Explicitly declare text files you want to always be normalized and converted # to native line endings on checkout. *.c text *.h text *.cpp text *.hpp text *.fth text *.f text *.txt text *.m text # Declare files that will always have CRLF line endings on checkout. *.sln text eol=crlf *.dsp text eol=crlf *.dsw text eol=crlf *.vcproj text eol=crlf *.sln text eol=crlf *.sln text eol=crlf *.doc text eol=crlf *.bat text eol=crlf # Denote all files that are truly binary and should not be modified. *.dic binary *.odt binary *.pdf binary *.png binary *.jpg binary *.wav binary pforth-2.0.1/.github/000077500000000000000000000000001435661464300143705ustar00rootroot00000000000000pforth-2.0.1/.github/workflows/000077500000000000000000000000001435661464300164255ustar00rootroot00000000000000pforth-2.0.1/.github/workflows/cmake.yml000066400000000000000000000021251435661464300202300ustar00rootroot00000000000000name: CMake on: push: branches: [ master ] pull_request: branches: [ master ] workflow_dispatch: env: # Customize the CMake build type here (Release, Debug, RelWithDebInfo, etc.) BUILD_TYPE: Release jobs: build: # The CMake configure and build commands are platform agnostic and should work equally # well on Windows or Mac. You can convert this to a matrix build if you need # cross-platform coverage. # See: https://docs.github.com/en/free-pro-team@latest/actions/learn-github-actions/managing-complex-workflows#using-a-build-matrix runs-on: ubuntu-latest steps: - uses: actions/checkout@v2 - name: Configure CMake run: cmake ${{github.workspace}}/. - name: Build run: cmake --build ${{github.workspace}}/. - name: Test working-directory: ${{github.workspace}}/fth run: | ./pforth_standalone t_corex.fth ./pforth_standalone t_strings.fth ./pforth_standalone t_locals.fth ./pforth_standalone t_alloc.fth ./pforth_standalone t_floats.fth ./pforth_standalone t_file.fth pforth-2.0.1/.github/workflows/make.yml000066400000000000000000000007371435661464300200740ustar00rootroot00000000000000name: Make on: push: branches: [ master ] pull_request: branches: [ master ] workflow_dispatch: env: # Customize the Make build type here (Release, Debug, RelWithDebInfo, etc.) BUILD_TYPE: Release jobs: build: # This uses a Unix Makefile and should run on Linux and Mac runs-on: ubuntu-latest steps: - uses: actions/checkout@v2 - name: Build and Test working-directory: ${{github.workspace}}/platforms/unix run: make test pforth-2.0.1/.github/workflows/make32.yml000066400000000000000000000011231435661464300202270ustar00rootroot00000000000000name: Make32 on: push: branches: [ master ] pull_request: branches: [ master ] workflow_dispatch: env: # Customize the Make build type here (Release, Debug, RelWithDebInfo, etc.) BUILD_TYPE: Release jobs: build: # This uses a Unix Makefile and should run on Linux and Mac runs-on: ubuntu-latest steps: - uses: actions/checkout@v2 - name: Install MultiLib to support 32-bit builds run: sudo apt-get install gcc-multilib - name: Build and Test working-directory: ${{github.workspace}}/platforms/unix run: make test WIDTHOPT=-m32 pforth-2.0.1/.gitignore000066400000000000000000000006411435661464300150210ustar00rootroot00000000000000**/*.eo **/*.o **/pfdicdat.h **/pforth **/pforth.dic **/pforth_standalone platform/win32/**/.vs platform/win32/**/Debug platform/win32/**/Release fth/fatest1.txt fth/pforth.dic **/.DS_Store build/ CMakeCache.txt CMakeFiles/ CTestTestfile.cmake Makefile cmake_install.cmake csrc/CMakeFiles/ csrc/CTestTestfile.cmake csrc/Makefile csrc/cmake_install.cmake csrc/libPforth_lib.a csrc/libPforth_lib_sd.a csrc/pfdicdat.h pforth-2.0.1/.travis.yml000066400000000000000000000006451435661464300151460ustar00rootroot00000000000000os: - 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 platforms/unix/ test pforth-2.0.1/CMakeLists.txt000066400000000000000000000052361435661464300155760ustar00rootroot00000000000000# NAME/CMakeLists.txt # Original file by Robin Rowe 2020-05-01 # Extended by Phil Burk 2021-10-31 # License: BSD Zero # To build pforth: # # cmake . # make # # That will create the following files: # fth/pforth # executable that loads pforth.dic # fth/pforth.dic # fth/pforth_standalone # executable that does not need a .dic file # # The build has several steps # 1. Build pforth executable # 2. Build pforth.dic by compiling system.fth # 3. Create a pfdicdat.h header containing a precompiled dictionary # as C source code. # 4. Build pforth_standalone using the precompiled dictionary. cmake_minimum_required(VERSION 3.6) set(CMAKE_CXX_STANDARD 17) set(CMAKE_CXX_STANDARD_REQUIRED ON) set(CMAKE_CXX_EXTENSIONS OFF) # Put pforth in the fth folder so we can load the Forth code more easily. set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/fth) project(PForth) message("Configuring ${PROJECT_NAME}...") enable_testing() if(WIN32) add_definitions(-D_CRT_SECURE_NO_WARNINGS) message("Warning: _CRT_SECURE_NO_WARNINGS") endif(WIN32) add_subdirectory(csrc) if(NOT WIN32 AND NOT APPLE) link_libraries(rt pthread) endif(NOT WIN32 AND NOT APPLE) option(UNISTD "Enable libunistd" false) if(UNISTD) set(LIBUNISTD_PATH /code/github/libunistd) if(WIN32) include_directories(${LIBUNISTD_PATH}/unistd) link_directories(${LIBUNISTD_PATH}/build/unistd/Release) link_libraries(libunistd) endif(WIN32) endif(UNISTD) # 1. Build pforth executable add_executable(pforth csrc/pf_main.c) target_link_libraries(pforth ${PROJECT_NAME}_lib m) # 2. Build pforth.dic by compiling system.fth set(PFORTH_DIC "${CMAKE_RUNTIME_OUTPUT_DIRECTORY}/pforth.dic") add_custom_command(OUTPUT ${PFORTH_DIC} COMMAND ./pforth -i system.fth WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} DEPENDS pforth COMMENT Building pforth.dic VERBATIM ) add_custom_target(pforth_dic DEPENDS ${PFORTH_DIC}) # 3. Create a pfdicdat.h header containing a precompiled dictionary # as C source code. set(PFORTH_DIC_HEADER "csrc/pfdicdat.h") add_custom_command(OUTPUT ${PFORTH_DIC_HEADER} COMMAND ./pforth mkdicdat.fth COMMAND mv pfdicdat.h ../csrc/. WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} DEPENDS pforth_dic COMMENT Building pfdicdat.h VERBATIM ) add_custom_target(pforth_dic_header DEPENDS ${PFORTH_DIC_HEADER}) add_dependencies(${PROJECT_NAME}_lib_sd pforth_dic_header) # 4. Build pforth_standalone using the precompiled dictionary. add_executable(pforth_standalone csrc/pf_main.c) target_link_libraries(pforth_standalone ${PROJECT_NAME}_lib_sd m) target_compile_definitions(pforth_standalone PRIVATE PF_STATIC_DIC) add_dependencies(pforth_standalone pforth_dic_header) pforth-2.0.1/README.md000066400000000000000000000110271435661464300143100ustar00rootroot00000000000000# PForth - a Portable ANS-like Forth written in ANSI 'C' by Phil Burk with Larry Polansky, David Rosenboom and Darren Gibbs. Support for 64-bit cells by Aleksej Saushev. Last updated: November 27, 2022 Portable Forth written in 'C' for most 32 and 64-bit platforms. PForth is written in 'C' and can be easily ported to new 32 and 64-bit platforms. It only needs character input and output functions to operate and, therefore, does not require an operating system. This makes it handy for bringing up and testing embedded systems. PForth also works on desktops including Windows, Mac and Linux and supports command line history. This lets you develop hardware tests on a desktop before trying them on your embedded system. But pForth is not a rich and friendly desktop programming environment. There are no GUI tools for developing desktop applications. PForth is lean and mean and optimized for portability. PForth has a tool for compiling code on a desktop, then exporting the dictionary in big or little endian format as 'C' source code. This lets you compile tests for an embedded system that does not have file I/O. PForth is based on ANSI-Forth but is not 100% compatible. Code for pForth is maintained on GitHub at: https://github.com/philburk/pforth Documentation for pForth at: http://www.softsynth.com/pforth/ To report bugs or request features please file a GitHub Issue. For questions or general discussion please use the pForth forum at: http://groups.google.com/group/pforthdev ## LEGAL NOTICE Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ## Contents of SDK platforms - tools for building pForth on various platforms platforms/unix - Makefile for unix csrc - pForth kernel in ANSI 'C' csrc/pf_main.c - main() application for a standalone Forth csrc/stdio - I/O code using basic stdio for generic platforms csrc/posix - I/O code for Posix platform csrc/win32 - I/O code for basic WIN32 platform csrc/win32_console - I/O code for WIN32 console that supports command line history fth - Forth code fth/util - utility functions ## How to Build pForth Building pForth involves two steps: 1) building the C based Forth kernel 2) building the Forth dictionary file using: ./pforth -i system.fth 3) optional build of standalone executable with built-in dictionary We have provided build scripts to simplify this process. On Unix and MacOS using Makefile: cd platforms/unix make all ./pforth_standalone For more details, see the [Wiki](https://github.com/philburk/pforth/wiki/Compiling-on-Unix) Using CMake: cmake . make cd fth ./pforth_standalone For embedded systems, see the pForth reference manual at: http://www.softsynth.com/pforth/pf_ref.php ## How to Run pForth To run the all-in-one pForth enter: ./pforth_standalone OR, to run using the dictionary file, enter: ./pforth Quick check of Forth: 3 4 + . words bye To compile source code files use: INCLUDE filename To create a custom dictionary enter in pForth: c" newfilename.dic" SAVE-FORTH The name must end in ".dic". To run PForth with the new dictionary enter in the shell: pforth -dnewfilename.dic To run PForth and automatically include a forth file: pforth myprogram.fth ## How to Test pForth PForth comes with a small test suite. To test the Core words, you can use the coretest developed by John Hayes. On Unix and MacOS using Makefile: cd platforms/unix make test Using CMake: cmake . make cd fth ./pforth include tester.fth include coretest.fth To run the other tests, enter: pforth t_corex.fth pforth t_strings.fth pforth t_locals.fth pforth t_alloc.fth They will report the number of tests that pass or fail. You can also test pForth kernel without loading a dictionary using option "-i". Only the primitive words defined in C will be available. This might be necessary if the dictionary can't be built. ./pforth -i 3 4 + . 23 77 swap .s loadsys pforth-2.0.1/RELEASES.md000066400000000000000000000310331435661464300145550ustar00rootroot00000000000000# Release History for pForth - a Portable ANS-like Forth written in ANSI 'C' PForth hosted at https://github.com/philburk/pforth Documentation at http://www.softsynth.com/pforth/ ## V2.0.0 #29 - Jan 1, 2023 ### Breaking API change! * Fixed FROUND, was leaving result on data stack instead of float stack, [#69](https://github.com/philburk/pforth/issues/69) ### Other changes * Added standard version numbering, eg. "2.0.0" * Add BYE-CODE variable, which will be returned to the shell when pForth exits. * Set BYE-CODE when a test fails to simplify continuous integration tests. * Add ANS structure support * Add [DEFINED] and [UNDEFINED] * Implement MSEC using usleep() to avoid busy wait. * Added VERSION_CODE for software version checks. * Added S\" * Terminal is unbuffered on posix systems * Added CMAKE build, (thanks Robin Rowe) * Improve unix/Makefile, moved to "platforms" folder * Added GitHub actions for CI * Add compiler warnings about precision loss. * Improve 64-bit CELL support. * Allow header and code size to be more easily controlled. * Fixed definition of PF_DEFAULT_HEADER_SIZE * Change license to 0BSD * Added privatize to history.fth ## V28 - April 24, 2018, tagged as V1.28.0 to conform to standard version format * 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 * Fixed REPOSITION-FILE FILE-SIZE and FILE-POSITION. They used to use single precision offset. Now use double as specified. * Delete object directories in Makefile clean. * Fixed "Issue 4: Filehandle remains locked upon INCLUDE error". http://code.google.com/p/pforth/issues/detail?id=4&can=1 * Fixed scrambled HISTORY on 64-bit systems. Was using CELL+ but really needed 4 +. * Fixed floating point input. Now accepts "1E" as 1.0. Was Issue #2. * Fixed lots of warning and made code compatible with C89 and ANSI. Uses -pedantic. * Use fseek and ftell on WIN32 instead of fseeko and ftello. * Makefile is now more standard. Builds in same dir as Makefile. Uses CFLAGS etc. * Add support for console IO with _WATCOMC_ * Internal CStringToForth and ForthStringToC now take a destination size for safety. * Run units tests for CStringToForth and ForthStringToC if PF_UNIT_TESTS is defined. ## V26 5/20/2010 * 64-bit support for M* UM/MOD etc by Aleksej Saushev. Thanks Aleksej! ## V25 5/19/2010 * Added 64-bit CELL support contributed by Aleksej Saushev. Thanks Aleksej! * Added "-x c" to Makefile CCOPTS to prevent confusion with C++ * Allow space after -d command line option. * Restore normal tty mode if pForth dictionary loading fails. ## V24 2/20/09 * Fixed Posix IO on Mac. ?TERMINAL was always returning true. * ACCCEPT now emits a space at end of line before output. * Fixed RESIZE because it was returning the wrong address. ## V23 8/4/2008 * Removed -v option from mkdir in build/unix/Makefile. It was not supported on FreeBSD. Thank you Alexsej Saushev for reporting this. ## V23 7/20/2008 * Reorganized for Google Code project. ## V22 (unreleased) * Added command line history and cursor control words. * Sped up UM* and M* by a factor of 3. Thanks to Steve Green for suggested algorithm. * Modified ACCEPT so that a line at the end of a file that does NOT have a line terminator will now be processed. * Use _getch(), _putch(), and _kbhit() so that KEY, EMIT and ?TERMINAL will work on PC. * Fixed : foo { -- } 55 ; - Was entering local frame but not exiting. Now prints error. * Redefined MAKE_ID to protect it from 16 bit ints * John Providenza says "If you split local variables onto 2 lines, PForth crashes." Fixed. Also allow \ * Fixed float evaluation in EVALUATE in "quit.fth". * Flush register cache for ffColon and ffSemiColon to prevent stack warnings from ; ## V21 - 9/16/1998 * Fixed some compiler warnings. ## V20 * Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash. Thank you Michael Connor of Vancouver for reporting this bug. * Removed FDROP in REPRESENT to fix stack underflow after "0.0 F.". Thank you Jim Rosenow of Minnesota for reporting this bug. * Changed pfCharToLower to function to prevent macro expansion bugs under VXWORKS Thank you Jim Rosenow of Minnesota for reporting this bug. * "0.0 F~" now checks actual binary encoding of floats. Before this it used to just compare value which was incorrect. Now "0.0 -0.0 0.0 F~" returns FALSE. * Fixed definition of INPUT$ in tutorial. Thank you Hampton Miller of California for reporting this bug. * Added support for producing a target dictionary with a different Endian-ness than the host CPU. See PF_BIG_ENDIAN_DIC and PF_LITTLE_ENDIAN_DIC. * PForth kernel now comes up in a mode that uses BASE for numeric input when started with "-i" option. It used to always consider numeric input as HEX. Initial BASE is decimal. ## V19 4/1998 * Warn if local var name matches dictionary, : foo { count -- } ; * TO -> and +-> now parse input stream. No longer use to-flag. * TO -> and +-> now give error if used with non-immediate word. * Added (FLITERAL) support to SEE. * Aded TRACE facility for single step debugging of Forth words. * Added stub for ?TERMINAL and KEY? for embedded systems. * Added PF_NO_GLOBAL_INIT for no reliance on global initialization. * Added PF_USER_FLOAT for customization of FP support. * Added floating point to string conversion words (F.) (FS.) (FE.) For example: : F. (F.) TYPE SPACE ; * Reversed order that values are placed on return stack in 2>R so that it matches ANS standard. 2>R is now same as SWAP >R >R Thank you Leo Wong for reporting this bug. * Added PF_USER_INIT and PF_USER_TERM for user definable init and term calls. * FIXED memory leak in pfDoForth() ## V18 * Make FILL a 'C' primitive. * optimized locals with (1_LOCAL@) * optimized inner interpreter by 15% * fix tester.fth failures * Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined. * Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition. * Fixed saving and restoring of TIB when nesting include files. ## V17 * Fixed input of large floats. 0.7071234567 F. used to fail. ## V16 * Define PF_USER_CUSTOM if you are defining your own custom 'C' glue routines. This will ifndef the published example. * Fixed warning in pf_cglue.c. * Fixed SDAD in savedicd.fth. It used to generate bogus 'C' code if called when (BASE != 10), as in HEX mode. * Fixed address comparisons in forget.fth and private.fth for addresses above 0x80000000. Must be unsigned. * Call FREEZE at end of system.fth to initialize rfence. * Fixed 0.0 F. which used to leave 0.0 on FP stack. * Added FPICK ( n -- ) ( i*f -- i*f f[n] ) * .S now prints hex numbers as unsigned. * Fixed internal number to text conversion for unsigned nums. ## V15 - 2/15/97 * If you use PF_USER_FILEIO, you must now define PF_STDIN and PF_STDOUT among other additions. See "pf_io.h". * COMPARE now matches ANS STRING word set! * Added PF_USER_INC1 and PF_USER_INC2 for optional includes and host customization. See "pf_all.h". * Fixed more warnings. * Fixed >NAME and WORDS for systems with high "negative" addresses. * Added WORDS.LIKE utility. Enter: WORDS.LIKE EMIT * Added stack check after every word in high level interpreter. Enter QUIT to enter high level interpreter which uses this feature. * THROW will no longer crash if not using high level interpreter. * Isolated all host dependencies into "pf_unix.h", "pf_win32.h", "pf_mac.h", etc. See "pf_all.h". * Added tests for CORE EXT, STRINGS words sets. * Added SEARCH * Fixed WHILE and REPEAT for multiple WHILEs. * Fixed .( ) for empty strings. * Fixed FATAN2 which could not compile on some systems (Linux gcc). ## V14 - 12/23/96 * pforth command now requires -d before dictionary name. Eg. pforth -dcustom.dic test.fth * PF_USER_* now need to be defined as include file names. * PF_USER_CHARIO now requires different functions to be defined. See "csrc/pf_io.h". * Moved pfDoForth() from pf_main.c to pf_core.c to simplify file with main(). * Fix build with PF_NO_INIT * Makefile now has target for embedded dictionary, "gmake pfemb". ## V13 - 12/15/9 * Add "extern 'C' {" to pf_mem.h for C++ * Separate PF_STATIC_DIC from PF_NO_FILEIO so that we can use a static dictionary but also have file I/O. * Added PF_USER_FILEIO, PF_USER_CHARIO, PF_USER_CLIB. * INCLUDE now aborts if file not found. * Add +-> which allows you to add to a local variable, like +! . * VALUE now works properly as a self fetching constant. * Add CODE-SIZE and HEADERS-SIZE which lets you resize dictionary saved using SAVE-FORTH. * Added FILE?. Enter "FILE? THEN" to see what files THEN is defined in. * Fixed bug in local variables that caused problems if compilation aborted in a word with local variables. * Added SEE which "disassembles" Forth words. See "see.fth". * Added PRIVATE{ which can be used to hide low level support words. See "private.fth". ## V12 - 12/1/96 * Advance pointers in pfCopyMemory() and pfSetMemory() to fix PF_NO_CLIB build. * Increase size of array for PF_NO_MALLOC * Eliminate many warnings involving type casts and (const char *) * Fix error recovery in dictionary creation. * Conditionally eliminate some include files for embedded builds. * Cleanup some test files. ## V11 - 11/14/96 * Added support for AUTO.INIT and AUTO.TERM. These are called automagically when the Forth starts and quits. * Change all int to int32. * Changed DO LOOP to ?DO LOOP in ENDCASE and LV.MATCH to fix hang when zero local variables. * Align long word members in :STRUCT to avoid bus errors. ## V10 - 3/21/96 * Close nested source files when INCLUDE aborts. * Add PF_NO_CLIB option to reduce OS dependencies. * Add CREATE-FILE, fix R/W access mode for OPEN-FILE. * Use PF_FLOAT instead of FLOAT to avoid DOS problem. * Add PF_HOST_DOS for compilation control. * Shorten all long file names to fit in the 8.3 format required by some primitive operating systems. My apologies to those with modern computers who suffer as a result. ;-) ## V9 - 10/13/95 * Cleaned up and documented for alpha release. * Added EXISTS? * compile floats.fth if F* exists * got PF_NO_SHELL working * added TURNKEY to build headerless dictionary apps * improved release script and rlsMakefile * added FS@ and FS! for FLPT structure members ## V8 - 5/1/95 * Report line number and line dump when INCLUDE aborts * Abort if stack depth changes in colon definition. Helps detect unbalanced conditionals (IF without THEN). * Print bytes added by include. Helps determine current file. * Added RETURN-CODE which is returned to caller, eg. UNIX shell. * Changed Header and Code sizes to 60000 and 150000 * Added check for overflowing dictionary when creating secondaries. ## V8 - 5/1/95 * Report line number and line dump when INCLUDE aborts * Abort if stack depth changes in colon definition. Helps detect unbalanced conditionals (IF without THEN). * Print bytes added by include. Helps determine current file. * Added RETURN-CODE which is returned to caller, eg. UNIX shell. * Changed Header and Code sizes to 60000 and 150000 * Added check for overflowing dictionary when creating secondaries. ## V7 - 4/12/95 * Converted to 3DO Teamware environment * Added conditional compiler [IF] [ELSE] [THEN], use like #if * Fixed W->S B->S for positive values * Fixed ALLOCATE FREE validation. Was failing on some 'C' compilers. * Added FILE-SIZE * Fixed ERASE, now fills with zero instead of BL ## V6 - 3/16/95 * Added floating point * Changed NUMBER? to return a numeric type * Support double number entry, eg. 234. -> 234 0 ## V5 - 3/9/95 * Added pfReportError() * Fixed problem with NumPrimitives growing and breaking dictionaries * Reduced size of saved dictionaries, 198K -> 28K in one instance * Funnel all terminal I/O through ioKey() and ioEmit() * Removed dependencies on printf() except for debugging ## V4 - 3/6/95 * Added smart conditionals to allow IF THEN DO LOOP etc. outside colon definitions. * Fixed RSHIFT, made logical. * Added ARSHIFT for arithmetic shift. * Added proper M* * Added <> U> U< * Added FM/MOD SM/REM /MOD MOD */ */MOD * Added +LOOP EVALUATE UNLOOP EXIT * Everything passes "coretest.fth" except UM/MOD FIND and WORD ## V3 - 3/1/95 * Added support for embedded systems: PF_NO_FILEIO and PF_NO_MALLOC. * Fixed bug in dictionary loader that treated HERE as name relative. ## V2 - 8/94 * made improvements necessary for use with M2 Verilog testing ## V1 - 5/94 * built pForth from my Forth used in HMSL ---------------------------------------------------------- Enjoy, Phil Burk pforth-2.0.1/csrc/000077500000000000000000000000001435661464300137625ustar00rootroot00000000000000pforth-2.0.1/csrc/CMakeLists.txt000066400000000000000000000022351435661464300165240ustar00rootroot00000000000000# pforth/csrc/CMakeLists.txt # Extended by Phil Burk 2021-10-31 # License: BSD Zero file(STRINGS sources.cmake SOURCES) if(WIN32) set(PLATFORM stdio/pf_fileio_stdio.c win32_console/pf_io_win32_console.c ) endif(WIN32) if(UNIX OR APPLE) set(PLATFORM posix/pf_io_posix.c stdio/pf_fileio_stdio.c) endif(UNIX OR APPLE) if (MSVC) # warning level 4 and all warnings as errors add_compile_options(/W4 /WX) else() # lots of warnings and all warnings as errors add_compile_options( # --std=c89 -fsigned-char -fno-builtin -fno-unroll-loops -pedantic -Wcast-qual -Wall -Werror -Wwrite-strings -Winline -Wmissing-prototypes -Wmissing-declarations ) endif() add_library(${PROJECT_NAME}_lib ${SOURCES} ${PLATFORM}) target_compile_definitions(${PROJECT_NAME}_lib PRIVATE PF_SUPPORT_FP) # Compile the same library but with an option for the static dictionary. add_library(${PROJECT_NAME}_lib_sd STATIC ${SOURCES} ${PLATFORM}) target_compile_definitions(${PROJECT_NAME}_lib_sd PRIVATE PF_STATIC_DIC) target_compile_definitions(${PROJECT_NAME}_lib_sd PRIVATE PF_SUPPORT_FP) pforth-2.0.1/csrc/pf_all.h000066400000000000000000000034501435661464300153720ustar00rootroot00000000000000/* @(#) pf_all.h 98/01/26 1.2 */ #ifndef _pf_all_h #define _pf_all_h /*************************************************************** ** Include all files needed for PForth ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ** 940521 PLB Creation. ** ***************************************************************/ #ifdef PF_EMBEDDED #define PF_NO_INIT #define PF_NO_STDIO #define PF_NO_MALLOC #define PF_NO_CLIB #define PF_NO_FILEIO #endif /* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */ #ifdef __MWERKS__ #define PF_SUPPORT_FP (1) #endif #ifdef WIN32 #define PF_USER_INC2 "pf_win32.h" #endif #if defined(PF_USER_INC1) #include PF_USER_INC1 #else #include "pf_inc1.h" #endif #include "pforth.h" #include "pf_types.h" #include "pf_io.h" #include "pf_guts.h" #include "pf_text.h" #include "pfcompil.h" #include "pf_clib.h" #include "pf_words.h" #include "pf_save.h" #include "pf_mem.h" #include "pf_cglue.h" #include "pf_core.h" #ifdef PF_USER_INC2 /* This could be used to undef and redefine macros. */ #include PF_USER_INC2 #endif #endif /* _pf_all_h */ pforth-2.0.1/csrc/pf_cglue.c000066400000000000000000000060001435661464300157060ustar00rootroot00000000000000/* @(#) pf_cglue.c 98/02/11 1.4 */ /*************************************************************** ** 'C' Glue support for Forth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #include "pf_all.h" extern CFunc0 CustomFunctionTable[]; /***************************************************************/ cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams ) { cell_t P1, P2, P3, P4, P5; cell_t Result = 0; CFunc0 CF; DBUG(("CallUserFunction: Index = %d, ReturnMode = %d, NumParams = %d\n", Index, ReturnMode, NumParams )); CF = CustomFunctionTable[Index]; switch( NumParams ) { case 0: Result = ((CFunc0) CF) ( ); break; case 1: P1 = POP_DATA_STACK; Result = ((CFunc1) CF) ( P1 ); break; case 2: P2 = POP_DATA_STACK; P1 = POP_DATA_STACK; Result = ((CFunc2) CF) ( P1, P2 ); break; case 3: P3 = POP_DATA_STACK; P2 = POP_DATA_STACK; P1 = POP_DATA_STACK; Result = ((CFunc3) CF) ( P1, P2, P3 ); break; case 4: P4 = POP_DATA_STACK; P3 = POP_DATA_STACK; P2 = POP_DATA_STACK; P1 = POP_DATA_STACK; Result = ((CFunc4) CF) ( P1, P2, P3, P4 ); break; case 5: P5 = POP_DATA_STACK; P4 = POP_DATA_STACK; P3 = POP_DATA_STACK; P2 = POP_DATA_STACK; P1 = POP_DATA_STACK; Result = ((CFunc5) CF) ( P1, P2, P3, P4, P5 ); break; default: pfReportError("CallUserFunction", PF_ERR_NUM_PARAMS); EXIT(1); } /* Push result on Forth stack if requested. */ if(ReturnMode == C_RETURNS_VALUE) PUSH_DATA_STACK( Result ); return Result; } #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) /***************************************************************/ Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams ) { ucell_t Packed; char FName[40]; CStringToForth( FName, CName, sizeof(FName) ); Packed = (Index & 0xFFFF) | 0 | (NumParams << 24) | (ReturnMode << 31); DBUG(("Packed = 0x%8x\n", Packed)); ffCreateSecondaryHeader( FName ); CODE_COMMA( ID_CALL_C ); CODE_COMMA(Packed); ffFinishSecondary(); return 0; } #endif pforth-2.0.1/csrc/pf_cglue.h000066400000000000000000000033041435661464300157170ustar00rootroot00000000000000/* @(#) pf_cglue.h 96/12/18 1.7 */ #ifndef _pf_c_glue_h #define _pf_c_glue_h /*************************************************************** ** Include file for PForth 'C' Glue support ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ typedef cell_t (*CFunc0)( void ); typedef cell_t (*CFunc1)( cell_t P1 ); typedef cell_t (*CFunc2)( cell_t P1, cell_t P2 ); typedef cell_t (*CFunc3)( cell_t P1, cell_t P2, cell_t P3 ); typedef cell_t (*CFunc4)( cell_t P1, cell_t P2, cell_t P3, cell_t P4 ); typedef cell_t (*CFunc5)( cell_t P1, cell_t P2, cell_t P3, cell_t P4, cell_t P5 ); #ifdef __cplusplus extern "C" { #endif Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams ); Err CompileCustomFunctions( void ); Err LoadCustomFunctionTable( void ); cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams ); #ifdef __cplusplus } #endif #define C_RETURNS_VOID (0) #define C_RETURNS_VALUE (1) #endif /* _pf_c_glue_h */ pforth-2.0.1/csrc/pf_clib.c000066400000000000000000000041321435661464300155240ustar00rootroot00000000000000/* @(#) pf_clib.c 96/12/18 1.12 */ /*************************************************************** ** Duplicate functions from stdlib for PForth based on 'C' ** ** This code duplicates some of the code in the 'C' lib ** because it reduces the dependency on foreign libraries ** for monitor mode where no OS is available. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 961124 PLB Advance pointers in pfCopyMemory() and pfSetMemory() ***************************************************************/ #include "pf_all.h" #ifdef PF_NO_CLIB /* Count chars until NUL. Replace strlen() */ #define NUL ((char) 0) cell_t pfCStringLength( const char *s ) { cell_t len = 0; while( *s++ != NUL ) len++; return len; } /* void *memset (void *s, cell_t c, size_t n); */ void *pfSetMemory( void *s, cell_t c, cell_t n ) { uint8_t *p = s, byt = (uint8_t) c; while( (n--) > 0) *p++ = byt; return s; } /* void *memccpy (void *s1, const void *s2, cell_t c, size_t n); */ void *pfCopyMemory( void *s1, const void *s2, cell_t n) { uint8_t *p1 = s1; const uint8_t *p2 = s2; while( (n--) > 0) *p1++ = *p2++; return s1; } #endif /* PF_NO_CLIB */ char pfCharToUpper( char c ) { return (char) ( ((c>='a') && (c<='z')) ? (c - ('a' - 'A')) : c ); } char pfCharToLower( char c ) { return (char) ( ((c>='A') && (c<='Z')) ? (c + ('a' - 'A')) : c ); } pforth-2.0.1/csrc/pf_clib.h000066400000000000000000000035451435661464300155400ustar00rootroot00000000000000/* @(#) pf_clib.h 96/12/18 1.10 */ #ifndef _pf_clib_h #define _pf_clib_h /*************************************************************** ** Include file for PForth tools ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #ifdef PF_NO_CLIB #ifdef __cplusplus extern "C" { #endif cell_t pfCStringLength( const char *s ); void *pfSetMemory( void *s, cell_t c, cell_t n ); void *pfCopyMemory( void *s1, const void *s2, cell_t n); #define EXIT(n) {while(1);} #ifdef __cplusplus } #endif #else /* PF_NO_CLIB */ #ifdef PF_USER_CLIB #include PF_USER_CLIB #else /* Use stdlib functions if available because they are probably faster. */ #define pfCStringLength strlen #define pfSetMemory memset #define pfCopyMemory memcpy #define EXIT(n) exit(n) #endif /* PF_USER_CLIB */ #endif /* !PF_NO_CLIB */ #ifdef __cplusplus extern "C" { #endif /* Always use my own functions to avoid macro expansion problems with tolower(*s++) */ char pfCharToUpper( char c ); char pfCharToLower( char c ); #ifdef __cplusplus } #endif #endif /* _pf_clib_h */ pforth-2.0.1/csrc/pf_core.c000066400000000000000000000424561435661464300155560ustar00rootroot00000000000000/* @(#) pf_core.c 98/01/28 1.5 */ /*************************************************************** ** Forth based on 'C' ** ** This file has the main entry points to the pForth library. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 940502 PLB Creation. ** 940505 PLB More macros. ** 940509 PLB Moved all stack handling into inner interpreter. ** Added Create, Colon, Semicolon, HNumberQ, etc. ** 940510 PLB Got inner interpreter working with secondaries. ** Added (LITERAL). Compiles colon definitions. ** 940511 PLB Added conditionals, LITERAL, CREATE DOES> ** 940512 PLB Added DO LOOP DEFER, fixed R> ** 940520 PLB Added INCLUDE ** 940521 PLB Added NUMBER? ** 940930 PLB Outer Interpreter now uses deferred NUMBER? ** 941005 PLB Added ANSI locals, LEAVE, modularised ** 950320 RDG Added underflow checking for FP stack ** 970702 PLB Added STACK_SAFETY to FP stack size. ***************************************************************/ #include "pf_all.h" /*************************************************************** ** Global Data ***************************************************************/ char gScratch[TIB_SIZE]; pfTaskData_t *gCurrentTask = NULL; pfDictionary_t *gCurrentDictionary; cell_t gNumPrimitives; ExecToken gLocalCompiler_XT; /* custom compiler for local variables */ ExecToken gNumberQ_XT; /* XT of NUMBER? */ ExecToken gQuitP_XT; /* XT of (QUIT) */ ExecToken gAcceptP_XT; /* XT of ACCEPT */ /* Depth of data stack when colon called. */ cell_t gDepthAtColon; /* Global Forth variables. * These must be initialized in pfInit below. */ cell_t gVarContext; /* Points to last name field. */ cell_t gVarState; /* 1 if compiling. */ cell_t gVarBase; /* Numeric Base. */ cell_t gVarByeCode; /* Echo input. */ cell_t gVarEcho; /* Echo input. */ cell_t gVarTraceLevel; /* Trace Level for Inner Interpreter. */ cell_t gVarTraceStack; /* Dump Stack each time if true. */ cell_t gVarTraceFlags; /* Enable various internal debug messages. */ cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ /* data for INCLUDE that allows multiple nested files. */ IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH]; cell_t gIncludeIndex; static void pfResetForthTask( void ); static void pfInit( void ); static void pfTerm( void ); #define DEFAULT_RETURN_DEPTH (512) #define DEFAULT_USER_DEPTH (512) #ifndef PF_DEFAULT_HEADER_SIZE #define PF_DEFAULT_HEADER_SIZE (120000) #endif #ifndef PF_DEFAULT_CODE_SIZE #define PF_DEFAULT_CODE_SIZE (300000) #endif /* Initialize globals in a function to simplify loading on * embedded systems which may not support initialization of data section. */ static void pfInit( void ) { /* all zero */ gCurrentTask = NULL; gCurrentDictionary = NULL; gNumPrimitives = 0; gLocalCompiler_XT = 0; gVarContext = (cell_t)NULL; /* Points to last name field. */ gVarState = 0; /* 1 if compiling. */ gVarByeCode = 0; /* BYE-CODE */ gVarEcho = 0; /* Echo input. */ gVarTraceLevel = 0; /* Trace Level for Inner Interpreter. */ gVarTraceFlags = 0; /* Enable various internal debug messages. */ gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */ gIncludeIndex = 0; /* non-zero */ gVarBase = 10; /* Numeric Base. */ gDepthAtColon = DEPTH_AT_COLON_INVALID; gVarTraceStack = 1; pfInitMemoryAllocator(); ioInit(); } static void pfTerm( void ) { ioTerm(); } /*************************************************************** ** Task Management ***************************************************************/ void pfDeleteTask( PForthTask task ) { pfTaskData_t *cftd = (pfTaskData_t *)task; FREE_VAR( cftd->td_ReturnLimit ); FREE_VAR( cftd->td_StackLimit ); pfFreeMem( cftd ); } /* Allocate some extra cells to protect against mild stack underflows. */ #define STACK_SAFETY (8) PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth ) { pfTaskData_t *cftd; cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) ); if( !cftd ) goto nomem; pfSetMemory( cftd, 0, sizeof( pfTaskData_t )); /* Allocate User Stack */ cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * (UserStackDepth + STACK_SAFETY))); if( !cftd->td_StackLimit ) goto nomem; cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth; cftd->td_StackPtr = cftd->td_StackBase; /* Allocate Return Stack */ cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) ); if( !cftd->td_ReturnLimit ) goto nomem; cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth; cftd->td_ReturnPtr = cftd->td_ReturnBase; /* Allocate Float Stack */ #ifdef PF_SUPPORT_FP /* Allocate room for as many Floats as we do regular data. */ cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) * (UserStackDepth + STACK_SAFETY))); if( !cftd->td_FloatStackLimit ) goto nomem; cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth; cftd->td_FloatStackPtr = cftd->td_FloatStackBase; #endif cftd->td_InputStream = PF_STDIN; cftd->td_SourcePtr = &cftd->td_TIB[0]; cftd->td_SourceNum = 0; return (PForthTask) cftd; nomem: ERR("CreateTaskContext: insufficient memory.\n"); if( cftd ) pfDeleteTask( (PForthTask) cftd ); return NULL; } /*************************************************************** ** Dictionary Management ***************************************************************/ ThrowCode pfExecIfDefined( const char *CString ) { ThrowCode result = 0; if( NAME_BASE != (cell_t)NULL) { ExecToken XT; if( ffFindC( CString, &XT ) ) { result = pfCatch( XT ); } } return result; } /*************************************************************** ** Delete a dictionary created by pfCreateDictionary() */ void pfDeleteDictionary( PForthDictionary dictionary ) { pfDictionary_t *dic = (pfDictionary_t *) dictionary; if( !dic ) return; if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS ) { FREE_VAR( dic->dic_HeaderBaseUnaligned ); FREE_VAR( dic->dic_CodeBaseUnaligned ); } pfFreeMem( dic ); } /*************************************************************** ** Create a complete dictionary. ** The dictionary consists of two parts, the header with the names, ** and the code portion. ** Delete using pfDeleteDictionary(). ** Return pointer to dictionary management structure. */ PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize ) { /* Allocate memory for initial dictionary. */ pfDictionary_t *dic; dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) ); if( !dic ) goto nomem; pfSetMemory( dic, 0, sizeof( pfDictionary_t )); dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS; /* Align dictionary segments to preserve alignment of floats across hosts. * Thank you Helmut Proelss for pointing out that this needs to be cast * to (ucell_t) on 16 bit systems. */ #define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10)) #define DIC_ALIGN(addr) ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1)) /* Allocate memory for header. */ if( HeaderSize > 0 ) { dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE ); if( !dic->dic_HeaderBaseUnaligned ) goto nomem; /* Align header base. */ dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned); pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize); dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize; dic->dic_HeaderPtr = dic->dic_HeaderBase; } else { dic->dic_HeaderBase = 0; } /* Allocate memory for code. */ dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE ); if( !dic->dic_CodeBaseUnaligned ) goto nomem; dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned); pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize); dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize; dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES))); return (PForthDictionary) dic; nomem: pfDeleteDictionary( dic ); return NULL; } /*************************************************************** ** Used by Quit and other routines to restore system. ***************************************************************/ static void pfResetForthTask( void ) { /* Go back to terminal input. */ gCurrentTask->td_InputStream = PF_STDIN; /* Reset stacks. */ gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase; gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase; #ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */ gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase; #endif /* Advance >IN to end of input. */ gCurrentTask->td_IN = gCurrentTask->td_SourceNum; gVarState = 0; } /*************************************************************** ** Set current task context. ***************************************************************/ void pfSetCurrentTask( PForthTask task ) { gCurrentTask = (pfTaskData_t *) task; } /*************************************************************** ** Set Quiet Flag. ***************************************************************/ void pfSetQuiet( cell_t IfQuiet ) { gVarQuiet = (cell_t) IfQuiet; } /*************************************************************** ** Query message status. ***************************************************************/ cell_t pfQueryQuiet( void ) { return gVarQuiet; } /*************************************************************** ** Top level interpreter. ***************************************************************/ ThrowCode pfQuit( void ) { ThrowCode exception; int go = 1; while(go) { exception = ffOuterInterpreterLoop(); if( exception == 0 ) { exception = ffOK(); } switch( exception ) { case 0: break; case THROW_BYE: go = 0; break; case THROW_ABORT: default: ffDotS(); pfReportThrow( exception ); pfHandleIncludeError(); pfResetForthTask(); break; } } return gVarReturnCode; } /*************************************************************** ** Include file based on 'C' name. ***************************************************************/ cell_t pfIncludeFile( const char *FileName ) { FileStream *fid; cell_t Result; char buffer[32]; cell_t numChars, len; /* Open file. */ fid = sdOpenFile( FileName, "r" ); if( fid == NULL ) { ERR("pfIncludeFile could not open "); ERR(FileName); EMIT_CR; return -1; } /* Create a dictionary word named ::::FileName for FILE? */ pfCopyMemory( &buffer[0], "::::", 4); len = (cell_t) pfCStringLength(FileName); numChars = ( len > (32-4-1) ) ? (32-4-1) : len; pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 ); CreateDicEntryC( ID_NOOP, buffer, 0 ); Result = ffIncludeFile( fid ); /* Also close the file. */ /* Create a dictionary word named ;;;; for FILE? */ CreateDicEntryC( ID_NOOP, ";;;;", 0 ); return Result; } /*************************************************************** ** Output 'C' string message. ** Use sdTerminalOut which works before initializing gCurrentTask. ***************************************************************/ void pfDebugMessage( const char *CString ) { #if 0 while( *CString ) { char c = *CString++; if( c == '\n' ) { sdTerminalOut( 0x0D ); sdTerminalOut( 0x0A ); pfDebugMessage( "DBG: " ); } else { sdTerminalOut( c ); } } #else (void)CString; #endif } /*************************************************************** ** Print a decimal number to debug output. */ void pfDebugPrintDecimalNumber( int n ) { pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) ); } /*************************************************************** ** Output 'C' string message. ** This is provided to help avoid the use of printf() and other I/O ** which may not be present on a small embedded system. ** Uses ioType & ioEmit so requires that gCurrentTask has been initialized. ***************************************************************/ void pfMessage( const char *CString ) { ioType( CString, (cell_t) pfCStringLength(CString) ); } /************************************************************************** ** Main entry point for pForth. */ ThrowCode pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit ) { pfTaskData_t *cftd; pfDictionary_t *dic = NULL; ThrowCode Result = 0; ExecToken EntryPoint = 0; #ifdef PF_USER_INIT Result = PF_USER_INIT; if( Result < 0 ) goto error1; #endif pfInit(); /* Allocate Task structure. */ pfDebugMessage("pfDoForth: call pfCreateTask()\n"); cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH ); if( cftd ) { pfSetCurrentTask( cftd ); if( !gVarQuiet ) { MSG( "PForth V"PFORTH_VERSION_NAME", " ); if( IsHostLittleEndian() ) MSG("LE"); else MSG("BE"); #if PF_BIG_ENDIAN_DIC MSG("/BE"); #elif PF_LITTLE_ENDIAN_DIC MSG("/LE"); #endif if (sizeof(cell_t) == 8) { MSG("/64"); } else if (sizeof(cell_t) == 4) { MSG("/32"); } MSG( ", built "__DATE__" "__TIME__ ); } /* Don't use MSG before task set. */ if( SourceName ) { pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n"); } #ifdef PF_NO_GLOBAL_INIT if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */ #endif #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) if( IfInit ) { pfDebugMessage("Build dictionary from scratch.\n"); dic = pfBuildDictionary( PF_DEFAULT_HEADER_SIZE, PF_DEFAULT_CODE_SIZE ); } else #else TOUCH(IfInit); #endif /* !PF_NO_INIT && !PF_NO_SHELL*/ { if( DicFileName ) { pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n"); if( !gVarQuiet ) { EMIT_CR; } dic = pfLoadDictionary( DicFileName, &EntryPoint ); } else { if( !gVarQuiet ) { MSG(" (static)"); EMIT_CR; } dic = pfLoadStaticDictionary(); } } if( dic == NULL ) goto error2; if( !gVarQuiet ) { EMIT_CR; } pfDebugMessage("pfDoForth: try AUTO.INIT\n"); Result = pfExecIfDefined("AUTO.INIT"); if( Result != 0 ) { MSG("Error in AUTO.INIT"); goto error2; } if( EntryPoint != 0 ) { Result = pfCatch( EntryPoint ); } #ifndef PF_NO_SHELL else { if( SourceName == NULL ) { pfDebugMessage("pfDoForth: pfQuit\n"); Result = pfQuit(); } else { if( !gVarQuiet ) { MSG("Including: "); MSG(SourceName); MSG("\n"); } Result = pfIncludeFile( SourceName ); } } #endif /* PF_NO_SHELL */ /* Clean up after running Forth. */ pfExecIfDefined("AUTO.TERM"); pfDeleteDictionary( dic ); pfDeleteTask( cftd ); } pfTerm(); #ifdef PF_USER_TERM PF_USER_TERM; #endif return Result ? Result : gVarByeCode; error2: MSG("pfDoForth: Error occured.\n"); pfDeleteTask( cftd ); /* Terminate so we restore normal shell tty mode. */ pfTerm(); #ifdef PF_USER_INIT error1: #endif return -1; } #ifdef PF_UNIT_TEST cell_t pfUnitTest( void ) { cell_t numErrors = 0; numErrors += pfUnitTestText(); return numErrors; } #endif pforth-2.0.1/csrc/pf_core.h000066400000000000000000000023161435661464300155520ustar00rootroot00000000000000/* @(#) pf_core.h 98/01/26 1.3 */ #ifndef _pf_core_h #define _pf_core_h /*************************************************************** ** Include file for PForth 'C' Glue support ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #ifdef __cplusplus extern "C" { #endif void pfInitGlobals( void ); void pfDebugMessage( const char *CString ); void pfDebugPrintDecimalNumber( int n ); cell_t pfUnitTestText( void ); #ifdef __cplusplus } #endif #endif /* _pf_core_h */ pforth-2.0.1/csrc/pf_float.h000066400000000000000000000026651435661464300157360ustar00rootroot00000000000000/* @(#) pf_float.h 98/01/28 1.1 */ #ifndef _pf_float_h #define _pf_float_h /*************************************************************** ** Include file for PForth, a Forth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ typedef double PF_FLOAT; /* Define pForth specific math functions. */ #define fp_acos acos #define fp_asin asin #define fp_atan atan #define fp_atan2 atan2 #define fp_cos cos #define fp_cosh cosh #define fp_fabs fabs #define fp_floor floor #define fp_log log #define fp_log10 log10 #define fp_pow pow #define fp_sin sin #define fp_sinh sinh #define fp_sqrt sqrt #define fp_tan tan #define fp_tanh tanh #define fp_round round #endif pforth-2.0.1/csrc/pf_guts.h000066400000000000000000000415231435661464300156070ustar00rootroot00000000000000/* @(#) pf_guts.h 98/01/28 1.4 */ #ifndef _pf_guts_h #define _pf_guts_h /*************************************************************** ** Include file for PForth, a Forth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ /* ** PFORTH_VERSION changes when PForth is modified and released. ** See README file for version info. */ #define PFORTH_VERSION_CODE 29 #define PFORTH_VERSION_NAME "2.0.0" /* ** PFORTH_FILE_VERSION changes when incompatible changes are made ** in the ".dic" file format. ** ** FV3 - 950225 - Use ABS_TO_CODEREL for CodePtr. See file "pf_save.c". ** FV4 - 950309 - Added NameSize and CodeSize to pfSaveForth(). ** FV5 - 950316 - Added Floats and reserved words. ** FV6 - 961213 - Added ID_LOCAL_PLUSSTORE, ID_COLON_P, etc. ** 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 (10) /* Bump this whenever primitives added. */ #define PF_EARLIEST_FILE_VERSION (9) /* earliest one still compatible */ /*************************************************************** ** Sizes and other constants ***************************************************************/ #define TIB_SIZE (256) #ifndef FALSE #define FALSE (0) #endif #ifndef TRUE #define TRUE (1) #endif #define FFALSE (0) #define FTRUE (-1) #define BLANK (' ') #define FLAG_PRECEDENCE (0x80) #define FLAG_IMMEDIATE (0x40) #define FLAG_SMUDGE (0x20) #define MASK_NAME_SIZE (0x1F) /* Debug TRACE flags */ #define TRACE_INNER (0x0002) #define TRACE_COMPILE (0x0004) #define TRACE_SPECIAL (0x0008) /* Numeric types returned by NUMBER? */ #define NUM_TYPE_BAD (0) #define NUM_TYPE_SINGLE (1) #define NUM_TYPE_DOUBLE (2) #define NUM_TYPE_FLOAT (3) #define CREATE_BODY_OFFSET (3*sizeof(cell_t)) /*************************************************************** ** Primitive Token IDS ** Do NOT change the order of these IDs or dictionary files will break! ***************************************************************/ enum cforth_primitive_ids { ID_EXIT = 0, /* ID_EXIT must always be zero. */ /* Do NOT change the order of these IDs or dictionary files will break! */ ID_1MINUS, ID_1PLUS, ID_2DUP, ID_2LITERAL, ID_2LITERAL_P, ID_2MINUS, ID_2OVER, ID_2PLUS, ID_2SWAP, ID_2_R_FETCH, ID_2_R_FROM, ID_2_TO_R, ID_ACCEPT_P, ID_ALITERAL, ID_ALITERAL_P, ID_ALLOCATE, ID_AND, ID_ARSHIFT, ID_BAIL, ID_BODY_OFFSET, ID_BRANCH, ID_BYE, ID_CALL_C, ID_CFETCH, ID_CMOVE, ID_CMOVE_UP, ID_COLON, ID_COLON_P, ID_COMPARE, ID_COMP_EQUAL, ID_COMP_GREATERTHAN, ID_COMP_LESSTHAN, ID_COMP_NOT_EQUAL, ID_COMP_U_GREATERTHAN, ID_COMP_U_LESSTHAN, ID_COMP_ZERO_EQUAL, ID_COMP_ZERO_GREATERTHAN, ID_COMP_ZERO_LESSTHAN, ID_COMP_ZERO_NOT_EQUAL, ID_CR, ID_CREATE, ID_CREATE_P, ID_CSTORE, ID_DEFER, ID_DEFER_P, ID_DEPTH, ID_DIVIDE, ID_DOT, ID_DOTS, ID_DO_P, ID_DROP, ID_DUMP, ID_DUP, ID_D_MINUS, ID_D_MTIMES, ID_D_MUSMOD, ID_D_PLUS, ID_D_UMSMOD, ID_D_UMTIMES, ID_EMIT, ID_EMIT_P, ID_EOL, ID_ERRORQ_P, ID_EXECUTE, ID_FETCH, ID_FILE_CLOSE, ID_FILE_CREATE, ID_FILE_OPEN, ID_FILE_POSITION, ID_FILE_READ, ID_FILE_REPOSITION, ID_FILE_RO, ID_FILE_RW, ID_FILE_SIZE, ID_FILE_WRITE, ID_FILL, ID_FIND, ID_FINDNFA, ID_FLUSHEMIT, ID_FREE, ID_HERE, ID_NUMBERQ_P, ID_I, ID_INCLUDE_FILE, ID_J, ID_KEY, ID_LEAVE_P, ID_LITERAL, ID_LITERAL_P, ID_LOADSYS, ID_LOCAL_COMPILER, ID_LOCAL_ENTRY, ID_LOCAL_EXIT, ID_LOCAL_FETCH, ID_LOCAL_FETCH_1, ID_LOCAL_FETCH_2, ID_LOCAL_FETCH_3, ID_LOCAL_FETCH_4, ID_LOCAL_FETCH_5, ID_LOCAL_FETCH_6, ID_LOCAL_FETCH_7, ID_LOCAL_FETCH_8, ID_LOCAL_PLUSSTORE, ID_LOCAL_STORE, ID_LOCAL_STORE_1, ID_LOCAL_STORE_2, ID_LOCAL_STORE_3, ID_LOCAL_STORE_4, ID_LOCAL_STORE_5, ID_LOCAL_STORE_6, ID_LOCAL_STORE_7, ID_LOCAL_STORE_8, ID_LOOP_P, ID_LSHIFT, ID_MAX, ID_MIN, ID_MINUS, ID_NAME_TO_PREVIOUS, ID_NAME_TO_TOKEN, ID_NOOP, ID_NUMBERQ, ID_OR, ID_OVER, ID_PICK, ID_PLUS, ID_PLUSLOOP_P, ID_PLUS_STORE, ID_QDO_P, ID_QDUP, ID_QTERMINAL, ID_QUIT_P, ID_REFILL, ID_RESIZE, ID_SOURCE_LINE_NUMBER_FETCH, /* used to be ID_RESTORE_INPUT */ ID_ROLL, ID_ROT, ID_RP_FETCH, ID_RP_STORE, ID_RSHIFT, ID_R_DROP, ID_R_FETCH, ID_R_FROM, ID_SAVE_FORTH_P, ID_SOURCE_LINE_NUMBER_STORE, /* used to be ID_SAVE_INPUT */ ID_SCAN, ID_SEMICOLON, ID_SKIP, ID_SOURCE, ID_SOURCE_ID, ID_SOURCE_ID_POP, ID_SOURCE_ID_PUSH, ID_SOURCE_SET, ID_SP_FETCH, ID_SP_STORE, ID_STORE, ID_SWAP, ID_TEST1, ID_TEST2, ID_TEST3, ID_TICK, ID_TIMES, ID_TO_R, ID_TYPE, ID_TYPE_P, ID_VAR_BASE, ID_VAR_CODE_BASE, ID_VAR_CODE_LIMIT, ID_VAR_CONTEXT, ID_VAR_DP, ID_VAR_ECHO, ID_VAR_HEADERS_BASE, ID_VAR_HEADERS_LIMIT, ID_VAR_HEADERS_PTR, ID_VAR_NUM_TIB, ID_VAR_OUT, ID_VAR_RETURN_CODE, ID_VAR_SOURCE_ID, ID_VAR_STATE, ID_VAR_TO_IN, ID_VAR_TRACE_FLAGS, ID_VAR_TRACE_LEVEL, ID_VAR_TRACE_STACK, ID_VLIST, ID_WORD, ID_WORD_FETCH, ID_WORD_STORE, ID_XOR, ID_ZERO_BRANCH, ID_CATCH, ID_THROW, ID_INTERPRET, ID_FILE_WO, ID_FILE_BIN, /* Added to support 64 bit operation. */ ID_CELL, ID_CELLS, /* DELETE-FILE */ ID_FILE_DELETE, ID_FILE_FLUSH, /* FLUSH-FILE */ ID_FILE_RENAME, /* (RENAME-FILE) */ ID_FILE_RESIZE, /* RESIZE-FILE */ ID_SLEEP_P, /* (SLEEP) V2.0.0 */ ID_VAR_BYE_CODE, /* BYE-CODE */ ID_VERSION_CODE, /* 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 ** unsupported primitives when loading dictionary. */ ID_RESERVED03, ID_RESERVED04, ID_RESERVED05, ID_RESERVED06, ID_RESERVED07, ID_RESERVED08, ID_RESERVED09, ID_FP_D_TO_F, ID_FP_FSTORE, ID_FP_FTIMES, ID_FP_FPLUS, ID_FP_FMINUS, ID_FP_FSLASH, ID_FP_F_ZERO_LESS_THAN, ID_FP_F_ZERO_EQUALS, ID_FP_F_LESS_THAN, ID_FP_F_TO_D, ID_FP_FFETCH, ID_FP_FDEPTH, ID_FP_FDROP, ID_FP_FDUP, ID_FP_FLITERAL, ID_FP_FLITERAL_P, ID_FP_FLOAT_PLUS, ID_FP_FLOATS, ID_FP_FLOOR, ID_FP_FMAX, ID_FP_FMIN, ID_FP_FNEGATE, ID_FP_FOVER, ID_FP_FROT, ID_FP_FROUND, ID_FP_FSWAP, ID_FP_FSTAR_STAR, ID_FP_FABS, ID_FP_FACOS, ID_FP_FACOSH, ID_FP_FALOG, ID_FP_FASIN, ID_FP_FASINH, ID_FP_FATAN, ID_FP_FATAN2, ID_FP_FATANH, ID_FP_FCOS, ID_FP_FCOSH, ID_FP_FLN, ID_FP_FLNP1, ID_FP_FLOG, ID_FP_FSIN, ID_FP_FSINCOS, ID_FP_FSINH, ID_FP_FSQRT, ID_FP_FTAN, ID_FP_FTANH, ID_FP_FPICK, #endif /* Add new IDs by replacing reserved IDs or extending FP routines. */ /* Do NOT change the order of these IDs or dictionary files will break! */ NUM_PRIMITIVES /* This must always be LAST */ }; /*************************************************************** ** THROW Codes ***************************************************************/ /* ANSI standard definitions needed by pForth */ #define THROW_ABORT (-1) #define THROW_ABORT_QUOTE (-2) #define THROW_STACK_OVERFLOW (-3) #define THROW_STACK_UNDERFLOW (-4) #define THROW_UNDEFINED_WORD (-13) #define THROW_EXECUTING (-14) #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. */ #define THROW_SEMICOLON (-257) /* Error detected at ; */ #define THROW_DEFERRED (-258) /* Not a deferred word. Used in system.fth */ /*************************************************************** ** Structures ***************************************************************/ typedef struct pfTaskData_s { cell_t *td_StackPtr; /* Primary data stack */ cell_t *td_StackBase; cell_t *td_StackLimit; cell_t *td_ReturnPtr; /* Return stack */ cell_t *td_ReturnBase; cell_t *td_ReturnLimit; #ifdef PF_SUPPORT_FP PF_FLOAT *td_FloatStackPtr; PF_FLOAT *td_FloatStackBase; PF_FLOAT *td_FloatStackLimit; #endif cell_t *td_InsPtr; /* Instruction pointer, "PC" */ FileStream *td_InputStream; /* Terminal. */ char td_TIB[TIB_SIZE]; /* Buffer for terminal input. */ cell_t td_IN; /* Index into Source */ cell_t td_SourceNum; /* #TIB after REFILL */ char *td_SourcePtr; /* Pointer to TIB or other source. */ cell_t td_LineNumber; /* Incremented on every refill. */ cell_t td_OUT; /* Current output column. */ } pfTaskData_t; typedef struct pfNode { struct pfNode *n_Next; struct pfNode *n_Prev; } pfNode; /* Structure of header entry in dictionary. These will be stored in dictionary specific endian format*/ typedef struct cfNameLinks { cell_t cfnl_PreviousName; /* name relative address of previous */ ExecToken cfnl_ExecToken; /* Execution token for word. */ /* Followed by variable length name field. */ } cfNameLinks; #define PF_DICF_ALLOCATED_SEGMENTS ( 0x0001) typedef struct pfDictionary_s { pfNode dic_Node; ucell_t dic_Flags; /* Headers contain pointers to names and dictionary. */ ucell_t dic_HeaderBaseUnaligned; ucell_t dic_HeaderBase; ucell_t dic_HeaderPtr; ucell_t dic_HeaderLimit; /* Code segment contains tokenized code and data. */ ucell_t dic_CodeBaseUnaligned; ucell_t dic_CodeBase; union { cell_t *Cell; uint8_t *Byte; } dic_CodePtr; ucell_t dic_CodeLimit; } pfDictionary_t; /* Save state of include when nesting files. */ typedef struct IncludeFrame { FileStream *inf_FileID; cell_t inf_LineNumber; cell_t inf_SourceNum; cell_t inf_IN; char inf_SaveTIB[TIB_SIZE]; } IncludeFrame; #define MAX_INCLUDE_DEPTH (16) /*************************************************************** ** Prototypes ***************************************************************/ #ifdef __cplusplus extern "C" { #endif ThrowCode pfCatch( ExecToken XT ); #ifdef __cplusplus } #endif /*************************************************************** ** External Globals ***************************************************************/ extern pfTaskData_t *gCurrentTask; extern pfDictionary_t *gCurrentDictionary; extern char gScratch[TIB_SIZE]; extern cell_t gNumPrimitives; extern ExecToken gLocalCompiler_XT; /* CFA of (LOCAL) compiler. */ extern ExecToken gNumberQ_XT; /* XT of NUMBER? */ extern ExecToken gQuitP_XT; /* XT of (QUIT) */ extern ExecToken gAcceptP_XT; /* XT of ACCEPT */ #define DEPTH_AT_COLON_INVALID (-100) extern cell_t gDepthAtColon; /* Global variables. */ extern cell_t gVarContext; /* Points to last name field. */ extern cell_t gVarState; /* 1 if compiling. */ extern cell_t gVarBase; /* Numeric Base. */ extern cell_t gVarByeCode; /* BYE-CODE returned on exit */ extern cell_t gVarEcho; /* Echo input from file. */ extern cell_t gVarEchoAccept; /* Echo input from ACCEPT. */ extern cell_t gVarTraceLevel; extern cell_t gVarTraceStack; extern cell_t gVarTraceFlags; extern cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ extern cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ extern IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH]; extern cell_t gIncludeIndex; /*************************************************************** ** Macros ***************************************************************/ /* Endian specific macros for creating target dictionaries for machines with ** different endian-ness. */ #if defined(PF_BIG_ENDIAN_DIC) #define WRITE_FLOAT_DIC WriteFloatBigEndian #define WRITE_CELL_DIC(addr,data) WriteCellBigEndian((uint8_t *)(addr),(ucell_t)(data)) #define WRITE_SHORT_DIC(addr,data) Write16BigEndian((uint8_t *)(addr),(uint16_t)(data)) #define READ_FLOAT_DIC ReadFloatBigEndian #define READ_CELL_DIC(addr) ReadCellBigEndian((const uint8_t *)(addr)) #define READ_SHORT_DIC(addr) Read16BigEndian((const uint8_t *)(addr)) #elif defined(PF_LITTLE_ENDIAN_DIC) #define WRITE_FLOAT_DIC WriteFloatLittleEndian #define WRITE_CELL_DIC(addr,data) WriteCellLittleEndian((uint8_t *)(addr),(ucell_t)(data)) #define WRITE_SHORT_DIC(addr,data) Write16LittleEndian((uint8_t *)(addr),(uint16_t)(data)) #define READ_FLOAT_DIC ReadFloatLittleEndian #define READ_CELL_DIC(addr) ReadCellLittleEndian((const uint8_t *)(addr)) #define READ_SHORT_DIC(addr) Read16LittleEndian((const uint8_t *)(addr)) #else #define WRITE_FLOAT_DIC(addr,data) { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); } #define WRITE_CELL_DIC(addr,data) { *((cell_t *)(addr)) = (cell_t)(data); } #define WRITE_SHORT_DIC(addr,data) { *((int16_t *)(addr)) = (int16_t)(data); } #define READ_FLOAT_DIC(addr) ( *((PF_FLOAT *)(addr)) ) #define READ_CELL_DIC(addr) ( *((const ucell_t *)(addr)) ) #define READ_SHORT_DIC(addr) ( *((const uint16_t *)(addr)) ) #endif #define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell) #define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell) #define CODE_COMMA( N ) WRITE_CELL_DIC(CODE_HERE++,(N)) #define NAME_BASE (gCurrentDictionary->dic_HeaderBase) #define CODE_BASE (gCurrentDictionary->dic_CodeBase) #define NAME_SIZE (gCurrentDictionary->dic_HeaderLimit - gCurrentDictionary->dic_HeaderBase) #define CODE_SIZE (gCurrentDictionary->dic_CodeLimit - gCurrentDictionary->dic_CodeBase) #define IN_CODE_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_CodeBase) && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_CodeLimit) ) #define IN_NAME_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_HeaderLimit) ) #define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr)) /* Address conversion */ #define ABS_TO_NAMEREL( a ) ((cell_t) (((ucell_t) a) - NAME_BASE )) #define ABS_TO_CODEREL( a ) ((cell_t) (((ucell_t) a) - CODE_BASE )) #define NAMEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + NAME_BASE)) #define CODEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + CODE_BASE)) /* The check for >0 is only needed for CLONE testing. !!! */ #define IsTokenPrimitive(xt) ((xt=0)) #define FREE_VAR(v) { if (v) { pfFreeMem((void *)(v)); v = 0; } } #define DATA_STACK_DEPTH (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) #define DROP_DATA_STACK (gCurrentTask->td_StackPtr++) #define POP_DATA_STACK (*gCurrentTask->td_StackPtr++) #define PUSH_DATA_STACK(x) {*(--(gCurrentTask->td_StackPtr)) = (cell_t) x; } /* Force Quad alignment. */ #define QUADUP(x) (((x)+3)&~3) #ifndef MIN #define MIN(a,b) ( ((a)<(b)) ? (a) : (b) ) #endif #ifndef MAX #define MAX(a,b) ( ((a)>(b)) ? (a) : (b) ) #endif #ifndef TOUCH #define TOUCH(argument) ((void)argument) #endif /*************************************************************** ** I/O related macros ***************************************************************/ #define EMIT(c) ioEmit(c) #define EMIT_CR EMIT('\n'); #define MSG(cs) pfMessage(cs) #define ERR(x) MSG(x) #define DBUG(x) /* PRT(x) */ #define DBUGX(x) /* DBUG(x) */ #define MSG_NUM_D(msg,num) { MSG(msg); ffDot((cell_t) num); EMIT_CR; } #define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((cell_t) num); EMIT_CR; } #define DBUG_NUM_D(msg,num) { pfDebugMessage(msg); pfDebugPrintDecimalNumber((cell_t) num); pfDebugMessage("\n"); } #endif /* _pf_guts_h */ pforth-2.0.1/csrc/pf_host.h000066400000000000000000000021011435661464300155670ustar00rootroot00000000000000/* @(#) pf_host.h 96/12/18 1.12 */ #ifndef _pf_system_h #define _pf_system_h /*************************************************************** ** System Dependant Includes for PForth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ***************************************************************/ #endif /* _pf_system_h */ pforth-2.0.1/csrc/pf_inc1.h000066400000000000000000000026661435661464300154640ustar00rootroot00000000000000/* @(#) pf_unix.h 98/01/28 1.4 */ #ifndef _pf_embedded_h #define _pf_embedded_h /*************************************************************** ** Embedded System include file for PForth, a Forth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #ifndef PF_NO_CLIB #include /* Needed for strlen(), memcpy(), and memset(). */ #include /* Needed for exit(). */ #endif #ifdef PF_NO_STDIO #define NULL ((void *) 0) #define EOF (-1) #else #include #endif #ifdef PF_SUPPORT_FP #include #ifndef PF_USER_FP #include "pf_float.h" #else #include PF_USER_FP #endif #endif #endif /* _pf_embedded_h */ pforth-2.0.1/csrc/pf_inner.c000066400000000000000000001574241435661464300157430ustar00rootroot00000000000000/* @(#) pf_inner.c 98/03/16 1.7 */ /*************************************************************** ** Inner Interpreter for Forth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** ** 940502 PLB Creation. ** 940505 PLB More macros. ** 940509 PLB Moved all stack stuff into pfCatch. ** 941014 PLB Converted to flat secondary strusture. ** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH, ** and ID_HERE for armcc ** 941130 PLB Made w@ unsigned ** ***************************************************************/ #include "pf_all.h" #if defined(WIN32) && !defined(__MINGW32__) #include #endif #define SYSTEM_LOAD_FILE "system.fth" /*************************************************************** ** Macros for data stack access. ** TOS is cached in a register in pfCatch. ***************************************************************/ #define STKPTR (DataStackPtr) #define M_POP (*(STKPTR++)) #define M_PUSH(n) {*(--(STKPTR)) = (cell_t) (n);} #define M_STACK(n) (STKPTR[n]) #define TOS (TopOfStack) #define PUSH_TOS M_PUSH(TOS) #define M_DUP PUSH_TOS; #define M_DROP { TOS = M_POP; } #define ASCII_EOT (0x04) /*************************************************************** ** Macros for Floating Point stack access. ***************************************************************/ #ifdef PF_SUPPORT_FP #define FP_STKPTR (FloatStackPtr) #define M_FP_SPZERO (gCurrentTask->td_FloatStackBase) #define M_FP_POP (*(FP_STKPTR++)) #define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);} #define M_FP_STACK(n) (FP_STKPTR[n]) #define FP_TOS (fpTopOfStack) #define PUSH_FP_TOS M_FP_PUSH(FP_TOS) #define M_FP_DUP PUSH_FP_TOS; #define M_FP_DROP { FP_TOS = M_FP_POP; } #endif /*************************************************************** ** Macros for return stack access. ***************************************************************/ #define TORPTR (ReturnStackPtr) #define M_R_DROP {TORPTR++;} #define M_R_POP (*(TORPTR++)) #define M_R_PICK(n) (TORPTR[n]) #define M_R_PUSH(n) {*(--(TORPTR)) = (cell_t) (n);} /*************************************************************** ** Misc Forth macros ***************************************************************/ #define M_BRANCH { InsPtr = (cell_t *) (((uint8_t *) InsPtr) + READ_CELL_DIC(InsPtr)); } /* Cache top of data stack like in JForth. */ #ifdef PF_SUPPORT_FP #define LOAD_REGISTERS \ { \ STKPTR = gCurrentTask->td_StackPtr; \ TOS = M_POP; \ FP_STKPTR = gCurrentTask->td_FloatStackPtr; \ FP_TOS = M_FP_POP; \ TORPTR = gCurrentTask->td_ReturnPtr; \ } #define SAVE_REGISTERS \ { \ gCurrentTask->td_ReturnPtr = TORPTR; \ M_PUSH( TOS ); \ gCurrentTask->td_StackPtr = STKPTR; \ M_FP_PUSH( FP_TOS ); \ gCurrentTask->td_FloatStackPtr = FP_STKPTR; \ } #else /* Cache top of data stack like in JForth. */ #define LOAD_REGISTERS \ { \ STKPTR = gCurrentTask->td_StackPtr; \ TOS = M_POP; \ TORPTR = gCurrentTask->td_ReturnPtr; \ } #define SAVE_REGISTERS \ { \ gCurrentTask->td_ReturnPtr = TORPTR; \ M_PUSH( TOS ); \ gCurrentTask->td_StackPtr = STKPTR; \ } #endif #define M_DOTS \ SAVE_REGISTERS; \ ffDotS( ); \ LOAD_REGISTERS; #define DO_VAR(varname) { PUSH_TOS; TOS = (cell_t) &varname; } #ifdef PF_SUPPORT_FP #define M_THROW(err) \ { \ ExceptionReturnCode = (ThrowCode)(err); \ TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \ STKPTR = InitialDataStack; \ FP_STKPTR = InitialFloatStack; \ } #else #define M_THROW(err) \ { \ ExceptionReturnCode = (err); \ TORPTR = InitialReturnStack; /* Will cause return to 'C' */ \ STKPTR = InitialDataStack; \ } #endif /*************************************************************** ** Other macros ***************************************************************/ #define BINARY_OP( op ) { TOS = M_POP op TOS; } #define endcase break #if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE) #define TRACENAMES /* no names */ #else /* Display name of executing routine. */ static void TraceNames( ExecToken Token, cell_t Level ) { char *DebugName; cell_t i; if( ffTokenToName( Token, &DebugName ) ) { cell_t NumSpaces; if( gCurrentTask->td_OUT > 0 ) EMIT_CR; EMIT( '>' ); for( i=0; itd_OUT; for( i=0; i < NumSpaces; i++ ) { EMIT( ' ' ); } ffDotS(); /* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */ } else { MSG_NUM_H("Couldn't find Name for ", Token); } } #define TRACENAMES \ if( (gVarTraceLevel > Level) ) \ { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; } #endif /* PF_NO_SHELL */ /* Use local copy of CODE_BASE for speed. */ #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase)) /* Truncate the unsigned double cell integer LO/HI to an uint64_t. */ static uint64_t UdToUint64( ucell_t Lo, ucell_t Hi ) { return (( 2 * sizeof(ucell_t) == sizeof(uint64_t) ) ? (((uint64_t)Lo) | (((uint64_t)Hi) >> (sizeof(ucell_t) * 8))) : Lo); } /* Return TRUE if the unsigned double cell integer LO/HI is not greater * then the greatest uint64_t. */ static int UdIsUint64( ucell_t Lo, ucell_t Hi ) { return (( 2 * sizeof(ucell_t) == sizeof(uint64_t) ) ? TRUE : Hi == 0); } static const char *pfSelectFileModeCreate( cell_t fam ); static const char *pfSelectFileModeOpen( cell_t fam ); /**************************************************************/ static const char *pfSelectFileModeCreate( cell_t fam ) { const char *famText = NULL; switch( fam ) { case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_CREATE_WO; break; case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_CREATE_RW; break; case PF_FAM_WRITE_ONLY: famText = PF_FAM_CREATE_WO; break; case PF_FAM_READ_WRITE: famText = PF_FAM_CREATE_RW; break; default: famText = "illegal"; break; } return famText; } /**************************************************************/ static const char *pfSelectFileModeOpen( cell_t fam ) { const char *famText = NULL; switch( fam ) { case (PF_FAM_READ_ONLY + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_OPEN_RO; break; case (PF_FAM_WRITE_ONLY + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_CREATE_WO; break; case (PF_FAM_READ_WRITE + PF_FAM_BINARY_FLAG): famText = PF_FAM_BIN_OPEN_RW; break; case PF_FAM_READ_ONLY: famText = PF_FAM_OPEN_RO; break; case PF_FAM_WRITE_ONLY: famText = PF_FAM_CREATE_WO; break; case PF_FAM_READ_WRITE: default: famText = PF_FAM_OPEN_RW; break; } return famText; } /**************************************************************/ ThrowCode pfCatch( ExecToken XT ) { register cell_t TopOfStack; /* Cache for faster execution. */ register cell_t *DataStackPtr; register cell_t *ReturnStackPtr; register cell_t *InsPtr = NULL; register cell_t Token; cell_t Scratch; #ifdef PF_SUPPORT_FP PF_FLOAT fpTopOfStack; PF_FLOAT *FloatStackPtr; PF_FLOAT fpScratch; PF_FLOAT fpTemp; PF_FLOAT *InitialFloatStack; #endif #ifdef PF_SUPPORT_TRACE cell_t Level = 0; #endif cell_t *LocalsPtr = NULL; cell_t Temp; cell_t *InitialReturnStack; cell_t *InitialDataStack; cell_t FakeSecondary[2]; char *CharPtr; cell_t *CellPtr; FileStream *FileID; uint8_t *CodeBase = (uint8_t *) CODE_BASE; ThrowCode ExceptionReturnCode = 0; /* FIXME gExecutionDepth += 1; PRT(("pfCatch( 0x%x ), depth = %d\n", XT, gExecutionDepth )); */ /* ** Initialize FakeSecondary this way to avoid having stuff in the data section, ** which is not supported for some embedded system loaders. */ FakeSecondary[0] = 0; FakeSecondary[1] = ID_EXIT; /* For EXECUTE */ /* Move data from task structure to registers for speed. */ LOAD_REGISTERS; /* Save initial stack depths for THROW */ InitialReturnStack = TORPTR; InitialDataStack = STKPTR ; #ifdef PF_SUPPORT_FP InitialFloatStack = FP_STKPTR; #endif Token = XT; do { DBUG(("pfCatch: Token = 0x%x\n", Token )); /* --------------------------------------------------------------- */ /* If secondary, thread down code tree until we hit a primitive. */ while( !IsTokenPrimitive( Token ) ) { #ifdef PF_SUPPORT_TRACE if((gVarTraceFlags & TRACE_INNER) ) { MSG("pfCatch: Secondary Token = 0x"); ffDotHex(Token); MSG_NUM_H(", InsPtr = 0x", InsPtr); } TRACENAMES; #endif /* Save IP on return stack like a JSR. */ M_R_PUSH( InsPtr ); /* Convert execution token to absolute address. */ InsPtr = (cell_t *) ( LOCAL_CODEREL_TO_ABS(Token) ); /* Fetch token at IP. */ Token = READ_CELL_DIC(InsPtr++); #ifdef PF_SUPPORT_TRACE /* Bump level for trace display */ Level++; #endif } #ifdef PF_SUPPORT_TRACE TRACENAMES; #endif /* Execute primitive Token. */ switch( Token ) { /* Pop up a level in Forth inner interpreter. ** Used to implement semicolon. ** Put first in switch because ID_EXIT==0 */ case ID_EXIT: InsPtr = ( cell_t *) M_R_POP; #ifdef PF_SUPPORT_TRACE Level--; #endif endcase; case ID_1MINUS: TOS--; endcase; case ID_1PLUS: TOS++; endcase; #ifndef PF_NO_SHELL case ID_2LITERAL: ff2Literal( TOS, M_POP ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_2LITERAL_P: /* hi part stored first, put on top of stack */ PUSH_TOS; TOS = READ_CELL_DIC(InsPtr++); M_PUSH(READ_CELL_DIC(InsPtr++)); endcase; case ID_2MINUS: TOS -= 2; endcase; case ID_2PLUS: TOS += 2; endcase; case ID_2OVER: /* ( a b c d -- a b c d a b ) */ PUSH_TOS; Scratch = M_STACK(3); M_PUSH(Scratch); TOS = M_STACK(3); endcase; case ID_2SWAP: /* ( a b c d -- c d a b ) */ Scratch = M_STACK(0); /* c */ M_STACK(0) = M_STACK(2); /* a */ M_STACK(2) = Scratch; /* c */ Scratch = TOS; /* d */ TOS = M_STACK(1); /* b */ M_STACK(1) = Scratch; /* d */ endcase; case ID_2DUP: /* ( a b -- a b a b ) */ PUSH_TOS; Scratch = M_STACK(1); M_PUSH(Scratch); endcase; case ID_2_R_FETCH: PUSH_TOS; M_PUSH( (*(TORPTR+1)) ); TOS = (*(TORPTR)); endcase; case ID_2_R_FROM: PUSH_TOS; TOS = M_R_POP; M_PUSH( M_R_POP ); endcase; case ID_2_TO_R: M_R_PUSH( M_POP ); M_R_PUSH( TOS ); M_DROP; endcase; case ID_ACCEPT_P: /* ( c-addr +n1 -- +n2 ) */ CharPtr = (char *) M_POP; TOS = ioAccept( CharPtr, TOS ); endcase; #ifndef PF_NO_SHELL case ID_ALITERAL: ffALiteral( ABS_TO_CODEREL(TOS) ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_ALITERAL_P: PUSH_TOS; TOS = (cell_t) LOCAL_CODEREL_TO_ABS( READ_CELL_DIC(InsPtr++) ); endcase; /* Allocate some extra and put validation identifier at base */ #define PF_MEMORY_VALIDATOR (0xA81B4D69) case ID_ALLOCATE: /* Allocate at least one cell's worth because we clobber first cell. */ if ( TOS < sizeof(cell_t) ) { Temp = sizeof(cell_t); } else { Temp = TOS; } /* Allocate extra cells worth because we store validation info. */ CellPtr = (cell_t *) pfAllocMem( Temp + sizeof(cell_t) ); if( CellPtr ) { /* This was broken into two steps because different compilers incremented ** CellPtr before or after the XOR step. */ Temp = (cell_t)CellPtr ^ PF_MEMORY_VALIDATOR; *CellPtr++ = Temp; M_PUSH( (cell_t) CellPtr ); TOS = 0; } else { M_PUSH( 0 ); TOS = -1; /* FIXME Fix error code. */ } endcase; case ID_AND: BINARY_OP( & ); endcase; case ID_ARSHIFT: BINARY_OP( >> ); endcase; /* Arithmetic right shift */ case ID_BODY_OFFSET: PUSH_TOS; TOS = CREATE_BODY_OFFSET; endcase; /* Branch is followed by an offset relative to address of offset. */ case ID_BRANCH: DBUGX(("Before Branch: IP = 0x%x\n", InsPtr )); M_BRANCH; DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); endcase; case ID_BYE: EMIT_CR; M_THROW( THROW_BYE ); endcase; case ID_BAIL: MSG("Emergency exit.\n"); EXIT(1); endcase; case ID_CATCH: Scratch = TOS; TOS = M_POP; SAVE_REGISTERS; Scratch = pfCatch( Scratch ); LOAD_REGISTERS; M_PUSH( TOS ); TOS = Scratch; endcase; case ID_CALL_C: SAVE_REGISTERS; Scratch = READ_CELL_DIC(InsPtr++); CallUserFunction( Scratch & 0xFFFF, (Scratch >> 31) & 1, (Scratch >> 24) & 0x7F ); LOAD_REGISTERS; endcase; /* Support 32/64 bit operation. */ case ID_CELL: M_PUSH( TOS ); TOS = sizeof(cell_t); endcase; case ID_CELLS: TOS = TOS * sizeof(cell_t); endcase; case ID_CFETCH: TOS = *((uint8_t *) TOS); endcase; case ID_CMOVE: /* ( src dst n -- ) */ { register char *DstPtr = (char *) M_POP; /* dst */ CharPtr = (char *) M_POP; /* src */ for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ ) { *DstPtr++ = *CharPtr++; } M_DROP; } endcase; case ID_CMOVE_UP: /* ( src dst n -- ) */ { register char *DstPtr = ((char *) M_POP) + TOS; /* dst */ CharPtr = ((char *) M_POP) + TOS;; /* src */ for( Scratch=0; (ucell_t) Scratch < (ucell_t) TOS ; Scratch++ ) { *(--DstPtr) = *(--CharPtr); } M_DROP; } endcase; #ifndef PF_NO_SHELL case ID_COLON: SAVE_REGISTERS; ffColon( ); LOAD_REGISTERS; endcase; case ID_COLON_P: /* ( $name xt -- ) */ CreateDicEntry( TOS, (char *) M_POP, 0 ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_COMPARE: { const char *s1, *s2; cell_t len1; s2 = (const char *) M_POP; len1 = M_POP; s1 = (const char *) M_POP; TOS = ffCompare( s1, len1, s2, TOS ); } endcase; /* ( a b -- flag , Comparisons ) */ case ID_COMP_EQUAL: TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ; endcase; case ID_COMP_NOT_EQUAL: TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ; endcase; case ID_COMP_GREATERTHAN: TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ; endcase; case ID_COMP_LESSTHAN: TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ; endcase; case ID_COMP_U_GREATERTHAN: TOS = ( ((ucell_t)M_POP) > ((ucell_t)TOS) ) ? FTRUE : FFALSE ; endcase; case ID_COMP_U_LESSTHAN: TOS = ( ((ucell_t)M_POP) < ((ucell_t)TOS) ) ? FTRUE : FFALSE ; endcase; case ID_COMP_ZERO_EQUAL: TOS = ( TOS == 0 ) ? FTRUE : FFALSE ; endcase; case ID_COMP_ZERO_NOT_EQUAL: TOS = ( TOS != 0 ) ? FTRUE : FALSE ; endcase; case ID_COMP_ZERO_GREATERTHAN: TOS = ( TOS > 0 ) ? FTRUE : FFALSE ; endcase; case ID_COMP_ZERO_LESSTHAN: TOS = ( TOS < 0 ) ? FTRUE : FFALSE ; endcase; case ID_CR: EMIT_CR; endcase; #ifndef PF_NO_SHELL case ID_CREATE: SAVE_REGISTERS; ffCreate(); LOAD_REGISTERS; endcase; #endif /* !PF_NO_SHELL */ case ID_CREATE_P: PUSH_TOS; /* Put address of body on stack. Insptr points after code start. */ TOS = (cell_t) ((char *)InsPtr - sizeof(cell_t) + CREATE_BODY_OFFSET ); endcase; case ID_CSTORE: /* ( c caddr -- ) */ *((uint8_t *) TOS) = (uint8_t) M_POP; M_DROP; endcase; /* Double precision add. */ case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ { register ucell_t ah,al,bl,sh,sl; #define bh TOS bl = M_POP; ah = M_POP; al = M_POP; sh = 0; sl = al + bl; if( sl < bl ) sh = 1; /* Carry */ sh += ah + bh; M_PUSH( sl ); TOS = sh; #undef bh } endcase; /* Double precision subtract. */ case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */ { register ucell_t ah,al,bl,sh,sl; #define bh TOS bl = M_POP; ah = M_POP; al = M_POP; sh = 0; sl = al - bl; if( al < bl ) sh = 1; /* Borrow */ sh = ah - bh - sh; M_PUSH( sl ); TOS = sh; #undef bh } endcase; /* Assume 8-bit char and calculate cell width. */ #define NBITS ((sizeof(ucell_t)) * 8) /* Define half the number of bits in a cell. */ #define HNBITS (NBITS / 2) /* Assume two-complement arithmetic to calculate lower half. */ #define LOWER_HALF(n) ((n) & (((ucell_t)1 << HNBITS) - 1)) #define HIGH_BIT ((ucell_t)1 << (NBITS - 1)) /* Perform cell*cell bit multiply for a 2 cell result, by factoring into half cell quantities. * Using an improved algorithm suggested by Steve Green. * Converted to 64-bit by Aleksej Saushev. */ case ID_D_UMTIMES: /* UM* ( a b -- lo hi ) */ { ucell_t ahi, alo, bhi, blo; /* input parts */ ucell_t lo, hi, temp; /* Get values from stack. */ ahi = M_POP; bhi = TOS; /* Break into hi and lo 16 bit parts. */ alo = LOWER_HALF(ahi); ahi = ahi >> HNBITS; blo = LOWER_HALF(bhi); bhi = bhi >> HNBITS; lo = 0; hi = 0; /* higher part: ahi * bhi */ hi += ahi * bhi; /* middle (overlapping) part: ahi * blo */ temp = ahi * blo; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* middle (overlapping) part: alo * bhi */ temp = alo * bhi; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* lower part: alo * blo */ temp = alo * blo; /* its higher half overlaps with middle's lower half: */ lo += temp >> HNBITS; /* process carry: */ hi += lo >> HNBITS; lo = LOWER_HALF(lo); /* combine lower part of result: */ lo = (lo << HNBITS) + LOWER_HALF(temp); M_PUSH( lo ); TOS = hi; } endcase; /* Perform cell*cell bit multiply for 2 cell result, using shift and add. */ case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ { ucell_t ahi, alo, bhi, blo; /* input parts */ ucell_t lo, hi, temp; int sg; /* Get values from stack. */ ahi = M_POP; bhi = TOS; /* Calculate product sign: */ sg = ((cell_t)(ahi ^ bhi) < 0); /* Take absolute values and reduce to um* */ if ((cell_t)ahi < 0) ahi = (ucell_t)(-(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); ahi = ahi >> HNBITS; blo = LOWER_HALF(bhi); bhi = bhi >> HNBITS; lo = 0; hi = 0; /* higher part: ahi * bhi */ hi += ahi * bhi; /* middle (overlapping) part: ahi * blo */ temp = ahi * blo; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* middle (overlapping) part: alo * bhi */ temp = alo * bhi; lo += LOWER_HALF(temp); hi += temp >> HNBITS; /* lower part: alo * blo */ temp = alo * blo; /* its higher half overlaps with middle's lower half: */ lo += temp >> HNBITS; /* process carry: */ hi += lo >> HNBITS; lo = LOWER_HALF(lo); /* combine lower part of result: */ lo = (lo << HNBITS) + LOWER_HALF(temp); /* Negate product if one operand negative. */ if(sg) { /* lo = (ucell_t)(- lo); */ lo = ~lo + 1; hi = ~hi + ((lo == 0) ? 1 : 0); } M_PUSH( lo ); TOS = hi; } endcase; #define DULT(du1l,du1h,du2l,du2h) ( (du2h> 1) | (bh << (NBITS-1)); bh = bh >> 1; } if( !DULT(al,ah,bl,bh) ) { al = al - bl; q |= 1; } M_PUSH( al ); /* rem */ TOS = q; } endcase; /* Perform 2 cell by 1 cell divide for 2 cell result and remainder, using shift and subtract. */ case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ { register ucell_t ah,am,al,ql,qh,di; #define bdiv ((ucell_t)TOS) ah = 0; am = M_POP; al = M_POP; qh = ql = 0; for( di=0; di<2*NBITS; di++ ) { if( bdiv <= ah ) { ah = ah - bdiv; ql |= 1; } qh = (qh << 1) | (ql >> (NBITS-1)); ql = ql << 1; ah = (ah << 1) | (am >> (NBITS-1)); am = (am << 1) | (al >> (NBITS-1)); al = al << 1; DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); } if( bdiv <= ah ) { ah = ah - bdiv; ql |= 1; } M_PUSH( ah ); /* rem */ M_PUSH( ql ); TOS = qh; #undef bdiv } endcase; #ifndef PF_NO_SHELL case ID_DEFER: ffDefer( ); endcase; #endif /* !PF_NO_SHELL */ case ID_DEFER_P: endcase; case ID_DEPTH: PUSH_TOS; TOS = gCurrentTask->td_StackBase - STKPTR; endcase; case ID_DIVIDE: BINARY_OP( / ); endcase; case ID_DOT: ffDot( TOS ); M_DROP; endcase; case ID_DOTS: M_DOTS; endcase; case ID_DROP: M_DROP; endcase; case ID_DUMP: Scratch = M_POP; DumpMemory( (char *) Scratch, TOS ); M_DROP; endcase; case ID_DUP: M_DUP; endcase; case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */ M_R_PUSH( TOS ); M_R_PUSH( M_POP ); M_DROP; endcase; case ID_EOL: /* ( -- end_of_line_char ) */ PUSH_TOS; TOS = (cell_t) '\n'; endcase; case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */ Scratch = TOS; M_DROP; if(TOS) { M_THROW(Scratch); } else { M_DROP; } endcase; case ID_EMIT_P: EMIT( (char) TOS ); M_DROP; endcase; case ID_EXECUTE: /* Save IP on return stack like a JSR. */ M_R_PUSH( InsPtr ); #ifdef PF_SUPPORT_TRACE /* Bump level for trace. */ Level++; #endif if( IsTokenPrimitive( TOS ) ) { WRITE_CELL_DIC( (cell_t *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */ InsPtr = &FakeSecondary[0]; } else { InsPtr = (cell_t *) LOCAL_CODEREL_TO_ABS(TOS); } M_DROP; endcase; case ID_FETCH: #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { TOS = (cell_t) READ_CELL_DIC((cell_t *)TOS); } else { TOS = *((cell_t *)TOS); } #else TOS = *((cell_t *)TOS); #endif endcase; case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */ /* Build NUL terminated name string. */ Scratch = M_POP; /* u */ Temp = M_POP; /* caddr */ if( Scratch < TIB_SIZE-2 ) { const char *famText = pfSelectFileModeCreate( TOS ); pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch ); gScratch[Scratch] = '\0'; DBUG(("Create file = %s with famTxt %s\n", gScratch, famText )); FileID = sdOpenFile( gScratch, famText ); TOS = ( FileID == NULL ) ? -1 : 0 ; M_PUSH( (cell_t) FileID ); } else { ERR("Filename too large for name buffer.\n"); M_PUSH( 0 ); TOS = -2; } endcase; case ID_FILE_DELETE: /* ( c-addr u -- ior ) */ /* Build NUL terminated name string. */ Temp = M_POP; /* caddr */ if( TOS < TIB_SIZE-2 ) { pfCopyMemory( gScratch, (char *) Temp, (ucell_t) TOS ); gScratch[TOS] = '\0'; DBUG(("Delete file = %s\n", gScratch )); TOS = sdDeleteFile( gScratch ); } else { ERR("Filename too large for name buffer.\n"); TOS = -2; } endcase; case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */ /* Build NUL terminated name string. */ Scratch = M_POP; /* u */ Temp = M_POP; /* caddr */ if( Scratch < TIB_SIZE-2 ) { const char *famText = pfSelectFileModeOpen( TOS ); pfCopyMemory( gScratch, (char *) Temp, (ucell_t) Scratch ); gScratch[Scratch] = '\0'; DBUG(("Open file = %s\n", gScratch )); FileID = sdOpenFile( gScratch, famText ); TOS = ( FileID == NULL ) ? -1 : 0 ; M_PUSH( (cell_t) FileID ); } else { ERR("Filename too large for name buffer.\n"); M_PUSH( 0 ); TOS = -2; } endcase; case ID_FILE_CLOSE: /* ( fid -- ior ) */ TOS = sdCloseFile( (FileStream *) TOS ); endcase; case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */ FileID = (FileStream *) TOS; 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; { 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_WRITE: /* ( addr len fid -- ior ) */ FileID = (FileStream *) TOS; Scratch = M_POP; CharPtr = (char *) M_POP; Temp = sdWriteFile( CharPtr, 1, Scratch, FileID ); TOS = (Temp != Scratch) ? -3 : 0; endcase; case ID_FILE_REPOSITION: /* ( ud fid -- ior ) */ { file_offset_t offset; cell_t offsetHigh; cell_t offsetLow; FileID = (FileStream *) TOS; 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 ) */ { file_offset_t position; FileID = (FileStream *) TOS; position = sdTellFile( FileID ); 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; case ID_FILE_RO: /* ( -- fam ) */ PUSH_TOS; TOS = PF_FAM_READ_ONLY; endcase; case ID_FILE_RW: /* ( -- fam ) */ PUSH_TOS; TOS = PF_FAM_READ_WRITE; endcase; case ID_FILE_WO: /* ( -- fam ) */ PUSH_TOS; TOS = PF_FAM_WRITE_ONLY; endcase; case ID_FILE_BIN: /* ( fam1 -- fam2 ) */ 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; Temp = M_POP; /* num */ DstPtr = (char *) M_POP; /* dst */ for( Scratch=0; (ucell_t) Scratch < (ucell_t) Temp ; Scratch++ ) { *DstPtr++ = (char) TOS; } M_DROP; } endcase; #ifndef PF_NO_SHELL case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */ TOS = ffFind( (char *) TOS, (ExecToken *) &Temp ); M_PUSH( Temp ); endcase; case ID_FINDNFA: TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp ); M_PUSH( (cell_t) Temp ); endcase; #endif /* !PF_NO_SHELL */ case ID_FLUSHEMIT: sdTerminalFlush(); endcase; /* Validate memory before freeing. Clobber validator and first word. */ case ID_FREE: /* ( addr -- result ) */ if( TOS == 0 ) { ERR("FREE passed NULL!\n"); TOS = -2; /* FIXME error code */ } else { CellPtr = (cell_t *) TOS; CellPtr--; if( ((ucell_t)*CellPtr) != ((ucell_t)CellPtr ^ PF_MEMORY_VALIDATOR)) { TOS = -2; /* FIXME error code */ } else { CellPtr[0] = 0xDeadBeef; pfFreeMem((char *)CellPtr); TOS = 0; } } endcase; #include "pfinnrfp.h" case ID_HERE: PUSH_TOS; TOS = (cell_t)CODE_HERE; endcase; case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */ /* Convert using number converter in 'C'. ** Only supports single precision for bootstrap. */ TOS = (cell_t) ffNumberQ( (char *) TOS, &Temp ); if( TOS == NUM_TYPE_SINGLE) { M_PUSH( Temp ); /* Push single number */ } endcase; case ID_I: /* ( -- i , DO LOOP index ) */ PUSH_TOS; TOS = M_R_PICK(1); endcase; #ifndef PF_NO_SHELL case ID_INCLUDE_FILE: FileID = (FileStream *) TOS; M_DROP; /* Drop now so that INCLUDE has a clean stack. */ SAVE_REGISTERS; Scratch = ffIncludeFile( FileID ); LOAD_REGISTERS; if( Scratch ) M_THROW(Scratch) endcase; #endif /* !PF_NO_SHELL */ #ifndef PF_NO_SHELL case ID_INTERPRET: SAVE_REGISTERS; Scratch = ffInterpret(); LOAD_REGISTERS; if( Scratch ) M_THROW(Scratch) endcase; #endif /* !PF_NO_SHELL */ case ID_J: /* ( -- j , second DO LOOP index ) */ PUSH_TOS; TOS = M_R_PICK(3); endcase; case ID_KEY: PUSH_TOS; TOS = ioKey(); if (TOS == ASCII_EOT) { M_THROW(THROW_BYE); } endcase; #ifndef PF_NO_SHELL case ID_LITERAL: ffLiteral( TOS ); M_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_LITERAL_P: DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr )); PUSH_TOS; TOS = READ_CELL_DIC(InsPtr++); endcase; #ifndef PF_NO_SHELL case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase; #endif /* !PF_NO_SHELL */ case ID_LOCAL_FETCH: /* ( i -- n , fetch from local ) */ TOS = *(LocalsPtr - TOS); endcase; #define LOCAL_FETCH_N(num) \ case ID_LOCAL_FETCH_##num: /* ( -- n , fetch from local ) */ \ PUSH_TOS; \ TOS = *(LocalsPtr -(num)); \ endcase; LOCAL_FETCH_N(1); LOCAL_FETCH_N(2); LOCAL_FETCH_N(3); LOCAL_FETCH_N(4); LOCAL_FETCH_N(5); LOCAL_FETCH_N(6); LOCAL_FETCH_N(7); LOCAL_FETCH_N(8); case ID_LOCAL_STORE: /* ( n i -- , store n in local ) */ *(LocalsPtr - TOS) = M_POP; M_DROP; endcase; #define LOCAL_STORE_N(num) \ case ID_LOCAL_STORE_##num: /* ( n -- , store n in local ) */ \ *(LocalsPtr - (num)) = TOS; \ M_DROP; \ endcase; LOCAL_STORE_N(1); LOCAL_STORE_N(2); LOCAL_STORE_N(3); LOCAL_STORE_N(4); LOCAL_STORE_N(5); LOCAL_STORE_N(6); LOCAL_STORE_N(7); LOCAL_STORE_N(8); case ID_LOCAL_PLUSSTORE: /* ( n i -- , add n to local ) */ *(LocalsPtr - TOS) += M_POP; M_DROP; endcase; case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */ /* create local stack frame */ { cell_t i = TOS; cell_t *lp; DBUG(("LocalEntry: n = %d\n", TOS)); /* End of locals. Create stack frame */ DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); M_R_PUSH(LocalsPtr); LocalsPtr = TORPTR; TORPTR -= TOS; DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); lp = TORPTR; while(i-- > 0) { *lp++ = M_POP; /* Load local vars from stack */ } M_DROP; } endcase; case ID_LOCAL_EXIT: /* cleanup up local stack frame */ DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); TORPTR = LocalsPtr; LocalsPtr = (cell_t *) M_R_POP; DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n", TORPTR, LocalsPtr)); endcase; #ifndef PF_NO_SHELL case ID_LOADSYS: MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR; FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r"); if( FileID ) { SAVE_REGISTERS; Scratch = ffIncludeFile( FileID ); /* Also closes the file. */ LOAD_REGISTERS; if( Scratch ) M_THROW(Scratch); } else { ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n"); } endcase; #endif /* !PF_NO_SHELL */ case ID_LEAVE_P: /* ( R: index limit -- ) */ M_R_DROP; M_R_DROP; M_BRANCH; endcase; case ID_LOOP_P: /* ( R: index limit -- | index limit ) */ Temp = M_R_POP; /* limit */ Scratch = M_R_POP + 1; /* index */ if( Scratch == Temp ) { InsPtr++; /* skip branch offset, exit loop */ } else { /* Push index and limit back to R */ M_R_PUSH( Scratch ); M_R_PUSH( Temp ); /* Branch back to just after (DO) */ M_BRANCH; } endcase; case ID_LSHIFT: BINARY_OP( << ); endcase; case ID_MAX: Scratch = M_POP; TOS = ( TOS > Scratch ) ? TOS : Scratch ; endcase; case ID_MIN: Scratch = M_POP; TOS = ( TOS < Scratch ) ? TOS : Scratch ; endcase; case ID_MINUS: BINARY_OP( - ); endcase; #ifndef PF_NO_SHELL case ID_NAME_TO_TOKEN: TOS = (cell_t) NameToToken((ForthString *)TOS); endcase; case ID_NAME_TO_PREVIOUS: TOS = (cell_t) NameToPrevious((ForthString *)TOS); endcase; #endif case ID_NOOP: endcase; case ID_OR: BINARY_OP( | ); endcase; case ID_OVER: PUSH_TOS; TOS = M_STACK(1); endcase; case ID_PICK: /* ( ... n -- sp(n) ) */ TOS = M_STACK(TOS); endcase; case ID_PLUS: BINARY_OP( + ); endcase; case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { Scratch = READ_CELL_DIC((cell_t *)TOS); Scratch += M_POP; WRITE_CELL_DIC((cell_t *)TOS,Scratch); } else { *((cell_t *)TOS) += M_POP; } #else *((cell_t *)TOS) += M_POP; #endif M_DROP; endcase; case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */ { 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 { /* Push index and limit back to R */ M_R_PUSH( NewIndex ); M_R_PUSH( Limit ); /* Branch back to just after (DO) */ M_BRANCH; } M_DROP; } endcase; case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */ Scratch = M_POP; /* limit */ if( Scratch == TOS ) { /* Branch to just after (LOOP) */ M_BRANCH; } else { M_R_PUSH( TOS ); M_R_PUSH( Scratch ); InsPtr++; /* skip branch offset, enter loop */ } M_DROP; endcase; case ID_QDUP: if( TOS ) M_DUP; endcase; case ID_QTERMINAL: /* WARNING: Typically not fully implemented! */ PUSH_TOS; TOS = sdQueryTerminal(); endcase; case ID_QUIT_P: /* Stop inner interpreter, go back to user. */ #ifdef PF_SUPPORT_TRACE Level = 0; #endif M_THROW(THROW_QUIT); endcase; case ID_R_DROP: M_R_DROP; endcase; case ID_R_FETCH: PUSH_TOS; TOS = (*(TORPTR)); endcase; case ID_R_FROM: PUSH_TOS; TOS = M_R_POP; endcase; case ID_REFILL: PUSH_TOS; TOS = (ffRefill() > 0) ? FTRUE : FFALSE; endcase; /* Resize memory allocated by ALLOCATE. */ case ID_RESIZE: /* ( addr1 u -- addr2 result ) */ { cell_t *Addr1 = (cell_t *) M_POP; /* Point to validator below users address. */ cell_t *FreePtr = Addr1 - 1; if( ((ucell_t)*FreePtr) != ((ucell_t)FreePtr ^ PF_MEMORY_VALIDATOR)) { /* 090218 - Fixed bug, was returning zero. */ M_PUSH( Addr1 ); TOS = -3; } else { /* Try to allocate. */ CellPtr = (cell_t *) pfAllocMem( TOS + sizeof(cell_t) ); if( CellPtr ) { /* Copy memory including validation. */ pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell_t) ); *CellPtr = (cell_t)(((ucell_t)CellPtr) ^ (ucell_t)PF_MEMORY_VALIDATOR); /* 090218 - Fixed bug that was incrementing the address twice. Thanks Reinhold Straub. */ /* Increment past validator to user address. */ M_PUSH( (cell_t) (CellPtr + 1) ); TOS = 0; /* Result code. */ /* Mark old cell as dead so we can't free it twice. */ FreePtr[0] = 0xDeadBeef; pfFreeMem((char *) FreePtr); } else { /* 090218 - Fixed bug, was returning zero. */ M_PUSH( Addr1 ); TOS = -4; /* FIXME Fix error code. */ } } } endcase; /* ** RP@ and RP! are called secondaries so we must ** account for the return address pushed before calling. */ case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */ PUSH_TOS; TOS = (cell_t)TORPTR; /* value before calling RP@ */ endcase; case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */ TORPTR = (cell_t *) TOS; M_DROP; endcase; case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */ { cell_t ri; cell_t *srcPtr, *dstPtr; Scratch = M_STACK(TOS); srcPtr = &M_STACK(TOS-1); dstPtr = &M_STACK(TOS); for( ri=0; ri> TOS; } endcase; #ifndef PF_NO_SHELL case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */ { cell_t NameSize, CodeSize, EntryPoint; CodeSize = TOS; NameSize = M_POP; EntryPoint = M_POP; ForthStringToC( gScratch, (char *) M_POP, sizeof(gScratch) ); TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize ); } endcase; #endif case ID_SLEEP_P: TOS = sdSleepMillis(TOS); endcase; case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */ PUSH_TOS; TOS = (cell_t)STKPTR; endcase; case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */ STKPTR = (cell_t *) TOS; M_DROP; endcase; case ID_STORE: /* ( n addr -- , write n to addr ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { WRITE_CELL_DIC((cell_t *)TOS,M_POP); } else { *((cell_t *)TOS) = M_POP; } #else *((cell_t *)TOS) = M_POP; #endif M_DROP; endcase; case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */ Scratch = M_POP; /* cnt */ Temp = M_POP; /* addr */ TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr ); M_PUSH((cell_t) CharPtr); endcase; #ifndef PF_NO_SHELL case ID_SEMICOLON: SAVE_REGISTERS; Scratch = ffSemiColon(); LOAD_REGISTERS; if( Scratch ) M_THROW( Scratch ); endcase; #endif /* !PF_NO_SHELL */ case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */ Scratch = M_POP; /* cnt */ Temp = M_POP; /* addr */ TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr ); M_PUSH((cell_t) CharPtr); endcase; case ID_SOURCE: /* ( -- c-addr num ) */ PUSH_TOS; M_PUSH( (cell_t) gCurrentTask->td_SourcePtr ); TOS = (cell_t) gCurrentTask->td_SourceNum; endcase; case ID_SOURCE_SET: /* ( c-addr num -- ) */ gCurrentTask->td_SourcePtr = (char *) M_POP; gCurrentTask->td_SourceNum = TOS; M_DROP; endcase; case ID_SOURCE_ID: PUSH_TOS; TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ; endcase; case ID_SOURCE_ID_POP: PUSH_TOS; TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ; endcase; case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */ TOS = (cell_t)ffConvertSourceIDToStream( TOS ); Scratch = ffPushInputStream((FileStream *) TOS ); if( Scratch ) { M_THROW(Scratch); } 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; *STKPTR = Scratch; endcase; case ID_TEST1: PUSH_TOS; M_PUSH( 0x11 ); M_PUSH( 0x22 ); TOS = 0x33; endcase; case ID_TEST2: endcase; case ID_THROW: /* ( k*x err -- k*x | i*x err , jump to where CATCH was called ) */ if(TOS) { M_THROW(TOS); } else M_DROP; endcase; #ifndef PF_NO_SHELL case ID_TICK: PUSH_TOS; CharPtr = (char *) ffWord( (char) ' ' ); TOS = ffFind( CharPtr, (ExecToken *) &Temp ); if( TOS == 0 ) { ERR("' could not find "); ioType( (char *) CharPtr+1, *CharPtr ); EMIT_CR; M_THROW(-13); } else { TOS = Temp; } endcase; #endif /* !PF_NO_SHELL */ case ID_TIMES: BINARY_OP( * ); endcase; case ID_TYPE: Scratch = M_POP; /* addr */ ioType( (char *) Scratch, TOS ); M_DROP; endcase; case ID_TO_R: M_R_PUSH( TOS ); M_DROP; endcase; case ID_VAR_BASE: DO_VAR(gVarBase); endcase; case ID_VAR_BYE_CODE: DO_VAR(gVarByeCode); endcase; case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase; case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase; case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase; case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase; case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase; case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase; case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase; case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr); endcase; case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase; case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase; case ID_VAR_STATE: DO_VAR(gVarState); endcase; case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase; case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase; case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase; case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase; case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase; case ID_VERSION_CODE: M_PUSH( TOS ); TOS = PFORTH_VERSION_CODE; endcase; case ID_WORD: TOS = (cell_t) ffWord( (char) TOS ); endcase; case ID_WORD_FETCH: /* ( waddr -- w ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { TOS = (uint16_t) READ_SHORT_DIC((uint16_t *)TOS); } else { TOS = *((uint16_t *)TOS); } #else TOS = *((uint16_t *)TOS); #endif endcase; case ID_WORD_STORE: /* ( w waddr -- ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_DICS( TOS ) ) { WRITE_SHORT_DIC((uint16_t *)TOS,(uint16_t)M_POP); } else { *((uint16_t *)TOS) = (uint16_t) M_POP; } #else *((uint16_t *)TOS) = (uint16_t) M_POP; #endif M_DROP; endcase; case ID_XOR: BINARY_OP( ^ ); endcase; /* Branch is followed by an offset relative to address of offset. */ case ID_ZERO_BRANCH: DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr )); if( TOS == 0 ) { M_BRANCH; } else { InsPtr++; /* skip over offset */ } M_DROP; DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr )); endcase; default: ERR("pfCatch: Unrecognised token = 0x"); ffDotHex(Token); ERR(" at 0x"); ffDotHex((cell_t) InsPtr); EMIT_CR; InsPtr = 0; endcase; } if(InsPtr) Token = READ_CELL_DIC(InsPtr++); /* Traverse to next token in secondary. */ #ifdef PF_DEBUG M_DOTS; #endif #if 0 if( _CrtCheckMemory() == 0 ) { ERR("_CrtCheckMemory abort: InsPtr = 0x"); ffDotHex((int)InsPtr); ERR("\n"); } #endif } while( (InitialReturnStack - TORPTR) > 0 ); SAVE_REGISTERS; return ExceptionReturnCode; } pforth-2.0.1/csrc/pf_io.c000066400000000000000000000127351435661464300152320ustar00rootroot00000000000000/* @(#) pf_io.c 96/12/23 1.12 */ /*************************************************************** ** I/O subsystem for PForth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 941004 PLB Extracted IO calls from pforth_main.c ***************************************************************/ #include "pf_all.h" /*************************************************************** ** Initialize I/O system. */ void ioInit( void ) { /* System dependant terminal initialization. */ sdTerminalInit(); } void ioTerm( void ) { sdTerminalTerm(); } /*************************************************************** ** Send single character to output stream. */ void ioEmit( char c ) { cell_t Result; Result = sdTerminalOut(c); if( Result < 0 ) EXIT(1); if( gCurrentTask ) { if(c == '\n') { gCurrentTask->td_OUT = 0; sdTerminalFlush(); } else { gCurrentTask->td_OUT++; } } } /*************************************************************** ** Send an entire string.. */ void ioType( const char *s, cell_t n ) { cell_t i; for( i=0; i 0 ) /* Don't go beyond beginning of line. */ { EMIT(BACKSPACE); EMIT(' '); EMIT(BACKSPACE); p--; len--; } break; default: sdTerminalEcho( (char) c ); *p++ = (char) c; len++; break; } } gotline: sdDisableInput(); sdTerminalEcho( SPACE ); /* NUL terminate line to simplify printing when debugging. */ if( len < maxChars ) p[len] = '\0'; return len; } #define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); } /***********************************************************************************/ /*********** File I/O **************************************************************/ /***********************************************************************************/ #ifdef PF_NO_FILEIO /* Provide stubs for standard file I/O */ FileStream *PF_STDIN; FileStream *PF_STDOUT; cell_t sdInputChar( FileStream *stream ) { UNIMPLEMENTED("sdInputChar"); TOUCH(stream); return -1; } FileStream *sdOpenFile( const char *FileName, const char *Mode ) { UNIMPLEMENTED("sdOpenFile"); TOUCH(FileName); TOUCH(Mode); return NULL; } cell_t sdFlushFile( FileStream * Stream ) { TOUCH(Stream); return 0; } cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ) { UNIMPLEMENTED("sdReadFile"); TOUCH(ptr); TOUCH(Size); TOUCH(nItems); TOUCH(Stream); return 0; } cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream ) { UNIMPLEMENTED("sdWriteFile"); TOUCH(ptr); TOUCH(Size); TOUCH(nItems); TOUCH(Stream); return 0; } cell_t sdSeekFile( FileStream * Stream, file_offset_t Position, int32_t Mode ) { UNIMPLEMENTED("sdSeekFile"); TOUCH(Stream); TOUCH(Position); TOUCH(Mode); return 0; } file_offset_t sdTellFile( FileStream * Stream ) { UNIMPLEMENTED("sdTellFile"); TOUCH(Stream); return 0; } cell_t sdCloseFile( FileStream * Stream ) { UNIMPLEMENTED("sdCloseFile"); TOUCH(Stream); return 0; } cell_t sdDeleteFile( const char *FileName ) { UNIMPLEMENTED("sdDeleteFile"); TOUCH(FileName); 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 pforth-2.0.1/csrc/pf_io.h000066400000000000000000000124721435661464300152350ustar00rootroot00000000000000/* @(#) pf_io.h 98/01/26 1.2 */ #ifndef _pf_io_h #define _pf_io_h /*************************************************************** ** Include file for PForth IO ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #include "pf_types.h" #define PF_CHAR_XON (0x11) #define PF_CHAR_XOFF (0x13) #ifdef __cplusplus extern "C" { #endif int sdTerminalOut( char c ); int sdTerminalEcho( char c ); int sdTerminalFlush( void ); int sdTerminalIn( void ); int sdQueryTerminal( void ); void sdTerminalInit( void ); void sdTerminalTerm( void ); cell_t sdSleepMillis( cell_t msec ); #ifdef __cplusplus } #endif void ioInit( void ); void ioTerm( void ); #ifdef PF_NO_CHARIO void sdEnableInput( void ); void sdDisableInput( void ); #else /* PF_NO_CHARIO */ #ifdef PF_USER_CHARIO /* Get user prototypes or macros from include file. ** API must match that defined above for the stubs. */ /* If your sdTerminalIn echos, define PF_KEY_ECHOS. */ #include PF_USER_CHARIO #else #define sdEnableInput() /* sdTerminalOut( PF_CHAR_XON ) */ #define sdDisableInput() /* sdTerminalOut( PF_CHAR_XOFF ) */ #endif #endif /* PF_NO_CHARIO */ /* Define file access modes. */ /* User can #undef and re#define using PF_USER_FILEIO if needed. */ #define PF_FAM_READ_ONLY (0) #define PF_FAM_READ_WRITE (1) #define PF_FAM_WRITE_ONLY (2) #define PF_FAM_BINARY_FLAG (8) #define PF_FAM_CREATE_WO ("w") #define PF_FAM_CREATE_RW ("w+") #define PF_FAM_OPEN_RO ("r") #define PF_FAM_OPEN_RW ("r+") #define PF_FAM_BIN_CREATE_WO ("wb") #define PF_FAM_BIN_CREATE_RW ("wb+") #define PF_FAM_BIN_OPEN_RO ("rb") #define PF_FAM_BIN_OPEN_RW ("rb+") #ifdef PF_NO_FILEIO typedef void FileStream; extern FileStream *PF_STDIN; extern FileStream *PF_STDOUT; #ifdef __cplusplus extern "C" { #endif /* Prototypes for stubs. */ FileStream *sdOpenFile( const char *FileName, const char *Mode ); 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, 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 ); #ifdef __cplusplus } #endif #define PF_SEEK_SET (0) #define PF_SEEK_CUR (1) #define PF_SEEK_END (2) /* ** printf() is only used for debugging purposes. ** It is not required for normal operation. */ #define PRT(x) /* No printf(). */ #else #ifdef PF_USER_FILEIO /* Get user prototypes or macros from include file. ** API must match that defined above for the stubs. */ #include PF_USER_FILEIO #else typedef FILE FileStream; #define sdOpenFile fopen #define sdDeleteFile remove #define sdFlushFile fflush #define sdReadFile fread #define sdWriteFile fwrite /* * 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_STDOUT ((FileStream *) stdout) #define PF_SEEK_SET (SEEK_SET) #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. */ #define PRT(x) { printf x; sdFlushFile(PF_STDOUT); } #endif #endif /* PF_NO_FILEIO */ #ifdef __cplusplus extern "C" { #endif cell_t ioAccept( char *Target, cell_t n1 ); cell_t ioKey( void); void ioEmit( char c ); void ioType( const char *s, cell_t n); #ifdef __cplusplus } #endif #endif /* _pf_io_h */ pforth-2.0.1/csrc/pf_io_none.c000066400000000000000000000027641435661464300162520ustar00rootroot00000000000000/* $Id$ */ /*************************************************************** ** I/O subsystem for PForth when NO CHARACTER I/O is supported. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 941004 PLB Extracted IO calls from pforth_main.c ***************************************************************/ #include "pf_all.h" #ifdef PF_NO_CHARIO int sdTerminalOut( char c ) { TOUCH(c); return 0; } int sdTerminalEcho( char c ) { TOUCH(c); return 0; } int sdTerminalIn( void ) { return -1; } int sdTerminalFlush( void ) { return -1; } void sdTerminalInit( void ) { } void sdTerminalTerm( void ) { } void sdSleepMillis(cell_t /* msec */) { // TODO Call some platform specific sleep function here. return PF_ERR_NOT_SUPPORTED; } #endif pforth-2.0.1/csrc/pf_main.c000066400000000000000000000072141435661464300155430ustar00rootroot00000000000000/* @(#) pf_main.c 98/01/26 1.2 */ /*************************************************************** ** Forth based on 'C' ** ** main() routine that demonstrates how to call PForth as ** a module from 'C' based application. ** Customize this as needed for your application. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #if (defined(PF_NO_STDIO) || defined(PF_EMBEDDED)) #define NULL ((void *) 0) #define ERR(msg) /* { printf msg; } */ #else #include #define ERR(msg) { printf msg; } #endif #include "pforth.h" #ifndef PF_DEFAULT_DICTIONARY #define PF_DEFAULT_DICTIONARY "pforth.dic" #endif #ifdef __MWERKS__ #include #include #endif #ifndef TRUE #define TRUE (1) #define FALSE (0) #endif #ifdef PF_EMBEDDED int main( void ) { char IfInit = 0; const char *DicName = NULL; const char *SourceName = NULL; pfMessage("\npForth Embedded\n"); return pfDoForth( DicName, SourceName, IfInit); } #else int main( int argc, char **argv ) { #ifdef PF_STATIC_DIC const char *DicName = NULL; #else /* PF_STATIC_DIC */ const char *DicName = PF_DEFAULT_DICTIONARY; #endif /* !PF_STATIC_DIC */ const char *SourceName = NULL; char IfInit = FALSE; char *s; cell_t i; ThrowCode Result; /* For Metroworks on Mac */ #ifdef __MWERKS__ argc = ccommand(&argv); #endif pfSetQuiet( FALSE ); /* Parse command line. */ for( i=1; idlln_Previous) #define dllNextNode(n) ((n)->dlln_Next) void dllSetupList( DoublyLinkedList *dll ) { dll->dll_First = &(dll->dll_Null); dll->dll_Null = (DoublyLinkedListNode *) NULL; dll->dll_Last = &(dll->dll_First); } void dllLinkNodes( DoublyLinkedListNode *Node0, DoublyLinkedListNode *Node1 ) { Node0->dlln_Next = Node1; Node1->dlln_Previous = Node0; } void dllInsertNodeBefore( DoublyLinkedListNode *NewNodePtr, DoublyLinkedListNode *NodeInListPtr ) { DoublyLinkedListNode *NodePreviousPtr = dllPreviousNode( NodeInListPtr ); dllLinkNodes( NodePreviousPtr, NewNodePtr ); dllLinkNodes( NewNodePtr, NodeInListPtr ); } void dllInsertNodeAfter( DoublyLinkedListNode *NewNodePtr, DoublyLinkedListNode *NodeInListPtr ) { DoublyLinkedListNode *NodeNextPtr = dllNextNode( NodeInListPtr ); dllLinkNodes( NodeInListPtr, NewNodePtr ); dllLinkNodes( NewNodePtr, NodeNextPtr ); } void dllDumpNode( DoublyLinkedListNode *NodePtr ) { TOUCH(NodePtr); DBUG((" 0x%x -> (0x%x) -> 0x%x\n", dllPreviousNode( NodePtr ), NodePtr, dllNextNode( NodePtr ) )); } cell_t dllCheckNode( DoublyLinkedListNode *NodePtr ) { if( (NodePtr->dlln_Next->dlln_Previous != NodePtr) || (NodePtr->dlln_Previous->dlln_Next != NodePtr)) { ERR("dllCheckNode: Bad Node!\n"); dllDumpNode( dllPreviousNode( NodePtr ) ); dllDumpNode( NodePtr ); dllDumpNode( dllNextNode( NodePtr ) ); return -1; } else { return 0; } } void dllRemoveNode( DoublyLinkedListNode *NodePtr ) { if( dllCheckNode( NodePtr ) == 0 ) { dllLinkNodes( dllPreviousNode( NodePtr ), dllNextNode( NodePtr ) ); } } void dllAddNodeToHead( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr ) { dllInsertNodeBefore( NewNodePtr, ListPtr->dll_First ); } void dllAddNodeToTail( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr ) { dllInsertNodeAfter( NewNodePtr, ListPtr->dll_Last ); } #define dllIsNodeInList( n ) (!((n)->dlln_Next == NULL) ) #define dllIsLastNode( n ) ((n)->dlln_Next->dll_nNext == NULL ) #define dllIsListEmpty( l ) ((l)->dll_First == ((DoublyLinkedListNode *) &((l)->dll_Null)) ) #define dllFirstNode( l ) ((l)->dll_First) static DoublyLinkedList gMemList; typedef struct MemListNode { DoublyLinkedListNode mln_Node; cell_t mln_Size; } MemListNode; #ifdef PF_DEBUG /*************************************************************** ** Dump memory list. */ void maDumpList( void ) { MemListNode *mln; MSG("PForth MemList\n"); for( mln = (MemListNode *) dllFirstNode( &gMemList ); dllIsNodeInList( (DoublyLinkedListNode *) mln); mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) { MSG(" Node at = 0x"); ffDotHex(mln); MSG_NUM_H(", size = 0x", mln->mln_Size); } } #endif /*************************************************************** ** Free mem of any size. */ static void pfFreeRawMem( char *Mem, cell_t NumBytes ) { MemListNode *mln, *FreeNode; MemListNode *AdjacentLower = NULL; MemListNode *AdjacentHigher = NULL; MemListNode *NextBiggest = NULL; /* Allocate in whole blocks of 16 bytes */ DBUG(("\npfFreeRawMem( 0x%x, 0x%x )\n", Mem, NumBytes )); NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1); DBUG(("\npfFreeRawMem: Align NumBytes to 0x%x\n", NumBytes )); /* Check memory alignment. */ if( ( ((cell_t)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0) { MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (cell_t) Mem ); return; } /* Scan list from low to high looking for various nodes. */ for( mln = (MemListNode *) dllFirstNode( &gMemList ); dllIsNodeInList( (DoublyLinkedListNode *) mln); mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) { if( (((char *) mln) + mln->mln_Size) == Mem ) { AdjacentLower = mln; } else if( ((char *) mln) == ( Mem + NumBytes )) { AdjacentHigher = mln; } /* is this the next biggest node. */ else if( (NextBiggest == NULL) && (mln->mln_Size >= NumBytes) ) { NextBiggest = mln; } } /* Check to see if we can merge nodes. */ if( AdjacentHigher ) { DBUG((" Merge (0x%x) -> 0x%x\n", Mem, AdjacentHigher )); NumBytes += AdjacentHigher->mln_Size; dllRemoveNode( (DoublyLinkedListNode *) AdjacentHigher ); } if( AdjacentLower ) { DBUG((" Merge 0x%x -> (0x%x)\n", AdjacentLower, Mem )); AdjacentLower->mln_Size += NumBytes; } else { DBUG((" Link before 0x%x\n", NextBiggest )); FreeNode = (MemListNode *) Mem; FreeNode->mln_Size = NumBytes; if( NextBiggest == NULL ) { /* Nothing bigger so add to end of list. */ dllAddNodeToTail( &gMemList, (DoublyLinkedListNode *) FreeNode ); } else { /* Add this node before the next biggest one we found. */ dllInsertNodeBefore( (DoublyLinkedListNode *) FreeNode, (DoublyLinkedListNode *) NextBiggest ); } } /* maDumpList(); */ } /*************************************************************** ** Setup memory list. Initialize allocator. */ static void pfInitMemBlock( void *addr, ucell_t poolSize ) { char *AlignedMemory; cell_t AlignedSize; pfDebugMessage("pfInitMemBlock()\n"); /* Set globals. */ gMemPoolPtr = addr; gMemPoolSize = poolSize; dllSetupList( &gMemList ); /* Adjust to next highest aligned memory location. */ AlignedMemory = (char *) ((((cell_t)gMemPoolPtr) + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1)); /* Adjust size to reflect aligned memory. */ AlignedSize = gMemPoolSize - (AlignedMemory - gMemPoolPtr); /* Align size of pool. */ AlignedSize = AlignedSize & ~(PF_MEM_BLOCK_SIZE - 1); /* Free to pool. */ pfFreeRawMem( AlignedMemory, AlignedSize ); } /*************************************************************** ** Allocate mem from list of free nodes. */ static char *pfAllocRawMem( cell_t NumBytes ) { char *Mem = NULL; MemListNode *mln; pfDebugMessage("pfAllocRawMem()\n"); if( NumBytes <= 0 ) return NULL; /* Allocate in whole blocks of 16 bytes */ NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1); DBUG(("\npfAllocRawMem( 0x%x )\n", NumBytes )); /* Scan list from low to high until we find a node big enough. */ for( mln = (MemListNode *) dllFirstNode( &gMemList ); dllIsNodeInList( (DoublyLinkedListNode *) mln); mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) { if( mln->mln_Size >= NumBytes ) { cell_t RemSize; Mem = (char *) mln; /* Remove this node from list. */ dllRemoveNode( (DoublyLinkedListNode *) mln ); /* Is there enough left in block to make it worth splitting? */ RemSize = mln->mln_Size - NumBytes; if( RemSize >= PF_MEM_BLOCK_SIZE ) { pfFreeRawMem( (Mem + NumBytes), RemSize ); } break; } } /* maDumpList(); */ DBUG(("Allocate mem at 0x%x.\n", Mem )); return Mem; } /*************************************************************** ** Keep mem size at first cell. */ char *pfAllocMem( cell_t NumBytes ) { cell_t *IntMem; if( NumBytes <= 0 ) return NULL; /* Allocate an extra cell for size. */ NumBytes += sizeof(cell_t); IntMem = (cell_t *)pfAllocRawMem( NumBytes ); if( IntMem != NULL ) *IntMem++ = NumBytes; return (char *) IntMem; } /*************************************************************** ** Free mem with mem size at first cell. */ void pfFreeMem( void *Mem ) { cell_t *IntMem; cell_t NumBytes; if( Mem == NULL ) return; /* Allocate an extra cell for size. */ IntMem = (cell_t *) Mem; IntMem--; NumBytes = *IntMem; pfFreeRawMem( (char *) IntMem, NumBytes ); } void pfInitMemoryAllocator( void ) { pfInitMemBlock( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE ); } #else /* PF_NO_MALLOC */ int not_an_empty_file; /* Stops nasty compiler warnings when PF_NO_MALLOC not defined. */ #endif /* PF_NO_MALLOC */ pforth-2.0.1/csrc/pf_mem.h000066400000000000000000000030321435661464300153740ustar00rootroot00000000000000/* @(#) pf_mem.h 98/01/26 1.3 */ #ifndef _pf_mem_h #define _pf_mem_h /*************************************************************** ** Include file for PForth Fake Memory Allocator ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ***************************************************************/ #ifdef PF_NO_MALLOC #ifdef __cplusplus extern "C" { #endif void pfInitMemoryAllocator( void ); char *pfAllocMem( cell_t NumBytes ); void pfFreeMem( void *Mem ); #ifdef __cplusplus } #endif #else #ifdef PF_USER_MALLOC /* Get user prototypes or macros from include file. ** API must match that defined above for the stubs. */ #include PF_USER_MALLOC #else #define pfInitMemoryAllocator() #define pfAllocMem malloc #define pfFreeMem free #endif #endif /* PF_NO_MALLOC */ #endif /* _pf_mem_h */ pforth-2.0.1/csrc/pf_save.c000066400000000000000000000604041435661464300155550ustar00rootroot00000000000000/* @(#) pf_save.c 98/01/26 1.3 */ /*************************************************************** ** Save and Load Dictionary ** for PForth based on 'C' ** ** Compile file based version or static data based version ** depending on PF_NO_FILEIO switch. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 940225 PLB Fixed CodePtr save, was using NAMEREL instead of CODEREL ** This would only work if the relative location ** of names and code was the same when saved and reloaded. ** 940228 PLB Added PF_NO_FILEIO version ** 961204 PLB Added PF_STATIC_DIC ** 000623 PLB Cast chars as ucell_t before shifting for 16 bit systems. ***************************************************************/ #include #include "pf_all.h" /* If no File I/O, then force static dictionary. */ #ifdef PF_NO_FILEIO #ifndef PF_STATIC_DIC #define PF_STATIC_DIC #endif #endif #ifdef PF_STATIC_DIC #include "pfdicdat.h" #endif /* Dictionary File Format based on IFF standard. The chunk IDs, sizes, and data values are all Big Endian in conformance with the IFF standard. The dictionaries may be big or little endian. 'FORM' size 'P4TH' - Form Identifier Chunks 'P4DI' size struct DictionaryInfoChunk 'P4NM' size Name and Header portion of dictionary. (Big or Little Endian) (Optional) 'P4CD' size Code portion of dictionary. (Big or Little Endian) */ /***************************************************************/ /* Endian-ness tools. */ ucell_t ReadCellBigEndian( const uint8_t *addr ) { ucell_t temp = (ucell_t)addr[0]; temp = (temp << 8) | ((ucell_t)addr[1]); temp = (temp << 8) | ((ucell_t)addr[2]); temp = (temp << 8) | ((ucell_t)addr[3]); if( sizeof(ucell_t) == 8 ) { temp = (temp << 8) | ((ucell_t)addr[4]); temp = (temp << 8) | ((ucell_t)addr[5]); temp = (temp << 8) | ((ucell_t)addr[6]); temp = (temp << 8) | ((ucell_t)addr[7]); } return temp; } /***************************************************************/ /* Endian-ness tools. */ uint32_t Read32BigEndian( const uint8_t *addr ) { uint32_t temp = (uint32_t)addr[0]; temp = (temp << 8) | ((uint32_t)addr[1]); temp = (temp << 8) | ((uint32_t)addr[2]); temp = (temp << 8) | ((uint32_t)addr[3]); return temp; } /***************************************************************/ uint16_t Read16BigEndian( const uint8_t *addr ) { return (uint16_t) ((addr[0]<<8) | addr[1]); } /***************************************************************/ ucell_t ReadCellLittleEndian( const uint8_t *addr ) { ucell_t temp = 0; if( sizeof(ucell_t) == 8 ) { temp = (temp << 8) | ((uint32_t)addr[7]); temp = (temp << 8) | ((uint32_t)addr[6]); temp = (temp << 8) | ((uint32_t)addr[5]); temp = (temp << 8) | ((uint32_t)addr[4]); } temp = (temp << 8) | ((uint32_t)addr[3]); temp = (temp << 8) | ((uint32_t)addr[2]); temp = (temp << 8) | ((uint32_t)addr[1]); temp = (temp << 8) | ((uint32_t)addr[0]); return temp; } /***************************************************************/ uint32_t Read32LittleEndian( const uint8_t *addr ) { uint32_t temp = (uint32_t)addr[3]; temp = (temp << 8) | ((uint32_t)addr[2]); temp = (temp << 8) | ((uint32_t)addr[1]); temp = (temp << 8) | ((uint32_t)addr[0]); return temp; } /***************************************************************/ uint16_t Read16LittleEndian( const uint8_t *addr ) { const unsigned char *bp = (const unsigned char *) addr; return (uint16_t) ((bp[1]<<8) | bp[0]); } #ifdef PF_SUPPORT_FP /***************************************************************/ static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst ); static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst ) { int i; unsigned char *d = (unsigned char *) dst; const unsigned char *s = (const unsigned char *) src; for( i=0; i>56); *addr++ = (uint8_t) (data>>48); *addr++ = (uint8_t) (data>>40); *addr++ = (uint8_t) (data>>32); } *addr++ = (uint8_t) (data>>24); *addr++ = (uint8_t) (data>>16); *addr++ = (uint8_t) (data>>8); *addr = (uint8_t) (data); } /***************************************************************/ void Write32BigEndian( uint8_t *addr, uint32_t data ) { *addr++ = (uint8_t) (data>>24); *addr++ = (uint8_t) (data>>16); *addr++ = (uint8_t) (data>>8); *addr = (uint8_t) (data); } /***************************************************************/ void Write16BigEndian( uint8_t *addr, uint16_t data ) { *addr++ = (uint8_t) (data>>8); *addr = (uint8_t) (data); } /***************************************************************/ void WriteCellLittleEndian( uint8_t *addr, ucell_t data ) { /* Write should be in order of increasing address * to optimize for burst writes to DRAM. */ if( sizeof(ucell_t) == 8 ) { *addr++ = (uint8_t) data; /* LSB at near end */ data = data >> 8; *addr++ = (uint8_t) data; data = data >> 8; *addr++ = (uint8_t) data; data = data >> 8; *addr++ = (uint8_t) data; data = data >> 8; } *addr++ = (uint8_t) data; data = data >> 8; *addr++ = (uint8_t) data; data = data >> 8; *addr++ = (uint8_t) data; data = data >> 8; *addr = (uint8_t) data; } /***************************************************************/ void Write32LittleEndian( uint8_t *addr, uint32_t data ) { *addr++ = (uint8_t) data; data = data >> 8; *addr++ = (uint8_t) data; data = data >> 8; *addr++ = (uint8_t) data; data = data >> 8; *addr = (uint8_t) data; } /***************************************************************/ void Write16LittleEndian( uint8_t *addr, uint16_t data ) { *addr++ = (uint8_t) data; data = data >> 8; *addr = (uint8_t) data; } /***************************************************************/ /* Return 1 if host CPU is Little Endian */ int IsHostLittleEndian( void ) { static int gEndianCheck = 1; unsigned char *bp = (unsigned char *) &gEndianCheck; return (int) (*bp); /* Return byte pointed to by address. If LSB then == 1 */ } #if defined(PF_NO_FILEIO) || defined(PF_NO_SHELL) cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize) { TOUCH(FileName); TOUCH(EntryPoint); TOUCH(NameSize); TOUCH(CodeSize); pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED); return -1; } #else /* PF_NO_FILEIO or PF_NO_SHELL */ /***************************************************************/ static int Write32ToFile( FileStream *fid, uint32_t Val ) { size_t numw; uint8_t pad[4]; Write32BigEndian(pad,Val); numw = sdWriteFile( pad, 1, sizeof(pad), fid ); if( numw != sizeof(pad) ) return -1; return 0; } /***************************************************************/ static cell_t WriteChunkToFile( FileStream *fid, cell_t ID, char *Data, int32_t NumBytes ) { cell_t numw; cell_t EvenNumW; 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 ); if( numw != EvenNumW ) goto error; return 0; error: pfReportError("WriteChunkToFile", PF_ERR_WRITE_FILE); return -1; } /* Convert dictionary info chunk between native and on-disk (big-endian). */ static void convertDictionaryInfoWrite (DictionaryInfoChunk *sd) { /* Convert all fields in DictionaryInfoChunk from Native to BigEndian. * This assumes they are all 32-bit integers. */ int i; uint32_t *p = (uint32_t *) sd; for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++) { Write32BigEndian( (uint8_t *)&p[i], p[i] ); } } static void convertDictionaryInfoRead (DictionaryInfoChunk *sd) { /* Convert all fields in structure from BigEndian to Native. */ int i; uint32_t *p = (uint32_t *) sd; for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++) { p[i] = Read32BigEndian( (uint8_t *)&p[i] ); } } /**************************************************************** ** Save Dictionary in File. ** If EntryPoint is NULL, save as development environment. ** If EntryPoint is non-NULL, save as turnKey environment with no names. */ cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize) { FileStream *fid; DictionaryInfoChunk SD; uint32_t FormSize; uint32_t NameChunkSize = 0; uint32_t CodeChunkSize; uint32_t relativeCodePtr; fid = sdOpenFile( FileName, "wb" ); if( fid == NULL ) { pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE); return -1; } /* Save in uninitialized form. */ pfExecIfDefined("AUTO.TERM"); /* Write FORM Header ---------------------------- */ if( Write32ToFile( fid, ID_FORM ) < 0 ) goto error; if( Write32ToFile( fid, 0 ) < 0 ) goto error; if( Write32ToFile( fid, ID_P4TH ) < 0 ) goto error; /* Write P4DI Dictionary Info ------------------ */ SD.sd_Version = PF_FILE_VERSION; relativeCodePtr = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */ SD.sd_RelCodePtr = relativeCodePtr; SD.sd_UserStackSize = sizeof(cell_t) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit); SD.sd_ReturnStackSize = sizeof(cell_t) * (gCurrentTask->td_ReturnBase - gCurrentTask->td_ReturnLimit); SD.sd_NumPrimitives = gNumPrimitives; /* Must match compiled dictionary. */ #ifdef PF_SUPPORT_FP SD.sd_FloatSize = sizeof(PF_FLOAT); /* Must match compiled dictionary. */ #else SD.sd_FloatSize = 0; #endif SD.sd_CellSize = sizeof(cell_t); /* Set bit that specifies whether dictionary is BIG or LITTLE Endian. */ { #if defined(PF_BIG_ENDIAN_DIC) int eflag = SD_F_BIG_ENDIAN_DIC; #elif defined(PF_LITTLE_ENDIAN_DIC) int eflag = 0; #else int eflag = IsHostLittleEndian() ? 0 : SD_F_BIG_ENDIAN_DIC; #endif SD.sd_Flags = eflag; } if( EntryPoint ) { SD.sd_EntryPoint = EntryPoint; /* Turnkey! */ } else { SD.sd_EntryPoint = 0; } /* Do we save names? */ if( NameSize == 0 ) { SD.sd_RelContext = 0; SD.sd_RelHeaderPtr = 0; SD.sd_NameSize = 0; } else { uint32_t relativeHeaderPtr; /* Development mode. */ SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext); relativeHeaderPtr = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr); SD.sd_RelHeaderPtr = relativeHeaderPtr; /* How much real name space is there? */ NameChunkSize = QUADUP(relativeHeaderPtr); /* Align */ /* NameSize must be 0 or greater than NameChunkSize + 1K */ NameSize = QUADUP(NameSize); /* Align */ if( NameSize > 0 ) { 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( (ucell_t)CodeSize, (CodeChunkSize + 2048) ); SD.sd_CodeSize = CodeSize; convertDictionaryInfoWrite (&SD); if( WriteChunkToFile( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error; /* Write Name Fields if NameSize non-zero ------- */ if( NameSize > 0 ) { if( WriteChunkToFile( fid, ID_P4NM, (char *) NAME_BASE, NameChunkSize ) < 0 ) goto error; } /* Write Code Fields ---------------------------- */ if( WriteChunkToFile( fid, ID_P4CD, (char *) CODE_BASE, CodeChunkSize ) < 0 ) goto error; FormSize = (uint32_t) sdTellFile( fid ) - 8; sdSeekFile( fid, 4, PF_SEEK_SET ); if( Write32ToFile( fid, FormSize ) < 0 ) goto error; sdCloseFile( fid ); /* Restore initialization. */ pfExecIfDefined("AUTO.INIT"); return 0; error: sdSeekFile( fid, 0, PF_SEEK_SET ); Write32ToFile( fid, ID_BADF ); /* Mark file as bad. */ sdCloseFile( fid ); /* Restore initialization. */ pfExecIfDefined("AUTO.INIT"); return -1; } #endif /* !PF_NO_FILEIO and !PF_NO_SHELL */ #ifndef PF_NO_FILEIO /***************************************************************/ static int32_t Read32FromFile( FileStream *fid, uint32_t *ValPtr ) { cell_t numr; uint8_t pad[4]; numr = sdReadFile( pad, 1, sizeof(pad), fid ); if( numr != sizeof(pad) ) return -1; *ValPtr = Read32BigEndian( pad ); return 0; } /***************************************************************/ PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) { pfDictionary_t *dic = NULL; FileStream *fid; DictionaryInfoChunk *sd; uint32_t ChunkID; uint32_t ChunkSize; uint32_t FormSize; uint32_t BytesLeft; cell_t numr; int isDicBigEndian; DBUG(("pfLoadDictionary( %s )\n", FileName )); /* Open file. */ fid = sdOpenFile( FileName, "rb" ); if( fid == NULL ) { pfReportError("pfLoadDictionary", PF_ERR_OPEN_FILE); goto xt_error; } /* Read FORM, Size, ID */ if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error; if( ChunkID != ID_FORM ) { pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE); goto error; } if (Read32FromFile( fid, &FormSize ) < 0) goto read_error; BytesLeft = FormSize; if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error; BytesLeft -= 4; if( ChunkID != ID_P4TH ) { pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE); goto error; } /* Scan and parse all chunks in file. */ while( BytesLeft > 0 ) { if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error; if (Read32FromFile( fid, &ChunkSize ) < 0) goto read_error; BytesLeft -= 8; DBUG(("ChunkID = %4s, Size = %d\n", (char *)&ChunkID, ChunkSize )); switch( ChunkID ) { case ID_P4DI: sd = (DictionaryInfoChunk *) pfAllocMem( ChunkSize ); if( sd == NULL ) goto nomem_error; numr = sdReadFile( sd, 1, ChunkSize, fid ); if( numr != ChunkSize ) goto read_error; BytesLeft -= ChunkSize; convertDictionaryInfoRead (sd); isDicBigEndian = sd->sd_Flags & SD_F_BIG_ENDIAN_DIC; if( !gVarQuiet ) { MSG("pForth loading dictionary from file "); MSG(FileName); EMIT_CR; MSG_NUM_D(" File format version is ", sd->sd_Version ); MSG_NUM_D(" Name space size = ", sd->sd_NameSize ); MSG_NUM_D(" Code space size = ", sd->sd_CodeSize ); MSG_NUM_D(" Entry Point = ", sd->sd_EntryPoint ); MSG_NUM_D(" Cell Size = ", sd->sd_CellSize ); MSG( (isDicBigEndian ? " Big Endian Dictionary" : " Little Endian Dictionary") ); if( isDicBigEndian == IsHostLittleEndian() ) MSG(" !!!!"); EMIT_CR; } if( sd->sd_Version > PF_FILE_VERSION ) { pfReportError("pfLoadDictionary", PF_ERR_VERSION_FUTURE ); goto error; } if( sd->sd_Version < PF_EARLIEST_FILE_VERSION ) { pfReportError("pfLoadDictionary", PF_ERR_VERSION_PAST ); goto error; } if( sd->sd_CellSize != sizeof(cell_t) ) { pfReportError("pfLoadDictionary", PF_ERR_CELL_SIZE_CONFLICT ); goto error; } if( sd->sd_NumPrimitives > NUM_PRIMITIVES ) { pfReportError("pfLoadDictionary", PF_ERR_NOT_SUPPORTED ); goto error; } /* Check to make sure that EndianNess of dictionary matches mode of pForth. */ #if defined(PF_BIG_ENDIAN_DIC) if(isDicBigEndian == 0) #elif defined(PF_LITTLE_ENDIAN_DIC) if(isDicBigEndian == 1) #else if( isDicBigEndian == IsHostLittleEndian() ) #endif { pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT ); goto error; } /* Check for compatible float size. */ #ifdef PF_SUPPORT_FP if( sd->sd_FloatSize != sizeof(PF_FLOAT) ) #else if( sd->sd_FloatSize != 0 ) #endif { pfReportError("pfLoadDictionary", PF_ERR_FLOAT_CONFLICT ); goto error; } dic = pfCreateDictionary( sd->sd_NameSize, sd->sd_CodeSize ); if( dic == NULL ) goto nomem_error; gCurrentDictionary = dic; if( sd->sd_NameSize > 0 ) { gVarContext = NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */ gCurrentDictionary->dic_HeaderPtr = (ucell_t)(uint8_t *) NAMEREL_TO_ABS(sd->sd_RelHeaderPtr); } else { gVarContext = 0; gCurrentDictionary->dic_HeaderPtr = (ucell_t)NULL; } gCurrentDictionary->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(sd->sd_RelCodePtr); gNumPrimitives = sd->sd_NumPrimitives; /* Must match compiled dictionary. */ /* Pass EntryPoint back to caller. */ if( EntryPointPtr != NULL ) *EntryPointPtr = sd->sd_EntryPoint; pfFreeMem(sd); break; case ID_P4NM: #ifdef PF_NO_SHELL pfReportError("pfLoadDictionary", PF_ERR_NO_SHELL ); goto error; #else if( NAME_BASE == 0 ) { pfReportError("pfLoadDictionary", PF_ERR_NO_NAMES ); goto error; } if( gCurrentDictionary == NULL ) { pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); goto error; } if( ChunkSize > NAME_SIZE ) { pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG); goto error; } numr = sdReadFile( (char *) NAME_BASE, 1, ChunkSize, fid ); if( numr != ChunkSize ) goto read_error; BytesLeft -= ChunkSize; #endif /* PF_NO_SHELL */ break; case ID_P4CD: if( gCurrentDictionary == NULL ) { pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); goto error; } if( ChunkSize > CODE_SIZE ) { pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG); goto error; } numr = sdReadFile( (uint8_t *) CODE_BASE, 1, ChunkSize, fid ); if( numr != ChunkSize ) goto read_error; BytesLeft -= ChunkSize; break; default: pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); sdSeekFile( fid, ChunkSize, PF_SEEK_CUR ); break; } } sdCloseFile( fid ); if( NAME_BASE != 0) { cell_t Result; /* Find special words in dictionary for global XTs. */ if( (Result = FindSpecialXTs()) < 0 ) { pfReportError("pfLoadDictionary: FindSpecialXTs", (Err)Result); goto error; } } DBUG(("pfLoadDictionary: return %p\n", dic)); return (PForthDictionary) dic; nomem_error: pfReportError("pfLoadDictionary", PF_ERR_NO_MEM); sdCloseFile( fid ); return NULL; read_error: pfReportError("pfLoadDictionary", PF_ERR_READ_FILE); error: sdCloseFile( fid ); xt_error: return NULL; } #else PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) { (void) FileName; (void) EntryPointPtr; return NULL; } #endif /* !PF_NO_FILEIO */ /***************************************************************/ PForthDictionary pfLoadStaticDictionary( void ) { #ifdef PF_STATIC_DIC cell_t Result; pfDictionary_t *dic; cell_t NewNameSize, NewCodeSize; if( IF_LITTLE_ENDIAN != IsHostLittleEndian() ) { MSG( (IF_LITTLE_ENDIAN ? "Little Endian Dictionary on " : "Big Endian Dictionary on ") ); MSG( (IsHostLittleEndian() ? "Little Endian CPU" : "Big Endian CPU") ); EMIT_CR; } /* Check to make sure that EndianNess of dictionary matches mode of pForth. */ #if defined(PF_BIG_ENDIAN_DIC) if(IF_LITTLE_ENDIAN == 1) #elif defined(PF_LITTLE_ENDIAN_DIC) if(IF_LITTLE_ENDIAN == 0) #else /* Code is native endian! */ if( IF_LITTLE_ENDIAN != IsHostLittleEndian() ) #endif { pfReportError("pfLoadStaticDictionary", PF_ERR_ENDIAN_CONFLICT ); goto error; } #ifndef PF_EXTRA_HEADERS #define PF_EXTRA_HEADERS (20000) #endif #ifndef PF_EXTRA_CODE #define PF_EXTRA_CODE (40000) #endif /* Copy static const data to allocated dictionaries. */ NewNameSize = sizeof(MinDicNames) + PF_EXTRA_HEADERS; NewCodeSize = sizeof(MinDicCode) + PF_EXTRA_CODE; DBUG_NUM_D( "static dic name size = ", NewNameSize ); DBUG_NUM_D( "static dic code size = ", NewCodeSize ); gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize ); if( !dic ) goto nomem_error; pfCopyMemory( (uint8_t *) dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) ); pfCopyMemory( (uint8_t *) dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) ); DBUG(("Static data copied to newly allocated dictionaries.\n")); dic->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(CODEPTR); gNumPrimitives = NUM_PRIMITIVES; if( NAME_BASE != 0) { /* Setup name space. */ dic->dic_HeaderPtr = (ucell_t)(uint8_t *) NAMEREL_TO_ABS(HEADERPTR); gVarContext = NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */ /* Find special words in dictionary for global XTs. */ if( (Result = FindSpecialXTs()) < 0 ) { pfReportError("pfLoadStaticDictionary: FindSpecialXTs", Result); goto error; } } return (PForthDictionary) dic; error: return NULL; nomem_error: pfReportError("pfLoadStaticDictionary", PF_ERR_NO_MEM); #endif /* PF_STATIC_DIC */ return NULL; } pforth-2.0.1/csrc/pf_save.h000066400000000000000000000073001435661464300155560ustar00rootroot00000000000000/* @(#) pf_save.h 96/12/18 1.8 */ #ifndef _pforth_save_h #define _pforth_save_h /*************************************************************** ** Include file for PForth SaveForth ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ** 941031 rdg fix redefinition of MAKE_ID and EVENUP to be conditional ** ***************************************************************/ typedef struct DictionaryInfoChunk { /* All fields are stored in BIG ENDIAN format for consistency in data files. * All fields must be the same size for easy endian conversion. * All fields must be 32 bit for file compatibility with older versions. */ int32_t sd_Version; int32_t sd_RelContext; /* relative ptr to Dictionary Context */ int32_t sd_RelHeaderPtr; /* relative ptr to Dictionary Header Ptr */ int32_t sd_RelCodePtr; /* relative ptr to Dictionary Header Ptr */ int32_t sd_EntryPoint; /* relative ptr to entry point or NULL */ int32_t sd_UserStackSize; /* in bytes */ int32_t sd_ReturnStackSize; /* in bytes */ int32_t sd_NameSize; /* in bytes */ int32_t sd_CodeSize; /* in bytes */ int32_t sd_NumPrimitives; /* To distinguish between primitive and secondary. */ uint32_t sd_Flags; int32_t sd_FloatSize; /* In bytes. Must match code. 0 means no floats. */ int32_t sd_CellSize; /* In bytes. Must match code. */ } DictionaryInfoChunk; /* Bits in sd_Flags */ #define SD_F_BIG_ENDIAN_DIC (1<<0) #ifndef MAKE_ID #define MAKE_ID(a,b,c,d) ((((uint32_t)a)<<24)|(((uint32_t)b)<<16)|(((uint32_t)c)<<8)|((uint32_t)d)) #endif #define ID_FORM MAKE_ID('F','O','R','M') #define ID_P4TH MAKE_ID('P','4','T','H') #define ID_P4DI MAKE_ID('P','4','D','I') #define ID_P4NM MAKE_ID('P','4','N','M') #define ID_P4CD MAKE_ID('P','4','C','D') #define ID_BADF MAKE_ID('B','A','D','F') #ifndef EVENUP #define EVENUP(n) ((n+1)&(~1)) #endif #ifdef __cplusplus extern "C" { #endif cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize ); /* Endian-ness tools. */ int IsHostLittleEndian( void ); ucell_t ReadCellBigEndian( const uint8_t *addr ); uint32_t Read32BigEndian( const uint8_t *addr ); uint16_t Read16BigEndian( const uint8_t *addr ); ucell_t ReadCellLittleEndian( const uint8_t *addr ); uint32_t Read32LittleEndian( const uint8_t *addr ); uint16_t Read16LittleEndian( const uint8_t *addr ); void WriteCellBigEndian( uint8_t *addr, ucell_t data ); void Write32BigEndian( uint8_t *addr, uint32_t data ); void Write16BigEndian( uint8_t *addr, uint16_t data ); void WriteCellLittleEndian( uint8_t *addr, ucell_t data ); void Write32LittleEndian( uint8_t *addr, uint32_t data ); void Write16LittleEndian( uint8_t *addr, uint16_t data ); #ifdef PF_SUPPORT_FP void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data ); PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr ); void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data ); PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr ); #endif #ifdef __cplusplus } #endif #endif /* _pforth_save_h */ pforth-2.0.1/csrc/pf_text.c000066400000000000000000000257111435661464300156050ustar00rootroot00000000000000/* @(#) pf_text.c 98/01/26 1.3 */ /*************************************************************** ** Text Strings for Error Messages ** Various Text tools. ** ** For PForth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 19970702 PLB Fixed ConvertNumberToText for unsigned numbers. ** 19980522 PLB Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash. ***************************************************************/ #include "pf_all.h" #define PF_ENGLISH /* ** Define array of error messages. ** These are defined in one place to make it easier to translate them. */ #ifdef PF_ENGLISH /***************************************************************/ void pfReportError( const char *FunctionName, Err ErrCode ) { const char *s; MSG("Error in "); MSG(FunctionName); MSG(" - "); switch(ErrCode & 0xFF) { case PF_ERR_NO_MEM & 0xFF: s = "insufficient memory"; break; case PF_ERR_TOO_BIG & 0xFF: s = "data chunk too large"; break; case PF_ERR_NUM_PARAMS & 0xFF: s = "incorrect number of parameters"; break; case PF_ERR_OPEN_FILE & 0xFF: s = "could not open file"; break; case PF_ERR_WRONG_FILE & 0xFF: s = "wrong type of file format"; break; case PF_ERR_BAD_FILE & 0xFF: s = "badly formatted file"; break; case PF_ERR_READ_FILE & 0xFF: s = "file read failed"; break; case PF_ERR_WRITE_FILE & 0xFF: s = "file write failed"; break; case PF_ERR_CORRUPT_DIC & 0xFF: s = "corrupted dictionary"; break; case PF_ERR_NOT_SUPPORTED & 0xFF: s = "not supported in this version"; break; case PF_ERR_VERSION_FUTURE & 0xFF: s = "version from future"; break; case PF_ERR_VERSION_PAST & 0xFF: s = "version is obsolete. Rebuild new one."; break; case PF_ERR_COLON_STACK & 0xFF: s = "stack depth changed between : and ; . Probably unbalanced conditional"; break; case PF_ERR_HEADER_ROOM & 0xFF: s = "no room left in header space"; break; case PF_ERR_CODE_ROOM & 0xFF: s = "no room left in code space"; break; case PF_ERR_NO_SHELL & 0xFF: s = "attempt to use names in forth compiled with PF_NO_SHELL"; break; case PF_ERR_NO_NAMES & 0xFF: s = "dictionary has no names"; break; case PF_ERR_OUT_OF_RANGE & 0xFF: s = "parameter out of range"; break; case PF_ERR_ENDIAN_CONFLICT & 0xFF: s = "endian-ness of dictionary does not match code"; break; case PF_ERR_FLOAT_CONFLICT & 0xFF: s = "float support mismatch between .dic file and code"; break; case PF_ERR_CELL_SIZE_CONFLICT & 0xFF: s = "cell size mismatch between .dic file and code"; break; default: s = "unrecognized error code!"; break; } MSG(s); EMIT_CR; } void pfReportThrow( ThrowCode code ) { const char *s = NULL; switch(code) { case THROW_ABORT: case THROW_ABORT_QUOTE: s = "ABORT"; break; case THROW_STACK_OVERFLOW: s = "Stack overflow!"; break; case THROW_STACK_UNDERFLOW: s = "Stack underflow!"; break; case THROW_EXECUTING: s = "Executing a compile-only word!"; break; case THROW_FLOAT_STACK_UNDERFLOW: s = "Float Stack underflow!"; break; case THROW_UNDEFINED_WORD: s = "Undefined word!"; break; case THROW_PAIRS: s = "Conditional control structure mismatch!"; break; case THROW_BYE: case THROW_QUIT: break; case THROW_SEMICOLON: s = "Stack depth changed between : and ; . Probably unbalanced conditional!"; break; case THROW_DEFERRED: s = "Not a DEFERred word!"; break; default: s = "Unrecognized throw code!"; break; } if( s ) { MSG_NUM_D("THROW code = ", code ); MSG(s); EMIT_CR; } } #endif /************************************************************** ** Copy a Forth String to a 'C' string. */ char *ForthStringToC( char *dst, const char *FString, cell_t dstSize ) { cell_t Len; Len = (cell_t) *FString; /* Make sure the text + NUL can fit. */ if( Len >= dstSize ) { Len = dstSize - 1; } pfCopyMemory( dst, FString+1, Len ); dst[Len] = '\0'; return dst; } /************************************************************** ** Copy a NUL terminated string to a Forth counted string. */ char *CStringToForth( char *dst, const char *CString, cell_t dstSize ) { cell_t i; /* Make sure the SIZE+text can fit. */ for( i=1; is2; */ cell_t ffCompare( const char *s1, cell_t len1, const char *s2, cell_t len2 ) { cell_t i, result, n, diff; result = 0; n = MIN(len1,len2); for( i=0; i 0) ? -1 : 1 ; break; } } if( result == 0 ) /* Match up to MIN(len1,len2) */ { if( len1 < len2 ) { result = -1; } else if ( len1 > len2 ) { result = 1; } } return result; } /*************************************************************** ** Convert number to text. */ #define CNTT_PAD_SIZE ((sizeof(cell_t)*8)+2) /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */ static char cnttPad[CNTT_PAD_SIZE]; char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars ) { cell_t IfNegative = 0; char *p,c; ucell_t NewNum, Rem, uNum; cell_t i = 0; uNum = Num; if( IfSigned ) { /* Convert to positive and keep sign. */ if( Num < 0 ) { IfNegative = TRUE; uNum = -Num; } } /* Point past end of Pad */ p = cnttPad + CNTT_PAD_SIZE; *(--p) = (char) 0; /* NUL terminate */ while( (i++ '}')) c = '.'; EMIT(c); } EMIT_CR; } } /* Print name, mask off any dictionary bits. */ void TypeName( const char *Name ) { const char *FirstChar; cell_t Len; FirstChar = Name+1; Len = *Name & 0x1F; ioType( FirstChar, Len ); } #ifdef PF_UNIT_TEST /* Unit test for string conversion routines. */ #define ASSERT_PAD_IS( index, value, msg ) \ if( pad[index] != ((char)(value)) ) \ { \ ERR(( "ERROR text test failed: " msg "\n")); \ numErrors += 1; \ } \ cell_t pfUnitTestText( void ) { cell_t numErrors = 0; char pad[16]; char fpad[8]; /* test CStringToForth */ pfSetMemory(pad,0xA5,sizeof(pad)); CStringToForth( pad, "frog", 6 ); ASSERT_PAD_IS( 0, 4, "CS len 6" ); ASSERT_PAD_IS( 4, 'g', "CS end 6" ); ASSERT_PAD_IS( 5, 0xA5, "CS past 6" ); pfSetMemory(pad,0xA5,sizeof(pad)); CStringToForth( pad, "frog", 5 ); ASSERT_PAD_IS( 0, 4, "CS len 5" ); ASSERT_PAD_IS( 4, 'g', "CS end 5" ); ASSERT_PAD_IS( 5, 0xA5, "CS past 5" ); pfSetMemory(pad,0xA5,sizeof(pad)); CStringToForth( pad, "frog", 4 ); ASSERT_PAD_IS( 0, 3, "CS len 4" ); ASSERT_PAD_IS( 3, 'o', "CS end 4" ); ASSERT_PAD_IS( 4, 0xA5, "CS past 4" ); /* Make a Forth string for testing ForthStringToC. */ CStringToForth( fpad, "frog", sizeof(fpad) ); pfSetMemory(pad,0xA5,sizeof(pad)); ForthStringToC( pad, fpad, 6 ); ASSERT_PAD_IS( 0, 'f', "FS len 6" ); ASSERT_PAD_IS( 3, 'g', "FS end 6" ); ASSERT_PAD_IS( 4, 0, "FS nul 6" ); ASSERT_PAD_IS( 5, 0xA5, "FS past 6" ); pfSetMemory(pad,0xA5,sizeof(pad)); ForthStringToC( pad, fpad, 5 ); ASSERT_PAD_IS( 0, 'f', "FS len 5" ); ASSERT_PAD_IS( 3, 'g', "FS end 5" ); ASSERT_PAD_IS( 4, 0, "FS nul 5" ); ASSERT_PAD_IS( 5, 0xA5, "FS past 5" ); pfSetMemory(pad,0xA5,sizeof(pad)); ForthStringToC( pad, fpad, 4 ); ASSERT_PAD_IS( 0, 'f', "FS len 4" ); ASSERT_PAD_IS( 2, 'o', "FS end 4" ); ASSERT_PAD_IS( 3, 0, "FS nul 4" ); ASSERT_PAD_IS( 4, 0xA5, "FS past 4" ); return numErrors; } #endif pforth-2.0.1/csrc/pf_text.h000066400000000000000000000056151435661464300156130ustar00rootroot00000000000000/* @(#) pf_text.h 96/12/18 1.10 */ #ifndef _pforth_text_h #define _pforth_text_h /*************************************************************** ** Include file for PForth Text ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #define PF_ERR_INDEX_MASK (0xFFFF) #define PF_ERR_BASE (0x80000000) #define PF_ERR_NO_MEM (PF_ERR_BASE | 0) #define PF_ERR_TOO_BIG (PF_ERR_BASE | 2) #define PF_ERR_NUM_PARAMS (PF_ERR_BASE | 3) #define PF_ERR_OPEN_FILE (PF_ERR_BASE | 4) #define PF_ERR_WRONG_FILE (PF_ERR_BASE | 5) #define PF_ERR_BAD_FILE (PF_ERR_BASE | 6) #define PF_ERR_READ_FILE (PF_ERR_BASE | 7) #define PF_ERR_WRITE_FILE (PF_ERR_BASE | 8) #define PF_ERR_CORRUPT_DIC (PF_ERR_BASE | 9) #define PF_ERR_NOT_SUPPORTED (PF_ERR_BASE | 10) #define PF_ERR_VERSION_FUTURE (PF_ERR_BASE | 11) #define PF_ERR_VERSION_PAST (PF_ERR_BASE | 12) #define PF_ERR_COLON_STACK (PF_ERR_BASE | 13) #define PF_ERR_HEADER_ROOM (PF_ERR_BASE | 14) #define PF_ERR_CODE_ROOM (PF_ERR_BASE | 15) #define PF_ERR_NO_SHELL (PF_ERR_BASE | 16) #define PF_ERR_NO_NAMES (PF_ERR_BASE | 17) #define PF_ERR_OUT_OF_RANGE (PF_ERR_BASE | 18) #define PF_ERR_ENDIAN_CONFLICT (PF_ERR_BASE | 19) #define PF_ERR_FLOAT_CONFLICT (PF_ERR_BASE | 20) #define PF_ERR_CELL_SIZE_CONFLICT (PF_ERR_BASE | 21) /* If you add an error code here, also add a text message in "pf_text.c". */ #ifdef __cplusplus extern "C" { #endif void pfReportError( const char *FunctionName, Err ErrCode ); 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 ffCompareTextCaseN( const char *s1, const char *s2, cell_t len ); void DumpMemory( void *addr, cell_t cnt); char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars ); void TypeName( const char *Name ); cell_t pfUnitTestText( void ); #ifdef __cplusplus } #endif #endif /* _pforth_text_h */ pforth-2.0.1/csrc/pf_types.h000066400000000000000000000026121435661464300157650ustar00rootroot00000000000000/* @(#) pf_types.h 96/12/18 1.3 */ #ifndef _pf_types_h #define _pf_types_h /*************************************************************** ** Type declarations for PForth, a Forth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ /*************************************************************** ** Type Declarations ***************************************************************/ #if !defined(AMIGA) && !defined(ATARI) #include #endif /* file_offset_t is used in place of off_t */ typedef long file_offset_t; #ifndef Err typedef long Err; #endif typedef char ForthString; typedef char *ForthStringPtr; #endif /* _pf_types_h */ pforth-2.0.1/csrc/pf_win32.h000066400000000000000000000025511435661464300155650ustar00rootroot00000000000000/* @(#) pf_win32.h 98/01/26 1.2 */ #ifndef _pf_win32_h #define _pf_win32_h #include /*************************************************************** ** WIN32 dependant include file for PForth, a Forth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ /* Include as PF_USER_INC2 for PCs */ /* Modify some existing defines. */ /* ** The PC will insert LF characters into the dictionary files unless ** we use "b" mode! */ #undef PF_FAM_CREATE #define PF_FAM_CREATE ("wb+") #undef PF_FAM_OPEN_RO #define PF_FAM_OPEN_RO ("rb") #undef PF_FAM_OPEN_RW #define PF_FAM_OPEN_RW ("rb+") #endif /* _pf_win32_h */ pforth-2.0.1/csrc/pf_words.c000066400000000000000000000134141435661464300157540ustar00rootroot00000000000000/* @(#) pf_words.c 96/12/18 1.10 */ /*************************************************************** ** Forth words for PForth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ** ** 941031 rdg fix ffScan() to look for CRs and LFs ** ***************************************************************/ #include "pf_all.h" /*************************************************************** ** Print number in current base to output stream. ** This version does not handle double precision. */ void ffDot( cell_t n ) { MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) ); EMIT(' '); } /*************************************************************** ** Print number in current base to output stream. ** This version does not handle double precision. */ void ffDotHex( cell_t n ) { MSG( ConvertNumberToText( n, 16, FALSE, 1 ) ); EMIT(' '); } /* ( ... --- ... , print stack ) */ void ffDotS( void ) { cell_t *sp; cell_t i, Depth; MSG("Stack<"); MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */ MSG("> "); Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr; sp = gCurrentTask->td_StackBase; if( Depth < 0 ) { MSG("UNDERFLOW!"); } else { for( i=0; i 0 ) && (( *s == BLANK) || ( *s == '\t')) ) { DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt )); s++; Cnt--; } } else { while(( Cnt > 0 ) && ( *s == c )) { DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt )); s++; Cnt--; } } *AddrOut = s; return Cnt; } /* ( addr cnt char -- addr' cnt' , scan for char ) */ cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut ) { char *s; s = AddrIn; if( c == BLANK ) { while(( Cnt > 0 ) && ( *s != BLANK) && ( *s != '\r') && ( *s != '\n') && ( *s != '\t')) { DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt )); s++; Cnt--; } } else { while(( Cnt > 0 ) && ( *s != c )) { DBUGX(("ffScan: %c, %d\n", *s, Cnt )); s++; Cnt--; } } *AddrOut = s; return Cnt; } /*************************************************************** ** Forth equivalent 'C' functions. ***************************************************************/ /* Convert a single digit to the corresponding hex number. */ static cell_t HexDigitToNumber( char c ) { if( (c >= '0') && (c <= '9') ) { return( c - '0' ); } else if ( (c >= 'A') && (c <= 'F') ) { return( c - 'A' + 0x0A ); } else { return -1; } } /* 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, 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 == '-' ) { Sign = -1; s++; Len--; } for( i=0; i= Base) ) { return NUM_TYPE_BAD; } Accum = (Accum * Base) + n; } *Num = Accum * Sign; return NUM_TYPE_SINGLE; } /*************************************************************** ** Compiler Support ***************************************************************/ /* 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; cell_t i, nc; s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN; n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN; n2 = ffSkip( s1, n1, c, &s2 ); DBUGX(("Word: s2=%c, %d\n", *s2, n2 )); n3 = ffScan( s2, n2, c, &s3 ); 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 ); } pforth-2.0.1/csrc/pf_words.h000066400000000000000000000024101435661464300157530ustar00rootroot00000000000000/* @(#) pf_words.h 96/12/18 1.7 */ #ifndef _pforth_words_h #define _pforth_words_h /*************************************************************** ** Include file for PForth Words ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #ifdef __cplusplus extern "C" { #endif void ffDot( cell_t n ); void ffDotHex( cell_t n ); void ffDotS( void ); cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut ); cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut ); #ifdef __cplusplus } #endif #endif /* _pforth_words_h */ pforth-2.0.1/csrc/pfcompfp.h000066400000000000000000000067151435661464300157560ustar00rootroot00000000000000/* @(#) pfcompfp.h 96/12/18 1.6 */ /*************************************************************** ** Compile FP routines. ** This file is included from "pf_compile.c" ** ** These routines could be left out of an execute only version. ** ** Author: Darren Gibbs, Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** ***************************************************************/ #ifdef PF_SUPPORT_FP /* Core words */ CreateDicEntryC( ID_FP_D_TO_F, "D>F", 0 ); CreateDicEntryC( ID_FP_FSTORE, "F!", 0 ); CreateDicEntryC( ID_FP_FTIMES, "F*", 0 ); CreateDicEntryC( ID_FP_FPLUS, "F+", 0 ); CreateDicEntryC( ID_FP_FMINUS, "F-", 0 ); CreateDicEntryC( ID_FP_FSLASH, "F/", 0 ); CreateDicEntryC( ID_FP_F_ZERO_LESS_THAN, "F0<", 0 ); CreateDicEntryC( ID_FP_F_ZERO_EQUALS, "F0=", 0 ); CreateDicEntryC( ID_FP_F_LESS_THAN, "F<", 0 ); CreateDicEntryC( ID_FP_F_TO_D, "F>D", 0 ); CreateDicEntryC( ID_FP_FFETCH, "F@", 0 ); CreateDicEntryC( ID_FP_FDEPTH, "FDEPTH", 0 ); CreateDicEntryC( ID_FP_FDROP, "FDROP", 0 ); CreateDicEntryC( ID_FP_FDUP, "FDUP", 0 ); CreateDicEntryC( ID_FP_FLITERAL, "FLITERAL", FLAG_IMMEDIATE ); CreateDicEntryC( ID_FP_FLITERAL_P, "(FLITERAL)", 0 ); CreateDicEntryC( ID_FP_FLOAT_PLUS, "FLOAT+", 0 ); CreateDicEntryC( ID_FP_FLOATS, "FLOATS", 0 ); CreateDicEntryC( ID_FP_FLOOR, "FLOOR", 0 ); CreateDicEntryC( ID_FP_FMAX, "FMAX", 0 ); CreateDicEntryC( ID_FP_FMIN, "FMIN", 0 ); CreateDicEntryC( ID_FP_FNEGATE, "FNEGATE", 0 ); CreateDicEntryC( ID_FP_FOVER, "FOVER", 0 ); CreateDicEntryC( ID_FP_FROT, "FROT", 0 ); CreateDicEntryC( ID_FP_FROUND, "FROUND", 0 ); CreateDicEntryC( ID_FP_FSWAP, "FSWAP", 0 ); /* Extended words */ CreateDicEntryC( ID_FP_FSTAR_STAR, "F**", 0 ); CreateDicEntryC( ID_FP_FABS, "FABS", 0 ); CreateDicEntryC( ID_FP_FACOS, "FACOS", 0 ); CreateDicEntryC( ID_FP_FACOSH, "FACOSH", 0 ); CreateDicEntryC( ID_FP_FALOG, "FALOG", 0 ); CreateDicEntryC( ID_FP_FASIN, "FASIN", 0 ); CreateDicEntryC( ID_FP_FASINH, "FASINH", 0 ); CreateDicEntryC( ID_FP_FATAN, "FATAN", 0 ); CreateDicEntryC( ID_FP_FATAN2, "FATAN2", 0 ); CreateDicEntryC( ID_FP_FATANH, "FATANH", 0 ); CreateDicEntryC( ID_FP_FCOS, "FCOS", 0 ); CreateDicEntryC( ID_FP_FCOSH, "FCOSH", 0 ); CreateDicEntryC( ID_FP_FLN, "FLN", 0 ); CreateDicEntryC( ID_FP_FLNP1, "FLNP1", 0 ); CreateDicEntryC( ID_FP_FLOG, "FLOG", 0 ); CreateDicEntryC( ID_FP_FSIN, "FSIN", 0 ); CreateDicEntryC( ID_FP_FSINCOS, "FSINCOS", 0 ); CreateDicEntryC( ID_FP_FSINH, "FSINH", 0 ); CreateDicEntryC( ID_FP_FSQRT, "FSQRT", 0 ); CreateDicEntryC( ID_FP_FTAN, "FTAN", 0 ); CreateDicEntryC( ID_FP_FTANH, "FTANH", 0 ); CreateDicEntryC( ID_FP_FPICK, "FPICK", 0 ); #endif pforth-2.0.1/csrc/pfcompil.c000066400000000000000000001107511435661464300157440ustar00rootroot00000000000000/* @(#) pfcompil.c 98/01/26 1.5 */ /*************************************************************** ** Compiler for PForth based on 'C' ** ** These routines could be left out of an execute only version. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 941004 PLB Extracted IO calls from pforth_main.c ** 950320 RDG Added underflow checking for FP stack ***************************************************************/ #include "pf_all.h" #include "pfcompil.h" #define ABORT_RETURN_CODE (10) #define UINT32_MASK ((sizeof(ucell_t)-1)) /***************************************************************/ /************** Static Prototypes ******************************/ /***************************************************************/ static void ffStringColon( const ForthStringPtr FName ); static cell_t CheckRedefinition( const ForthStringPtr FName ); static void ffUnSmudge( void ); static cell_t FindAndCompile( const char *theWord ); static cell_t ffCheckDicRoom( void ); #ifndef PF_NO_INIT static void CreateDeferredC( ExecToken DefaultXT, const char *CName ); #endif cell_t NotCompiled( const char *FunctionName ) { MSG("Function "); MSG(FunctionName); MSG(" not compiled in this version of PForth.\n"); return -1; } #ifndef PF_NO_SHELL /*************************************************************** ** Create an entry in the Dictionary for the given ExecutionToken. ** FName is name in Forth format. */ void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags ) { cfNameLinks *cfnl; cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr; /* Set link to previous header, if any. */ if( gVarContext ) { WRITE_CELL_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) ); } else { cfnl->cfnl_PreviousName = 0; } /* Put Execution token in header. */ WRITE_CELL_DIC( &cfnl->cfnl_ExecToken, XT ); /* Advance Header Dictionary Pointer */ gCurrentDictionary->dic_HeaderPtr += sizeof(cfNameLinks); /* Laydown name. */ gVarContext = gCurrentDictionary->dic_HeaderPtr; pfCopyMemory( (uint8_t *) gCurrentDictionary->dic_HeaderPtr, FName, (*FName)+1 ); gCurrentDictionary->dic_HeaderPtr += (*FName)+1; /* Set flags. */ *(char*)gVarContext |= (char) Flags; /* Align to quad byte boundaries with zeroes. */ while( gCurrentDictionary->dic_HeaderPtr & UINT32_MASK ) { *(char*)(gCurrentDictionary->dic_HeaderPtr++) = 0; } } /*************************************************************** ** Convert name then create dictionary entry. */ void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags ) { ForthString FName[40]; CStringToForth( FName, CName, sizeof(FName) ); CreateDicEntry( XT, FName, Flags ); } /*************************************************************** ** Convert absolute namefield address to previous absolute name ** field address or NULL. */ const ForthString *NameToPrevious( const ForthString *NFA ) { cell_t RelNamePtr; const cfNameLinks *cfnl; /* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (cell_t) NFA)); */ cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) ); RelNamePtr = READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_PreviousName)); /* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (cell_t) RelNamePtr )); */ if( RelNamePtr ) { return ( (ForthString *) NAMEREL_TO_ABS( RelNamePtr ) ); } else { return NULL; } } /*************************************************************** ** Convert NFA to ExecToken. */ ExecToken NameToToken( const ForthString *NFA ) { const cfNameLinks *cfnl; /* Convert absolute namefield address to absolute link field address. */ cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) ); return READ_CELL_DIC((const cell_t *) (&cfnl->cfnl_ExecToken)); } /*************************************************************** ** Find XTs needed by compiler. */ cell_t FindSpecialXTs( void ) { if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind; if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind; if( ffFindC( "ACCEPT", &gAcceptP_XT ) == 0) goto nofind; DBUG(("gNumberQ_XT = 0x%x\n", (unsigned int)gNumberQ_XT )); return 0; nofind: ERR("FindSpecialXTs failed!\n"); return -1; } /*************************************************************** ** Build a dictionary from scratch. */ #ifndef PF_NO_INIT PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ) { pfDictionary_t *dic; dic = pfCreateDictionary( HeaderSize, CodeSize ); if( !dic ) goto nomem; pfDebugMessage("pfBuildDictionary: Start adding dictionary entries.\n"); gCurrentDictionary = dic; gNumPrimitives = NUM_PRIMITIVES; CreateDicEntryC( ID_EXIT, "EXIT", 0 ); pfDebugMessage("pfBuildDictionary: added EXIT\n"); CreateDicEntryC( ID_1MINUS, "1-", 0 ); pfDebugMessage("pfBuildDictionary: added 1-\n"); CreateDicEntryC( ID_1PLUS, "1+", 0 ); CreateDicEntryC( ID_2_R_FETCH, "2R@", 0 ); CreateDicEntryC( ID_2_R_FROM, "2R>", 0 ); CreateDicEntryC( ID_2_TO_R, "2>R", 0 ); CreateDicEntryC( ID_2DUP, "2DUP", 0 ); CreateDicEntryC( ID_2LITERAL, "2LITERAL", FLAG_IMMEDIATE ); CreateDicEntryC( ID_2LITERAL_P, "(2LITERAL)", 0 ); CreateDicEntryC( ID_2MINUS, "2-", 0 ); CreateDicEntryC( ID_2PLUS, "2+", 0 ); CreateDicEntryC( ID_2OVER, "2OVER", 0 ); CreateDicEntryC( ID_2SWAP, "2SWAP", 0 ); CreateDicEntryC( ID_ACCEPT_P, "(ACCEPT)", 0 ); CreateDeferredC( ID_ACCEPT_P, "ACCEPT" ); CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE ); CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 ); CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 ); pfDebugMessage("pfBuildDictionary: added ALLOCATE\n"); CreateDicEntryC( ID_ARSHIFT, "ARSHIFT", 0 ); CreateDicEntryC( ID_AND, "AND", 0 ); CreateDicEntryC( ID_BAIL, "BAIL", 0 ); CreateDicEntryC( ID_BRANCH, "BRANCH", 0 ); CreateDicEntryC( ID_BODY_OFFSET, "BODY_OFFSET", 0 ); CreateDicEntryC( ID_BYE, "BYE", 0 ); CreateDicEntryC( ID_CATCH, "CATCH", 0 ); CreateDicEntryC( ID_CELL, "CELL", 0 ); CreateDicEntryC( ID_CELLS, "CELLS", 0 ); CreateDicEntryC( ID_CFETCH, "C@", 0 ); CreateDicEntryC( ID_CMOVE, "CMOVE", 0 ); CreateDicEntryC( ID_CMOVE_UP, "CMOVE>", 0 ); CreateDicEntryC( ID_COLON, ":", 0 ); CreateDicEntryC( ID_COLON_P, "(:)", 0 ); CreateDicEntryC( ID_COMPARE, "COMPARE", 0 ); CreateDicEntryC( ID_COMP_EQUAL, "=", 0 ); CreateDicEntryC( ID_COMP_NOT_EQUAL, "<>", 0 ); CreateDicEntryC( ID_COMP_GREATERTHAN, ">", 0 ); CreateDicEntryC( ID_COMP_U_GREATERTHAN, "U>", 0 ); pfDebugMessage("pfBuildDictionary: added U>\n"); CreateDicEntryC( ID_COMP_LESSTHAN, "<", 0 ); CreateDicEntryC( ID_COMP_U_LESSTHAN, "U<", 0 ); CreateDicEntryC( ID_COMP_ZERO_EQUAL, "0=", 0 ); CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL, "0<>", 0 ); CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN, "0>", 0 ); CreateDicEntryC( ID_COMP_ZERO_LESSTHAN, "0<", 0 ); CreateDicEntryC( ID_CR, "CR", 0 ); CreateDicEntryC( ID_CREATE, "CREATE", 0 ); CreateDicEntryC( ID_CREATE_P, "(CREATE)", 0 ); CreateDicEntryC( ID_D_PLUS, "D+", 0 ); CreateDicEntryC( ID_D_MINUS, "D-", 0 ); CreateDicEntryC( ID_D_UMSMOD, "UM/MOD", 0 ); CreateDicEntryC( ID_D_MUSMOD, "MU/MOD", 0 ); CreateDicEntryC( ID_D_MTIMES, "M*", 0 ); pfDebugMessage("pfBuildDictionary: added M*\n"); CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 ); CreateDicEntryC( ID_DEFER, "DEFER", 0 ); CreateDicEntryC( ID_CSTORE, "C!", 0 ); CreateDicEntryC( ID_DEPTH, "DEPTH", 0 ); pfDebugMessage("pfBuildDictionary: added DEPTH\n"); CreateDicEntryC( ID_DIVIDE, "/", 0 ); CreateDicEntryC( ID_DOT, ".", 0 ); CreateDicEntryC( ID_DOTS, ".S", 0 ); pfDebugMessage("pfBuildDictionary: added .S\n"); CreateDicEntryC( ID_DO_P, "(DO)", 0 ); CreateDicEntryC( ID_DROP, "DROP", 0 ); CreateDicEntryC( ID_DUMP, "DUMP", 0 ); CreateDicEntryC( ID_DUP, "DUP", 0 ); CreateDicEntryC( ID_EMIT_P, "(EMIT)", 0 ); pfDebugMessage("pfBuildDictionary: added (EMIT)\n"); CreateDeferredC( ID_EMIT_P, "EMIT"); pfDebugMessage("pfBuildDictionary: added EMIT\n"); CreateDicEntryC( ID_EOL, "EOL", 0 ); CreateDicEntryC( ID_ERRORQ_P, "(?ERROR)", 0 ); CreateDicEntryC( ID_ERRORQ_P, "?ERROR", 0 ); CreateDicEntryC( ID_EXECUTE, "EXECUTE", 0 ); CreateDicEntryC( ID_FETCH, "@", 0 ); CreateDicEntryC( ID_FILL, "FILL", 0 ); CreateDicEntryC( ID_FIND, "FIND", 0 ); CreateDicEntryC( ID_FILE_CREATE, "CREATE-FILE", 0 ); CreateDicEntryC( ID_FILE_DELETE, "DELETE-FILE", 0 ); CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE", 0 ); CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE", 0 ); CreateDicEntryC( ID_FILE_READ, "READ-FILE", 0 ); CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE", 0 ); 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_FILE_BIN, "BIN", 0 ); CreateDicEntryC( ID_FINDNFA, "FINDNFA", 0 ); CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT", 0 ); CreateDicEntryC( ID_FREE, "FREE", 0 ); #include "pfcompfp.h" CreateDicEntryC( ID_HERE, "HERE", 0 ); CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)", 0 ); CreateDicEntryC( ID_I, "I", 0 ); CreateDicEntryC( ID_INTERPRET, "INTERPRET", 0 ); CreateDicEntryC( ID_J, "J", 0 ); CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE", 0 ); CreateDicEntryC( ID_KEY, "KEY", 0 ); CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 ); CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE ); CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 ); CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 ); CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 ); CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 ); CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 ); CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 ); CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 ); CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 ); CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 ); CreateDicEntryC( ID_MAX, "MAX", 0 ); CreateDicEntryC( ID_MIN, "MIN", 0 ); CreateDicEntryC( ID_MINUS, "-", 0 ); CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 ); CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 ); CreateDicEntryC( ID_NOOP, "NOOP", 0 ); CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" ); CreateDicEntryC( ID_OR, "OR", 0 ); CreateDicEntryC( ID_OVER, "OVER", 0 ); pfDebugMessage("pfBuildDictionary: added OVER\n"); CreateDicEntryC( ID_PICK, "PICK", 0 ); CreateDicEntryC( ID_PLUS, "+", 0 ); CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 ); CreateDicEntryC( ID_PLUS_STORE, "+!", 0 ); CreateDicEntryC( ID_QUIT_P, "(QUIT)", 0 ); CreateDeferredC( ID_QUIT_P, "QUIT" ); CreateDicEntryC( ID_QDO_P, "(?DO)", 0 ); CreateDicEntryC( ID_QDUP, "?DUP", 0 ); CreateDicEntryC( ID_QTERMINAL, "?TERMINAL", 0 ); CreateDicEntryC( ID_QTERMINAL, "KEY?", 0 ); CreateDicEntryC( ID_REFILL, "REFILL", 0 ); CreateDicEntryC( ID_RESIZE, "RESIZE", 0 ); CreateDicEntryC( ID_ROLL, "ROLL", 0 ); CreateDicEntryC( ID_ROT, "ROT", 0 ); CreateDicEntryC( ID_RSHIFT, "RSHIFT", 0 ); CreateDicEntryC( ID_R_DROP, "RDROP", 0 ); CreateDicEntryC( ID_R_FETCH, "R@", 0 ); CreateDicEntryC( ID_R_FROM, "R>", 0 ); CreateDicEntryC( ID_RP_FETCH, "RP@", 0 ); CreateDicEntryC( ID_RP_STORE, "RP!", 0 ); CreateDicEntryC( ID_SEMICOLON, ";", FLAG_IMMEDIATE ); CreateDicEntryC( ID_SP_FETCH, "SP@", 0 ); CreateDicEntryC( ID_SP_STORE, "SP!", 0 ); CreateDicEntryC( ID_STORE, "!", 0 ); CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)", 0 ); CreateDicEntryC( ID_SCAN, "SCAN", 0 ); CreateDicEntryC( ID_SKIP, "SKIP", 0 ); CreateDicEntryC( ID_SLEEP_P, "(SLEEP)", 0 ); CreateDicEntryC( ID_SOURCE, "SOURCE", 0 ); CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE", 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 ); CreateDicEntryC( ID_TICK, "'", 0 ); CreateDicEntryC( ID_TIMES, "*", 0 ); CreateDicEntryC( ID_THROW, "THROW", 0 ); CreateDicEntryC( ID_TO_R, ">R", 0 ); CreateDicEntryC( ID_TYPE, "TYPE", 0 ); CreateDicEntryC( ID_VAR_BASE, "BASE", 0 ); CreateDicEntryC( ID_VAR_BYE_CODE, "BYE-CODE", 0 ); CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 ); CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 ); CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 ); CreateDicEntryC( ID_VAR_DP, "DP", 0 ); CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 ); CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 ); CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 ); CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 ); CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 ); CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 ); CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 ); CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 ); CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 ); CreateDicEntryC( ID_VAR_OUT, "OUT", 0 ); CreateDicEntryC( ID_VAR_STATE, "STATE", 0 ); CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 ); CreateDicEntryC( ID_VERSION_CODE, "VERSION_CODE", 0 ); CreateDicEntryC( ID_WORD, "WORD", 0 ); CreateDicEntryC( ID_WORD_FETCH, "W@", 0 ); CreateDicEntryC( ID_WORD_STORE, "W!", 0 ); CreateDicEntryC( ID_XOR, "XOR", 0 ); CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 ); pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n"); if( FindSpecialXTs() < 0 ) goto error; if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */ #ifdef PF_DEBUG DumpMemory( dic->dic_HeaderBase, 256 ); DumpMemory( dic->dic_CodeBase, 256 ); #endif pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n"); return (PForthDictionary) dic; error: pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n"); pfDeleteDictionary( dic ); return NULL; nomem: return NULL; } #endif /* !PF_NO_INIT */ /* ** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT ) ** 1 for IMMEDIATE values */ cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr ) { const ForthString *NameField; cell_t Searching = TRUE; cell_t Result = 0; ExecToken TempXT; NameField = (ForthString *) gVarContext; DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext)); do { TempXT = NameToToken( NameField ); if( TempXT == XT ) { DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); *NFAPtr = NameField ; Result = 1; Searching = FALSE; } else { NameField = NameToPrevious( NameField ); if( NameField == NULL ) { *NFAPtr = 0; Searching = FALSE; } } } while ( Searching); return Result; } /* ** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary ) ** 1 for IMMEDIATE values */ cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) { const ForthString *WordChar; uint8_t WordLen; const char *NameField, *NameChar; int8_t NameLen; cell_t Searching = TRUE; cell_t Result = 0; WordLen = (uint8_t) ((ucell_t)*WordName & 0x1F); WordChar = WordName+1; NameField = (ForthString *) gVarContext; DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar )); DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext)); do { NameLen = (uint8_t) ((ucell_t)(*NameField) & MASK_NAME_SIZE); NameChar = NameField+1; /* DBUG((" %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */ if( ((*NameField & FLAG_SMUDGE) == 0) && (NameLen == WordLen) && ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */ { DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField)); *NFAPtr = NameField ; Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1; Searching = FALSE; } else { NameField = NameToPrevious( NameField ); if( NameField == NULL ) { *NFAPtr = WordName; Searching = FALSE; } } } while ( Searching); DBUG(("ffFindNFA: returns 0x%x\n", Result)); return Result; } /*************************************************************** ** ( $name -- $name 0 | xt -1 | xt 1 ) ** 1 for IMMEDIATE values */ cell_t ffFind( const ForthString *WordName, ExecToken *pXT ) { const ForthString *NFA; cell_t Result; Result = ffFindNFA( WordName, &NFA ); DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */ if( Result ) { *pXT = NameToToken( NFA ); } else { *pXT = (ExecToken) WordName; } return Result; } /**************************************************************** ** Find name when passed 'C' string. */ cell_t ffFindC( const char *WordName, ExecToken *pXT ) { DBUG(("ffFindC: %s\n", WordName )); CStringToForth( gScratch, WordName, sizeof(gScratch) ); return ffFind( gScratch, pXT ); } /***********************************************************/ /********* Compiling New Words *****************************/ /***********************************************************/ #define DIC_SAFETY_MARGIN (400) /************************************************************* ** Check for dictionary overflow. */ static cell_t ffCheckDicRoom( void ) { cell_t RoomLeft; RoomLeft = (char *)gCurrentDictionary->dic_HeaderLimit - (char *)gCurrentDictionary->dic_HeaderPtr; if( RoomLeft < DIC_SAFETY_MARGIN ) { pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM); return PF_ERR_HEADER_ROOM; } RoomLeft = (char *)gCurrentDictionary->dic_CodeLimit - (char *)gCurrentDictionary->dic_CodePtr.Byte; if( RoomLeft < DIC_SAFETY_MARGIN ) { pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM); return PF_ERR_CODE_ROOM; } return 0; } /************************************************************* ** Create a dictionary entry given a string name. */ void ffCreateSecondaryHeader( const ForthStringPtr FName) { pfDebugMessage("ffCreateSecondaryHeader()\n"); /* Check for dictionary overflow. */ if( ffCheckDicRoom() ) return; pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n"); CheckRedefinition( FName ); /* Align CODE_HERE */ CODE_HERE = (cell_t *)( (((ucell_t)CODE_HERE) + UINT32_MASK) & ~UINT32_MASK); CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE ); } /************************************************************* ** Begin compiling a secondary word. */ static void ffStringColon( const ForthStringPtr FName) { ffCreateSecondaryHeader( FName ); gVarState = 1; } /************************************************************* ** Read the next ExecToken from the Source and create a word. */ void ffColon( void ) { char *FName; gDepthAtColon = DATA_STACK_DEPTH; FName = ffWord( BLANK ); if( *FName > 0 ) { ffStringColon( FName ); } } /************************************************************* ** Check to see if name is already in dictionary. */ static cell_t CheckRedefinition( const ForthStringPtr FName ) { cell_t flag; ExecToken XT; flag = ffFind( FName, &XT); if ( flag && !gVarQuiet) { ioType( FName+1, (cell_t) *FName ); MSG( " redefined.\n" ); /* FIXME - allow user to run off this warning. */ } return flag; } void ffStringCreate( char *FName) { ffCreateSecondaryHeader( FName ); CODE_COMMA( ID_CREATE_P ); CODE_COMMA( ID_EXIT ); ffFinishSecondary(); } /* Read the next ExecToken from the Source and create a word. */ void ffCreate( void ) { char *FName; FName = ffWord( BLANK ); if( *FName > 0 ) { ffStringCreate( FName ); } } void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ) { pfDebugMessage("ffStringDefer()\n"); ffCreateSecondaryHeader( FName ); CODE_COMMA( ID_DEFER_P ); CODE_COMMA( DefaultXT ); ffFinishSecondary(); } #ifndef PF_NO_INIT /* Convert name then create deferred dictionary entry. */ static void CreateDeferredC( ExecToken DefaultXT, const char *CName ) { char FName[40]; CStringToForth( FName, CName, sizeof(FName) ); ffStringDefer( FName, DefaultXT ); } #endif /* Read the next token from the Source and create a word. */ void ffDefer( void ) { char *FName; FName = ffWord( BLANK ); if( *FName > 0 ) { ffStringDefer( FName, ID_QUIT_P ); } } /* Unsmudge the word to make it visible. */ static void ffUnSmudge( void ) { *(char*)gVarContext &= ~FLAG_SMUDGE; } /* Implement ; */ ThrowCode ffSemiColon( void ) { ThrowCode exception = 0; gVarState = 0; if( (gDepthAtColon != DATA_STACK_DEPTH) && (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */ { exception = THROW_SEMICOLON; } else { ffFinishSecondary(); } gDepthAtColon = DEPTH_AT_COLON_INVALID; return exception; } /* Finish the definition of a Forth word. */ void ffFinishSecondary( void ) { CODE_COMMA( ID_EXIT ); ffUnSmudge(); } /**************************************************************/ /* Used to pull a number from the dictionary to the stack */ void ff2Literal( cell_t dHi, cell_t dLo ) { CODE_COMMA( ID_2LITERAL_P ); CODE_COMMA( dHi ); CODE_COMMA( dLo ); } void ffALiteral( cell_t Num ) { CODE_COMMA( ID_ALITERAL_P ); CODE_COMMA( Num ); } void ffLiteral( cell_t Num ) { CODE_COMMA( ID_LITERAL_P ); CODE_COMMA( Num ); } #ifdef PF_SUPPORT_FP void ffFPLiteral( PF_FLOAT fnum ) { /* Hack for Metrowerks compiler which won't compile the * original expression. */ PF_FLOAT *temp; cell_t *dicPtr; /* Make sure that literal float data is float aligned. */ dicPtr = CODE_HERE + 1; while( (((ucell_t) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0) { DBUG((" comma NOOP to align FPLiteral\n")); CODE_COMMA( ID_NOOP ); } CODE_COMMA( ID_FP_FLITERAL_P ); temp = (PF_FLOAT *)CODE_HERE; WRITE_FLOAT_DIC(temp,fnum); /* Write to dictionary. */ temp++; CODE_HERE = (cell_t *) temp; } #endif /* PF_SUPPORT_FP */ /**************************************************************/ static ThrowCode FindAndCompile( const char *theWord ) { cell_t Flag; ExecToken XT; cell_t Num; ThrowCode exception = 0; Flag = ffFind( theWord, &XT); DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag )); /* Is it a normal word ? */ if( Flag == -1 ) { if( gVarState ) /* compiling? */ { CODE_COMMA( XT ); } else { exception = pfCatch( XT ); } } else if ( Flag == 1 ) /* or is it IMMEDIATE ? */ { DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord )); exception = pfCatch( XT ); } else /* try to interpret it as a number. */ { /* Call deferred NUMBER? */ cell_t NumResult; DBUG(("FindAndCompile: not found, try number?\n" )); PUSH_DATA_STACK( theWord ); /* Push text of number */ exception = pfCatch( gNumberQ_XT ); if( exception ) goto error; DBUG(("FindAndCompile: after number?\n" )); NumResult = POP_DATA_STACK; /* Success? */ switch( NumResult ) { case NUM_TYPE_SINGLE: if( gVarState ) /* compiling? */ { Num = POP_DATA_STACK; ffLiteral( Num ); } break; case NUM_TYPE_DOUBLE: if( gVarState ) /* compiling? */ { Num = POP_DATA_STACK; /* get hi portion */ ff2Literal( Num, POP_DATA_STACK ); } break; #ifdef PF_SUPPORT_FP case NUM_TYPE_FLOAT: if( gVarState ) /* compiling? */ { ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ ); } break; #endif case NUM_TYPE_BAD: default: ioType( theWord+1, *theWord ); MSG( " ? - unrecognized word!\n" ); exception = THROW_UNDEFINED_WORD; break; } } error: return exception; } /************************************************************** ** Forth outer interpreter. Parses words from Source. ** Executes them or compiles them based on STATE. */ ThrowCode ffInterpret( void ) { cell_t flag; char *theWord; ThrowCode exception = 0; /* Is there any text left in Source ? */ while( gCurrentTask->td_IN < (gCurrentTask->td_SourceNum) ) { pfDebugMessage("ffInterpret: calling ffWord(()\n"); theWord = ffLWord( BLANK ); DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord )); if( *theWord > 0 ) { flag = 0; if( gLocalCompiler_XT ) { PUSH_DATA_STACK( theWord ); /* Push word. */ exception = pfCatch( gLocalCompiler_XT ); if( exception ) goto error; flag = POP_DATA_STACK; /* Compiled local? */ } if( flag == 0 ) { exception = FindAndCompile( theWord ); if( exception ) goto error; } } DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN, gCurrentTask->td_SourceNum ) ); } error: return exception; } /**************************************************************/ ThrowCode ffOK( void ) { cell_t exception = 0; /* Check for stack underflow. %Q what about overflows? */ if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 ) { exception = THROW_STACK_UNDERFLOW; } #ifdef PF_SUPPORT_FP /* Check floating point stack too! */ else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0) { exception = THROW_FLOAT_STACK_UNDERFLOW; } #endif else if( gCurrentTask->td_InputStream == PF_STDIN) { if( !gVarState ) /* executing? */ { if( !gVarQuiet ) { MSG( " ok\n" ); if(gVarTraceStack) ffDotS(); } else { EMIT_CR; } } } return exception; } /*************************************************************** ** Cleanup Include stack by popping and closing files. ***************************************************************/ void pfHandleIncludeError( void ) { FileStream *cur; while( (cur = ffPopInputStream()) != PF_STDIN) { DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur )); sdCloseFile(cur); } } /*************************************************************** ** Interpret input in a loop. ***************************************************************/ ThrowCode ffOuterInterpreterLoop( void ) { cell_t exception = 0; do { exception = ffRefill(); if(exception <= 0) break; exception = ffInterpret(); if( exception == 0 ) { exception = ffOK(); } } while( exception == 0 ); return exception; } /*************************************************************** ** Include then close a file ***************************************************************/ ThrowCode ffIncludeFile( FileStream *InputFile ) { ThrowCode exception; /* Push file stream. */ exception = ffPushInputStream( InputFile ); if( exception < 0 ) return exception; /* Run outer interpreter for stream. */ exception = ffOuterInterpreterLoop(); if( exception ) { int i; /* Report line number and nesting level. */ MSG("INCLUDE error on line #"); ffDot(gCurrentTask->td_LineNumber); MSG(", level = "); ffDot(gIncludeIndex ); EMIT_CR /* Dump line of error and show offset in line for >IN */ for( i=0; itd_SourceNum; i++ ) { char c = gCurrentTask->td_SourcePtr[i]; if( c == '\t' ) c = ' '; EMIT(c); } EMIT_CR; for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^'); EMIT_CR; } /* Pop file stream. */ ffPopInputStream(); /* ANSI spec specifies that this should also close the file. */ sdCloseFile(InputFile); return exception; } #endif /* !PF_NO_SHELL */ /*************************************************************** ** Save current input stream on stack, use this new one. ***************************************************************/ Err ffPushInputStream( FileStream *InputFile ) { Err Result = 0; IncludeFrame *inf; /* Push current input state onto special include stack. */ if( gIncludeIndex < MAX_INCLUDE_DEPTH ) { inf = &gIncludeStack[gIncludeIndex++]; inf->inf_FileID = gCurrentTask->td_InputStream; inf->inf_IN = gCurrentTask->td_IN; inf->inf_LineNumber = gCurrentTask->td_LineNumber; inf->inf_SourceNum = gCurrentTask->td_SourceNum; /* Copy TIB plus any NUL terminator into saved area. */ if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) ) { pfCopyMemory( inf->inf_SaveTIB, gCurrentTask->td_TIB, inf->inf_SourceNum+1 ); } /* Set new current input. */ DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile )); gCurrentTask->td_InputStream = InputFile; gCurrentTask->td_LineNumber = 0; } else { ERR("ffPushInputStream: max depth exceeded.\n"); return -1; } return Result; } /*************************************************************** ** Go back to reading previous stream. ** Just return gCurrentTask->td_InputStream upon underflow. ***************************************************************/ FileStream *ffPopInputStream( void ) { IncludeFrame *inf; FileStream *Result; DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex)); Result = gCurrentTask->td_InputStream; /* Restore input state. */ if( gIncludeIndex > 0 ) { inf = &gIncludeStack[--gIncludeIndex]; gCurrentTask->td_InputStream = inf->inf_FileID; DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask->td_InputStream )); gCurrentTask->td_IN = inf->inf_IN; gCurrentTask->td_LineNumber = inf->inf_LineNumber; gCurrentTask->td_SourceNum = inf->inf_SourceNum; /* Copy TIB plus any NUL terminator into saved area. */ if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) ) { pfCopyMemory( gCurrentTask->td_TIB, inf->inf_SaveTIB, inf->inf_SourceNum+1 ); } } DBUG(("ffPopInputStream: return = 0x%x\n", Result )); return Result; } /*************************************************************** ** Convert file pointer to value consistent with SOURCE-ID. ***************************************************************/ cell_t ffConvertStreamToSourceID( FileStream *Stream ) { cell_t Result; if(Stream == PF_STDIN) { Result = 0; } else if(Stream == NULL) { Result = -1; } else { Result = (cell_t) Stream; } return Result; } /*************************************************************** ** Convert file pointer to value consistent with SOURCE-ID. ***************************************************************/ FileStream * ffConvertSourceIDToStream( cell_t id ) { FileStream *stream; if( id == 0 ) { stream = PF_STDIN; } else if( id == -1 ) { stream = NULL; } else { stream = (FileStream *) id; } return stream; } /************************************************************** ** Receive line from input stream. ** Return length, or -1 for EOF. */ #define BACKSPACE (8) static cell_t readLineFromStream( char *buffer, cell_t maxChars, FileStream *stream ) { int c; int len; char *p; static int lastChar = 0; int done = 0; DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer, len, stream )); p = buffer; len = 0; while( (len < maxChars) && !done ) { c = sdInputChar(stream); switch(c) { case EOF: DBUG(("EOF\n")); done = 1; if( len <= 0 ) len = -1; break; case '\n': DBUGX(("EOL=\\n\n")); if( lastChar != '\r' ) done = 1; break; case '\r': DBUGX(("EOL=\\r\n")); done = 1; break; default: *p++ = (char) c; len++; break; } lastChar = c; } /* NUL terminate line to simplify printing when debugging. */ if( (len >= 0) && (len < maxChars) ) p[len] = '\0'; return len; } /************************************************************** ** ( -- , fill Source from current stream ) ** Return 1 if successful, 0 for EOF, or a negative error. */ cell_t ffRefill( void ) { cell_t Num; cell_t Result = 1; /* reset >IN for parser */ gCurrentTask->td_IN = 0; /* get line from current stream */ if( gCurrentTask->td_InputStream == PF_STDIN ) { /* ACCEPT is deferred so we call it through the dictionary. */ ThrowCode throwCode; PUSH_DATA_STACK( gCurrentTask->td_SourcePtr ); PUSH_DATA_STACK( TIB_SIZE ); throwCode = pfCatch( gAcceptP_XT ); if (throwCode) { Result = throwCode; goto error; } Num = POP_DATA_STACK; if( Num < 0 ) { Result = Num; goto error; } } else { Num = readLineFromStream( gCurrentTask->td_SourcePtr, TIB_SIZE, gCurrentTask->td_InputStream ); if( Num == EOF ) { Result = 0; Num = 0; } } gCurrentTask->td_SourceNum = Num; gCurrentTask->td_LineNumber++; /* Bump for include. */ /* echo input if requested */ if( gVarEcho && ( Num > 0)) { ioType( gCurrentTask->td_SourcePtr, gCurrentTask->td_SourceNum ); EMIT_CR; } error: return Result; } pforth-2.0.1/csrc/pfcompil.h000066400000000000000000000054271435661464300157540ustar00rootroot00000000000000/* @(#) pfcompil.h 96/12/18 1.11 */ #ifndef _pforth_compile_h #define _pforth_compile_h /*************************************************************** ** Include file for PForth Compiler ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #ifdef __cplusplus extern "C" { #endif Err ffPushInputStream( FileStream *InputFile ); ExecToken NameToToken( const ForthString *NFA ); FileStream * ffConvertSourceIDToStream( cell_t id ); FileStream *ffPopInputStream( void ); cell_t ffConvertStreamToSourceID( FileStream *Stream ); cell_t ffFind( const ForthString *WordName, ExecToken *pXT ); cell_t ffFindC( const char *WordName, ExecToken *pXT ); cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ); cell_t ffNumberQ( const char *FWord, cell_t *Num ); cell_t ffRefill( void ); 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 ); cell_t NotCompiled( const char *FunctionName ); void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags ); void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags ); void ff2Literal( cell_t dHi, cell_t dLo ); void ffALiteral( cell_t Num ); void ffColon( void ); void ffCreate( void ); void ffCreateSecondaryHeader( const ForthStringPtr FName); void ffDefer( void ); void ffFinishSecondary( void ); void ffLiteral( cell_t Num ); void ffStringCreate( ForthStringPtr FName); void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ); void pfHandleIncludeError( void ); ThrowCode ffSemiColon( void ); ThrowCode ffOK( void ); ThrowCode ffInterpret( void ); ThrowCode ffOuterInterpreterLoop( void ); ThrowCode ffIncludeFile( FileStream *InputFile ); #ifdef PF_SUPPORT_FP void ffFPLiteral( PF_FLOAT fnum ); #endif #ifdef __cplusplus } #endif #endif /* _pforth_compile_h */ pforth-2.0.1/csrc/pfcustom.c000066400000000000000000000076651435661464300160040ustar00rootroot00000000000000/* @(#) pfcustom.c 98/01/26 1.3 */ #ifndef PF_USER_CUSTOM /*************************************************************** ** Call Custom Functions for pForth ** ** Create a file similar to this and compile it into pForth ** by setting -DPF_USER_CUSTOM="mycustom.c" ** ** Using this, you could, for example, call X11 from Forth. ** See "pf_cglue.c" for more information. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #include "pf_all.h" static cell_t CTest0( cell_t Val ); static void CTest1( cell_t Val1, cell_t Val2 ); /**************************************************************** ** Step 1: Put your own special glue routines here ** or link them in from another file or library. ****************************************************************/ static cell_t CTest0( cell_t Val ) { MSG_NUM_D("CTest0: Val = ", Val); return Val+1; } static void CTest1( cell_t Val1, cell_t Val2 ) { MSG("CTest1: Val1 = "); ffDot(Val1); MSG_NUM_D(", Val2 = ", Val2); } /**************************************************************** ** Step 2: Create CustomFunctionTable. ** Do not change the name of CustomFunctionTable! ** It is used by the pForth kernel. ****************************************************************/ #ifdef PF_NO_GLOBAL_INIT /****************** ** If your loader does not support global initialization, then you ** must define PF_NO_GLOBAL_INIT and provide a function to fill ** the table. Some embedded system loaders require this! ** Do not change the name of LoadCustomFunctionTable()! ** It is called by the pForth kernel. */ #define NUM_CUSTOM_FUNCTIONS (2) CFunc0 CustomFunctionTable[NUM_CUSTOM_FUNCTIONS]; Err LoadCustomFunctionTable( void ) { CustomFunctionTable[0] = CTest0; CustomFunctionTable[1] = CTest1; return 0; } #else /****************** ** If your loader supports global initialization (most do.) then just ** create the table like this. */ CFunc0 CustomFunctionTable[] = { (CFunc0) CTest0, (CFunc0) CTest1 }; #endif /**************************************************************** ** Step 3: Add custom functions to the dictionary. ** Do not change the name of CompileCustomFunctions! ** It is called by the pForth kernel. ****************************************************************/ #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) Err CompileCustomFunctions( void ) { Err err; int i = 0; /* Compile Forth words that call your custom functions. ** Make sure order of functions matches that in LoadCustomFunctionTable(). ** Parameters are: Name in UPPER CASE, Function, Index, Mode, NumParams */ err = CreateGlueToC( "CTEST0", i++, C_RETURNS_VALUE, 1 ); if( err < 0 ) return err; err = CreateGlueToC( "CTEST1", i++, C_RETURNS_VOID, 2 ); if( err < 0 ) return err; return 0; } #else Err CompileCustomFunctions( void ) { return 0; } #endif /**************************************************************** ** Step 4: Recompile using compiler option PF_USER_CUSTOM ** and link with your code. ** Then rebuild the Forth using "pforth -i system.fth" ** Test: 10 Ctest0 ( should print message then '11' ) ****************************************************************/ #endif /* PF_USER_CUSTOM */ pforth-2.0.1/csrc/pfinnrfp.h000066400000000000000000000241271435661464300157630ustar00rootroot00000000000000/* @(#) pfinnrfp.h 98/02/26 1.4 */ /*************************************************************** ** Compile FP routines. ** This file is included from "pf_inner.c" ** ** These routines could be left out of an execute only version. ** ** Author: Darren Gibbs, Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** ***************************************************************/ #ifdef PF_SUPPORT_FP #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; Scratch = M_POP; /* dlo */ DBUG(("dlo = 0x%8x , ", Scratch)); DBUG(("dhi = 0x%8x\n", TOS)); if( ((TOS == 0) && (Scratch >= 0)) || ((TOS == -1) && (Scratch < 0))) { /* <= 32 bit precision. */ FP_TOS = ((PF_FLOAT) Scratch); /* Convert dlo and push on FP stack. */ } else /* > 32 bit precision. */ { fpTemp = ((PF_FLOAT) TOS); /* dhi */ fpTemp *= FP_DHI1; fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) ); /* Convert TOS and push on FP stack. */ FP_TOS = fpTemp + fpScratch; } M_DROP; /* printf("d2f = %g\n", FP_TOS); */ break; case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */ #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_CODE_DIC(TOS) ) { WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS ); } else { *((PF_FLOAT *) TOS) = FP_TOS; } #else *((PF_FLOAT *) TOS) = FP_TOS; #endif M_FP_DROP; /* drop FP value */ M_DROP; /* drop addr */ break; case ID_FP_FTIMES: /* ( F: r1 r2 -- r1*r2 ) */ FP_TOS = M_FP_POP * FP_TOS; break; case ID_FP_FPLUS: /* ( F: r1 r2 -- r1+r2 ) */ FP_TOS = M_FP_POP + FP_TOS; break; case ID_FP_FMINUS: /* ( F: r1 r2 -- r1-r2 ) */ FP_TOS = M_FP_POP - FP_TOS; break; case ID_FP_FSLASH: /* ( F: r1 r2 -- r1/r2 ) */ FP_TOS = M_FP_POP / FP_TOS; break; case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag ) ( F: r -- ) */ PUSH_TOS; TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ; M_FP_DROP; break; case ID_FP_F_ZERO_EQUALS: /* ( -- flag ) ( F: r -- ) */ PUSH_TOS; TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ; M_FP_DROP; break; case ID_FP_F_LESS_THAN: /* ( -- flag ) ( F: r1 r2 -- ) */ PUSH_TOS; TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ; M_FP_DROP; break; case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */ /* printf("f2d = %g\n", FP_TOS); */ { ucell_t dlo; cell_t dhi; int ifNeg; /* Convert absolute value, then negate D if negative. */ PUSH_TOS; /* Save old TOS */ fpTemp = FP_TOS; M_FP_DROP; ifNeg = (fpTemp < 0.0); if( ifNeg ) { fpTemp = 0.0 - fpTemp; } fpScratch = fpTemp / FP_DHI1; /* printf("f2d - fpScratch = %g\n", fpScratch); */ dhi = (cell_t) fpScratch; /* dhi */ fpScratch = ((PF_FLOAT) dhi) * FP_DHI1; /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */ fpTemp = fpTemp - fpScratch; /* Remainder */ dlo = (ucell_t) fpTemp; /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */ if( ifNeg ) { dlo = 0 - dlo; dhi = 0 - dhi - 1; } /* Push onto stack. */ TOS = dlo; PUSH_TOS; TOS = dhi; } break; case ID_FP_FFETCH: /* ( addr -- ) ( F: -- r ) */ PUSH_FP_TOS; #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) if( IN_CODE_DIC(TOS) ) { FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS ); } else { FP_TOS = *((PF_FLOAT *) TOS); } #else FP_TOS = *((PF_FLOAT *) TOS); #endif M_DROP; break; case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */ PUSH_TOS; /* Add 1 to account for FP_TOS in cached in register. */ TOS = (( M_FP_SPZERO - FP_STKPTR) + 1); break; case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */ M_FP_DROP; break; case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */ PUSH_FP_TOS; break; case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */ TOS = TOS + sizeof(PF_FLOAT); break; case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */ TOS = TOS * sizeof(PF_FLOAT); break; case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_floor( FP_TOS ); break; case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */ fpScratch = M_FP_POP; FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ; break; case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */ fpScratch = M_FP_POP; FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ; break; case ID_FP_FNEGATE: FP_TOS = -FP_TOS; break; case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */ PUSH_FP_TOS; FP_TOS = M_FP_STACK(1); break; case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */ fpScratch = M_FP_POP; /* r2 */ fpTemp = M_FP_POP; /* r1 */ M_FP_PUSH( fpScratch ); /* r2 */ PUSH_FP_TOS; /* r3 */ FP_TOS = fpTemp; /* r1 */ break; case ID_FP_FROUND: /* This was broken before and used to push its result to the * integer data stack! Now it conforms to the ANSI standard. * https://github.com/philburk/pforth/issues/69 */ FP_TOS = (PF_FLOAT)fp_round(FP_TOS); break; case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */ fpScratch = FP_TOS; FP_TOS = *FP_STKPTR; *FP_STKPTR = fpScratch; break; case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */ fpScratch = M_FP_POP; FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS); break; case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS ); break; case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_acos( FP_TOS ); break; case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */ /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */ FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1))); break; case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS); break; case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_asin( FP_TOS ); break; case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */ /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */ FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1))); break; case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_atan( FP_TOS ); break; case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */ fpTemp = M_FP_POP; FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS ); break; case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS))); break; case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_cos( FP_TOS ); break; case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS ); break; #ifndef PF_NO_SHELL case ID_FP_FLITERAL: ffFPLiteral( FP_TOS ); M_FP_DROP; endcase; #endif /* !PF_NO_SHELL */ case ID_FP_FLITERAL_P: PUSH_FP_TOS; #if 0 /* Some wimpy compilers can't handle this! */ FP_TOS = *(((PF_FLOAT *)InsPtr)++); #else { PF_FLOAT *fptr; fptr = (PF_FLOAT *)InsPtr; FP_TOS = READ_FLOAT_DIC( fptr++ ); InsPtr = (cell_t *) fptr; } #endif endcase; case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_log(FP_TOS); break; case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0); break; case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_log10( FP_TOS ); break; case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_sin( FP_TOS ); break; case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */ M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS)); FP_TOS = (PF_FLOAT) fp_cos(FP_TOS); break; case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS ); break; case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS ); break; case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_tan( FP_TOS ); break; case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */ FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS ); break; case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */ PUSH_FP_TOS; /* push cached floats into RAM */ FP_TOS = FP_STKPTR[TOS]; /* 0 FPICK gets top of FP stack */ M_DROP; break; #endif pforth-2.0.1/csrc/pforth.h000066400000000000000000000061211435661464300154350ustar00rootroot00000000000000/* @(#) pforth.h 98/01/26 1.2 */ #ifndef _pforth_h #define _pforth_h /*************************************************************** ** Include file for pForth, a portable Forth based on 'C' ** ** This file is included in any application that uses pForth as a library. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ** ***************************************************************/ /* Define stubs for data types so we can pass pointers but not touch inside. */ typedef void *PForthTask; typedef void *PForthDictionary; #include /* Integer types for Forth cells, signed and unsigned: */ typedef intptr_t cell_t; typedef uintptr_t ucell_t; typedef ucell_t ExecToken; /* Execution Token */ typedef cell_t ThrowCode; #ifdef __cplusplus extern "C" { #endif /* Main entry point to pForth. */ ThrowCode pfDoForth( const char *DicName, const char *SourceName, cell_t IfInit ); /* Turn off messages. */ void pfSetQuiet( cell_t IfQuiet ); /* Query message status. */ cell_t pfQueryQuiet( void ); /* Send a message using low level I/O of pForth */ void pfMessage( const char *CString ); /* Create a task used to maintain context of execution. */ PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth ); /* Establish this task as the current task. */ void pfSetCurrentTask( PForthTask task ); /* Delete task created by pfCreateTask */ void pfDeleteTask( PForthTask task ); /* Build a dictionary with all the basic kernel words. */ PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize ); /* Create an empty dictionary. */ PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize ); /* Load dictionary from a file. */ PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); /* Load dictionary from static array in "pfdicdat.h". */ PForthDictionary pfLoadStaticDictionary( void ); /* Delete dictionary data. */ void pfDeleteDictionary( PForthDictionary dict ); /* Execute the pForth interpreter. Yes, QUIT is an odd name but it has historical meaning. */ ThrowCode pfQuit( void ); /* Execute a single execution token in the current task and return 0 or an error code. */ ThrowCode pfCatch( ExecToken XT ); /* Include the given pForth source code file. */ ThrowCode pfIncludeFile( const char *FileName ); /* Execute a Forth word by name. */ ThrowCode pfExecIfDefined( const char *CString ); #ifdef __cplusplus } #endif #endif /* _pforth_h */ pforth-2.0.1/csrc/posix/000077500000000000000000000000001435661464300151245ustar00rootroot00000000000000pforth-2.0.1/csrc/posix/pf_io_posix.c000066400000000000000000000106541435661464300176140ustar00rootroot00000000000000/* $Id$ */ /*************************************************************** ** I/O subsystem for PForth based on 'C' ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 941004 PLB Extracted IO calls from pforth_main.c ** 090220 PLB Fixed broken sdQueryTerminal on Mac. It always returned true. ***************************************************************/ #include "../pf_all.h" /* Configure console so that characters are not buffered. * This allows KEY and ?TERMINAL to work and also HISTORY.ON */ #include #include #ifdef sun #include /* Needed on Solaris for uint32_t in termio.h */ #endif #include #include static struct termios save_termios; static int stdin_is_tty; /* poll() is broken in Mac OS X Tiger OS so use select() instead. */ #ifndef PF_USE_SELECT #define PF_USE_SELECT (1) #endif /* Default portable terminal I/O. */ int sdTerminalOut( char c ) { return putchar(c); } int sdTerminalEcho( char c ) { putchar(c); return 0; } int sdTerminalIn( void ) { return getchar(); } int sdTerminalFlush( void ) { #ifdef PF_NO_FILEIO return -1; #else return fflush(PF_STDOUT); #endif } /****************************************************/ int sdQueryTerminal( void ) { #if PF_USE_SELECT int select_retval; fd_set readfds; struct timeval tv; FD_ZERO(&readfds); FD_SET(STDIN_FILENO, &readfds); /* Set timeout to zero so that we just poll and return. */ tv.tv_sec = 0; tv.tv_usec = 0; select_retval = select(STDIN_FILENO+1, &readfds, NULL, NULL, &tv); if (select_retval < 0) { perror("sdTerminalInit: select"); } return FD_ISSET(STDIN_FILENO,&readfds) ? FTRUE : FFALSE; #else int result; struct pollfd pfd = { 0 }; sdTerminalFlush(); pfd.fd = STDIN_FILENO; pfd.events = POLLIN; result = poll( &pfd, 1, 0 ); /* On a Mac it may set revents to POLLNVAL because poll() is broken on Tiger. */ if( pfd.revents & POLLNVAL ) { PRT(("sdQueryTerminal: poll got POLLNVAL, stdin not open\n")); return FFALSE; } else { return (pfd.revents & POLLIN) ? FTRUE : FFALSE; } #endif } /****************************************************/ void sdTerminalInit(void) { struct termios term; stdin_is_tty = isatty(STDIN_FILENO); if (stdin_is_tty) { /* Get current terminal attributes and save them so we can restore them. */ tcgetattr(STDIN_FILENO, &term); save_termios = term; /* ICANON says to wait upon read until a character is received, * and then to return it immediately (or soon enough....) * ECHOCTL says not to echo backspaces and other control chars as ^H */ term.c_lflag &= ~( ECHO | ECHONL | ECHOCTL | ICANON ); term.c_cc[VTIME] = 0; term.c_cc[VMIN] = 1; if( tcsetattr(STDIN_FILENO, TCSANOW, &term) < 0 ) { perror("sdTerminalInit: tcsetattr"); } if (setvbuf(stdout, NULL, _IONBF, (size_t) 0) != 0) { perror("sdTerminalInit: setvbuf"); } } } /****************************************************/ void sdTerminalTerm(void) { if (stdin_is_tty) { tcsetattr(STDIN_FILENO, TCSANOW, &save_termios); } } cell_t sdSleepMillis(cell_t msec) { const cell_t kMaxMicros = 500000; /* to be safe, usleep() limit is 1000000 */ cell_t micros; cell_t napTime; if (msec < 0) return 0; micros = msec * 1000; while (micros > 0) { napTime = (micros > kMaxMicros) ? kMaxMicros : micros; if (usleep(napTime)) { perror("sdSleepMillis: usleep failed"); return -1; } micros -= napTime; } return 0; } pforth-2.0.1/csrc/sources.cmake000066400000000000000000000005151435661464300164500ustar00rootroot00000000000000sources.cmake pf_all.h pf_cglue.h pf_clib.h pf_core.h pf_float.h pf_guts.h pf_host.h pf_inc1.h pf_io.h pf_mem.h pf_save.h pf_text.h pf_types.h pf_win32.h pf_words.h pfcompfp.h pfcompil.h pfinnrfp.h pforth.h pf_cglue.c pf_clib.c pf_core.c pf_inner.c pf_io.c pf_io_none.c pf_mem.c pf_save.c pf_text.c pf_words.c pfcompil.c pfcustom.c pforth-2.0.1/csrc/stdio/000077500000000000000000000000001435661464300151045ustar00rootroot00000000000000pforth-2.0.1/csrc/stdio/pf_fileio_stdio.c000066400000000000000000000071671435661464300204210ustar00rootroot00000000000000/*************************************************************** ** File access routines based on ANSI C (no Unix stuff). ** ** This file is part of pForth ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ****************************************************************/ #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 */ pforth-2.0.1/csrc/stdio/pf_io_stdio.c000066400000000000000000000030011435661464300175400ustar00rootroot00000000000000/* $Id$ */ /*************************************************************** ** I/O subsystem for PForth for common systems. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 941004 PLB Extracted IO calls from pforth_main.c ***************************************************************/ #include "../pf_all.h" /* Default portable terminal I/O. */ int sdTerminalOut( char c ) { return putchar(c); } /* We don't need to echo because getchar() echos. */ int sdTerminalEcho( char c ) { return 0; } int sdTerminalIn( void ) { return getchar(); } int sdQueryTerminal( void ) { return 0; } int sdTerminalFlush( void ) { #ifdef PF_NO_FILEIO return -1; #else return fflush(PF_STDOUT); #endif } void sdTerminalInit( void ) { } void sdTerminalTerm( void ) { } pforth-2.0.1/csrc/win32/000077500000000000000000000000001435661464300147245ustar00rootroot00000000000000pforth-2.0.1/csrc/win32/pf_io_win32.c000066400000000000000000000036121435661464300172100ustar00rootroot00000000000000/* $Id$ */ /*************************************************************** ** I/O subsystem for PForth for WIN32 systems. ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** **************************************************************** ** 941004 PLB Extracted IO calls from pforth_main.c ***************************************************************/ #include "../pf_all.h" #include #include /* for Sleep() */ /* Use console mode I/O so that KEY and ?TERMINAL will work. */ #if defined(WIN32) || defined(__NT__) int sdTerminalOut( char c ) { #if defined(__WATCOMC__) return putch((char)(c)); #else return _putch((char)(c)); #endif } /* Needed cuz _getch() does not echo. */ int sdTerminalEcho( char c ) { #if defined(__WATCOMC__) return putch((char)(c)); #else return _putch((char)(c)); #endif } int sdTerminalIn( void ) { return _getch(); } int sdQueryTerminal( void ) { return _kbhit(); } int sdTerminalFlush( void ) { #ifdef PF_NO_FILEIO return -1; #else return fflush(PF_STDOUT); #endif } void sdTerminalInit( void ) { } void sdTerminalTerm( void ) { } cell_t sdSleepMillis(cell_t msec) { if (msec < 0) return 0; Sleep((DWORD)msec); return 0; } #endif pforth-2.0.1/csrc/win32_console/000077500000000000000000000000001435661464300164465ustar00rootroot00000000000000pforth-2.0.1/csrc/win32_console/pf_io_win32_console.c000066400000000000000000000140741435661464300224600ustar00rootroot00000000000000/* $Id$ */ /*************************************************************** ** I/O subsystem for PForth for WIN32 systems. ** ** Use Windows Console so we can add the ANSI console commands needed to support HISTORY ** ** Author: Phil Burk ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom ** ** Permission to use, copy, modify, and/or distribute this ** software for any purpose with or without fee is hereby granted. ** ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. ** ***************************************************************/ #include "../pf_all.h" #if defined(WIN32) || defined(__NT__) #include #define ASCII_ESCAPE (0x1B) static HANDLE sConsoleHandle = INVALID_HANDLE_VALUE; static int sIsConsoleValid = FALSE; typedef enum ConsoleState_e { SDCONSOLE_STATE_IDLE = 0, SDCONSOLE_STATE_GOT_ESCAPE, SDCONSOLE_STATE_GOT_BRACKET } ConsoleState; static int sConsoleState = SDCONSOLE_STATE_IDLE; static int sParam1 = 0; static CONSOLE_SCREEN_BUFFER_INFO sScreenInfo; /******************************************************************/ static void sdConsoleEmit( char c ) { /* Write a WCHAR in case we have compiled with Unicode support. * Otherwise we will see '?' printed.*/ WCHAR wc = (WCHAR) c; DWORD count; if( sIsConsoleValid ) { WriteConsoleW(sConsoleHandle, &wc, 1, &count, NULL ); } else { /* This will get called if we are redirecting to a file.*/ WriteFile(sConsoleHandle, &c, 1, &count, NULL ); } } /******************************************************************/ static void sdClearScreen( void ) { if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) { COORD XY; int numNeeded; DWORD count; XY.X = 0; XY.Y = sScreenInfo.srWindow.Top; numNeeded = sScreenInfo.dwSize.X * (sScreenInfo.srWindow.Bottom - sScreenInfo.srWindow.Top + 1); FillConsoleOutputCharacter( sConsoleHandle, ' ', numNeeded, XY, &count ); SetConsoleCursorPosition( sConsoleHandle, XY ); } } /******************************************************************/ static void sdEraseEOL( void ) { if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) { COORD savedXY; int numNeeded; DWORD count; savedXY.X = sScreenInfo.dwCursorPosition.X; savedXY.Y = sScreenInfo.dwCursorPosition.Y; numNeeded = sScreenInfo.dwSize.X - savedXY.X; FillConsoleOutputCharacter( sConsoleHandle, ' ', numNeeded, savedXY, &count ); } } /******************************************************************/ static void sdCursorBack( int dx ) { if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) { COORD XY; XY.X = sScreenInfo.dwCursorPosition.X; XY.Y = sScreenInfo.dwCursorPosition.Y; XY.X -= dx; if( XY.X < 0 ) XY.X = 0; SetConsoleCursorPosition( sConsoleHandle, XY ); } } /******************************************************************/ static void sdCursorForward( int dx ) { if( GetConsoleScreenBufferInfo( sConsoleHandle, &sScreenInfo ) ) { COORD XY; int width = sScreenInfo.dwSize.X; XY.X = sScreenInfo.dwCursorPosition.X; XY.Y = sScreenInfo.dwCursorPosition.Y; XY.X += dx; if( XY.X > width ) XY.X = width; SetConsoleCursorPosition( sConsoleHandle, XY ); } } /******************************************************************/ /* Use console mode I/O so that KEY and ?TERMINAL will work. * Parse ANSI escape sequences and call the appropriate cursor * control functions. */ int sdTerminalOut( char c ) { switch( sConsoleState ) { case SDCONSOLE_STATE_IDLE: switch( c ) { case ASCII_ESCAPE: sConsoleState = SDCONSOLE_STATE_GOT_ESCAPE; break; default: sdConsoleEmit( c ); } break; case SDCONSOLE_STATE_GOT_ESCAPE: switch( c ) { case '[': sConsoleState = SDCONSOLE_STATE_GOT_BRACKET; sParam1 = 0; break; default: sConsoleState = SDCONSOLE_STATE_IDLE; sdConsoleEmit( c ); } break; case SDCONSOLE_STATE_GOT_BRACKET: if( (c >= '0') && (c <= '9') ) { sParam1 = (sParam1 * 10) + (c - '0'); } else { sConsoleState = SDCONSOLE_STATE_IDLE; if( c == 'K') { sdEraseEOL(); } else if( c == 'D' ) { sdCursorBack( sParam1 ); } else if( c == 'C' ) { sdCursorForward( sParam1 ); } else if( (c == 'J') && (sParam1 == 2) ) { sdClearScreen(); } } break; } return 0; } /* Needed cuz _getch() does not echo. */ int sdTerminalEcho( char c ) { sdConsoleEmit((char)(c)); return 0; } int sdTerminalIn( void ) { return _getch(); } int sdQueryTerminal( void ) { return _kbhit(); } int sdTerminalFlush( void ) { #ifdef PF_NO_FILEIO return -1; #else return fflush(PF_STDOUT); #endif } void sdTerminalInit( void ) { DWORD mode = 0; sConsoleHandle = GetStdHandle( STD_OUTPUT_HANDLE ); if( GetConsoleMode( sConsoleHandle, &mode ) ) { /*printf("GetConsoleMode() mode is 0x%08X\n", mode );*/ sIsConsoleValid = TRUE; } else { /*printf("GetConsoleMode() failed\n", mode );*/ sIsConsoleValid = FALSE; } } void sdTerminalTerm( void ) { } #endif pforth-2.0.1/fth/000077500000000000000000000000001435661464300136115ustar00rootroot00000000000000pforth-2.0.1/fth/ansilocs.fth000066400000000000000000000122501435661464300161270ustar00rootroot00000000000000\ @(#) ansilocs.fth 98/01/26 1.3 \ local variable support words \ These support the ANSI standard (LOCAL) and TO words. \ \ They are built from the following low level primitives written in 'C': \ (local@) ( i+1 -- n , fetch from ith local variable ) \ (local!) ( n i+1 -- , store to ith local variable ) \ (local.entry) ( num -- , allocate stack frame for num local variables ) \ (local.exit) ( -- , free local variable stack frame ) \ local-compiler ( -- addr , variable containing CFA of locals compiler ) \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ \ 10/27/99 Fixed : foo { -- } 55 ; was entering local frame but not exiting. anew task-ansilocs.fth private{ decimal 16 constant LV_MAX_VARS \ maximum number of local variables 31 constant LV_MAX_CHARS \ maximum number of letters in name lv_max_vars lv_max_chars $array LV-NAMES variable LV-#NAMES \ number of names currently defined \ Search name table for match : LV.MATCH ( $string -- index true | $string false ) 0 swap lv-#names @ 0 ?DO i lv-names over $= IF 2drop true i LEAVE THEN LOOP swap ; : LV.COMPILE.FETCH ( index -- ) 1+ \ adjust for optimised (local@), LocalsPtr points above vars CASE 1 OF compile (1_local@) ENDOF 2 OF compile (2_local@) ENDOF 3 OF compile (3_local@) ENDOF 4 OF compile (4_local@) ENDOF 5 OF compile (5_local@) ENDOF 6 OF compile (6_local@) ENDOF 7 OF compile (7_local@) ENDOF 8 OF compile (8_local@) ENDOF dup [compile] literal compile (local@) ENDCASE ; : LV.COMPILE.STORE ( index -- ) 1+ \ adjust for optimised (local!), LocalsPtr points above vars CASE 1 OF compile (1_local!) ENDOF 2 OF compile (2_local!) ENDOF 3 OF compile (3_local!) ENDOF 4 OF compile (4_local!) ENDOF 5 OF compile (5_local!) ENDOF 6 OF compile (6_local!) ENDOF 7 OF compile (7_local!) ENDOF 8 OF compile (8_local!) ENDOF dup [compile] literal compile (local!) ENDCASE ; : LV.COMPILE.LOCAL ( $name -- handled? , check for matching locals name ) \ ." LV.COMPILER.LOCAL name = " dup count type cr lv.match IF ( index ) lv.compile.fetch true ELSE drop false THEN ; : LV.CLEANUP ( -- , restore stack frame on exit from colon def ) lv-#names @ IF compile (local.exit) THEN ; : LV.FINISH ( -- , restore stack frame on exit from colon def ) lv.cleanup lv-#names off local-compiler off ; : LV.SETUP ( -- ) 0 lv-#names ! ; : LV.TERM ." Locals turned off" cr lv-#names off local-compiler off ; if.forgotten lv.term }private : (LOCAL) ( adr len -- , ANSI local primitive ) dup IF lv-#names @ lv_max_vars >= abort" Too many local variables!" lv-#names @ lv-names place \ Warn programmer if local variable matches an existing dictionary name. lv-#names @ lv-names find nip IF ." (LOCAL) - Note: " lv-#names @ lv-names count type ." redefined as a local variable in " latest id. cr THEN 1 lv-#names +! ELSE \ Last local. Finish building local stack frame. 2drop lv-#names @ dup 0= \ fixed 10/27/99, Thanks to John Providenza IF drop ." (LOCAL) - Warning: no locals defined!" cr ELSE [compile] literal compile (local.entry) ['] lv.compile.local local-compiler ! THEN THEN ; : VALUE CREATE ( n ) , DOES> @ ; : TO ( val -- ) bl word lv.match IF ( -- index ) lv.compile.store ELSE find 0= abort" not found" >body \ point to data state @ IF \ compiling ( -- pfa ) [compile] aliteral compile ! ELSE \ executing ( -- val pfa ) ! THEN THEN ; immediate : -> ( -- ) [compile] to ; immediate : +-> ( val -- ) bl word lv.match IF ( -- index ) 1+ \ adjust for optimised (local!), LocalsPtr points above vars [compile] literal compile (local+!) ELSE find 0= abort" not found" >body \ point to data state @ IF \ compiling ( -- pfa ) [compile] aliteral compile +! ELSE \ executing ( -- val pfa ) +! THEN THEN ; immediate : : lv.setup : ; : ; lv.finish [compile] ; ; immediate : exit lv.cleanup compile exit ; immediate : does> lv.finish [compile] does> ; immediate privatize pforth-2.0.1/fth/bench.fth000066400000000000000000000105341435661464300153760ustar00rootroot00000000000000\ @(#) bench.fth 97/12/10 1.1 \ Benchmark Forth \ by Phil Burk \ 11/17/95 \ \ pForthV9 on Indy, compiled with gcc \ bench1 took 15 seconds \ bench2 took 16 seconds \ bench3 took 17 seconds \ bench4 took 17 seconds \ bench5 took 19 seconds \ sieve took 4 seconds \ \ Darren Gibbs reports that on an SGI Octane loaded with multiple users: \ bench1 took 2.8sec \ bench2 took 2.7 \ bench3 took 2.9 \ bench4 took 2.1 \ bench 5 took 2.5 \ seive took .6 \ \ HForth on Mac Quadra 800, 68040 \ bench1 took 1.73 seconds \ bench2 took 6.48 seconds \ bench3 took 2.65 seconds \ bench4 took 2.50 seconds \ bench5 took 1.91 seconds \ sieve took 0.45 seconds \ \ pForthV9 on Mac Quadra 800 \ bench1 took 40 seconds \ bench2 took 43 seconds \ bench3 took 43 seconds \ bench4 took 44 seconds \ bench5 took 42 seconds \ sieve took 20 seconds \ \ pForthV9 on PB5300, 100 MHz PPC 603 based Mac Powerbook \ bench1 took 8.6 seconds \ bench2 took 9.0 seconds \ bench3 took 9.7 seconds \ bench4 took 8.8 seconds \ bench5 took 10.3 seconds \ sieve took 2.3 seconds \ \ HForth on PB5300 \ bench1 took 1.1 seconds \ bench2 took 3.6 seconds \ bench3 took 1.7 seconds \ bench4 took 1.2 seconds \ bench5 took 1.3 seconds \ sieve took 0.2 seconds anew task-bench.fth decimal \ benchmark primitives create #do 2000000 , : t1 #do @ 0 do loop ; : t2 23 45 #do @ 0 do swap loop 2drop ; : t3 23 #do @ 0 do dup drop loop drop ; : t4 23 45 #do @ 0 do over drop loop 2drop ; : t5 #do @ 0 do 23 45 + drop loop ; : t6 23 #do @ 0 do >r r> loop drop ; : t7 23 45 67 #do @ 0 do rot loop 2drop drop ; : t8 #do @ 0 do 23 2* drop loop ; : t9 #do @ 10 / 0 do 23 5 /mod 2drop loop ; : t10 #do #do @ 0 do dup @ drop loop drop ; : foo ( noop ) ; : t11 #do @ 0 do foo loop ; \ more complex benchmarks ----------------------- \ BENCH1 - sum data --------------------------------------- create data1 23 , 45 , 67 , 89 , 111 , 222 , 333 , 444 , : sum.cells ( addr num -- sum ) 0 swap \ sum 0 DO over \ get address i cells + @ + LOOP swap drop ; : bench1 ( -- ) 200000 0 DO data1 8 sum.cells drop LOOP ; \ BENCH2 - recursive factorial -------------------------- : factorial ( n -- n! ) dup 1 > IF dup 1- recurse * ELSE drop 1 THEN ; : bench2 ( -- ) 200000 0 DO 10 factorial drop LOOP ; \ BENCH3 - DEFER ---------------------------------- defer calc.answer : answer ( n -- m ) dup + $ a5a5 xor 1000 max ; ' answer is calc.answer : bench3 1500000 0 DO i calc.answer drop LOOP ; \ BENCH4 - locals --------------------------------- : use.locals { x1 x2 | aa bb -- result } x1 2* -> aa x2 2/ -> bb x1 aa * x2 bb * + ; : bench4 400000 0 DO 234 567 use.locals drop LOOP ; \ BENCH5 - string compare ------------------------------- : match.strings { $s1 $s2 | adr1 len1 adr2 len2 -- flag } $s1 count -> len1 -> adr1 $s2 count -> len2 -> adr2 len1 len2 - IF FALSE ELSE TRUE len1 0 DO adr1 i + c@ adr2 i + c@ - IF drop FALSE leave THEN LOOP THEN ; : bench5 ( -- ) 60000 0 DO " This is a string. X foo" " This is a string. Y foo" match.strings drop LOOP ; \ SIEVE OF ERATOSTHENES from BYTE magazine ----------------------- DECIMAL 8190 CONSTANT TSIZE VARIABLE FLAGS TSIZE ALLOT : ( --- #primes ) FLAGS TSIZE 1 FILL 0 TSIZE 0 DO ( n ) I FLAGS + C@ IF I DUP + 3 + DUP I + ( I2*+3 I3*+3 ) BEGIN DUP TSIZE < ( same flag ) WHILE 0 OVER FLAGS + C! ( i' i'' ) OVER + REPEAT 2DROP 1+ THEN LOOP ; : SIEVE ." 10 iterations " CR 0 10 0 DO swap drop LOOP . ." primes " CR ; : SIEVE50 ." 50 iterations " CR 0 50 0 DO swap drop LOOP . ." primes " CR ; \ 10 iterations \ 21.5 sec Amiga Multi-Forth Indirect Threaded \ 8.82 sec Amiga 1000 running JForth \ ~5 sec SGI Indy running pForthV9 pforth-2.0.1/fth/c_struct.fth000066400000000000000000000157611435661464300161540ustar00rootroot00000000000000\ @(#) c_struct.fth 98/01/26 1.2 \ STRUCTUREs are for interfacing with 'C' programs. \ Structures are created using :STRUCT and ;STRUCT \ \ This file must be loaded before loading any .J files. \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ \ MOD: PLB 1/16/87 Use abort" instead of er.report \ MDH 4/14/87 Added sign-extend words to ..@ \ MOD: PLB 9/1/87 Add pointer to last member for debug. \ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..! \ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long \ fixed OB.COMPILE.+@/! for 0 offset \ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE \ MOD: RDG 9/19/90 Added floating point member support \ MOD: PLB 12/21/90 Optimized ..@ and ..! \ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed \ Don't need MOVEQ.L #0,D0 for 16@+WORD and 8@+WORD \ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR \ 951112 PLB Added FS@ and FS! \ This version for the pForth system. ANEW TASK-C_STRUCT decimal \ STRUCT ====================================================== : <:STRUCT> ( pfa -- , run time action for a structure) [COMPILE] CREATE @ even-up here swap dup ( -- here # # ) allot ( make room for ivars ) 0 fill ( initialize to zero ) \ immediate \ 00001 \ DOES> [compile] aliteral \ 00001 ; \ Contents of a structure definition. \ CELL 0 = size of instantiated structures \ CELL 1 = #bytes to last member name in dictionary. \ this is relative so it will work with structure \ relocation schemes like MODULE : :STRUCT ( -- , Create a 'C' structure ) \ Check pairs ob-state @ warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!" ob_def_struct ob-state ! ( set pair flags ) \ \ Create new struct defining word. CREATE here ob-current-class ! ( set current ) 0 , ( initial ivar offset ) 0 , ( location for #byte to last ) DOES> <:STRUCT> ; : ;STRUCT ( -- , terminate structure ) ob-state @ ob_def_struct = NOT abort" ;STRUCT - Missing :STRUCT above!" false ob-state ! \ Point to last member. latest ob-current-class @ body> >name - ( byte difference of NFAs ) ob-current-class @ cell+ ! \ \ Even up byte offset in case last member was BYTE. ob-current-class @ dup @ even-up swap ! ; \ Member reference words. : .. ( object -- member_address , calc addr of member ) ob.stats? drop state @ IF ?dup IF [compile] literal compile + THEN ELSE + THEN ; immediate : (S+C!) ( val addr offset -- ) + c! ; : (S+W!) ( val addr offset -- ) + w! ; : (S+!) ( val addr offset -- ) + ! ; : (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ; : compile+!bytes ( offset size -- ) \ ." compile+!bytes ( " over . dup . ." )" cr swap [compile] literal \ compile offset into word CASE cell OF compile (s+!) ENDOF 2 OF compile (s+w!) ENDOF 1 OF compile (s+c!) ENDOF -cell OF compile (s+rel!) ENDOF \ 00002 -2 OF compile (s+w!) ENDOF -1 OF compile (s+c!) ENDOF true abort" s! - illegal size!" ENDCASE ; : !BYTES ( value address size -- ) CASE cell OF ! ENDOF -cell OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002 ABS 2 OF w! ENDOF 1 OF c! ENDOF true abort" s! - illegal size!" ENDCASE ; \ These provide ways of setting and reading members values \ without knowing their size in bytes. : (S!) ( offset size -- , compile proper fetch ) state @ IF compile+!bytes ELSE ( -- value addr off size ) >r + r> !bytes THEN ; : S! ( value object -- , store value in member ) ob.stats? (s!) ; immediate : @BYTES ( addr +/-size -- value ) CASE cell OF @ ENDOF 2 OF w@ ENDOF 1 OF c@ ENDOF -cell OF @ if.rel->use ENDOF \ 00002 -2 OF w@ w->s ENDOF -1 OF c@ b->s ENDOF true abort" s@ - illegal size!" ENDCASE ; : (S+UC@) ( addr offset -- val ) + c@ ; : (S+UW@) ( addr offset -- val ) + w@ ; : (S+@) ( addr offset -- val ) + @ ; : (S+REL@) ( addr offset -- val ) + @ if.rel->use ; : (S+C@) ( addr offset -- val ) + c@ b->s ; : (S+W@) ( addr offset -- val ) + w@ w->s ; : compile+@bytes ( offset size -- ) \ ." compile+@bytes ( " over . dup . ." )" cr swap [compile] literal \ compile offset into word CASE cell OF compile (s+@) ENDOF 2 OF compile (s+uw@) ENDOF 1 OF compile (s+uc@) ENDOF -cell OF compile (s+rel@) ENDOF \ 00002 -2 OF compile (s+w@) ENDOF -1 OF compile (s+c@) ENDOF true abort" s@ - illegal size!" ENDCASE ; : (S@) ( offset size -- , compile proper fetch ) state @ IF compile+@bytes ELSE >r + r> @bytes THEN ; : S@ ( object -- value , fetch value from member ) ob.stats? (s@) ; immediate exists? F* [IF] \ 951112 Floating Point support : FLPT ( -- , declare space for a floating point value. ) 1 floats bytes ; : (S+F!) ( val addr offset -- ) + f! ; : (S+F@) ( addr offset -- val ) + f@ ; : FS! ( value object -- , fetch value from member ) ob.stats? 1 floats <> abort" FS@ with non-float!" state @ IF [compile] literal compile (s+f!) ELSE (s+f!) THEN ; immediate : FS@ ( object -- value , fetch value from member ) ob.stats? 1 floats <> abort" FS@ with non-float!" state @ IF [compile] literal compile (s+f@) ELSE (s+f@) THEN ; immediate [THEN] 0 [IF] :struct mapper long map_l1 long map_l2 short map_s1 ushort map_s2 byte map_b1 ubyte map_b2 aptr map_a1 rptr map_r1 flpt map_f1 ;struct mapper map1 ." compiling TT" cr : TT 123456 map1 s! map_l1 map1 s@ map_l1 123456 - abort" map_l1 failed!" 987654 map1 s! map_l2 map1 s@ map_l2 987654 - abort" map_l2 failed!" -500 map1 s! map_s1 map1 s@ map_s1 dup . cr -500 - abort" map_s1 failed!" -500 map1 s! map_s2 map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!" -89 map1 s! map_b1 map1 s@ map_b1 -89 - abort" map_s1 failed!" here map1 s! map_r1 map1 s@ map_r1 here - abort" map_r1 failed!" -89 map1 s! map_b2 map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!" 23.45 map1 fs! map_f1 map1 fs@ map_f1 f. ." =?= 23.45" cr ; ." Testing c_struct.fth" cr TT [THEN] pforth-2.0.1/fth/case.fth000066400000000000000000000041551435661464300152340ustar00rootroot00000000000000\ @(#) case.fth 98/01/26 1.2 \ CASE Statement \ \ This definition is based upon Wil Baden's assertion that \ >MARK >RESOLVE ?BRANCH etc. are not needed if one has IF ELSE THEN etc. \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ \ MOD: PLB 6/24/91 Check for missing ENDOF \ MOD: PLB 8/7/91 Add ?OF and RANGEOF \ MOD: PLB 11/2/99 Fixed nesting of CASE. Needed to save of-depth on stack as well as case-depth. anew TASK-CASE variable CASE-DEPTH variable OF-DEPTH : CASE ( n -- , start case statement ) ( -c- case-depth ) ?comp of-depth @ 0 of-depth ! \ 11/2/99 case-depth @ 0 case-depth ! ( allow nesting ) ; IMMEDIATE : ?OF ( n flag -- | n , doit if true ) ( -c- addr ) [compile] IF compile drop 1 case-depth +! 1 of-depth +! ; IMMEDIATE : OF ( n t -- | n , doit if match ) ( -c- addr ) ?comp compile over compile = [compile] ?OF ; IMMEDIATE : (RANGEOF?) ( n lo hi -- | n flag ) >r over ( n lo n ) <= IF dup r> ( n n hi ) <= ELSE rdrop false THEN ; : RANGEOF ( n lo hi -- | n , doit if within ) ( -c- addr ) compile (rangeof?) [compile] ?OF ; IMMEDIATE : ENDOF ( -- ) ( addr -c- addr' ) [compile] ELSE -1 of-depth +! ; IMMEDIATE : ENDCASE ( n -- ) ( old-case-depth addr' addr' ??? -- ) of-depth @ IF >newline ." Missing ENDOF in CASE!" cr abort THEN \ compile drop case-depth @ 0 ?DO [compile] THEN LOOP case-depth ! of-depth ! ; IMMEDIATE pforth-2.0.1/fth/condcomp.fth000066400000000000000000000031101435661464300161110ustar00rootroot00000000000000\ @(#) condcomp.fth 98/01/26 1.2 \ Conditional Compilation support \ \ Words: STRINGS= [IF] [ELSE] [THEN] EXISTS? \ \ Lifted from X3J14 dpANS-6 document. anew task-condcomp.fth : [ELSE] ( -- ) 1 BEGIN \ level BEGIN BL WORD \ level $word COUNT DUP \ level adr len len WHILE \ level adr len 2DUP S" [IF]" COMPARE 0= IF \ level adr len 2DROP 1+ \ level' ELSE \ level adr len 2DUP S" [ELSE]" COMPARE 0= \ level adr len flag IF \ level adr len 2DROP 1- DUP IF 1+ THEN \ level' ELSE \ level adr len S" [THEN]" COMPARE 0= IF 1- \ level' THEN THEN THEN ?DUP 0= IF EXIT THEN \ level' REPEAT 2DROP \ level REFILL 0= UNTIL \ level DROP ; IMMEDIATE : [IF] ( flag -- ) 0= IF POSTPONE [ELSE] THEN ; IMMEDIATE : [THEN] ( -- ) ; IMMEDIATE : EXISTS? ( -- flag , true if defined ) bl word find nip 0<> ; immediate : [DEFINED] ( -- flag , true if defined, ANS ) bl word find nip 0<> ; immediate : [UNDEFINED] ( -- flag , true if not defined, ANS ) bl word find nip 0= ; immediate pforth-2.0.1/fth/coretest.fth000066400000000000000000000623731435661464300161570ustar00rootroot00000000000000\ From: John Hayes S1I \ Subject: core.fr \ Date: Mon, 27 Nov 95 13:10 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. \ VERSION 1.2 \ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. \ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE \ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND \ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. \ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... \ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... \ Load test tools - Phil Burk include? testing tester.fth TESTING CORE WORDS HEX \ ------------------------------------------------------------------------ TESTING BASIC ASSUMPTIONS { -> } \ START WITH CLEAN SLATE ( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) { : BITSSET? IF 0 0 ELSE 0 THEN ; -> } { 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR ) { 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT ) { -1 BITSSET? -> 0 0 } \ ------------------------------------------------------------------------ TESTING BOOLEANS: INVERT AND OR XOR { 0 0 AND -> 0 } { 0 1 AND -> 0 } { 1 0 AND -> 0 } { 1 1 AND -> 1 } { 0 INVERT 1 AND -> 1 } { 1 INVERT 1 AND -> 0 } 0 CONSTANT 0S 0 INVERT CONSTANT 1S { 0S INVERT -> 1S } { 1S INVERT -> 0S } { 0S 0S AND -> 0S } { 0S 1S AND -> 0S } { 1S 0S AND -> 0S } { 1S 1S AND -> 1S } { 0S 0S OR -> 0S } { 0S 1S OR -> 1S } { 1S 0S OR -> 1S } { 1S 1S OR -> 1S } { 0S 0S XOR -> 0S } { 0S 1S XOR -> 1S } { 1S 0S XOR -> 1S } { 1S 1S XOR -> 0S } \ ------------------------------------------------------------------------ TESTING 2* 2/ LSHIFT RSHIFT ( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) 1S 1 RSHIFT INVERT CONSTANT MSB { MSB BITSSET? -> 0 0 } { 0S 2* -> 0S } { 1 2* -> 2 } { 4000 2* -> 8000 } { 1S 2* 1 XOR -> 1S } { MSB 2* -> 0S } { 0S 2/ -> 0S } { 1 2/ -> 0 } { 4000 2/ -> 2000 } { 1S 2/ -> 1S } \ MSB PROPOGATED { 1S 1 XOR 2/ -> 1S } { MSB 2/ MSB AND -> MSB } { 1 0 LSHIFT -> 1 } { 1 1 LSHIFT -> 2 } { 1 2 LSHIFT -> 4 } { 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT { 1S 1 LSHIFT 1 XOR -> 1S } { MSB 1 LSHIFT -> 0 } { 1 0 RSHIFT -> 1 } { 1 1 RSHIFT -> 0 } { 2 1 RSHIFT -> 1 } { 4 2 RSHIFT -> 1 } { 8000 F RSHIFT -> 1 } \ BIGGEST { MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS { MSB 1 RSHIFT 2* -> MSB } \ ------------------------------------------------------------------------ TESTING COMPARISONS: 0= = 0< < > U< MIN MAX 0 INVERT CONSTANT MAX-UINT 0 INVERT 1 RSHIFT CONSTANT MAX-INT 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT 0 INVERT 1 RSHIFT CONSTANT MID-UINT 0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 0S CONSTANT 1S CONSTANT { 0 0= -> } { 1 0= -> } { 2 0= -> } { -1 0= -> } { MAX-UINT 0= -> } { MIN-INT 0= -> } { MAX-INT 0= -> } { 0 0 = -> } { 1 1 = -> } { -1 -1 = -> } { 1 0 = -> } { -1 0 = -> } { 0 1 = -> } { 0 -1 = -> } { 0 0< -> } { -1 0< -> } { MIN-INT 0< -> } { 1 0< -> } { MAX-INT 0< -> } { 0 1 < -> } { 1 2 < -> } { -1 0 < -> } { -1 1 < -> } { MIN-INT 0 < -> } { MIN-INT MAX-INT < -> } { 0 MAX-INT < -> } { 0 0 < -> } { 1 1 < -> } { 1 0 < -> } { 2 1 < -> } { 0 -1 < -> } { 1 -1 < -> } { 0 MIN-INT < -> } { MAX-INT MIN-INT < -> } { MAX-INT 0 < -> } { 0 1 > -> } { 1 2 > -> } { -1 0 > -> } { -1 1 > -> } { MIN-INT 0 > -> } { MIN-INT MAX-INT > -> } { 0 MAX-INT > -> } { 0 0 > -> } { 1 1 > -> } { 1 0 > -> } { 2 1 > -> } { 0 -1 > -> } { 1 -1 > -> } { 0 MIN-INT > -> } { MAX-INT MIN-INT > -> } { MAX-INT 0 > -> } { 0 1 U< -> } { 1 2 U< -> } { 0 MID-UINT U< -> } { 0 MAX-UINT U< -> } { MID-UINT MAX-UINT U< -> } { 0 0 U< -> } { 1 1 U< -> } { 1 0 U< -> } { 2 1 U< -> } { MID-UINT 0 U< -> } { MAX-UINT 0 U< -> } { MAX-UINT MID-UINT U< -> } { 0 1 MIN -> 0 } { 1 2 MIN -> 1 } { -1 0 MIN -> -1 } { -1 1 MIN -> -1 } { MIN-INT 0 MIN -> MIN-INT } { MIN-INT MAX-INT MIN -> MIN-INT } { 0 MAX-INT MIN -> 0 } { 0 0 MIN -> 0 } { 1 1 MIN -> 1 } { 1 0 MIN -> 0 } { 2 1 MIN -> 1 } { 0 -1 MIN -> -1 } { 1 -1 MIN -> -1 } { 0 MIN-INT MIN -> MIN-INT } { MAX-INT MIN-INT MIN -> MIN-INT } { MAX-INT 0 MIN -> 0 } { 0 1 MAX -> 1 } { 1 2 MAX -> 2 } { -1 0 MAX -> 0 } { -1 1 MAX -> 1 } { MIN-INT 0 MAX -> 0 } { MIN-INT MAX-INT MAX -> MAX-INT } { 0 MAX-INT MAX -> MAX-INT } { 0 0 MAX -> 0 } { 1 1 MAX -> 1 } { 1 0 MAX -> 1 } { 2 1 MAX -> 2 } { 0 -1 MAX -> 0 } { 1 -1 MAX -> 1 } { 0 MIN-INT MAX -> 0 } { MAX-INT MIN-INT MAX -> MAX-INT } { MAX-INT 0 MAX -> MAX-INT } \ ------------------------------------------------------------------------ TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP { 1 2 2DROP -> } { 1 2 2DUP -> 1 2 1 2 } { 1 2 3 4 2OVER -> 1 2 3 4 1 2 } { 1 2 3 4 2SWAP -> 3 4 1 2 } { 0 ?DUP -> 0 } { 1 ?DUP -> 1 1 } { -1 ?DUP -> -1 -1 } { DEPTH -> 0 } { 0 DEPTH -> 0 1 } { 0 1 DEPTH -> 0 1 2 } { 0 DROP -> } { 1 2 DROP -> 1 } { 1 DUP -> 1 1 } { 1 2 OVER -> 1 2 1 } { 1 2 3 ROT -> 2 3 1 } { 1 2 SWAP -> 2 1 } \ ------------------------------------------------------------------------ TESTING >R R> R@ { : GR1 >R R> ; -> } { : GR2 >R R@ R> DROP ; -> } { 123 GR1 -> 123 } { 123 GR2 -> 123 } { 1S GR1 -> 1S } ( RETURN STACK HOLDS CELLS ) \ ------------------------------------------------------------------------ TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE { 0 5 + -> 5 } { 5 0 + -> 5 } { 0 -5 + -> -5 } { -5 0 + -> -5 } { 1 2 + -> 3 } { 1 -2 + -> -1 } { -1 2 + -> 1 } { -1 -2 + -> -3 } { -1 1 + -> 0 } { MID-UINT 1 + -> MID-UINT+1 } { 0 5 - -> -5 } { 5 0 - -> 5 } { 0 -5 - -> 5 } { -5 0 - -> -5 } { 1 2 - -> -1 } { 1 -2 - -> 3 } { -1 2 - -> -3 } { -1 -2 - -> 1 } { 0 1 - -> -1 } { MID-UINT+1 1 - -> MID-UINT } { 0 1+ -> 1 } { -1 1+ -> 0 } { 1 1+ -> 2 } { MID-UINT 1+ -> MID-UINT+1 } { 2 1- -> 1 } { 1 1- -> 0 } { 0 1- -> -1 } { MID-UINT+1 1- -> MID-UINT } { 0 NEGATE -> 0 } { 1 NEGATE -> -1 } { -1 NEGATE -> 1 } { 2 NEGATE -> -2 } { -2 NEGATE -> 2 } { 0 ABS -> 0 } { 1 ABS -> 1 } { -1 ABS -> 1 } { MIN-INT ABS -> MID-UINT+1 } \ ------------------------------------------------------------------------ TESTING MULTIPLY: S>D * M* UM* { 0 S>D -> 0 0 } { 1 S>D -> 1 0 } { 2 S>D -> 2 0 } { -1 S>D -> -1 -1 } { -2 S>D -> -2 -1 } { MIN-INT S>D -> MIN-INT -1 } { MAX-INT S>D -> MAX-INT 0 } { 0 0 M* -> 0 S>D } { 0 1 M* -> 0 S>D } { 1 0 M* -> 0 S>D } { 1 2 M* -> 2 S>D } { 2 1 M* -> 2 S>D } { 3 3 M* -> 9 S>D } { -3 3 M* -> -9 S>D } { 3 -3 M* -> -9 S>D } { -3 -3 M* -> 9 S>D } { 0 MIN-INT M* -> 0 S>D } { 1 MIN-INT M* -> MIN-INT S>D } { 2 MIN-INT M* -> 0 1S } { 0 MAX-INT M* -> 0 S>D } { 1 MAX-INT M* -> MAX-INT S>D } { 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 } { MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT } { MAX-INT MIN-INT M* -> MSB MSB 2/ } { MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT } { 0 0 * -> 0 } \ TEST IDENTITIES { 0 1 * -> 0 } { 1 0 * -> 0 } { 1 2 * -> 2 } { 2 1 * -> 2 } { 3 3 * -> 9 } { -3 3 * -> -9 } { 3 -3 * -> -9 } { -3 -3 * -> 9 } { MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 } { MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 } { MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 } { 0 0 UM* -> 0 0 } { 0 1 UM* -> 0 0 } { 1 0 UM* -> 0 0 } { 1 2 UM* -> 2 0 } { 2 1 UM* -> 2 0 } { 3 3 UM* -> 9 0 } { MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 } { MID-UINT+1 2 UM* -> 0 1 } { MID-UINT+1 4 UM* -> 0 2 } { 1S 2 UM* -> 1S 1 LSHIFT 1 } { MAX-UINT MAX-UINT UM* -> 1 1 INVERT } \ ------------------------------------------------------------------------ TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD { 0 S>D 1 FM/MOD -> 0 0 } { 1 S>D 1 FM/MOD -> 0 1 } { 2 S>D 1 FM/MOD -> 0 2 } { -1 S>D 1 FM/MOD -> 0 -1 } { -2 S>D 1 FM/MOD -> 0 -2 } { 0 S>D -1 FM/MOD -> 0 0 } { 1 S>D -1 FM/MOD -> 0 -1 } { 2 S>D -1 FM/MOD -> 0 -2 } { -1 S>D -1 FM/MOD -> 0 1 } { -2 S>D -1 FM/MOD -> 0 2 } { 2 S>D 2 FM/MOD -> 0 1 } { -1 S>D -1 FM/MOD -> 0 1 } { -2 S>D -2 FM/MOD -> 0 1 } { 7 S>D 3 FM/MOD -> 1 2 } { 7 S>D -3 FM/MOD -> -2 -3 } { -7 S>D 3 FM/MOD -> 2 -3 } { -7 S>D -3 FM/MOD -> -1 2 } { MAX-INT S>D 1 FM/MOD -> 0 MAX-INT } { MIN-INT S>D 1 FM/MOD -> 0 MIN-INT } { MAX-INT S>D MAX-INT FM/MOD -> 0 1 } { MIN-INT S>D MIN-INT FM/MOD -> 0 1 } { 1S 1 4 FM/MOD -> 3 MAX-INT } { 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT } { 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 } { 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT } { 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 } { 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT } { 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 } { 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT } { 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 } { MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT } { MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT } { MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT } { MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT } { 0 S>D 1 SM/REM -> 0 0 } { 1 S>D 1 SM/REM -> 0 1 } { 2 S>D 1 SM/REM -> 0 2 } { -1 S>D 1 SM/REM -> 0 -1 } { -2 S>D 1 SM/REM -> 0 -2 } { 0 S>D -1 SM/REM -> 0 0 } { 1 S>D -1 SM/REM -> 0 -1 } { 2 S>D -1 SM/REM -> 0 -2 } { -1 S>D -1 SM/REM -> 0 1 } { -2 S>D -1 SM/REM -> 0 2 } { 2 S>D 2 SM/REM -> 0 1 } { -1 S>D -1 SM/REM -> 0 1 } { -2 S>D -2 SM/REM -> 0 1 } { 7 S>D 3 SM/REM -> 1 2 } { 7 S>D -3 SM/REM -> 1 -2 } { -7 S>D 3 SM/REM -> -1 -2 } { -7 S>D -3 SM/REM -> -1 2 } { MAX-INT S>D 1 SM/REM -> 0 MAX-INT } { MIN-INT S>D 1 SM/REM -> 0 MIN-INT } { MAX-INT S>D MAX-INT SM/REM -> 0 1 } { MIN-INT S>D MIN-INT SM/REM -> 0 1 } { 1S 1 4 SM/REM -> 3 MAX-INT } { 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT } { 2 MIN-INT M* MIN-INT SM/REM -> 0 2 } { 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT } { 2 MAX-INT M* MAX-INT SM/REM -> 0 2 } { MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT } { MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT } { MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT } { MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT } { 0 0 1 UM/MOD -> 0 0 } { 1 0 1 UM/MOD -> 0 1 } { 1 0 2 UM/MOD -> 1 0 } { 3 0 2 UM/MOD -> 1 1 } { MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT } { MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 } { MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT } : IFFLOORED [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; : IFSYM [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; \ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. \ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. IFFLOORED : T/MOD >R S>D R> FM/MOD ; IFFLOORED : T/ T/MOD SWAP DROP ; IFFLOORED : TMOD T/MOD DROP ; IFFLOORED : T*/MOD >R M* R> FM/MOD ; IFFLOORED : T*/ T*/MOD SWAP DROP ; IFSYM : T/MOD >R S>D R> SM/REM ; IFSYM : T/ T/MOD SWAP DROP ; IFSYM : TMOD T/MOD DROP ; IFSYM : T*/MOD >R M* R> SM/REM ; IFSYM : T*/ T*/MOD SWAP DROP ; { 0 1 /MOD -> 0 1 T/MOD } { 1 1 /MOD -> 1 1 T/MOD } { 2 1 /MOD -> 2 1 T/MOD } { -1 1 /MOD -> -1 1 T/MOD } { -2 1 /MOD -> -2 1 T/MOD } { 0 -1 /MOD -> 0 -1 T/MOD } { 1 -1 /MOD -> 1 -1 T/MOD } { 2 -1 /MOD -> 2 -1 T/MOD } { -1 -1 /MOD -> -1 -1 T/MOD } { -2 -1 /MOD -> -2 -1 T/MOD } { 2 2 /MOD -> 2 2 T/MOD } { -1 -1 /MOD -> -1 -1 T/MOD } { -2 -2 /MOD -> -2 -2 T/MOD } { 7 3 /MOD -> 7 3 T/MOD } { 7 -3 /MOD -> 7 -3 T/MOD } { -7 3 /MOD -> -7 3 T/MOD } { -7 -3 /MOD -> -7 -3 T/MOD } { MAX-INT 1 /MOD -> MAX-INT 1 T/MOD } { MIN-INT 1 /MOD -> MIN-INT 1 T/MOD } { MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD } { MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD } { 0 1 / -> 0 1 T/ } { 1 1 / -> 1 1 T/ } { 2 1 / -> 2 1 T/ } { -1 1 / -> -1 1 T/ } { -2 1 / -> -2 1 T/ } { 0 -1 / -> 0 -1 T/ } { 1 -1 / -> 1 -1 T/ } { 2 -1 / -> 2 -1 T/ } { -1 -1 / -> -1 -1 T/ } { -2 -1 / -> -2 -1 T/ } { 2 2 / -> 2 2 T/ } { -1 -1 / -> -1 -1 T/ } { -2 -2 / -> -2 -2 T/ } { 7 3 / -> 7 3 T/ } { 7 -3 / -> 7 -3 T/ } { -7 3 / -> -7 3 T/ } { -7 -3 / -> -7 -3 T/ } { MAX-INT 1 / -> MAX-INT 1 T/ } { MIN-INT 1 / -> MIN-INT 1 T/ } { MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ } { MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ } { 0 1 MOD -> 0 1 TMOD } { 1 1 MOD -> 1 1 TMOD } { 2 1 MOD -> 2 1 TMOD } { -1 1 MOD -> -1 1 TMOD } { -2 1 MOD -> -2 1 TMOD } { 0 -1 MOD -> 0 -1 TMOD } { 1 -1 MOD -> 1 -1 TMOD } { 2 -1 MOD -> 2 -1 TMOD } { -1 -1 MOD -> -1 -1 TMOD } { -2 -1 MOD -> -2 -1 TMOD } { 2 2 MOD -> 2 2 TMOD } { -1 -1 MOD -> -1 -1 TMOD } { -2 -2 MOD -> -2 -2 TMOD } { 7 3 MOD -> 7 3 TMOD } { 7 -3 MOD -> 7 -3 TMOD } { -7 3 MOD -> -7 3 TMOD } { -7 -3 MOD -> -7 -3 TMOD } { MAX-INT 1 MOD -> MAX-INT 1 TMOD } { MIN-INT 1 MOD -> MIN-INT 1 TMOD } { MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD } { MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD } { 0 2 1 */ -> 0 2 1 T*/ } { 1 2 1 */ -> 1 2 1 T*/ } { 2 2 1 */ -> 2 2 1 T*/ } { -1 2 1 */ -> -1 2 1 T*/ } { -2 2 1 */ -> -2 2 1 T*/ } { 0 2 -1 */ -> 0 2 -1 T*/ } { 1 2 -1 */ -> 1 2 -1 T*/ } { 2 2 -1 */ -> 2 2 -1 T*/ } { -1 2 -1 */ -> -1 2 -1 T*/ } { -2 2 -1 */ -> -2 2 -1 T*/ } { 2 2 2 */ -> 2 2 2 T*/ } { -1 2 -1 */ -> -1 2 -1 T*/ } { -2 2 -2 */ -> -2 2 -2 T*/ } { 7 2 3 */ -> 7 2 3 T*/ } { 7 2 -3 */ -> 7 2 -3 T*/ } { -7 2 3 */ -> -7 2 3 T*/ } { -7 2 -3 */ -> -7 2 -3 T*/ } { MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ } { MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ } { 0 2 1 */MOD -> 0 2 1 T*/MOD } { 1 2 1 */MOD -> 1 2 1 T*/MOD } { 2 2 1 */MOD -> 2 2 1 T*/MOD } { -1 2 1 */MOD -> -1 2 1 T*/MOD } { -2 2 1 */MOD -> -2 2 1 T*/MOD } { 0 2 -1 */MOD -> 0 2 -1 T*/MOD } { 1 2 -1 */MOD -> 1 2 -1 T*/MOD } { 2 2 -1 */MOD -> 2 2 -1 T*/MOD } { -1 2 -1 */MOD -> -1 2 -1 T*/MOD } { -2 2 -1 */MOD -> -2 2 -1 T*/MOD } { 2 2 2 */MOD -> 2 2 2 T*/MOD } { -1 2 -1 */MOD -> -1 2 -1 T*/MOD } { -2 2 -2 */MOD -> -2 2 -2 T*/MOD } { 7 2 3 */MOD -> 7 2 3 T*/MOD } { 7 2 -3 */MOD -> 7 2 -3 T*/MOD } { -7 2 3 */MOD -> -7 2 3 T*/MOD } { -7 2 -3 */MOD -> -7 2 -3 T*/MOD } { MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD } { MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD } \ ------------------------------------------------------------------------ TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT HERE 1 ALLOT HERE CONSTANT 2NDA CONSTANT 1STA { 1STA 2NDA U< -> } \ HERE MUST GROW WITH ALLOT { 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT ( MISSING TEST: NEGATIVE ALLOT ) HERE 1 , HERE 2 , CONSTANT 2ND CONSTANT 1ST { 1ST 2ND U< -> } \ HERE MUST GROW WITH ALLOT { 1ST CELL+ -> 2ND } \ ... BY ONE CELL { 1ST 1 CELLS + -> 2ND } { 1ST @ 2ND @ -> 1 2 } { 5 1ST ! -> } { 1ST @ 2ND @ -> 5 2 } { 6 2ND ! -> } { 1ST @ 2ND @ -> 5 6 } { 1ST 2@ -> 6 5 } { 2 1 1ST 2! -> } { 1ST 2@ -> 2 1 } { 1S 1ST ! 1ST @ -> 1S } \ CAN STORE CELL-WIDE VALUE HERE 1 C, HERE 2 C, CONSTANT 2NDC CONSTANT 1STC { 1STC 2NDC U< -> } \ HERE MUST GROW WITH ALLOT { 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR { 1STC 1 CHARS + -> 2NDC } { 1STC C@ 2NDC C@ -> 1 2 } { 3 1STC C! -> } { 1STC C@ 2NDC C@ -> 3 2 } { 4 2NDC C! -> } { 1STC C@ 2NDC C@ -> 3 4 } ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT CONSTANT A-ADDR CONSTANT UA-ADDR { UA-ADDR ALIGNED -> A-ADDR } { 1 A-ADDR C! A-ADDR C@ -> 1 } { 1234 A-ADDR ! A-ADDR @ -> 1234 } { 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 } { 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 } { 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 } { 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 } { 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 } : BITS ( X -- U ) 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; ( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) { 1 CHARS 1 < -> } { 1 CHARS 1 CELLS > -> } ( TBD: HOW TO FIND NUMBER OF BITS? ) ( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) { 1 CELLS 1 < -> } { 1 CELLS 1 CHARS MOD -> 0 } { 1S BITS 10 < -> } { 0 1ST ! -> } { 1 1ST +! -> } { 1ST @ -> 1 } { -1 1ST +! 1ST @ -> 0 } \ ------------------------------------------------------------------------ TESTING CHAR [CHAR] [ ] BL S" { BL -> 20 } { CHAR X -> 58 } { CHAR HELLO -> 48 } { : GC1 [CHAR] X ; -> } { : GC2 [CHAR] HELLO ; -> } { GC1 -> 58 } { GC2 -> 48 } { : GC3 [ GC1 ] LITERAL ; -> } { GC3 -> 58 } { : GC4 S" XY" ; -> } { GC4 SWAP DROP -> 2 } { GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 } \ ------------------------------------------------------------------------ TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE { : GT1 123 ; -> } { ' GT1 EXECUTE -> 123 } { : GT2 ['] GT1 ; IMMEDIATE -> } { GT2 EXECUTE -> 123 } HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING { GT1STRING FIND -> ' GT1 -1 } { GT2STRING FIND -> ' GT2 1 } ( HOW TO SEARCH FOR NON-EXISTENT WORD? ) { : GT3 GT2 LITERAL ; -> } { GT3 -> ' GT1 } { GT1STRING COUNT -> GT1STRING CHAR+ 3 } { : GT4 POSTPONE GT1 ; IMMEDIATE -> } { : GT5 GT4 ; -> } { GT5 -> 123 } { : GT6 345 ; IMMEDIATE -> } { : GT7 POSTPONE GT6 ; -> } { GT7 -> 345 } { : GT8 STATE @ ; IMMEDIATE -> } { GT8 -> 0 } { : GT9 GT8 LITERAL ; -> } { GT9 0= -> } \ ------------------------------------------------------------------------ TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE { : GI1 IF 123 THEN ; -> } { : GI2 IF 123 ELSE 234 THEN ; -> } { 0 GI1 -> } { 1 GI1 -> 123 } { -1 GI1 -> 123 } { 0 GI2 -> 234 } { 1 GI2 -> 123 } { -1 GI1 -> 123 } { : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> } { 0 GI3 -> 0 1 2 3 4 5 } { 4 GI3 -> 4 5 } { 5 GI3 -> 5 } { 6 GI3 -> 6 } { : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> } { 3 GI4 -> 3 4 5 6 } { 5 GI4 -> 5 6 } { 6 GI4 -> 6 7 } { : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> } { 1 GI5 -> 1 345 } { 2 GI5 -> 2 345 } { 3 GI5 -> 3 4 5 123 } { 4 GI5 -> 4 5 123 } { 5 GI5 -> 5 123 } { : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> } { 0 GI6 -> 0 } { 1 GI6 -> 0 1 } { 2 GI6 -> 0 1 2 } { 3 GI6 -> 0 1 2 3 } { 4 GI6 -> 0 1 2 3 4 } \ ------------------------------------------------------------------------ TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT { : GD1 DO I LOOP ; -> } { 4 1 GD1 -> 1 2 3 } { 2 -1 GD1 -> -1 0 1 } { MID-UINT+1 MID-UINT GD1 -> MID-UINT } { : GD2 DO I -1 +LOOP ; -> } { 1 4 GD2 -> 4 3 2 1 } { -1 2 GD2 -> 2 1 0 -1 } { MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT } { : GD3 DO 1 0 DO J LOOP LOOP ; -> } { 4 1 GD3 -> 1 2 3 } { 2 -1 GD3 -> -1 0 1 } { MID-UINT+1 MID-UINT GD3 -> MID-UINT } { : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> } { 1 4 GD4 -> 4 3 2 1 } { -1 2 GD4 -> 2 1 0 -1 } { MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT } { : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> } { 1 GD5 -> 123 } { 5 GD5 -> 123 } { 6 GD5 -> 234 } { : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) 0 SWAP 0 DO I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP LOOP ; -> } { 1 GD6 -> 1 } { 2 GD6 -> 3 } { 3 GD6 -> 4 1 2 } \ ------------------------------------------------------------------------ TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY { 123 CONSTANT X123 -> } { X123 -> 123 } { : EQU CONSTANT ; -> } { X123 EQU Y123 -> } { Y123 -> 123 } { VARIABLE V1 -> } { 123 V1 ! -> } { V1 @ -> 123 } { : NOP : POSTPONE ; ; -> } { NOP NOP1 NOP NOP2 -> } { NOP1 -> } { NOP2 -> } { : DOES1 DOES> @ 1 + ; -> } { : DOES2 DOES> @ 2 + ; -> } { CREATE CR1 -> } { CR1 -> HERE } { ' CR1 >BODY -> HERE } { 1 , -> } { CR1 @ -> 1 } { DOES1 -> } { CR1 -> 2 } { DOES2 -> } { CR1 -> 3 } { : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> } { WEIRD: W1 -> } { ' W1 >BODY -> HERE } { W1 -> HERE 1 + } { W1 -> HERE 2 + } \ ------------------------------------------------------------------------ TESTING EVALUATE : GE1 S" 123" ; IMMEDIATE : GE2 S" 123 1+" ; IMMEDIATE : GE3 S" : GE4 345 ;" ; : GE5 EVALUATE ; IMMEDIATE { GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE ) { GE2 EVALUATE -> 124 } { GE3 EVALUATE -> } { GE4 -> 345 } { : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE ) { GE6 -> 123 } { : GE7 GE2 GE5 ; -> } { GE7 -> 124 } \ ------------------------------------------------------------------------ TESTING SOURCE >IN WORD : GS1 S" SOURCE" 2DUP EVALUATE >R SWAP >R = R> R> = ; { GS1 -> } VARIABLE SCANS : RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; { 2 SCANS ! 345 RESCAN? -> 345 345 } : GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; { GS2 -> 123 123 123 123 123 } : GS3 WORD COUNT SWAP C@ ; { BL GS3 HELLO -> 5 CHAR H } { CHAR " GS3 GOODBYE" -> 7 CHAR G } { BL GS3 DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING : GS4 SOURCE >IN ! DROP ; { GS4 123 456 -> } \ ------------------------------------------------------------------------ TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL : S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH R> ?DUP IF \ IF NON-EMPTY STRINGS 0 DO OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN SWAP CHAR+ SWAP CHAR+ LOOP THEN 2DROP \ IF WE GET HERE, STRINGS MATCH ELSE R> DROP 2DROP \ LENGTHS MISMATCH THEN ; : GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; { GP1 -> } : GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; { GP2 -> } : GP3 <# 1 0 # # #> S" 01" S= ; { GP3 -> } : GP4 <# 1 0 #S #> S" 1" S= ; { GP4 -> } 24 CONSTANT MAX-BASE \ BASE 2 .. 36 : COUNT-BITS 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD : GP5 BASE @ MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE I BASE ! \ TBD: ASSUMES BASE WORKS I 0 <# #S #> S" 10" S= AND LOOP SWAP BASE ! ; { GP5 -> } : GP6 BASE @ >R 2 BASE ! MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY R> BASE ! \ S: C-ADDR U DUP #BITS-UD = SWAP 0 DO \ S: C-ADDR FLAG OVER C@ [CHAR] 1 = AND \ ALL ONES >R CHAR+ R> LOOP SWAP DROP ; { GP6 -> } : GP7 BASE @ >R MAX-BASE BASE ! A 0 DO I 0 <# #S #> 1 = SWAP C@ I 30 + = AND AND LOOP MAX-BASE A DO I 0 <# #S #> 1 = SWAP C@ 41 I A - + = AND AND LOOP R> BASE ! ; { GP7 -> } \ >NUMBER TESTS CREATE GN-BUF 0 C, : GN-STRING GN-BUF 1 ; : GN-CONSUMED GN-BUF CHAR+ 0 ; : GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; { 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED } { 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED } { 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED } { 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE { 0 0 GN' +' >NUMBER -> 0 0 GN-STRING } { 0 0 GN' .' >NUMBER -> 0 0 GN-STRING } : >NUMBER-BASED BASE @ >R BASE ! >NUMBER R> BASE ! ; { 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED } { 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING } { 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED } { 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING } { 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED } { 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED } : GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. BASE @ >R BASE ! <# #S #> 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY R> BASE ! ; { 0 0 2 GN1 -> 0 0 0 } { MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 } { MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 } { 0 0 MAX-BASE GN1 -> 0 0 0 } { MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 } { MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 } : GN2 \ ( -- 16 10 ) BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; { GN2 -> 10 A } \ ------------------------------------------------------------------------ TESTING FILL MOVE CREATE FBUF 00 C, 00 C, 00 C, CREATE SBUF 12 C, 34 C, 56 C, : SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; { FBUF 0 20 FILL -> } { SEEBUF -> 00 00 00 } { FBUF 1 20 FILL -> } { SEEBUF -> 20 00 00 } { FBUF 3 20 FILL -> } { SEEBUF -> 20 20 20 } { FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE { SEEBUF -> 20 20 20 } { SBUF FBUF 0 CHARS MOVE -> } { SEEBUF -> 20 20 20 } { SBUF FBUF 1 CHARS MOVE -> } { SEEBUF -> 12 20 20 } { SBUF FBUF 3 CHARS MOVE -> } { SEEBUF -> 12 34 56 } { FBUF FBUF CHAR+ 2 CHARS MOVE -> } { SEEBUF -> 12 12 34 } { FBUF CHAR+ FBUF 2 CHARS MOVE -> } { SEEBUF -> 12 34 34 } \ ------------------------------------------------------------------------ TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. : OUTPUT-TEST ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR 41 BL DO I EMIT LOOP CR 61 41 DO I EMIT LOOP CR 7F 61 DO I EMIT LOOP CR ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR 9 1+ 0 DO I . LOOP CR ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR ." YOU SHOULD SEE TWO SEPARATE LINES:" CR S" LINE 1" TYPE CR S" LINE 2" TYPE CR ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR ." SIGNED: " MIN-INT . MAX-INT . CR ." UNSIGNED: " 0 U. MAX-UINT U. CR ; { OUTPUT-TEST -> } \ ------------------------------------------------------------------------ TESTING INPUT: ACCEPT CREATE ABUF 80 CHARS ALLOT : ACCEPT-TEST CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR ABUF 80 ACCEPT CR ." RECEIVED: " [CHAR] " EMIT ABUF SWAP TYPE [CHAR] " EMIT CR ; { ACCEPT-TEST -> } \ ------------------------------------------------------------------------ TESTING DICTIONARY SEARCH RULES { : GDX 123 ; : GDX GDX 234 ; -> } { GDX -> 123 234 } pforth-2.0.1/fth/file.fth000066400000000000000000000113601435661464300152340ustar00rootroot00000000000000\ READ-LINE and WRITE-LINE \ \ This code is part of pForth. \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 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 pforth-2.0.1/fth/filefind.fth000066400000000000000000000055261435661464300161040ustar00rootroot00000000000000\ @(#) filefind.fth 98/01/26 1.2 \ FILE? ( -- , report which file this Forth word was defined in ) \ \ FILE? looks for ::::Filename and ;;;; in the dictionary \ that have been left by INCLUDE. It figures out nested \ includes and reports each file that defines the word. \ \ Author: Phil Burk \ Copyright 1992 Phil Burk \ \ 00001 PLB 2/21/92 Handle words from kernel or keyboard. \ Support EACH.FILE? \ 961213 PLB Port to pForth. ANEW TASK-FILEFIND.FTH : BE@ { addr | val -- val , fetch from unaligned address in BigEndian order } 4 0 DO addr i + c@ val 8 lshift or -> val LOOP val ; : BE! { val addr -- , store to unaligned address in BigEndian order } 4 0 DO val 3 i - 8 * rshift addr i + c! LOOP ; : BEW@ { addr -- , fetch word from unaligned address in BigEndian order } addr c@ 8 lshift addr 1+ c@ OR ; : BEW! { val addr -- , store word to unaligned address in BigEndian order } val 8 rshift addr c! val addr 1+ c! ; \ scan dictionary from NFA for filename : F?.SEARCH.NFA { nfa | dpth stoploop keyb nfa0 -- addr count } 0 -> dpth 0 -> stoploop 0 -> keyb nfa -> nfa0 BEGIN nfa prevname -> nfa nfa 0> IF nfa 1+ be@ CASE $ 3a3a3a3a ( :::: ) OF dpth 0= IF nfa count 31 and 4 - swap 4 + swap true -> stoploop ELSE -1 dpth + -> dpth THEN ENDOF $ 3b3b3b3b ( ;;;; ) OF 1 dpth + -> dpth true -> keyb \ maybe from keyboard ENDOF ENDCASE ELSE true -> stoploop keyb IF " keyboard" ELSE " 'C' kernel" THEN count THEN stoploop UNTIL ; : FINDNFA.FROM { $name start_nfa -- nfa true | $word false } context @ >r start_nfa context ! $name findnfa r> context ! ; \ Search entire dictionary for all occurences of named word. : FILE? { | $word nfa done? -- , take name from input } 0 -> done? bl word -> $word $word findnfa IF ( -- nfa ) $word count type ." from:" cr -> nfa BEGIN nfa f?.search.nfa ( addr cnt ) nfa name> 12 .r \ print xt 4 spaces type cr nfa prevname dup -> nfa 0> IF $word nfa findnfa.from \ search from one behind found nfa swap -> nfa not ELSE true THEN UNTIL ELSE ( -- $word ) count type ." not found!" cr THEN ; pforth-2.0.1/fth/floats.fth000066400000000000000000000305561435661464300156150ustar00rootroot00000000000000\ @(#) floats.fth 98/02/26 1.4 17:51:40 \ High Level Forth support for Floating Point \ \ Author: Phil Burk and Darren Gibbs \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ \ 19970702 PLB Drop 0.0 in REPRESENT to fix 0.0 F. \ 19980220 PLB Added FG. , fixed up large and small formatting \ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix 0.0 F. (!!!) \ Fixed F~ by using (F.EXACTLY) ANEW TASK-FLOATS.FTH : FALIGNED ( addr -- a-addr ) 1 floats 1- + 1 floats / 1 floats * ; : FALIGN ( -- , align DP ) dp @ faligned dp ! ; \ account for size of create when aligning floats here create fp-create-size fp-create-size swap - constant CREATE_SIZE : FALIGN.CREATE ( -- , align DP for float after CREATE ) dp @ CREATE_SIZE + faligned CREATE_SIZE - dp ! ; : FCREATE ( -- , create with float aligned data ) falign.create CREATE ; : FVARIABLE ( -- ) ( F: -- ) FCREATE 1 floats allot ; : FCONSTANT FCREATE here 1 floats allot f! DOES> f@ ; : F0SP ( -- ) ( F: ? -- ) fdepth 0 max 0 ?DO fdrop LOOP ; \ Floating point structure member. : FFIELD: ( n1 "name" -- n2 ; addr1 -- addr2 ) FALIGNED 1 FLOATS +FIELD ; \ Convert between single precision integer and floating point : S>F ( s -- ) ( F: -- r ) s>d d>f ; : F>S ( -- s ) ( F: r -- ) f>d d>s ; : (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells } 1 floats -> fsize fsize cell 1- + cell 1- invert and \ round up to nearest multiple of stack size cell / -> fcells ( number of cells per float ) \ make room on data stack for floats data fcells 0 ?DO 0 LOOP sp@ -> caddr1 fcells 0 ?DO 0 LOOP sp@ -> caddr2 \ compare bit representation caddr1 f! caddr2 f! caddr1 fsize caddr2 fsize compare 0= >r fcells 2* 0 ?DO drop LOOP r> \ drop float bits ; : F~ ( -0- flag ) ( r1 r2 r3 -f- ) fdup F0< IF frot frot ( -- r3 r1 r2 ) fover fover ( -- r3 r1 r2 r1 r2 ) f- fabs ( -- r3 r1 r2 |r1-r2| ) frot frot ( -- r3 |r1-r2| r1 r2 ) fabs fswap fabs f+ ( -- r3 |r1-r2| |r1|+|r2| ) frot fabs f* ( -- |r1-r2| |r1|+|r2|*|r3| ) f< ELSE fdup f0= IF fdrop (f.exactly) \ f- f0= \ 19980812 Used to cheat. Now actually compares bit patterns. ELSE frot frot ( -- r3 r1 r2 ) f- fabs ( -- r3 |r1-r2| ) fswap f< THEN THEN ; \ FP Output -------------------------------------------------------- fvariable FVAR-REP \ scratch var for represent : REPRESENT { c-addr u | n flag1 flag2 -- n flag1 flag2 , FLOATING } ( F: r -- ) TRUE -> flag2 \ FIXME - need to check range fvar-rep f! \ fvar-rep f@ f0< IF -1 -> flag1 fvar-rep f@ fabs fvar-rep f! \ absolute value ELSE 0 -> flag1 THEN \ fvar-rep f@ f0= IF \ fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F." c-addr u [char] 0 fill 0 -> n ELSE fvar-rep f@ flog fdup f0< not IF 1 s>f f+ \ round up exponent THEN f>s -> n \ ." REP - n = " n . cr \ normalize r to u digits fvar-rep f@ 10 s>f u n - s>f f** f* 1 s>f 2 s>f f/ f+ \ round result \ \ convert float to double_int then convert to text f>d \ ." REP - d = " over . dup . cr <# u 1- 0 ?DO # loop #s #> \ ( -- addr cnt ) \ Adjust exponent if rounding caused number of digits to increase. \ For example from 9999 to 10000. u - +-> n c-addr u move THEN \ n flag1 flag2 ; variable FP-PRECISION \ Set maximum digits that are meaningful for the precision that we use. 1 FLOATS 4 / 7 * constant FP_PRECISION_MAX : PRECISION ( -- u ) fp-precision @ ; : SET-PRECISION ( u -- ) fp_precision_max min fp-precision ! ; 7 set-precision 32 constant FP_REPRESENT_SIZE 64 constant FP_OUTPUT_SIZE create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot \ used with REPRESENT create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot \ used to assemble final output variable FP-OUTPUT-PTR \ points into FP-OUTPUT-PAD : FP.HOLD ( char -- , add char to output ) fp-output-ptr @ fp-output-pad 64 + < IF fp-output-ptr @ tuck c! 1+ fp-output-ptr ! ELSE drop THEN ; : FP.APPEND { addr cnt -- , add string to output } cnt 0 max 0 ?DO addr i + c@ fp.hold LOOP ; : FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output ) BEGIN fp-output-ptr @ fp-output-pad u> fp-output-ptr @ 1- c@ [char] 0 = and WHILE -1 fp-output-ptr +! REPEAT ; : FP.APPEND.ZEROS ( numZeros -- ) 0 max 0 ?DO [char] 0 fp.hold LOOP ; : FP.MOVE.DECIMAL { n prec -- , append with decimal point shifted } fp-represent-pad n prec min fp.append n prec - fp.append.zeros [char] . fp.hold fp-represent-pad n + prec n - 0 max fp.append ; : (EXP.) ( n -- addr cnt , convert exponent to two digit value ) dup abs 0 <# # #s rot 0< IF [char] - HOLD ELSE [char] + hold THEN #> ; : FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- ) ; : (FS.) ( -- addr cnt ) ( F: r -- , scientific notation ) fp-output-pad fp-output-ptr ! \ setup pointer fp-represent-pad precision represent \ ." (FS.) - represent " fp-represent-pad precision type cr ( -- n flag1 flag2 ) IF IF [char] - fp.hold THEN 1 precision fp.move.decimal [char] e fp.hold 1- (exp.) fp.append \ n ELSE 2drop s" " fp.append THEN fp-output-pad fp-output-ptr @ over - ; : FS. ( F: r -- , scientific notation ) (fs.) type space ; : (FE.) ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- } fp-output-pad fp-output-ptr ! \ setup pointer fp-represent-pad precision represent ( -- n flag1 flag2 ) IF IF [char] - fp.hold THEN \ convert exponent to multiple of three -> n n 1- s>d 3 fm/mod \ use floored divide 3 * -> n3 1+ precision fp.move.decimal \ amount to move decimal point [char] e fp.hold n3 (exp.) fp.append \ n ELSE 2drop s" " fp.append THEN fp-output-pad fp-output-ptr @ over - ; : FE. ( F: r -- , engineering notation ) (FE.) type space ; : (FG.) ( F: r -- , normal or scientific ) { | n n3 ndiff -- } fp-output-pad fp-output-ptr ! \ setup pointer fp-represent-pad precision represent ( -- n flag1 flag2 ) IF IF [char] - fp.hold THEN \ compare n with precision to see whether we do scientific display dup precision > over -3 < OR IF \ use exponential notation 1 precision fp.move.decimal fp.strip.trailing.zeros [char] e fp.hold 1- (exp.) fp.append \ n ELSE dup 0> IF \ POSITIVE EXPONENT - place decimal point in middle precision fp.move.decimal ELSE \ NEGATIVE EXPONENT - use 0.000???? s" 0." fp.append \ output leading zeros negate fp.append.zeros fp-represent-pad precision fp.append THEN fp.strip.trailing.zeros THEN ELSE 2drop s" " fp.append THEN fp-output-pad fp-output-ptr @ over - ; : FG. ( F: r -- ) (fg.) type space ; : (F.) ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- } fp-output-pad fp-output-ptr ! \ setup pointer fp-represent-pad \ place to put number fdup flog 1 s>f f+ f>s precision max fp_precision_max min dup -> prec' represent ( -- n flag1 flag2 ) IF \ add '-' sign if negative IF [char] - fp.hold THEN \ compare n with precision to see whether we must do scientific display dup fp_precision_max > IF \ use exponential notation 1 precision fp.move.decimal fp.strip.trailing.zeros [char] e fp.hold 1- (exp.) fp.append \ n ELSE dup 0> IF \ POSITIVE EXPONENT - place decimal point in middle prec' fp.move.decimal ELSE \ NEGATIVE EXPONENT - use 0.000???? s" 0." fp.append \ output leading zeros dup negate precision min fp.append.zeros fp-represent-pad precision rot + fp.append THEN THEN ELSE 2drop s" " fp.append THEN fp-output-pad fp-output-ptr @ over - ; : F. ( F: r -- ) (f.) type space ; : F.S ( -- , print FP stack ) ." FP> " fdepth 0> IF fdepth 0 DO cr? fdepth i - 1- \ index of next float fpick f. cr? LOOP ELSE ." empty" THEN cr ; \ FP Input ---------------------------------------------------------- variable FP-REQUIRE-E \ must we put an E in FP numbers? false fp-require-e ! \ violate ANSI !! : >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag } u 0= IF false exit THEN false -> flag 0 -> nshift \ \ check for minus sign c-addr c@ [char] - = dup -> fsign c-addr c@ [char] + = OR IF 1 +-> c-addr -1 +-> u \ skip char THEN \ \ convert first set of digits 0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo u' 0> IF \ convert optional second set of digits c-addr c@ [char] . = IF dlo dhi c-addr 1+ u' 1- dup -> nshift >number dup nshift - -> nshift -> u' -> c-addr -> dhi -> dlo THEN \ convert exponent u' 0> IF c-addr c@ [char] E = c-addr c@ [char] e = OR IF 1 +-> c-addr -1 +-> u' \ skip E char u' 0> IF c-addr c@ [char] + = \ ignore + on exponent IF 1 +-> c-addr -1 +-> u' \ skip char THEN c-addr u' ((number?)) num_type_single = IF nshift + -> nshift true -> flag THEN ELSE true -> flag \ allow "1E" THEN THEN ELSE \ only require E field if this variable is true fp-require-e @ not -> flag THEN THEN \ convert double precision int to float flag IF dlo dhi d>f 10 s>f nshift s>f f** f* \ apply exponent fsign IF fnegate THEN THEN flag ; 3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER? : (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number ) \ check to see if it is a valid float, if not use old (NUMBER?) dup count >float IF drop NUM_TYPE_FLOAT ELSE (number?) THEN ; defer fp.old.number? variable FP-IF-INIT : FP.TERM ( -- , deinstall fp conversion ) fp-if-init @ IF what's fp.old.number? is number? fp-if-init off THEN ; : FP.INIT ( -- , install FP converion ) fp.term what's number? is fp.old.number? ['] (fp.number?) is number? fp-if-init on ." Floating point numeric conversion installed." cr ; FP.INIT if.forgotten fp.term 0 [IF] 23.8e-9 fconstant fsmall 1.0 fsmall f- fconstant falmost1 ." Should be 1.0 = " falmost1 f. cr : TSEGF ( r -f- , print in all formats ) ." --------------------------------" cr 34 0 DO fdup fs. 4 spaces fdup fe. 4 spaces fdup fg. 4 spaces fdup f. cr 10.0 f/ LOOP fdrop ; : TFP 1.234e+22 tsegf 1.23456789e+22 tsegf 0.927 fsin 1.234e+22 f* tsegf ; [THEN] pforth-2.0.1/fth/forget.fth000066400000000000000000000055111435661464300156040ustar00rootroot00000000000000\ @(#) forget.fth 98/01/26 1.2 \ forget.fth \ \ forget part of dictionary \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ \ 19970701 PLB Use unsigned compares for machines with "negative" addresses. variable RFENCE \ relocatable value below which we won't forget : FREEZE ( -- , protect below here ) here rfence a! ; : FORGET.NFA ( nfa -- , set DP etc. ) dup name> >code dp ! prevname ( dup current ! ) dup context ! n>nextlink headers-ptr ! ; : VERIFY.FORGET ( nfa -- , ask for verification if below fence ) dup name> >code rfence a@ u< \ 19970701 IF >newline dup id. ." is below fence!!" cr drop ELSE forget.nfa THEN ; : (FORGET) ( -- ) BL word findnfa IF verify.forget ELSE ." FORGET - couldn't find " count type cr abort THEN ; variable LAST-FORGET \ contains address of last if.forgotten frame 0 last-forget ! : IF.FORGOTTEN ( -- , place links in dictionary without header ) bl word find IF ( xt ) here \ start of frame last-forget a@ a, \ Cell[0] = rel address of previous frame last-forget a! \ point to this frame compile, \ Cell[1] = xt for this frame ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort THEN ; if.forgotten noop : [FORGET] ( -- , forget then exec forgotten words ) (forget) last-forget BEGIN a@ dup 0<> \ 19970701 IF dup here u> \ 19970701 IF dup cell+ x@ execute false ELSE dup last-forget a! true THEN ELSE true THEN UNTIL drop ; : FORGET ( -- , execute latest [FORGET] ) " [FORGET]" find IF execute ELSE ." FORGET - couldn't find " count type cr abort THEN ; : ANEW ( -- , forget if defined then redefine ) >in @ bl word find IF over >in ! forget THEN drop >in ! variable ; : MARKER ( -- , define a word that forgets itself when executed, ANS ) CREATE latest namebase - \ convert to relocatable , \ save for DOES> DOES> ( -- body ) @ namebase + \ convert back to NFA verify.forget ; pforth-2.0.1/fth/history.fth000066400000000000000000000262311435661464300160210ustar00rootroot00000000000000\ Command Line History \ \ Author: Phil Burk \ Copyright 1988 Phil Burk \ Revised 2001 for pForth 0 [IF] Requires an ANSI compatible terminal. To get Windows computers to use ANSI mode in their DOS windows, Add this line to "C:\CONFIG.SYS" then reboot. device=c:\windows\command\ansi.sys When command line history is on, you can use the UP and DOWN arrow to scroll through previous commands. Use the LEFT and RIGHT arrows to edit within a line. CONTROL-A moves to beginning of line. CONTROL-E moves to end of line. CONTROL-X erases entire line. HISTORY# ( -- , dump history buffer with numbers) HISTORY ( -- , dump history buffer ) XX ( line# -- , execute line x of history ) HISTORY.RESET ( -- , clear history tables ) HISTORY.ON ( -- , install history vectors ) HISTORY.OFF ( -- , uninstall history vectors ) [THEN] include? ESC[ termio.fth ANEW TASK-HISTORY.FTH decimal private{ \ You can expand the history buffer by increasing this constant!!!!!!!!!! 2048 constant KH_HISTORY_SIZE create KH-HISTORY kh_history_size allot KH-HISTORY kh_history_size erase \ An entry in the history buffer consists of \ byte - Count byte = N, \ chars - N chars, \ short - line number in Big Endian format, \ byte - another Count byte = N, for reverse scan \ \ The most recent entry is put at the beginning, \ older entries are shifted up. 4 constant KH_LINE_EXTRA_SIZE ( 2 count bytes plus 2 line_number bytes ) : KH-END ( -- addr , end of history buffer ) kh-history kh_history_size + ; : LINENUM@ ( addr -- w , stores in BigEndian format ) dup c@ 8 shift swap 1+ c@ or ; : LINENUM! ( w addr -- ) over -8 shift over c! 1+ c! ; variable KH-LOOK ( cursor offset into history, point to 1st count byte of line ) variable KH-MAX variable KH-COUNTER ( 16 bit counter for line # ) variable KH-SPAN ( total number of characters in line ) variable KH-MATCH-SPAN ( span for matching on shift-up ) variable KH-CURSOR ( points to next insertion point ) variable KH-ADDRESS ( address to store chars ) variable KH-INSIDE ( true if we are scrolling inside the history buffer ) : KH.MAKE.ROOM ( N -- , make room for N more bytes at beginning) >r ( save N ) kh-history dup r@ + ( source dest ) kh_history_size r> - 0 max move ; : KH.NEWEST.LINE ( -- addr count , most recent line ) kh-history count ; : KH.REWIND ( -- , move cursor to most recent line ) 0 kh-look ! ; : KH.CURRENT.ADDR ( -- $addr , count byte of current line ) kh-look @ kh-history + ; : KH.CURRENT.LINE ( -- addr count ) kh.current.addr count ; : KH.COMPARE ( addr count -- flag , true if redundant ) kh.newest.line compare 0= \ note: ANSI COMPARE is different than JForth days ; : KH.NUM.ADDR ( -- addr , address of current line's line count ) kh.current.line + ; : KH.CURRENT.NUM ( -- # , number of current line ) kh.num.addr LINENUM@ ; : KH.ADDR++ ( $addr -- $addr' , convert one kh to previous ) count + 3 + ; : KH.ADDR-- ( $addr -- $addr' , convert one kh to next ) dup 1- c@ \ get next lines endcount 4 + \ account for lineNum and two count bytes - \ calc previous address ; : KH.ENDCOUNT.ADDR ( -- addr , address of current end count ) kh.num.addr 2+ ; : KH.ADD.LINE ( addr count -- ) dup 256 > IF ." KH.ADD.LINE - Too big for history!" 2drop ELSE ( add to end ) \ Compare with most recent line. 2dup kh.compare IF 2drop ELSE >r ( save count ) \ Set look pointer to point to first count byte of last string. 0 kh-look ! \ Make room for this line of text and line header. \ PLB20100823 Was cell+ which broke on 64-bit code. r@ KH_LINE_EXTRA_SIZE + kh.make.room \ Set count bytes at beginning and end. r@ kh-history c! ( start count ) r@ kh.endcount.addr c! kh-counter @ kh.num.addr LINENUM! ( line ) \ Number lines modulo 1024 kh-counter @ 1+ $ 3FF and kh-counter ! kh-history 1+ ( calc destination ) r> cmove ( copy chars into space ) THEN THEN ; : KH.BACKUP.LINE { | cantmove addr' -- cantmove , advance KH-LOOK if in bounds } true -> cantmove ( default flag, at end of history ) \ KH-LOOK points to count at start of current line kh.current.addr c@ \ do we have any lines? IF kh.current.addr kh.addr++ -> addr' addr' kh-end U< \ within bounds? IF addr' c@ \ older line has chars? IF addr' kh-history - kh-look ! false -> cantmove THEN THEN THEN cantmove ; : KH.FORWARD.LINE ( -- cantmove? ) kh-look @ 0= dup not IF kh.current.addr kh.addr-- kh-history - kh-look ! THEN ; : KH.OLDEST.LINE ( -- addr count | 0, oldest in buffer ) BEGIN kh.backup.line UNTIL kh.current.line dup 0= IF nip THEN ; : KH.FIND.LINE ( line# -- $addr ) kh.rewind BEGIN kh.current.num over - WHILE kh.backup.line IF ." Line not in History Buffer!" cr drop 0 exit THEN REPEAT drop kh.current.addr ; : KH-BUFFER ( -- buffer ) kh-address @ ; : KH.RETURN ( -- , move to beginning of line ) 0 out ! 13 emit ; : KH.REPLACE.LINE ( addr count -- , make this the current line of input ) kh.return tio.erase.eol dup kh-span ! dup kh-cursor ! 2dup kh-buffer swap cmove type ; : KH.GET.MATCH ( -- , search for line with same start ) kh-match-span @ 0= ( keep length for multiple matches ) IF kh-span @ kh-match-span ! THEN BEGIN kh.backup.line not WHILE kh.current.line drop kh-buffer kh-match-span @ text= IF kh.current.line kh.replace.line exit THEN REPEAT ; : KH.FAR.RIGHT kh-span @ kh-cursor @ - dup 0> IF tio.forwards kh-span @ kh-cursor ! ELSE drop THEN ; : KH.FAR.LEFT ( -- ) kh.return kh-cursor off ; : KH.GET.OLDER ( -- , goto previous line ) kh-inside @ IF kh.backup.line drop THEN kh.current.line kh.replace.line kh-inside on ; : KH.GET.NEWER ( -- , next line ) kh.forward.line IF kh-inside off tib 0 ELSE kh.current.line THEN kh.replace.line ; : KH.CLEAR.LINE ( -- , rewind history scrolling and clear line ) kh.rewind tib 0 kh.replace.line kh-inside off ; : KH.GO.RIGHT ( -- ) kh-cursor @ kh-span @ < IF 1 kh-cursor +! 1 tio.forwards THEN ; : KH.GO.LEFT ( -- ) kh-cursor @ ?dup IF 1- kh-cursor ! 1 tio.backwards THEN ; : KH.REFRESH ( -- , redraw current line as is ) kh.return kh-buffer kh-span @ type tio.erase.eol kh.return kh-cursor @ ?dup IF tio.forwards THEN kh-span @ out ! ; : KH.BACKSPACE ( -- , backspace character from buffer and screen ) kh-cursor @ ?dup ( past 0? ) IF kh-span @ < IF ( inside line ) kh-buffer kh-cursor @ + ( -- source ) dup 1- ( -- source dest ) kh-span @ kh-cursor @ - cmove \ ." Deleted!" cr ELSE backspace THEN -1 kh-span +! -1 kh-cursor +! ELSE bell THEN kh.refresh ; : KH.DELETE ( -- , forward delete ) kh-cursor @ kh-span @ < ( before end ) IF ( inside line ) kh-buffer kh-cursor @ + 1+ ( -- source ) dup 1- ( -- source dest ) kh-span @ kh-cursor @ - 0 max cmove -1 kh-span +! kh.refresh THEN ; : KH.HANDLE.WINDOWS.KEY ( char -- , handle fkeys or arrows used by Windows ANSI.SYS ) CASE $ 8D OF kh.get.match ENDOF 0 kh-match-span ! ( reset if any other key ) $ 48 OF kh.get.older ENDOF $ 50 OF kh.get.newer ENDOF $ 4D OF kh.go.right ENDOF $ 4B OF kh.go.left ENDOF $ 91 OF kh.clear.line ENDOF $ 74 OF kh.far.right ENDOF $ 73 OF kh.far.left ENDOF $ 53 OF kh.delete ENDOF ENDCASE ; : KH.HANDLE.ANSI.KEY ( char -- , handle fkeys or arrows used by ANSI terminal ) CASE $ 41 OF kh.get.older ENDOF $ 42 OF kh.get.newer ENDOF $ 43 OF kh.go.right ENDOF $ 44 OF kh.go.left ENDOF ENDCASE ; : KH.SPECIAL.KEY ( char -- true | false , handle fkeys or arrows, true if handled ) true >r CASE $ E0 OF key kh.handle.windows.key ENDOF ASCII_ESCAPE OF key dup $ 4F = \ for TELNET $ 5B = OR \ for regular ANSI terminals IF key kh.handle.ansi.key ELSE rdrop false >r THEN ENDOF ASCII_BACKSPACE OF kh.backspace ENDOF ASCII_DELETE OF kh.backspace ENDOF ASCII_CTRL_X OF kh.clear.line ENDOF ASCII_CTRL_A OF kh.far.left ENDOF ASCII_CTRL_E OF kh.far.right ENDOF rdrop false >r ENDCASE r> ; : KH.SMART.KEY ( -- char ) BEGIN key dup kh.special.key WHILE drop REPEAT ; : KH.INSCHAR { charc | repaint -- } false -> repaint kh-cursor @ kh-span @ < IF \ Move characters up kh-buffer kh-cursor @ + ( -- source ) dup 1+ ( -- source dest ) kh-span @ kh-cursor @ - cmove> true -> repaint THEN \ write character to buffer charc kh-buffer kh-cursor @ + c! 1 kh-cursor +! 1 kh-span +! repaint IF kh.refresh ELSE charc emit THEN ; : EOL? ( char -- flag , true if an end of line character ) dup 13 = swap 10 = OR ; : KH.GETLINE ( max -- ) kh-max ! kh-span off kh-cursor off kh-inside off kh.rewind 0 kh-match-span ! BEGIN kh-max @ kh-span @ > IF kh.smart.key dup EOL? not ( ) ELSE 0 false THEN ( -- char flag ) WHILE ( -- char ) kh.inschar REPEAT drop kh-span @ kh-cursor @ - ?dup IF tio.forwards ( move to end of line ) THEN space flushemit ; : KH.ACCEPT ( addr max -- numChars ) swap kh-address ! kh.getline kh-span @ 0> IF kh-buffer kh-span @ kh.add.line THEN kh-span @ ; : TEST.HISTORY 4 0 DO pad 128 kh.accept cr pad swap type cr LOOP ; }private : HISTORY# ( -- , dump history buffer with numbers) cr kh.oldest.line ?dup IF BEGIN kh.current.num 3 .r ." ) " type ?pause cr kh.forward.line 0= WHILE kh.current.line REPEAT THEN ; : HISTORY ( -- , dump history buffer ) cr kh.oldest.line ?dup IF BEGIN type ?pause cr kh.forward.line 0= WHILE kh.current.line REPEAT THEN ; : XX ( line# -- , execute line x of history ) kh.find.line ?dup IF count evaluate THEN ; : HISTORY.RESET ( -- , clear history tables ) kh-history kh_history_size erase kh-counter off ; : HISTORY.ON ( -- , install history vectors ) history.reset what's accept ['] (accept) = IF ['] kh.accept is accept THEN ; : HISTORY.OFF ( -- , uninstall history vectors ) what's accept ['] kh.accept = IF ['] (accept) is accept THEN ; privatize : AUTO.INIT auto.init history.on ; : AUTO.TERM history.off auto.term ; if.forgotten history.off 0 [IF] history.reset history.on [THEN] pforth-2.0.1/fth/loadhist.fth000066400000000000000000000003351435661464300161240ustar00rootroot00000000000000\ Load history and save new dictionary. \ This is not part of the standard build because some computers \ do not support ANSI terminal I/O. include? ESC[ termio.fth include? HISTORY history.fth c" pforth.dic" save-forth pforth-2.0.1/fth/loadp4th.fth000066400000000000000000000033101435661464300160300ustar00rootroot00000000000000\ @(#) loadp4th.fth 98/01/28 1.3 \ Load various files needed by PForth \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. include? forget forget.fth include? >number numberio.fth include? task-misc1.fth misc1.fth include? case case.fth include? +field structure.fth include? $= strings.fth include? privatize private.fth include? (local) ansilocs.fth include? { locals.fth include? fm/mod math.fth include? [if] condcomp.fth include? task-misc2.fth misc2.fth include? save-input save-input.fth include? read-line file.fth include? require require.fth include? s\" slashqt.fth \ load floating point support if basic support is in kernel exists? F* [IF] include? task-floats.fth floats.fth [THEN] \ useful but optional stuff follows -------------------- include? task-member.fth member.fth include? :struct c_struct.fth include? smif{ smart_if.fth include? file? filefind.fth include? see see.fth include? words.like wordslik.fth include? trace trace.fth include? ESC[ termio.fth include? HISTORY history.fth map pforth-2.0.1/fth/locals.fth000066400000000000000000000045021435661464300155720ustar00rootroot00000000000000\ @(#) $M$ 98/01/26 1.2 \ standard { v0 v1 ... vn | l0 l1 .. lm -- } syntax \ based on ANSI basis words (LOCAL) and TO \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ MOD: PLB 2/11/00 Allow EOL and \ between { }. anew task-locals.fth private{ variable loc-temp-mode \ if true, declaring temporary variables variable loc-comment-mode \ if true, in comment section variable loc-done }private : { ( -- ) loc-done off loc-temp-mode off loc-comment-mode off BEGIN bl word count dup 0> \ make sure we are not at the end of a line IF over c@ CASE \ handle special characters ascii } OF loc-done on 2drop ENDOF ascii | OF loc-temp-mode on 2drop ENDOF ascii - OF loc-comment-mode on 2drop ENDOF ascii ) OF ." { ... ) imbalance!" cr abort ENDOF ascii \ OF postpone \ 2drop ENDOF \ Forth comment \ process name >r ( save char ) ( addr len ) loc-comment-mode @ IF 2drop ELSE \ if in temporary mode, assign local var = 0 loc-temp-mode @ IF compile false THEN \ otherwise take value from stack (local) THEN r> ENDCASE ELSE 2drop refill 0= abort" End of input while defining local variables!" THEN loc-done @ UNTIL 0 0 (local) ; immediate privatize \ tests : tlv1 { n -- } n dup n * dup n * ; : tlv2 { v1 v2 | l1 l2 -- } v1 . v2 . cr v1 v2 + -> l1 l1 . l2 . cr ; pforth-2.0.1/fth/math.fth000066400000000000000000000044041435661464300152470ustar00rootroot00000000000000\ @(#) math.fth 98/01/26 1.2 \ Extended Math routines \ FM/MOD SM/REM \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. anew task-math.fth decimal : FM/MOD { dl dh nn | dlp dhp nnp rem quo -- rem quo , floored } dl dh dabs -> dhp -> dlp nn abs -> nnp dlp dhp nnp um/mod -> quo -> rem dh 0< IF \ negative dividend nn 0< IF \ negative divisor rem negate -> rem ELSE \ positive divisor rem 0= IF quo negate -> quo ELSE quo 1+ negate -> quo nnp rem - -> rem THEN THEN ELSE \ positive dividend nn 0< IF \ negative divisor rem 0= IF quo negate -> quo ELSE nnp rem - negate -> rem quo 1+ negate -> quo THEN THEN THEN rem quo ; : SM/REM { dl dh nn | dlp dhp nnp rem quo -- rem quo , symmetric } dl dh dabs -> dhp -> dlp nn abs -> nnp dlp dhp nnp um/mod -> quo -> rem dh 0< IF \ negative dividend rem negate -> rem nn 0> IF \ positive divisor quo negate -> quo THEN ELSE \ positive dividend nn 0< IF \ negative divisor quo negate -> quo THEN THEN rem quo ; : /MOD ( a b -- rem quo ) >r s>d r> sm/rem ; : MOD ( a b -- rem ) /mod drop ; : */MOD ( a b c -- rem a*b/c , use double precision intermediate value ) >r m* r> sm/rem ; : */ ( a b c -- a*b/c , use double precision intermediate value ) */mod nip ; pforth-2.0.1/fth/member.fth000066400000000000000000000117671435661464300155770ustar00rootroot00000000000000\ @(#) member.fth 98/01/26 1.2 \ This files, along with c_struct.fth, supports the definition of \ structure members similar to those used in 'C'. \ \ Some of this same code is also used by ODE, \ the Object Development Environment. \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ \ MOD: PLB 1/16/87 Use abort" instead of er.report. \ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal. \ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs. \ MOD: PLB 7/31/88 Add USHORT and UBYTE. \ MOD: PLB 1/20/89 Treat LITERAL as state sensitive. \ MOD: RDG 9/19/90 Add floating point member support. \ MOD: PLB 6/10/91 Add RPTR \ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S! \ 941102 RDG port to pforth \ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal. \ 960710 PLB align long members for SUN ANEW TASK-MEMBER.FTH decimal : FIND.BODY ( -- , pfa true | $name false , look for word in dict. ) \ Return address of parameter data. bl word find IF >body true ELSE false THEN ; \ Variables shared with object oriented code. VARIABLE OB-STATE ( Compilation state. ) VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class ) 1 constant OB_DEF_CLASS ( defining a class ) 2 constant OB_DEF_STRUCT ( defining a structure ) \ A member contains: \ cell size of data in bytes (1, 2, cell) \ cell offset within structure cell 1- constant CELL_MASK cell negate constant -CELL cell constant OB_OFFSET_SIZE : OB.OFFSET@ ( member_def -- offset ) @ ; : OB.OFFSET, ( value -- ) , ; : OB.SIZE@ ( member_def -- offset ) ob_offset_size + @ ; : OB.SIZE, ( value -- ) , ; ( Members are associated with an offset from the base of a structure. ) : OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time) dup >r ( -- +-b , save #bytes ) ABS ( -- |+-b| ) ob-current-class @ ( -- b addr-space) tuck @ ( as #b c , current space needed ) over CELL_MASK and 0= ( multiple of cell? ) IF aligned ELSE over 1 and 0= ( multiple of two? ) IF even-up THEN THEN swap over + rot ! ( update space needed ) \ Save data in member definition. %M ob.offset, ( save old offset for ivar ) r> ob.size, ( store size in bytes for ..! and ..@ ) ; \ Unions allow one to address the same memory as different members. \ Unions work by saving the current offset for members on \ the stack and then reusing it for different members. : UNION{ ( -- offset , Start union definition. ) ob-current-class @ @ ; : }UNION{ ( old-offset -- new-offset , Middle of union ) union{ ( Get current for }UNION to compare ) swap ob-current-class @ ! ( Set back to old ) ; : }UNION ( offset -- , Terminate union definition, check lengths. ) union{ = NOT abort" }UNION - Two parts of UNION are not the same size!" ; \ Make members compile their offset, for "disposable includes". : OB.MEMBER ( #bytes -- , make room in an object at compile time) ( -- offset , run time for structure ) CREATE ob.make.member immediate DOES> ob.offset@ ( get offset ) ?literal ; : OB.FINDIT ( -- pfa , get pfa of thing or error ) find.body not IF cr count type ." ???" true abort" OB.FINDIT - Word not found!" THEN ; : OB.STATS ( member_pfa -- offset #bytes ) dup ob.offset@ swap ob.size@ ; : OB.STATS? ( -- offset #bytes ) ob.findit ob.stats ; : SIZEOF() ( OR -- #bytes , lookup size of object ) ob.findit @ ?literal ; immediate \ Basic word for defining structure members. : BYTES ( #bytes -- , error check for structure only ) ob-state @ ob_def_struct = not abort" BYTES - Only valid in :STRUCT definitions." ob.member ; \ Declare various types of structure members. \ Negative size indicates a signed member. : BYTE ( -- , declare space for a byte ) -1 bytes ; : SHORT ( -- , declare space for a 16 bit value ) -2 bytes ; : LONG ( -- ) cell bytes ; : UBYTE ( -- , declare space for signed byte ) 1 bytes ; : USHORT ( -- , declare space for signed 16 bit value ) 2 bytes ; \ Aliases : APTR ( -- ) long ; : RPTR ( -- ) -cell bytes ; \ relative relocatable pointer 00001 : ULONG ( -- ) long ; : STRUCT ( -- , define a structure as an ivar ) [compile] sizeof() bytes ; pforth-2.0.1/fth/misc1.fth000066400000000000000000000076231435661464300153400ustar00rootroot00000000000000\ @(#) misc1.fth 98/01/26 1.2 \ miscellaneous words \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. anew task-misc1.fth decimal : >> rshift ; : << lshift ; : (WARNING") ( flag $message -- ) swap IF count type ELSE drop THEN ; : WARNING" ( flag -- , print warning if true. ) [compile] " ( compile message ) state @ IF compile (warning") ELSE (warning") THEN ; IMMEDIATE : (ABORT") ( flag $message -- ) swap IF count type cr err_abortq throw ELSE drop THEN ; : ABORT" ( flag -- , print warning if true. ) [compile] " ( compile message ) state @ IF compile (abort") ELSE (abort") THEN ; IMMEDIATE : ?PAUSE ( -- , Pause if key hit. ) ?terminal IF key drop cr ." Hit space to continue, any other key to abort:" key dup emit BL = not abort" Terminated" THEN ; 60 constant #cols : CR? ( -- , do CR if near end ) OUT @ #cols 16 - 10 max > IF cr THEN ; : CLS ( -- clear screen ) 40 0 do cr loop ; : PAGE ( -- , clear screen, compatible with Brodie ) cls ; : $ ( -- N , convert next number as hex ) base @ hex bl lword number? num_type_single = not abort" Not a single number!" swap base ! state @ IF [compile] literal THEN ; immediate : .HX ( nibble -- ) dup 9 > IF $ 37 ELSE $ 30 THEN + emit ; variable TAB-WIDTH 8 TAB-WIDTH ! : TAB ( -- , tab over to next stop ) out @ tab-width @ mod tab-width @ swap - spaces ; $ 20 constant FLAG_SMUDGE \ Vocabulary listing : WORDS ( -- ) 0 latest BEGIN dup 0<> WHILE ( -- count NFA ) dup c@ flag_smudge and 0= IF dup id. tab cr? ?pause swap 1+ swap THEN prevname REPEAT drop cr . ." words" cr ; : VLIST words ; variable CLOSEST-NFA variable CLOSEST-XT : >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! ) 0 closest-nfa ! 0 closest-xt ! latest BEGIN dup 0<> IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) < IF true ( addr below this cfa, can't be it) ELSE ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) = IF ( found it ! ) dup closest-nfa ! false ELSE dup name> closest-xt @ > IF dup closest-nfa ! dup name> closest-xt ! THEN true THEN THEN ELSE false THEN WHILE prevname REPEAT ( -- cfa nfa ) 2drop closest-nfa @ ; : @EXECUTE ( addr -- , execute if non-zero ) x@ ?dup IF execute THEN ; : TOLOWER ( char -- char_lower ) dup ascii [ < IF dup ascii @ > IF ascii A - ascii a + THEN THEN ; : EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth ) \ save current input state and switch to passed in string source >r >r set-source -1 push-source-id >in @ >r 0 >in ! \ interpret the string interpret \ restore input state pop-source-id drop r> >in ! r> r> set-source ; : \S ( -- , comment out rest of file ) source-id IF BEGIN \ using REFILL is safer than popping SOURCE-ID refill 0= UNTIL THEN ; pforth-2.0.1/fth/misc2.fth000066400000000000000000000155401435661464300153360ustar00rootroot00000000000000\ @(#) misc2.fth 98/01/26 1.2 \ Utilities for PForth extracted from HMSL \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ \ 00001 9/14/92 Added call, 'c w->s \ 00002 11/23/92 Moved redef of : to loadcom.fth anew task-misc2.fth : 'N ( -- , make 'n state smart ) bl word find IF state @ IF namebase - ( make nfa relocatable ) [compile] literal ( store nfa of word to be compiled ) compile namebase+ THEN THEN ; IMMEDIATE : ?LITERAL ( n -- , do literal if compiling ) state @ IF [compile] literal THEN ; : 'c ( -- xt , state sensitive ' ) ' ?literal ; immediate variable if-debug : ? ( address -- , fatch from address and print value ) @ . ; decimal create MSEC-DELAY 100000 , \ calibrate this for your system : (MSEC.SPIN) ( #msecs -- , busy wait, not accurate ) 0 max \ avoid endless loop 0 ?do msec-delay @ 0 do loop loop ; : (MSEC) ( millis -- ) dup (sleep) \ call system sleep in kernel IF ." (SLEEP) failed or not implemented! Using (MSEC.SPIN)" CR (msec.spin) ELSE drop THEN ; defer msec \ (SLEEP) uses system sleep functions to actually sleep. \ Use (MSEC.SPIN) on embedded systems that do not support Win32 Sleep() posix usleep(). 1 (SLEEP) [IF] ." (SLEEP) failed or not implemented! Use (MSEC.SPIN) for MSEC" CR ' (msec.spin) is msec [ELSE] ' (msec) is msec [THEN] : MS ( msec -- , sleep, ANS standard ) msec ; : SHIFT ( val n -- val< if swap then ; \ sort top two items on stack. : -2sort ( a b -- a>b | b>a , smallest on top of stack) 2dup < if swap then ; : barray ( #bytes -- ) ( index -- addr ) create allot does> + ; : warray ( #words -- ) ( index -- addr ) create 2* allot does> swap 2* + ; : array ( #cells -- ) ( index -- addr ) create cell* allot does> swap cell* + ; : .bin ( n -- , print in binary ) base @ binary swap . base ! ; : .dec ( n -- ) base @ decimal swap . base ! ; : .hex ( n -- ) base @ hex swap . base ! ; : B->S ( c -- c' , sign extend byte ) dup $ 80 and IF [ $ 0FF invert ] literal or ELSE $ 0FF and THEN ; : W->S ( 16bit-signed -- cell-signed ) dup $ 8000 and IF [ $ 0FFFF invert ] literal or ELSE $ 0FFFF and THEN ; : WITHIN { n1 n2 n3 -- flag } n2 n3 <= IF n2 n1 <= n1 n3 < AND ELSE n2 n1 <= n1 n3 < OR THEN ; : MOVE ( src dst num -- ) >r 2dup - 0< IF r> CMOVE> ELSE r> CMOVE THEN ; : ERASE ( caddr num -- ) dup 0> IF 0 fill ELSE 2drop THEN ; : BLANK ( addr u -- , set memory to blank ) DUP 0> IF BL FILL ELSE 2DROP THEN ; \ Obsolete but included for CORE EXT word set. : QUERY REFILL DROP ; VARIABLE SPAN : EXPECT accept span ! ; : TIB source drop ; : UNUSED ( -- unused , dictionary space ) CODELIMIT HERE - ; : MAP ( -- , dump interesting dictionary info ) ." Code Segment" cr ." CODEBASE = " codebase .hex cr ." HERE = " here .hex cr ." CODELIMIT = " codelimit .hex cr ." Compiled Code Size = " here codebase - . cr ." CODE-SIZE = " code-size @ . cr ." Code Room UNUSED = " UNUSED . cr ." Name Segment" cr ." NAMEBASE = " namebase .hex cr ." HEADERS-PTR @ = " headers-ptr @ .hex cr ." NAMELIMIT = " namelimit .hex cr ." CONTEXT @ = " context @ .hex cr ." LATEST = " latest .hex ." = " latest id. cr ." Compiled Name size = " headers-ptr @ namebase - . cr ." HEADERS-SIZE = " headers-size @ . cr ." Name Room Left = " namelimit headers-ptr @ - . cr ; \ Search for substring S2 in S1 : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag } \ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr \ if true, s1 contains s2 at addr3 with cnt3 chars remaining \ if false, s3 = s1 addr1 -> addr3 cnt1 -> cnt3 cnt1 cnt2 < not IF cnt1 cnt2 - 1+ 0 DO true -> flag cnt2 0 ?DO addr2 i chars + c@ addr1 i j + chars + c@ <> \ mismatch? IF false -> flag LEAVE THEN LOOP flag IF addr1 i chars + -> addr3 cnt1 i - -> cnt3 LEAVE THEN LOOP THEN 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 pforth-2.0.1/fth/mkdicdat.fth000066400000000000000000000002101435661464300160650ustar00rootroot00000000000000\ Generate the pfdicdat.h header file. include savedicd.fth ." Generate a static embedded dictionary" cr sdad ." pfdicdat.h created" cr pforth-2.0.1/fth/numberio.fth000066400000000000000000000133061435661464300161370ustar00rootroot00000000000000\ @(#) numberio.fth 98/01/26 1.2 \ numberio.fth \ \ numeric conversion \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. anew task-numberio.fth decimal \ ------------------------ INPUT ------------------------------- \ Convert a single character to a number in the given base. : DIGIT ( char base -- n true | char false ) >r \ convert lower to upper dup ascii a < not IF ascii a - ascii A + THEN \ dup dup ascii A 1- > IF ascii A - ascii 9 + 1+ ELSE ( char char ) dup ascii 9 > IF ( between 9 and A is bad ) drop 0 ( trigger error below ) THEN THEN ascii 0 - dup r> < IF dup 1+ 0> IF nip true ELSE drop FALSE THEN ELSE drop FALSE THEN ; : >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE ) >r BEGIN r@ 0> \ any characters left? IF dup c@ base @ digit ( ud1 c-addr , n true | char false ) IF TRUE ELSE drop FALSE THEN ELSE false THEN WHILE ( -- ud1 c-addr n ) swap >r ( -- ud1lo ud1hi n ) swap base @ ( -- ud1lo n ud1hi base ) um* drop ( -- ud1lo n ud1hi*baselo ) rot base @ ( -- n ud1hi*baselo ud1lo base ) um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi ) d+ ( -- ud2 ) r> 1+ \ increment char* r> 1- >r \ decrement count REPEAT r> ; \ obsolete : CONVERT ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT ) 256 >NUMBER DROP ; 0 constant NUM_TYPE_BAD 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? 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 /string ( -- base c-addr+1 cnt-1 , skip past minus sign ) THEN ( 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 r@ \ check flag to see if '-' sign used IF negate THEN NUM_TYPE_SINGLE ELSE ( -- d addr cnt ) 1 = swap \ if final character is '.' then double c@ ascii . = AND IF r@ \ check flag to see if '-' sign used IF dnegate THEN NUM_TYPE_DOUBLE ELSE 2drop NUM_TYPE_BAD THEN THEN rdrop ; : (NUMBER?) ( $addr -- 0 | n 1 | d 2 , convert string to number ) count ((number?)) ; ' (number?) is number? \ hex \ 0sp c" xyz" (number?) .s \ 0sp c" 234" (number?) .s \ 0sp c" -234" (number?) .s \ 0sp c" 234." (number?) .s \ 0sp c" -234." (number?) .s \ 0sp c" 1234567855554444." (number?) .s \ ------------------------ OUTPUT ------------------------------ \ Number output based on F83 variable HLD \ points to last character added : hold ( char -- , add character to text representation) -1 hld +! hld @ c! ; : <# ( -- , setup conversion ) pad hld ! ; : #> ( d -- addr len , finish conversion ) 2drop hld @ pad over - ; : sign ( n -- , add '-' if negative ) 0< if ascii - hold then ; : # ( d -- d , convert one digit ) base @ mu/mod rot 9 over < IF 7 + THEN ascii 0 + hold ; : #s ( d -- d , convert remaining digits ) BEGIN # 2dup or 0= UNTIL ; : (UD.) ( ud -- c-addr cnt ) <# #s #> ; : UD. ( ud -- , print unsigned double number ) (ud.) type space ; : UD.R ( ud n -- ) >r (ud.) r> over - spaces type ; : (D.) ( d -- c-addr cnt ) tuck dabs <# #s rot sign #> ; : D. ( d -- ) (d.) type space ; : D.R ( d n -- , right justified ) >r (d.) r> over - spaces type ; : (U.) ( u -- c-addr cnt ) 0 (ud.) ; : U. ( u -- , print unsigned number ) 0 ud. ; : U.R ( u n -- , print right justified ) >r (u.) r> over - spaces type ; : (.) ( n -- c-addr cnt ) dup abs 0 <# #s rot sign #> ; : . ( n -- , print signed number) (.) type space ; : .R ( n l -- , print right justified) >r (.) r> over - spaces type ; pforth-2.0.1/fth/private.fth000066400000000000000000000023541435661464300157720ustar00rootroot00000000000000\ @(#) private.fth 98/01/26 1.2 \ PRIVATIZE \ \ Privatize words that are only needed within the file \ and do not need to be exported. \ \ Usage: \ PRIVATE{ \ : FOO ; \ Everything between PRIVATE{ and }PRIVATE will become private. \ : MOO ; \ }PRIVATE \ : GOO foo moo ; \ can use foo and moo \ PRIVATIZE \ smudge foo and moo \ ' foo \ will fail \ \ Copyright 1996 Phil Burk \ \ 19970701 PLB Use unsigned compares for machines with "negative" addresses. anew task-private.fth variable private-start variable private-stop : PRIVATE{ private-start @ 0= not abort" ERROR: Missing PRIVATIZE" private-stop @ 0= not abort" ERROR: Missing PRIVATIZE" latest private-start ! 0 private-stop ! ; : }PRIVATE private-stop @ 0= not abort" ERROR: Extra }PRIVATE" latest private-stop ! ; : PRIVATIZE ( -- , smudge all words between PRIVATE{ and }PRIVATE ) private-start @ 0= abort" ERROR: Missing PRIVATE{" private-stop @ 0= abort" ERROR: Missing }PRIVATE" private-stop @ BEGIN dup private-start @ u> \ 19970701 WHILE \ ." Smudge " dup id. cr dup c@ flag_smudge or over c! prevname REPEAT drop 0 private-start ! 0 private-stop ! ; pforth-2.0.1/fth/require.fth000066400000000000000000000024351435661464300157740ustar00rootroot00000000000000\ REQUIRE and REQUIRED \ \ This code is part of pForth. \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 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 pforth-2.0.1/fth/save-input.fth000066400000000000000000000045621435661464300164160ustar00rootroot00000000000000\ SAVE-INPUT and RESTORE-INPUT \ \ This code is part of pForth. \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 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 pforth-2.0.1/fth/savedicd.fth000066400000000000000000000077061435661464300161100ustar00rootroot00000000000000\ @(#) savedicd.fth 98/01/26 1.2 \ Save dictionary as data table. \ \ Author: Phil Burk \ Copyright 1987 Phil Burk \ All Rights Reserved. \ \ 970311 PLB Fixed problem with calling SDAD when in HEX mode. \ 20010606 PLB Fixed AUTO.INIT , started with ';' !! decimal ANEW TASK-SAVE_DIC_AS_DATA \ !!! set to 4 for minimally sized dictionary to prevent DIAB \ compiler from crashing! Allocate more space in pForth. 4 constant SDAD_NAMES_EXTRA \ space for additional names 4 constant SDAD_CODE_EXTRA \ space for additional names \ buffer the file I/O for better performance 256 constant SDAD_BUFFER_SIZE create SDAD-BUFFER SDAD_BUFFER_SIZE allot variable SDAD-BUFFER-INDEX variable SDAD-BUFFER-FID 0 SDAD-BUFFER-FID ! : SDAD.FLUSH ( -- ior ) sdad-buffer sdad-buffer-index @ \ data \ 2dup type sdad-buffer-fid @ write-file 0 sdad-buffer-index ! ; : SDAD.EMIT ( char -- ) sdad-buffer-index @ sdad_buffer_size >= IF sdad.flush abort" SDAD.FLUSH failed!" THEN \ sdad-buffer sdad-buffer-index @ + c! 1 sdad-buffer-index +! ; : SDAD.TYPE ( c-addr cnt -- ) 0 DO dup c@ sdad.emit \ char to buffer 1+ \ advance char pointer LOOP drop ; : $SDAD.LINE ( $addr -- ) count sdad.type EOL sdad.emit ; : (U8.) ( u -- a l , unsigned conversion, at least 8 digits ) 0 <# # # # # # # # #S #> ; : (U2.) ( u -- a l , unsigned conversion, at least 2 digits ) 0 <# # #S #> ; : SDAD.CLOSE ( -- ) SDAD-BUFFER-FID @ ?dup IF sdad.flush abort" SDAD.FLUSH failed!" close-file drop 0 SDAD-BUFFER-FID ! THEN ; : SDAD.OPEN ( -- ior, open file ) sdad.close s" pfdicdat.h" r/w create-file dup >r IF drop ." Could not create file pfdicdat.h" cr ELSE SDAD-BUFFER-FID ! THEN r> ; : SDAD.DUMP.HEX { val -- } base @ >r hex s" 0x" sdad.type val (u8.) sdad.type r> base ! ; : SDAD.DUMP.HEX, s" " sdad.type sdad.dump.hex ascii , sdad.emit ; : SDAD.DUMP.HEX.BYTE { val -- } base @ >r hex s" 0x" sdad.type val (u2.) sdad.type r> base ! ; : SDAD.DUMP.HEX.BYTE, sdad.dump.hex.byte ascii , sdad.emit ; : SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- } end-address start-address - -> num-bytes num-bytes 0 ?DO i $ 7FF and 0= IF ." 0x" i .hex cr THEN \ progress report i 15 and 0= IF EOL sdad.emit s" /* " sdad.type i sdad.dump.hex s" : */ " sdad.type THEN \ 16 bytes per line, print offset start-address i + c@ sdad.dump.hex.byte, LOOP \ num-zeros 0 ?DO i $ 7FF and 0= IF i . cr THEN \ progress report i 15 and 0= IF EOL sdad.emit THEN \ 15 numbers per line 0 sdad.dump.hex.byte, LOOP ; : SDAD.DEFINE { $name val -- } s" #define " sdad.type $name count sdad.type s" (" sdad.type val sdad.dump.hex c" )" $sdad.line ; : IS.LITTLE.ENDIAN? ( -- flag , is Forth in Little Endian mode? ) 1 pad ! pad c@ ; : SDAD { | fid -- } sdad.open abort" sdad.open failed!" \ Write headers. c" /* This file generated by the Forth command SDAD */" $sdad.line c" HEADERPTR" headers-ptr @ namebase - sdad.define c" RELCONTEXT" context @ namebase - sdad.define c" CODEPTR" here codebase - sdad.define c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define ." Saving Names" cr s" static const uint8_t MinDicNames[] = {" sdad.type namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data EOL sdad.emit c" };" $sdad.line ." Saving Code" cr s" static const uint8_t MinDicCode[] = {" sdad.type codebase here SDAD_CODE_EXTRA sdad.dump.data EOL sdad.emit c" };" $sdad.line sdad.close ; if.forgotten sdad.close : AUTO.INIT ( -- , init at launch ) auto.init \ daisy chain initialization 0 SDAD-BUFFER-FID ! 0 SDAD-BUFFER-INDEX ! ; ." Enter: SDAD" cr pforth-2.0.1/fth/see.fth000066400000000000000000000102031435661464300150640ustar00rootroot00000000000000\ @(#) see.fth 98/01/26 1.4 \ SEE ( -- , disassemble pForth word ) \ \ Copyright 1996 Phil Burk ' file? >code rfence a! anew task-see.fth : .XT ( xt -- , print execution tokens name ) >name dup c@ flag_immediate and IF ." POSTPONE " THEN id. space ; \ dictionary may be defined as byte code or cell code 0 constant BYTE_CODE BYTE_CODE [IF] : CODE@ ( addr -- xt , fetch from code space ) C@ ; 1 constant CODE_CELL .( BYTE_CODE not implemented) abort [ELSE] : CODE@ ( addr -- xt , fetch from code space ) @ ; CELL constant CODE_CELL [THEN] private{ 0 value see_level \ level of conditional imdentation 0 value see_addr \ address of next token 0 value see_out : SEE.INDENT.BY ( -- n ) see_level 1+ 1 max 4 * ; : SEE.CR >newline see_addr ." ( ".hex ." )" see.indent.by spaces 0 -> see_out ; : SEE.NEWLINE see_out 0> IF see.cr THEN ; : SEE.CR? see_out 6 > IF see.newline THEN ; : SEE.OUT+ 1 +-> see_out ; : SEE.ADVANCE code_cell +-> see_addr ; : SEE.GET.INLINE ( -- n ) see_addr @ ; : SEE.GET.TARGET ( -- branch-target-addr ) see_addr @ see_addr + ; : SEE.SHOW.LIT ( -- ) see.get.inline . see.advance see.out+ ; exists? F* [IF] : SEE.SHOW.FLIT ( -- ) see_addr f@ f. 1 floats +-> see_addr see.out+ ; [THEN] : SEE.SHOW.ALIT ( -- ) see.get.inline >name id. space see.advance see.out+ ; : SEE.SHOW.STRING ( -- ) see_addr count 2dup + aligned -> see_addr type see.out+ ; : SEE.SHOW.TARGET ( -- ) see.get.target .hex see.advance ; : SEE.BRANCH ( -- addr | , handle branch ) -1 +-> see_level see.newline see.get.inline 0> IF \ forward branch ." ELSE " see.get.target \ calculate address of target 1 +-> see_level nip \ remove old address for THEN ELSE ." REPEAT " see.get.target .hex drop \ remove old address for THEN THEN see.advance see.cr ; : SEE.0BRANCH ( -- addr | , handle 0branch ) see.newline see.get.inline 0> IF \ forward branch ." IF or WHILE " see.get.target \ calculate adress of target 1 +-> see_level ELSE ." UNTIL=>" see.get.target .hex THEN see.advance see.cr ; : SEE.XT { xt -- } xt CASE 0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0 -> see_addr THEN ENDOF ['] (LITERAL) OF see.show.lit ENDOF ['] (ALITERAL) OF see.show.alit ENDOF [ exists? (FLITERAL) [IF] ] ['] (FLITERAL) OF see.show.flit ENDOF [ [THEN] ] ['] BRANCH OF see.branch ENDOF ['] 0BRANCH OF see.0branch ENDOF ['] (LOOP) OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr ENDOF ['] (+LOOP) OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr ENDOF ['] (DO) OF see.newline ." DO" 1 +-> see_level see.cr ENDOF ['] (?DO) OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF ['] (.") OF .' ." ' see.show.string .' " ' ENDOF ['] (C") OF .' C" ' see.show.string .' " ' ENDOF ['] (S") OF .' S" ' see.show.string .' " ' ENDOF see.cr? xt .xt see.out+ ENDCASE ; : (SEE) { cfa | xt -- } 0 -> see_level cfa -> see_addr see.cr 0 \ fake address for THEN handler BEGIN see_addr code@ -> xt BEGIN dup see_addr ( >newline .s ) = WHILE -1 +-> see_level see.newline ." THEN " see.cr drop REPEAT CODE_CELL +-> see_addr xt see.xt see_addr 0= UNTIL cr 0= not abort" SEE conditional analyser nesting failed!" ; }PRIVATE : SEE ( -- , disassemble ) ' dup ['] FIRST_COLON > IF >code (see) ELSE >name id. ." is primitive defined in 'C' kernel." cr THEN ; PRIVATIZE 0 [IF] : SEE.JOKE dup swap drop ; : SEE.IF IF ." hello" cr ELSE ." bye" cr THEN see.joke ; : SEE.DO 4 0 DO i . cr LOOP ; : SEE." ." Here are some strings." cr c" Forth string." count type cr s" Addr/Cnt string" type cr ; [THEN] pforth-2.0.1/fth/siev.fth000066400000000000000000000013331435661464300152620ustar00rootroot00000000000000\ #! /usr/stud/paysan/bin/forth DECIMAL \ : SECS TIME&DATE SWAP 60 * + SWAP 3600 * + NIP NIP NIP ; CREATE FLAGS 8190 ALLOT variable eflag \ FLAGS 8190 + CONSTANT EFLAG \ use secondary fill like pForth !!! : FILL { caddr num charval -- } num 0 ?DO charval caddr i + c! LOOP ; : PRIMES ( -- n ) FLAGS 8190 1 FILL 0 3 EFLAG @ FLAGS DO I C@ IF DUP I + DUP EFLAG @ < IF EFLAG @ SWAP DO 0 I C! DUP +LOOP ELSE DROP THEN SWAP 1+ SWAP THEN 2 + LOOP DROP ; : BENCHMARK 0 100 0 DO PRIMES NIP LOOP ; \ !!! ONLY 100 \ SECS BENCHMARK . SECS SWAP - CR . .( secs) : main flags 8190 + eflag ! benchmark ( . ) drop ; pforth-2.0.1/fth/slashqt.fth000066400000000000000000000112561435661464300160000ustar00rootroot00000000000000\ S\" implementation for pForth \ \ Copied from ANS reference implementation at: \ http://www.forth200x.org/escaped-strings.html \ \ The code was not modified except for the use of private{ }private \ \ Added November 2021 by Phil Burk ANEW TASK-SLASHQT.FTH private{ decimal : c+! \ c c-addr -- \ *G Add character C to the contents of address C-ADDR. tuck c@ + swap c! ; : addchar \ char string -- \ *G Add the character to the end of the counted string. tuck count + c! 1 swap c+! ; : append \ c-addr u $dest -- \ *G Add the string described by C-ADDR U to the counted string at \ ** $DEST. The strings must not overlap. >r tuck r@ count + swap cmove \ add source to end r> c+! \ add length to count ; : extract2H \ c-addr len -- c-addr' len' u \ *G Extract a two-digit hex number in the given base from the \ ** start of the string, returning the remaining string \ ** and the converted number. base @ >r hex 0 0 2over drop 2 >number 2drop drop >r 2 /string r> r> base ! ; create EscapeTable \ -- addr \ *G Table of translations for \a..\z. 7 c, \ \a BEL (Alert) 8 c, \ \b BS (Backspace) char c c, \ \c char d c, \ \d 27 c, \ \e ESC (Escape) 12 c, \ \f FF (Form feed) char g c, \ \g char h c, \ \h char i c, \ \i char j c, \ \j char k c, \ \k 10 c, \ \l LF (Line feed) char m c, \ \m 10 c, \ \n (Unices only) char o c, \ \o char p c, \ \p char " c, \ \q " (Double quote) 13 c, \ \r CR (Carriage Return) char s c, \ \s 9 c, \ \t HT (horizontal tab} char u c, \ \u 11 c, \ \v VT (vertical tab) char w c, \ \w char x c, \ \x char y c, \ \y 0 c, \ \z NUL (no character) create CRLF$ \ -- addr ; CR/LF as counted string 2 c, 13 c, 10 c, : addEscape \ c-addr len dest -- c-addr' len' \ *G Add an escape sequence to the counted string at dest, \ ** returning the remaining string. over 0= \ zero length check if drop exit then >r \ -- caddr len ; R: -- dest over c@ [char] x = if \ hex number? 1 /string extract2H r> addchar exit then over c@ [char] m = if \ CR/LF pair 1 /string 13 r@ addchar 10 r> addchar exit then over c@ [char] n = if \ CR/LF pair? (Windows/DOS only) 1 /string crlf$ count r> append exit then over c@ [char] a [char] z 1+ within if over c@ [char] a - EscapeTable + c@ r> addchar else over c@ r> addchar then 1 /string ; : parse\" \ c-addr len dest -- c-addr' len' \ *G Parses a string up to an unescaped '"', translating '\' \ ** escapes to characters. The translated string is a \ ** counted string at *\i{dest}. \ ** The supported escapes (case sensitive) are: \ *D \a BEL (alert) \ *D \b BS (backspace) \ *D \e ESC (not in C99) \ *D \f FF (form feed) \ *D \l LF (ASCII 10) \ *D \m CR/LF pair - for HTML etc. \ *D \n newline - CRLF for Windows/DOS, LF for Unices \ *D \q double-quote \ *D \r CR (ASCII 13) \ *D \t HT (tab) \ *D \v VT \ *D \z NUL (ASCII 0) \ *D \" double-quote \ *D \xAB Two char Hex numerical character value \ *D \\ backslash itself \ *D \ before any other character represents that character dup >r 0 swap c! \ zero destination begin \ -- caddr len ; R: -- dest dup while over c@ [char] " <> \ check for terminator while over c@ [char] \ = if \ deal with escapes 1 /string r@ addEscape else \ normal character over c@ r@ addchar 1 /string then repeat then dup \ step over terminating " if 1 /string then r> drop ; create pocket \ -- addr \ *G A tempory buffer to hold processed string. \ This would normally be an internal system buffer. s" /COUNTED-STRING" environment? 0= [if] 256 [then] 1 chars + allot : readEscaped \ "ccc" -- c-addr \ *G Parses an escaped string from the input stream according to \ ** the rules of *\fo{parse\"} above, returning the address \ ** of the translated counted string in *\fo{POCKET}. source >in @ /string tuck \ -- len caddr len pocket parse\" nip - >in +! pocket ; }private : S\" \ "string" -- caddr u \ *G As *\fo{S"}, but translates escaped characters using \ ** *\fo{parse\"} above. readEscaped count state @ if postpone sliteral then ; IMMEDIATE privatize \ hide the internal words pforth-2.0.1/fth/smart_if.fth000066400000000000000000000040101435661464300161130ustar00rootroot00000000000000\ @(#) smart_if.fth 98/01/26 1.2 \ Smart Conditionals \ Allow use of if, do, begin, etc.outside of colon definitions. \ \ Thanks to Mitch Bradley for the idea. \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. anew task-smart_if.fth variable SMIF-XT \ execution token for conditional code variable SMIF-DEPTH \ depth of nested conditionals : SMIF{ ( -- , if executing, start compiling, setup depth ) state @ 0= IF :noname smif-xt ! 1 smif-depth ! ELSE 1 smif-depth +! THEN ; : }SMIF ( -- , unnest, stop compiling, execute code and forget ) smif-xt @ IF -1 smif-depth +! smif-depth @ 0 <= IF postpone ; \ stop compiling smif-xt @ execute \ execute conditional code smif-xt @ >code dp ! \ forget conditional code 0 smif-xt ! \ clear so we don't mess up later THEN THEN ; \ redefine conditionals to use smart mode : IF smif{ postpone if ; immediate : DO smif{ postpone do ; immediate : ?DO smif{ postpone ?do ; immediate : BEGIN smif{ postpone begin ; immediate : THEN postpone then }smif ; immediate : REPEAT postpone repeat }smif ; immediate : UNTIL postpone until }smif ; immediate : LOOP postpone loop }smif ; immediate : +LOOP postpone +loop }smif ; immediate pforth-2.0.1/fth/strings.fth000066400000000000000000000036361435661464300160150ustar00rootroot00000000000000\ @(#) strings.fth 98/01/26 1.2 \ String support for PForth \ \ Copyright Phil Burk 1994 ANEW TASK-STRINGS.FTH : -TRAILING ( c-addr u1 -- c-addr u2 , strip trailing blanks ) dup 0> IF BEGIN 2dup 1- chars + c@ bl = over 0> and WHILE 1- REPEAT THEN ; \ Structure of string table : $ARRAY ( ) CREATE ( #strings #chars_max -- ) dup , 2+ * even-up allot DOES> ( index -- $addr ) dup @ ( get #chars ) rot * + cell+ ; \ Compare two strings : $= ( $1 $2 -- flag , true if equal ) -1 -rot dup c@ 1+ 0 DO dup c@ tolower 2 pick c@ tolower - IF rot drop 0 -rot LEAVE THEN 1+ swap 1+ swap LOOP 2drop ; : TEXT= ( addr1 addr2 count -- flag ) >r -1 -rot r> 0 ?DO dup c@ tolower 2 pick c@ tolower - IF rot drop 0 -rot LEAVE THEN 1+ swap 1+ swap LOOP 2drop ; : TEXT=? ( addr1 count addr2 -- flag , for JForth compatibility ) swap text= ; : $MATCH? ( $string1 $string2 -- flag , case INsensitive ) dup c@ 1+ text= ; : INDEX ( $string char -- false | address_char true , search for char in string ) >r >r 0 r> r> over c@ 1+ 1 DO over i + c@ over = IF rot drop over i + rot rot LEAVE THEN LOOP 2drop ?dup 0= 0= ; : $APPEND.CHAR ( $string char -- ) \ ugly stack diagram over count chars + c! dup c@ 1+ swap c! ; \ ---------------------------------------------- : ($ROM) ( index address -- $string ) ( -- index address ) swap 0 ?DO dup c@ 1+ + aligned LOOP ; : $ROM ( packed array of strings, unalterable ) CREATE ( -- ) DOES> ( index -- $string ) ($rom) ; : TEXTROM ( packed array of strings, unalterable ) CREATE ( -- ) DOES> ( index -- address count ) ($rom) count ; \ ----------------------------------------------- pforth-2.0.1/fth/structure.fth000066400000000000000000000023561435661464300163620ustar00rootroot00000000000000\ Structures and fields. \ \ The code is based on the implementation from the ANS standard. \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. anew task-structure.fth : BEGIN-STRUCTURE ( "name" -- struct-sys 0 , start the definition of a structure ) CREATE HERE 0 0 , \ mark stack, lay dummy DOES> @ \ -- structure-size ; : END-STRUCTURE ( addr n -- , terminate a structure definition ) SWAP ! ; : +FIELD ( n <"name"> -- ; Exec: addr -- 'addr ) CREATE OVER , + DOES> @ + ; : FIELD: ( n1 "name" -- n2 ; addr1 -- addr2 ) ALIGNED 1 CELLS +FIELD ; : CFIELD: ( n1 "name" -- n2 ; addr1 -- addr2 ) 1 CHARS +FIELD ; pforth-2.0.1/fth/system.fth000066400000000000000000000472201435661464300156450ustar00rootroot00000000000000: FIRST_COLON ; : LATEST context @ ; : FLAG_IMMEDIATE 64 ; : IMMEDIATE latest dup c@ flag_immediate OR swap c! ; : ( 41 word drop ; immediate ( That was the definition for the comment word. ) ( Now we can add comments to what we are doing! ) ( Note that we are in decimal numeric input mode. ) : \ ( -- , comment out rest of line ) EOL word drop ; immediate \ 1 echo ! \ Uncomment this line to echo Forth code while compiling. \ ********************************************************************* \ This is another style of comment that is common in Forth. \ pFORTH - Portable Forth System \ Based on HMSL Forth \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. \ ********************************************************************* : COUNT dup 1+ swap c@ ; \ Miscellaneous support words : ON ( addr -- , set true ) -1 swap ! ; : OFF ( addr -- , set false ) 0 swap ! ; : CELL+ ( n -- n+cell ) cell + ; : CELL- ( n -- n+cell ) cell - ; : CELL* ( n -- n*cell ) cells ; : CHAR+ ( n -- n+size_of_char ) 1+ ; : CHARS ( n -- n*size_of_char , don't do anything) ; immediate \ useful stack manipulation words : -ROT ( a b c -- c a b ) rot rot ; : 3DUP ( a b c -- a b c a b c ) 2 pick 2 pick 2 pick ; : 2DROP ( a b -- ) drop drop ; : NIP ( a b -- b ) swap drop ; : TUCK ( a b -- b a b ) swap over ; : <= ( a b -- f , true if A <= b ) > 0= ; : >= ( a b -- f , true if A >= b ) < 0= ; : INVERT ( n -- 1'comp ) -1 xor ; : NOT ( n -- !n , logical negation ) 0= ; : NEGATE ( n -- -n ) 0 swap - ; : DNEGATE ( d -- -d , negate by doing 0-d ) 0 0 2swap d- ; \ -------------------------------------------------------------------- : ID. ( nfa -- ) count 31 and type ; : DECIMAL 10 base ! ; : OCTAL 8 base ! ; : HEX 16 base ! ; : BINARY 2 base ! ; : PAD ( -- addr ) here 128 + ; : $MOVE ( $src $dst -- ) over c@ 1+ cmove ; : BETWEEN ( n lo hi -- flag , true if between lo & hi ) >r over r> > >r < r> or 0= ; : [ ( -- , enter interpreter mode ) 0 state ! ; immediate : ] ( -- enter compile mode ) 1 state ! ; : EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ; : ALIGNED ( addr -- a-addr ) [ cell 1- ] literal + [ cell 1- invert ] literal and ; : ALIGN ( -- , align DP ) dp @ aligned dp ! ; : ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ; : C, ( c -- ) here c! 1 chars dp +! ; : W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ; : , ( n -- , lay into dictionary ) align here ! cell allot ; \ Dictionary conversions ------------------------------------------ : N>NEXTLINK ( nfa -- nextlink , traverses name field ) dup c@ 31 and 1+ + aligned ; : NAMEBASE ( -- base-of-names ) Headers-Base @ ; : CODEBASE ( -- base-of-code dictionary ) Code-Base @ ; : NAMELIMIT ( -- limit-of-names ) Headers-limit @ ; : CODELIMIT ( -- limit-of-code, last address in dictionary ) Code-limit @ ; : NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual ) namebase + ; : >CODE ( xt -- secondary_code_address, not valid for primitives ) codebase + ; : CODE> ( secondary_code_address -- xt , not valid for primitives ) codebase - ; : N>LINK ( nfa -- lfa ) 2 CELLS - ; : >BODY ( xt -- pfa ) >code body_offset + ; : BODY> ( pfa -- xt ) body_offset - code> ; \ convert between addresses useable by @, and relocatable addresses. : USE->REL ( useable_addr -- rel_addr ) codebase - ; : REL->USE ( rel_addr -- useable_addr ) codebase + ; \ for JForth code \ : >REL ( adr -- adr ) ; immediate \ : >ABS ( adr -- adr ) ; immediate : X@ ( addr -- xt , fetch execution token from relocatable ) @ ; : X! ( addr -- xt , store execution token as relocatable ) ! ; \ Compiler support ------------------------------------------------ : COMPILE, ( xt -- , compile call to xt ) , ; ( Compiler support , based on FIG ) : [COMPILE] ( -- , compile now even if immediate ) ' compile, ; IMMEDIATE : (COMPILE) ( xt -- , postpone compilation of token ) [compile] literal ( compile a call to literal ) ( store xt of word to be compiled ) [ ' compile, ] literal \ compile call to compile, compile, ; : COMPILE ( -- , save xt and compile later ) ' (compile) ; IMMEDIATE : :NONAME ( -- xt , begin compilation of headerless secondary ) align here code> \ convert here to execution token ] ; \ Error codes defined in ANSI Exception word set. : ERR_ABORT -1 ; \ general abort : ERR_ABORTQ -2 ; \ for abort" : ERR_EXECUTING -14 ; \ compile time word while not compiling : ERR_PAIRS -22 ; \ mismatch in conditional : ERR_DEFER -258 ; \ not a deferred word : ABORT ( i*x -- ) ERR_ABORT throw ; \ Conditionals in '83 form ----------------------------------------- : CONDITIONAL_KEY ( -- , lazy constant ) 29521 ; : ?CONDITION ( f -- ) conditional_key - err_pairs ?error ; : >MARK ( -- addr ) here 0 , ; : >RESOLVE ( addr -- ) here over - swap ! ; : mark ; immediate : THEN ( f orig -- ) swap ?condition >resolve ; immediate : BEGIN ( -- f dest ) ?comp conditional_key mark ; immediate \ conditionals built from primitives : ELSE ( f orig1 -- f orig2 ) [compile] AHEAD 2swap [compile] THEN ; immediate : WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate : REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate : ['] ( -- xt , define compile time tick ) ?comp ' [compile] literal ; immediate \ for example: \ compile time: compile create , (does>) then ; \ execution time: create , ',' data, then patch pi to point to @ \ : con create , does> @ ; \ 345 con pi \ pi \ : (DOES>) ( xt -- , modify previous definition to execute code at xt ) latest name> >code \ get address of code for new word cell + \ offset to second cell in create word ! \ store execution token of DOES> code in new word ; : DOES> ( -- , define execution code for CREATE word ) 0 [compile] literal \ dummy literal to hold xt here cell- \ address of zero in literal compile (does>) \ call (DOES>) from new creation word >r \ move addrz to return stack so ; doesn't see stack garbage [compile] ; \ terminate part of code before does> r> :noname ( addrz xt ) swap ! \ save execution token in literal ; immediate : VARIABLE ( -- ) CREATE 0 , \ IMMEDIATE \ DOES> [compile] aliteral \ %Q This could be optimised ; : 2VARIABLE ( -c- ) ( -x- addr ) create 0 , 0 , ; : CONSTANT ( n -c- ) ( -x- n ) CREATE , ( n -- ) DOES> @ ( -- n ) ; 0 1- constant -1 0 2- constant -2 : 2! ( x1 x2 addr -- , store x2 followed by x1 ) swap over ! cell+ ! ; : 2@ ( addr -- x1 x2 ) dup cell+ @ swap @ ; : 2CONSTANT ( n1 n2 -c- ) ( -x- n1 n2 ) CREATE , , ( n1 n2 -- ) DOES> 2@ ( -- n1 n2 ) ; : ABS ( n -- |n| ) dup 0< IF negate THEN ; : DABS ( d -- |d| ) dup 0< IF dnegate THEN ; : S>D ( s -- d , extend signed single precision to double ) dup 0< IF -1 ELSE 0 THEN ; : D>S ( d -- s ) drop ; : /MOD ( a b -- rem quo , unsigned version, FIXME ) >r s>d r> um/mod ; : MOD ( a b -- rem ) /mod drop ; : 2* ( n -- n*2 ) 1 lshift ; : 2/ ( n -- n/2 ) 1 arshift ; : D2* ( d -- d*2 ) 2* over cell 8 * 1- rshift or swap 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 32 constant BL \ Store and Fetch relocatable data addresses. --------------- : IF.USE->REL ( use -- rel , preserve zero ) dup IF use->rel THEN ; : IF.REL->USE ( rel -- use , preserve zero ) dup IF rel->use THEN ; : A! ( dictionary_address addr -- ) >r if.use->rel r> ! ; : A@ ( addr -- dictionary_address ) @ if.rel->use ; : A, ( dictionary_address -- ) if.use->rel , ; \ Stack data structure ---------------------------------------- \ This is a general purpose stack utility used to implement necessary \ stacks for the compiler or the user. Not real fast. \ These stacks grow up which is different then normal. \ cell 0 - stack pointer, offset from pfa of word \ cell 1 - limit for range checking \ cell 2 - first data location : :STACK ( #cells -- ) CREATE 2 cells , ( offset of first data location ) dup , ( limit for range checking, not currently used ) cells cell+ allot ( allot an extra cell for safety ) ; : >STACK ( n stack -- , push onto stack, postincrement ) dup @ 2dup cell+ swap ! ( -- n stack offset ) + ! ; : STACK> ( stack -- n , pop , predecrement ) dup @ cell- 2dup swap ! + @ ; : STACK@ ( stack -- n , copy ) dup @ cell- + @ ; : STACK.PICK ( index stack -- n , grab Nth from top of stack ) dup @ cell- + swap cells - \ offset for index @ ; : STACKP ( stack -- ptr , to next empty location on stack ) dup @ + ; : 0STACKP ( stack -- , clear stack) 8 swap ! ; 32 :stack ustack ustack 0stackp \ Define JForth like words. : >US ustack >stack ; : US> ustack stack> ; : US@ ustack stack@ ; : 0USP ustack 0stackp ; \ DO LOOP ------------------------------------------------ 3 constant do_flag 4 constant leave_flag 5 constant ?do_flag : DO ( -- , loop-back do_flag jump-from ?do_flag ) ?comp compile (do) here >us do_flag >us ( for backward branch ) ; immediate : ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack ) ?comp ( leave address to set for forward branch ) compile (?do) here 0 , here >us do_flag >us ( for backward branch ) >us ( for forward branch ) ?do_flag >us ; immediate : LEAVE ( -- addr leave_flag ) compile (leave) here 0 , >us leave_flag >us ; immediate : LOOP-FORWARD ( -us- jump-from ?do_flag -- ) BEGIN us@ leave_flag = us@ ?do_flag = OR WHILE us> leave_flag = IF us> here over - cell+ swap ! ELSE us> dup here swap - cell+ swap ! THEN REPEAT ; : LOOP-BACK ( loop-addr do_flag -us- ) us> do_flag ?pairs us> here - here ! cell allot ; : LOOP ( -- , loop-back do_flag jump-from ?do_flag ) compile (loop) loop-forward loop-back ; immediate \ : DOTEST 5 0 do 333 . loop 888 . ; \ : ?DOTEST0 0 0 ?do 333 . loop 888 . ; \ : ?DOTEST1 5 0 ?do 333 . loop 888 . ; : +LOOP ( -- , loop-back do_flag jump-from ?do_flag ) compile (+loop) loop-forward loop-back ; immediate : UNLOOP ( loop-sys -r- ) r> \ save return pointer rdrop rdrop >r ; : RECURSE ( ? -- ? , call the word currently being defined ) latest name> compile, ; immediate : SPACE bl emit ; : SPACES 512 min 0 max 0 ?DO space LOOP ; : 0SP depth 0 ?do drop loop ; : >NEWLINE ( -- , CR if needed ) out @ 0> IF cr THEN ; \ Support for DEFER -------------------- : CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type ) >code @ ['] emit >code @ - err_defer ?error ; : >is ( xt -- address_of_vector ) >code cell + ; : (IS) ( xt_do xt_deferred -- ) >is ! ; : IS ( xt -- , act like normal IS ) ' \ xt dup check.defer state @ IF [compile] literal compile (is) ELSE (is) THEN ; immediate : (WHAT'S) ( xt -- xt_do ) >is @ ; : WHAT'S ( -- xt , what will deferred word call? ) ' \ xt dup check.defer state @ IF [compile] literal compile (what's) ELSE (what's) THEN ; immediate : /STRING ( addr len n -- addr' len' ) over min rot over + -rot - ; : PLACE ( addr len to -- , move string ) 3dup 1+ swap cmove c! drop ; : PARSE-WORD ( char -- addr len ) >r source tuck >in @ /string r@ skip over swap r> scan >r over - rot r> dup 0<> + - >in ! ; : PARSE ( char -- addr len ) >r source >in @ /string over swap r> scan >r over - dup r> 0<> - >in +! ; : LWORD ( char -- addr ) parse-word here place here \ 00002 , use PARSE-WORD ; : ASCII ( -- char , state smart ) bl parse drop c@ state @ IF [compile] literal THEN ; immediate : CHAR ( -- char , interpret mode ) bl parse drop c@ ; : [CHAR] ( -- char , for compile mode ) char [compile] literal ; immediate : $TYPE ( $string -- ) count type ; : 'word ( -- addr ) here ; : EVEN ( addr -- addr' ) dup 1 and + ; : (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?) r> dup count + aligned >r ; : (S") ( -- c-addr cnt ) r> count 2dup + aligned >r ; : (.") ( -- , type following string ) r> count 2dup + aligned >r type ; : ", ( adr len -- , place string into dictionary ) tuck 'word place 1+ allot align ; : ," ( -- ) [char] " parse ", ; : .( ( -- , type string delimited by parentheses ) [CHAR] ) PARSE TYPE ; IMMEDIATE : ." ( -- , type string ) state @ IF compile (.") ," ELSE [char] " parse type THEN ; immediate : .' ( -- , type string delimited by single quote ) state @ IF compile (.") [char] ' parse ", ELSE [char] ' parse type THEN ; immediate : C" ( -- addr , return string address, ANSI ) state @ IF compile (c") ," ELSE [char] " parse pad place pad THEN ; immediate : S" ( -- , -- addr , return string address, ANSI ) state @ IF compile (s") ," ELSE [char] " parse pad place pad count THEN ; immediate : " ( -- , -- addr , return string address ) [compile] C" ; immediate : P" ( -- , -- addr , return string address ) [compile] C" ; immediate : "" ( -- addr ) state @ IF compile (C") bl parse-word ", ELSE bl parse-word pad place pad THEN ; immediate : SLITERAL ( addr cnt -- , compile string ) compile (S") ", ; IMMEDIATE : $APPEND ( addr count $1 -- , append text to $1 ) over >r dup >r count + ( -- a2 c2 end1 ) swap cmove r> dup c@ ( a1 c1 ) r> + ( -- a1 totalcount ) swap c! ; \ ANSI word to replace [COMPILE] and COMPILE ---------------- : POSTPONE ( -- ) bl word find dup 0= IF ." Postpone could not find " count type cr abort ELSE 0> IF compile, \ immediate ELSE (compile) \ normal THEN THEN ; immediate \ ----------------------------------------------------------------- \ Auto Initialization : AUTO.INIT ( -- ) \ Kernel finds AUTO.INIT and executes it after loading dictionary. \ ." Begin AUTO.INIT ------" cr ; : AUTO.TERM ( -- ) \ Kernel finds AUTO.TERM and executes it on bye. \ ." End AUTO.TERM ------" cr ; \ -------------- INCLUDE ------------------------------------------ variable TRACE-INCLUDE : 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 (:) ; : INCLUDED ( c-addr u -- ) \ Print messages. trace-include @ IF >newline ." Include " 2dup type cr THEN here >r 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> - IF ." Warning: stack depth changed during include!" cr .s cr 0sp THEN include.mark.end THEN trace-include @ IF ." include added " here r@ - . ." bytes," codelimit here - . ." left." cr THEN rdrop ; defer MAP.FILENAME ( $filename1 -- $filename2 , modify name ) ' noop is map.filename : $INCLUDE ( $filename -- ) map.filename count included ; create INCLUDE-SAVE-NAME 128 allot : INCLUDE ( -- ) BL lword dup include-save-name $move \ save for RI $include ; : RI ( -- , ReInclude previous file as a convenience ) include-save-name $include ; : INCLUDE? ( -- , load file if word not defined ) bl word find IF drop bl word drop ( eat word from source ) ELSE drop include THEN ; \ desired sizes for dictionary loaded after SAVE-FORTH variable HEADERS-SIZE variable CODE-SIZE : AUTO.INIT auto.init codelimit codebase - code-size ! namelimit namebase - headers-size ! ; auto.init : SAVE-FORTH ( $name -- ) 0 \ Entry point headers-ptr @ namebase - 65536 + \ NameSize headers-size @ MAX here codebase - 131072 + \ CodeSize code-size @ MAX (save-forth) IF ." SAVE-FORTH failed!" cr abort THEN ; : TURNKEY ( $name entry-token-- ) 0 \ NameSize = 0, names not saved in turnkey dictionary here codebase - 131072 + \ CodeSize, remember that base is HEX (save-forth) IF ." TURNKEY failed!" cr abort THEN ; \ Now that we can load from files, load remainder of dictionary. trace-include on \ Turn this OFF if you do not want to see the contents of the stack after each entry. trace-stack off include loadp4th.fth decimal : ;;;; ; \ Mark end of this file so FILE? can find things in here. FREEZE \ prevent forgetting below this point .( Dictionary compiled, save in "pforth.dic".) cr \ 300000 headers-size ! \ 700000 code-size ! c" pforth.dic" save-forth pforth-2.0.1/fth/t_alloc.fth000066400000000000000000000052741435661464300157410ustar00rootroot00000000000000\ @(#) t_alloc.fth 97/01/28 1.4 \ Test PForth ALLOCATE \ \ Copyright 1994 3DO, Phil Burk INCLUDE? }T{ t_tools.fth anew task-t_alloc.fth decimal 64 constant NUM_TAF_SLOTS variable TAF-MAX-ALLOC variable TAF-MAX-SLOT \ hold addresses and sizes NUM_TAF_SLOTS array TAF-ADDRESSES NUM_TAF_SLOTS array TAF-SIZES : TAF.MAX.ALLOC? { | numb addr ior maxb -- max } 0 -> maxb \ determine maximum amount we can allocate 1024 40 * -> numb BEGIN numb 0> WHILE numb allocate -> ior -> addr ior 0= IF \ success addr free abort" Free failed!" numb -> maxb 0 -> numb ELSE numb 1024 - -> numb THEN REPEAT maxb ; : TAF.INIT ( -- ) NUM_TAF_SLOTS 0 DO 0 i taf-addresses ! LOOP \ taf.max.alloc? ." Total Avail = " dup . cr dup taf-max-alloc ! NUM_TAF_SLOTS / taf-max-slot ! ; : TAF.ALLOC.SLOT { slotnum | addr size -- } \ allocate some RAM taf-max-slot @ 8 - choose 8 + dup allocate abort" Allocation failed!" -> addr -> size addr slotnum taf-addresses ! size slotnum taf-sizes ! \ \ paint RAM with slot number addr size slotnum fill ; : TAF.FREE.SLOT { slotnum | addr size -- } slotnum taf-addresses @ -> addr \ something allocated so check it and free it. slotnum taf-sizes @ 0 DO addr i + c@ slotnum - IF ." Error at " addr i + . ." , slot# " slotnum . cr abort THEN LOOP addr free abort" Free failed!" 0 slotnum taf-addresses ! ; : TAF.DO.SLOT { slotnum -- } slotnum taf-addresses @ 0= IF slotnum taf.alloc.slot ELSE slotnum taf.free.slot THEN ; : TAF.TERM ( -- error , 0 if PASSED ) NUM_TAF_SLOTS 0 DO i taf-addresses @ IF i taf.free.slot THEN LOOP \ taf.max.alloc? dup ." Final MAX = " . cr ." Original MAX = " taf-max-alloc @ dup . cr = IF ." Test PASSED." 0 ELSE ." Test FAILED!" 1 THEN cr ; : TAF.TEST ( NumTests -- ) 1 max dup . ." tests" cr \ flushemit taf.init ." Please wait for test to complete..." cr 0 DO NUM_TAF_SLOTS choose taf.do.slot LOOP taf.term ; .( Testing ALLOCATE and FREE) cr TEST{ T{ 10000 taf.test }T{ 0 }T }TEST pforth-2.0.1/fth/t_case.fth000066400000000000000000000005031435661464300155500ustar00rootroot00000000000000\ test CASE anew test-case : TCASE ( N -- ) CASE 0 OF ." is zero" ENDOF 1 OF 2 choose CASE 0 OF ." chose zero" ENDOF 1 OF ." chose one" ENDOF [ .s cr ." of-depth = " of-depth @ . cr ] ENDCASE ENDOF [ .s cr ." of-depth = " of-depth @ . cr ] ENDCASE ; pforth-2.0.1/fth/t_corex.fth000066400000000000000000000235111435661464300157610ustar00rootroot00000000000000\ @(#) t_corex.fth 98/03/16 1.2 \ Test ANS Forth Core Extensions \ \ Copyright 1994 3DO, Phil Burk INCLUDE? }T{ t_tools.fth ANEW TASK-T_COREX.FTH DECIMAL TEST{ \ ========================================================== T{ 1 2 3 }T{ 1 2 3 }T \ ----------------------------------------------------- .( T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T \ ----------------------------------------------------- 0<> T{ 5 0<> }T{ TRUE }T T{ 0 0<> }T{ 0 }T T{ -1000 0<> }T{ TRUE }T \ ----------------------------------------------------- 2>R 2R> 2R@ : T2>R ( -- .... ) 17 20 5 2>R 19 2R@ 37 2R> \ 2>R should be the equivalent of SWAP >R >R so this next construct \ should reduce to a SWAP. 88 77 2>R R> R> ; T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T \ ----------------------------------------------------- :NONAME T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T \ ----------------------------------------------------- <> T{ 12345 12305 <> }T{ TRUE }T T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T \ ----------------------------------------------------- ?DO : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ; T{ 0 T?DO }T{ 0 }T T{ 4 T?DO }T{ 10 }T \ ----------------------------------------------------- AGAIN : T.AGAIN ( n -- ) BEGIN DUP . DUP 6 < IF EXIT THEN 1- AGAIN ; T{ 10 T.AGAIN CR }T{ 5 }T \ ----------------------------------------------------- C" : T.C" ( -- $STRING ) C" x5&" ; T{ T.C" C@ }T{ 3 }T T{ T.C" COUNT DROP C@ }T{ CHAR x }T T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T \ ----------------------------------------------------- CASE : T.CASE ( N -- ) CASE 1 OF 101 ENDOF 27 OF 892 ENDOF 941 SWAP \ default ENDCASE ; T{ 1 T.CASE }T{ 101 }T T{ 27 T.CASE }T{ 892 }T T{ 49 T.CASE }T{ 941 }T \ ----------------------------------------------------- COMPILE, : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE : T.COMPILE, 19 20 27 COMPILE.SWAP 39 ; T{ T.COMPILE, }T{ 19 27 20 39 }T \ ----------------------------------------------------- CONVERT : T.CONVERT 0 S>D S" 1234xyz" DROP CONVERT >R D>S R> C@ ; T{ T.CONVERT }T{ 1234 CHAR x }T \ ----------------------------------------------------- ERASE : T.COMMA.SEQ ( n -- , lay down N sequential bytes ) 0 ?DO I C, LOOP ; CREATE T-ERASE-DATA 64 T.COMMA.SEQ T{ T-ERASE-DATA 8 + C@ }T{ 8 }T T{ T-ERASE-DATA 7 + 3 ERASE T{ T-ERASE-DATA 6 + C@ }T{ 6 }T T{ T-ERASE-DATA 7 + C@ }T{ 0 }T T{ T-ERASE-DATA 8 + C@ }T{ 0 }T T{ T-ERASE-DATA 9 + C@ }T{ 0 }T T{ T-ERASE-DATA 10 + C@ }T{ 10 }T \ ----------------------------------------------------- FALSE T{ FALSE }T{ 0 }T \ ----------------------------------------------------- HEX T{ HEX 10 DECIMAL }T{ 16 }T \ ----------------------------------------------------- MARKER : INDIC? ( -- ifInDic , is the following word defined? ) bl word find swap drop 0= 0= ; create FOOBAR MARKER MYMARK \ create word that forgets itself create GOOFBALL MYMARK T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T \ ----------------------------------------------------- NIP T{ 33 44 55 NIP }T{ 33 55 }T \ ----------------------------------------------------- PARSE : T.PARSE ( char char -- addr num ) PARSE >R \ save length PAD R@ CMOVE \ move string to pad PAD R> ; T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T \ ----------------------------------------------------- PICK T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T \ ----------------------------------------------------- QUERY T{ ' QUERY 0<> }T{ TRUE }T \ ----------------------------------------------------- REFILL T{ ' REFILL 0<> }T{ TRUE }T \ ----------------------------------------------------- RESTORE-INPUT 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{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T \ ----------------------------------------------------- SOURCE-ID T{ SOURCE-ID 0<> }T{ TRUE }T T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T \ ----------------------------------------------------- SPAN T{ ' SPAN 0<> }T{ TRUE }T \ ----------------------------------------------------- TO VALUE 333 VALUE MY-VALUE T{ MY-VALUE }T{ 333 }T T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T : TEST.VALUE ( -- 19 100 ) 100 TO MY-VALUE 19 MY-VALUE ; T{ TEST.VALUE }T{ 19 100 }T \ ----------------------------------------------------- TRUE T{ TRUE }T{ 0 0= }T \ ----------------------------------------------------- TUCK T{ 44 55 66 TUCK }T{ 44 66 55 66 }T \ ----------------------------------------------------- U.R HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR ABCD4321 C U.R CR DECIMAL \ ----------------------------------------------------- U> T{ -5 3 U> }T{ TRUE }T T{ 10 8 U> }T{ TRUE }T \ ----------------------------------------------------- UNUSED T{ UNUSED 0> }T{ TRUE }T \ ----------------------------------------------------- WITHIN T{ 4 5 10 WITHIN }T{ 0 }T T{ 5 5 10 WITHIN }T{ TRUE }T T{ 9 5 10 WITHIN }T{ TRUE }T T{ 10 5 10 WITHIN }T{ 0 }T T{ 4 10 5 WITHIN }T{ TRUE }T T{ 5 10 5 WITHIN }T{ 0 }T T{ 9 10 5 WITHIN }T{ 0 }T T{ 10 10 5 WITHIN }T{ TRUE }T T{ -6 -5 10 WITHIN }T{ 0 }T T{ -5 -5 10 WITHIN }T{ TRUE }T T{ 9 -5 10 WITHIN }T{ TRUE }T T{ 10 -5 10 WITHIN }T{ 0 }T \ ----------------------------------------------------- [COMPILE] : T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE : T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ; 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 \ ----------------------------------------------------- PROGRAMMING T{ exists? words }T{ true }T \ high level T{ exists? swap }T{ true }T \ in kernel T{ exists? lkajsdlakjs }T{ false }T T{ [defined] if }T{ true }T \ high level T{ [defined] dup }T{ true }T \ in kernel T{ [defined] k23jh42 }T{ false }T T{ [undefined] if }T{ false }T \ high level T{ [undefined] dup }T{ false }T \ in kernel T{ [undefined] k23jh42 }T{ true }T \ ----------------------------------------------------- Structures BEGIN-STRUCTURE XYZS cfield: xyz.c1 field: xyz.w1 cfield: xyz.c2 END-STRUCTURE T{ xyzs }T{ 2 cells 1+ }T T{ 0 xyz.c1 }T{ 0 }T T{ 0 xyz.w1 }T{ cell }T T{ 0 xyz.c2 }T{ 2 cells }T CREATE MY-XYZS XYZS ALLOT \ test forward order 77 my-xyzs xyz.c1 c! 1234567 my-xyzs xyz.w1 ! 99 my-xyzs xyz.c2 c! T{ my-xyzs xyz.c1 c@ }T{ 77 }T T{ my-xyzs xyz.w1 @ }T{ 1234567 }T T{ my-xyzs xyz.c2 c@ }T{ 99 }T }TEST pforth-2.0.1/fth/t_file.fth000066400000000000000000000246411435661464300155650ustar00rootroot00000000000000\ 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 \ ---------------------------------------------------------------------------- T{ : GC4 S" XY" ; }T{ }T T{ GC4 SWAP DROP }T{ 2 }T T{ GC4 DROP DUP C@ SWAP CHAR+ C@ }T{ $ 58 $ 59 }T : GC5 S" A String"2DROP ; \ There is no space between the " and 2DROP T{ GC5 }T{ }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 pforth-2.0.1/fth/t_floats.fth000066400000000000000000000112441435661464300161310ustar00rootroot00000000000000\ @(#) t_floats.fth 98/02/26 1.1 17:46:04 \ Test ANS Forth FLOAT words. \ \ Copyright 1994 3DO, Phil Burk INCLUDE? }T{ t_tools.fth ANEW TASK-T_FLOATS.FTH DECIMAL 3.14159265 fconstant PI TEST{ \ ========================================================== T{ 1 2 3 }T{ 1 2 3 }T \ ----------------------------------------------------- D>F F>D \ test some basic floating point <> integer conversion T{ 4 0 D>F F>D }T{ 4 0 }T T{ 835 0 D>F F>D }T{ 835 0 }T T{ -57 -1 D>F F>D }T{ -57 -1 }T T{ 15 S>F 2 S>F F/ F>S }T{ 7 }T \ 15.0/2.0 -> 7.5 \ ----------------------------------------------------- input T{ 79.2 F>S }T{ 79 }T T{ 0.003 F>S }T{ 0 }T \ ------------------------------------------------------ F~ T{ 23.4 23.5 0.2 f~ }T{ true }T T{ 23.4 23.7 0.2 f~ }T{ false }T T{ 922.3 922.3 0.0 f~ }T{ true }T T{ 922.3 922.31 0.0 f~ }T{ false }T T{ 0.0 0.0 0.0 f~ }T{ true }T T{ 0.0 -0.0 0.0 f~ }T{ false }T T{ 50.0 51.0 -0.02 f~ }T{ true }T T{ 50.0 51.0 -0.002 f~ }T{ false }T T{ 500.0 510.0 -0.02 f~ }T{ true }T T{ 500.0 510.0 -0.002 f~ }T{ false }T \ convert number to text representation and then back to float : T_F. ( -- ok? ) ( r ftol -f- ) fover (f.) >float fswap f~ AND ; : T_FS. ( -- ok? ) ( r ftol -f- ) fover (fs.) >float fswap f~ AND ; : T_FE. ( -- ok? ) ( r ftol -f- ) fover (fe.) >float fswap f~ AND ; : T_FG. ( -- ok? ) ( r ftol -f- ) fover (f.) >float fswap f~ AND ; : T_F>D ( -- ok? ) ( r ftol -f- ) fover f>d d>f fswap f~ ; T{ 0.0 0.00001 T_F. }T{ true }T T{ 0.0 0.00001 T_FS. }T{ true }T T{ 0.0 0.00001 T_FE. }T{ true }T T{ 0.0 0.00001 T_FG. }T{ true }T T{ 0.0 0.00001 T_F>D }T{ true }T T{ 12.34 -0.0001 T_F. }T{ true }T T{ 12.34 -0.0001 T_FS. }T{ true }T T{ 12.34 -0.0001 T_FE. }T{ true }T T{ 12.34 -0.0001 T_FG. }T{ true }T T{ 1234.0 -0.0001 T_F>D }T{ true }T T{ 2345 S>F 79 S>F F/ -0.0001 T_F. }T{ true }T T{ 511 S>F -294 S>F F/ -0.0001 T_F. }T{ true }T : T.SERIES { N matchCFA | flag -- ok? } ( fstart fmult -f- ) fswap ( -- fmult fstart ) true -> flag N 0 ?DO fdup -0.0001 matchCFA execute not IF false -> flag ." T_F_SERIES failed for " i . fdup f. cr leave THEN \ i . fdup f. cr fover f* LOOP matchCFA >name id. ." T.SERIES final = " fs. cr flag ; : T.SERIES_F. ['] t_f. t.series ; : T.SERIES_FS. ['] t_fs. t.series ; : T.SERIES_FG. ['] t_fg. t.series ; : T.SERIES_FE. ['] t_fe. t.series ; : T.SERIES_F>D ['] t_f>d t.series ; T{ 1.0 1.3 150 t.series_f. }T{ true }T T{ 1.0 -1.3 150 t.series_f. }T{ true }T T{ 2.3456789 1.3719 150 t.series_f. }T{ true }T T{ 3000.0 1.298 120 t.series_f>d }T{ true }T T{ 1.2 1.27751 150 t.series_fs. }T{ true }T T{ 7.43 0.812255 200 t.series_fs. }T{ true }T T{ 1.195 1.30071 150 t.series_fe. }T{ true }T T{ 5.913 0.80644 200 t.series_fe. }T{ true }T T{ 1.395 1.55071 120 t.series_fe. }T{ true }T T{ 5.413 0.83644 160 t.series_fe. }T{ true }T \ ----------------------------------------------------- FABS T{ 0.0 FABS 0.0 0.00001 F~ }T{ true }T T{ 7.0 FABS 7.0 0.00001 F~ }T{ true }T T{ -47.3 FABS 47.3 0.00001 F~ }T{ true }T \ ----------------------------------------------------- FSQRT T{ 49.0 FSQRT 7.0 -0.0001 F~ }T{ true }T T{ 2.0 FSQRT 1.414214 -0.0001 F~ }T{ true }T \ ----------------------------------------------------- FSIN T{ 0.0 FSIN 0.0 0.00001 F~ }T{ true }T T{ PI FSIN 0.0 0.00001 F~ }T{ true }T T{ PI 2.0 F* FSIN 0.0 0.00001 F~ }T{ true }T T{ PI 0.5 F* FSIN 1.0 0.00001 F~ }T{ true }T T{ PI 6.0 F/ FSIN 0.5 0.00001 F~ }T{ true }T \ ----------------------------------------------------- FROUND T{ 0.1 FROUND 0.0 0.0 F~ }T{ true }T T{ 6.6 FROUND 7.0 0.0 F~ }T{ true }T T{ -3.2 FROUND -3.0 0.0 F~ }T{ true }T T{ -8.8 FROUND -9.0 0.0 F~ }T{ true }T \ ----------------------------------------------------- FFIELD: BEGIN-STRUCTURE ABCS field: abc.w1 ffield: abc.f1 field: abc.w2 END-STRUCTURE T{ 0 abc.w1 }T{ 0 }T T{ 0 abc.f1 }T{ 1 floats }T \ aligns to next float boundary T{ 0 abc.w2 }T{ 2 floats }T \ f1 adds a float T{ abcs }T{ 2 floats cell + }T \ w2 adds a cell CREATE MY-ABCS ABCS ALLOT 6543 my-abcs abc.w1 ! 23.45 my-abcs abc.f1 f! 98765 my-abcs abc.w2 ! T{ my-abcs abc.w1 @ }T{ 6543 }T T{ my-abcs abc.f1 f@ 23.45 0.0 F~ }T{ true }T T{ my-abcs abc.w2 @ }T{ 98765 }T \ ----------------------------------------------------- \ }TEST pforth-2.0.1/fth/t_include.fth000066400000000000000000000003211435661464300162560ustar00rootroot00000000000000\ Test INCLUDE errors. \ \ Copyright 2001Phil Burk include? }T{ t_tools.fth marker task-t_string.fth decimal : F_UNDEF " t_load_undef.fth" ; test{ T{ F_UNDEF ' $include catch }T{ F_UNDEF -13 }T }test pforth-2.0.1/fth/t_load.fth000066400000000000000000000002111435661464300155500ustar00rootroot00000000000000\ Test nested INCLUDE errors. \ \ Copyright 2001Phil Burk \ include t_load_undef.fth \ include t_load_semi.fth include t_load_defer.fth pforth-2.0.1/fth/t_load_defer.fth000066400000000000000000000001531435661464300167220ustar00rootroot00000000000000\ Test INCLUDE errors. what's dup >name id. \ but DUP is not deferred! We should never reach this text. pforth-2.0.1/fth/t_load_pairs.fth000066400000000000000000000000761435661464300167570ustar00rootroot00000000000000\ Test INCLUDE errors. : T.LOAD.PAIRS 10 0 DO i . THEN ; pforth-2.0.1/fth/t_load_semi.fth000066400000000000000000000001241435661464300165700ustar00rootroot00000000000000\ Test INCLUDE errors. : T.LOAD.PAIRS 1 IF ." hello" cr ; \ missing a THEN pforth-2.0.1/fth/t_load_undef.fth000066400000000000000000000001371435661464300167400ustar00rootroot00000000000000\ Test INCLUDE errors. : T.LOAD.UNDEF 23 45 swap BADWORD \ reference an undefined word! ; pforth-2.0.1/fth/t_locals.fth000066400000000000000000000021571435661464300161210ustar00rootroot00000000000000\ @(#) t_locals.fth 97/01/28 1.1 \ Test PForth LOCAL variables. \ \ Copyright 1996 3DO, Phil Burk include? }T{ t_tools.fth anew task-t_locals.fth decimal test{ \ test value and locals T{ 333 value my-value my-value }T{ 333 }T T{ 1000 -> my-value my-value }T{ 1000 }T T{ 35 +-> my-value my-value }T{ 1035 }T T{ 987 to my-value my-value }T{ 987 }T : test.value ( -- ok ) 100 -> my-value my-value 100 = 47 +-> my-value my-value 147 = AND ; T{ test.value }T{ TRUE }T \ test compile time behavior of a VALUE 567 value VAL3 immediate : VD3 val3 literal ; T{ vd3 }T{ 567 }T \ test locals in a word : test.locs { aa bb | cc -- ok } cc 0= aa bb + -> cc aa bb + cc = AND aa -> cc bb +-> cc aa bb + cc = AND ; T{ 200 59 test.locs }T{ TRUE }T .( Test warning when no locals defined.) cr : loc.nonames { -- } 1234 ; T{ loc.nonames }T{ 1234 }T \ try to put EOLs and comments in variable list : calc.area { width \ horizontal dimension height \ vertical dimension -- area , calculate area of a rectangle } width height * ; T{ 5 20 calc.area }T{ 100 }T }test pforth-2.0.1/fth/t_nolf.fth000066400000000000000000000001701435661464300155730ustar00rootroot00000000000000\ Test behavior of pForth when line encountered with no EOF at end. ." First Line of Two" cr ." Second Line of Two" cr pforth-2.0.1/fth/t_required_helper1.fth000066400000000000000000000000371435661464300200770ustar00rootroot00000000000000\ For testing REQUIRED etc 1+ pforth-2.0.1/fth/t_required_helper2.fth000066400000000000000000000000371435661464300201000ustar00rootroot00000000000000\ For testing REQUIRED etc 1+ pforth-2.0.1/fth/t_strings.fth000066400000000000000000000113031435661464300163260ustar00rootroot00000000000000\ @(#) t_strings.fth 97/12/10 1.1 \ Test ANS Forth String Word Set \ \ Copyright 1994 3DO, Phil Burk include? }T{ t_tools.fth marker task-t_string.fth decimal test{ echo off \ ========================================================== \ test is.ok? T{ 1 2 3 }T{ 1 2 3 }T : STR1 S" Hello " ; : STR2 S" Hello World" ; : STR3 S" " ; \ ----------------------------------------------------- -TRAILING T{ STR1 -TRAILING }T{ STR1 DROP 5 }T T{ STR2 -TRAILING }T{ STR2 }T T{ STR3 -TRAILING }T{ STR3 }T \ ----------------------------------------------------- /STRING T{ STR2 6 /STRING }T{ STR2 DROP 6 CHARS + STR2 NIP 6 - }T \ ----------------------------------------------------- BLANK : T.COMMA.SEQ ( n -- , lay down N sequential bytes ) 0 ?DO I C, LOOP ; CREATE T-BLANK-DATA 64 T.COMMA.SEQ T{ T-BLANK-DATA 8 + C@ }T{ 8 }T T-BLANK-DATA 7 + 3 BLANK T{ T-BLANK-DATA 6 + C@ }T{ 6 }T T{ T-BLANK-DATA 7 + C@ }T{ BL }T T{ T-BLANK-DATA 8 + C@ }T{ BL }T T{ T-BLANK-DATA 9 + C@ }T{ BL }T T{ T-BLANK-DATA 10 + C@ }T{ 10 }T FORGET T.COMMA.SEQ \ ----------------------------------------------------- CMOVE : T.COMMA.SEQ ( n -- , lay down N sequential bytes ) 0 ?DO I C, LOOP ; CREATE T-BLANK-DATA 64 T.COMMA.SEQ T-BLANK-DATA 7 + T-BLANK-DATA 6 + 3 CMOVE T{ T-BLANK-DATA 5 + C@ }T{ 5 }T T{ T-BLANK-DATA 6 + C@ }T{ 7 }T T{ T-BLANK-DATA 7 + C@ }T{ 8 }T T{ T-BLANK-DATA 8 + C@ }T{ 9 }T T{ T-BLANK-DATA 9 + C@ }T{ 9 }T FORGET T.COMMA.SEQ \ ----------------------------------------------------- CMOVE> : T.COMMA.SEQ ( n -- , lay down N sequential bytes ) 0 ?DO I C, LOOP ; CREATE T-BLANK-DATA 64 T.COMMA.SEQ T{ T-BLANK-DATA 6 + T-BLANK-DATA 7 + 3 CMOVE> T{ T-BLANK-DATA 5 + C@ }T{ 5 }T T{ T-BLANK-DATA 6 + C@ }T{ 6 }T T{ T-BLANK-DATA 7 + C@ }T{ 6 }T T{ T-BLANK-DATA 8 + C@ }T{ 7 }T T{ T-BLANK-DATA 9 + C@ }T{ 8 }T T{ T-BLANK-DATA 10 + C@ }T{ 10 }T FORGET T.COMMA.SEQ \ ----------------------------------------------------- COMPARE T{ : T.COMPARE.1 S" abcd" S" abcd" compare ; t.compare.1 }T{ 0 }T T{ : T.COMPARE.2 S" abcd" S" abcde" compare ; t.compare.2 }T{ -1 }T T{ : T.COMPARE.3 S" abcdef" S" abcde" compare ; t.compare.3 }T{ 1 }T T{ : T.COMPARE.4 S" abGd" S" abcde" compare ; t.compare.4 }T{ -1 }T T{ : T.COMPARE.5 S" abcd" S" aXcde" compare ; t.compare.5 }T{ 1 }T T{ : T.COMPARE.6 S" abGd" S" abcd" compare ; t.compare.6 }T{ -1 }T T{ : T.COMPARE.7 S" World" S" World" compare ; t.compare.7 }T{ 0 }T FORGET T.COMPARE.1 \ ----------------------------------------------------- SEARCH : STR-SEARCH S" ABCDefghIJKL" ; T{ : T.SEARCH.1 STR-SEARCH S" ABCD" SEARCH ; T.SEARCH.1 }T{ STR-SEARCH TRUE }T T{ : T.SEARCH.2 STR-SEARCH S" efg" SEARCH ; T.SEARCH.2 }T{ STR-SEARCH 4 - SWAP 4 CHARS + SWAP TRUE }T T{ : T.SEARCH.3 STR-SEARCH S" IJKL" SEARCH ; T.SEARCH.3 }T{ STR-SEARCH DROP 8 CHARS + 4 TRUE }T T{ : T.SEARCH.4 STR-SEARCH STR-SEARCH SEARCH ; T.SEARCH.4 }T{ STR-SEARCH TRUE }T T{ : T.SEARCH.5 STR-SEARCH S" CDex" SEARCH ; T.SEARCH.5 }T{ STR-SEARCH FALSE }T T{ : T.SEARCH.6 STR-SEARCH S" KLM" SEARCH ; T.SEARCH.6 }T{ STR-SEARCH FALSE }T FORGET STR-SEARCH \ ----------------------------------------------------- SLITERAL CREATE FAKE-STRING CHAR H C, CHAR e C, CHAR l C, CHAR l C, CHAR o C, ALIGN T{ : T.SLITERAL.1 [ FAKE-STRING 5 ] SLITERAL ; T.SLITERAL.1 FAKE-STRING 5 COMPARE }T{ 0 }T \ ----------------------------------------------------- S\" HEX T{ : GC5 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; }T{ }T T{ GC5 SWAP DROP }T{ 14 }T \ String length T{ GC5 DROP C@ }T{ 07 }T \ \a BEL Bell T{ GC5 DROP 1 CHARS + C@ }T{ 08 }T \ \b BS Backspace T{ GC5 DROP 2 CHARS + C@ }T{ 1B }T \ \e ESC Escape T{ GC5 DROP 3 CHARS + C@ }T{ 0C }T \ \f FF Form feed T{ GC5 DROP 4 CHARS + C@ }T{ 0A }T \ \l LF Line feed T{ GC5 DROP 5 CHARS + C@ }T{ 0D }T \ \m CR of CR/LF pair T{ GC5 DROP 6 CHARS + C@ }T{ 0A }T \ LF of CR/LF pair T{ GC5 DROP 7 CHARS + C@ }T{ 22 }T \ \q " Double Quote T{ GC5 DROP 8 CHARS + C@ }T{ 0D }T \ \r CR Carriage Return T{ GC5 DROP 9 CHARS + C@ }T{ 09 }T \ \t TAB Horizontal Tab T{ GC5 DROP A CHARS + C@ }T{ 0B }T \ \v VT Vertical Tab T{ GC5 DROP B CHARS + C@ }T{ 0F }T \ \x0F Given Char T{ GC5 DROP C CHARS + C@ }T{ 30 }T \ 0 0 Digit follow on T{ GC5 DROP D CHARS + C@ }T{ 1F }T \ \x1F Given Char T{ GC5 DROP E CHARS + C@ }T{ 61 }T \ a a Hex follow on T{ GC5 DROP F CHARS + C@ }T{ AB }T \ \xaB Insensitive Given Char T{ GC5 DROP 10 CHARS + C@ }T{ 78 }T \ x x Non hex follow on T{ GC5 DROP 11 CHARS + C@ }T{ 00 }T \ \z NUL No Character T{ GC5 DROP 12 CHARS + C@ }T{ 22 }T \ \" " Double Quote T{ GC5 DROP 13 CHARS + C@ }T{ 5C }T \ \\ \ Back Slash DECIMAL }test pforth-2.0.1/fth/t_tools.fth000066400000000000000000000037221435661464300160030ustar00rootroot00000000000000\ @(#) t_tools.fth 97/12/10 1.1 \ Test Tools for pForth \ \ Based on testing tools from John Hayes \ (c) 1993 Johns Hopkins University / Applied Physics Laboratory \ \ Syntax was changed to avoid conflict with { -> and } for local variables. \ Also added tracking of #successes and #errors. anew task-t_tools.fth decimal variable TEST-DEPTH variable TEST-PASSED variable TEST-FAILED 40 constant TEST_EXIT_FAILURE \ returned form pForth to shell : TEST{ depth test-depth ! 0 test-passed ! 0 test-failed ! ; : }TEST test-passed @ 4 .r ." passed, " test-failed @ 4 .r ." failed." cr test-failed @ 0> IF TEST_EXIT_FAILURE bye-code ! THEN ; VARIABLE actual-depth \ stack record CREATE actual-results 20 CELLS ALLOT : empty-stack \ ( ... -- ) Empty stack. DEPTH dup 0> IF 0 DO DROP LOOP ELSE drop THEN ; CREATE the-test 128 CHARS ALLOT : ERROR \ ( c-addr u -- ) Display an error message followed by \ the line that had the error. TYPE the-test COUNT TYPE CR \ display line corresponding to error empty-stack \ throw away every thing else ; : T{ source the-test place empty-stack ; : }T{ \ ( ... -- ) Record depth and content of stack. DEPTH actual-depth ! \ record depth DEPTH 0 ?DO actual-results I CELLS + ! LOOP \ save them ; : }T \ ( ... -- ) Compare stack (expected) contents with saved \ (actual) contents. DEPTH actual-depth @ = IF \ if depths match 1 test-passed +! \ assume will pass DEPTH 0 ?DO \ for each stack item actual-results I CELLS + @ \ compare actual with expected <> IF -1 test-passed +! 1 test-failed +! S" INCORRECT RESULT: " error LEAVE THEN LOOP ELSE \ depth mismatch 1 test-failed +! S" WRONG NUMBER OF RESULTS: " error THEN ; pforth-2.0.1/fth/termio.fth000066400000000000000000000032021435661464300156100ustar00rootroot00000000000000\ Terminal I/O \ \ Requires an ANSI compatible terminal. \ \ To get Windows computers to use ANSI mode in their DOS windows, \ Add this line to "C:\CONFIG.SYS" then reboot. \ \ device=c:\windows\command\ansi.sys \ \ Author: Phil Burk \ Copyright 1988 Phil Burk \ Revised 2001 for pForth ANEW TASK-TERMIO.FTH decimal $ 08 constant ASCII_BACKSPACE $ 7F constant ASCII_DELETE $ 1B constant ASCII_ESCAPE $ 01 constant ASCII_CTRL_A $ 05 constant ASCII_CTRL_E $ 18 constant ASCII_CTRL_X \ ANSI arrow key sequences \ ESC [ 0x41 is UP \ ESC [ 0x42 is DOWN \ ESC [ 0x43 is RIGHT \ ESC [ 0x44 is LEFT \ ANSI terminal control \ ESC [ 2J is clear screen \ ESC [ {n} D is move left \ ESC [ {n} C is move right \ ESC [ K is erase to end of line : ESC[ ( send ESCAPE and [ ) ASCII_ESCAPE emit ascii [ emit ; : CLS ( -- , clear screen ) ESC[ ." 2J" ; : TIO.BACKWARDS ( n -- , move cursor backwards ) ESC[ base @ >r decimal 0 .r r> base ! ascii D emit ; : TIO.FORWARDS ( n -- , move cursor forwards ) ESC[ base @ >r decimal 0 .r r> base ! ascii C emit ; : TIO.ERASE.EOL ( -- , erase to the end of the line ) ESC[ ascii K emit ; : BELL ( -- , ring the terminal bell ) 7 emit ; : BACKSPACE ( -- , backspace action ) 8 emit space 8 emit ; 0 [IF] \ for testing : SHOWKEYS ( -- , show keys pressed in hex ) BEGIN key dup . ." , $ " dup .hex cr ascii q = UNTIL ; : AZ ascii z 1+ ascii a DO i emit LOOP ; : TEST.BACK1 AZ 5 tio.backwards 1000 msec tio.erase.eol ; : TEST.BACK2 AZ 10 tio.backwards 1000 msec ." 12345" 1000 msec ; [THEN] pforth-2.0.1/fth/tester.fth000066400000000000000000000033401435661464300156220ustar00rootroot00000000000000\ From: John Hayes S1I \ Subject: tester.fr \ Date: Mon, 27 Nov 95 13:10:09 PST \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. \ VERSION 1.1 HEX \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. VARIABLE VERBOSE FALSE VERBOSE ! : EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; : ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY \ THE LINE THAT HAD THE ERROR. TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR EMPTY-STACK \ THROW AWAY EVERY THING ELSE ; VARIABLE ACTUAL-DEPTH \ STACK RECORD CREATE ACTUAL-RESULTS 20 CELLS ALLOT : { \ ( -- ) SYNTACTIC SUGAR. ; : -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH ?DUP IF \ IF THERE IS SOMETHING ON STACK 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM THEN ; : } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED \ (ACTUAL) CONTENTS. DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK 0 DO \ FOR EACH STACK ITEM ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN LOOP THEN ELSE \ DEPTH MISMATCH S" WRONG NUMBER OF RESULTS: " ERROR THEN ; : TESTING \ ( -- ) TALKING COMMENT. SOURCE VERBOSE @ IF DUP >R TYPE CR R> >IN ! ELSE >IN ! DROP THEN ; pforth-2.0.1/fth/trace.fth000066400000000000000000000314131435661464300154140ustar00rootroot00000000000000\ @(#) trace.fth 98/01/28 1.2 \ TRACE ( -- , trace pForth word ) \ \ Single step debugger. \ TRACE ( i*x -- , setup trace for Forth word ) \ S ( -- , step over ) \ SM ( many -- , step over many times ) \ SD ( -- , step down ) \ G ( -- , go to end of word ) \ GD ( n -- , go down N levels from current level, stop at end of this level ) \ \ This debugger works by emulating the inner interpreter of pForth. \ It executes code and maintains a separate return stack for the \ program under test. Thus all primitives that operate on the return \ stack, such as DO and R> must be trapped. Local variables must \ also be handled specially. Several state variables are also \ saved and restored to establish the context for the program being \ tested. \ \ Copyright 1997 Phil Burk \ \ Modifications: \ 19990930 John Providenza - Fixed stack bugs in GD anew task-trace.fth : SPACE.TO.COLUMN ( col -- ) out @ - spaces ; : IS.PRIMITIVE? ( xt -- flag , true if kernel primitive ) ['] first_colon < ; 0 value TRACE_IP \ instruction pointer 0 value TRACE_LEVEL \ level of descent for inner interpreter 0 value TRACE_LEVEL_MAX \ maximum level of descent private{ \ use fake return stack 128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot variable TRACE-RSP : TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n : TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++ : TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp : TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index] : TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ; : TRACE.RDROP ( -- ) cell trace-rsp +! ; : TRACE.RCHECK ( -- , abort if return stack out of range ) trace-rsp @ trace-return-stack u< abort" TRACE return stack OVERFLOW!" trace-rsp @ trace-return-stack trace_return_size + 12 + u> abort" TRACE return stack UNDERFLOW!" ; \ save and restore several state variables 10 cells constant TRACE_STATE_SIZE create TRACE-STATE-1 TRACE_STATE_SIZE allot create TRACE-STATE-2 TRACE_STATE_SIZE allot variable TRACE-STATE-PTR : TRACE.SAVE++ ( addr -- , save next thing ) @ trace-state-ptr @ ! cell trace-state-ptr +! ; : TRACE.SAVE.STATE ( -- ) state trace.save++ hld trace.save++ base trace.save++ ; : TRACE.SAVE.STATE1 ( -- , save normal state ) trace-state-1 trace-state-ptr ! trace.save.state ; : TRACE.SAVE.STATE2 ( -- , save state of word being debugged ) trace-state-2 trace-state-ptr ! trace.save.state ; : TRACE.RESTORE++ ( addr -- , restore next thing ) trace-state-ptr @ @ swap ! cell trace-state-ptr +! ; : TRACE.RESTORE.STATE ( -- ) state trace.restore++ hld trace.restore++ base trace.restore++ ; : TRACE.RESTORE.STATE1 ( -- ) trace-state-1 trace-state-ptr ! trace.restore.state ; : TRACE.RESTORE.STATE2 ( -- ) trace-state-2 trace-state-ptr ! trace.restore.state ; \ The implementation of these pForth primitives is specific to pForth. variable TRACE-LOCALS-PTR \ point to top of local frame \ create a return stack frame for NUM local variables : TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- } trace-locals-ptr @ trace.>r trace-rsp @ trace-locals-ptr ! trace-rsp @ num cells - trace-rsp ! \ make room for locals trace-rsp @ -> lp num 0 DO lp ! cell +-> lp \ move data into locals frame on return stack LOOP ; : TRACE.(LOCAL.EXIT) ( -- ) trace-locals-ptr @ trace-rsp ! trace.r> trace-locals-ptr ! ; : TRACE.(LOCAL@) ( l# -- n , fetch from local frame ) trace-locals-ptr @ swap cells - @ ; : TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ; : TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ; : TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ; : TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ; : TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ; : TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ; : TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ; : TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ; : TRACE.(LOCAL!) ( n l# -- , store into local frame ) trace-locals-ptr @ swap cells - ! ; : TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ; : TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ; : TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ; : TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ; : TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ; : TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ; : TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ; : TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ; : TRACE.(LOCAL+!) ( n l# -- , store into local frame ) trace-locals-ptr @ swap cells - +! ; : TRACE.(?DO) { limit start ip -- ip' } limit start = IF ip @ +-> ip \ BRANCH ELSE start trace.>r limit trace.>r cell +-> ip THEN ip ; : TRACE.(LOOP) { ip | limit indx -- ip' } trace.r> -> limit trace.r> 1+ -> indx limit indx = IF cell +-> ip ELSE indx trace.>r limit trace.>r ip @ +-> ip THEN ip ; : TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' } trace.r> -> limit trace.r> -> oldindx oldindx delta + -> indx \ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */ \ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) || \ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) ) oldindx limit - limit 1- indx - AND $ 80000000 AND indx limit - limit 1- oldindx - AND $ 80000000 AND OR IF cell +-> ip ELSE indx trace.>r limit trace.>r ip @ +-> ip THEN ip ; : TRACE.CHECK.IP { ip -- } ip ['] first_colon u< ip here u> OR IF ." TRACE - IP out of range = " ip .hex cr abort THEN ; : TRACE.SHOW.IP { ip -- , print name and offset } ip code> >name dup id. name> >code ip swap - ." +" . ; : TRACE.SHOW.STACK { | mdepth -- } base @ >r ." <" base @ decimal 1 .r ." :" depth 1 .r ." > " r> base ! depth 5 min -> mdepth depth mdepth - IF ." ... " \ if we don't show entire stack THEN mdepth 0 ?DO mdepth i 1+ - pick . \ show numbers in current base LOOP ; : TRACE.SHOW.NEXT { ip -- } >newline ip trace.check.ip \ show word name and offset ." << " ip trace.show.ip 16 space.to.column \ show data stack trace.show.stack 40 space.to.column ." ||" trace_level 2* spaces ip code@ cell +-> ip \ show primitive about to be executed dup .xt space \ trap any primitives that are followed by inline data CASE ['] (LITERAL) OF ip @ . ENDOF ['] (ALITERAL) OF ip a@ . ENDOF [ exists? (FLITERAL) [IF] ] ['] (FLITERAL) OF ip f@ f. ENDOF [ [THEN] ] ['] BRANCH OF ip @ . ENDOF ['] 0BRANCH OF ip @ . ENDOF ['] (.") OF ip count type .' "' ENDOF ['] (C") OF ip count type .' "' ENDOF ['] (S") OF ip count type .' "' ENDOF ENDCASE 65 space.to.column ." >> " ; : TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip } xt CASE 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT ['] (CREATE) OF ip cell- body_offset + ENDOF ['] (LITERAL) OF ip @ cell +-> ip ENDOF ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF [ exists? (FLITERAL) [IF] ] ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF [ [THEN] ] ['] BRANCH OF ip @ +-> ip ENDOF ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF ['] >R OF trace.>r ENDOF ['] R> OF trace.r> ENDOF ['] R@ OF trace.r@ ENDOF ['] RDROP OF trace.rdrop ENDOF ['] 2>R OF trace.>r trace.>r ENDOF ['] 2R> OF trace.r> trace.r> ENDOF ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF ['] i OF 1 trace.rpick ENDOF ['] j OF 3 trace.rpick ENDOF ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF ['] (LOOP) OF ip trace.(loop) -> ip ENDOF ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF ['] (DO) OF trace.>r trace.>r ENDOF ['] (?DO) OF ip trace.(?do) -> ip ENDOF ['] (.") OF ip count type ip count + aligned -> ip ENDOF ['] (C") OF ip ip count + aligned -> ip ENDOF ['] (S") OF ip count ip count + aligned -> ip ENDOF ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF ['] (LOCAL@) OF trace.(local@) ENDOF ['] (1_LOCAL@) OF trace.(1_local@) ENDOF ['] (2_LOCAL@) OF trace.(2_local@) ENDOF ['] (3_LOCAL@) OF trace.(3_local@) ENDOF ['] (4_LOCAL@) OF trace.(4_local@) ENDOF ['] (5_LOCAL@) OF trace.(5_local@) ENDOF ['] (6_LOCAL@) OF trace.(6_local@) ENDOF ['] (7_LOCAL@) OF trace.(7_local@) ENDOF ['] (8_LOCAL@) OF trace.(8_local@) ENDOF ['] (LOCAL!) OF trace.(local!) ENDOF ['] (1_LOCAL!) OF trace.(1_local!) ENDOF ['] (2_LOCAL!) OF trace.(2_local!) ENDOF ['] (3_LOCAL!) OF trace.(3_local!) ENDOF ['] (4_LOCAL!) OF trace.(4_local!) ENDOF ['] (5_LOCAL!) OF trace.(5_local!) ENDOF ['] (6_LOCAL!) OF trace.(6_local!) ENDOF ['] (7_LOCAL!) OF trace.(7_local!) ENDOF ['] (8_LOCAL!) OF trace.(8_local!) ENDOF ['] (LOCAL+!) OF trace.(local+!) ENDOF >r xt EXECUTE r> ENDCASE ip ; : TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip } ip trace.check.ip \ set context for word under test trace.save.state1 here -> oldhere trace.restore.state2 oldhere 256 + dp ! \ get execution token ip code@ -> xt cell +-> ip \ execute token xt is.primitive? IF \ primitive ip xt trace.do.primitive -> ip ELSE \ secondary trace_level trace_level_max < IF ip trace.>r \ threaded execution 1 +-> trace_level xt codebase + -> ip ELSE \ treat it as a primitive ip xt trace.do.primitive -> ip THEN THEN \ restore original context trace.rcheck trace.save.state2 trace.restore.state1 oldhere dp ! ip ; : TRACE.NEXT { ip | xt -- ip' } trace_level 0> IF ip trace.do.next -> ip THEN trace_level 0> IF ip trace.show.next ELSE trace-stack on ." Finished." cr THEN ip ; }private : TRACE ( i*x -- i*x , setup trace environment ) ' dup is.primitive? IF drop ." Sorry. You can't trace a primitive." cr ELSE 1 -> trace_level trace_level -> trace_level_max trace.0rp >code -> trace_ip trace_ip trace.show.next trace-stack off trace.save.state2 THEN ; : s ( -- , step over ) trace_level -> trace_level_max trace_ip trace.next -> trace_ip ; : sd ( -- , step down ) trace_level 1+ -> trace_level_max trace_ip trace.next -> trace_ip ; : sm ( many -- , step many times ) trace_level -> trace_level_max 0 ?DO trace_ip trace.next -> trace_ip LOOP ; defer trace.user ( IP -- stop? ) ' 0= is trace.user : gd { more_levels | stop_level -- } here what's trace.user u< \ has it been forgotten? IF ." Resetting TRACE.USER !!!" cr ['] 0= is trace.user THEN more_levels 0< more_levels 10 > or \ 19990930 - OR was missing IF ." GD level out of range (0-10), = " more_levels . cr ELSE trace_level more_levels + -> trace_level_max trace_level 1- -> stop_level BEGIN trace_ip trace.user \ call deferred user word ?dup \ leave flag for UNTIL \ 19990930 - was DUP IF ." TRACE.USER returned " dup . ." so stopping execution." cr ELSE trace_ip trace.next -> trace_ip trace_level stop_level > not THEN UNTIL THEN ; : g ( -- , execute until end of word ) 0 gd ; : TRACE.HELP ( -- ) ." TRACE ( i*x -- , setup trace for Forth word )" cr ." S ( -- , step over )" cr ." SM ( many -- , step over many times )" cr ." SD ( -- , step down )" cr ." G ( -- , go to end of word )" cr ." GD ( n -- , go down N levels from current level," cr ." stop at end of this level )" cr ; privatize 0 [IF] variable var1 100 var1 ! : FOO dup IF 1 + . THEN 77 var1 @ + . ; : ZOO 29 foo 99 22 + . ; : ROO 92 >r 1 r@ + . r> . ; : MOO c" hello" count type ." This is a message." cr s" another message" type cr ; : KOO 7 FOO ." DONE" ; : TR.DO 4 0 DO i . LOOP ; : TR.?DO 0 ?DO i . LOOP ; : TR.LOC1 { aa bb } aa bb + . ; : TR.LOC2 789 >r 4 5 tr.loc1 r> . ; [THEN] pforth-2.0.1/fth/tut.fth000066400000000000000000000024771435661464300151420ustar00rootroot00000000000000anew task-tut.fth : SUM.OF.N.A ( N -- SUM[N] , calculate sum of N integers ) 0 \ starting value of SUM BEGIN OVER 0> \ Is N greater than zero? WHILE OVER + \ add N to sum SWAP 1- SWAP \ decrement N REPEAT SWAP DROP \ get rid on N ; : SUM.OF.N.B ( N -- SUM[N] ) 0 SWAP \ starting value of SUM 1+ 0 \ set indices for DO LOOP ?DO \ safer than DO if N=0 I + LOOP ; : SUM.OF.N.C ( N -- SUM[N] ) 0 \ starting value of SUM BEGIN ( -- N' SUM ) OVER + SWAP 1- SWAP OVER 0< UNTIL SWAP DROP ; : SUM.OF.N.D ( N -- SUM[N] ) >R \ put NUM on return stack 0 \ starting value of SUM BEGIN ( -- SUM ) R@ + \ add num to sum R> 1- DUP >R 0< UNTIL RDROP \ get rid of NUM ; : SUM.OF.N.E { NUM | SUM -- SUM[N] , use return stack } BEGIN NUM +-> SUM \ add NUM to SUM -1 +-> NUM \ decrement NUM NUM 0< UNTIL SUM \ return SUM ; : SUM.OF.N.F ( NUM -- SUM[N] , Gauss' method ) DUP 1+ * 2/ ; : TTT 10 0 DO I SUM.OF.N.A . I SUM.OF.N.B . I SUM.OF.N.C . I SUM.OF.N.D . I SUM.OF.N.E . I SUM.OF.N.F . CR LOOP ; TTT pforth-2.0.1/fth/utils/000077500000000000000000000000001435661464300147515ustar00rootroot00000000000000pforth-2.0.1/fth/utils/clone.fth000066400000000000000000000312011435661464300165510ustar00rootroot00000000000000\ @(#) clone.fth 97/12/10 1.1 \ Clone for PForth \ \ Create the smallest dictionary required to run an application. \ \ Clone decompiles the Forth dictionary starting with the top \ word in the program. It then moves all referenced secondaries \ into a new dictionary. \ \ This work was inspired by the CLONE feature that Mike Haas wrote \ for JForth. Mike's CLONE disassembled 68000 machine code then \ reassembled it which is much more difficult. \ \ Copyright Phil Burk & 3DO 1994 \ \ O- trap custom 'C' calls \ O- investigate ALITERAL, XLITERAL, use XLITERAL in ['] anew task-clone.fth decimal \ move to 'C' : PRIMITIVE? ( xt -- flag , true if primitive ) ['] FIRST_COLON < ; : 'SELF ( -- xt , return xt of word being compiled ) ?comp latest name> [compile] literal ; immediate :struct CL.REFERENCE long clr_OriginalXT \ original XT of word long clr_NewXT \ corresponding XT in cloned dictionary long clr_TotalSize \ size including data in body ;struct variable CL-INITIAL-REFS \ initial number of refs to allocate 100 cl-initial-refs ! variable CL-REF-LEVEL \ level of threading while scanning variable CL-NUM-REFS \ number of secondaries referenced variable CL-MAX-REFS \ max number of secondaries allocated variable CL-LEVEL-MAX \ max level reached while scanning variable CL-LEVEL-ABORT \ max level before aborting 10 cl-level-abort ! variable CL-REFERENCES \ pointer to cl.reference array variable CL-TRACE \ print debug stuff if true \ Cloned dictionary builds in allocated memory but XTs are relative \ to normal code-base, if CL-TEST-MODE true. variable CL-TEST-MODE variable CL-INITIAL-DICT \ initial size of dict to allocate 20 1024 * cl-initial-dict ! variable CL-DICT-SIZE \ size of allocated cloned dictionary variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary variable CL-DICT-ALLOC \ pointer to allocated dictionary memory variable CL-DICT-PTR \ rel pointer index into cloned dictionary 0 cl-dict-base ! : CL.INDENT ( -- ) cl-ref-level @ 2* 2* spaces ; : CL.DUMP.NAME ( xt -- ) cl.indent >name id. cr ; : CL.DICT[] ( relptr -- addr ) cl-dict-base @ + ; : CL, ( cell -- , comma into clone dictionary ) cl-dict-ptr @ cl.dict[] ! cell cl-dict-ptr +! ; : CL.FREE.DICT ( -- , free dictionary we built into ) cl-dict-alloc @ ?dup IF free dup ?error 0 cl-dict-alloc ! THEN ; : CL.FREE.REFS ( -- , free dictionary we built into ) cl-references @ ?dup IF free dup ?error 0 cl-references ! THEN ; : CL.ALLOC.REFS ( -- , allocate references to track ) cl-initial-refs @ \ initial number of references dup cl-max-refs ! \ maximum allowed sizeof() cl.reference * allocate dup ?error cl-references ! ; : CL.RESIZE.REFS ( -- , allocate references to track ) cl-max-refs @ \ current number of references allocated 5 * 4 / dup cl-max-refs ! \ new maximum allowed \ cl.indent ." Resize # references to " dup . cr sizeof() cl.reference * cl-references @ swap resize dup ?error cl-references ! ; : CL.ALLOC.DICT ( -- , allocate dictionary to build into ) cl-initial-dict @ \ initial dictionary size dup cl-dict-size ! allocate dup ?error cl-dict-alloc ! \ \ kludge dictionary if testing cl-test-mode @ IF cl-dict-alloc @ code-base @ - cl-dict-ptr +! code-base @ cl-dict-base ! ELSE cl-dict-alloc @ cl-dict-base ! THEN ." CL.ALLOC.DICT" cr ." cl-dict-alloc = $" cl-dict-alloc @ .hex cr ." cl-dict-base = $" cl-dict-base @ .hex cr ." cl-dict-ptr = $" cl-dict-ptr @ .hex cr ; : CODEADDR>DATASIZE { code-addr -- datasize } \ Determine size of any literal data following execution token. \ Examples are text following (."), or branch offsets. code-addr @ CASE ['] (literal) OF cell ENDOF \ a number ['] 0branch OF cell ENDOF \ branch offset ['] branch OF cell ENDOF ['] (do) OF 0 ENDOF ['] (?do) OF cell ENDOF ['] (loop) OF cell ENDOF ['] (+loop) OF cell ENDOF ['] (.") OF code-addr cell+ c@ 1+ ENDOF \ text ['] (s") OF code-addr cell+ c@ 1+ ENDOF ['] (c") OF code-addr cell+ c@ 1+ ENDOF 0 swap ENDCASE ; : XT>SIZE ( xt -- wordsize , including code and data ) dup >code swap >name dup latest = IF drop here ELSE dup c@ 1+ + aligned 8 + \ get next name name> >code \ where is next word THEN swap - ; \ ------------------------------------------------------------------ : CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize -- } \ scan secondary and pass each code-address to ca-process \ CA-PROCESS ( code-addr -- , required stack action for vector ) 1 cl-ref-level +! cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL" BEGIN code-addr @ -> xt \ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr code-addr codeaddr>datasize -> dsize \ any data after this? code-addr ca-process execute \ process it code-addr cell+ dsize + aligned -> code-addr \ skip past data \ !!! Bummer! EXIT called in middle of secondary will cause early stop. xt ['] EXIT = \ stop when we get to EXIT UNTIL -1 cl-ref-level +! ; \ ------------------------------------------------------------------ : CL.DUMP.XT ( xt -- ) cl-trace @ IF dup primitive? IF ." PRI: " ELSE ." SEC: " THEN cl.dump.name ELSE drop THEN ; \ ------------------------------------------------------------------ : CL.REF[] ( index -- clref ) sizeof() cl.reference * cl-references @ + ; : CL.DUMP.REFS ( -- , print references ) cl-num-refs @ 0 DO i 3 .r ." : " i cl.ref[] dup s@ clr_OriginalXT >name id. ." => " dup s@ clr_NewXT . ." , size = " dup s@ clr_TotalSize . cr drop \ clref loop ; : CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found } BEGIN \ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr indx cl-num-refs @ >= IF true ELSE indx cl.ref[] s@ clr_OriginalXT \ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr xt = IF true dup -> flag ELSE false indx 1+ -> indx THEN THEN UNTIL indx flag \ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr ; : CL.ADD.REF { xt | clref -- , add referenced secondary to list } cl-references @ 0= abort" CL.ADD.REF - References not allocated!" \ \ do we need to allocate more room? cl-num-refs @ cl-max-refs @ >= IF cl.resize.refs THEN \ cl-num-refs @ cl.ref[] -> clref \ index into array xt clref s! clr_OriginalXT 0 clref s! clr_NewXT xt xt>size clref s! clr_TotalSize \ 1 cl-num-refs +! ; \ ------------------------------------------------------------------ \ called by cl.traverse.secondary to compile each piece of secondary : CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- , } \ recompile to new location \ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr code-addr @ -> xt \ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr xt cl.dump.xt xt primitive? IF xt cl, ELSE xt CL.XT>REF_INDEX IF cl.ref[] -> clref clref s@ clr_NewXT dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT" cl, ELSE cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr abort THEN THEN \ \ transfer any literal data code-addr codeaddr>datasize -> dsize dsize 0> IF \ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr code-addr cell+ cl-dict-ptr @ cl.dict[] dsize move cl-dict-ptr @ dsize + aligned cl-dict-ptr ! THEN \ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr ; : CL.RECOMPILE.REF { indx | clref codesize datasize -- } \ all references have been resolved so recompile new secondary depth >r indx cl.ref[] -> clref cl-trace @ IF cl.indent clref s@ clr_OriginalXT >name id. ." recompiled at $" cl-dict-ptr @ .hex cr \ new address THEN cl-dict-ptr @ clref s! clr_NewXT \ \ traverse this secondary and compile into new dictionary clref s@ clr_OriginalXT >code ['] cl.recompile.secondary cl.traverse.secondary \ \ determine whether there is any data following definition cl-dict-ptr @ clref s@ clr_NewXT - -> codesize \ size of cloned code clref s@ clr_TotalSize \ total bytes codesize - -> datasize cl-trace @ IF cl.indent ." Move data: data size = " datasize . ." codesize = " codesize . cr THEN \ \ copy any data that followed definition datasize 0> IF clref s@ clr_OriginalXT >code codesize + clref s@ clr_NewXT cl-dict-base @ + codesize + datasize move datasize cl-dict-ptr +! \ allot space in clone dictionary THEN depth r> - abort" Stack depth change in CL.RECOMPILE.REF" ; \ ------------------------------------------------------------------ : CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list ) depth 1- >r \ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr cl-ref-level @ cl-level-max @ MAX cl-level-max ! @ ( get xt ) \ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr dup cl.dump.xt dup primitive? IF drop \ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr ELSE dup CL.XT>REF_INDEX IF drop \ indx \ already referenced once so ignore drop \ xt ELSE >r \ indx dup cl.add.ref >code 'self cl.traverse.secondary \ use 'self for recursion! r> cl.recompile.ref \ now that all refs resolved, recompile THEN THEN \ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr depth r> - abort" Stack depth change in CL.SCAN.SECONDARY" ; : CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list ) dup primitive? abort" Cannot CLONE a PRIMITIVE word!" 0 cl-ref-level ! 0 cl-level-max ! 0 cl-num-refs ! dup cl.add.ref \ word being cloned is top of ref list >code ['] cl.scan.secondary cl.traverse.secondary 0 cl.recompile.ref ; \ ------------------------------------------------------------------ : CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict ) cl.xt>ref_index 0= abort" not in cloned dictionary!" cl.ref[] s@ clr_NewXT ; : CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict ) cl.xt>New_XT cl-dict-base @ + ; : CL.REPORT ( -- ) ." Clone scan went " cl-level-max @ . ." levels deep." cr ." Clone scanned " cl-num-refs @ . ." secondaries." cr ." New dictionary size = " cl-dict-ptr @ cl-dict-base @ - . cr ; \ ------------------------------------------------------------------ : CL.TERM ( -- , cleanup ) cl.free.refs cl.free.dict ; : CL.INIT ( -- ) cl.term 0 cl-dict-size ! ['] first_colon cl-dict-ptr ! cl.alloc.dict cl.alloc.refs ; : 'CLONE ( xt -- , clone dictionary from this word ) cl.init cl.clone.xt cl.report cl.dump.refs cl-test-mode @ IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr THEN ; : SAVE-CLONE ( -- ) bl word ." Save cloned image in " dup count type drop ." SAVE-CLONE unimplemented!" \ %Q ; : CLONE ( -- ) ' 'clone ; if.forgotten cl.term \ ---------------------------------- TESTS -------------------- : TEST.CLONE ( -- ) cl-test-mode @ not abort" CL-TEST-MODE not on!" 0 cl.ref[] s@ clr_NewXT execute ; : TEST.CLONE.REAL ( -- ) cl-test-mode @ abort" CL-TEST-MODE on!" code-base @ 0 cl.ref[] s@ clr_NewXT \ get cloned execution token cl-dict-base @ code-base ! \ WARNING - code-base munged, only execute primitives or cloned code execute code-base ! \ restore code base for normal ; : TCL1 34 dup + ; : TCL2 ." Hello " tcl1 . cr ; : TCL3 4 0 DO tcl2 i . cr i 100 + . cr LOOP ; create VAR1 567 , : TCL4 345 var1 ! ." VAR1 = " var1 @ . cr var1 @ 345 - IF ." TCL4 failed!" cr ELSE ." TCL4 succeded! Yay!" cr THEN ; \ do deferred words get cloned! defer tcl.vector : TCL.DOIT ." Hello Fred!" cr ; ' tcl.doit is tcl.vector : TCL.DEFER 12 . cr tcl.vector 999 dup + . cr ; trace-stack on cl-test-mode on pforth-2.0.1/fth/utils/dump_struct.fth000066400000000000000000000050521435661464300200270ustar00rootroot00000000000000\ @(#) dump_struct.fth 97/12/10 1.1 \ Dump contents of structure showing values and member names. \ \ Author: Phil Burk \ Copyright 1987 Phil Burk \ All Rights Reserved. \ \ MOD: PLB 9/4/88 Print size too. \ MOD: PLB 9/9/88 Print U/S , add ADST \ MOD: PLB 12/6/90 Modified to work with H4th \ 941109 PLB Converted to pforth. Added RP detection. \ 090609 PLB Convert >rel to use->rel and ..! to s! include? task-member.fth member.fth include? task-c_struct c_struct.fth ANEW TASK-DUMP_STRUCT : EMIT-TO-COLUMN ( char col -- ) out @ - 0 max 80 min 0 DO dup emit LOOP drop ; VARIABLE SN-FENCE : STACK.NFAS ( fencenfa topnfa -- 0 nfa0 nfa1 ... ) \ Fill stack with nfas of words until fence hit. >r sn-fence ! 0 r> ( set terminator ) BEGIN ( -- 0 n0 n1 ... top ) dup sn-fence @ > WHILE \ dup n>link @ \ JForth dup prevname \ HForth REPEAT drop ; : DST.DUMP.TYPE ( +-size -- , dump data type, 941109) dup abs 4 = IF 0< IF ." RP" ELSE ." U4" THEN ELSE dup 0< IF ascii U ELSE ascii S THEN emit abs 1 .r THEN ; : DUMP.MEMBER ( addr member-pfa -- , dump member of structure) ob.stats ( -- addr offset size ) >r + r> ( -- addr' size ) dup ABS 4 > ( -- addr' size flag ) IF cr 2dup swap . . ABS dump ELSE tuck @bytes 10 .r ( -- size ) 3 spaces dst.dump.type THEN ; VARIABLE DS-ADDR : DUMP.STRUCT ( addr-data addr-structure -- ) >newline swap >r ( -- as , save addr-data for dumping ) \ dup cell+ @ over + \ JForth dup code> >name swap cell+ @ over + \ HForth stack.nfas ( fill stack with nfas of members ) BEGIN dup WHILE ( continue until non-zero ) dup name> >body r@ swap dump.member bl 18 emit-to-column id. cr ?pause REPEAT drop rdrop ; : DST ( addr -- , dump contents of structure ) ob.findit state @ IF [compile] literal compile dump.struct ELSE dump.struct THEN ; immediate : ADST ( absolute_address -- , dump structure ) use->rel [compile] dst \ mod 090609 ; immediate \ For Testing Purposes false [IF] :STRUCT GOO LONG DATAPTR SHORT GOO_WIDTH USHORT GOO_HEIGHT ;STRUCT :STRUCT FOO LONG ALONG1 STRUCT GOO AGOO SHORT ASHORT1 BYTE ABYTE BYTE ABYTE2 ;STRUCT FOO AFOO : AFOO.INIT $ 12345678 afoo s! along1 $ -665 afoo s! ashort1 $ 21 afoo s! abyte $ 43 afoo s! abyte2 -234 afoo .. agoo s! goo_height ; afoo.init : TDS ( afoo -- ) dst foo ; [THEN] pforth-2.0.1/fth/utils/load_file.fth000066400000000000000000000020231435661464300173670ustar00rootroot00000000000000\ Load a file into an allocated memory image. \ \ Author: Phil Burk \ Copyright 3DO 1995 anew task-load_file.fth : $LOAD.FILE { $filename | fid numbytes numread err data -- data-addr 0 | 0 err } 0 -> data \ open file $filename count r/o open-file -> err -> fid err IF ." $LOAD.FILE - Could not open input file!" cr ELSE \ determine size of file fid file-size -> err -> numbytes err IF ." $LOAD.FILE - File size failed!" cr ELSE ." File size = " numbytes . cr \ allocate memory for sample, when done free memory using FREE numbytes allocate -> err -> data err IF ." $LOAD.FILE - Memory allocation failed!" cr ELSE \ read data data numbytes fid read-file -> err ." Read " . ." bytes from file " $filename count type cr THEN THEN fid close-file drop THEN data err ; \ Example: c" myfile" $load.file abort" Oops!" free . pforth-2.0.1/fth/utils/make_all256.fth000066400000000000000000000020321435661464300174530ustar00rootroot00000000000000\ @(#) make_all256.fth 97/12/10 1.1 \ Make a file with all possible 256 bytes in random order. \ \ Author: Phil Burk \ Copyright 1987 Phil Burk \ All Rights Reserved. ANEW TASK-MAKE_ALL256 variable RAND8-SEED 19 rand8-seed ! : RANDOM8 ( -- r8 , generate random bytes, repeat every 256 ) RAND8-SEED @ 77 * 55 + $ FF and dup RAND8-SEED ! ; create rand8-pad 256 allot : make.256.data 256 0 DO random8 rand8-pad i + c! LOOP ; : SHUFFLE.DATA { num | ind1 ind2 -- } num 0 DO 256 choose -> ind1 256 choose -> ind2 ind1 rand8-pad + c@ ind2 rand8-pad + c@ ind1 rand8-pad + c! ind2 rand8-pad + c! LOOP ; : WRITE.256.FILE { | fid -- } p" all256.raw" count r/w create-file IF drop ." Could not create file." cr ELSE -> fid fid . cr rand8-pad 256 fid write-file abort" write failed!" fid close-file drop THEN ; : MAKE.256.FILE make.256.data 1000 shuffle.data write.256.file ; MAKE.256.FILE pforth-2.0.1/fth/wordslik.fth000066400000000000000000000025001435661464300161470ustar00rootroot00000000000000\ @(#) wordslik.fth 98/01/26 1.2 \ \ WORDS.LIKE ( -- , search for words that contain string ) \ \ Enter: WORDS.LIKE + \ Enter: WORDS.LIKE EMIT \ \ Author: Phil Burk \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom \ \ Permission to use, copy, modify, and/or distribute this \ software for any purpose with or without fee is hereby granted. \ \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. anew task-wordslik.fth decimal : PARTIAL.MATCH.NAME ( $str1 nfa -- flag , is $str1 in nfa ??? ) count $ 1F and rot count search >r 2drop r> ; : WORDS.LIKE ( -- , print all words containing substring ) BL word latest >newline BEGIN prevname dup 0<> \ get previous name in dictionary WHILE 2dup partial.match.name IF dup id. tab cr? THEN REPEAT 2drop >newline ; pforth-2.0.1/license.txt000066400000000000000000000011371435661464300152150ustar00rootroot00000000000000Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. pforth-2.0.1/platforms/000077500000000000000000000000001435661464300150375ustar00rootroot00000000000000pforth-2.0.1/platforms/linux-crossbuild-amiga/000077500000000000000000000000001435661464300214215ustar00rootroot00000000000000pforth-2.0.1/platforms/linux-crossbuild-amiga/Makefile000066400000000000000000000112361435661464300230640ustar00rootroot00000000000000# This Makefile can be used to cross-compile pForth on a Linux host to # an Amiga target. GCC is used as host-compiler and VBCC as # cross-compiler. # makefile for pForth # Portable Forth written in 'C' # by Phil Burk # For more info visit http://www.softsynth.com/pforth/ # # See "help" target below. # Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG # See "docs/pf_ref.htm" file for more info. # We are going to use VBCC as cross compiler. I've installed VBCC # under /opt/m68k-amigaos. It's configured to generate Motorola 680x0 code in # "Amiga Hunk" object format. VBCC := /opt/m68k-amigaos PATH := $(VBCC)/bin:$(PATH) XCC = vc # The VBCC compiler SRCDIR = ../.. PFORTHDIR = $(SRCDIR) CSRCDIR = $(PFORTHDIR)/csrc FTHDIR = $(PFORTHDIR)/fth PFDICAPP = pforth PFORTHDIC = pforth.dic PFDICDAT = pfdicdat.h PFORTHAPP = amiga_pforth_standalone # We need to create a 32-bit dictionary WIDTHOPT= -m32 DEBUGOPTS = -g FULL_WARNINGS = \ --std=c89 \ -pedantic \ -Wcast-qual \ -Wall \ -Wwrite-strings \ -Winline \ -Wmissing-prototypes \ -Wmissing-declarations CCOPTS = $(WIDTHOPT) -x c -O2 $(FULL_WARNINGS) $(EXTRA_CCOPTS) $(DEBUGOPTS) #IO_SOURCE = pf_io_posix.c IO_SOURCE = pf_io_stdio.c pf_fileio_stdio.c #IO_SOURCE = pf_io_win32_console.c EMBCCOPTS = -DPF_STATIC_DIC ####################################### PFINCLUDES = pf_all.h pf_cglue.h pf_clib.h pf_core.h pf_float.h \ pf_guts.h pf_host.h pf_inc1.h pf_io.h pf_mem.h pf_save.h \ pf_text.h pf_types.h pf_words.h pfcompfp.h \ pfcompil.h pfdicdat_arm.h pfinnrfp.h pforth.h PFBASESOURCE = pf_cglue.c pf_clib.c pf_core.c pf_inner.c \ pf_io.c pf_io_none.c pf_main.c pf_mem.c pf_save.c \ pf_text.c pf_words.c pfcompil.c pfcustom.c PFSOURCE = $(PFBASESOURCE) $(IO_SOURCE) VPATH = .:$(CSRCDIR):$(CSRCDIR)/posix:$(CSRCDIR)/stdio CPPFLAGS = -I. -DPF_BIG_ENDIAN_DIC -DPF_SUPPORT_FP CFLAGS = $(CCOPTS) LDFLAGS = $(WIDTHOPT) -lm COMPILE = $(CC) $(CFLAGS) $(CPPFLAGS) # Cross compiler flags (for VBCC not gcc) XCFLAGS = -c99 -O3 #XCPPFLAGS = -DPF_SUPPORT_FP -DWIN32 XCPPFLAGS = -I. -DAMIGA -DPF_SUPPORT_FP XLDFLAGS = -lmieee -lm881 XCOMPILE = $(XCC) $(XCFLAGS) $(XCPPFLAGS) XLINK = $(XCC) $(XLDFLAGS) .SUFFIXES: .c .o .eo PFOBJS = $(PFSOURCE:.c=.o) PFEMBOBJS = $(PFSOURCE:.c=.eo) .c.o: $(PFINCLUDES) $(COMPILE) -c -o $@ $< .c.eo: $(PFINCLUDES) pfdicdat.h $(XCOMPILE) $(EMBCCOPTS) -c -o $@ $< .PHONY: all clean test .PHONY: help pffiles pfdicapp pfdicdat pforthapp all: $(PFORTHAPP) pffiles: @echo "INCLUDE FILES -----------------" @echo ${PFINCLUDES} @echo "'C' FILES ---------------------" @echo ${PFSOURCE} @echo "OBJECT FILES ------------------" @echo ${PFOBJS} @echo "EMBEDDED OBJECT FILES ------------------" @echo ${PFEMBOBJS} # Build pforth by compiling 'C' source. $(PFDICAPP): $(PFINCLUDES) $(PFOBJS) $(CC) -o $@ $(PFOBJS) $(LDADD) $(LDFLAGS) # Build basic dictionary image by running newly built pforth and including "system.fth". $(PFORTHDIC): $(PFDICAPP) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFDICAPP) -i system.fth) (cd $(FTHDIR); cat pforth.dic; rm -f pforth.dic) > $@ $(PFDICDAT): $(PFORTHDIC) $(PFDICAPP) echo 'include $(FTHDIR)/savedicd.fth SDAD'>load-dict-tmp.fth&& ./$(PFDICAPP) -d $(PFORTHDIC) load-dict-tmp.fth; rm -f load-dict-tmp.fth $(PFORTHAPP): $(PFDICDAT) $(PFEMBOBJS) $(XLINK) -o $@ $(PFEMBOBJS) $(XLDADD) @echo "" @echo "Standalone pForth executable written to $(PFORTHAPP)" # target aliases pfdicapp: $(PFDICAPP) pfdicdat: $(PFDICDAT) pforthapp: $(PFORTHAPP) help: @echo "Use 'make all' to build standalone pForth executable." @echo "PForth can be built in several stages using these targets:" @echo " pfdicapp = executable pForth with minimal dictionary. All from 'C'." @echo " pfdicdat = image of full dictionary build by compiling Forth code." @echo " pforthapp = executable with embedded dictionary image. DEFAULT 'all' target." @echo "" @echo " The file 'fth/pfdicdat.h' is generated by pForth. It contains a binary image of the Forth dictionary." @echo " It allows pForth to work as a standalone image that does not need to load a dictionary file." test: $(PFORTHAPP) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_corex.fth) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_strings.fth) 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) clean: rm -f $(PFOBJS) $(PFEMBOBJS) rm -f $(PFORTHAPP) rm -f $(PFDICDAT) $(FTHDIR)/$(PFDICDAT) rm -f $(PFORTHDIC) $(FTHDIR)/$(PFORTHDIC) rm -f $(PFDICAPP) pforth-2.0.1/platforms/linux-crossbuild-atari/000077500000000000000000000000001435661464300214435ustar00rootroot00000000000000pforth-2.0.1/platforms/linux-crossbuild-atari/Makefile000066400000000000000000000111521435661464300231030ustar00rootroot00000000000000# This Makefile can be used to cross-compile pForth on a Linux host to # an Atari ST target. GCC is used as host-compiler and VBCC as # cross-compiler. # makefile for pForth # Portable Forth written in 'C' # by Phil Burk # For more info visit http://www.softsynth.com/pforth/ # # See "help" target below. # Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG # See "docs/pf_ref.htm" file for more info. # We are going to use VBCC as cross compiler. I've installed VBCC # under /opt/vbcc. It's configured to generate Motorola 680x0 code. VBCC := /opt/vbcc PATH := $(VBCC)/bin:$(PATH) XCC = vc # The VBCC compiler SRCDIR = ../.. PFORTHDIR = $(SRCDIR) CSRCDIR = $(PFORTHDIR)/csrc FTHDIR = $(PFORTHDIR)/fth PFDICAPP = pforth PFORTHDIC = pforth.dic PFDICDAT = pfdicdat.h PFORTHAPP = pforth.ttp # We need to create a 32-bit dictionary WIDTHOPT= -m32 DEBUGOPTS = -g FULL_WARNINGS = \ --std=c89 \ -pedantic \ -Wcast-qual \ -Wall \ -Wwrite-strings \ -Winline \ -Wmissing-prototypes \ -Wmissing-declarations CCOPTS = $(WIDTHOPT) -x c -O2 $(FULL_WARNINGS) $(EXTRA_CCOPTS) $(DEBUGOPTS) #IO_SOURCE = pf_io_posix.c IO_SOURCE = pf_io_stdio.c pf_fileio_stdio.c #IO_SOURCE = pf_io_win32_console.c EMBCCOPTS = -DPF_STATIC_DIC ####################################### PFINCLUDES = pf_all.h pf_cglue.h pf_clib.h pf_core.h pf_float.h \ pf_guts.h pf_host.h pf_inc1.h pf_io.h pf_mem.h pf_save.h \ pf_text.h pf_types.h pf_words.h pfcompfp.h \ pfcompil.h pfdicdat_arm.h pfinnrfp.h pforth.h PFBASESOURCE = pf_cglue.c pf_clib.c pf_core.c pf_inner.c \ pf_io.c pf_io_none.c pf_main.c pf_mem.c pf_save.c \ pf_text.c pf_words.c pfcompil.c pfcustom.c PFSOURCE = $(PFBASESOURCE) $(IO_SOURCE) VPATH = .:$(CSRCDIR):$(CSRCDIR)/posix:$(CSRCDIR)/stdio CPPFLAGS = -I. -DPF_BIG_ENDIAN_DIC -DPF_SUPPORT_FP CFLAGS = $(CCOPTS) LDFLAGS = $(WIDTHOPT) -lm COMPILE = $(CC) $(CFLAGS) $(CPPFLAGS) # Cross compiler flags (for VBCC not gcc) XCFLAGS = +tos -c99 -O3 #XCPPFLAGS = -DPF_SUPPORT_FP -DWIN32 XCPPFLAGS = -I. -DATARI -DPF_SUPPORT_FP XLDFLAGS = +tos -lm -lm881 XCOMPILE = $(XCC) $(XCFLAGS) $(XCPPFLAGS) XLINK = $(XCC) $(XLDFLAGS) .SUFFIXES: .c .o .eo PFOBJS = $(PFSOURCE:.c=.o) PFEMBOBJS = $(PFSOURCE:.c=.eo) .c.o: $(PFINCLUDES) $(COMPILE) -c -o $@ $< .c.eo: $(PFINCLUDES) pfdicdat.h $(XCOMPILE) $(EMBCCOPTS) -c -o $@ $< .PHONY: all clean test .PHONY: help pffiles pfdicapp pfdicdat pforthapp all: $(PFORTHAPP) pffiles: @echo "INCLUDE FILES -----------------" @echo ${PFINCLUDES} @echo "'C' FILES ---------------------" @echo ${PFSOURCE} @echo "OBJECT FILES ------------------" @echo ${PFOBJS} @echo "EMBEDDED OBJECT FILES ------------------" @echo ${PFEMBOBJS} # Build pforth by compiling 'C' source. $(PFDICAPP): $(PFINCLUDES) $(PFOBJS) $(CC) -o $@ $(PFOBJS) $(LDADD) $(LDFLAGS) # Build basic dictionary image by running newly built pforth and including "system.fth". $(PFORTHDIC): $(PFDICAPP) wd=$$(pwd); (cd $(FTHDIR); $${wd}/$(PFDICAPP) -i system.fth) (cd $(FTHDIR); cat pforth.dic; rm -f pforth.dic) > $@ $(PFDICDAT): $(PFORTHDIC) $(PFDICAPP) echo 'include $(FTHDIR)/savedicd.fth SDAD'>load-dict-tmp.fth&& ./$(PFDICAPP) -d $(PFORTHDIC) load-dict-tmp.fth; rm -f load-dict-tmp.fth $(PFORTHAPP): $(PFDICDAT) $(PFEMBOBJS) $(XLINK) -o $@ $(PFEMBOBJS) $(XLDADD) @echo "" @echo "Standalone pForth executable written to $(PFORTHAPP)" # target aliases pfdicapp: $(PFDICAPP) pfdicdat: $(PFDICDAT) pforthapp: $(PFORTHAPP) help: @echo "Use 'make all' to build standalone pForth executable." @echo "PForth can be built in several stages using these targets:" @echo " pfdicapp = executable pForth with minimal dictionary. All from 'C'." @echo " pfdicdat = image of full dictionary build by compiling Forth code." @echo " pforthapp = executable with embedded dictionary image. DEFAULT 'all' target." @echo "" @echo " The file 'fth/pfdicdat.h' is generated by pForth. It contains a binary image of the Forth dictionary." @echo " It allows pForth to work as a standalone image that does not need to load a dictionary file." test: $(PFORTHAPP) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_corex.fth) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_strings.fth) 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) clean: rm -f $(PFOBJS) $(PFEMBOBJS) rm -f $(PFORTHAPP) rm -f $(PFDICDAT) $(FTHDIR)/$(PFDICDAT) rm -f $(PFORTHDIC) $(FTHDIR)/$(PFORTHDIC) rm -f $(PFDICAPP) pforth-2.0.1/platforms/mingw-crossbuild-linux/000077500000000000000000000000001435661464300214645ustar00rootroot00000000000000pforth-2.0.1/platforms/mingw-crossbuild-linux/Makefile000066400000000000000000000107671435661464300231370ustar00rootroot00000000000000# makefile for pForth # Portable Forth written in 'C' # by Phil Burk # For more info visit http://www.softsynth.com/pforth/ # # See "help" target below. .POSIX: # Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG # See "docs/pf_ref.htm" file for more info. CC = x86_64-w64-mingw32-gcc WINE = wineconsole SRCDIR = ../.. PFORTHDIR = $(SRCDIR) CSRCDIR = $(PFORTHDIR)/csrc FTHDIR = $(PFORTHDIR)/fth PFDICAPP = pforth.exe PFORTHDIC = pforth.dic PFDICDAT = pfdicdat.h PFORTHAPP = pforth_standalone.exe # This is needed to get pForth to build on Snow Leopard and other 64 bit platforms. WIDTHOPT= FULL_WARNINGS = \ --std=c89 \ -fsigned-char \ -fno-builtin \ -fno-unroll-loops \ -fpeephole \ -fno-keep-inline-functions \ -pedantic \ -Wcast-qual \ -Wall \ -Wwrite-strings \ -Winline \ -Wmissing-prototypes \ -Wmissing-declarations DEBUGOPTS = -g 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 pf_fileio_stdio.c EMBCCOPTS = -DPF_STATIC_DIC ####################################### PFINCLUDES = pf_all.h pf_cglue.h pf_clib.h pf_core.h pf_float.h \ pf_guts.h pf_host.h pf_inc1.h pf_io.h pf_mem.h pf_save.h \ pf_text.h pf_types.h pf_win32.h pf_words.h pfcompfp.h \ pfcompil.h pfdicdat_arm.h pfinnrfp.h pforth.h PFBASESOURCE = pf_cglue.c pf_clib.c pf_core.c pf_inner.c \ pf_io.c pf_io_none.c pf_main.c pf_mem.c pf_save.c \ pf_text.c pf_words.c pfcompil.c pfcustom.c PFSOURCE = $(PFBASESOURCE) $(IO_SOURCE) VPATH = .:$(CSRCDIR):$(CSRCDIR)/posix:$(CSRCDIR)/stdio:$(CSRCDIR)/win32_console:$(CSRCDIR)/win32 XCFLAGS = $(CCOPTS) #XCPPFLAGS = -DPF_SUPPORT_FP -DWIN32 XCPPFLAGS = -DWIN32 XLDFLAGS = $(WIDTHOPT) CPPFLAGS = -I. $(XCPPFLAGS) CFLAGS = $(XCFLAGS) LDFLAGS = $(XLDFLAGS) COMPILE = $(CC) $(CFLAGS) $(CPPFLAGS) LINK = $(CC) $(LDFLAGS) .SUFFIXES: .c .o .eo PFOBJS = $(PFSOURCE:.c=.o) PFEMBOBJS = $(PFSOURCE:.c=.eo) .c.o: $(PFINCLUDES) $(COMPILE) -c -o $@ $< .c.eo: $(PFINCLUDES) pfdicdat.h $(COMPILE) $(EMBCCOPTS) -c -o $@ $< .PHONY: all clean test .PHONY: help pffiles pfdicapp pfdicdat pforthapp all: $(PFORTHAPP) pffiles: @echo "INCLUDE FILES -----------------" @echo ${PFINCLUDES} @echo "'C' FILES ---------------------" @echo ${PFSOURCE} @echo "OBJECT FILES ------------------" @echo ${PFOBJS} @echo "EMBEDDED OBJECT FILES ------------------" @echo ${PFEMBOBJS} # Build pforth by compiling 'C' source. $(PFDICAPP): $(PFINCLUDES) $(PFOBJS) $(LINK) -o $@ $(PFOBJS) $(LDADD) -lm # Build basic dictionary image by running newly built pforth and including "system.fth". $(PFORTHDIC): $(PFDICAPP) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFDICAPP) -i system.fth) (cd $(FTHDIR); cat pforth.dic; rm -f pforth.dic) > $@ $(PFDICDAT): $(PFORTHDIC) $(PFDICAPP) echo 'include $(FTHDIR)/savedicd.fth SDAD BYE'>load-dict-tmp.fth&& $(WINE) ./$(PFDICAPP) -d $(PFORTHDIC) load-dict-tmp.fth; rm -f load-dict-tmp.fth $(PFORTHAPP): $(PFDICDAT) $(PFEMBOBJS) $(LINK) -o $@ $(PFEMBOBJS) $(LDADD) -lm @echo "" @echo "Standalone pForth executable written to $(PFORTHAPP)" # target aliases pfdicapp: $(PFDICAPP) pfdicdat: $(PFDICDAT) pforthapp: $(PFORTHAPP) help: @echo "Use 'make all' to build standalone pForth executable." @echo "PForth can be built in several stages using these targets:" @echo " pfdicapp = executable pForth with minimal dictionary. All from 'C'." @echo " pfdicdat = image of full dictionary build by compiling Forth code." @echo " pforthapp = executable with embedded dictionary image. DEFAULT 'all' target." @echo "" @echo " The file 'fth/pfdicdat.h' is generated by pForth. It contains a binary image of the Forth dictionary." @echo " It allows pForth to work as a standalone image that does not need to load a dictionary file." test: $(PFORTHAPP) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_corex.fth) wd=$$(pwd); (cd $(FTHDIR); $(WINE) $${wd}/$(PFORTHAPP) -q t_strings.fth) 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) rm -f $(PFORTHAPP) rm -f $(PFDICDAT) $(FTHDIR)/$(PFDICDAT) rm -f $(PFORTHDIC) $(FTHDIR)/$(PFORTHDIC) rm -f $(PFDICAPP) pforth-2.0.1/platforms/unix/000077500000000000000000000000001435661464300160225ustar00rootroot00000000000000pforth-2.0.1/platforms/unix/Makefile000066400000000000000000000110571435661464300174660ustar00rootroot00000000000000# makefile for pForth # Portable Forth written in 'C' # by Phil Burk # For more info visit http://www.softsynth.com/pforth/ # # See "help" target below. .POSIX: # Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG # See "docs/pf_ref.htm" file for more info. SRCDIR = ../.. PFORTHDIR = $(SRCDIR) CSRCDIR = $(PFORTHDIR)/csrc FTHDIR = $(PFORTHDIR)/fth UNIXDIR = platforms/unix PFDICAPP = pforth PFORTHDIC = pforth.dic PFDICDAT = pfdicdat.h PFORTHAPP = pforth_standalone # Set this parameter to -m32 if you want to compile a 32-bit binary. WIDTHOPT= FULL_WARNINGS = \ --std=c89 \ -fsigned-char \ -fno-builtin \ -fno-unroll-loops \ -pedantic \ -Wcast-qual \ -Wall \ -Wwrite-strings \ -Winline \ -Wmissing-prototypes \ -Wmissing-declarations DEBUGOPTS = -g CCOPTS = $(WIDTHOPT) -x c -O2 $(FULL_WARNINGS) $(EXTRA_CCOPTS) $(DEBUGOPTS) IO_SOURCE = pf_io_posix.c pf_fileio_stdio.c #IO_SOURCE = pf_io_stdio.c EMBCCOPTS = -DPF_STATIC_DIC #-DPF_NO_FILEIO ####################################### PFINCLUDES = pf_all.h pf_cglue.h pf_clib.h pf_core.h pf_float.h \ pf_guts.h pf_host.h pf_inc1.h pf_io.h pf_mem.h pf_save.h \ pf_text.h pf_types.h pf_win32.h pf_words.h pfcompfp.h \ pfcompil.h pfinnrfp.h pforth.h PFBASESOURCE = pf_cglue.c pf_clib.c pf_core.c pf_inner.c \ pf_io.c pf_io_none.c pf_main.c pf_mem.c pf_save.c \ pf_text.c pf_words.c pfcompil.c pfcustom.c PFSOURCE = $(PFBASESOURCE) $(IO_SOURCE) VPATH = .:$(CSRCDIR):$(CSRCDIR)/posix:$(CSRCDIR)/stdio:$(CSRCDIR)/win32_console:$(CSRCDIR)/win32 XCFLAGS = $(CCOPTS) XCPPFLAGS = -DPF_SUPPORT_FP -D_DEFAULT_SOURCE -D_GNU_SOURCE XLDFLAGS = $(WIDTHOPT) CPPFLAGS = -I. $(XCPPFLAGS) CFLAGS = $(XCFLAGS) LDFLAGS = $(XLDFLAGS) COMPILE = $(CC) $(CFLAGS) $(CPPFLAGS) LINK = $(CC) $(LDFLAGS) .SUFFIXES: .c .o .eo PFOBJS = $(PFSOURCE:.c=.o) PFEMBOBJS = $(PFSOURCE:.c=.eo) %.o: %.c $(PFINCLUDES) $(COMPILE) -c -o $@ $< %.eo: %.c $(PFINCLUDES) pfdicdat.h $(COMPILE) $(EMBCCOPTS) -c -o $@ $< .PHONY: all clean test .PHONY: help pffiles pfdicapp pfdicdat pforthapp all: $(PFORTHAPP) pffiles: @echo "INCLUDE FILES -----------------" @echo ${PFINCLUDES} @echo "'C' FILES ---------------------" @echo ${PFSOURCE} @echo "OBJECT FILES ------------------" @echo ${PFOBJS} @echo "EMBEDDED OBJECT FILES ------------------" @echo ${PFEMBOBJS} # Build pforth by compiling 'C' source. $(PFDICAPP): $(PFINCLUDES) $(PFOBJS) $(LINK) -o $@ $(PFOBJS) $(LDADD) -lm # Build basic dictionary image by running newly built pforth and including "system.fth". $(PFORTHDIC): $(PFDICAPP) wd=$$(pwd); (cd $(FTHDIR); "$${wd}/$(PFDICAPP)" -i system.fth) (cd $(FTHDIR); cat pforth.dic; rm -f pforth.dic) > $@ $(PFDICDAT): $(PFORTHDIC) $(PFDICAPP) @test -f $(CSRCDIR)/$(PFDICDAT) && echo WARNING old $(CSRCDIR)/$(PFDICDAT) would interfere || true # Remove stray csrc/pfdicdat.h because it may accidentally get included. rm -f $(CSRCDIR)/$(PFDICDAT) echo 'include $(FTHDIR)/savedicd.fth SDAD BYE' | ./$(PFDICAPP) -d $(PFORTHDIC) $(PFORTHAPP): $(PFDICDAT) $(PFEMBOBJS) $(LINK) -o $@ $(PFEMBOBJS) $(LDADD) -lm @echo "" @echo "Standalone pForth executable written to $(PFORTHAPP)" # target aliases pfdicapp: $(PFDICAPP) pforthdic: $(PFORTHDIC) pfdicdat: $(PFDICDAT) pforthapp: $(PFORTHAPP) help: @echo "Use 'make all' to build standalone pForth executable." @echo "PForth can be built in several stages using these targets:" @echo " pfdicapp = executable pForth with minimal dictionary. All from 'C'." @echo " pforthdic = executable pforth plus pforth.dic file" @echo " pfdicdat = header image of full dictionary build by compiling Forth code." @echo " pforthapp = executable with embedded dictionary image. DEFAULT 'all' target." @echo "" @echo " The file 'fth/pfdicdat.h' is generated by pForth. It contains a binary image of the Forth dictionary." @echo " It allows pForth to work as a standalone image that does not need to load a dictionary file." test: $(PFORTHAPP) cd $(FTHDIR) && ../$(UNIXDIR)/$(PFORTHAPP) -q t_corex.fth cd $(FTHDIR) && ../$(UNIXDIR)/$(PFORTHAPP) -q t_strings.fth cd $(FTHDIR) && ../$(UNIXDIR)/$(PFORTHAPP) -q t_locals.fth cd $(FTHDIR) && ../$(UNIXDIR)/$(PFORTHAPP) -q t_alloc.fth cd $(FTHDIR) && ../$(UNIXDIR)/$(PFORTHAPP) -q t_floats.fth cd $(FTHDIR) && ../$(UNIXDIR)/$(PFORTHAPP) -q t_file.fth @echo "PForth Tests PASSED" clean: rm -f $(PFOBJS) $(PFEMBOBJS) rm -f $(PFORTHAPP) rm -f $(PFDICDAT) $(FTHDIR)/$(PFDICDAT) $(CSRCDIR)/$(PFDICDAT) rm -f $(PFORTHDIC) $(FTHDIR)/$(PFORTHDIC) rm -f $(PFDICAPP) pforth-2.0.1/platforms/win32/000077500000000000000000000000001435661464300160015ustar00rootroot00000000000000pforth-2.0.1/platforms/win32/vs2017/000077500000000000000000000000001435661464300167435ustar00rootroot00000000000000pforth-2.0.1/platforms/win32/vs2017/pforth.sln000066400000000000000000000026531435661464300207710ustar00rootroot00000000000000 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 pforth-2.0.1/platforms/win32/vs2017/pforth_main.vcxproj000066400000000000000000000226161435661464300226750ustar00rootroot00000000000000 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 pforth-2.0.1/platforms/win32/vs2017/pforth_main.vcxproj.filters000066400000000000000000000077201435661464300243430ustar00rootroot00000000000000 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}