From 996b4376343ecb0c7bb1be4d86ab5314806697e6 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Thu, 5 Jun 2008 17:31:28 -0600 Subject: [PATCH] Imported Upstream version 21 --- Makefile | 87 +++ README.txt | 291 ++++++++ ansilocs.fth | 196 ++++++ bench.fth | 190 +++++ bloop.fth | 34 + c_struct.fth | 242 +++++++ case.fth | 75 ++ catch.fth | 61 ++ checkit.fth | 32 + condcomp.fth | 50 ++ coretest.fth | 996 ++++++++++++++++++++++++++ csrc/pf_all.h | 62 ++ csrc/pf_cglue.c | 108 +++ csrc/pf_cglue.h | 39 + csrc/pf_clib.c | 64 ++ csrc/pf_clib.h | 63 ++ csrc/pf_core.c | 422 +++++++++++ csrc/pf_core.h | 51 ++ csrc/pf_float.h | 43 ++ csrc/pf_guts.h | 565 +++++++++++++++ csrc/pf_host.h | 24 + csrc/pf_inner.c | 1563 +++++++++++++++++++++++++++++++++++++++++ csrc/pf_io.c | 211 ++++++ csrc/pf_io.h | 146 ++++ csrc/pf_mac.h | 39 + csrc/pf_main.c | 102 +++ csrc/pf_mem.c | 361 ++++++++++ csrc/pf_mem.h | 46 ++ csrc/pf_save.c | 726 +++++++++++++++++++ csrc/pf_save.h | 90 +++ csrc/pf_text.c | 297 ++++++++ csrc/pf_text.h | 68 ++ csrc/pf_types.h | 58 ++ csrc/pf_unix.h | 41 ++ csrc/pf_win32.h | 40 ++ csrc/pf_words.c | 223 ++++++ csrc/pf_words.h | 36 + csrc/pfcompfp.h | 78 ++ csrc/pfcompil.c | 1104 +++++++++++++++++++++++++++++ csrc/pfcompil.h | 72 ++ csrc/pfcustom.c | 122 ++++ csrc/pfinnrfp.h | 336 +++++++++ csrc/pforth.h | 88 +++ docs/pf_ref.htm | 1333 +++++++++++++++++++++++++++++++++++ docs/pf_todo.txt | 116 +++ docs/pf_tut.htm | 1308 ++++++++++++++++++++++++++++++++++ docs/pfmanual.txt | 223 ++++++ filefind.fth | 102 +++ floats.fth | 497 +++++++++++++ forget.fth | 97 +++ go.bat | 1 + loadp4th.fth | 47 ++ locals.fth | 69 ++ math.fth | 89 +++ member.fth | 155 ++++ mipsBuild/pforth.bld | 79 +++ misc1.fth | 150 ++++ misc2.fth | 232 ++++++ numberio.fth | 204 ++++++ pcbuild/pForth.dsp | 316 +++++++++ pcbuild/pForth.dsw | 29 + pcbuild/pForth.ncb | Bin 0 -> 50176 bytes pcbuild/pForth.opt | Bin 0 -> 49664 bytes pcbuild/pForth.plg | 59 ++ private.fth | 48 ++ quit.fth | 136 ++++ see.fth | 218 ++++++ siev.fs | 23 + siev.fth | 31 + smart_if.fth | 57 ++ strings.fth | 97 +++ system.fth | 805 +++++++++++++++++++++ t_alloc.fth | 116 +++ t_corex.fth | 226 ++++++ t_floats.fth | 134 ++++ t_locals.fth | 41 ++ t_strings.fth | 106 +++ t_tools.fth | 83 +++ tester.fth | 54 ++ trace.fth | 455 ++++++++++++ tut.fth | 70 ++ utils/clone.fth | 489 +++++++++++++ utils/dump_struct.fth | 120 ++++ utils/load_file.fth | 39 + utils/make_all256.fth | 57 ++ utils/savedicd.fth | 170 +++++ utils/trace.fth | 438 ++++++++++++ wordslik.fth | 44 ++ 88 files changed, 18705 insertions(+) create mode 100644 Makefile create mode 100644 README.txt create mode 100644 ansilocs.fth create mode 100644 bench.fth create mode 100644 bloop.fth create mode 100644 c_struct.fth create mode 100644 case.fth create mode 100644 catch.fth create mode 100644 checkit.fth create mode 100644 condcomp.fth create mode 100644 coretest.fth create mode 100644 csrc/pf_all.h create mode 100644 csrc/pf_cglue.c create mode 100644 csrc/pf_cglue.h create mode 100644 csrc/pf_clib.c create mode 100644 csrc/pf_clib.h create mode 100644 csrc/pf_core.c create mode 100644 csrc/pf_core.h create mode 100644 csrc/pf_float.h create mode 100644 csrc/pf_guts.h create mode 100644 csrc/pf_host.h create mode 100644 csrc/pf_inner.c create mode 100644 csrc/pf_io.c create mode 100644 csrc/pf_io.h create mode 100644 csrc/pf_mac.h create mode 100644 csrc/pf_main.c create mode 100644 csrc/pf_mem.c create mode 100644 csrc/pf_mem.h create mode 100644 csrc/pf_save.c create mode 100644 csrc/pf_save.h create mode 100644 csrc/pf_text.c create mode 100644 csrc/pf_text.h create mode 100644 csrc/pf_types.h create mode 100644 csrc/pf_unix.h create mode 100644 csrc/pf_win32.h create mode 100644 csrc/pf_words.c create mode 100644 csrc/pf_words.h create mode 100644 csrc/pfcompfp.h create mode 100644 csrc/pfcompil.c create mode 100644 csrc/pfcompil.h create mode 100644 csrc/pfcustom.c create mode 100644 csrc/pfinnrfp.h create mode 100644 csrc/pforth.h create mode 100644 docs/pf_ref.htm create mode 100644 docs/pf_todo.txt create mode 100644 docs/pf_tut.htm create mode 100644 docs/pfmanual.txt create mode 100644 filefind.fth create mode 100644 floats.fth create mode 100644 forget.fth create mode 100644 go.bat create mode 100644 loadp4th.fth create mode 100644 locals.fth create mode 100644 math.fth create mode 100644 member.fth create mode 100644 mipsBuild/pforth.bld create mode 100644 misc1.fth create mode 100644 misc2.fth create mode 100644 numberio.fth create mode 100644 pcbuild/pForth.dsp create mode 100644 pcbuild/pForth.dsw create mode 100644 pcbuild/pForth.ncb create mode 100644 pcbuild/pForth.opt create mode 100644 pcbuild/pForth.plg create mode 100644 private.fth create mode 100644 quit.fth create mode 100644 see.fth create mode 100644 siev.fs create mode 100644 siev.fth create mode 100644 smart_if.fth create mode 100644 strings.fth create mode 100644 system.fth create mode 100644 t_alloc.fth create mode 100644 t_corex.fth create mode 100644 t_floats.fth create mode 100644 t_locals.fth create mode 100644 t_strings.fth create mode 100644 t_tools.fth create mode 100644 tester.fth create mode 100644 trace.fth create mode 100644 tut.fth create mode 100644 utils/clone.fth create mode 100644 utils/dump_struct.fth create mode 100644 utils/load_file.fth create mode 100644 utils/make_all256.fth create mode 100644 utils/savedicd.fth create mode 100644 utils/trace.fth create mode 100644 wordslik.fth diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..40a3fc3 --- /dev/null +++ b/Makefile @@ -0,0 +1,87 @@ +# @(#) rlsMakefile 97/12/10 1.1 +# makefile for pForth +# Portable Forth written in 'C' +# Phil Burk + +.SUFFIXES: .c .o + +# Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG +# See "docs/pf_ref.htm" file for more info. + +SOURCEDIR = csrc +OBJECTDIR = objects +EMBOBJECTDIR = embobjects + +FULL_WARNINGS = -O2 \ + -fsigned-char \ + -fno-builtin \ + -fno-unroll-loops \ + -fpeephole \ + -fno-keep-inline-functions \ + -x c++ \ + -Wcast-qual \ + -Wall \ + -Wwrite-strings \ + -Winline \ + -Wmissing-prototypes \ + -Wmissing-declarations + +CCOPTS = -DPF_SUPPORT_FP $(FULL_WARNINGS) +COMPILER = gcc + +EMBCCOPTS = -DPF_NO_INIT -DPF_NO_MALLOC -DPF_NO_FILEIO \ + -DPF_NO_CLIB -DPF_STATIC_DIC + +####################################### +# Build file lists from wildcards. +PFITEMP = ${wildcard ${SOURCEDIR}/*.h} +PFINCLUDES = ${PFITEMP:${SOURCEDIR}/pfdicdat.h=} +PFSOURCE = ${wildcard ${SOURCEDIR}/*.c} +PFTEMP = ${PFSOURCE:%.c=%.o} +PFOBJS = ${PFTEMP:${SOURCEDIR}/%=${OBJECTDIR}/%} +PFEMBOBJS = ${PFTEMP:${SOURCEDIR}/%=${EMBOBJECTDIR}/%} + +COMPILE = $(COMPILER) $(CCOPTS) $(CDEFS) + +${OBJECTDIR}/%.o: $(PFINCLUDES) ${SOURCEDIR}/%.c + $(COMPILE) -O -o ${OBJECTDIR}/$*.o -c ${SOURCEDIR}/$*.c + +${EMBOBJECTDIR}/%.o: $(PFINCLUDES) ${SOURCEDIR}/%.c ${SOURCEDIR}/pfdicdat.h + $(COMPILE) -O -o ${EMBOBJECTDIR}/$*.o -c ${SOURCEDIR}/$*.c $(EMBCCOPTS) + +all: pforth pforth.dic + +pffiles: + echo "ITEMP FILES -----------------" + echo ${PFITEMP} + 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 +pforth: $(PFINCLUDES) $(PFOBJS) + $(COMPILER) $(PFOBJS) -lm -o pforth + +# build basic dictionary by running newly built pforth and including system.fth +pforth.dic: pforth + pforth -i system.fth + +${SOURCEDIR}/pfdicdat.h: pforth pforth.dic + @(echo 'INCLUDE utils/savedicd.fth'; \ + echo 'SDAD'; \ + echo 'bye') | \ + pforth -dpforth.dic + cp pfdicdat.h ${SOURCEDIR} + + +pfemb: $(PFINCLUDES) $(PFEMBOBJS) + $(COMPILER) $(PFEMBOBJS) -lm -o pfemb + +clean: + rm -f $(PFOBJS) $(PFEMBOBJS) pforth *.dic core ${SOURCEDIR}/pfdicdat.h pfemb + diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..b37e94f --- /dev/null +++ b/README.txt @@ -0,0 +1,291 @@ +README for pForth - a Portable ANS-like Forth written in ANSI 'C' + +by Phil Burk +with Larry Polansky, David Rosenboom and Darren Gibbs. + +Last updated: 4/6/98 V19 + +Please direct feedback, bug reports, and suggestions to: + + philburk@softsynth.com. + + +The author is available for customization of pForth, porting to new + +platforms, or developing pForth applications on a contractual basis. + +If interested, contact Phil Burk at philburk@softsynth.com. + + + +-- LEGAL NOTICE ----------------------------------------- + +The pForth software code is dedicated to the public domain, +and any third party may reproduce, distribute and modify +the pForth software code or any derivative works thereof +without any compensation or license. The pForth software +code is provided on an "as is" basis without any warranty +of any kind, including, without limitation, the implied +warranties of merchantability and fitness for a particular +purpose and their equivalents under the laws of any jurisdiction. + +-- How to run PForth ------------------------------------ + + +Note: Please refer to "pf_ref.htm" for more complete information. + + +Once you have compiled and built the dictionary, just enter: + pforth + + +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 run PForth ------------------------------------ + +You can test the Forth without loading a dictionary +which might be necessary if the dictionary can't be built. + + +Enter: pforth -i +In pForth, enter: 3 4 + . +In pForth, enter: loadsys +In pForth, enter: 10 0 do i . loop + +PForth comes with a small test suite. To test the Core words, +you can use the coretest developed by John Hayes. + +Enter: pforth +Enter: include tester.fth +Enter: 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. + +-- Version History -------------------------------------- + +V1 - 5/94 + - built pForth from various Forths including HMSL + +V2 - 8/94 + - made improvements necessary for use with M2 Verilog testing + +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. + +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 + +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 + +V6 - 3/16/95 + - Added floating point + - Changed NUMBER? to return a numeric type + - Support double number entry, eg. 234. -> 234 0 + +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 + +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. + +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 + +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. ;-) + +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. + +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. + +V13 - 12/15/96 + - 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". + +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". + +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). + +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. + +V17 + - Fixed input of large floats. 0.7071234567 F. used to fail. + +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. + +V19 4/98 + + - 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() + +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. + +V21 + - Fixed some compiler warnings. + +Enjoy, +Phil Burk diff --git a/ansilocs.fth b/ansilocs.fth new file mode 100644 index 0000000..a32ee93 --- /dev/null +++ b/ansilocs.fth @@ -0,0 +1,196 @@ +\ @(#) 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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-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 @ [compile] literal compile (local.entry) + ['] lv.compile.local local-compiler ! + THEN +; + + +: VALUE + CREATE ( n ) + , + immediate + DOES> + state @ + IF + [compile] aliteral + compile @ + ELSE + @ + THEN +; + +: TO ( val -- ) + bl word + lv.match + IF ( -- index ) + lv.compile.store + ELSE + find + 1 = 0= abort" TO or -> before non-local or non-value" + >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 + 1 = 0= abort" +-> before non-local or non-value" + >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 diff --git a/bench.fth b/bench.fth new file mode 100644 index 0000000..cc594c2 --- /dev/null +++ b/bench.fth @@ -0,0 +1,190 @@ +\ @(#) 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 +\ +\ 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 diff --git a/bloop.fth b/bloop.fth new file mode 100644 index 0000000..e0024fe --- /dev/null +++ b/bloop.fth @@ -0,0 +1,34 @@ + + +: BLOOP ( n -- n' ) + 0 swap 0 + DO + i + + i 1 and + IF + dup dup 2 + + swap - drop + THEN + LOOP +; + + +\ ." START" cr +\ 8000000 bloop . +\ ." END" cr + + +: uselocs { aa bb -- } + aa bb + + aa bb - + - drop +; + +: BLOCS ( N -- ) + 0 DO i 77 uselocs LOOP +; + + +." START" cr +2000000 blocs +." END" cr diff --git a/c_struct.fth b/c_struct.fth new file mode 100644 index 0000000..86062d7 --- /dev/null +++ b/c_struct.fth @@ -0,0 +1,242 @@ +\ @(#) 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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 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 + -4 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 + -4 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 + -4 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 + -4 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 + aptr map_a1 + rptr map_r1 + flpt map_f1 + short map_s1 + ushort map_s2 + byte map_b1 + ubyte map_b2 +;struct +mapper map1 + +: TT + -500 map1 s! map_s1 + map1 s@ map_s1 -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] diff --git a/case.fth b/case.fth new file mode 100644 index 0000000..205e650 --- /dev/null +++ b/case.fth @@ -0,0 +1,75 @@ +\ @(#) 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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ MOD: PLB 6/24/91 Check for missing ENDOF +\ MOD: PLB 8/7/91 Add ?OF and RANGEOF + +anew TASK-CASE + +variable CASE-DEPTH +variable OF-DEPTH + +: CASE ( n -- , start case statement ) ( -c- case-depth ) + ?comp case-depth @ case-depth off ( allow nesting ) + 0 of-depth ! +; 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 ! +; IMMEDIATE + diff --git a/catch.fth b/catch.fth new file mode 100644 index 0000000..99698bb --- /dev/null +++ b/catch.fth @@ -0,0 +1,61 @@ +\ @(#) catch.fth 98/01/26 1.2 +\ Catch and Throw support +\ +\ Lifted from X3J14 dpANS-6 document. + +anew task-catch.fth + +variable CATCH-HANDLER +0 catch-handler ! + +: CATCH ( xt -- exception# | 0 ) + sp@ >r ( xt ) \ save data stack pointer + catch-handler @ >r ( xt ) \ save previous handler + rp@ catch-handler ! ( xt ) \ set current handler + execute ( ) \ execute returns if no throw + r> catch-handler ! ( ) \ restore previous handler + r> drop ( ) \ discard saved stack pointer + 0 ( ) \ normal completion +; + +: THROW ( ???? exception# -- ???? exception# ) + ?dup ( exc# ) \ 0 THROW is a no-op + IF + catch-handler @ + dup 0= + IF + ." THROW has noone to catch!" cr + quit + THEN + rp! ( exc# ) \ restore prev return stack + r> catch-handler ! ( exc# ) \ restore prev handler + r> swap >r ( saved-sp ) \ exc# on return stack + sp! drop r> ( exc# ) \ restore stack + THEN + \ return to caller of catch +; + + +: (ABORT) ERR_ABORT throw ; +defer old.abort +what's abort is old.abort +' (abort) is abort +: restore.abort what's old.abort is abort ; +if.forgotten restore.abort + +hex +: BAD.WORD -5 throw ; +: NAIVE.WORD ( -- ) + 7777 8888 23 . cr + bad.word + ." After bad word!" cr +; + +: CATCH.BAD ( -- ) + ['] naive.word catch . +; + +: CATCH.GOOD ( -- ) + 777 ['] . catch . cr +; +decimal diff --git a/checkit.fth b/checkit.fth new file mode 100644 index 0000000..a4ff1d7 --- /dev/null +++ b/checkit.fth @@ -0,0 +1,32 @@ +\ compare dictionaries + +anew comp +hex + +: checksum { start end -- sum } + 0 + end start + DO + i @ + + 4 +LOOP +; + +: findword { target start end -- } + end start + DO + i @ target = + IF + ." found at " i u. cr + i 16 dump + THEN + 4 +LOOP +; + +echo on +hex +$ 01500fc4 codebase here findword +codebase here cr .s checksum u. cr +namebase context @ cr .s checksum u. cr +decimal + +echo off diff --git a/condcomp.fth b/condcomp.fth new file mode 100644 index 0000000..b95b005 --- /dev/null +++ b/condcomp.fth @@ -0,0 +1,50 @@ +\ @(#) 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 + swap drop +; immediate diff --git a/coretest.fth b/coretest.fth new file mode 100644 index 0000000..e5e1a94 --- /dev/null +++ b/coretest.fth @@ -0,0 +1,996 @@ +\ 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?... + +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 } + + diff --git a/csrc/pf_all.h b/csrc/pf_all.h new file mode 100644 index 0000000..da2e603 --- /dev/null +++ b/csrc/pf_all.h @@ -0,0 +1,62 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** 940521 PLB Creation. +** +***************************************************************/ + +/* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */ +#ifdef __MWERKS__ + #define PF_USER_INC1 "pf_mac.h" + #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 +/* Default to UNIX if no host speciied. */ + #include "pf_unix.h" +#endif + +#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 */ + diff --git a/csrc/pf_cglue.c b/csrc/pf_cglue.c new file mode 100644 index 0000000..0fe58b0 --- /dev/null +++ b/csrc/pf_cglue.c @@ -0,0 +1,108 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#include "pf_all.h" + +typedef cell (*CFunc0)( void ); +typedef cell (*CFunc1)( cell P1 ); +typedef cell (*CFunc2)( cell P1, cell P2 ); +typedef cell (*CFunc3)( cell P1, cell P2, cell P3 ); +typedef cell (*CFunc4)( cell P1, cell P2, cell P3, cell P4 ); +typedef cell (*CFunc5)( cell P1, cell P2, cell P3, cell P4, cell P5 ); + + +extern void *CustomFunctionTable[]; + +/***************************************************************/ +int32 CallUserFunction( int32 Index, int32 ReturnMode, int32 NumParams ) +{ + cell P1, P2, P3, P4, P5; + cell Result = 0; + void *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, uint32 Index, int32 ReturnMode, int32 NumParams ) +{ + uint32 Packed; + char FName[40]; + + CStringToForth( FName, CName ); + 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 diff --git a/csrc/pf_cglue.h b/csrc/pf_cglue.h new file mode 100644 index 0000000..eed6ae0 --- /dev/null +++ b/csrc/pf_cglue.h @@ -0,0 +1,39 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + + +#ifdef __cplusplus +extern "C" { +#endif + +Err CreateGlueToC( const char *CName, uint32 Index, int32 ReturnMode, int32 NumParams ); +Err CompileCustomFunctions( void ); +Err LoadCustomFunctionTable( void ); +int32 CallUserFunction( int32 Index, int32 ReturnMode, int32 NumParams ); + +#ifdef __cplusplus +} +#endif + +#define C_RETURNS_VOID (0) +#define C_RETURNS_VALUE (1) + +#endif /* _pf_c_glue_h */ diff --git a/csrc/pf_clib.c b/csrc/pf_clib.c new file mode 100644 index 0000000..34fcfb7 --- /dev/null +++ b/csrc/pf_clib.c @@ -0,0 +1,64 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 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 pfCStringLength( const char *s ) +{ + cell len = 0; + while( *s++ != NUL ) len++; + return len; +} + +/* void *memset (void *s, int32 c, size_t n); */ +void *pfSetMemory( void *s, cell c, cell n ) +{ + uint8 *p = s, byt = (uint8) c; + while( (n--) > 0) *p++ = byt; + return s; +} + +/* void *memccpy (void *s1, const void *s2, int32 c, size_t n); */ +void *pfCopyMemory( void *s1, const void *s2, cell n) +{ + uint8 *p1 = s1; + const uint8 *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 ); +} diff --git a/csrc/pf_clib.h b/csrc/pf_clib.h new file mode 100644 index 0000000..3e58dd1 --- /dev/null +++ b/csrc/pf_clib.h @@ -0,0 +1,63 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef PF_NO_CLIB + + #ifdef __cplusplus + extern "C" { + #endif + + cell pfCStringLength( const char *s ); + void *pfSetMemory( void *s, cell c, cell n ); + void *pfCopyMemory( void *s1, const void *s2, cell 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 */ diff --git a/csrc/pf_core.c b/csrc/pf_core.c new file mode 100644 index 0000000..77f5a0f --- /dev/null +++ b/csrc/pf_core.c @@ -0,0 +1,422 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 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 +***************************************************************/ + +cfTaskData *gCurrentTask; +cfDictionary *gCurrentDictionary; +int32 gNumPrimitives; +char gScratch[TIB_SIZE]; +ExecToken gLocalCompiler_XT; /* custom compiler for local variables */ + +/* Depth of data stack when colon called. */ +int32 gDepthAtColon; + +/* Global Forth variables. */ +char *gVarContext; /* Points to last name field. */ +cell gVarState; /* 1 if compiling. */ +cell gVarBase; /* Numeric Base. */ +cell gVarEcho; /* Echo input. */ +cell gVarTraceLevel; /* Trace Level for Inner Interpreter. */ +cell gVarTraceStack; /* Dump Stack each time if true. */ +cell gVarTraceFlags; /* Enable various internal debug messages. */ +cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ +cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ + +#define DEFAULT_RETURN_DEPTH (512) +#define DEFAULT_USER_DEPTH (512) +#define DEFAULT_HEADER_SIZE (120000) +#define DEFAULT_CODE_SIZE (300000) + +/* Initialize non-zero globals in a function to simplify loading on + * embedded systems which may only support uninitialized data segments. + */ +void pfInitGlobals( void ) +{ + gVarBase = 10; + gVarTraceStack = 1; + gDepthAtColon = DEPTH_AT_COLON_INVALID; +} + +/*************************************************************** +** Task Management +***************************************************************/ + +void pfDeleteTask( cfTaskData *cftd ) +{ + 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) +cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ) +{ + cfTaskData *cftd; + + cftd = ( cfTaskData * ) pfAllocMem( sizeof( cfTaskData ) ); + if( !cftd ) goto nomem; + pfSetMemory( cftd, 0, sizeof( cfTaskData )); + +/* Allocate User Stack */ + cftd->td_StackLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) * + (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 *) pfAllocMem((uint32)(sizeof(int32) * 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((uint32)(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 cftd; + +nomem: + ERR("CreateTaskContext: insufficient memory.\n"); + if( cftd ) pfDeleteTask( cftd ); + return NULL; +} + +/*************************************************************** +** Dictionary Management +***************************************************************/ + +void pfExecByName( const char *CString ) +{ + if( NAME_BASE != NULL) + { + ExecToken autoInitXT; + if( ffFindC( CString, &autoInitXT ) ) + { + pfExecuteToken( autoInitXT ); + } + } +} + +/*************************************************************** +** Delete a dictionary created by pfCreateDictionary() +*/ +void pfDeleteDictionary( cfDictionary *dic ) +{ + 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. +*/ +cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize ) +{ +/* Allocate memory for initial dictionary. */ + cfDictionary *dic; + + dic = ( cfDictionary * ) pfAllocMem( sizeof( cfDictionary ) ); + if( !dic ) goto nomem; + pfSetMemory( dic, 0, sizeof( cfDictionary )); + + dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS; + +/* Align dictionary segments to preserve alignment of floats across hosts. */ +#define DIC_ALIGNMENT_SIZE (0x10) +#define DIC_ALIGN(addr) ((uint8 *)((((uint32)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))) + +/* Allocate memory for header. */ + if( HeaderSize > 0 ) + { + dic->dic_HeaderBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) HeaderSize + DIC_ALIGNMENT_SIZE ); + if( !dic->dic_HeaderBaseUnaligned ) goto nomem; +/* Align header base. */ + dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned); + pfSetMemory( dic->dic_HeaderBase, 0xA5, (uint32) HeaderSize); + dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize; + dic->dic_HeaderPtr.Byte = dic->dic_HeaderBase; + } + else + { + dic->dic_HeaderBase = NULL; + } + +/* Allocate memory for code. */ + dic->dic_CodeBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) CodeSize + DIC_ALIGNMENT_SIZE ); + if( !dic->dic_CodeBaseUnaligned ) goto nomem; + dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned); + pfSetMemory( dic->dic_CodeBase, 0x5A, (uint32) CodeSize); + + dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize; + dic->dic_CodePtr.Byte = dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES); + + return dic; +nomem: + pfDeleteDictionary( dic ); + return NULL; +} + +/*************************************************************** +** Used by Quit and other routines to restore system. +***************************************************************/ + +void ResetForthTask( 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( cfTaskData *cftd ) +{ + gCurrentTask = cftd; +} + +/*************************************************************** +** Set Quiet Flag. +***************************************************************/ + +void pfSetQuiet( int32 IfQuiet ) +{ + gVarQuiet = (cell) IfQuiet; +} + +/*************************************************************** +** Query message status. +***************************************************************/ + +int32 pfQueryQuiet( void ) +{ + return gVarQuiet; +} + +/*************************************************************** +** RunForth +***************************************************************/ + +int32 pfRunForth( void ) +{ + ffQuit(); + return gVarReturnCode; +} + +/*************************************************************** +** Include file based on 'C' name. +***************************************************************/ + +int32 pfIncludeFile( const char *FileName ) +{ + FileStream *fid; + int32 Result; + char buffer[32]; + int32 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 = 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 ); + +/* Create a dictionary word named ;;;; for FILE? */ + CreateDicEntryC( ID_NOOP, ";;;;", 0 ); + + sdCloseFile(fid); + return Result; +} + +/*************************************************************** +** 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. +***************************************************************/ + +void pfMessage( const char *CString ) +{ + ioType( CString, pfCStringLength(CString) ); +} + +/************************************************************************** +** Main entry point fo pForth +*/ +int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ) +{ + cfTaskData *cftd; + cfDictionary *dic; + int32 Result = 0; + ExecToken EntryPoint = 0; + +#ifdef PF_USER_INIT + Result = PF_USER_INIT; + if( Result < 0 ) goto error; +#endif + + pfInitGlobals(); + +/* Allocate Task structure. */ + cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH ); + + if( cftd ) + { + pfSetCurrentTask( cftd ); + + if( !pfQueryQuiet() ) + { + MSG( "PForth V"PFORTH_VERSION"\n" ); + } + +#if 0 +/* Don't use MSG before task set. */ + if( IfInit ) MSG("Build dictionary from scratch.\n"); + + if( DicName ) + { + MSG("DicName = "); MSG(DicName); MSG("\n"); + } + if( SourceName ) + { + MSG("SourceName = "); MSG(SourceName); MSG("\n"); + } +#endif + + +#ifdef PF_NO_GLOBAL_INIT + if( LoadCustomFunctionTable() < 0 ) goto error; /* Init custom 'C' call array. */ +#endif + +#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) + if( IfInit ) + { + dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE ); + } + else +#else + TOUCH(IfInit); +#endif /* !PF_NO_INIT && !PF_NO_SHELL*/ + { + dic = pfLoadDictionary( DicName, &EntryPoint ); + } + if( dic == NULL ) goto error; + + pfExecByName("AUTO.INIT"); + + if( EntryPoint != 0 ) + { + pfExecuteToken( EntryPoint ); + } +#ifndef PF_NO_SHELL + else + { + if( SourceName == NULL ) + { + Result = pfRunForth(); + } + else + { + MSG("Including: "); + MSG(SourceName); + MSG("\n"); + Result = pfIncludeFile( SourceName ); + } + } +#endif /* PF_NO_SHELL */ + pfExecByName("AUTO.TERM"); + pfDeleteDictionary( dic ); + pfDeleteTask( cftd ); + } + +#ifdef PF_USER_TERM + PF_USER_TERM; +#endif + + return Result; + +error: + MSG("pfDoForth: Error occured.\n"); + pfDeleteTask( cftd ); + return -1; +} diff --git a/csrc/pf_core.h b/csrc/pf_core.h new file mode 100644 index 0000000..b55c9d4 --- /dev/null +++ b/csrc/pf_core.h @@ -0,0 +1,51 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +/* Main entry point fo pForth. */ +int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ); + +void pfInitGlobals( void ); +cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ); +void pfDeleteTask( cfTaskData *cftd ); +void pfSetCurrentTask( cfTaskData *cftd ); + +cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize ); +void pfDeleteDictionary( cfDictionary *dic ); + +void pfSetQuiet( int32 IfQuiet ); +int32 pfQueryQuiet( void ); +int32 pfRunForth( void ); +int32 pfIncludeFile( const char *FileName ); +void pfMessage( const char *CString ); +void pfExecByName( const char *CString ); + +void ResetForthTask( void ); + +#ifdef __cplusplus +} +#endif + + +#endif /* _pf_core_h */ diff --git a/csrc/pf_float.h b/csrc/pf_float.h new file mode 100644 index 0000000..ca5ef3d --- /dev/null +++ b/csrc/pf_float.h @@ -0,0 +1,43 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +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 + +#endif diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h new file mode 100644 index 0000000..3a19f79 --- /dev/null +++ b/csrc/pf_guts.h @@ -0,0 +1,565 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/* +** PFORTH_VERSION changes when PForth is modified and released. +** See README file for version info. +*/ +#define PFORTH_VERSION "21" + +/* +** 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. +*/ +#define PF_FILE_VERSION (8) /* Bump this whenever primitives added. */ +#define PF_EARLIEST_FILE_VERSION (8) /* 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)) + +/*************************************************************** +** 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, + 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_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_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, +/* 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_RESERVED01, + ID_RESERVED02, + ID_RESERVED03, + ID_RESERVED04, + ID_RESERVED05, + ID_RESERVED06, + ID_RESERVED07, + ID_RESERVED08, + ID_RESERVED09, + ID_RESERVED10, + ID_RESERVED11, + ID_RESERVED12, + ID_RESERVED13, + ID_RESERVED14, + ID_RESERVED15, + ID_RESERVED16, + ID_RESERVED17, + ID_RESERVED18, + ID_RESERVED19, + ID_RESERVED20, + 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 */ +}; + + +/*************************************************************** +** Structures +***************************************************************/ +#define CFTD_FLAG_GO (0x0001) +/* This flag is true when ABORTing to cause the 'C' code to unravel. */ +#define CFTD_FLAG_ABORT (0x0002) + +typedef struct cfTaskData +{ + cell *td_StackPtr; /* Primary data stack */ + cell *td_StackBase; + cell *td_StackLimit; + cell *td_ReturnPtr; /* Return stack */ + cell *td_ReturnBase; + cell *td_ReturnLimit; +#ifdef PF_SUPPORT_FP + PF_FLOAT *td_FloatStackPtr; + PF_FLOAT *td_FloatStackBase; + PF_FLOAT *td_FloatStackLimit; +#endif + cell *td_InsPtr; /* Instruction pointer, "PC" */ + cell td_Flags; + FileStream *td_InputStream; +/* Terminal. */ + char td_TIB[TIB_SIZE]; /* Buffer for terminal input. */ + cell td_IN; /* Index into Source */ + cell td_SourceNum; /* #TIB after REFILL */ + char *td_SourcePtr; /* Pointer to TIB or other source. */ + int32 td_LineNumber; /* Incremented on every refill. */ + cell td_OUT; /* Current output column. */ +} cfTaskData; + +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 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 cfDictionary +{ + pfNode dic_Node; + uint32 dic_Flags; +/* Headers contain pointers to names and dictionary. */ + uint8 *dic_HeaderBaseUnaligned; + uint8 *dic_HeaderBase; + union + { + cell *Cell; + uint8 *Byte; + } dic_HeaderPtr; + uint8 *dic_HeaderLimit; +/* Code segment contains tokenized code and data. */ + uint8 *dic_CodeBaseUnaligned; + uint8 *dic_CodeBase; + union + { + cell *Cell; + uint8 *Byte; + } dic_CodePtr; + uint8 *dic_CodeLimit; +} cfDictionary; + +/* Save state of include when nesting files. */ +typedef struct IncludeFrame +{ + FileStream *inf_FileID; + int32 inf_LineNumber; + int32 inf_SourceNum; + int32 inf_IN; + char inf_SaveTIB[TIB_SIZE]; +} IncludeFrame; + +#define MAX_INCLUDE_DEPTH (8) + +/*************************************************************** +** Prototypes +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +void pfExecuteToken( ExecToken XT ); + +#ifdef __cplusplus +} +#endif + +/*************************************************************** +** External Globals +***************************************************************/ +extern cfTaskData *gCurrentTask; +extern cfDictionary *gCurrentDictionary; +extern char gScratch[TIB_SIZE]; +extern int32 gNumPrimitives; + +extern ExecToken gLocalCompiler_XT; /* CFA of (LOCAL) compiler. */ + +#define DEPTH_AT_COLON_INVALID (-100) +extern int32 gDepthAtColon; + +/* Global variables. */ +extern char *gVarContext; /* Points to last name field. */ +extern cell gVarState; /* 1 if compiling. */ +extern cell gVarBase; /* Numeric Base. */ +extern cell gVarEcho; /* Echo input from file. */ +extern cell gVarEchoAccept; /* Echo input from ACCEPT. */ +extern cell gVarTraceLevel; +extern cell gVarTraceStack; +extern cell gVarTraceFlags; +extern cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ +extern cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ + +/*************************************************************** +** 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_LONG_DIC(addr,data) WriteLongBigEndian((uint32 *)(addr),(uint32)(data)) +#define WRITE_SHORT_DIC(addr,data) WriteShortBigEndian((uint16 *)(addr),(uint16)(data)) +#define READ_FLOAT_DIC ReadFloatBigEndian +#define READ_LONG_DIC(addr) ReadLongBigEndian((uint32 *)(addr)) +#define READ_SHORT_DIC(addr) ReadShortBigEndian((uint16 *)(addr)) +#elif defined(PF_LITTLE_ENDIAN_DIC) +#define WRITE_FLOAT_DIC WriteFloatLittleEndian +#define WRITE_LONG_DIC(addr,data) WriteLongLittleEndian((uint32 *)(addr),(uint32)(data)) +#define WRITE_SHORT_DIC(addr,data) WriteShortLittleEndian((uint16 *)(addr),(uint16)(data)) +#define READ_FLOAT_DIC ReadFloatLittleEndian +#define READ_LONG_DIC(addr) ReadLongLittleEndian((uint32 *)(addr)) +#define READ_SHORT_DIC(addr) ReadShortLittleEndian((uint16 *)(addr)) +#else +#define WRITE_FLOAT_DIC(addr,data) { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); } +#define WRITE_LONG_DIC(addr,data) { *((int32 *)(addr)) = (int32)(data); } +#define WRITE_SHORT_DIC(addr,data) { *((int16 *)(addr)) = (int16)(data); } +#define READ_FLOAT_DIC(addr) ( *((PF_FLOAT *)(addr)) ) +#define READ_LONG_DIC(addr) ( *((int32 *)(addr)) ) +#define READ_SHORT_DIC(addr) ( *((int16 *)(addr)) ) +#endif + +#define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell) +#define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell) +#define CODE_COMMA( N ) WRITE_LONG_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 *)(addr)) >= gCurrentDictionary->dic_CodeBase) && ( ((uint8 *)(addr)) < gCurrentDictionary->dic_CodeLimit) ) +#define IN_NAME_DIC(addr) ( ( ((uint8 *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8 *)(addr)) < gCurrentDictionary->dic_HeaderLimit) ) +#define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr)) + +/* Address conversion */ +#define ABS_TO_NAMEREL( a ) ((int32) (((uint8 *) a) - NAME_BASE )) +#define ABS_TO_CODEREL( a ) ((int32) (((uint8 *) a) - CODE_BASE )) +#define NAMEREL_TO_ABS( a ) ((char *) (((int32) a) + NAME_BASE)) +#define CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CODE_BASE)) + +/* The check for >0 is only needed for CLONE testing. !!! */ +#define IsTokenPrimitive(xt) ((xt=0)) + +#define SET_ABORT { gCurrentTask->td_Flags |= CFTD_FLAG_ABORT; } +#define CLEAR_ABORT { gCurrentTask->td_Flags &= ~CFTD_FLAG_ABORT; } +#define CHECK_ABORT (gCurrentTask->td_Flags & CFTD_FLAG_ABORT) + +#define FREE_VAR(v) { if (v) { pfFreeMem(v); v = NULL; } } + +#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) x; } + +/* Force Quad alignment. */ +#define QUADUP(x) (((x)+3)&~3) + +#define MIN(a,b) ( ((a)<(b)) ? (a) : (b) ) +#define MAX(a,b) ( ((a)>(b)) ? (a) : (b) ) + + +#ifndef TOUCH + #define TOUCH(argument) ((void)argument) +#endif + +/*************************************************************** +** I/O related macros +***************************************************************/ + +#define EMIT(c) ioEmit(c) +#define EMIT_CR EMIT('\n'); + +#define DBUG(x) /* PRT(x) */ +#define DBUGX(x) /* DBUG(x) */ + +#define MSG(cs) pfMessage(cs) +#define ERR(x) MSG(x) + +#define MSG_NUM_D(msg,num) { MSG(msg); ffDot((int32) num); EMIT_CR; } +#define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((int32) num); EMIT_CR; } + +#endif /* _pf_guts_h */ + diff --git a/csrc/pf_host.h b/csrc/pf_host.h new file mode 100644 index 0000000..fe44cb2 --- /dev/null +++ b/csrc/pf_host.h @@ -0,0 +1,24 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +***************************************************************/ + +#endif /* _pf_system_h */ + diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c new file mode 100644 index 0000000..131bfdc --- /dev/null +++ b/csrc/pf_inner.c @@ -0,0 +1,1563 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +** 940502 PLB Creation. +** 940505 PLB More macros. +** 940509 PLB Moved all stack stuff into pfExecuteToken. +** 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" + +#define SYSTEM_LOAD_FILE "system.fth" + +/*************************************************************** +** Macros for data stack access. +** TOS is cached in a register in pfExecuteToken. +***************************************************************/ + +#define STKPTR (DataStackPtr) +#define M_POP (*(STKPTR++)) +#define M_PUSH(n) {*(--(STKPTR)) = (cell) (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; } + + +/*************************************************************** +** 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) (n);} + +/*************************************************************** +** Misc Forth macros +***************************************************************/ + +#define M_BRANCH { InsPtr = (cell *) (((uint8 *) InsPtr) + READ_LONG_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) &varname; } + +#define M_QUIT \ + { \ + ResetForthTask( ); \ + LOAD_REGISTERS; \ + } + +/*************************************************************** +** 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, int32 Level ) +{ + char *DebugName; + int32 i; + + if( ffTokenToName( Token, &DebugName ) ) + { + cell 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 *) (((int32) a) + CodeBase)) + +/**************************************************************/ +void pfExecuteToken( ExecToken XT ) +{ + register cell TopOfStack; /* Cache for faster execution. */ + register cell *DataStackPtr; + register cell *ReturnStackPtr; +#ifdef PF_SUPPORT_FP + register PF_FLOAT fpTopOfStack; + PF_FLOAT *FloatStackPtr; + register PF_FLOAT fpScratch; + register PF_FLOAT fpTemp; +#endif + register cell *InsPtr = NULL; + register cell Token; + register cell Scratch; +#ifdef PF_SUPPORT_TRACE + register int32 Level = 0; +#endif + cell *LocalsPtr = NULL; + cell Temp; + cell *InitialReturnStack; + cell FakeSecondary[2]; + char *CharPtr; + cell *CellPtr; + FileStream *FileID; + uint8 *CodeBase = CODE_BASE; + +/* +** 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; + InitialReturnStack = TORPTR; + Token = XT; + + do + { +DBUG(("pfExecuteToken: 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("pfExecuteToken: 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 *) ( LOCAL_CODEREL_TO_ABS(Token) ); + +/* Fetch token at IP. */ + Token = READ_LONG_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. Put first in switch because ID_EXIT==0 */ + case ID_EXIT: + InsPtr = ( cell *) 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_LONG_DIC(InsPtr++); + M_PUSH(READ_LONG_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: /* ( c-addr +n1 -- +n2 ) */ + CharPtr = (char *) M_POP; + TOS = ioAccept( CharPtr, TOS, PF_STDIN ); + 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) LOCAL_CODEREL_TO_ABS( READ_LONG_DIC(InsPtr++) ); + endcase; + +/* Allocate some extra and put validation identifier at base */ +#define PF_MEMORY_VALIDATOR (0xA81B4D69) + case ID_ALLOCATE: + CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) ); + if( CellPtr ) + { +/* This was broken into two steps because different compilers incremented +** CellPtr before or after the XOR step. */ + Temp = (int32)CellPtr ^ PF_MEMORY_VALIDATOR; + *CellPtr++ = Temp; + M_PUSH( (cell) 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; + +/* Clear GO flag to tell QUIT to return. */ + case ID_BYE: + gCurrentTask->td_Flags &= ~CFTD_FLAG_GO; + endcase; + + case ID_BAIL: + MSG("Emergency exit.\n"); + EXIT(1); + endcase; + + case ID_CALL_C: + SAVE_REGISTERS; + Scratch = READ_LONG_DIC(InsPtr++); + CallUserFunction( Scratch & 0xFFFF, + (Scratch >> 31) & 1, + (Scratch >> 24) & 0x7F ); + LOAD_REGISTERS; + endcase; + + case ID_CFETCH: TOS = *((uint8 *) TOS); endcase; + + case ID_CMOVE: /* ( src dst n -- ) */ + { + register char *DstPtr = (char *) M_POP; /* dst */ + CharPtr = (char *) M_POP; /* src */ + for( Scratch=0; (uint32) Scratch < (uint32) 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; (uint32) Scratch < (uint32) TOS ; Scratch++ ) + { + *(--DstPtr) = *(--CharPtr); + } + M_DROP; + } + endcase; + +#ifndef PF_NO_SHELL + case ID_COLON: + ffColon( ); + 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; + int32 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 = ( ((uint32)M_POP) > ((uint32)TOS) ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_U_LESSTHAN: + TOS = ( ((uint32)M_POP) < ((uint32)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: + ffCreate(); + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_CREATE_P: + PUSH_TOS; +/* Put address of body on stack. Insptr points after code start. */ + TOS = (cell) ((char *)InsPtr - sizeof(cell) + CREATE_BODY_OFFSET ); + endcase; + + case ID_CSTORE: /* ( c caddr -- ) */ + *((uint8 *) TOS) = (uint8) M_POP; + M_DROP; + endcase; + +/* Double precision add. */ + case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ + { + register ucell 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 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; + +/* Perform 32*32 bit multiply for 64 bit result, using shift and add. */ +/* This seems crazy. There must be an easier way. !!! */ + case ID_D_UMTIMES: /* M* ( a b -- pl ph ) */ + { + register ucell a, b; + register ucell pl, ph, mi; + a = M_POP; + b = TOS; + ph = pl = 0; + for( mi=0; mi<32; mi++ ) + { +/* Shift B to left, checking bits. */ +/* Shift Product to left and add AP. */ + ph = (ph << 1) | (pl >> 31); /* 64 bit shift */ + pl = pl << 1; + if( b & 0x80000000 ) + { + register ucell temp; + temp = pl + a; + if( (temp < pl) || (temp < a) ) ph += 1; /* Carry */ + pl = temp; + } + b = b << 1; +DBUG(("UM* : mi = %d, a = 0x%08x, b = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, a, b, ph, pl )); + } + M_PUSH( pl ); + TOS = ph; + } + endcase; + +/* Perform 32*32 bit multiply for 64 bit result, using shift and add. */ +/* This seems crazy. There must be an easier way. !!! */ + case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ + { + register cell a, b; + register ucell pl, ph, mi, ap, bp; + a = M_POP; + ap = (a < 0) ? -a : a ; /* Positive A */ + b = TOS; + bp = (b < 0) ? -b : b ; /* Positive B */ + ph = pl = 0; + for( mi=0; mi<32; mi++ ) + { +/* Shift B to left, checking bits. */ +/* Shift Product to left and add AP. */ + ph = (ph << 1) | (pl >> 31); /* 64 bit shift */ + pl = pl << 1; + if( bp & 0x80000000 ) + { + register ucell temp; + temp = pl + ap; + if( (temp < pl) && (temp < ap) ) ph += 1; /* Carry */ + pl = temp; + } + bp = bp << 1; +DBUG(("M* : mi = %d, ap = 0x%08x, bp = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, ap, bp, ph, pl )); + } +/* Negate product if one operand negative. */ + if( ((a ^ b) & 0x80000000) ) + { + pl = 0-pl; +DBUG(("M* : -pl = 0x%08x\n", pl )); + if( pl & 0x80000000 ) + { + ph = -1 - ph; /* Borrow */ + } + else + { + ph = 0 - ph; + } +DBUG(("M* : -ph = 0x%08x\n", ph )); + } + M_PUSH( pl ); + TOS = ph; + } + endcase; + +#define DULT(du1l,du1h,du2l,du2h) ( (du2h> 1) | (bh << 31); + bh = bh >> 1; + } + if( !DULT(al,ah,bl,bh) ) + { + + al = al - bl; + q |= 1; + } + M_PUSH( al ); /* rem */ + TOS = q; + } + endcase; + +/* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */ + case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ + { + register ucell ah,am,al,ql,qh,di; +#define bdiv ((ucell)TOS) + ah = 0; + am = M_POP; + al = M_POP; + qh = ql = 0; + for( di=0; di<64; di++ ) + { + if( bdiv <= ah ) + { + ah = ah - bdiv; + ql |= 1; + } + qh = (qh << 1) | (ql >> 31); + ql = ql << 1; + ah = (ah << 1) | (am >> 31); + am = (am << 1) | (al >> 31); + 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) '\n'; + endcase; + + case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */ + Scratch = TOS; + M_DROP; + if(TOS) + { + MSG_NUM_D("Error: ", (int32) Scratch); + M_QUIT; + } + 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_LONG_DIC( (cell *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */ + InsPtr = &FakeSecondary[0]; + } + else + { + InsPtr = (cell *) 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) READ_LONG_DIC((cell *)TOS); + } + else + { + TOS = *((cell *)TOS); + } +#else + TOS = *((cell *)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 ) + { + pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch ); + gScratch[Scratch] = '\0'; + DBUG(("Create file = %s\n", gScratch )); + FileID = sdOpenFile( gScratch, PF_FAM_CREATE ); + TOS = ( FileID == NULL ) ? -1 : 0 ; + M_PUSH( (cell) FileID ); + } + else + { + ERR("Filename too large for name buffer.\n"); + M_PUSH( 0 ); + 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 *fam; + + pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch ); + gScratch[Scratch] = '\0'; + DBUG(("Open file = %s\n", gScratch )); + fam = ( TOS == PF_FAM_READ_ONLY ) ? PF_FAM_OPEN_RO : PF_FAM_OPEN_RW ; + FileID = sdOpenFile( gScratch, fam ); + TOS = ( FileID == NULL ) ? -1 : 0 ; + M_PUSH( (cell) 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 ); + M_PUSH(Temp); + TOS = 0; + endcase; + + case ID_FILE_SIZE: /* ( fid -- ud ior ) */ +/* Determine file size by seeking to end and returning position. */ + FileID = (FileStream *) TOS; + Scratch = sdTellFile( FileID ); + sdSeekFile( FileID, 0, PF_SEEK_END ); + M_PUSH( sdTellFile( FileID )); + sdSeekFile( FileID, Scratch, PF_SEEK_SET ); + TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */ + 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: /* ( pos fid -- ior ) */ + FileID = (FileStream *) TOS; + Scratch = M_POP; + TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET ); + endcase; + + case ID_FILE_POSITION: /* ( pos fid -- ior ) */ + M_PUSH( sdTellFile( (FileStream *) TOS )); + TOS = 0; + 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_FILL: /* ( caddr num charval -- ) */ + { + register char *DstPtr; + Temp = M_POP; /* num */ + DstPtr = (char *) M_POP; /* dst */ + for( Scratch=0; (uint32) Scratch < (uint32) 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) 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 *) TOS; + CellPtr--; + if( ((uint32)*CellPtr) != ((uint32)CellPtr ^ PF_MEMORY_VALIDATOR)) + { + TOS = -2; /* FIXME error code */ + } + else + { + CellPtr[0] = 0xDeadBeef; + CellPtr[1] = 0xDeadBeef; + pfFreeMem((char *)CellPtr); + TOS = 0; + } + } + endcase; + +#include "pfinnrfp.h" + + case ID_HERE: + PUSH_TOS; + TOS = (cell)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) 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; + ffIncludeFile( FileID ); + LOAD_REGISTERS; +#endif /* !PF_NO_SHELL */ + endcase; + + case ID_J: /* ( -- j , second DO LOOP index ) */ + PUSH_TOS; + TOS = M_R_PICK(3); + endcase; + + case ID_KEY: + PUSH_TOS; + TOS = ioKey(); + 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_LONG_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 */ + { + int32 i = TOS; + cell *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 *) 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; + ffIncludeFile( FileID ); + LOAD_REGISTERS; + sdCloseFile( FileID ); + } + 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) NameToToken((ForthString *)TOS); + endcase; + + case ID_NAME_TO_PREVIOUS: + TOS = (cell) 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_LONG_DIC((cell *)TOS); + Scratch += M_POP; + WRITE_LONG_DIC((cell *)TOS,Scratch); + } + else + { + *((cell *)TOS) += M_POP; + } +#else + *((cell *)TOS) += M_POP; +#endif + M_DROP; + endcase; + + case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */ + { + ucell OldIndex, NewIndex, Limit; + + Limit = M_R_POP; + OldIndex = M_R_POP; + NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */ +/* Do indices cross boundary between LIMIT-1 and LIMIT ? */ + if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) || + ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) ) + { + 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 implemented! */ + PUSH_TOS; + TOS = sdQueryTerminal(); + endcase; + + case ID_QUIT_P: /* Stop inner interpreter, go back to user. */ +#ifdef PF_SUPPORT_TRACE + Level = 0; +#endif + ffAbort(); + 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(); + endcase; + +/* Resize memory allocated by ALLOCATE. */ + case ID_RESIZE: /* ( addr1 u -- addr2 result ) */ + { + cell *FreePtr; + + FreePtr = (cell *) ( M_POP - sizeof(cell) ); + if( ((uint32)*FreePtr) != ((uint32)FreePtr ^ PF_MEMORY_VALIDATOR)) + { + M_PUSH( 0 ); + TOS = -3; + } + else + { + /* Try to allocate. */ + CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) ); + if( CellPtr ) + { + /* Copy memory including validation. */ + pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell) ); + *CellPtr++ = ((int32)CellPtr ^ PF_MEMORY_VALIDATOR); + M_PUSH( (cell) ++CellPtr ); + TOS = 0; + FreePtr[0] = 0xDeadBeef; + FreePtr[1] = 0xDeadBeef; + pfFreeMem((char *) FreePtr); + } + else + { + M_PUSH( 0 ); + 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)TORPTR; /* value before calling RP@ */ + endcase; + + case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */ + TORPTR = (cell *) TOS; + M_DROP; + endcase; + + case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */ + { + int32 ri; + cell *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 ) */ + { + int32 NameSize, CodeSize, EntryPoint; + CodeSize = TOS; + NameSize = M_POP; + EntryPoint = M_POP; + ForthStringToC( gScratch, (char *) M_POP ); + TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize ); + } + endcase; +#endif + +/* Source Stack +** EVALUATE >IN SourceID=(-1) 1111 +** keyboard >IN SourceID=(0) 2222 +** file >IN lineNumber filePos SourceID=(fileID) +*/ + case ID_SAVE_INPUT: /* FIXME - finish */ + { + } + endcase; + + case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */ + PUSH_TOS; + TOS = (cell)STKPTR; + endcase; + + case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */ + STKPTR = (cell *) 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_LONG_DIC((cell *)TOS,M_POP); + } + else + { + *((cell *)TOS) = M_POP; + } +#else + *((cell *)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) CharPtr); + endcase; + +#ifndef PF_NO_SHELL + case ID_SEMICOLON: + ffSemiColon( ); + 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) CharPtr); + endcase; + + case ID_SOURCE: /* ( -- c-addr num ) */ + PUSH_TOS; + M_PUSH( (cell) gCurrentTask->td_SourcePtr ); + TOS = (cell) 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)ffConvertSourceIDToStream( TOS ); + if( ffPushInputStream((FileStream *) TOS ) ) + { + M_QUIT; + TOUCH(TOS); + } + M_DROP; + 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; + +#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 ); + M_QUIT; + } + 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_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.Cell); 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_WORD: + TOS = (cell) 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) READ_SHORT_DIC((uint16 *)TOS); + } + else + { + TOS = *((uint16 *)TOS); + } +#else + TOS = *((uint16 *)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 *)TOS,(uint16)M_POP); + } + else + { + *((uint16 *)TOS) = (uint16) M_POP; + } +#else + *((uint16 *)TOS) = (uint16) 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("pfExecuteToken: Unrecognised token = 0x"); + ffDotHex(Token); + ERR(" at 0x"); + ffDotHex((int32) InsPtr); + EMIT_CR; + InsPtr = 0; + endcase; + } + + if(InsPtr) Token = READ_LONG_DIC(InsPtr++); /* Traverse to next token in secondary. */ + +#ifdef PF_DEBUG + M_DOTS; +#endif + + } while( (( InitialReturnStack - TORPTR) > 0 ) && (!CHECK_ABORT) ); + + SAVE_REGISTERS; +} diff --git a/csrc/pf_io.c b/csrc/pf_io.c new file mode 100644 index 0000000..da6e6a3 --- /dev/null +++ b/csrc/pf_io.c @@ -0,0 +1,211 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 941004 PLB Extracted IO calls from pforth_main.c +***************************************************************/ + +#include "pf_all.h" + +/*************************************************************** +** Send single character to output stream. +*/ +void ioEmit( char c ) +{ + int32 Result; + Result = sdTerminalOut(c); + + if( Result < 0 ) EXIT(1); + if(c == '\n') + { + gCurrentTask->td_OUT = 0; + sdTerminalFlush(); + } + else + { + gCurrentTask->td_OUT++; + } +} + +void ioType( const char *s, int32 n ) +{ + int32 i; + + for( i=0; i 0) + { + if( stream == PF_STDIN ) + { + c = ioKey(); +/* If KEY does not echo, then echo here. If using getchar(), KEY will echo. */ +#ifndef PF_KEY_ECHOS + ioEmit( c ); + if( c == '\r') ioEmit('\n'); /* Send LF after CR */ +#endif + } + else + { + c = sdInputChar(stream); + } + switch(c) + { + case EOF: + DBUG(("EOF\n")); + return -1; + break; + + case '\r': + case '\n': + *p++ = (char) c; + DBUGX(("EOL\n")); + goto gotline; + break; + + case BACKSPACE: + if( Len < MaxLen ) /* Don't go beyond beginning of line. */ + { + EMIT(' '); + EMIT(BACKSPACE); + p--; + Len++; + } + break; + + default: + *p++ = (char) c; + Len--; + break; + } + + } +gotline: + *p = '\0'; + + return pfCStringLength( Target ); +} + +#define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); } + +#ifdef PF_NO_CHARIO +int sdTerminalOut( char c ) +{ + TOUCH(c); + return 0; +} +int sdTerminalIn( void ) +{ + return -1; +} +int sdTerminalFlush( void ) +{ + return -1; +} +#endif + +/***********************************************************************************/ +#ifdef PF_NO_FILEIO + +/* Provide stubs for standard file I/O */ + +FileStream *PF_STDIN; +FileStream *PF_STDOUT; + +int32 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; +} +int32 sdFlushFile( FileStream * Stream ) +{ + TOUCH(Stream); + return 0; +} +int32 sdReadFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ) +{ + UNIMPLEMENTED("sdReadFile"); + TOUCH(ptr); + TOUCH(Size); + TOUCH(nItems); + TOUCH(Stream); + return 0; +} +int32 sdWriteFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ) +{ + UNIMPLEMENTED("sdWriteFile"); + TOUCH(ptr); + TOUCH(Size); + TOUCH(nItems); + TOUCH(Stream); + return 0; +} +int32 sdSeekFile( FileStream * Stream, int32 Position, int32 Mode ) +{ + UNIMPLEMENTED("sdSeekFile"); + TOUCH(Stream); + TOUCH(Position); + TOUCH(Mode); + return 0; +} +int32 sdTellFile( FileStream * Stream ) +{ + UNIMPLEMENTED("sdTellFile"); + TOUCH(Stream); + return 0; +} +int32 sdCloseFile( FileStream * Stream ) +{ + UNIMPLEMENTED("sdCloseFile"); + TOUCH(Stream); + return 0; +} +#endif + diff --git a/csrc/pf_io.h b/csrc/pf_io.h new file mode 100644 index 0000000..d07c0f6 --- /dev/null +++ b/csrc/pf_io.h @@ -0,0 +1,146 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef PF_NO_CHARIO + int sdTerminalOut( char c ); + int sdTerminalFlush( void ); + int sdTerminalIn( void ); + int sdQueryTerminal( 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 sdTerminalOut(c) putchar(c) + #define sdTerminalIn getchar +/* Since getchar() echos, define PF_KEY_ECHOS. */ + #define PF_KEY_ECHOS +/* + * If you know a way to implement ?TERMINAL in STANDARD ANSI 'C', + * please let me know. ?TERMINAL ( -- charAvailable? ) + */ + #define sdQueryTerminal() (0) + #ifdef PF_NO_FILEIO + #define sdTerminalFlush() /* fflush(PF_STDOUT) */ + #else + #define sdTerminalFlush() fflush(PF_STDOUT) + #endif + #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_CREATE ("w+") +#define PF_FAM_OPEN_RO ("r") +#define PF_FAM_OPEN_RW ("r+") + +#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 ); + int32 sdFlushFile( FileStream * Stream ); + int32 sdReadFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ); + int32 sdWriteFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ); + int32 sdSeekFile( FileStream * Stream, int32 Position, int32 Mode ); + int32 sdTellFile( FileStream * Stream ); + int32 sdCloseFile( FileStream * Stream ); + int32 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 sdFlushFile fflush + #define sdReadFile fread + #define sdWriteFile fwrite + #define sdSeekFile fseek + #define sdTellFile ftell + #define sdCloseFile fclose + #define sdInputChar fgetc + + #define PF_STDIN ((FileStream *) stdin) + #define PF_STDOUT ((FileStream *) stdout) + + #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) { printf x; sdFlushFile(PF_STDOUT); } + #endif + +#endif /* PF_NO_FILEIO */ + + +#ifdef __cplusplus +extern "C" { +#endif + +cell ioAccept( char *Target, cell n1, FileStream *Stream ); +cell ioKey( void); +void ioEmit( char c ); +void ioType( const char *s, int32 n); + +#ifdef __cplusplus +} +#endif + +#endif /* _pf_io_h */ diff --git a/csrc/pf_mac.h b/csrc/pf_mac.h new file mode 100644 index 0000000..80e9188 --- /dev/null +++ b/csrc/pf_mac.h @@ -0,0 +1,39 @@ +/* @(#) pf_mac.h 98/01/26 1.2 */ +#ifndef _pf_mac_h +#define _pf_mac_h + +/*************************************************************** +** Macintosh dependant include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#include +#include + +#include +#include + + +#ifdef PF_SUPPORT_FP + #include + + #ifndef PF_USER_FP + #include "pf_float.h" + #else + #include PF_USER_FP + #endif +#endif + +#endif /* _pf_mac_h */ diff --git a/csrc/pf_main.c b/csrc/pf_main.c new file mode 100644 index 0000000..e834f14 --- /dev/null +++ b/csrc/pf_main.c @@ -0,0 +1,102 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef PF_NO_STDIO + #define NULL ((void *) 0) + #define ERR(msg) /* { printf msg; } */ +#else + #include + #define ERR(msg) { printf msg; } +#endif + +#include "pforth.h" + +#ifdef __MWERKS__ + #include + #include +#endif + +#ifndef TRUE +#define TRUE (1) +#define FALSE (0) +#endif + +int main( int argc, char **argv ) +{ + const char *DicName = "pforth.dic"; + const char *SourceName = NULL; + char IfInit = FALSE; + char *s; + int32 i; + int Result; + +/* For Metroworks on Mac */ + #ifdef __MWERKS__ + argc = ccommand(&argv); + #endif + +/* Parse command line. */ + for( i=1; idlln_Previous) +#define dllNextNode(n) ((n)->dlln_Next) + +void dllSetupList( DoublyLinkedList *dll ) +{ + dll->dll_First = (DoublyLinkedListNode *) &(dll->dll_Null); + dll->dll_Null = (DoublyLinkedListNode *) NULL; + dll->dll_Last = (DoublyLinkedListNode *) &(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 ) )); +} + +int32 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; +static int32 gIfMemListInit; + +typedef struct MemListNode +{ + DoublyLinkedListNode mln_Node; + int32 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, int32 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( ( ((int32)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0) + { + MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (int32) 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. +*/ +void pfInitMemAllocator( void *addr, uint32 poolSize ) +{ + char *AlignedMemory; + int32 AlignedSize; + +/* Set globals. */ + gMemPoolPtr = addr; + gMemPoolSize = poolSize; + + dllSetupList( &gMemList ); + gIfMemListInit = TRUE; + +/* Adjust to next highest aligned memory location. */ + AlignedMemory = (char *) ((((int32)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( int32 NumBytes ) +{ + char *Mem = NULL; + MemListNode *mln; + + if( NumBytes <= 0 ) return NULL; + + if( gIfMemListInit == 0 ) pfInitMemAllocator( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE ); + +/* 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 ) + { + int32 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( int32 NumBytes ) +{ + int32 *IntMem; + + if( NumBytes <= 0 ) return NULL; + +/* Allocate an extra cell for size. */ + NumBytes += sizeof(int32); + + IntMem = (int32 *)pfAllocRawMem( NumBytes ); + + if( IntMem != NULL ) *IntMem++ = NumBytes; + + return (char *) IntMem; +} + +/*************************************************************** +** Free mem with mem size at first cell. +*/ +void pfFreeMem( void *Mem ) +{ + int32 *IntMem; + int32 NumBytes; + + if( Mem == NULL ) return; + +/* Allocate an extra cell for size. */ + IntMem = (int32 *) Mem; + IntMem--; + NumBytes = *IntMem; + + pfFreeRawMem( (char *) IntMem, NumBytes ); + +} + +#endif /* PF_NO_MALLOC */ diff --git a/csrc/pf_mem.h b/csrc/pf_mem.h new file mode 100644 index 0000000..dabacfe --- /dev/null +++ b/csrc/pf_mem.h @@ -0,0 +1,46 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +***************************************************************/ + +#ifdef PF_NO_MALLOC + + #ifdef __cplusplus + extern "C" { + #endif + + void pfInitMemAllocator( void *addr, uint32 poolSize ); + char *pfAllocMem( int32 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 pfAllocMem malloc + #define pfFreeMem free + #endif + +#endif /* PF_NO_MALLOC */ + +#endif /* _pf_mem_h */ diff --git a/csrc/pf_save.c b/csrc/pf_save.c new file mode 100644 index 0000000..c330b4f --- /dev/null +++ b/csrc/pf_save.c @@ -0,0 +1,726 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 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 +***************************************************************/ + +#include "pf_all.h" + +int IsHostLittleEndian( void ); + +/* If no File I/O, then force static dictionary. */ +#ifdef PF_NO_FILEIO + #ifndef PF_STATIC_DIC + #define PF_STATIC_DIC + #endif +#endif + +#if 0 +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) +#endif + + +/***************************************************************/ +/* Endian-ness tools. */ +uint32 ReadLongBigEndian( const uint32 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (bp[0]<<24) | (bp[1]<<16) | (bp[2]<<8) | bp[3]; +} +/***************************************************************/ +uint16 ReadShortBigEndian( const uint16 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (uint16) ((bp[0]<<8) | bp[1]); +} + +/***************************************************************/ +uint32 ReadLongLittleEndian( const uint32 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (bp[3]<<24) | (bp[2]<<16) | (bp[1]<<8) | bp[0]; +} +/***************************************************************/ +uint16 ReadShortLittleEndian( const uint16 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (uint16) ((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>24); + bp[1] = (unsigned char) (data>>16); + bp[2] = (unsigned char) (data>>8); + bp[3] = (unsigned char) (data); +} + +/***************************************************************/ +void WriteShortBigEndian( uint16 *addr, uint16 data ) +{ + unsigned char *bp = (unsigned char *) addr; + + bp[0] = (unsigned char) (data>>8); + bp[1] = (unsigned char) (data); +} + +/***************************************************************/ +void WriteLongLittleEndian( uint32 *addr, uint32 data ) +{ + unsigned char *bp = (unsigned char *) addr; + + bp[0] = (unsigned char) (data); + bp[1] = (unsigned char) (data>>8); + bp[2] = (unsigned char) (data>>16); + bp[3] = (unsigned char) (data>>24); +} +/***************************************************************/ +void WriteShortLittleEndian( uint16 *addr, uint16 data ) +{ + unsigned char *bp = (unsigned char *) addr; + + bp[0] = (unsigned char) (data); + bp[1] = (unsigned char) (data>>8); +} + +/***************************************************************/ +/* Return 1 if host CPU is Little Endian */ +int IsHostLittleEndian( void ) +{ + uint16 gEndianCheck = 1; + unsigned char *bp = (unsigned char *) &gEndianCheck; + return *bp; /* Return byte pointed to by address. If LSB then == 1 */ +} + +#ifndef PF_STATIC_DIC + +#ifndef PF_NO_SHELL +/***************************************************************/ +static int32 WriteLong( FileStream *fid, int32 Val ) +{ + int32 numw; + uint32 pad; + + WriteLongBigEndian(&pad,Val); + numw = sdWriteFile( (char *) &pad, 1, sizeof(int32), fid ); + if( numw != sizeof(int32) ) return -1; + return 0; +} + +/***************************************************************/ +static int32 WriteChunk( FileStream *fid, int32 ID, char *Data, int32 NumBytes ) +{ + int32 numw; + int32 EvenNumW; + + EvenNumW = EVENUP(NumBytes); + + if( WriteLong( fid, ID ) < 0 ) goto error; + if( WriteLong( fid, EvenNumW ) < 0 ) goto error; + + numw = sdWriteFile( Data, 1, EvenNumW, fid ); + if( numw != EvenNumW ) goto error; + return 0; +error: + pfReportError("WriteChunk", PF_ERR_WRITE_FILE); + return -1; +} + +/**************************************************************** +** Save Dictionary in File. +** If EntryPoint is NULL, save as development environment. +** If EntryPoint is non-NULL, save as turnKey environment with no names. +*/ +int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize) +{ + FileStream *fid; + DictionaryInfoChunk SD; + int32 FormSize; + int32 NameChunkSize = 0; + int32 CodeChunkSize; + uint32 rhp, rcp; + uint32 *p; + int i; + + fid = sdOpenFile( FileName, "wb" ); + if( fid == NULL ) + { + pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE); + return -1; + } + +/* Save in uninitialized form. */ + pfExecByName("AUTO.TERM"); + +/* Write FORM Header ---------------------------- */ + if( WriteLong( fid, ID_FORM ) < 0 ) goto error; + if( WriteLong( fid, 0 ) < 0 ) goto error; + if( WriteLong( fid, ID_P4TH ) < 0 ) goto error; + +/* Write P4DI Dictionary Info ------------------ */ + SD.sd_Version = PF_FILE_VERSION; + + rcp = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */ + SD.sd_RelCodePtr = rcp; + SD.sd_UserStackSize = sizeof(cell) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit); + SD.sd_ReturnStackSize = sizeof(cell) * (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_Reserved = 0; + +/* Set bit that specifiec 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 + { +/* Development mode. */ + SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext); + rhp = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr.Byte); + SD.sd_RelHeaderPtr = rhp; + +/* How much real name space is there? */ + NameChunkSize = QUADUP(rhp); /* Align */ + +/* NameSize must be 0 or greater than NameChunkSize + 1K */ + NameSize = QUADUP(NameSize); /* Align */ + if( NameSize > 0 ) + { + NameSize = MAX( NameSize, (NameChunkSize + 1024) ); + } + SD.sd_NameSize = NameSize; + } + +/* How much real code is there? */ + CodeChunkSize = QUADUP(rcp); + CodeSize = QUADUP(CodeSize); /* Align */ + CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) ); + SD.sd_CodeSize = CodeSize; + + +/* Convert all fields in structure from Native to BigEndian. */ + p = (uint32 *) &SD; + for( i=0; i<((int)(sizeof(SD)/sizeof(int32))); i++ ) + { + WriteLongBigEndian( &p[i], p[i] ); + } + + if( WriteChunk( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error; + +/* Write Name Fields if NameSize non-zero ------- */ + if( NameSize > 0 ) + { + if( WriteChunk( fid, ID_P4NM, (char *) NAME_BASE, + NameChunkSize ) < 0 ) goto error; + } + +/* Write Code Fields ---------------------------- */ + if( WriteChunk( fid, ID_P4CD, (char *) CODE_BASE, + CodeChunkSize ) < 0 ) goto error; + + FormSize = sdTellFile( fid ) - 8; + sdSeekFile( fid, 4, PF_SEEK_SET ); + if( WriteLong( fid, FormSize ) < 0 ) goto error; + + sdCloseFile( fid ); + + + +/* Restore initialization. */ + + pfExecByName("AUTO.INIT"); + + return 0; + +error: + sdSeekFile( fid, 0, PF_SEEK_SET ); + WriteLong( fid, ID_BADF ); /* Mark file as bad. */ + sdCloseFile( fid ); + +/* Restore initialization. */ + + pfExecByName("AUTO.INIT"); + + return -1; +} +#endif /* !PF_NO_SHELL */ + +/***************************************************************/ +static int32 ReadLong( FileStream *fid, int32 *ValPtr ) +{ + int32 numr; + uint32 temp; + + numr = sdReadFile( &temp, 1, sizeof(int32), fid ); + if( numr != sizeof(int32) ) return -1; + *ValPtr = ReadLongBigEndian( &temp ); + return 0; +} + +/***************************************************************/ +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) +{ + cfDictionary *dic = NULL; + FileStream *fid; + DictionaryInfoChunk *sd; + int32 ChunkID; + int32 ChunkSize; + int32 FormSize; + int32 BytesLeft; + int32 numr; + uint32 *p; + int i; + 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 (ReadLong( fid, &ChunkID ) < 0) goto read_error; + if( ChunkID != ID_FORM ) + { + pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE); + goto error; + } + + if (ReadLong( fid, &FormSize ) < 0) goto read_error; + BytesLeft = FormSize; + + if (ReadLong( 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 (ReadLong( fid, &ChunkID ) < 0) goto read_error; + if (ReadLong( fid, &ChunkSize ) < 0) goto read_error; + BytesLeft -= 8; + + DBUG(("ChunkID = %4s, Size = %d\n", &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; + +/* Convert all fields in structure from BigEndian to Native. */ + p = (uint32 *) sd; + for( i=0; i<((int)(sizeof(*sd)/sizeof(int32))); i++ ) + { + p[i] = ReadLongBigEndian( &p[i] ); + } + + 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( (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_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 = (char *) NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */ + gCurrentDictionary->dic_HeaderPtr.Byte = (uint8 *) + NAMEREL_TO_ABS(sd->sd_RelHeaderPtr); + } + else + { + gVarContext = 0; + gCurrentDictionary->dic_HeaderPtr.Byte = NULL; + } + gCurrentDictionary->dic_CodePtr.Byte = (uint8 *) 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 == NULL ) + { + 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( 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( 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 != NULL) + { + int32 Result; +/* Find special words in dictionary for global XTs. */ + if( (Result = FindSpecialXTs()) < 0 ) + { + pfReportError("pfLoadDictionary: FindSpecialXTs", Result); + goto error; + } + } + +DBUG(("pfLoadDictionary: return 0x%x\n", dic)); + return 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 /* PF_STATIC_DIC ============================================== */ + +/* +** Dictionary must come from data array because there is no file I/O. +*/ +#ifndef HEADERPTR + #include "pfdicdat.h" +#endif + +int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize) +{ + TOUCH(FileName); + TOUCH(EntryPoint); + TOUCH(NameSize); + TOUCH(CodeSize); + + pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED); + return -1; +} + + +/***************************************************************/ +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) +{ + cfDictionary *dic; + int32 Result; + int32 NewNameSize, NewCodeSize; + +MSG("pfLoadDictionary - Filename ignored! Loading from static data.\n"); + + TOUCH(FileName); + TOUCH(EntryPointPtr); + +/* 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 + if( IF_LITTLE_ENDIAN != IsHostLittleEndian() ) +#endif + { + pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT ); + goto error; + } + +/* Static data too small. Copy it to larger array. */ +#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; + + gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize ); + if( !dic ) goto nomem_error; + + pfCopyMemory( dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) ); + pfCopyMemory( dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) ); + MSG("Static data copied to newly allocated dictionaries.\n"); + + dic->dic_CodePtr.Byte = (uint8 *) CODEREL_TO_ABS(CODEPTR); + gNumPrimitives = NUM_PRIMITIVES; + + if( NAME_BASE != NULL) + { +/* Setup name space. */ + dic->dic_HeaderPtr.Byte = (uint8 *) NAMEREL_TO_ABS(HEADERPTR); + gVarContext = (char *) NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */ + +/* Find special words in dictionary for global XTs. */ + if( (Result = FindSpecialXTs()) < 0 ) + { + pfReportError("pfLoadDictionary: FindSpecialXTs", Result); + goto error; + } + } + + return dic; + +error: + pfReportError("pfLoadDictionary", -1); + return NULL; + +nomem_error: + pfReportError("pfLoadDictionary", PF_ERR_NO_MEM); + return NULL; +} + + +#endif /* PF_STATIC_DIC */ diff --git a/csrc/pf_save.h b/csrc/pf_save.h new file mode 100644 index 0000000..d5e21ce --- /dev/null +++ b/csrc/pf_save.h @@ -0,0 +1,90 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** 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 fileds must be the same size as int32 for easy endian conversion. */ + int32 sd_Version; + int32 sd_RelContext; /* relative ptr to Dictionary Context */ + int32 sd_RelHeaderPtr; /* relative ptr to Dictionary Header Ptr */ + int32 sd_RelCodePtr; /* relative ptr to Dictionary Header Ptr */ + ExecToken sd_EntryPoint; /* relative ptr to entry point or NULL */ + int32 sd_UserStackSize; /* in bytes */ + int32 sd_ReturnStackSize; /* in bytes */ + int32 sd_NameSize; /* in bytes */ + int32 sd_CodeSize; /* in bytes */ + int32 sd_NumPrimitives; /* To distinguish between primitive and secondary. */ + uint32 sd_Flags; + int32 sd_FloatSize; /* In bytes. Must match code. 0 means no floats. */ + uint32 sd_Reserved; +} DictionaryInfoChunk; + +/* Bits in sd_Flags */ +#define SD_F_BIG_ENDIAN_DIC (1<<0) + +#ifndef MAKE_ID +#define MAKE_ID(a,b,c,d) ((a<<24)|(b<<16)|(c<<8)|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 + +int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize ); +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); + +/* Endian-ness tools. */ +uint32 ReadLongBigEndian( const uint32 *addr ); +uint16 ReadShortBigEndian( const uint16 *addr ); +uint32 ReadLongLittleEndian( const uint32 *addr ); +uint16 ReadShortLittleEndian( const uint16 *addr ); +void WriteLongBigEndian( uint32 *addr, uint32 data ); +void WriteShortBigEndian( uint16 *addr, uint16 data ); +void WriteLongLittleEndian( uint32 *addr, uint32 data ); +void WriteShortLittleEndian( uint16 *addr, uint16 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 */ diff --git a/csrc/pf_text.c b/csrc/pf_text.c new file mode 100644 index 0000000..51d0610 --- /dev/null +++ b/csrc/pf_text.c @@ -0,0 +1,297 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 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_BAD_ADDR & 0xFF: + s = "address misaligned"; 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; + default: + s = "unrecognized error code!"; break; + } + MSG(s); + EMIT_CR; +} +#endif + +/************************************************************** +** Copy a Forth String to a 'C' string. +*/ + +char *ForthStringToC( char *dst, const char *FString ) +{ + int32 Len; + + Len = (int32) *FString; + 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 ) +{ + char *s; + int32 i; + + s = dst+1; + for( i=0; *CString; i++ ) + { + *s++ = *CString++; + } + *dst = (char ) i; + return dst; +} + +/************************************************************** +** Compare two test strings, case sensitive. +** Return TRUE if they match. +*/ +int32 ffCompareText( const char *s1, const char *s2, int32 len ) +{ + int32 i, Result; + + Result = TRUE; + for( i=0; is2; +*/ +int32 ffCompare( const char *s1, int32 len1, const char *s2, int32 len2 ) +{ + int32 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(int32)*8)+2) /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */ +static char cnttPad[CNTT_PAD_SIZE]; + +char *ConvertNumberToText( int32 Num, int32 Base, int32 IfSigned, int32 MinChars ) +{ + int32 IfNegative = 0; + char *p,c; + uint32 NewNum, Rem, uNum; + int32 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; + int32 Len; + + FirstChar = Name+1; + Len = *Name & 0x1F; + + ioType( FirstChar, Len ); +} + diff --git a/csrc/pf_text.h b/csrc/pf_text.h new file mode 100644 index 0000000..7ea2378 --- /dev/null +++ b/csrc/pf_text.h @@ -0,0 +1,68 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#define PF_ERR_INDEX_MASK (0xFFFF) +#define PF_ERR_BASE (0x80000000) +#define PF_ERR_NO_MEM (PF_ERR_BASE | 0) +#define PF_ERR_BAD_ADDR (PF_ERR_BASE | 1) +#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) +/* 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 ); + +char *ForthStringToC( char *dst, const char *FString ); +char *CStringToForth( char *dst, const char *CString ); + +int32 ffCompare( const char *s1, int32 len1, const char *s2, int32 len2 ); +int32 ffCompareText( const char *s1, const char *s2, int32 len ); +int32 ffCompareTextCaseN( const char *s1, const char *s2, int32 len ); + +void DumpMemory( void *addr, int32 cnt); +char *ConvertNumberToText( int32 Num, int32 Base, int32 IfSigned, int32 MinChars ); +void TypeName( const char *Name ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_text_h */ diff --git a/csrc/pf_types.h b/csrc/pf_types.h new file mode 100644 index 0000000..e727e41 --- /dev/null +++ b/csrc/pf_types.h @@ -0,0 +1,58 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/*************************************************************** +** Type Declarations +***************************************************************/ + +#ifndef int32 + typedef signed long int32; +#endif +#ifndef uint32 + typedef unsigned long uint32; +#endif +#ifndef int16 + typedef signed short int16; +#endif +#ifndef uint16 + typedef unsigned short uint16; +#endif +#ifndef int8 + typedef signed char int8; +#endif +#ifndef uint8 + typedef unsigned char uint8; +#endif +#ifndef Err + typedef long Err; +#endif + +typedef uint32 ExecToken; /* Execution Token */ +typedef int32 cell; +typedef uint32 ucell; +typedef cell *dicptr; + +typedef char ForthString; +typedef char *ForthStringPtr; + + + +#endif /* _pf_types_h */ diff --git a/csrc/pf_unix.h b/csrc/pf_unix.h new file mode 100644 index 0000000..67fbf36 --- /dev/null +++ b/csrc/pf_unix.h @@ -0,0 +1,41 @@ +/* @(#) pf_unix.h 98/01/28 1.4 */ +#ifndef _pf_unix_h +#define _pf_unix_h + +/*************************************************************** +** UNIX dependant include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#include + +#ifndef PF_NO_CLIB + #include /* Needed for strlen(), memcpy(), and memset(). */ + #include /* Needed for exit(). */ +#endif + +#include /* Needed for FILE and getc(). */ + +#ifdef PF_SUPPORT_FP + #include + + #ifndef PF_USER_FP + #include "pf_float.h" + #else + #include PF_USER_FP + #endif +#endif + +#endif /* _pf_unix_h */ diff --git a/csrc/pf_win32.h b/csrc/pf_win32.h new file mode 100644 index 0000000..e42e65d --- /dev/null +++ b/csrc/pf_win32.h @@ -0,0 +1,40 @@ +/* @(#) pf_win32.h 98/01/26 1.2 */ +#ifndef _pf_win32_h +#define _pf_win32_h + +/*************************************************************** +** WIN32 dependant include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/* Include 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+") + +#define LITTLE_ENDIAN + +#endif /* _pf_win32_h */ diff --git a/csrc/pf_words.c b/csrc/pf_words.c new file mode 100644 index 0000000..b385861 --- /dev/null +++ b/csrc/pf_words.c @@ -0,0 +1,223 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** +** 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( int32 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( int32 n ) +{ + MSG( ConvertNumberToText( n, 16, FALSE, 1 ) ); + EMIT(' '); +} + +/* ( ... --- ... , print stack ) */ +void ffDotS( void ) +{ + cell *sp; + int32 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 ffScan( char *AddrIn, cell 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 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 ffNumberQ( const char *FWord, cell *Num ) +{ + int32 Len, i, Accum=0, n, Sign=1; + const char *s; + +/* get count */ + Len = *FWord++; + s = FWord; + +/* process initial minus sign */ + if( *s == '-' ) + { + Sign = -1; + s++; + Len--; + } + + for( i=0; i= gVarBase) ) + { + return NUM_TYPE_BAD; + } + + Accum = (Accum * gVarBase) + n; + } + *Num = Accum * Sign; + return NUM_TYPE_SINGLE; +} + +/*************************************************************** +** Compiler Support +***************************************************************/ + +/* ( char -- c-addr , parse word ) */ +char * ffWord( char c ) +{ + char *s1,*s2,*s3; + int32 n1, n2, n3; + int32 i, nc; + + s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN; + n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN; + n2 = ffSkip( s1, n1, c, &s2 ); +DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 )); + n3 = ffScan( s2, n2, c, &s3 ); +DBUGX(("ffWord: 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]; +} diff --git a/csrc/pf_words.h b/csrc/pf_words.h new file mode 100644 index 0000000..48729dc --- /dev/null +++ b/csrc/pf_words.h @@ -0,0 +1,36 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +void ffDot( int32 n ); +void ffDotHex( int32 n ); +void ffDotS( void ); +cell ffSkip( char *AddrIn, cell Cnt, char c, char **AddrOut ); +cell ffScan( char *AddrIn, cell Cnt, char c, char **AddrOut ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_words_h */ diff --git a/csrc/pfcompfp.h b/csrc/pfcompfp.h new file mode 100644 index 0000000..1e5b773 --- /dev/null +++ b/csrc/pfcompfp.h @@ -0,0 +1,78 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +***************************************************************/ + + +#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", 0 ); + 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 diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c new file mode 100644 index 0000000..5bbb218 --- /dev/null +++ b/csrc/pfcompil.c @@ -0,0 +1,1104 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 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) + +/***************************************************************/ +/************** GLOBAL DATA ************************************/ +/***************************************************************/ +/* data for INCLUDE that allows multiple nested files. */ +static IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH]; +static int32 gIncludeIndex; + +static ExecToken gNumberQ_XT; /* XT of NUMBER? */ +static ExecToken gQuitP_XT; /* XT of (QUIT) */ + +/***************************************************************/ +/************** Static Prototypes ******************************/ +/***************************************************************/ + +static void ffStringColon( const ForthStringPtr FName ); +static int32 CheckRedefinition( const ForthStringPtr FName ); +static void ReportIncludeState( void ); +static void ffUnSmudge( void ); +static void FindAndCompile( const char *theWord ); +static int32 ffCheckDicRoom( void ); +static void ffCleanIncludeStack( void ); + +#ifndef PF_NO_INIT + static void CreateDeferredC( ExecToken DefaultXT, const char *CName ); +#endif + +int32 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, uint32 Flags ) +{ + cfNameLinks *cfnl; + + cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr.Byte; + +/* Set link to previous header, if any. */ + if( gVarContext ) + { + WRITE_LONG_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) ); + } + else + { + cfnl->cfnl_PreviousName = 0; + } + +/* Put Execution token in header. */ + WRITE_LONG_DIC( &cfnl->cfnl_ExecToken, XT ); + +/* Advance Header Dictionary Pointer */ + gCurrentDictionary->dic_HeaderPtr.Byte += sizeof(cfNameLinks); + +/* Laydown name. */ + gVarContext = (char *) gCurrentDictionary->dic_HeaderPtr.Byte; + pfCopyMemory( gCurrentDictionary->dic_HeaderPtr.Byte, FName, (*FName)+1 ); + gCurrentDictionary->dic_HeaderPtr.Byte += (*FName)+1; + +/* Set flags. */ + *gVarContext |= (char) Flags; + +/* Align to quad byte boundaries with zeroes. */ + while( ((uint32) gCurrentDictionary->dic_HeaderPtr.Byte) & 3) + { + *gCurrentDictionary->dic_HeaderPtr.Byte++ = 0; + } +} + +/*************************************************************** +** Convert name then create dictionary entry. +*/ +void CreateDicEntryC( ExecToken XT, const char *CName, uint32 Flags ) +{ + ForthString FName[40]; + CStringToForth( FName, CName ); + CreateDicEntry( XT, FName, Flags ); +} + +/*************************************************************** +** Convert absolute namefield address to previous absolute name +** field address or NULL. +*/ +const ForthString *NameToPrevious( const ForthString *NFA ) +{ + cell RelNamePtr; + const cfNameLinks *cfnl; + +/* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (int32) NFA)); */ + cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) ); + + RelNamePtr = READ_LONG_DIC((const cell *) (&cfnl->cfnl_PreviousName)); +/* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (int32) RelNamePtr )); */ + if( RelNamePtr ) + { + return ( 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_LONG_DIC((const cell *) (&cfnl->cfnl_ExecToken)); +} + +/*************************************************************** +** Find XTs needed by compiler. +*/ +int32 FindSpecialXTs( void ) +{ + + if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind; + if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind; +DBUG(("gNumberQ_XT = 0x%x\n", gNumberQ_XT )); + return 0; + +nofind: + ERR("FindSpecialXTs failed!\n"); + return -1; +} + +/*************************************************************** +** Build a dictionary from scratch. +*/ +#ifndef PF_NO_INIT +cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ) +{ + cfDictionary *dic; + + dic = pfCreateDictionary( HeaderSize, CodeSize ); + if( !dic ) goto nomem; + + gCurrentDictionary = dic; + gNumPrimitives = NUM_PRIMITIVES; + + CreateDicEntryC( ID_EXIT, "EXIT", 0 ); + CreateDicEntryC( ID_1MINUS, "1-", 0 ); + 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, "ACCEPT", 0 ); + CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE ); + CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 ); + CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 ); + 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_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 ); + 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 ); + CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 ); + CreateDicEntryC( ID_DEFER, "DEFER", 0 ); + CreateDicEntryC( ID_CSTORE, "C!", 0 ); + CreateDicEntryC( ID_DEPTH, "DEPTH", 0 ); + CreateDicEntryC( ID_DIVIDE, "/", 0 ); + CreateDicEntryC( ID_DOT, ".", 0 ); + CreateDicEntryC( ID_DOTS, ".S", 0 ); + 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 ); + CreateDeferredC( ID_EMIT_P, "EMIT"); + 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_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_RO, "R/O", 0 ); + CreateDicEntryC( ID_FILE_RW, "R/W", 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_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 ); + 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_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_SWAP, "SWAP", 0 ); + CreateDicEntryC( ID_TEST1, "TEST1", 0 ); + CreateDicEntryC( ID_TICK, "'", 0 ); + CreateDicEntryC( ID_TIMES, "*", 0 ); + CreateDicEntryC( ID_TO_R, ">R", 0 ); + CreateDicEntryC( ID_TYPE, "TYPE", 0 ); + CreateDicEntryC( ID_VAR_BASE, "BASE", 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_VLIST, "VLIST", 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 ); + + 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 + + return dic; + +error: + 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 ffTokenToName( ExecToken XT, const ForthString **NFAPtr ) +{ + const ForthString *NameField; + int32 Searching = TRUE; + cell Result = 0; + ExecToken TempXT; + + NameField = 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 ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) +{ + const ForthString *WordChar; + uint8 WordLen; + const char *NameField, *NameChar; + int8 NameLen; + int32 Searching = TRUE; + cell Result = 0; + + WordLen = (uint8) ((uint32)*WordName & 0x1F); + WordChar = WordName+1; + + NameField = gVarContext; +DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar )); +DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext)); + do + { + NameLen = (uint8) ((uint32)(*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 ffFind( const ForthString *WordName, ExecToken *pXT ) +{ + const ForthString *NFA; + int32 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 ffFindC( const char *WordName, ExecToken *pXT ) +{ +DBUG(("ffFindC: %s\n", WordName )); + CStringToForth( gScratch, WordName ); + return ffFind( gScratch, pXT ); +} + + +/***********************************************************/ +/********* Compiling New Words *****************************/ +/***********************************************************/ +#define DIC_SAFETY_MARGIN (400) + +/************************************************************* +** Check for dictionary overflow. +*/ +static int32 ffCheckDicRoom( void ) +{ + int32 RoomLeft; + RoomLeft = gCurrentDictionary->dic_HeaderLimit - + gCurrentDictionary->dic_HeaderPtr.Byte; + if( RoomLeft < DIC_SAFETY_MARGIN ) + { + pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM); + return PF_ERR_HEADER_ROOM; + } + + RoomLeft = gCurrentDictionary->dic_CodeLimit - + 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) +{ +/* Check for dictionary overflow. */ + if( ffCheckDicRoom() ) return; + + CheckRedefinition( FName ); +/* Align CODE_HERE */ + CODE_HERE = (cell *)( (((uint32)CODE_HERE) + 3) & ~3); + CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE ); +DBUG(("ffCreateSecondaryHeader, XT = 0x%x, Name = %8s\n")); +} + +/************************************************************* +** 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 int32 CheckRedefinition( const ForthStringPtr FName ) +{ + int32 Flag; + ExecToken XT; + + Flag = ffFind( FName, &XT); + if( Flag ) + { + ioType( FName+1, (int32) *FName ); + MSG( " already defined.\n" ); + } + 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 ) +{ + + 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 ); + 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. */ +void ffUnSmudge( void ) +{ + *gVarContext &= ~FLAG_SMUDGE; +} + +/* Implement ; */ +void ffSemiColon( void ) +{ + gVarState = 0; + + if( (gDepthAtColon != DATA_STACK_DEPTH) && + (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */ + { + pfReportError("ffSemiColon", PF_ERR_COLON_STACK); + ffAbort(); + } + else + { + ffFinishSecondary(); + } + gDepthAtColon = DEPTH_AT_COLON_INVALID; +} + +/* 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 dHi, cell dLo ) +{ + CODE_COMMA( ID_2LITERAL_P ); + CODE_COMMA( dHi ); + CODE_COMMA( dLo ); +} +void ffALiteral( cell Num ) +{ + CODE_COMMA( ID_ALITERAL_P ); + CODE_COMMA( Num ); +} +void ffLiteral( cell Num ) +{ + CODE_COMMA( ID_LITERAL_P ); + CODE_COMMA( Num ); +} + +#ifdef PF_SUPPORT_FP +void ffFPLiteral( PF_FLOAT fnum ) +{ + /* Hack for Metrowerks complier which won't compile the + * original expression. + */ + PF_FLOAT *temp; + cell *dicPtr; + +/* Make sure that literal float data is float aligned. */ + dicPtr = CODE_HERE + 1; + while( (((uint32) 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 *) temp; +} +#endif /* PF_SUPPORT_FP */ + +/**************************************************************/ +void FindAndCompile( const char *theWord ) +{ + int32 Flag; + ExecToken XT; + cell Num; + + 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 + { + pfExecuteToken( XT ); + } + } + else if ( Flag == 1 ) /* or is it IMMEDIATE ? */ + { +DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord )); + pfExecuteToken( XT ); + } + else /* try to interpret it as a number. */ + { +/* Call deferred NUMBER? */ + int32 NumResult; + +DBUG(("FindAndCompile: not found, try number?\n" )); + PUSH_DATA_STACK( theWord ); /* Push text of number */ + pfExecuteToken( gNumberQ_XT ); +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" ); + ffAbort( ); + break; + + } + } +} +/************************************************************** +** Forth outer interpreter. Parses words from Source. +** Executes them or compiles them based on STATE. +*/ +int32 ffInterpret( void ) +{ + int32 Flag; + char *theWord; + +/* Is there any text left in Source ? */ + while( (gCurrentTask->td_IN < (gCurrentTask->td_SourceNum-1) ) && + !CHECK_ABORT) + { +DBUGX(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN, + gCurrentTask->td_SourceNum ) ); + theWord = ffWord( BLANK ); +DBUGX(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord )); + if( *theWord > 0 ) + { + Flag = 0; + if( gLocalCompiler_XT ) + { + PUSH_DATA_STACK( theWord ); /* Push word. */ + pfExecuteToken( gLocalCompiler_XT ); + Flag = POP_DATA_STACK; /* Compiled local? */ + } + if( Flag == 0 ) + { + FindAndCompile( theWord ); + } + } + } + DBUG(("ffInterpret: CHECK_ABORT = %d\n", CHECK_ABORT)); + return( CHECK_ABORT ? -1 : 0 ); +} + +/**************************************************************/ +void ffOK( void ) +{ +/* Check for stack underflow. %Q what about overflows? */ + if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 ) + { + MSG("Stack underflow!\n"); + ResetForthTask( ); + } +#ifdef PF_SUPPORT_FP /* Check floating point stack too! */ + else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0) + { + MSG("FP stack underflow!\n"); + ResetForthTask( ); + } +#endif + else if( gCurrentTask->td_InputStream == PF_STDIN) + { + if( !gVarState ) /* executing? */ + { + if( !gVarQuiet ) + { + MSG( " ok\n" ); + if(gVarTraceStack) ffDotS(); + } + else + { + EMIT_CR; + } + } + } +} + +/*************************************************************** +** Report state of include stack. +***************************************************************/ +static void ReportIncludeState( void ) +{ + int32 i; +/* If not INCLUDing, just return. */ + if( gIncludeIndex == 0 ) return; + +/* Report line number and nesting level. */ + MSG_NUM_D("INCLUDE error on line #", gCurrentTask->td_LineNumber ); + MSG_NUM_D("INCLUDE nesting level = ", gIncludeIndex ); + +/* Dump line of error and show offset in line for >IN */ + MSG( gCurrentTask->td_SourcePtr ); + for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^'); + EMIT_CR; +} + + +/*************************************************************** +** Interpret input in a loop. +***************************************************************/ +void ffQuit( void ) +{ + gCurrentTask->td_Flags |= CFTD_FLAG_GO; + + while( gCurrentTask->td_Flags & CFTD_FLAG_GO ) + { + if(!ffRefill()) + { +/* gCurrentTask->td_Flags &= ~CFTD_FLAG_GO; */ + return; + } + ffInterpret(); + DBUG(("gCurrentTask->td_Flags = 0x%x\n", gCurrentTask->td_Flags)); + if(CHECK_ABORT) + { + CLEAR_ABORT; + } + else + { + ffOK( ); + } + } +} + +/*************************************************************** +** Include a file +***************************************************************/ + +cell ffIncludeFile( FileStream *InputFile ) +{ + cell Result; + +/* Push file stream. */ + Result = ffPushInputStream( InputFile ); + if( Result < 0 ) return Result; + +/* Run outer interpreter for stream. */ + ffQuit(); + +/* Pop file stream. */ + ffPopInputStream(); + + return gVarReturnCode; +} + +#endif /* !PF_NO_SHELL */ + +/*************************************************************** +** Save current input stream on stack, use this new one. +***************************************************************/ +Err ffPushInputStream( FileStream *InputFile ) +{ + cell 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 ffConvertStreamToSourceID( FileStream *Stream ) +{ + cell Result; + if(Stream == PF_STDIN) + { + Result = 0; + } + else if(Stream == NULL) + { + Result = -1; + } + else + { + Result = (cell) Stream; + } + return Result; +} + +/*************************************************************** +** Convert file pointer to value consistent with SOURCE-ID. +***************************************************************/ +FileStream * ffConvertSourceIDToStream( cell id ) +{ + FileStream *stream; + + if( id == 0 ) + { + stream = PF_STDIN; + } + else if( id == -1 ) + { + stream = NULL; + } + else + { + stream = (FileStream *) id; + } + return stream; +} + +/*************************************************************** +** Cleanup Include stack by popping and closing files. +***************************************************************/ +static void ffCleanIncludeStack( void ) +{ + FileStream *cur; + + while( (cur = ffPopInputStream()) != PF_STDIN) + { + DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur )); + sdCloseFile(cur); + } +} + +/**************************************************************/ +void ffAbort( void ) +{ +#ifndef PF_NO_SHELL + ReportIncludeState(); +#endif /* PF_NO_SHELL */ + ffCleanIncludeStack(); + ResetForthTask(); + SET_ABORT; + if( gVarReturnCode == 0 ) gVarReturnCode = ABORT_RETURN_CODE; +} + +/**************************************************************/ +/* ( -- , fill Source from current stream ) */ +/* Return FFALSE if no characters. */ +cell ffRefill( void ) +{ + cell Num, Result = FTRUE; + +/* get line from current stream */ + Num = ioAccept( gCurrentTask->td_SourcePtr, + TIB_SIZE, gCurrentTask->td_InputStream ); + if( Num < 0 ) + { + Result = FFALSE; + Num = 0; + } + +/* reset >IN for parser */ + gCurrentTask->td_IN = 0; + gCurrentTask->td_SourceNum = Num; + gCurrentTask->td_LineNumber++; /* Bump for include. */ + +/* echo input if requested */ + if( gVarEcho && ( Num > 0)) + { + MSG( gCurrentTask->td_SourcePtr ); + } + + return Result; +} diff --git a/csrc/pfcompil.h b/csrc/pfcompil.h new file mode 100644 index 0000000..76bd289 --- /dev/null +++ b/csrc/pfcompil.h @@ -0,0 +1,72 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +Err ffPushInputStream( FileStream *InputFile ); +ExecToken NameToToken( const ForthString *NFA ); +FileStream * ffConvertSourceIDToStream( cell id ); +FileStream *ffPopInputStream( void ); +cell ffConvertStreamToSourceID( FileStream *Stream ); +cell ffFind( const ForthString *WordName, ExecToken *pXT ); +cell ffFindC( const char *WordName, ExecToken *pXT ); +cell ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ); +cell ffIncludeFile( FileStream *InputFile ); +cell ffNumberQ( const char *FWord, cell *Num ); +cell ffRefill( void ); +cell ffTokenToName( ExecToken XT, const ForthString **NFAPtr ); +cell *NameToCode( ForthString *NFA ); +cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ); +char *ffWord( char c ); +const ForthString *NameToPrevious( const ForthString *NFA ); +int32 FindSpecialCFAs( void ); +int32 FindSpecialXTs( void ); +int32 NotCompiled( const char *FunctionName ); +int32 ffInterpret( void ); +void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, uint32 Flags ); +void CreateDicEntryC( ExecToken XT, const char *CName, uint32 Flags ); +void ff2Literal( cell dHi, cell dLo ); +void ffALiteral( cell Num ); +void ffAbort( void ); +void ffColon( void ); +void ffCreate( void ); +void ffCreateSecondaryHeader( const ForthStringPtr FName); +void ffDefer( void ); +void ffFinishSecondary( void ); +void ffLiteral( cell Num ); +void ffOK( void ); +void ffQuit( void ); +void ffSemiColon( void ); +void ffStringCreate( ForthStringPtr FName); +void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ); + +#ifdef PF_SUPPORT_FP +void ffFPLiteral( PF_FLOAT fnum ); +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_compile_h */ diff --git a/csrc/pfcustom.c b/csrc/pfcustom.c new file mode 100644 index 0000000..1973336 --- /dev/null +++ b/csrc/pfcustom.c @@ -0,0 +1,122 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + + +#include "pf_all.h" + +static int32 CTest0( int32 Val ); +static void CTest1( int32 Val1, cell Val2 ); + +/**************************************************************** +** Step 1: Put your own special glue routines here +** or link them in from another file or library. +****************************************************************/ +static int32 CTest0( int32 Val ) +{ + MSG_NUM_D("CTest0: Val = ", Val); + return Val+1; +} + +static void CTest1( int32 Val1, cell 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) +void *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. +*/ + +void *CustomFunctionTable[] = +{ + (void *)CTest0, + (void *)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; + +/* 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", 0, C_RETURNS_VALUE, 1 ); + if( err < 0 ) return err; + err = CreateGlueToC( "CTEST1", 1, 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" +** Test: 10 Ctest0 ( should print message then '11' ) +****************************************************************/ + +#endif /* PF_USER_CUSTOM */ + diff --git a/csrc/pfinnrfp.h b/csrc/pfinnrfp.h new file mode 100644 index 0000000..82a34f1 --- /dev/null +++ b/csrc/pfinnrfp.h @@ -0,0 +1,336 @@ +/* @(#) 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, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +***************************************************************/ + +#ifdef PF_SUPPORT_FP + +#define FP_DHI1 (((PF_FLOAT)0x40000000)*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) ((unsigned int)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); */ + { + uint32 dlo; + int32 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 = (int32) fpScratch; /* dhi */ + fpScratch = ((PF_FLOAT) dhi) * FP_DHI1; + /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */ + + fpTemp = fpTemp - fpScratch; /* Remainder */ + dlo = (uint32) 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: + ERR("\nID_FP_FROUND - Not Yet!! FIXME\n"); + 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 *) 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 diff --git a/csrc/pforth.h b/csrc/pforth.h new file mode 100644 index 0000000..e94be1b --- /dev/null +++ b/csrc/pforth.h @@ -0,0 +1,88 @@ +/* @(#) 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 tool. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** +***************************************************************/ + +/* Define stubs for data types so we can pass pointers but not touch inside. */ +typedef struct cfTaskData cfTaskData; +typedef struct cfDictionary cfDictionary; + +typedef unsigned long ExecToken; /* Execution Token */ + +#ifndef int32 + typedef long int32; +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/* Main entry point to pForth. */ +int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ); + +/* Turn off messages. */ +void pfSetQuiet( int32 IfQuiet ); + +/* Query message status. */ +int32 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. */ +cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ); + +/* Establish this task as the current task. */ +void pfSetCurrentTask( cfTaskData *cftd ); + +/* Delete task created by pfCreateTask */ +void pfDeleteTask( cfTaskData *cftd ); + +/* Build a dictionary with all the basic kernel words. */ +cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ); + +/* Create an empty dictionary. */ +cfDictionary *pfCreateDictionary( int32 HeaderSize, int32 CodeSize ); + +/* Load dictionary from a file. */ +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); + +/* Delete dictionary data. */ +void pfDeleteDictionary( cfDictionary *dic ); + +/* Execute the pForth interpreter. */ +int32 pfRunForth( void ); + +/* Execute a single execution token in the current task. */ +void pfExecuteToken( ExecToken XT ); + +/* Include the given pForth source code file. */ +int32 pfIncludeFile( const char *FileName ); + +/* Execute a Forth word by name. */ +void pfExecByName( const char *CString ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_h */ diff --git a/docs/pf_ref.htm b/docs/pf_ref.htm new file mode 100644 index 0000000..859d354 --- /dev/null +++ b/docs/pf_ref.htm @@ -0,0 +1,1333 @@ + + + + + + + + pForth Reference + + + +
+

+ +

+ +
+

+pForth Reference Manual

+ +
+
+ +

+pForth - a Portable ANSI style Forth written in ANSI 'C'.  Last +updated: August 20th, 1998 V20

+by Phil Burk with Larry Polansky, +David Rosenboom. Special thanks to contributors Darren Gibbs, Herb Maeder, +Gary Arakaki, Mike Haas. + +

PForth source code is freely available.  The author is available +for customization of pForth, porting to new platforms, or developing pForth +applications on a contractual basis.  If interested, contact  +Phil Burk at philburk@softsynth.com + +

Back to pForth Home Page +

+

+LEGAL NOTICE

+The pForth software code is dedicated to the public domain, and any third +party may reproduce, distribute and modify the pForth software code or +any derivative works thereof without any compensation or license. The pForth +software code is provided on an "as is" basis without any warranty of any +kind, including, without limitation, the implied warranties of merchantability +and fitness for a particular purpose and their equivalents under the laws +of any jurisdiction. + +

+

+

+Table of Contents

+ + + +
+

+What is pForth?

+PForth is an ANSI style Forth designed to be portable across many platforms. +The 'P' in pForth stands for "Portable". PForth is based on a Forth kernel +written in ANSI standard 'C'. +

+What is Forth?

+Forth is a stack based language invented by astronomer Charles Moore for +controlling telescopes. Forth is an interactive language. You can enter +commands at the keyboard and have them be immediately executed, similar +to BASIC or LISP. Forth has a dictionary of words that can be executed +or used to construct new words that are then added to the dictionary. Forth +words operate on a data stack that contains numbers and addresses. + +

To learn more about Forth, see the Forth Tutorial. +

+The Origins of pForth

+PForth began as a JSR threaded 68000 Forth called HForth that was used +to support HMSL, the Hierarchical Music Specification Language. HMSL was +a music experimentation language developed by Phil Burk, Larry Polansky +and David Rosenboom while working at the Mills College Center for Contemporary +Music. Phil moved from Mills to the 3DO Company where he ported the Forth +kernel to 'C'. It was used at 3DO as a tool for verifying ASIC design and +for bringing up new hardware platforms. At 3DO, the Forth had to run on +many systems including SUN, SGI, Macintosh, PC, Amiga, the 3DO ARM based +Opera system, and the 3DO PowerPC based M2 system. PForth is now being +developed for use at CagEnt, a spinoff of 3DO. +

+pForth Design Goals

+PForth has been designed with portability as the primary design goal. As +a result, pForth avoids any fancy UNIX calls. pForth also avoids using +any clever and original ways of constructing the Forth dictionary. It just +compiles its kernel from ANSI compatible 'C' code then loads ANS compatible +Forth code to build the dictionary. Very boring but very likely to work +on almost any platform. + +

The dictionary files that can be saved from pForth are almost host independant. +They can be compiled on one processor, and then run on another processor. +as long as the endian-ness is the same. In other words, dictionaries built +on a PC will only work on a PC. Dictionaries built on almost any other +computer will work on almost any other computer. + +

PForth can be used to bring up minimal hardware systems that have very +few system services implemented. It is possible to compile pForth for systems +that only support routines to send and receive a single character. If malloc() +and free() are not available, equivalent functions are available in standard +'C' code. If file I/O is not available, the dictionary can be saved as +a static data array in 'C' source format on a host system. The dictionary +in 'C' source form is then compiled with a custom pForth kernel to avoid +having to read the dictionary from disk. + +

+

+

+Compiling pForth for your +System

+The process of building pForth involves several steps. This process is +typically handled automatically by the Makefile or IDE Project. +
    +
  1. +Compile the 'C' based pForth kernel called "pforth".
    2. + +
  2. +Execute "pforth" with the -i option to build the dictionary from scratch.
    3. + +
  3. +Compile the "system.fth" file which will add all the top level Forth words.
    4. + +
  4. +Save the compiled dictionary as "pforth.dic".
    5. + +
  5. +The next time you run pforth, the precompiled pforth.dic file will be loaded +automatically.
    6. +
+ +

+UNIX

+A Makefile has been provided that should work on most UNIX platforms. +
    +
  1. +cd to top directory of pForth
    2. + +
  2. +Enter: make all
    3. +
+ +

+Macintosh

+A precompiled PPC binary for pForth is provided. A Code Warrior Project +has been provided that will rebuild pForth for PPC if desired. Alternatively +you could use MPW to make pForth as an MPW Tool.  Make sure that you +provide at least 1 Meg of heap space. If you build for 68K, make sure you +use 32 bit integers, and select the appropriate libraries.  To rebuild +pForth for PPC: +
    +
  1. +Open pForthCW
    2. + +
  2. +Make target "pForthApp"
    3. + +
  3. +Run pForthApp
    4. + +
  4. +Enter "-i" as Argumant in starting dialog to initialize dictionary.
    5. + +
  5. +To compile system.fth, enter "loadsys".
    6. + +
  6. +Quit pForth using File menu.
    7. + +
  7. +From now on, just double click pForthApp icon to run pForth.
    8. +
+ +

+PC Compatible

+A precompiled binary for pForth is provided. To rebuild +under Windows NT or Win95 using Microsoft Visual C++: +
    +
  1. +Double click on the pForth.dsw icon in "pForth\pcbuild".
    2. + +
  2. +Select the "MakeDic" configuration.
    3. + +
  3. +Select "Rebuild All" from the Build menu.This will +build the pForth.exe file.
    4. + +
  4. +Run the app with CTRL-F5 which will build the pforth.dic +file.
    5. + +
  5. +Select the "Release" configuration.
    6. + +
  6. +Run the app with CTRL-F5 which will drop you into +Forth.
    7. + +
  7. +From now on, to run pForth, just double click on +the pforth.exe file.
    8. +
+ +

+Description of Source Files

+ +

+Forth Source

+ +
ansilocs.fth    = support for ANSI (LOCAL) word
+c_struct.fth    = 'C' like data structures
+case.fth        = CASE OF ENDOF ENDCASE
+catch.fth       = CATCH and THROW
+condcomp.fth    = [IF] [ELSE] [THEN] conditional compiler
+filefind.fth    = FILE?
+floats.fth      = floating point support
+forget.fth      = FORGET [FORGET] IF.FORGOTTEN
+loadp4th.fth    = loads basic dictionary
+locals.fth      = { } style locals using (LOCAL)
+math.fth        = misc math words
+member.fth      = additional 'C' like data structure support
+misc1.fth       = miscellaneous words
+misc2.fth       = miscellaneous words
+numberio.fth    = formatted numeric input/output
+private.fth     = hide low level words
+quit.fth        = QUIT EVALUATE INTERPRET in high level
+smart_if.fth    = allows conditionals outside colon definition
+see.fth         = Forth "disassembler".  Eg.  SEE SPACES
+strings.fth     = string support
+system.fth      = bootstraps pForth dictionary
+trace.fth       = single step trace for debugging
+ +

+'C' Source

+csrc/pfcompil.c = pForth compiler support +
csrc/pfcustom.c = example of 'C' functions callable from pForth +
csrc/pfinnrfp.h = float extensions to interpreter +
csrc/pforth.h = include this in app that embeds pForth +
csrc/pf_cglue.c = glue for pForth calling 'C' +
csrc/pf_clib.c = replacement routines for 'C' stdlib +
csrc/pf_core.c = primary words called from 'C' app that embeds pForth +
csrc/pf_float.h = defines PF_FLOAT, and the floating point math functions +such as fp_sin +
csrc/pf_inner.c = inner interpreter +
csrc/pf_guts.h = primary include file, define structures +
csrc/pf_io.c = input/output +
csrc/pf_main.c = basic application for standalone pForth +
csrc/pf_mem.c = optional malloc() implementation +
csrc/pf_save.c = save and load dictionaries +
csrc/pf_text.c = string tools, error message text +
csrc/pf_words.c = miscellaneous pForth words implemented +
+
+

+Running pForth

+PForth can be run from a shell or by double clicking on its icon, depending +on the system you are using. The execution options for pForth are described +assuming that you are running it from a shell. + +

Usage: +

    +
    pforth [-i] [-dDictionaryFilename] [SourceFilename]
    +
+ +
+-i
+ +
+Initialize pForth by building dictionary from scratch. Used when building +pForth or when debugging pForth on new systems.
+ +
+-dDictionaryFilename
+ +
+Specify a custom dictionary to be loaded in place of the default "pforth.dic". +For example:
+ +
    +
      +
      pforth -dgame.dic
      +
    +
+ +
+SourceFilename
+ +
+A Forth source file can be automatically compiled by passing its name to +pForth. This is useful when using Forth as an assembler or for automated +hardware testing. Remember that the source file can compile code and execute +it all in the same file.
+ +

+Quick Verification of pForth

+To verify that PForth is working, enter: +
    +
    3 4 + .
    +
+It should print "7 ok". Now enter: +
    WORDS
+You should see a long list of all the words in the pForth dictionary. Don't +worry. You won't need to learn all of these.  More tests are described +in the README.txt file. + +

+

+

+ANSI Compliance

+This Forth is intended to be ANS compatible. I will not claim that it is +compatible until more people bang on it. If you find areas where it deviates +from the standard, please let me know. + +

Word sets supported include: +

    +
  • +FLOAT
    • + +
  • +LOCAL with support for { lv1 lv2 | lv3 -- } style locals
    • + +
  • +EXCEPTION but standard throw codes not implemented
    • + +
  • +FILE ACCESS
    • + +
  • +MEMORY ALLOCATION
    • +
+Here are the areas that I know are not compatible: + +

The ENVIRONMENT queries are not implemented. + +

Word sets NOT supported include: +

    +
  • +BLOCK - a matter of religion
    • + +
  • +SEARCH ORDER - coming soon
    • + +
  • +PROGRAMMING TOOLS - only has .S ? DUMP WORDS BYE
    • + +
  • +STRING - only has CMOVE CMOVE> COMPARE
    • + +
  • +DOUBLE NUMBER - but cell is 32 bits
    • +
+ +
+

+pForth Special Features

+These features are not part of the ANS standard for Forth.  They have +been added to assist developers. +

+Compiling from a File

+Use INCLUDE to compile source code from a file: +
    +
    INCLUDE filename
    +
+You can nest calls to INCLUDE. INCLUDE simply redirects Forth to takes +its input from the file instead of the keyboard so you can place any legal +Forth code in the source code file. +

+Saving Precompiled Dictionaries

+Use SAVE-FORTH save your precompiled code to a file. To save the current +dictionary to a file called "custom.dic", enter: +
    +
    c" custom.dic" SAVE-FORTH
    +
+You can then leave pForth and use your custom dictionary by enterring: +
    +
    pforth -dcustom.dic
    +
+On icon based systems, you may wish to name your custom dictionary "pforth.dic" +so that it will be loaded automatically. + +

Be careful that you do not leave absolute addresses stored in the dictionary +because they will not work when you reload pForth at a different address. +Use A! to store an address in a variable in a relocatable form and A@ to +get it back if you need to. +

    +
    VARIABLE DATA-PTR
+CREATE DATA 100 ALLOT
+DATA DATA-PTR !    \ storing absolute address!  BAD
+DATA DATA-PTR A!   \ storing relocatable address!  GOOD
+DATA-PTR A@        \ fetch relocatable address
    +
+ +

+Recompiling Code - ANEW +INCLUDE?

+When you are testing a file full of code, you will probably recompile many +times. You will probably want to FORGET the old code before loading the +new code. You could put a line at the beginning of your file like this: +
    +
    FORGET XXXX-MINE     : XXXX-MINE ;
    +
+This would automatically FORGET for you every time you load. Unfortunately, +you must define XXXX-MINE before you can ever load this file. We have a +word that will automatically define a word for you the first time, then +FORGET and redefine it each time after that. It is called ANEW and can +be found at the beginning of most Forth source files. We use a prefix of +TASK- followed by the filename just to be consistent. This TASK-name word +is handy when working with INCLUDE? as well. Here is an example: +
    +
    \ Start of file
+INCLUDE? TASK-MYTHING.FTH MYTHING.FTH
+ANEW TASK-THISFILE.FTH
+\ the rest of the file follows...
    +
+Notice that the INCLUDE? comes before the call to ANEW so that we don't +FORGET MYTHING.FTH every time we recompile. + +

FORGET allows you to get rid of code that you have already compiled. +This is an unusual feature in a programming language. It is very convenient +in Forth but can cause problems. Most problems with FORGET involve leaving +addresses that point to the forgotten code that are not themselves forgotten. +This can occur if you set a deferred system word to your word then FORGET +your word. The system word which is below your word in the dictionary is +pointing up to code that no longer exists. It will probably crash if called. +(See discussion of DEFER below.) Another problem is if your code allocates +memory, opens files, or opens windows. If your code is forgotten you may +have no way to free or close these thing. You could also have a problems +if you add addresses from your code to a table that is below your code. +This might be a jump table or data table. + +

Since this is a common problem we have provided a tool for handling +it. If you have some code that you know could potentially cause a problem +if forgotten, then write a cleanup word that will eliminate the problem. +This word could UNdefer words, free memory, etc. Then tell the system to +call this word if the code is forgotten. Here is how: +

    +
    : MY.CLEANUP  ( -- , do whatever )
+    MY-MEM @ FREE DROP
+    0 MY-MEM !
+;
+IF.FORGOTTEN  MY.CLEANUP
    +
+IF.FORGOTTEN creates a linked list node containing your CFA that is checked +by FORGET. Any nodes that end up above HERE (the Forth pointer to the top +of the dictionary) after FORGET is done are executed. +

+Customising FORGET with +[FORGET]

+Sometimes, you may need to extend the way that FORGET works. FORGET is +not deferred, however, because that could cause some real problems. Instead, +you can define a new version of [FORGET] which is searched for and executed +by FORGET. You MUST call [FORGET] from your program or FORGET will not +actually FORGET. Here is an example. +
    +
    : [FORGET]  ( -- , my version )
+    ." Change things around!" CR
+    [FORGET]  ( must be called )
+    ." Now put them back!" CR
+;
+: FOO ." Hello!" ;
+FORGET FOO  ( Will print "Change things around!", etc.)
    +
+This is recommended over redefining FORGET because words like ANEW that +call FORGET will now pick up your changes. +

+Smart Conditionals

+In pForth, you can use IF THEN DO LOOP and other conditionals outside of +colon definitions. PForth will switch temporarily into the compile state, +then automatically execute the conditional code. (Thank you Mitch Bradley) +For example, just enter this at the keyboard. +
    +
    10 0 DO I . LOOP
    +
+ +

+Development Tools

+ +

+WORDS.LIKE

+If you cannot remember the exact name of a word, you can use WORDS.LIKE +to search the dictionary for all words that contain a substring. For an +example, enter: +
    +
    WORDS.LIKE   FOR
+WORDS.LIKE   EMIT
    +
+ +

+FILE?

+You can use FILE? to find out what file a word was compiled from. If a +word was defined in multiple files then it will list each file. The execution +token of each definition of the word is listed on the same line. +
    FILE? IF +
    FILE? AUTO.INIT
+ +

+SEE

+You can use SEE to "disassemble" a word in the pForth dictionary. SEE will +attempt to print out Forth source in a form that is similar to the source +code. SEE will give you some idea of how the word was defined but is not +perfect. Certain compiler words, like BEGIN and LITERAL, are difficult +to disassemble and may not print properly. For an example, enter: +
    +
    SEE SPACES
+SEE WORDS
    +
+ +

+Single Step Trace and Debug

+It is often useful to proceed step by step through your code when debugging.  +PForth provides a simple single step trace facility for this purpose.  +Here is an example of using TRACE to debug a simple program.  Enter +the following program: +
  +
    +
    : SQUARE ( n -- n**2 )
+    DUP  *
+;
+: TSQ  ( n -- , test square )
+    ." Square of "   DUP   .
+    ." is "   SQUARE   .   CR
+;
    +
+Even though this program should work, let's pretend it doesn't and try +to debug it.  Enter: +
    7  TRACE  TSQ
+You should see: +
    +
    7 trace tsq
+<<  TSQ +0           <10:1> 7             ||  (.")  Square of "          >>    ok
    +
+The "TSQ +0" means that you are about to execute code at an offset of "+0" +from the beginning of TSQ.  The <10:1> means that we are in base +10, and that there is 1 item on the stack, which is shown to be "7". The +(.") is the word that is about to be executed.  (.") is the word that +is compiled when use use .".  Now to single step, enter: +
    +
    s
    +
+You should see: +
    +
    Square of
+<<  TSQ +16          <10:1> 7             ||  DUP                         >>    ok
    +
+ +
The "Square os" was printed by (."). We can step multiple times using the "sm" command. Enter:
+ +
    +
    3 sm
    +
+You should see: +
    +
    <<  TSQ +20          <10:2> 7 7           ||  .                         >> 7 
+<<  TSQ +24          <10:1> 7             ||  (.")  is "                >> is 
+<<  TSQ +32          <10:1> 7             ||  SQUARE                    >>    ok
    +
+The "7" after the ">>" was printed by the . word. If we entered "s", we +would step over the SQUARE word. If we want to dive down into SQUARE, we +can enter: +
    +
    sd
    +
+ +
You should see:
+ +
    +
    <<  SQUARE +0        <10:1> 7             ||    DUP                     >>    ok
    +
+ +
To step once in SQUARE, enter:
+ +
    +
    s
    +
+You should see: +
    +
    <<  SQUARE +4        <10:2> 7 7           ||    *                        >>    ok
    +
+ +
To go to the end of the current word, enter:
+ +
    +
    g
    +
+ +
You should see:
+ +
    +
    <<  SQUARE +8        <10:1> 49            ||    EXIT                      >> 
+<<  TSQ +36          <10:1> 49            ||  .                           >>    ok
    +
+EXIT is compiled at the end of every Forth word. For more information on +TRACE, enter TRACE.HELP: +
    +
    TRACE  ( i*x <name> -- , 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 )
    +
+ +

+Conditional Compilation +[IF] [ELSE] [THEN]

+PForth supports conditional compilation words similar to 'C''s #if, #else, +and #endif. +
+[IF] ( flag -- , if true, skip to [ELSE] or [THEN] )
+ +
+[ELSE] ( -- , skip to [THEN] )
+ +
+[THEN] ( -- , noop, used to terminate [IF] and [ELSE] section )
+ +
  +
For example: +
    +
    TRUE constant USE_FRENCH
+
+USE_FRENCH  [IF]
+  : WELCOME  ." Bienvenue!" cr ;
+[ELSE]
+  : WELCOME  ." Welcome!" cr ;
+[THEN]
    +
+Here is how to conditionally compile within a colon definition by using +[ and ]. +
    +
    : DOIT  ( -- )
+    START.REACTOR
+    IF
+        [ USE_FRENCH [IF] ] ." Zut alors!"
+        [ [ELSE] ] ." Uh oh!"
+        [THEN]
+    THEN cr
+;
    +
+ +

+Miscellaneous Handy Words

+ +
+.HEX ( n -- , print N as hex number )
+ +
+CHOOSE ( n -- rand , select random number between 0 and N )
+ +
+MAP ( -- , print dictionary information )
+ +

+Local Variables { foo --}

+In a complicated Forth word it is sometimes hard to keep track of where +things are on the stack. If you find you are doing a lot of stack operations +like DUP SWAP ROT PICK etc. then you may want to use local variables. They +can greatly simplify your code. You can declare local variables for a word +using a syntax similar to the stack diagram. These variables will only +be accessible within that word. Thus they are "local" as opposed to "global" +like regular variables. Local variables are self-fetching. They automatically +put their values on the stack when you give their name. You don't need +to @ the contents. Local variables do not take up space in the dictionary. +They reside on the return stack where space is made for them as needed. +Words written with them can be reentrant and recursive. + +

Consider a word that calculates the difference of two squares, Here +are two ways of writing the same word. +

    +
    : DIFF.SQUARES ( A B -- A*A-B*B ) 
+    DUP * 
+    SWAP DUP * 
+    SWAP - 
+; 
+  ( or ) 
+: DIFF.SQUARES { A B -- A*A-B*B } 
+    A A * 
+    B B * - 
+; 
+3 2 DIFF.SQUARES  ( would return 5 )
    +
+In the second definition of DIFF.SQUARES the curly bracket '{' told the +compiler to start declaring local variables. Two locals were defined, A +and B. The names could be as long as regular Forth words if desired. The +"--" marked the end of the local variable list. When the word is executed, +the values will automatically be pulled from the stack and placed in the +local variables. When a local variable is executed it places its value +on the stack instead of its address. This is called self-fetching. Since +there is no address, you may wonder how you can store into a local variable. +There is a special operator for local variables that does a store. It looks +like -> and is pronounced "to". + +

Local variables need not be passed on the stack. You can declare a local +variable by placing it after a "vertical bar" ( | )character. These are +automatically set to zero when created. Here is a simple example that uses +-> and | in a word: +

    +
    : SHOW2*  
+        { loc1 | unvar --  , 1 regular, 1 uninitialized }
+        LOC1  2*  ->  UNVAR 
+                (set unver to 2*LOC1 )
+        UNVAR   .   ( print UNVAR )
+;
+3 SHOW2*   ( pass only 1 parameter, prints 6 )
    +
+Since local variable often used as counters or accumulators, we have a +special operator for adding to a local variable It is +-> which is pronounced +"plus to". These next two lines are functionally equivalent but the second +line is faster and smaller: +
    +
    ACCUM   10 +   -> ACCUM
+10 +-> ACCUM
    +
+If you name a local variable the same as a Forth word in the dictionary, +eg. INDEX or COUNT, you will be given a warning message. The local variable +will still work but one could easily get confused so we warn you about +this. Other errors that can occur include, missing a closing '}', missing +'--', or having too many local variables. +

+'C' like Structures. :STRUCT

+You can define 'C' like data structures in pForth using :STRUCT. For example: +
    +
    :STRUCT  SONG
+    LONG     SONG_NUMNOTES  \ define 32 bit structure member named SONG_NUMNOTES
+    SHORT    SONG_SECONDS   \ define 16 bit structure member
+    BYTE     SONG_QUALITY   \ define 8 bit member
+    LONG     SONG_NUMBYTES  \ auto aligns after SHORT or BYTE
+    RPTR     SONG_DATA      \ relocatable pointer to data
+;STRUCT
    + +
    SONG  HAPPY   \ define a song structure called happy
    + +
    400  HAPPY  S!  SONG_NUMNOTES  \ set number of notes to 400
+17   HAPPY  S!  SONG_SECONDS   \ S! works with all size members
    + +
    CREATE  SONG-DATA  23 , 17 , 19 , 27 ,
+SONG-DATA  HAPPY S! SONG_DATA  \ store pointer in relocatable form
    + +
    HAPPY  DST  SONG    \ dump HAPPY as a SONG structure
    + +
    HAPPY   S@  SONG_NUMNOTES .  \ fetch numnotes and print
    +
+See the file "c_struct.fth" for more information. +

+Vectorred Execution - DEFER

+Using DEFER for vectored words. In Forth and other languages you can save +the address of a function in a variable. You can later fetch from that +variable and execute the function it points to.This is called vectored +execution. PForth provides a tool that simplifies this process. You can +define a word using DEFER. This word will contain the execution token of +another Forth function. When you execute the deferred word, it will execute +the function it points to. By changing the contents of this deferred word, +you can change what it will do. There are several words that support this +process. +
+
+DEFER ( <name> -- , define a deferred word )
+ +
+IS ( CFA <name> -- , set the function for a deferred word )
+ +
+WHAT'S ( <name> -- CFA , return the CFA set by IS )
+
+ +
+Simple way to see the name of what's in a deferred word:
+ +
    +
      +
      WHAT'S EMIT >NAME ID.
      +
    +
+ +
+should print name of current word that's in EMIT.
+ +
  +
Here is an example that uses a deferred word. +
    +
    DEFER PRINTIT
+' . IS PRINTIT   ( make PRINTIT use . )
+8 3 + PRINTIT
+
+: COUNTUP  ( -- , call deferred word )
+        ." Hit RETURN to stop!" CR
+        0 ( first value )
+        BEGIN 1+ DUP PRINTIT CR
+                ?TERMINAL
+        UNTIL
+;
+COUNTUP  ( uses simple . )
+
+: FANCY.PRINT  ( N -- , print in DECIMAL and HEX)
+        DUP ." DECIMAL = " .
+        ." , HEX = " .HEX
+;
+' FANCY.PRINT  IS PRINTIT  ( change printit )
+WHAT'S PRINTIT >NAME ID. ( shows use of WHAT'S )
+8 3 + PRINTIT
+COUNTUP  ( notice that it now uses FANCY.PRINT )
    +
+Many words in the system have been defined using DEFER which means that +we can change how they work without recompiling the entire system. Here +is a partial list of those words +
    +
    ABORT EMIT NUMBER?
    +
+ +

+Potential Problems with Defer

+Deferred words are very handy to use, however, you must be careful with +them. One problem that can occur is if you initialize a deferred system +more than once. In the below example, suppose we called STUTTER twice. +The first time we would save the original EMIT vector in OLD-EMIT and put +in a new one. The second time we called it we would take our new function +from EMIT and save it in OLD-EMIT overwriting what we had saved previously. +Thus we would lose the original vector for EMIT . You can avoid this if +you check to see whether you have already done the defer. Here's an example +of this technique. +
    +
    DEFER OLD-EMIT
+' QUIT  IS OLD-EMIT  ( set to known value )
+: EEMMIITT  ( char --- , our fun EMIT )
+    DUP OLD-EMIT OLD-EMIT
+; 
+: STUTTER   ( --- )
+    WHAT'S OLD-EMIT  'C QUIT =  ( still the same? )
+    IF  ( this must be the first time )
+        WHAT'S EMIT  ( get the current value of EMIT )  
+        IS OLD-EMIT  ( save this value in OLD-EMIT )  
+        'C EEMMIITT IS EMIT
+    ELSE ."  Attempt to STUTTER twice!" CR
+    THEN
+; 
+: STOP-IT!  ( --- )
+    WHAT'S OLD-EMIT ' QUIT =
+    IF  ." STUTTER not installed!" CR
+    ELSE  WHAT'S OLD-EMIT IS EMIT
+        'C QUIT IS OLD-EMIT  
+                ( reset to show termination )
+    THEN
+;
    +
+In the above example, we could call STUTTER or STOP-IT! as many times as +we want and still be safe. + +

Suppose you forget your word that EMIT now calls. As you compile new +code you will overwrite the code that EMIT calls and it will crash miserably. +You must reset any deferred words that call your code before you FORGET +your code. The easiest way to do this is to use the word IF.FORGOTTEN to +specify a cleanup word to be called if you ever FORGET the code in question. +In the above example using EMIT , we could have said: +

    +
    IF.FORGOTTEN STOP-IT!
    +
+ +

+Floating Point

+PForth supports the FLOAT word set and much of the FLOATEXT word set as +a compile time option.  You can select single or double precision +as the default by changing the typedef of PF_FLOAT. +
PForth has several options for floating point output. +
+FS. ( r -f- , prints in scientific/exponential format )
+ +
+FE. ( r -f- , prints in engineering format, exponent if multiple of 3  +)
+ +
+FG. ( r -f- , prints in normal or exponential format depending on size +)
+ +
+F. ( r -f- , as defined by the standard )
+ +
+Here is an example of output from each word for a number ranging from large +to very small.
+ +
+
     FS.             FE.            FG.           F.
+1.234000e+12     1.234000e+12     1.234e+12     1234000000000. 
+1.234000e+11     123.4000e+09     1.234e+11     123400000000. 
+1.234000e+10     12.34000e+09     1.234e+10     12340000000. 
+1.234000e+09     1.234000e+09     1.234e+09     1234000000. 
+1.234000e+08     123.4000e+06     1.234e+08     123400000. 
+1.234000e+07     12.34000e+06     1.234e+07     12340000. 
+1.234000e+06     1.234000e+06     1234000.     1234000. 
+1.234000e+05     123.4000e+03     123400.     123400.0 
+1.234000e+04     12.34000e+03     12340.     12340.00 
+1.234000e+03     1.234000e+03     1234.     1234.000 
+1.234000e+02     123.4000e+00     123.4     123.4000 
+1.234000e+01     12.34000e+00     12.34     12.34000 
+1.234000e+00     1.234000e+00     1.234     1.234000 
+1.234000e-01     123.4000e-03     0.1234     0.1234000 
+1.234000e-02     12.34000e-03     0.01234     0.0123400 
+1.234000e-03     1.234000e-03     0.001234     0.0012340 
+1.234000e-04     123.4000e-06     0.0001234     0.0001234 
+1.234000e-05     12.34000e-06     1.234e-05     0.0000123 
+1.234000e-06     1.234000e-06     1.234e-06     0.0000012 
+1.234000e-07     123.4000e-09     1.234e-07     0.0000001 
+1.234000e-08     12.34000e-09     1.234e-08     0.0000000 
+1.234000e-09     1.234000e-09     1.234e-09     0.0000000 
+1.234000e-10     123.4000e-12     1.234e-10     0.0000000 
+1.234000e-11     12.34000e-12     1.234e-11     0.0000000
+
+1.234568e+12     1.234568e+12     1.234568e+12     1234567890000. 
+1.234568e+11     123.4568e+09     1.234568e+11     123456789000. 
+1.234568e+10     12.34568e+09     1.234568e+10     12345678900. 
+1.234568e+09     1.234568e+09     1.234568e+09     1234567890. 
+1.234568e+08     123.4568e+06     1.234568e+08     123456789. 
+1.234568e+07     12.34568e+06     1.234568e+07     12345679. 
+1.234568e+06     1.234568e+06     1234568.     1234568. 
+1.234568e+05     123.4568e+03     123456.8     123456.8 
+1.234568e+04     12.34568e+03     12345.68     12345.68 
+1.234568e+03     1.234568e+03     1234.568     1234.568 
+1.234568e+02     123.4568e+00     123.4568     123.4568 
+1.234568e+01     12.34568e+00     12.34568     12.34568 
+1.234568e+00     1.234568e+00     1.234568     1.234568 
+1.234568e-01     123.4568e-03     0.1234568     0.1234568 
+1.234568e-02     12.34568e-03     0.01234568     0.0123456 
+1.234568e-03     1.234568e-03     0.001234568     0.0012345 
+1.234568e-04     123.4568e-06     0.0001234568     0.0001234 
+1.234568e-05     12.34568e-06     1.234568e-05     0.0000123 
+1.234568e-06     1.234568e-06     1.234568e-06     0.0000012 
+1.234568e-07     123.4568e-09     1.234568e-07     0.0000001 
+1.234568e-08     12.34568e-09     1.234568e-08     0.0000000 
+1.234568e-09     1.234568e-09     1.234568e-09     0.0000000 
+1.234568e-10     123.4568e-12     1.234568e-10     0.0000000 
+1.234568e-11     12.34568e-12     1.234568e-11     0.0000000
+
+
+ +
+
+ +

+pForth Design

+ +

+'C' kernel

+The pForth kernel is written in 'C' for portability. The inner interpreter +is implemented in the function ExecuteToken() which is in pf_inner.c. +
    +
    void pfExecuteToken( ExecToken XT );
    +
+It is passed an execution token the same as EXECUTE would accept. It handles +threading of secondaries and also has a large switch() case statement to +interpret primitives. It is in one huge routine to take advantage of register +variables, and to reduce calling overhead. Hopefully, your compiler will +optimise the switch() statement into a jump table so it will run fast. +

+Dictionary Structures

+This Forth supports multiple dictionaries. Each dictionary consists of +a header segment and a seperate code segment. The header segment contains +link fields and names. The code segment contains tokens and data. The headers, +as well as some entire dictionaries such as the compiler support words, +can be discarded when creating a stand-alone app. + +

[NOT IMPLEMENTED] Dictionaries can be split so that the compile time +words can be placed above the main dictionary. Thus they can use the same +relative addressing but be discarded when turnkeying. + +

Execution tokens are either an index of a primitive ( n < NUM_PRIMITIVES), +or the offset of a secondary in the code segment. ( n >= NUM_PRIMITIVES +) + +

The NAME HEADER portion of the dictionary contains a structure for each +named word in the dictionary. It contains the following fields: +

    +
    bytes 4 Link Field relative address of previous name header
+4 Code Pointer relative address of corresponding code
+n Name Field name as counted string Headers are quad byte aligned.
    +
+The CODE portion of the dictionary consists of the following structures: +

+Primitive

+No Forth code. 'C' code in "pf_inner.c". +

+Secondary

+ +
    +
    4*n Parameter Field execution tokens
+4 ID_NEXT = 0 terminates secondary
    +
+ +

+CREATE DOES>

+ +
    +
    4 ID_CREATE_P token
+4 Token for optional DOES> code, OR ID_NEXT = 0
+4 ID_NEXT = 0
+n Body = arbitrary data
    +
+ +

+Deferred Word

+ +
    +
    4 ID_DEFER_P same action as ID_NOOP, identifies deferred words
+4 Execution Token of word to execute.
+4 ID_NEXT = 0
    +
+ +

+Call to custom 'C' function.

+ +
    +
    4 ID_CALL_C
+4 Pack C Call Info Bits
    + +
      +
      0-15 = Function Index Bits
+16-23 = FunctionTable Index (Unused) Bits
+24-30 = NumParams Bit
+31 = 1 if function returns value
      +
    + +
    4 ID_NEXT = 0
    +
+ +
+

+Custom Compilation of pForth

+ +

+Compiler Options

+There are several versions of PForth that can be built. By default, the +full kernel will be built. For custom builds, define the following options +in the Makefile before compiling the 'C' code: + +

PF_NO_INIT +

    Don't compile the code used to initially build the dictionary. This +can be used to save space if you already have a prebuilt dictionary.
+PF_NO_SHELL +
    Don't compile the outer interpreter and Forth compiler. This can be +used with Cloned dictionaries.
+PF_NO_MALLOC +
    Replace malloc() and free() function with pForth's own version. See +pf_mem.c for more details.
+PF_USER_MALLOC='"filename.h"' +
    Replace malloc() and free() function with users custom version. See +pf_mem.h for details.
+PF_MEM_POOL_SIZE=numbytes +
    Size of array in bytes used by pForth custom allocator.
+PF_NO_GLOBAL_INIT +
    Define this if you want pForth to not rely on initialization of global +variables by the loader. This may be required for some embedded systems +that may not have a fully functioning loader.  Take a look in "pfcustom.c" +for an example of its use.
+PF_USER_INC1='"filename.h"' +
    File to include BEFORE other include files. Generally set to host dependent +files such as "pf_mac.h".
+PF_USER_INC2='"filename.h"' +
    File to include AFTER other include files. Generally used to #undef +and re#define symbols. See "pf_win32.h" for an example.
+PF_NO_CLIB +
    Replace 'C' lib calls like toupper and memcpy with pForth's own version. +This is useful for embedded systems.
+PF_USER_CLIB='"filename.h"' +
    Rreplace 'C' lib calls like toupper and memcpy with users custom version. +See pf_clib.h for details.
+PF_NO_FILEIO +
    System does not support standard file I/O so stub it out. Setting this +flag will automatically set PF_STATIC_DIC.
+PF_USER_CHARIO='"filename.h"' +
    Replace stdio terminal calls like getchar() and putchar() with users +custom version. See pf_io.h for details.
+PF_USER_FILEIO='"filename.h"' +
    Replace stdio file calls like fopen and fread with users custom version. +See pf_io.h for details.
+PF_USER_FLOAT='"filename.h"' +
    Replace floating point math calls like sin and pow with users custom +version. Also defines PF_FLOAT.
+PF_USER_INIT=MyInit() +
    Call a user defined initialization function that returns a negative +error code if it fails.
+PF_USER_TERM=MyTerm() +
    Call a user defined void termination function.
+PF_STATIC_DIC +
    Compile in static dictionary instead of loading dictionary. from file. +Use "utils/savedicd.fth" to save a dictionary as 'C' source code in a file +called "pfdicdat.h".
+PF_SUPPORT_FP +
    Compile ANSI floating point support.
+ +

+Building pForth on Supported +Hosts

+To build on UNIX, do nothing, system will default to "pf_unix.h". + +

To build on Macintosh: +

    +
    -DPF_USER_INC1='"pf_mac.h"'
    +
+To build on PCs: +
    +
    -DPF_USER_INC2='"pf_win32.h"'
    +
+To build a system that only runs turnkey or cloned binaries: +
    +
    -DPF_NO_INIT -DPF_NO_SHELL
    +
+ +

+Compiling for Embedded Systems

+You may want to create a version of pForth that can be run on a small system +that does not support file I/O. This is useful when bringing up new computer +systems. On UNIX systems, you can use the supplied gmake target. Simply +enter: +
    +
    gmake pfemb
    +
+For other systems, here are the steps to create an embedded pForth. +
    +
  1. +Determine whether your target system has a different endian-ness than your +host system.  If the address of a long word is the address of the +most significant byte, then it is "big endian". Examples of big endian +processors are Sparc, Motorola 680x0 and PowerPC60x.  If the address +of a long word is the address of the lest significant byte, then it is +"Little Endian". Examples of little endian processors are Intel 8088 and +derivatives such as the Intel Pentium.
    2. + +
  2. +If your target system has a different endian-ness than your host system, +then you must compile a version of pForth for your host that matches the +target.  Rebuild pForth with either PF_BIG_ENDIAN_DIC or PF_LITTLE_ENDIAN_DIC +defined.  You will need to rebuild pforth.dic as well as the executable +Forth.  If you do not specify one of these variables, then the dictionary +will match the native endian-ness of the processor (and run faster as a +result).
    3. + +
  3. +Execute pForth. Notice the message regarding the endian-ness of the dictionary.
    4. + +
  4. +Compile your custom Forth words on the host development system.
    5. + +
  5. +Compile the pForth utulity "utils/savedicd.fth".
    6. + +
  6. +Enter in pForth: SDAD
    7. + +
  7. +SDAD will generate a file called "pfdicdat.h" that contains your dictionary +in source code form.
    8. + +
  8. +Rewrite the character primitives sdTerminalOut(), sdTerminalIn() and sdTerminalFlush() +defined in pf_io.h to use your new computers communications port.
    9. + +
  9. +Write a "user_chario.h" file based on the API defined in "pf_io.h".
    10. + +
  10. +Compile a new version of pForth for your target machine with the following +options:
    11. + +
      +
      -DPF_NO_INIT -DPF_NO_MALLOC -DPF_NO_FILEIO \
+-DPF_USER_CHARIO="user_chario.h" \
+-DPF_NO_CLIB -DPF_STATIC_DIC
      +
    + +
  11. +The file "pfdicdat.h" will be compiled into this executable and your dictionary +will thus be included in the pForth executable as a static array.
    12. + +
  12. +Burn a ROM with your new pForth and run it on your target machine.
    13. + +
  13. +If you compiled a version of pForth with different endian-ness than your +host system, do not use it for daily operation because it will be much +slower than a native version.
    14. +
+ +

+Linking with Custom 'C' +Functions

+You can call the pForth interpreter as an embedded tool in a 'C' application. +For an example of this, see the file pf_main.c. This application does nothing +but load the dictionary and call the pForth interpreter. + +

You can call 'C' from pForth by adding your own custom 'C' functions +to a dispatch table, and then adding Forth words to the dictionary that +call those functions. See the file "pfcustom.c" for more information. +

+Testing your Compiled pForth

+Once you have compiled pForth, you can test it using the small verification +suite we provide.  The first test you should run was written by John +Hayes at John Hopkins University.  Enter: +
    +
    pforth
+include tester.fth
+include coretest.fth
+bye
    +
+The output will be self explanatory.  There are also a number of tests +that I have added that print the number of successes and failures. Enter: +
    +
    pforth t_corex.fth
+pforth t_locals.fth
+pforth t_strings.fth
+pforth t_floats.ft
    +
+Note that t_corex.fth reveals an expected error because SAVE-INPUT is not +fully implemented. (FIXME) +
+
+
PForth source code is freely available.  The author is available +for customization of pForth, porting to new platforms, or developing pForth +applications on a contractual basis.  If interested, contact  +Phil Burk at philburk@softsynth.com + +

Back to pForth Home Page + + diff --git a/docs/pf_todo.txt b/docs/pf_todo.txt new file mode 100644 index 0000000..ece9ff3 --- /dev/null +++ b/docs/pf_todo.txt @@ -0,0 +1,116 @@ +\ %Z% %M% %E% %I% +File: pf_todo.txt + +To Do -------------------------------------------------------- + +User Requests + +Peter Verbeke & Carmen Lams + search wordset, float ext wordset , file wordset + +BUGS + +O- Fix NUMBER? in tutorial + +HIGH +X- Add compile time selection for LittleEndian, BigEndian, or native dictionaries. +X- detect and report endian conflicts in dictionary. +O- add deferred user break to trace, allow stop, dump +O- document more glossary words in pf_glos.htm +O- pfInit() pfTerm(), pfTask() +O- note that Special Feature" are the non-ANS words in document +O- document stack diagram of words used with if.forgotten +X- make sure "binary -1 u." is fixed, is string long enough? + +MEDIUM +O- fix SAVE-INPUT and RESTORE-INPUT +O- add ENVIRONMENT? +O- fix t_corex.fth failures +O- go through ANSI and add what's missing +O- support more word sets +O- support ANSI error codes +O- add INCLUDED +O- add better command line support, -d -e"commands" -i -b +O- document all non-standard words +O- review tutorial and docs + +LOW +O- primitive that accepts, SP RSP and CFA, returns SP' and RSP' +O- merge (LEAVE) and UNLOOP +O- clear data stack in ABORT +O- resolve problems with EOL in WORD + +O- integrate SAVE-FORTH, SDAD, and CLONE +O- simplify dictionary management so that globals are tracked better +O- move globals into task data structure + +O- research ROM requirements +O- clean up C call mechanism +O- research byte size tokens +O- execute Forth QUIT automatically + +Maybe Do --------- +O- defer interpret + +Done ------------- +V19 +X- warn if local name matches dictionary, : foo { count -- } ; +X- TO -> and +-> now parse input stream. No longer use to-flag. +X- TO -> and +-> now give error if used with non-immediate word. +X- high level trace tool with step, alternative stack +X- ?TERMINAL stub for embedded machines +X- FIXED memory leak in pfDoForth() +X- Add PF_USER_INIT for custom initialization. +X- remove MM.FREE from docs +X- include trace in normal release and document + + +V18 +X- Make FILL a 'C' primitive. +X- optimized locals with (1_LOCAL@) +X- optimized inner interpreter by 15% +X- fix tester.fth failures +X- Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined. +X- Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition. +X- Fixed saving and restoring of TIB when nesting include files. + +V16 +X- add dictionary room to MAP command +X- fix UM/MOD +X- corex to kernel +X- COMPARE to kernel +X- integrate CATCH with ABORT and INTERPRET +X- add WORDS.LIKE +X- add list and description of files to README +X- get floats to work with :STRUCT and FLPT +X- add PD disclaimers to Forth code +X- make script to build release package for UNIX/Mac +X- clean up source files +X- bump version number +X- add PD disclaimers to 'C' code +X- conditionally compile modes: full_build, compiler, turnkey +X- save as turnkey or dev mode +X- eliminate reliance on printf() for embedded systems +X- funnel ALL I/O through pf_io.c +X- add LoadDictionary +X- add SAVEFORTH +X- Add numeric entry +X- call deferred word from Interpret +X- Create Does +X- Branch, 0branch +X- add decimal numeric output +X- add "OK" +X- FIX EMIT !!!!! defer problem?! +X- try to load dspp_asm.fth +X- dictionary traversal, nfa->ffa +X- fix BYE +X- add CATCH and THROW +X- REFILL +X- SOURCE-ID +X- EVALUATE +X- push and pop source-id +X- make .S deferred, redefine using current base +X- revise trace to use level, stack trace +X- allow minnamesize and mincodesize on save +X- handle decimal point for double precision words. + diff --git a/docs/pf_tut.htm b/docs/pf_tut.htm new file mode 100644 index 0000000..63fd489 --- /dev/null +++ b/docs/pf_tut.htm @@ -0,0 +1,1308 @@ + + + + + + + + pForth Tutorial + + + +

+
+

+Forth Tutorial

+ +
+ +

by Phil Burk + +

To pForth Home Page +

+Table of Contents

+ + +The intent of this tutorial is to provide a series of experiments that +will introduce you to the major concepts of Forth. It is only a starting +point. Feel free to deviate from the sequences I provide. A free form investigation +that is based on your curiosity is probably the best way to learn any language. +Forth is especially well adapted to this type of learning. + +

This tutorial is written for the PForth implementation of the ANS Forth +standard. I have tried to restrict this tutorial to words that are part +of the ANS standard but some PForth specific words may have crept in. + +

In the tutorials, I will print the things you need to type in upper +case, and indent them. You can enter them in upper or lower case. At the +end of each line, press the RETURN (or ENTER) key; this causes Forth to +interpret what you've entered. +

+Forth Syntax

+Forth has one of the simplest syntaxes of any computer language. The syntax +can be stated as follows, "Forth code is a bunch of words with spaces +between them." This is even simpler than English! Each word +is equivalent to a function or subroutine in a language like 'C'. They +are executed in the order they appear in the code. The following statement, +for example, could appear in a Forth program: +
    +
     WAKE.UP EAT.BREAKFAST WORK EAT.DINNER PLAY SLEEP
    +
+Notice that WAKE.UP has a dot between the WAKE and UP. The dot has no particular +meaning to the Forth compiler. I simply used a dot to connect the two words +together to make one word. Forth word names can have any combination of +letters, numbers, or punctuation. We will encounter words with names like: +
    +
     ." #S SWAP ! @ ACCEPT . *
    +
+They are all called words. The word $%%-GL7OP is a legal +Forth name, although not a very good one. It is up to the programmer to +name words in a sensible manner. + +

Now it is time to run your Forth and begin experimenting. Please consult +the manual for your Forth for instructions on how to run it. +

+Stack Manipulation

+The Forth language is based on the concept of a stack. Imagine a +stack of blocks with numbers on them. You can add or remove numbers from +the top of the stack. You can also rearrange the order of the numbers. +Forth uses several stacks. The DataStack is the one used for passing +data between Forth words so we will concentrate our attention there. The +Return Stack is another Forth stack that is primarily for internal +system use. In this tutorial, when we refer to the "stack," we will be +referring to the Data Stack. + +

The stack is initially empty. To put some numbers on the stack, enter: +

    +
    23 7 9182
    +
+Let's now print the number on top of the stack using the Forth word ' . +', which is pronounced " dot ". This is a hard word to write about in a +manual because it is a single period. + +

Enter: .  + +

You should see the last number you entered, 9182 , printed. Forth has +a very handy word for showing you what's on the stack. It is .S +, which is pronounced "dot S". The name was constructed from "dot" for +print, and "S" for stack. (PForth will automatically print the stack after +every line if the TRACE-STACK variable is set to TRUE.) If you enter: +

    +
    .S
    +
+you will see your numbers in a list. The number at the far right is the +one on top of the stack. + +

You will notice that the 9182 is not on the stack. The word ' . ' removes +the number on top of the stack before printing it. In contrast, ' .S ' +leaves the stack untouched. + +

We have a way of documenting the effect of words on the stack with a +stack diagram. A stack diagram is contained in parentheses. In Forth, +the parentheses indicate a comment. In the examples that follow, you do +not need to type in the comments. When you are programming, of course, +we encourage the use of comments and stack diagrams to make your code more +readable. In this manual, we often indicate stack diagrams in bold text +like the one that follows. Do not type these in. The stack diagram for +a word like ' . ' would be: +

. ( N -- , print number on top of stack )
+The symbols to the left of -- describe the parameters that a word expects +to process. In this example, N stands for any integer number. To the right +of --, up to the comma, is a description of the stack parameters when the +word is finished, in this case there are none because 'dot' "eats" the +N that was passed in. (Note that the stack descriptions are not necessary, +but they are a great help when learning other peoples programs.) + +

The text following the comma is an English description of the word. +You will note that after the -- , N is gone. You may be concerned about +the fact that there were other numbers on the stack, namely 23 and 7 . +The stack diagram, however, only describes the portion of the stack that +is affected by the word. For a more detailed description of the stack diagrams, +there is a special section on them in this manual right before the main +glossary section. + +

Between examples, you will probably want to clear the stack. If you +enter 0SP, pronounced "zero S P", then the stack will be cleared. + +

Since the stack is central to Forth, it is important to be able to alter +the stack easily. Let's look at some more words that manipulate the stack. +Enter: +

    +
    0SP .S \ That's a 'zero' 0, not an 'oh' O.
+777 DUP .S
    +
+You will notice that there are two copies of 777 on the stack. The word +DUP duplicates the top item on the stack. This is useful when you +want to use the number on top of the stack and still have a copy. The stack +diagram for DUP would be: +
DUP ( n -- n n , DUPlicate top of stack )
+Another useful word, is SWAP. Enter: +
    +
    0SP 
+23 7 .S 
+SWAP .S 
+SWAP .S
    +
+The stack diagram for SWAP would be: +
SWAP ( a b -- b a , swap top two items on stack )
+Now enter: +
    +
    OVER .S
+OVER .S
    +
+The word OVER causes a copy of the second item on the stack to leapfrog +over the first. It's stack diagram would be: + +

OVER ( a b -- a b a , copy second item on stack ) + +

Here is another commonly used Forth word: + +

DROP ( a -- , remove item from the stack ) + +

Can you guess what we will see if we enter: +

    +
    0SP 11 22 .S
+DROP .S
    +
+Another handy word for manipulating the stack is ROT. Enter: +
    +
    0SP
+11 22 33 44 .S
+ROT .S
    +
+The stack diagram for ROT is, therefore: + +

ROT ( a b c -- b c a , ROTate third item to top )  + +

You have now learned the more important stack manipulation words. You +will see these in almost every Forth program. I should caution you that +if you see too many stack manipulation words being used in your code then +you may want to reexamine and perhaps reorganize your code. You will often +find that you can avoid excessive stack manipulations by using local +or global VARIABLES which will be discussed later. + +

If you want to grab any arbitrary item on the stack, use PICK +. Try entering: +

    +
    0SP
+14 13 12 11 10
+3 PICK . ( prints 13 )
+0 PICK . ( prints 10 )
+4 PICK .
    +
+PICK makes a copy of the Nth item on the stack. The numbering starts with +zero, therefore: +
    0 PICK is equivalent to DUP +
    1 PICK is equivalent to OVER 
+PICK ( ... v3 v2 v1 v0 N -- ... v3 v2 v1 v0 vN )  + +

(Warning. The Forth-79 and FIG Forth standards differ from the ANS and +Forth '83 standard in that their PICK numbering starts with one, not zero.) + +

I have included the stack diagrams for some other useful stack manipulation +words. Try experimenting with them by putting numbers on the stack and +calling them to get a feel for what they do. Again, the text in parentheses +is just a comment and need not be entered. + +

DROP ( n -- , remove top of stack )  + +

?DUP ( n -- n n | 0 , duplicate only if non-zero, '|' means OR +)  + +

-ROT ( a b c -- c a b , rotate top to third position )  + +

2SWAP ( a b c d -- c d a b , swap pairs )  + +

2OVER ( a b c d -- a b c d a b , leapfrog pair )  + +

2DUP ( a b -- a b a b , duplicate pair )  + +

2DROP ( a b -- , remove pair )  + +

NIP ( a b -- b , remove second item from stack )  + +

TUCK ( a b -- b a b , copy top item to third position )  +

+Problems:

+Start each problem by entering: +
    +
    0SP 11 22 33
    +
+Then use the stack manipulation words you have learned to end up with the +following numbers on the stack: +
    +
    1) 11 33 22 22
    + +
    2) 22 33
    + +
    3) 22 33 11 11 22
    + +
    4) 11 33 22 33 11
    + +
    5) 33 11 22 11 22
    +
+Answers to the problems can be found +at the end of this tutorial. +

+Arithmetic

+Great joy can be derived from simply moving numbers around on a stack. +Eventually, however, you'll want to do something useful with them. This +section describes how to perform arithmetic operations in Forth. + +

The Forth arithmetic operators work on the numbers currently on top +of the stack. If you want to add the top two numbers together, use the +Forth word + , pronounced "plus". Enter: +

    +
    2 3 + .
+2 3 + 10 + .
    +
+This style of expressing arithmetic operations is called Reverse Polish +Notation, or RPN. It will already be familiar to those of you +with HP calculators. In the following examples, I have put the algebraic +equivalent representation in a comment. + +

Some other arithmetic operators are - * / . Enter: +

    +
    30 5 - . ( 25=30-5 )
+30 5 / . ( 6=30/5 )
+30 5 * . ( 150=30*5 )
+30 5 + 7 / . \ 5=(30+5)/7
    +
+Some combinations of operations are very common and have been coded in +assembly language for speed. For example, 2* is short for 2 * . +You should use these whenever possible to increase the speed of your program. +These include: +
    +
    1+ 1- 2+ 2- 2* 2/
    +
+Try entering: +
    +
    10 1- .
+7 2* 1+ . ( 15=7*2+1 )
    +
+One thing that you should be aware of is that when you are doing division +with integers using / , the remainder is lost. Enter: +
    +
    15 5 / .
+17 5 / .
    +
+This is true in all languages on all computers. Later we will examine /MOD +and MOD which do give the remainder. +

+Defining a New Word

+It's now time to write a small program in Forth. You can do this +by defining a new word that is a combination of words we have already learned. +Let's define and test a new word that takes the average of two numbers. +
+We will make use of two new words, : ( "colon"), and ; ( +"semicolon") . These words start and end a typical Forth definition. +Enter:
+ +
    +
    : AVERAGE ( a b -- avg ) + 2/ ;
    +
+Congratulations. You have just written a Forth program. Let's look more +closely at what just happened. The colon told Forth to add a new word to +its list of words. This list is called the Forth dictionary. The name of +the new word will be whatever name follows the colon. Any Forth words entered +after the name will be compiled into the new word. This continues until +the semicolon is reached which finishes the definition. + +

Let's test this word by entering: +

    +
    10 20 AVERAGE . ( should print 15 )
    +
+Once a word has been defined, it can be used to define more words. Let's +write a word that tests our word.. Enter: +
    +
    : TEST ( --) 50 60 AVERAGE . ;
+TEST
    +
+Try combining some of the words you have learned into new Forth definitions +of your choice. If you promise not to be overwhelmed, you can get a list +of the words that are available for programming by entering: +
    +
    WORDS
    +
+Don't worry, only a small fraction of these will be used directly in your +programs. +

+More Arithmetic

+When you need to know the remainder of a divide operation. /MOD will return +the remainder as well as the quotient. the word MOD will only return the +remainder. Enter: +
    +
    0SP
+53 10 /MOD .S
+0SP
+7 5 MOD .S
    +
+Two other handy words are MIN and MAX . They accept two numbers +and return the MINimum or MAXimum value respectively. Try entering the +following: +
    +
    56 34 MAX .
+56 34 MIN .
+-17 0 MIN .
    +
+Some other useful words are: + +

ABS ( n -- abs(n) , absolute value of n )  + +

NEGATE ( n -- -n , negate value, faster then -1 * )  + +

LSHIFT ( n c -- n<<c , left shift of n )  + +

RSHIFT ( n c -- n>>c , logical right shift of n )  + +

ARSHIFT ( n c -- n>>c ) , arithmetic right shift of n )  + +

ARSHIFT or LSHIFT can be used if you have to multiply quickly by a power +of 2 . A right shift is like doing a divide by 2. This is often faster +than doing a regular multiply or divide. Try entering: +

    +
    : 256* 8 LSHIFT ;
+3 256* .
    +
+ +

+Arithmetic Overflow

+If you are having problems with your calculation overflowing the 32-bit +precision of the stack, then you can use */ . This produces an intermediate +result that is 64 bits long. Try the following three methods of doing the +same calculation. Only the one using */ will yield the correct answer, +5197799. +
    +
    34867312 99154 * 665134 / .
+34867312 665134 / 99154 * .
+34867312 99154 665134 */ .
    +
+ +

+Convert Algebraic +Expressions to Forth

+How do we express complex algebraic expressions in Forth? For example: +20 + (3 * 4) + +

To convert this to Forth you must order the operations in the order +of evaluation. In Forth, therefore, this would look like: +

    +
    3 4 * 20 +
    +
+Evaluation proceeds from left to right in Forth so there is no ambiguity. +Compare the following algebraic expressions and their Forth equivalents: +(Do not enter these!) +
    +
    (100+50)/2 ==> 100 50 + 2/
+((2*7) + (13*5)) ==> 2 7 * 13 5 * +
    +
+If any of these expressions puzzle you, try entering them one word at a +time, while viewing the stack with .S . +

+Problems:

+Convert the following algebraic expressions to their equivalent Forth expressions. +(Do not enter these because they are not Forth code!) +
    +
    (12 * ( 20 - 17 ))
    + +
    (1 - ( 4 * (-18) / 6) )
    + +
    ( 6 * 13 ) - ( 4 * 2 * 7 )
    +
+Use the words you have learned to write these new words: +
    +
    SQUARE ( N -- N*N , calculate square )
    + +
    DIFF.SQUARES ( A B -- A*A-B*B , difference of squares )
    + +
    AVERAGE4 ( A B C D -- [A+B+C+D]/4 )
    + +
    HMS>SECONDS ( HOURS MINUTES SECONDS -- TOTAL-SECONDS , convert )
    +
+Answers to the problems can be found +at the end of this tutorial. +

+Character Input and Output

+The numbers on top of the stack can represent anything. The top number +might be how many blue whales are left on Earth or your weight in kilograms. +It can also be an ASCII character. Try entering the following: +
    +
    72 EMIT 105 EMIT
    +
+You should see the word "Hi" appear before the OK. The 72 is an ASCII 'H' +and 105 is an 'i'. EMIT takes the number on the stack and outputs it as +a character. If you want to find the ASCII value for any character, you +can use the word ASCII . Enter: +
    +
    CHAR W .
+CHAR % DUP . EMIT
+CHAR A DUP .
+32 + EMIT
    +
+There is an ASCII chart in the back of this manual for a complete character +list. + +

Notice that the word CHAR is a bit unusual because its input comes not +from the stack, but from the following text. In a stack diagram, we represent +that by putting the input in angle brackets, <input>. Here is the stack +diagram for CHAR. + +

CHAR ( <char> -- char , get ASCII value of a character )  + +

Using EMIT to output character strings would be very tedious. Luckily +there is a better way. Enter: +

    +
    : TOFU ." Yummy bean curd!" ;
+TOFU
    +
+The word ." , pronounced "dot quote", will take everything up to +the next quotation mark and print it to the screen. Make sure you leave +a space after the first quotation mark. When you want to have text begin +on a new line, you can issue a carriage return using the word CR +. Enter: +
    +
    : SPROUTS ." Miniature vegetables." ;
+: MENU
+    CR TOFU CR SPROUTS CR
+;
+MENU
    +
+You can emit a blank space with SPACE . A number of spaces can be +output with SPACES . Enter: +
    +
    CR TOFU SPROUTS
+CR TOFU SPACE SPROUTS
+CR 10 SPACES TOFU CR 20 SPACES SPROUTS
    +
+For character input, Forth uses the word KEY which corresponds to +the word EMIT for output. KEY waits for the user to press a key then leaves +its value on the stack. Try the following. +
    +
    : TESTKEY ( -- )
+    ." Hit a key: " KEY CR
+    ." That = " . CR
+;
+TESTKEY
    +
+[Note: On some computers, the input if buffered so you will need to hit +the ENTER key after typing your character.] + +

EMIT ( char -- , output character )  + +

KEY ( -- char , input character )  + +

SPACE ( -- , output a space )  + +

SPACES ( n -- , output n spaces )  + +

CHAR ( <char> -- char , convert to ASCII )  + +

CR ( -- , start new line , carriage return )  + +

." ( -- , output " delimited text )  +

+
+
+Compiling from Files

+PForth can read read from ordinary text files so you can use any editor +that you wish to write your programs. +

+Sample Program

+Enter into your file, the following code. +
    +
    \ Sample Forth Code
+\ Author: your name
    + +
    : SQUARE ( n -- n*n , square number )
+    DUP *
+;
    + +
    : TEST.SQUARE ( -- )
+    CR ." 7 squared = "
+    7 SQUARE . CR
+;
    +
+Now save the file to disk. + +

The text following the \ character is treated as a comment. This +would be a REM statement in BASIC or a /*---*/ in 'C'. The text in parentheses +is also a comment. +

+Using INCLUDE

+"INCLUDE" in Forth means to compile from a file. + +

You can compile this file using the INCLUDE command. If you saved your +file as WORK:SAMPLE, then compile it by entering: +

    +
    INCLUDE SAMPLE.FTH
    +
+Forth will compile your file and tell you how many bytes it has added to +the dictionary. To test your word, enter: +
    +
    TEST.SQUARE
    +
+Your two words, SQUARE and TEST.SQUARE are now in the Forth dictionary. +We can now do something that is very unusual in a programming language. +We can "uncompile" the code by telling Forth to FORGET it. Enter: +
    +
    FORGET SQUARE
    +
+This removes SQUARE and everything that follows it, ie. TEST.SQUARE, from +the dictionary. If you now try to execute TEST.SQUARE it won't be found. + +

Now let's make some changes to our file and reload it. Go back into +the editor and make the following changes: (1) Change TEST.SQUARE to use +15 instead of 7 then (2) Add this line right before the definition of SQUARE: +

    +
    ANEW TASK-SAMPLE.FTH
    +
+Now Save your changes and go back to the Forth window. + +

You're probably wondering what the line starting with ANEW was +for. ANEW is always used at the beginning of a file. It defines a special +marker word in the dictionary before the code. The word typically has "TASK-" +as a prefix followed by the name of the file. When you ReInclude a file, +ANEW will automatically FORGET the old code starting after the ANEW statement. +This allows you to Include a file over and over again without having to +manually FORGET the first word. If the code was not forgotten, the dictionary +would eventually fill up. + +

If you have a big project that needs lots of files, you can have a file +that will load all the files you need. Sometimes you need some code to +be loaded that may already be loaded. The word INCLUDE? will only +load code if it isn't already in the dictionary. In this next example, +I assume the file is on the volume WORK: and called SAMPLE. If not, please +substitute the actual name. Enter: +

    +
    FORGET TASK-SAMPLE.FTH
+INCLUDE? SQUARE WORK:SAMPLE
+INCLUDE? SQUARE WORK:SAMPLE
    +
+Only the first INCLUDE? will result in the file being loaded. +

+Variables

+Forth does not rely as heavily on the use of variables as other compiled +languages. This is because values normally reside on the stack. There are +situations, of course, where variables are required. To create a variable, +use the word VARIABLE as follows: +
    +
    VARIABLE MY-VAR
    +
+This created a variable named MY-VAR . A space in memory is now reserved +to hold its 32-bit value. The word VARIABLE is what's known as a "defining +word" since it creates new words in the dictionary. Now enter: +
    +
    MY-VAR .
    +
+The number you see is the address, or location, of the memory that was +reserved for MY-VAR. To store data into memory you use the word ! +, pronounced "store". It looks like an exclamation point, but to a Forth +programmer it is the way to write 32-bit data to memory. To read the value +contained in memory at a given address, use the Forth word @ , pronounced +"fetch". Try entering the following: +
    +
    513 MY-VAR !
+MY-VAR @ .
    +
+This sets the variable MY-VAR to 513 , then reads the value back and prints +it. The stack diagrams for these words follows: + +

@ ( address -- value , FETCH value FROM address in memory )  + +

! ( value address -- , STORE value TO address in memory ) + +

VARIABLE ( <name> -- , define a 4 byte memory storage location) + +

A handy word for checking the value of a variable is ? , pronounced +"question". Try entering: +

    +
    MY-VAR ?
    +
+If ? wasn't defined, we could define it as: +
    +
    : ? ( address -- , look at variable )
+    @ .
+;
    +
+Imagine you are writing a game and you want to keep track of the highest +score. You could keep the highest score in a variable. When you reported +a new score, you could check it aginst the highest score. Try entering +this code in a file as described in the previous section: +
    +
    VARIABLE HIGH-SCORE
    + +
    : REPORT.SCORE ( score -- , print out score )
+    DUP CR ." Your Score = " . CR
+    HIGH-SCORE @ MAX ( calculate new high )
+    DUP ." Highest Score = " . CR
+    HIGH-SCORE ! ( update variable )
+;
    +
+Save the file to disk, then compile this code using the INCLUDE word. Test +your word as follows: +
    +
    123 REPORT.SCORE
+9845 REPORT.SCORE
+534 REPORT.SCORE
    +
+The Forth words @ and ! work on 32-bit quantities. Some Forths are "16-bit" +Forths. They fetch and store 16-bit quantities. Forth has some words that +will work on 8 and 16-bit values. C@ and C! work characters which are usually +for 8-bit bytes. The 'C' stands for "Character" since ASCII characters +are 8-bit numbers. Use W@ and W! for 16-bit "Words." + +

Another useful word is +! , pronounced "plus store." It adds +a value to a 32-bit value in memory. Try: +

    +
    20 MY-VAR !
+5 MY-VAR +!
+MY-VAR @ .
    +
+Forth also provides some other words that are similar to VARIABLE. Look +in the glossary for VALUE and ARRAY. Also look at the section on "local +variables" which are variables which only exist on the stack while +a Forth word is executing. + +

A word of warning about fetching and storing to memory: You have +now learned enough about Forth to be dangerous. The operation of a computer +is based on having the right numbers in the right place in memory. You +now know how to write new numbers to any place in memory. Since an address +is just a number, you could, but shouldn't, enter: +

    +
    73 253000 ! ( Do NOT do this. )
    +
+The 253000 would be treated as an address and you would set that memory +location to 73. I have no idea what will happen after that, maybe nothing. +This would be like firing a rifle through the walls of your apartment building. +You don't know who or what you are going to hit. Since you share memory +with other programs including the operating system, you could easily cause +the computer to behave strangely, even crash. Don't let this bother you +too much, however. Crashing a computer, unlike crashing a car, does not +hurt the computer. You just have to reboot. The worst that could happen +is that if you crash while the computer is writing to a disk, you could +lose a file. That's why we make backups. This same potential problem exists +in any powerful language, not just Forth. This might be less likely in +BASIC, however, because BASIC protects you from a lot of things, including +the danger of writing powerful programs. + +

Another way to get into trouble is to do what's called an "odd address +memory access." The 68000 processor arranges words and longwords, 16 and +32 bit numbers, on even addresses. If you do a @ or ! , or +W@ or W! , to an odd address, the 68000 processor will take +exception to this and try to abort. + +

Forth gives you some protection from this by trapping this exception +and returning you to the OK prompt. If you really need to access data on +an odd address, check out the words ODD@ and ODD! in the +glossary. C@ and C! work fine on both odd and even addresses. +

+Constants

+If you have a number that is appearing often in your program, we recommend +that you define it as a "constant." Enter: +
    +
    128 CONSTANT MAX_CHARS
+MAX_CHARS .
    +
+We just defined a word called MAX_CHARS that returns the value on the stack +when it was defined. It cannot be changed unless you edit the program and +recompile. Using CONSTANT can improve the readability of your programs +and reduce some bugs. Imagine if you refer to the number 128 very often +in your program, say 8 times. Then you decide to change this number to +256. If you globally change 128 to 256 you might change something you didn't +intend to. If you change it by hand you might miss one, especially if your +program occupies more than one file. Using CONSTANT will make it easy to +change. The code that results is equally as fast and small as putting the +numbers in directly. I recommend defining a constant for almost any number. +

+Logical Operators

+These next two sections are concerned with decision making. This first +section deals with answering questions like "Is this value too large?" +or "Does the guess match the answer?". The answers to questions like these +are either TRUE or FALSE. Forth uses a 0 to represent FALSE and +a -1 to represent TRUE. TRUE and FALSE have been capitalized because +they have been defined as Forth constants. Try entering: +
    +
    23 71 = .
+18 18 = .
    +
+You will notice that the first line printed a 0, or FALSE, and the second +line a -1, or TRUE. The equal sign in Forth is used as a question, not +a statement. It asks whether the top two items on the stack are equal. +It does not set them equal. There are other questions that you can ask. +Enter: +
    +
    23 198 < .
+23 198 > .
+254 15 > .
    +
+In California, the drinking age for alcohol is 21. You could write a simple +word now to help bartenders. Enter: +
    +
    : DRINK? ( age -- flag , can this person drink? )
+    20 >
+;
    + +
    20 DRINK? .
+21 DRINK? .
+43 DRINK? .
    +
+The word FLAG in the stack diagram above refers to a logical value. + +

Forth provides special words for comparing a number to 0. They are 0= +0> and 0< . Using 0> is faster than calling 0 and > separately. +Enter: +

    23 0> . ( print -1 ) +
    -23 0> . ( print 0 ) +
    23 0= . ( print 0 )
+For more complex decisions, you can use the Boolean operators OR +, AND , and NOT . OR returns a TRUE if either one or both +of the top two stack items are true. +
    +
    TRUE TRUE OR .
+TRUE FALSE OR .
+FALSE FALSE OR .
    +
+AND only returns a TRUE if both of them are true. +
    +
    TRUE TRUE AND .
+TRUE FALSE AND .
    +
+NOT reverses the value of the flag on the stack. Enter: +
    +
    TRUE .
+TRUE NOT .
    +
+Logical operators can be combined. +
    +
    56 3 > 56 123 < AND .
+23 45 = 23 23 = OR .
    +
+Here are stack diagrams for some of these words. See the glossary for a +more complete list. + +

< ( a b -- flag , flag is true if A is less than B ) + +

> ( a b -- flag , flag is true if A is greater than B ) + +

= ( a b -- flag , flag is true if A is equal to B ) + +

0= ( a -- flag , true if a equals zero ) + +

OR ( a b -- a||b , perform logical OR of bits in A and B ) + +

AND ( a b -- a&b , perform logical AND of bits in A and B +) + +

NOT ( flag -- opposite-flag , true if false, false if true ) +

+Problems:

+1) Write a word called LOWERCASE? that returns TRUE if the number on top +of the stack is an ASCII lowercase character. An ASCII 'a' is 97 . An ASCII +'z' is 122 . Test using the characters " A ` a q z { ". +
    +
    CHAR A LOWERCASE? . ( should print 0 )
+CHAR a LOWERCASE? . ( should print -1 )
    +
+Answers to the problems can be found +at the end of this tutorial. +

+Conditionals - IF ELSE THEN +CASE

+You will now use the TRUE and FALSE flags you learned to generate in the +last section. The "flow of control" words accept flags from the stack, +and then possibly "branch" depending on the value. Enter the following +code. +
    +
    : .L ( flag -- , print logical value )
+    IF ." True value on stack!"
+    ELSE ." False value on stack!"
+    THEN
+;
    + +
    0 .L
+FALSE .L
+TRUE .L
+23 7 < .L
    +
+You can see that when a TRUE was on the stack, the first part got executed. +If a FALSE was on the stack, then the first part was skipped, and the second +part was executed. One thing you will find interesting is that if you enter: +
    +
    23 .L
    +
+the value on the stack will be treated as true. The flow of control words +consider any value that does not equal zero to be TRUE. + +

The ELSE word is optional in the IF...THEN construct. +Try the following: +

    +
    : BIGBUCKS? ( ammount -- )
+    1000 >
+    IF ." That's TOO expensive!"
+    THEN
+;
    + +
    531 BIGBUCKS?
+1021 BIGBUCKS?
    +
+Many Forths also support a CASE statement similar to switch() in +'C'. Enter: +
    +
    : TESTCASE ( N -- , respond appropriately )
+    CASE
+        0 OF ." Just a zero!" ENDOF
+        1 OF ." All is ONE!" ENDOF
+        2 OF WORDS ENDOF
+        DUP . ." Invalid Input!"
+    ENDCASE CR
+;
    + +
    0 TESTCASE
+1 TESTCASE
+5 TESTCASE
    +
+See CASE in the glossary for more information. +

+Problems:

+1) Write a word called DEDUCT that subtracts a value from a variable containing +your checking account balance. Assume the balance is in dollars. Print +the balance. Print a warning if the balance is negative. +
    +
    VARIABLE ACCOUNT
    + +
    : DEDUCT ( n -- , subtract N from balance )
+    ????????????????????????????????? ( you fill this in )
+;
    + +
    300 ACCOUNT ! ( initial funds )
+40 DEDUCT ( prints 260 )
+200 DEDUCT ( print 60 )
+100 DEDUCT ( print -40 and give warning! )
    +
+Answers to the problems can be found +at the end of this tutorial. +

+Loops

+Another useful pair of words is BEGIN...UNTIL . These are used to +loop until a given condition is true. Try this: +
    +
    : COUNTDOWN  ( N -- )
+    BEGIN
+        DUP . CR       ( print number on top of stack )
+        1-  DUP  0<    ( loop until we go negative )
+    UNTIL
+;
    + +
    16 COUNTDOWN
    +
+This word will count down from N to zero. + +

If you know how many times you want a loop to execute, you can use the +DO...LOOP construct. Enter: +

    +
    : SPELL
+    ." ba"
+    4 0 DO
+        ." na"
+    LOOP
+;
    +
+This will print "ba" followed by four occurrences of "na". The ending value +is placed on the stack before the beginning value. Be careful that you +don't pass the values in reverse. Forth will go "the long way around" which +could take awhile. The reason for this order is to make it easier to pass +the loop count into a word on the stack. Consider the following word for +doing character graphics. Enter: +
    +
    : PLOT# ( n -- )
+    0 DO
+        [CHAR] - EMIT
+    LOOP CR
+;
    + +
    CR 9 PLOT# 37 PLOT#
    +
+If you want to access the loop counter you can use the word I . Here is +a simple word that dumps numbers and their associated ASCII characters. +
    +
    : .ASCII ( end start -- , dump characters )
+    DO
+        CR I . I EMIT
+    LOOP CR
+;
    + +
    80 64 .ASCII
    +
+If you want to leave a DO LOOP before it finishes, you can use the word +LEAVE. Enter: +
    +
    : TEST.LEAVE  ( -- , show use of leave )
+    100 0
+    DO
+        I . CR  \ print loop index
+        I 20 >  \ is I over 20
+        IF
+            LEAVE
+        THEN
+    LOOP
+;
+TEST.LEAVE  \ will print 0 to 20
    +
+Please consult the manual to learn about the following words +LOOP +and RETURN . FIXME + +

Another useful looping construct is the BEGIN WHILE REPEAT loop. +This allows you to make a test each time through the loop before you actually +do something. The word WHILE will continue looping if the flag on the stack +is True. Enter: +

    +
    : SUM.OF.N ( 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
+;
    + +
    4 SUM.OF.N    \ prints 10   ( 1+2+3+4 )
    +
+ +

+Problems:

+1) Rewrite SUM.OF.N using a DO LOOP. + +

2) Rewrite SUM.OF.N using BEGIN UNTIL. + +

3) For bonus points, write SUM.OF.N without using any looping or conditional +construct! + +

Answers to the problems can be found +at the end of this tutorial. +

+Text Input and Output

+You learned earlier how to do single character I/O. This section concentrates +on using strings of characters. You can embed a text string in your program +using S". Note that you must follow the S" by one space. The text string +is terminated by an ending " .Enter: +
    +
    : TEST S" Hello world!" ;
+TEST .S
    +
+Note that TEST leaves two numbers on the stack. The first number is the +address of the first character. The second number is the number of characters +in the string. You can print the characters of the string as follows. +
    +
    TEST DROP       \ get rid of number of characters
+DUP C@ EMIT     \ prints first character, 'H'
+CHAR+ DUP C@ EMIT  \ prints second character, 'e'
+\ and so on
    +
+CHAR+ advances the address to the next character. You can print the entire +string using TYPE. +
    +
    TEST  TYPE
+TEST  2/  TYPE   \ print half of string
    +
+It would be nice if we could simply use a single address to describe a +string and not have to pass the number of characters around. 'C' does this +by putting a zero at the end of the string to show when it ends. Forth +has a different solution. A text string in Forth consists of a character +count in the first byte, followed immediately by the characters themselves. +This type of character string can be created using the Forth word C" , +pronounced 'c quote'. Enter: +
    +
    : T2 C" Greetings Fred" ;
+T2 .
    +
+The number that was printed was the address of the start of the string. +It should be a byte that contains the number of characters. Now enter: +
    +
    T2 C@ .
    +
+You should see a 14 printed. Remember that C@ fetches one character/byte +at the address on the stack. You can convert a counted Forth string to +an address and count using COUNT. +
    +
    T2 COUNT .S
+TYPE
    +
+The word COUNT extracts the number of characters and their starting +address. COUNT will only work with strings of less than 256 characters, +since 255 is the largest number that can be stored in the count byte. TYPE +will, however, work with longer strings since the length is on the stack. +Their stack diagrams follow: + +

CHAR+ ( address -- address' , add the size of one character ) + +

COUNT ( $addr -- addr #bytes , extract string information )  + +

TYPE ( addr #bytes -- , output characters at addr ) + +

The $addr is the address of a count byte. The dollar sign is often used +to mark words that relate to strings. + +

You can easily input a string using the word ACCEPT. (You may +want to put these upcoming examples in a file since they are very handy.) +The word ACCEPT receives characters from the keyboard and places +them at any specified address. ACCEPT takes input characters until +a maximum is reached or an end of line character is entered. ACCEPT +returns the number of characters entered. You can write a word for +entering text. Enter: +

    +
    : INPUT$ ( -- $addr )
+    PAD  1+ ( leave room for byte count )
+    127 ACCEPT ( recieve a maximum of 127 chars )
+    PAD C! ( set byte count )
+    PAD ( return address of string )
+;
    + +
    INPUT$ COUNT TYPE
    +
+Enter a string which should then be echoed. You could use this in a program +that writes form letters. +
    +
    : FORM.LETTER ( -- )
+    ." Enter customer's name." CR
+    INPUT$
+    CR ." Dear " DUP COUNT TYPE CR
+    ." Your cup that says " COUNT TYPE
+    ." is in the mail!" CR
+;
    +
+ACCEPT ( addr maxbytes -- numbytes , input text, save at address +)  + +

You can use your word INPUT$ to write a word that will read a number +from the keyboard. Enter: +

    +
    : INPUT# ( -- N true | false )
+    INPUT$ ( get string )
+    NUMBER? ( convert to a string if valid )
+    IF DROP TRUE ( get rid of high cell )
+    ELSE FALSE
+    THEN
+;
    +
+This word will return a single-precision number and a TRUE, or it will +just return FALSE. The word NUMBER? returns a double precision number +if the input string contains a valid number. Double precision numbers are +64-bit so we DROP the top 32 bits to get a single-precision 32 bit number. +

+Changing Numeric Base

+Our numbering system is decimal, or "base 10." This means that a number +like 527 is equal to (5*100 + 2*10 + 7*1). The use of 10 for the numeric +base is a completely arbitrary decision. It no doubt has something to do +with the fact that most people have 10 fingers (including thumbs). The +Babylonians used base 60, which is where we got saddled with the concept +of 60 minutes in an hour. Computer hardware uses base 2, or "binary". A +computer number like 1101 is equal to (1*8 + 1*4 + 0*2 + 1*1). If you add +these up, you get 8+4+1=13 . A 10 in binary is (1*2 + 0*1), or 2. Likewise +10 in any base N is N . + +

Forth makes it very easy to explore different numeric bases because +it can work in any base. Try entering the following: +

    +
    DECIMAL 6 BINARY .
+1 1 + .
+1101 DECIMAL .
    +
+Another useful numeric base is hexadecimal. which is base 16. One +problem with bases over 10 is that our normal numbering system only has +digits 0 to 9. For hex numbers we use the letters A to F for the digits +10 to 15. Thus the hex number 3E7 is equal to (3*256 + 14*16 + 7*1). Try +entering: +
    +
    DECIMAL 12 HEX .  \ print C
+DECIMAL 12 256 *   7 16 * +  10 + .S
+DUP BINARY .
+HEX .
    +
+A variable called BASE is used to keep track of the current numeric +base. The words HEX , DECIMAL , and BINARY work by changing +this variable. You can change the base to anything you want. Try: +
    +
    7 BASE !
+6 1 + .
+BASE @ . \ surprise!
    +
+You are now in base 7 . When you fetched and printed the value of BASE, +it said 10 because 7, in base 7, is 10. + +

PForth defines a word called .HEX that prints a number as hexadecimal +regardless of the current base. +

    +
    DECIMAL 14 .HEX
    +
+You could define a word like .HEX for any base. What is needed is a way +to temporarily set the base while a number is printed, then restore it +when we are through. Try the following word: +
    +
    : .BIN ( N -- , print N in Binary )
+    BASE @ ( save current base )
+    2 BASE ! ( set to binary )
+    SWAP . ( print number )
+    BASE ! ( restore base )
+;
    + +
    DECIMAL
+22 .BIN
+22 .
    +
+ +

+Answers to Problems

+If your answer doesn't exactly match these but it works, don't fret. In +Forth, there are usually many ways to the same thing. +

+Stack Manipulations

+ +
    +
    1) SWAP DUP
+2) ROT DROP
+3) ROT DUP 3 PICK
+4) SWAP OVER 3 PICK
+5) -ROT 2DUP
    +
+ +

+Arithmetic

+ +
    +
    (12 * (20 - 17)) ==> 20 17 - 12 *
+(1 - (4 * (-18) / 6)) ==> 1 4 -18 * 6 / -
+(6 * 13) - (4 * 2 * 7) ==> 6 13 * 4 2 * 7 * -
    + +
    : SQUARE ( N -- N*N ) 
+    DUP *
+;
    + +
    : DIFF.SQUARES ( A B -- A*A-B*B )
+SWAP SQUARE 
+SWAP SQUARE - 
+;
    + +
    : AVERAGE4 ( A B C D -- [A+B+C+D]/4 )
+    + + + ( add'em up )
+    -2 ashift ( divide by four the fast way, or 4 / )
+;
    + +
    +: HMS>SECONDS ( HOURS MINUTES SECONDS -- TOTAL-SECONDS )
    + +
        -ROT SWAP ( -- seconds minutes hours ) +
        60 * + ( -- seconds total-minutes ) +
        60 * + ( -- seconds ) +
    ; 
+ +

+Logical Operators

+ +
    +
    : LOWERCASE? ( CHAR -- FLAG , true if lowercase )
+    DUP 123 <
+    SWAP 96 > AND
+;
    +
+ +

+Conditionals

+ +
    +
    : DEDUCT ( n -- , subtract from account )
+    ACCOUNT @ ( -- n acc 
+    SWAP - DUP ACCOUNT ! ( -- acc' , update variable )
+    ." Balance = $" DUP . CR ( -- acc' )
+    0< ( are we broke? )
+    IF ." Warning!! Your account is overdrawn!" CR
+    THEN
+;
    +
+ +

+Loops

+ +
    +
    : SUM.OF.N.1 ( 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.2 ( N -- SUM[N] )
+    0 \ starting value of SUM
+    BEGIN ( -- N' SUM )
+        OVER +
+        SWAP 1- SWAP
+        OVER 0<
+    UNTIL
+    SWAP DROP
+;
    + +
    : SUM.OF.N.3 ( NUM -- SUM[N] , Gauss' method )
+    DUP 1+   \ SUM(N) = N*(N+1)/2
+    * 2/
+;
    +
+Back to pForth Home Page + + diff --git a/docs/pfmanual.txt b/docs/pfmanual.txt new file mode 100644 index 0000000..79b5941 --- /dev/null +++ b/docs/pfmanual.txt @@ -0,0 +1,223 @@ +UNFINISHED + +Manual for pForth - a Portable Forth + +The best reference for pForth is an ANSI Forth manual. pForth +is built on an ANSI model. There are, however, some non-standard +words which are documented here: + +{ ( i*x -- , declare local variables ) + Local variables are only usable within a colon definition. + They are taken from the stack as they are defined. + They are self fetching. Use -> to set them. + They help you avoid excessive stack dancing. + Here is an example: + + : SUMSQ { aa bb -- } + aa aa * + bb bb * + + ; + 3 4 SUMSQ . ( prints 25 ) + + Here is an example of using a temporary variable: + + : SUMN { num | sum -- , sum up integers the dumb way } + 0 -> sum \ uses -> to set local variable + num 0 + DO i sum + + -> sum \ write current TOS to sum + LOOP + sum + ; + +:STRUCT ( -- , defines a 'C' like structure ) + See end of "c_struct.fth" for an example. + +ANEW ( -- ) + Forgets NAME if it is already defined. + Then defines NAME. Put at beginning of file + so that file can be INCLUDEd multiple times + without redefining the contents. + +CASE OF ENDOF ENDCASE in the typical fashion. See "case.fth" + +CHOOSE ( range -- random , pick random number, 0...range-1 ) + +IF ELSE THEN DO LOOP etc. can be used outside colon definitions! + +IF.FORGOTTEN ( -- , executes NAME if forgotten ) + Put this at the end of a file to automatically + call your cleanup word if the code is forgotten. + +INCLUDE ( -- , interpret from file ) + Write your Forth programs in a file then load them + using INCLUDE. + + INCLUDE myprog.fth + +INCLUDE? ( -- , interpret from file if needed ) + INCLUDE the given file only if the named word is undefined. + The name should be of a Forth word defined in the file. + See "load_pforth.fth" for an example. + + INCLUDE? DO.MY.PROG myprog.fth + +MAP ( -- , dumps info about dictionary ) + +Other words + +FP.INIT +FP.TERM +F>S +S>F +EXISTS? +STRINGS= + +S@ +S! +;STRUCT +:STRUCT +STRUCT +ULONG +RPTR +APTR +FLPT +USHORT +UBYTE +LONG +SHORT +BYTE +BYTES +SIZEOF() +OB.STATS? +OB.STATS +OB.FINDIT +OB.MEMBER +}UNION +}UNION{ +UNION{ +OB.MAKE.MEMBER +MAP +.HEX +.DEC +.BIN +ARRAY +WARRAY +BARRAY +-2SORT +2SORT +WCHOOSE +CHOOSE +RANDOM +RAND-SEED +MSEC +MSEC-DELAY +VALUE +-> +TO + +-- strings -- +TEXTROM +$ROM +$APPEND.CHAR +INDEX +$MATCH? +TEXT=? +TEXT= +$= +COMPARE +$ARRAY + +-- case -- +ENDCASE ENDOF RANGEOF (RANGEOF?) OF +?OF CASE OF-DEPTH CASE-DEPTH + +TOLOWER +@EXECUTE +>NAME +CLOSEST-XT +CLOSEST-NFA +TAB +TAB-WIDTH +.HX +$ +CR? +#COLS +?PAUSE +ABORT" +WARNING" +CELL* +<< +>> + +TASK-MISC1.FTH .R . (.) +(NUMBER?) +((NUMBER?)) NUM_TYPE_DOUBLE NUM_TYPE_SINGLE +NUM_TYPE_BAD >NUMBER DIGIT + +ANEW FORGET [FORGET] IF.FORGOTTEN + +SAVE-FORTH +INCLUDE? +RI +INCLUDE +$INCLUDE +$APPEND +LWORD +PARSE +PARSE-WORD +PLACE + +WHAT'S +IS +DEFER + +>NEWLINE +0SP +SPACES +SPACE +RECURSE +UNLOOP + +-- user stack -- +0USP +US@ US> >US USTACK 0STACKP STACK@ +STACK> >STACK :STACK + +-- address storage and translation -- +A, A@ A! +IF.REL->USE IF.USE->REL +X! X@ +>ABS >REL REL->USE USE->REL +BODY> >BODY N>LINK CODE> >CODE NAME> +NAMEBASE+ CODEBASE NAMEBASE +N>NEXTLINK >NAME +PREVNAME NAME> + + +ID. + +OFF ON +TRACE-STACK +TRACE-LEVEL +TRACE-FLAGS + +HEADERS-BASE +HEADERS-PTR +ECHO +CODE-BASE + +POP-SOURCE-ID +PUSH-SOURCE-ID +SOURCE-ID +SET-SOURCE +SOURCE + +LOADSYS + +FLUSHEMIT +FINDNFA +BYE +BODY_OFFSET +BAIL +ARSHIFT diff --git a/filefind.fth b/filefind.fth new file mode 100644 index 0000000..8d0dd4a --- /dev/null +++ b/filefind.fth @@ -0,0 +1,102 @@ +\ @(#) 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 + +: ODD@ { addr | val -- val , fetch from odd aligned address, IBM PCs??? } + 4 0 + DO + addr i + c@ + val 8 lshift or -> val + LOOP + val +; + +\ 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+ odd@ + 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 +; + diff --git a/floats.fth b/floats.fth new file mode 100644 index 0000000..b3afe23 --- /dev/null +++ b/floats.fth @@ -0,0 +1,497 @@ +\ @(#) 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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 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 +; + +\ Convert between single precision 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 0 s>f true 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 char + 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 + 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] diff --git a/forget.fth b/forget.fth new file mode 100644 index 0000000..4b872ac --- /dev/null +++ b/forget.fth @@ -0,0 +1,97 @@ +\ @(#) forget.fth 98/01/26 1.2 +\ forget.fth +\ +\ forget part of dictionary +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 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 +; diff --git a/go.bat b/go.bat new file mode 100644 index 0000000..8146ef0 --- /dev/null +++ b/go.bat @@ -0,0 +1 @@ +bincmp -m10 pforth.dic pforth_mac.dic diff --git a/loadp4th.fth b/loadp4th.fth new file mode 100644 index 0000000..8ffc1be --- /dev/null +++ b/loadp4th.fth @@ -0,0 +1,47 @@ +\ @(#) loadp4th.fth 98/01/28 1.3 +\ Load various files needed by PForth +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +include? forget forget.fth +include? >number numberio.fth +include? task-misc1.fth misc1.fth +include? case case.fth +include? $= strings.fth +include? privatize private.fth +include? (local) ansilocs.fth +include? { locals.fth +include? fm/mod math.fth +include? task-misc2.fth misc2.fth +include? catch catch.fth +include? task-quit.fth quit.fth + +\ useful but optional stuff follows -------------------- + +include? [if] condcomp.fth + +\ load floating point support if basic support is in kernel +exists? F* + [IF] include? task-floats.fth floats.fth + [THEN] + +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 + +map + diff --git a/locals.fth b/locals.fth new file mode 100644 index 0000000..8beddab --- /dev/null +++ b/locals.fth @@ -0,0 +1,69 @@ +\ @(#) $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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-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 + 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 + +\ 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 + 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 +; diff --git a/math.fth b/math.fth new file mode 100644 index 0000000..e1852e2 --- /dev/null +++ b/math.fth @@ -0,0 +1,89 @@ +\ @(#) math.fth 98/01/26 1.2 +\ Extended Math routines +\ FM/MOD SM/REM +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-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 +; diff --git a/member.fth b/member.fth new file mode 100644 index 0000000..6aeb36e --- /dev/null +++ b/member.fth @@ -0,0 +1,155 @@ +\ @(#) 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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 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. + 32 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 ) + +4 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 3 and 0= ( multiple of four? ) + 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 ( -- ) -4 bytes ; \ relative relocatable pointer 00001 +: ULONG ( -- ) long ; + +: STRUCT ( -- , define a structure as an ivar ) + [compile] sizeof() bytes +; diff --git a/mipsBuild/pforth.bld b/mipsBuild/pforth.bld new file mode 100644 index 0000000..65898d4 --- /dev/null +++ b/mipsBuild/pforth.bld @@ -0,0 +1,79 @@ +#!build +default: + program + :check=bounds + :check=assignbound + :check=nilderef + :check=switch + :check=zerodivide + :check=usevariable + :check=return + :mips_option=littleendian + :mips_cputype=r5000 + :defines=PF_SUPPORT_FLOAT +e:\nomad\pforth\csrc\pf_all.h + include_file +e:\nomad\pforth\csrc\pf_cglue.c + C +e:\nomad\pforth\csrc\pf_cglue.h + include_file +e:\nomad\pforth\csrc\pf_clib.c + C +e:\nomad\pforth\csrc\pf_clib.h + include_file +e:\nomad\pforth\csrc\pf_core.c + C +e:\nomad\pforth\csrc\pf_core.h + include_file +e:\nomad\pforth\csrc\pf_float.h + include_file +e:\nomad\pforth\csrc\pf_guts.h + include_file +e:\nomad\pforth\csrc\pf_host.h + include_file +e:\nomad\pforth\csrc\pf_inner.c + C +e:\nomad\pforth\csrc\pf_io.c + C +e:\nomad\pforth\csrc\pf_io.h + include_file +e:\nomad\pforth\csrc\pf_mac.h + include_file +e:\nomad\pforth\csrc\pf_main.c + C +e:\nomad\pforth\csrc\pf_mem.c + C +e:\nomad\pforth\csrc\pf_mem.h + include_file +e:\nomad\pforth\csrc\pf_save.c + C +e:\nomad\pforth\csrc\pf_save.h + include_file +e:\nomad\pforth\csrc\pf_text.c + C + :c_option=needprototype + :c_mode=ansi +e:\nomad\pforth\csrc\pf_text.h + include_file +e:\nomad\pforth\csrc\pf_types.h + include_file +e:\nomad\pforth\csrc\pf_unix.h + include_file +e:\nomad\pforth\csrc\pf_win32.h + include_file +e:\nomad\pforth\csrc\pf_words.c + C +e:\nomad\pforth\csrc\pf_words.h + include_file +e:\nomad\pforth\csrc\pfcompfp.h + include_file +e:\nomad\pforth\csrc\pfcompil.c + C +e:\nomad\pforth\csrc\pfcompil.h + include_file +e:\nomad\pforth\csrc\pfcustom.c + C +e:\nomad\pforth\csrc\pfinnrfp.h + include_file +e:\nomad\pforth\csrc\pforth.h + include_file diff --git a/misc1.fth b/misc1.fth new file mode 100644 index 0000000..53728b6 --- /dev/null +++ b/misc1.fth @@ -0,0 +1,150 @@ +\ @(#) misc1.fth 98/01/26 1.2 +\ miscellaneous words +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-misc1.fth +decimal + +: >> rshift ; +: << lshift ; +: CELL* ( n -- n*cell ) 2 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 abort + 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 + 32 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 +; + +\ Vocabulary listing +: WORDS ( -- ) + 0 latest + BEGIN dup 0<> + WHILE dup id. tab cr? ?pause + prevname + swap 1+ swap + REPEAT drop + cr . ." words" cr +; + +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 +; diff --git a/misc2.fth b/misc2.fth new file mode 100644 index 0000000..cd4ccbf --- /dev/null +++ b/misc2.fth @@ -0,0 +1,232 @@ +\ @(#) misc2.fth 98/01/26 1.2 +\ Utilities for PForth extracted from HMSL +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 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 + +decimal +create msec-delay 1000 , ( default for SUN ) +: msec ( #msecs -- ) + 0 + do msec-delay @ 0 + do loop + loop +; + +: 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 + $ FFFFFF00 or + ELSE + $ 000000FF and + THEN +; +: W->S ( 16bit-signed -- 32bit-signed ) + dup $ 8000 and + if + $ FFFF0000 or + ELSE + $ 0000FFFF 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 +; + diff --git a/numberio.fth b/numberio.fth new file mode 100644 index 0000000..f17f4d7 --- /dev/null +++ b/numberio.fth @@ -0,0 +1,204 @@ +\ @(#) numberio.fth 98/01/26 1.2 +\ numberic_io.fth +\ +\ numeric conversion +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-numeric_io.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 + +\ 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 drop NUM_TYPE_BAD exit THEN \ any chars? + +\ prepare for >number + 0 0 2swap ( 0 0 c-addr cnt ) + +\ check for '-' at beginning, skip if present + over c@ ascii - = \ is it a '-' + dup >r \ save flag + IF 1- >r 1+ r> ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign ) + THEN +\ + >number 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 +; diff --git a/pcbuild/pForth.dsp b/pcbuild/pForth.dsp new file mode 100644 index 0000000..c2de9ee --- /dev/null +++ b/pcbuild/pForth.dsp @@ -0,0 +1,316 @@ +# Microsoft Developer Studio Project File - Name="pForth" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 5.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Console Application" 0x0103 + +CFG=pForth - Win32 MakeDic +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "pForth.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "pForth.mak" CFG="pForth - Win32 MakeDic" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "pForth - Win32 Release" (based on "Win32 (x86) Console Application") +!MESSAGE "pForth - Win32 Debug" (based on "Win32 (x86) Console Application") +!MESSAGE "pForth - Win32 MakeDic" (based on "Win32 (x86) Console Application") +!MESSAGE + +# Begin Project +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +RSC=rc.exe + +!IF "$(CFG)" == "pForth - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c +# ADD CPP /nologo /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c +# ADD BASE RSC /l 0x409 /d "NDEBUG" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386 +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386 /out:"../pForth.exe" + +!ELSEIF "$(CFG)" == "pForth - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "Debug" +# PROP BASE Intermediate_Dir "Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c +# ADD CPP /nologo /W4 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept + +!ELSEIF "$(CFG)" == "pForth - Win32 MakeDic" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "pForth__" +# PROP BASE Intermediate_Dir "pForth__" +# PROP BASE Ignore_Export_Lib 0 +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "pForth__" +# PROP Intermediate_Dir "pForth__" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c +# ADD CPP /nologo /W3 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept + +!ENDIF + +# Begin Target + +# Name "pForth - Win32 Release" +# Name "pForth - Win32 Debug" +# Name "pForth - Win32 MakeDic" +# Begin Group "Forth" + +# PROP Default_Filter ".fth, .j" +# Begin Source File + +SOURCE=..\ansilocs.fth +# End Source File +# Begin Source File + +SOURCE=..\bench.fth +# End Source File +# Begin Source File + +SOURCE=..\c_struct.fth +# End Source File +# Begin Source File + +SOURCE=..\case.fth +# End Source File +# Begin Source File + +SOURCE=..\catch.fth +# End Source File +# Begin Source File + +SOURCE=..\condcomp.fth +# End Source File +# Begin Source File + +SOURCE=..\coretest.fth +# End Source File +# Begin Source File + +SOURCE=..\filefind.fth +# End Source File +# Begin Source File + +SOURCE=..\floats.fth +# End Source File +# Begin Source File + +SOURCE=..\forget.fth +# End Source File +# Begin Source File + +SOURCE=..\loadp4th.fth +# End Source File +# Begin Source File + +SOURCE=..\locals.fth +# End Source File +# Begin Source File + +SOURCE=..\math.fth +# End Source File +# Begin Source File + +SOURCE=..\member.fth +# End Source File +# Begin Source File + +SOURCE=..\misc1.fth +# End Source File +# Begin Source File + +SOURCE=..\misc2.fth +# End Source File +# Begin Source File + +SOURCE=..\numberio.fth +# End Source File +# Begin Source File + +SOURCE=..\private.fth +# End Source File +# Begin Source File + +SOURCE=..\quit.fth +# End Source File +# Begin Source File + +SOURCE=..\see.fth +# End Source File +# Begin Source File + +SOURCE=..\smart_if.fth +# End Source File +# Begin Source File + +SOURCE=..\strings.fth +# End Source File +# Begin Source File + +SOURCE=..\system.fth +# End Source File +# Begin Source File + +SOURCE=..\t_alloc.fth +# End Source File +# Begin Source File + +SOURCE=..\t_corex.fth +# End Source File +# Begin Source File + +SOURCE=..\t_locals.fth +# End Source File +# Begin Source File + +SOURCE=..\t_strings.fth +# End Source File +# Begin Source File + +SOURCE=..\t_tools.fth +# End Source File +# Begin Source File + +SOURCE=..\tester.fth +# End Source File +# Begin Source File + +SOURCE=..\trace.fth +# End Source File +# Begin Source File + +SOURCE=..\tut.fth +# End Source File +# Begin Source File + +SOURCE=..\wordslik.fth +# End Source File +# End Group +# Begin Group "docs" + +# PROP Default_Filter ".txt, .htm" +# Begin Source File + +SOURCE=..\docs\pf_ref.htm +# End Source File +# Begin Source File + +SOURCE=..\docs\pf_todo.txt +# End Source File +# Begin Source File + +SOURCE=..\docs\pf_tut.htm +# End Source File +# Begin Source File + +SOURCE=..\docs\pfmanual.txt +# End Source File +# Begin Source File + +SOURCE=..\README.txt +# End Source File +# End Group +# Begin Source File + +SOURCE=..\csrc\pf_cglue.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_clib.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_core.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_inner.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_io.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_main.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_mem.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_save.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_text.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_words.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pfcompil.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pfcustom.c +# End Source File +# End Target +# End Project diff --git a/pcbuild/pForth.dsw b/pcbuild/pForth.dsw new file mode 100644 index 0000000..985e77c --- /dev/null +++ b/pcbuild/pForth.dsw @@ -0,0 +1,29 @@ +Microsoft Developer Studio Workspace File, Format Version 5.00 +# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! + +############################################################################### + +Project: "pForth"=.\pForth.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ +}}} + +############################################################################### + +Global: + +Package=<5> +{{{ +}}} + +Package=<3> +{{{ +}}} + +############################################################################### + diff --git a/pcbuild/pForth.ncb b/pcbuild/pForth.ncb new file mode 100644 index 0000000000000000000000000000000000000000..63bc88a8572f0950f5f69794d72ba26ac03bf008 GIT binary patch literal 50176 zcmeHQ3zQsHnf|+GNG1WoB!mQ#kg0?`$Rr_8Ktq(7^vom!^U6#Q1c-*7?&_Ildb)bM ztMhPq1OyBSs2s#_Ton-nfhay!P+8B3;%jk_Mi-akisJe_uIP%ph_7V7@7`N8HLn;r z5s2PDxpVJ#|NlPfulua3`*&+LRrE`KCUD~`;!Bshg`(eEOb)o|WRUDhmOOX$Su0nb zIC<6u8%3m2Bqpom1qAp0uEtpb-;&jU)xfc=ffG>qLzb)ttOl$GtOl$GtOl$GtOl$G ztOl$GtOl$GtOl$GtOl$GtOl$GtOl$GtOl$GtOl$GtOl$GtOl$GtOkx@4TwB{4AQr_g=V1;P%7)0PaU{v=I`nzaGrEm;j%4gBqBAdO4G%HKUzPE{8*ACo`V z`=`r%U`HM?c)gqtTq$=Ne6Fkmo*=%#%ViDlWN9MKiMvp0fv3o7;B(>bh5Jav??m`Y zxEta6;E1=tB@ISmOI8C`1Ak==g#G^vIYX87l?vVezbF3<9FrH&AF)1gYh@|0BhMJT zMD_0qc@tI(GHU|+H}Bm)BkoIZ3_lCs zlGT9Kz_Fo$G^)w|K3%4(3g2~{nsVHC%bmb6`KZBn%3fec)&R$RaqHzu;0ZF5xK`ZL z<<1tNpS_ z9Wfr|tx)@Wk?&S<*Di9K+Ruv22B^gTU@;^(^WOkIrYZMIxdymWK5p=}ay{@wxx(PI zlz=D6`NUXHY?U71<7F9fo45(N6nKgpK>p0HMLL0}%FPBhsr~YF*+F?cKM3S4;LnhZ z;h!%Jz^BTS;In?WpvEGn$rp%Yj{A1G1$dVH5#v;4t%Lo~>Az;ooM z%pc|NRqKz_rF)Xbjj=97*T_bN9e1YMug{aq4S!241O6HE8Jj?P z{|aFG2az{<3@?R$E}W&mT@8f&KivN>!Owwk{=eF}8ZAKN4%~l!5A<*HEufgj{ak5t zz2L|{PS*Wlr|RF8@`S;6$lc&ike?n;KKftm-DvNVuk1j--b#T#enD%z0eJ@XBd{_io|BQ#vMp!W9_viU@fzb(H*O{-+D z!GDrj5IbIOGV(pr5B?O{XZUkti@~p!)xey856HK{$Cm_#|8aQ|c!qq%q`ywBCuYeZ z;uV~49|C`_bQ}JBxeR!onzQyIj?b1ke|gByhkFa$O>p77^&y1Gr|gH|82@R+t%GA5 zeF|}N5dI1L#gRDT|APxk=vj^!j5p0oA&u{Y3_oyofj=?C zczU3}5Bf6s$UiO_$WM{~Qu5;VO96PAv>W{I&K%6}(>2aHau)t^e0Uw|7yF{Pcd1hc zGv#?Bzg_l#f0`^KAN9RO?f{-GpEdk*u=eJDV3op->s6GH|6Gk59jxq^fnOs#rt0(` zaXyOr&zCz4{+RPg;04kLWibCUD_3DfyHH9dzY1pt_=`e}oxuv^w^*(-{5h2iA%CXE zo`bI=R)W7oW|;ifIB!JyT4^%*PpF&;dDP0_-&9}}h7Q&l`K=BzK^X^mz0l`uXCd$^ z*=+b%IX42YmQNV`Ifq|Ltd*}B{X7%<6)xjkd6xJ^aeo_o5qO>4WBB`G-vNGucqaV^ zo%@jfjq+oI-(7Jp^j9ZeH+Wvf`M~w^fWe<~9)o;bo;G+x#pU2P$ZT^x2P%FE+$fU_ zeyHL};EnQ(k>6GE4&Y5vF#K~W+j0HPa*5%;!+AgQzd&9<`^0<&&DBDmEg^PmowLAi zletEIvvUb>hr|u;b^ZakOLmy+y)kw_uJ^;r|GDWcXQVfHF@RIbzC%_{}DsKJ$yAtm$z4=7T=txQ1oEp}P+Hcsm^N2aHcS zx=@Bb-(Ovhd%<~^@2f&ySZCtTBR%;KqpWYjG5qsLnDIBjQI@>tAs?0#md$c_hKRgS zZe&?unahm~F?Gf~sgtk_reppe!#$u5=(zv91a;tE)soe~-@69VPyo6$*7tLiD(+I_ zt%L7(mjFAW@PK2U_f^W>hQCzJUlT)&nX?A+ljXOHFK%A)z{d~bH%kuq1bu!G&;L3k z0eoV3o)F&?#DS;Cf131hjQ!j%u>bPeROqu$-w&Bjz(vCxGw9w5_c(YATe2Fk8aTWL z^y4h9penGgISx}$aG|6~6i+AFXcc)1#|{r}}^&Ze^( zIQBJwM`r5e@A6~+QtTC24Ok7lL=ABMZ-6@hheziieEb!m>fHct7=edxuK+#hFF6}8 zb)*80_6PJ)0zAZz5FX)=NxX(Sa(44i9UL+^N|bo<5bBlc|2(p6LP2v?zI^XV(%RGE z$lp3VPN}MrSe;u}HMP2`>RLQ%L3)>UgF36gtFM+ie0KY?>9b$_p3>LNr~=P#>YCt1 zilTAq^^!_+p~kwGl!C(B-}emab)EbHRp7ZVJeCFVxiaZ!)Jx|id+MM`x30Q+cXcI{ z81zk-v>#4us$x9xqaR;2uL@0I6q$P6{S4~F@5r@94y`X-;8CDG zby9g98YKVYKzrTw;%?f5#<`n^$;YKoUuD#Z-v{e@olp6rQ!QlVIxcQnC3?#Saq#tl z9q%B-2}UURzV8Vrpw4vn|z|D|=_9WIn>lT<)yC`4TUe0)L>XoKFQ=Kc7hU zvR}A@*%?E2%>%VSuKJD!^;Z83o7xS%t+A|St<$;c5F*#6@ zc+pD+-bR$1@Z-{0EK17HmjXA{mn^!qZoDly;7M6!Y_c4;`nhZmYG262yMkgi-`nEl zdxJhndAZ#1JWG)2@`6@xz%TC7m!tloxRMfgQ`*ZjGrzDaB1xH5COayEcs0dP-Gtv= zD0sL4gw-G96LMPo9pH>xb-zf(_r}Y`qL&X6$x^?hGV~gfL9%v`fjiCnkVLgpnIQlH zDzum#$OhT%UP*epQpIGD!o^dIm$`}N4coe!FKxs<>uvE<$z0qYC}eY9aod)JH170L z3BTXVOK*c$2>R-SxS#WZE=m^Tem?Ma1}Yzvf|#xVw@ZaKuq`pFG1cd*K%$sTc`e>{ zFE<1spXwiiO}S(*>W5UD%ULf_A>BISY#oJ6b3Pkv%=taZTuI#&L^Yt@2HpszK=G+e zkfwrF3sP*|OxPq&{T?CX&Tov^WIFQXJbM0m1oDU)~ z&G`su%9Trf($Tc7E78#07RjsDM7DP)Al{rWlmiYE2)7r!{OB8{#>Y}x<)^sAs-^3P z#GPnXifzW9LQphqTs1AN+933$Xclds;1J@gdBb`h1C{2lQ*uy<(ZEW4v(caz?4u1`PxhJ=) zC7bW}(kz%d(UP#Pt}Sjf>^c{t`OX49O=9sH|}5kxC58CX!jq47g89uf5F}k5o{NCnl^47)Y{~N~(})DtcaL zatHWfb74@oSxkEyb_KWrdg1`1K9|D;7x=|+N>8TK#c%;pK;uwNrjSu`CR>A;tuBrs z)4LcPul1Lb+c|AFmp1vOpd}jwIj=FF&L;E1KHAlXp0FX?Yoa(QtUAXG%^I-Xvv!nj z@v&lwW}!!BGnGUHRkp(&nfVK@q4T-H93a*w^J_tH6Myc#B!-gV}*w#_s z5KahjKabuMU?A!7u!2|h85~Dl^Xh9S! zT#SrfP-#_;vj^MZ7t>F?L`jq82i76lWAx>yp7m z3&c|xjF3S?wl^Cje0`OO*MZF=?$yO8TxW-=t2_WX6*JE8mr{EO)D=z5gfZ*)nsumN z_lJv8Z1p_sLt5*%Y-?_dw{$l&Zfj`lNNnPU#K`FVA~!O)5u3R&>BTBH=wJvJqPBE; zW1<^aqyeJ6yG=^1YR2mH(jFF$dTpay_E4p;dC6qD^IZewG#0{5*?hV_pElc};pzzb zJazeKbDRg!>pFd(N{M3|ogc~(+Z(+FY49>0_HSuyW5X?#i@0Pt7vLJ&eC(^#t}7kN zXH%-rhO?928=1TeFD|^Ugx^v0wqpr}{i*6Jk&CY#9fjelt*PFm)az)0ih5C_Di19d(NwKl zPvb+`1UtO>OEVAc;~>aG(;;X*sY@Zf}+$*b zczV~Pt`1WjuBitz0{l+&B`kNx8wAt?A`AlYgjWhyYA+mrF>B#j3HMnDtyU{4J~(RY zZrv8|?n<<`Zfojpizk}f+qy6iaB3Utd6Vfi!&xPH8jr;IHiFihc_NLc$a#8=)}d%Q znN}xg8Jcf4X<>?|IC&EFQSfMOf>v6hM5{9mk%&6vLu<*js6va@w8}y&kF-X~6NR+q zL`%@Lwn+<@Jk?4IFg%SD5-r`3c*2pyw>l(RxQfyw1TBJv` zr>s9QNGqH?iAti?77|Z-(vl^uJJX6aEqU=R<#O=&rk<90Xf1>mew2kO$ntb7Pk_?8 zGc9NFbTBPm@f0aff`-Hsh$LDEp@nW*1?N*q{@MU7lJc!KPx$jxAWsO9__mwYa-u|Q zMIqgb04-RBM9ZHfzQLqLYrZw4^=(?np%ook>Y=rBp4jDCSz7*j7G=<4C#~1;R3%SQ z^28`l+42qAkB}cv$ns5JC(`oQ40s}%R>)}igw{`aqL`;z`BsXzLo+^D|3N)Ppk0_EKhOM+6%2!@N{UDXmS2XiPoS<{KX0qt>Mse8Z9&N zZ8fdq(aH=@{VGctrmT9DL2Iu(l}3xVJVngYva~`&3p2DjPfKgGzC#P^v@*-nthD|_ zi+Vh*O3SdcwnK{-Ji$tfvpl^`YwWa$L90x(mctY7w8}+G{XQJ6NPPt|JekbX_q6=P zQ|vrJ7ZNSXl4!M)C(J|Q$ypLl=aOixhZeAC?TMD`X#JNKKS;FXegHmC{L-4;J@B6Z zpH_4Cp-i5<9*g)TO_XSTheXR^wA?`}^E_2f`h@XmC6Hg?&>}r82t>(4elt-QTGl1e zLO-p1k!X$NQRGLWv?{Y9!Xw|(tD%AD@Bh)l!-_l> z;U##fo)v+5n4QgMe2oYEbUEjZ#4E;Gy$!zdQ+esMMAAI%I}%azT;)hacbEV( z(<95i<5A!dsN#YfuDGRuM_@0u3Mk%yg7BT58SAHFS&FG8j!vsS^_lL|eY(GHO}UPz z&-~@jXa4%@-@N;Y)t7Eslh%Kp&sx)6w zBrpZgn!f?e0JA_2coU#?K85@=@Hqfmz&Zn*1>OPXfX@S@_XXr%1il2k3w#;)3h-6n zYrxk5()%&;Jn&86Tfn!0?*Qk3^S}k*y8!9Fhx`&y0E)n6;0mw+ECN@7_kj-p(!YlM zI&cH{KJX#%1K=j`L*PdM=`A5I0cBtrr~tQtkAM~64nTT@yO8ezYrs126JP__1nvV5 z0Mgq+{xR?f_$lx+U>o>3@C)EEKzjf0v|%ZHVoPA=0rJS&!^nnD^Vl)j98Mh4?3cft zU;N!Czn`FaXR2GU9$8NWpQYtRwZaJ~HBZZ@anpbZ{cI>G@cv@_E!Qz5AzkBV23!)jz6t@;d@%G1}xV9jQWs$#EUS4`|J8$Hzm3xZ| ziTJp*c5icSbveDdyHwgt#P!PK%?Io2Ya90;SJqKf3G*A$mzYv9S&%~LG*JEsCMs&b zjx^n#tFkCMB5x*>@US7ZYDJFRpHAN-d~tdA>gDUA=ypb(v|ox;TVwiVJGO~jao2t- zqrT=D2c0pcbrI;R((aTtm(d@{)TR~-ro>K{S8sn z-!PWDaeqrH>u*YBownMpNg9#kx&D3*Ij7vJ1FuL-g}zboeuVdi{Shc=Gq|>YY^($o@Zm{*Ryk8~RSdip&5rzzi@0%m6dM3@`)C05iZ094`jg z|98CBi${Aj2H5}C>;HSv`Rgs5NDgo=na)KYmhw1%OtAuz)5pV|KmG=Fnw~#i!72I` zoQ4l^>YmO($JS`iAIo^UoK_J_RR0%IqgsqkrdK!v6QjOgjIP<>Rco#^)he zmtb62Bl17;{BL#HpTzm^>Ex*HY{|E^e(1^e)Q8J!8#lYZPbVtEAr+~Usuvc{RB%?h z(}~zp(Ni7TICy+6>EqlDaV0wxeqLYbwlbvhTj^kGu#^sEW+kYpj@9l?&z9wm^i_yM z$2jlpwwyR^b6`c%x}S~%&n)x#@2)fOeExg%dkD8+2ABb6fEi#0m;q*h8DIvO0cPN{ zV1WI(%+^|K}!3TyON@D{%eXJKBY9**F{-YTlG!{ zr2G$~{GzU?gZ?p4u)?zEbh>y^Ln{0G)Tv9J(0e+T%|b11bWHV*aC&BLb8~3}kITMk zmG0Y7UB)YD(r-7N`+y-)RodB<3AQ{iG`qm~+l5 zm1QUcR|d`=f@8+E7sx2>XeO*ZwtXD^pFr^5ESVw z%ENS8fwwzIhelNMl|7JXV@yQ@8A3;hlZgcf4%;{PfvB? zzf$zbG`3_SnBbDW415y_Q^%3Cn>m%_h$)0DU)godg-cS3-hs z8<$BgR3RP&d`d-8pk>?&3wV16E|eoRnFu4@FkR{fDPEzXL^S;;;?+*+HHgnzvL$no zP3`fG4iiB}k)qI-DARZ?NGdfjdJ?5WaWzdFiC4@xT-J7dMZ{^PZWgIzAdu&lbAa%P(Bj|K)>hVIDp89t8 zWlNGLEt!pnk-8WR*oBycCyhdfu0zLlC|YSE!0|*<;F<-1pv{^YA*+kAsEHc(%Sw0AXTEW|=5U!hDoJc*lTLq~I>rwthi{^sGHmLC6NdXTmAdd+n`+n1{Qnc# zQ^2^lX1;iHo25s(8|?q@{D&g-m9zhUfDioD_5UB?PX}(w3@`)C05iZ0Fayj0Gr$Zm z1I)m&W`Op|L-_I z|2yLCg4LM;W`G%B2ABb6fEi#0m;q*h8F+0NVE^B1vy?oMAsAr)U$6hKjF_WUt7X;k zk%+%KYC8K8@lWYxQ(64eGNQgZu-}CB0MTFdhy$2I{Mi|_nF5B5|N4+@r14itJZc&> z{_Iih^|wEY{T$x^m86WllenDTvhj%Vl}uR3gvCs_nvH>;65Wc!wLW`G%B2ABb6fEi#0m;q*h8DIv+jRE%mj@ycl_k7v^ z+w1?GHmAMmom=exy7cvq|2p1xKb}1^zzi@0%m6dM3@`)C05iZ0j57o5{~PDk NAHTV?|F75o_g|Zp-wOZ$ literal 0 HcmV?d00001 diff --git a/pcbuild/pForth.plg b/pcbuild/pForth.plg new file mode 100644 index 0000000..1d12217 --- /dev/null +++ b/pcbuild/pForth.plg @@ -0,0 +1,59 @@ +--------------------Configuration: pForth - Win32 Release-------------------- +Begining build with project "E:\nomad\pForth\pcbuild\pForth.dsp", at root. +Active configuration is Win32 (x86) Console Application (based on Win32 (x86) Console Application) + +Project's tools are: + "32-bit C/C++ Compiler for 80x86" with flags "/nologo /ML /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /Fp"Release/pForth.pch" /YX /Fo"Release/" /Fd"Release/" /FD /c " + "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" " + "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" " + "COFF Linker for 80x86" with flags "kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /incremental:no /pdb:"Release/pForth.pdb" /machine:I386 /out:"../pForth.exe" " + "Custom Build" with flags "" + "" with flags "" + +Creating temp file "C:\WINDOWS\TEMP\RSP62A2.TMP" with contents +Creating command line "cl.exe @C:\WINDOWS\TEMP\RSP62A2.TMP" +Creating temp file "C:\WINDOWS\TEMP\RSP62A3.TMP" with contents +Creating command line "link.exe @C:\WINDOWS\TEMP\RSP62A3.TMP" +Compiling... +pf_cglue.c +pf_clib.c +pf_core.c +pf_inner.c +pf_io.c +pf_main.c +pf_mem.c +pf_save.c +pf_text.c +pf_words.c +pfcompil.c +pfcustom.c +Linking... + + + +pForth.exe - 0 error(s), 0 warning(s) diff --git a/private.fth b/private.fth new file mode 100644 index 0000000..0f843f8 --- /dev/null +++ b/private.fth @@ -0,0 +1,48 @@ +\ @(#) 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 +$ 20 constant FLAG_SMUDGE + +: PRIVATE{ + latest private-start ! + 0 private-stop ! +; +: }PRIVATE + private-stop @ 0= not abort" Extra }PRIVATE" + latest private-stop ! +; +: PRIVATIZE ( -- , smudge all words between PRIVATE{ and }PRIVATE ) + private-start @ 0= abort" Missing PRIVATE{" + private-stop @ 0= abort" 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 ! +; diff --git a/quit.fth b/quit.fth new file mode 100644 index 0000000..2a96365 --- /dev/null +++ b/quit.fth @@ -0,0 +1,136 @@ +\ @(#) quit.fth 98/01/26 1.2 +\ Outer Interpreter in Forth +\ +\ This used so that THROW can be caught by QUIT. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +include? catch catch.fth + +anew task-quit.fth + +: FIND&COMPILE ( $word -- {n} , find word in dictionary and handle it ) + dup >r \ save in case needed + find ( -- xt flag | $word 0 ) + + CASE + -1 OF \ not immediate + state @ \ compiling? + IF compile, + ELSE execute + THEN + ENDOF + + 1 OF execute \ immediate, so execute regardless of STATE + ENDOF + + 0 OF + number? \ is it a number? + num_type_single = + IF ?literal \ compile it or leave it on stack + ELSE + r@ count type ." is not recognized!!" cr + abort + THEN + ENDOF + ENDCASE + + rdrop +; + +: CHECK.STACK \ throw exception if stack underflows + depth 0< + IF + ." QUIT: Stack underflow!" cr + depth negate 0 \ restore depth + ?DO 0 + LOOP + ERR_UNDERFLOW throw + THEN +; + +\ interpret whatever is in source +: INTERPRET ( ?? -- ?? ) + BEGIN + >in @ source nip ( 1- ) < \ any input left? !!! is -1 needed? + WHILE + bl word + dup c@ 0> + IF + 0 >r \ flag + local-compiler @ + IF + dup local-compiler @ execute ( ?? -- ?? ) + r> drop TRUE >r + THEN + r> 0= + IF + find&compile ( -- {n} , may leave numbers on stack ) + THEN + ELSE + drop + THEN + check.stack + REPEAT +; + +: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth ) +\ save current input state and switch to pased 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 +; + +: POSTPONE ( -- ) + bl word find + CASE + 0 OF ." Postpone could not find " count type cr abort ENDOF + 1 OF compile, ENDOF \ immediate + -1 OF (compile) ENDOF \ normal + ENDCASE +; immediate + +: OK + ." OK " + trace-stack @ + IF .s + ELSE cr + THEN +; + +variable QUIT-QUIT + +: QUIT ( -- , interpret input until none left ) + quit-quit off + postpone [ + BEGIN + refill + quit-quit @ 0= and + WHILE +\ ." TIB = " source type cr + ['] interpret catch ?dup + IF + ." Exception # " . cr + ELSE + state @ 0= IF ok THEN + THEN + REPEAT +; diff --git a/see.fth b/see.fth new file mode 100644 index 0000000..9d866ad --- /dev/null +++ b/see.fth @@ -0,0 +1,218 @@ +\ @(#) 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] diff --git a/siev.fs b/siev.fs new file mode 100644 index 0000000..323715c --- /dev/null +++ b/siev.fs @@ -0,0 +1,23 @@ +\ #! /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 + +: 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 1000 0 DO PRIMES NIP LOOP ; +\ SECS BENCHMARK . SECS SWAP - CR . .( secs) +: main + flags 8190 + eflag ! + benchmark ( . ) drop +; diff --git a/siev.fth b/siev.fth new file mode 100644 index 0000000..579bf91 --- /dev/null +++ b/siev.fth @@ -0,0 +1,31 @@ +\ #! /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 +; diff --git a/smart_if.fth b/smart_if.fth new file mode 100644 index 0000000..17c1b61 --- /dev/null +++ b/smart_if.fth @@ -0,0 +1,57 @@ +\ @(#) 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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-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 diff --git a/strings.fth b/strings.fth new file mode 100644 index 0000000..08426c5 --- /dev/null +++ b/strings.fth @@ -0,0 +1,97 @@ +\ @(#) 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 * + 4 + +; + +\ 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 +; + +\ ----------------------------------------------- diff --git a/system.fth b/system.fth new file mode 100644 index 0000000..b2e04aa --- /dev/null +++ b/system.fth @@ -0,0 +1,805 @@ +: 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 + +\ This is another style of comment that is common in Forth. + +\ @(#) system.fth 98/01/26 1.4 +\ ********************************************************************* +\ pFORTH - Portable Forth System +\ Based on HMSL Forth +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ ********************************************************************* + +: COUNT dup 1+ swap c@ ; + +\ Miscellaneous support words +: ON ( addr -- , set true ) + -1 swap ! +; +: OFF ( addr -- , set false ) + 0 swap ! +; + +\ size of data items +\ FIXME - move these into 'C' code for portability ???? +: CELL ( -- size_of_stack_item ) 4 ; + +: CELL+ ( n -- n+cell ) cell + ; +: CELL- ( n -- n+cell ) cell - ; +: CELLS ( n -- n*cell ) 2 lshift ; + +: 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 ) + 8 - +; + +: >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 +: ERR_ABORT -1 ; \ general abort +: ERR_CONDITIONAL -2 ; \ stack error during conditional +: ERR_EXECUTING -3 ; \ compile time word while not compiling +: ERR_PAIRS -4 ; \ mismatch in conditional +: ERR_DEFER -5 ; \ not a deferred word +: ERR_UNDERFLOW -6 ; + +\ Conditionals in '83 form ----------------------------------------- +: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ; +: ?CONDITION ( f -- ) conditional_key - err_conditional ?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 + [compile] ; \ terminate part of code before does> + :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 @ +; + + +: 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 31 rshift or swap + 2* swap +; + +\ 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 + +defer ABORT \ will default to QUIT + +: /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! +; + +\ ----------------------------------------------------------------- +\ 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 ( $filename -- , mark start of include for FILE?) + " ::::" pad $MOVE + count pad $APPEND + pad ['] noop (:) +; + +: INCLUDE.MARK.END ( -- , mark end of include ) + " ;;;;" ['] noop (:) +; + +: $INCLUDE ( $filename -- ) +\ Print messages. + trace-include @ + IF + >newline ." Include " dup count type cr + THEN + here >r + dup + count r/o open-file + IF ( -- $filename bad-fid ) + drop ." Could not find file " $type cr abort + ELSE ( -- $filename good-fid ) + swap include.mark.start + dup >r \ save fid for close-file + depth >r + include-file + depth 1+ r> - + IF + ." Warning: stack depth changed during include!" cr + .s cr + 0sp + THEN + r> close-file drop + include.mark.end + THEN + trace-include @ + IF + ." include added " here r@ - . ." bytes," + codelimit here - . ." left." cr + THEN + rdrop +; + +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 +; + +\ load remainder of dictionary + +trace-include on +trace-stack on + +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 +c" pforth.dic" save-forth diff --git a/t_alloc.fth b/t_alloc.fth new file mode 100644 index 0000000..4f20917 --- /dev/null +++ b/t_alloc.fth @@ -0,0 +1,116 @@ +\ @(#) t_alloc.fth 97/01/28 1.4 +\ Test PForth ALLOCATE +\ +\ Copyright 1994 3DO, Phil Burk + +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 + 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." ELSE ." Test FAILED!" 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 +10000 taf.test + diff --git a/t_corex.fth b/t_corex.fth new file mode 100644 index 0000000..1f383c4 --- /dev/null +++ b/t_corex.fth @@ -0,0 +1,226 @@ +\ @(#) 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 + +\ STUB because missing definition in pForth - FIXME +: SAVE-INPUT ; +: RESTORE-INPUT -1 ; + +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 \ EXPECTED FAILURE + +\ ----------------------------------------------------- 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 + +\ ----------------------------------------------------- \ +}TEST + diff --git a/t_floats.fth b/t_floats.fth new file mode 100644 index 0000000..866d8e1 --- /dev/null +++ b/t_floats.fth @@ -0,0 +1,134 @@ +\ @(#) 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 -f- ) + fover (fs.) >float fswap f~ + AND +; +: T_FE. ( -- ok? ) ( r -f- ) + fover (fe.) >float fswap f~ + AND +; + +: T_FG. ( -- ok? ) ( r -f- ) + fover (f.) >float fswap f~ + AND +; + +: T_F>D ( -- ok? ) ( r -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 ( -- fmust 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 + +\ ----------------------------------------------------- \ +}TEST + diff --git a/t_locals.fth b/t_locals.fth new file mode 100644 index 0000000..7198ba7 --- /dev/null +++ b/t_locals.fth @@ -0,0 +1,41 @@ +\ @(#) 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{ + +echo off + + +\ 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 +: test.value ( -- ok ) + 100 -> my-value + my-value 100 = + 47 +-> my-value + my-value 147 = AND +; +T{ test.value }T{ TRUE }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 + diff --git a/t_strings.fth b/t_strings.fth new file mode 100644 index 0000000..be75379 --- /dev/null +++ b/t_strings.fth @@ -0,0 +1,106 @@ +\ @(#) 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 + +}test diff --git a/t_tools.fth b/t_tools.fth new file mode 100644 index 0000000..a165c3b --- /dev/null +++ b/t_tools.fth @@ -0,0 +1,83 @@ +\ @(#) 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 + +: TEST{ + depth test-depth ! + 0 test-passed ! + 0 test-failed ! +; + + +: }TEST + test-passed @ 4 .r ." passed, " + test-failed @ 4 .r ." failed." cr +; + + +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 +; diff --git a/tester.fth b/tester.fth new file mode 100644 index 0000000..f4f2dd8 --- /dev/null +++ b/tester.fth @@ -0,0 +1,54 @@ +\ 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 ; + diff --git a/trace.fth b/trace.fth new file mode 100644 index 0000000..c5c96c3 --- /dev/null +++ b/trace.fth @@ -0,0 +1,455 @@ +\ @(#) 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 + +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 + 30 space.to.column +\ show data stack + trace.show.stack + 65 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 + 100 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 + ." 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 > + 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 + 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 + +1 [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] diff --git a/tut.fth b/tut.fth new file mode 100644 index 0000000..957ae34 --- /dev/null +++ b/tut.fth @@ -0,0 +1,70 @@ +anew 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 + diff --git a/utils/clone.fth b/utils/clone.fth new file mode 100644 index 0000000..377d363 --- /dev/null +++ b/utils/clone.fth @@ -0,0 +1,489 @@ +\ @(#) 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 + diff --git a/utils/dump_struct.fth b/utils/dump_struct.fth new file mode 100644 index 0000000..58c051f --- /dev/null +++ b/utils/dump_struct.fth @@ -0,0 +1,120 @@ +\ @(#) 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. + +include? task-member 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 ) + >rel [compile] dst +; 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 ..! along1 + $ -665 afoo ..! ashort1 + $ 21 afoo ..! abyte + $ 43 afoo ..! abyte2 + -234 afoo .. agoo ..! goo_height +; +afoo.init + +: TDS ( afoo -- ) + dst foo +; + +.THEN diff --git a/utils/load_file.fth b/utils/load_file.fth new file mode 100644 index 0000000..71f5e56 --- /dev/null +++ b/utils/load_file.fth @@ -0,0 +1,39 @@ +\ 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 . diff --git a/utils/make_all256.fth b/utils/make_all256.fth new file mode 100644 index 0000000..87f2a75 --- /dev/null +++ b/utils/make_all256.fth @@ -0,0 +1,57 @@ +\ @(#) 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 diff --git a/utils/savedicd.fth b/utils/savedicd.fth new file mode 100644 index 0000000..482ec72 --- /dev/null +++ b/utils/savedicd.fth @@ -0,0 +1,170 @@ +\ @(#) 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. + +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 SAVE-DIC-AS-DATA */" $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 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 MinDicCode[] = {" sdad.type + codebase here SDAD_CODE_EXTRA sdad.dump.data + EOL sdad.emit + c" };" $sdad.line + + sdad.close +; + +if.forgotten sdad.close + +." Enter: SDAD" cr diff --git a/utils/trace.fth b/utils/trace.fth new file mode 100644 index 0000000..e2b948d --- /dev/null +++ b/utils/trace.fth @@ -0,0 +1,438 @@ +\ @(#) trace.fth 98/01/08 1.1 +\ 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 + +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 + 30 space.to.column +\ show data stack + trace.show.stack + 65 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 + 100 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 + ." 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 down ) + trace_level -> trace_level_max + 0 + ?DO + trace_ip trace.next -> trace_ip + LOOP +; + +: gd { more_levels | stop_level -- } + depth 1 < + IF + ." GD requires a MORE_LEVELS parameter." cr + ELSE + trace_level more_levels + -> trace_level_max + trace_level 1- -> stop_level + BEGIN + trace_ip trace.next -> trace_ip + trace_level stop_level > not + 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] diff --git a/wordslik.fth b/wordslik.fth new file mode 100644 index 0000000..adaa74f --- /dev/null +++ b/wordslik.fth @@ -0,0 +1,44 @@ +\ @(#) 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, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-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 +; -- 2.30.2