--- /dev/null
+# @(#) 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
+
--- /dev/null
+README for pForth - a Portable ANS-like Forth written in ANSI 'C'\r
+\r
+by Phil Burk\r
+with Larry Polansky, David Rosenboom and Darren Gibbs.\r
+\r
+Last updated: 4/6/98 V19\r
+\r
+Please direct feedback, bug reports, and suggestions to:\r
+\r
+ philburk@softsynth.com.\r
+\r
+\r
+The author is available for customization of pForth, porting to new\r
+\r
+platforms, or developing pForth applications on a contractual basis.\r
+\r
+If interested, contact Phil Burk at philburk@softsynth.com.\r
+\r
+\r
+\r
+-- LEGAL NOTICE -----------------------------------------\r
+\r
+The pForth software code is dedicated to the public domain,\r
+and any third party may reproduce, distribute and modify\r
+the pForth software code or any derivative works thereof\r
+without any compensation or license. The pForth software\r
+code is provided on an "as is" basis without any warranty\r
+of any kind, including, without limitation, the implied\r
+warranties of merchantability and fitness for a particular\r
+purpose and their equivalents under the laws of any jurisdiction.\r
+\r
+-- How to run PForth ------------------------------------\r
+\r
+\r
+Note: Please refer to "pf_ref.htm" for more complete information.\r
+\r
+\r
+Once you have compiled and built the dictionary, just enter:\r
+ pforth\r
+\r
+\r
+To compile source code files use: INCLUDE filename\r
+\r
+To create a custom dictionary enter in pForth:\r
+ c" newfilename.dic" SAVE-FORTH\r
+The name must end in ".dic".\r
+\r
+To run PForth with the new dictionary enter in the shell:\r
+ pforth -dnewfilename.dic\r
+\r
+To run PForth and automatically include a forth file:\r
+ pforth myprogram.fth\r
+\r
+-- How to run PForth ------------------------------------\r
+\r
+You can test the Forth without loading a dictionary\r
+which might be necessary if the dictionary can't be built.\r
+\r
+\r
+Enter: pforth -i\r
+In pForth, enter: 3 4 + .\r
+In pForth, enter: loadsys\r
+In pForth, enter: 10 0 do i . loop\r
+\r
+PForth comes with a small test suite. To test the Core words,\r
+you can use the coretest developed by John Hayes.\r
+\r
+Enter: pforth\r
+Enter: include tester.fth\r
+Enter: include coretest.fth\r
+\r
+To run the other tests, enter:\r
+\r
+ pforth t_corex.fth\r
+ pforth t_strings.fth\r
+ pforth t_locals.fth\r
+ pforth t_alloc.fth\r
+ \r
+They will report the number of tests that pass or fail.\r
+\r
+-- Version History --------------------------------------\r
+\r
+V1 - 5/94\r
+ - built pForth from various Forths including HMSL\r
+ \r
+V2 - 8/94\r
+ - made improvements necessary for use with M2 Verilog testing\r
+ \r
+V3 - 3/1/95\r
+ - Added support for embedded systems: PF_NO_FILEIO\r
+ and PF_NO_MALLOC.\r
+ - Fixed bug in dictionary loader that treated HERE as name relative.\r
+\r
+V4 - 3/6/95\r
+ - Added smart conditionals to allow IF THEN DO LOOP etc.\r
+ outside colon definitions.\r
+ - Fixed RSHIFT, made logical.\r
+ - Added ARSHIFT for arithmetic shift.\r
+ - Added proper M*\r
+ - Added <> U> U<\r
+ - Added FM/MOD SM/REM /MOD MOD */ */MOD\r
+ - Added +LOOP EVALUATE UNLOOP EXIT\r
+ - Everything passes "coretest.fth" except UM/MOD FIND and WORD\r
+\r
+V5 - 3/9/95\r
+ - Added pfReportError()\r
+ - Fixed problem with NumPrimitives growing and breaking dictionaries\r
+ - Reduced size of saved dictionaries, 198K -> 28K in one instance\r
+ - Funnel all terminal I/O through ioKey() and ioEmit()\r
+ - Removed dependencies on printf() except for debugging\r
+ \r
+V6 - 3/16/95\r
+ - Added floating point\r
+ - Changed NUMBER? to return a numeric type\r
+ - Support double number entry, eg. 234. -> 234 0\r
+ \r
+V7 - 4/12/95\r
+ - Converted to 3DO Teamware environment\r
+ - Added conditional compiler [IF] [ELSE] [THEN], use like #if\r
+ - Fixed W->S B->S for positive values\r
+ - Fixed ALLOCATE FREE validation. Was failing on some 'C' compilers.\r
+ - Added FILE-SIZE\r
+ - Fixed ERASE, now fills with zero instead of BL\r
+\r
+V8 - 5/1/95\r
+ - Report line number and line dump when INCLUDE aborts\r
+ - Abort if stack depth changes in colon definition. Helps\r
+ detect unbalanced conditionals (IF without THEN).\r
+ - Print bytes added by include. Helps determine current file.\r
+ - Added RETURN-CODE which is returned to caller, eg. UNIX shell.\r
+ - Changed Header and Code sizes to 60000 and 150000\r
+ - Added check for overflowing dictionary when creating secondaries.\r
+ \r
+V9 - 10/13/95\r
+ - Cleaned up and documented for alpha release.\r
+ - Added EXISTS?\r
+ - compile floats.fth if F* exists\r
+ - got PF_NO_SHELL working\r
+ - added TURNKEY to build headerless dictionary apps\r
+ - improved release script and rlsMakefile\r
+ - added FS@ and FS! for FLPT structure members\r
+ \r
+V10 - 3/21/96\r
+ - Close nested source files when INCLUDE aborts.\r
+ - Add PF_NO_CLIB option to reduce OS dependencies.\r
+ - Add CREATE-FILE, fix R/W access mode for OPEN-FILE.\r
+ - Use PF_FLOAT instead of FLOAT to avoid DOS problem.\r
+ - Add PF_HOST_DOS for compilation control.\r
+ - Shorten all long file names to fit in the 8.3 format\r
+ required by some primitive operating systems. My\r
+ apologies to those with modern computers who suffer\r
+ as a result. ;-)\r
+\r
+V11 - 11/14/96\r
+ - Added support for AUTO.INIT and AUTO.TERM. These are called\r
+ automagically when the Forth starts and quits.\r
+ - Change all int to int32.\r
+ - Changed DO LOOP to ?DO LOOP in ENDCASE and LV.MATCH\r
+ to fix hang when zero local variables.\r
+ - Align long word members in :STRUCT to avoid bus errors.\r
+ \r
+V12 - 12/1/96\r
+ - Advance pointers in pfCopyMemory() and pfSetMemory()\r
+ to fix PF_NO_CLIB build.\r
+ - Increase size of array for PF_NO_MALLOC\r
+ - Eliminate many warnings involving type casts and (const char *)\r
+ - Fix error recovery in dictionary creation.\r
+ - Conditionally eliminate some include files for embedded builds.\r
+ - Cleanup some test files.\r
+\r
+V13 - 12/15/96\r
+ - Add "extern 'C' {" to pf_mem.h for C++\r
+ - Separate PF_STATIC_DIC from PF_NO_FILEIO so that we can use a static\r
+ dictionary but also have file I/O.\r
+ - Added PF_USER_FILEIO, PF_USER_CHARIO, PF_USER_CLIB.\r
+ - INCLUDE now aborts if file not found.\r
+ - Add +-> which allows you to add to a local variable, like +! .\r
+ - VALUE now works properly as a self fetching constant.\r
+ - Add CODE-SIZE and HEADERS-SIZE which lets you resize\r
+ dictionary saved using SAVE-FORTH.\r
+ - Added FILE?. Enter "FILE? THEN" to see what files THEN is defined in.\r
+ - Fixed bug in local variables that caused problems if compilation\r
+ aborted in a word with local variables.\r
+ - Added SEE which "disassembles" Forth words. See "see.fth".\r
+ - Added PRIVATE{ which can be used to hide low level support\r
+ words. See "private.fth".\r
+ \r
+V14 - 12/23/96\r
+ * pforth command now requires -d before dictionary name.\r
+ Eg. pforth -dcustom.dic test.fth\r
+ * PF_USER_* now need to be defined as include file names.\r
+ * PF_USER_CHARIO now requires different functions to be defined.\r
+ See "csrc/pf_io.h".\r
+ - Moved pfDoForth() from pf_main.c to pf_core.c to simplify\r
+ file with main().\r
+ - Fix build with PF_NO_INIT\r
+ - Makefile now has target for embedded dictionary, "gmake pfemb".\r
+ \r
+V15 - 2/15/97\r
+ * If you use PF_USER_FILEIO, you must now define PF_STDIN and PF_STDOUT\r
+ among other additions. See "pf_io.h".\r
+ * COMPARE now matches ANS STRING word set!\r
+ - Added PF_USER_INC1 and PF_USER_INC2 for optional includes\r
+ and host customization. See "pf_all.h".\r
+ - Fixed more warnings.\r
+ - Fixed >NAME and WORDS for systems with high "negative" addresses.\r
+ - Added WORDS.LIKE utility. Enter: WORDS.LIKE EMIT\r
+ - Added stack check after every word in high level interpreter.\r
+ Enter QUIT to enter high level interpreter which uses this feature.\r
+ - THROW will no longer crash if not using high level interpreter.\r
+ - Isolated all host dependencies into "pf_unix.h", "pf_win32.h",\r
+ "pf_mac.h", etc. See "pf_all.h".\r
+ - Added tests for CORE EXT, STRINGS words sets.\r
+ - Added SEARCH\r
+ - Fixed WHILE and REPEAT for multiple WHILEs.\r
+ - Fixed .( ) for empty strings.\r
+ - Fixed FATAN2 which could not compile on some systems (Linux gcc).\r
+\r
+V16\r
+ * Define PF_USER_CUSTOM if you are defining your own custom\r
+ 'C' glue routines. This will ifndef the published example.\r
+ - Fixed warning in pf_cglue.c.\r
+ - Fixed SDAD in savedicd.fth. It used to generate bogus 'C' code\r
+ if called when (BASE != 10), as in HEX mode.\r
+ - Fixed address comparisons in forget.fth and private.fth for\r
+ addresses above 0x80000000. Must be unsigned.\r
+ - Call FREEZE at end of system.fth to initialize rfence.\r
+ - Fixed 0.0 F. which used to leave 0.0 on FP stack.\r
+ - Added FPICK ( n -- ) ( i*f -- i*f f[n] )\r
+ - .S now prints hex numbers as unsigned.\r
+ - Fixed internal number to text conversion for unsigned nums.\r
+\r
+V17\r
+ - Fixed input of large floats. 0.7071234567 F. used to fail.\r
+\r
+V18\r
+ - Make FILL a 'C' primitive.\r
+ - optimized locals with (1_LOCAL@)\r
+ - optimized inner interpreter by 15%\r
+ - fix tester.fth failures\r
+ - Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined.\r
+ - Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition.\r
+ - Fixed saving and restoring of TIB when nesting include files.\r
+\r
+V19 4/98\r
+\r
+ - Warn if local var name matches dictionary, : foo { count -- } ;\r
+ - TO -> and +-> now parse input stream. No longer use to-flag.\r
+ - TO -> and +-> now give error if used with non-immediate word.\r
+ - Added (FLITERAL) support to SEE.\r
+ - Aded TRACE facility for single step debugging of Forth words.\r
+ - Added stub for ?TERMINAL and KEY? for embedded systems.\r
+ - Added PF_NO_GLOBAL_INIT for no reliance on global initialization.\r
+ - Added PF_USER_FLOAT for customization of FP support.\r
+ - Added floating point to string conversion words (F.) (FS.) (FE.)\r
+ For example: : F. (F.) TYPE SPACE ;\r
+ - Reversed order that values are placed on return stack in 2>R\r
+ so that it matches ANS standard. 2>R is now same as SWAP >R >R\r
+ Thank you Leo Wong for reporting this bug.\r
+\r
+ - Added PF_USER_INIT and PF_USER_TERM for user definable init and term calls.\r
+\r
+ - FIXED memory leak in pfDoForth()\r
+\r
+V20\r
+ - Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.\r
+ Thank you Michael Connor of Vancouver for reporting this bug.\r
+\r
+ - Removed FDROP in REPRESENT to fix stack underflow after "0.0 F.".\r
+ Thank you Jim Rosenow of Minnesota for reporting this bug.\r
+ - Changed pfCharToLower to function to prevent macro expansion bugs under VXWORKS\r
+ Thank you Jim Rosenow of Minnesota for reporting this bug.\r
+\r
+ - "0.0 F~" now checks actual binary encoding of floats. Before this it used to just\r
+ compare value which was incorrect. Now "0.0 -0.0 0.0 F~" returns FALSE.\r
+\r
+ - Fixed definition of INPUT$ in tutorial.\r
+ Thank you Hampton Miller of California for reporting this bug.\r
+\r
+ - Added support for producing a target dictionary with a different\r
+ Endian-ness than the host CPU. See PF_BIG_ENDIAN_DIC and PF_LITTLE_ENDIAN_DIC.\r
+\r
+ - PForth kernel now comes up in a mode that uses BASE for numeric input when\r
+ started with "-i" option. It used to always consider numeric input as HEX.\r
+ Initial BASE is decimal. \r
+\r
+V21\r
+ - Fixed some compiler warnings.\r
+\r
+Enjoy,\r
+Phil Burk\r
--- /dev/null
+\ @(#) 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 <name> )
+ ,
+ immediate
+ DOES>
+ state @
+ IF
+ [compile] aliteral
+ compile @
+ ELSE
+ @
+ THEN
+;
+
+: TO ( val <name> -- )
+ 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 <name> -- )
+ 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
--- /dev/null
+\ @(#) 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
+
+: <SIEVE> ( --- #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 <SIEVE> swap drop
+ LOOP . ." primes " CR ;
+
+: SIEVE50 ." 50 iterations " CR 0 50 0
+ DO <SIEVE> 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
--- /dev/null
+\r
+\r
+: BLOOP ( n -- n' )\r
+ 0 swap 0\r
+ DO\r
+ i +\r
+ i 1 and\r
+ IF\r
+ dup dup 2 +\r
+ swap - drop\r
+ THEN\r
+ LOOP\r
+;\r
+\r
+\r
+\ ." START" cr\r
+\ 8000000 bloop .\r
+\ ." END" cr\r
+\r
+\r
+: uselocs { aa bb -- }\r
+ aa bb +\r
+ aa bb -\r
+ - drop\r
+;\r
+\r
+: BLOCS ( N -- )\r
+ 0 DO i 77 uselocs LOOP\r
+;\r
+\r
+\r
+." START" cr\r
+2000000 blocs\r
+." END" cr\r
--- /dev/null
+\ @(#) 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> -- 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 <member> -- , 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 <member> -- value , fetch value from member )
+ ob.stats?
+ (s@)
+; immediate
+
+
+
+exists? F* [IF]
+\ 951112 Floating Point support
+: FLPT ( <name> -- , 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 <member> -- , 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 <member> -- 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]
--- /dev/null
+\ @(#) 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
+
--- /dev/null
+\ @(#) 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
--- /dev/null
+\ compare dictionaries\r
+\r
+anew comp\r
+hex\r
+\r
+: checksum { start end -- sum }\r
+ 0\r
+ end start\r
+ DO\r
+ i @ +\r
+ 4 +LOOP\r
+;\r
+\r
+: findword { target start end -- }\r
+ end start\r
+ DO\r
+ i @ target =\r
+ IF\r
+ ." found at " i u. cr\r
+ i 16 dump\r
+ THEN\r
+ 4 +LOOP\r
+;\r
+\r
+echo on\r
+hex\r
+$ 01500fc4 codebase here findword\r
+codebase here cr .s checksum u. cr\r
+namebase context @ cr .s checksum u. cr\r
+decimal\r
+\r
+echo off\r
--- /dev/null
+\ @(#) 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? ( <name> -- flag , true if defined )
+ bl word find
+ swap drop
+; immediate
--- /dev/null
+\ 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 <FALSE>
+1S CONSTANT <TRUE>
+
+{ 0 0= -> <TRUE> }
+{ 1 0= -> <FALSE> }
+{ 2 0= -> <FALSE> }
+{ -1 0= -> <FALSE> }
+{ MAX-UINT 0= -> <FALSE> }
+{ MIN-INT 0= -> <FALSE> }
+{ MAX-INT 0= -> <FALSE> }
+
+{ 0 0 = -> <TRUE> }
+{ 1 1 = -> <TRUE> }
+{ -1 -1 = -> <TRUE> }
+{ 1 0 = -> <FALSE> }
+{ -1 0 = -> <FALSE> }
+{ 0 1 = -> <FALSE> }
+{ 0 -1 = -> <FALSE> }
+
+{ 0 0< -> <FALSE> }
+{ -1 0< -> <TRUE> }
+{ MIN-INT 0< -> <TRUE> }
+{ 1 0< -> <FALSE> }
+{ MAX-INT 0< -> <FALSE> }
+
+{ 0 1 < -> <TRUE> }
+{ 1 2 < -> <TRUE> }
+{ -1 0 < -> <TRUE> }
+{ -1 1 < -> <TRUE> }
+{ MIN-INT 0 < -> <TRUE> }
+{ MIN-INT MAX-INT < -> <TRUE> }
+{ 0 MAX-INT < -> <TRUE> }
+{ 0 0 < -> <FALSE> }
+{ 1 1 < -> <FALSE> }
+{ 1 0 < -> <FALSE> }
+{ 2 1 < -> <FALSE> }
+{ 0 -1 < -> <FALSE> }
+{ 1 -1 < -> <FALSE> }
+{ 0 MIN-INT < -> <FALSE> }
+{ MAX-INT MIN-INT < -> <FALSE> }
+{ MAX-INT 0 < -> <FALSE> }
+
+{ 0 1 > -> <FALSE> }
+{ 1 2 > -> <FALSE> }
+{ -1 0 > -> <FALSE> }
+{ -1 1 > -> <FALSE> }
+{ MIN-INT 0 > -> <FALSE> }
+{ MIN-INT MAX-INT > -> <FALSE> }
+{ 0 MAX-INT > -> <FALSE> }
+{ 0 0 > -> <FALSE> }
+{ 1 1 > -> <FALSE> }
+{ 1 0 > -> <TRUE> }
+{ 2 1 > -> <TRUE> }
+{ 0 -1 > -> <TRUE> }
+{ 1 -1 > -> <TRUE> }
+{ 0 MIN-INT > -> <TRUE> }
+{ MAX-INT MIN-INT > -> <TRUE> }
+{ MAX-INT 0 > -> <TRUE> }
+
+{ 0 1 U< -> <TRUE> }
+{ 1 2 U< -> <TRUE> }
+{ 0 MID-UINT U< -> <TRUE> }
+{ 0 MAX-UINT U< -> <TRUE> }
+{ MID-UINT MAX-UINT U< -> <TRUE> }
+{ 0 0 U< -> <FALSE> }
+{ 1 1 U< -> <FALSE> }
+{ 1 0 U< -> <FALSE> }
+{ 2 1 U< -> <FALSE> }
+{ MID-UINT 0 U< -> <FALSE> }
+{ MAX-UINT 0 U< -> <FALSE> }
+{ MAX-UINT MID-UINT U< -> <FALSE> }
+
+{ 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< -> <TRUE> } \ 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< -> <TRUE> } \ 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< -> <TRUE> } \ 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 < -> <FALSE> }
+{ 1 CHARS 1 CELLS > -> <FALSE> }
+( TBD: HOW TO FIND NUMBER OF BITS? )
+
+( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
+{ 1 CELLS 1 < -> <FALSE> }
+{ 1 CELLS 1 CHARS MOD -> 0 }
+{ 1S BITS 10 < -> <FALSE> }
+
+{ 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= -> <FALSE> }
+
+\ ------------------------------------------------------------------------
+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 -> <TRUE> <TRUE> }
+
+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 <FALSE> UNLOOP EXIT THEN
+ SWAP CHAR+ SWAP CHAR+
+ LOOP
+ THEN
+ 2DROP <TRUE> \ IF WE GET HERE, STRINGS MATCH
+ ELSE
+ R> DROP 2DROP <FALSE> \ LENGTHS MISMATCH
+ THEN ;
+
+: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
+{ GP1 -> <TRUE> }
+
+: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
+{ GP2 -> <TRUE> }
+
+: GP3 <# 1 0 # # #> S" 01" S= ;
+{ GP3 -> <TRUE> }
+
+: GP4 <# 1 0 #S #> S" 1" S= ;
+{ GP4 -> <TRUE> }
+
+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 @ <TRUE>
+ 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 -> <TRUE> }
+
+: 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 -> <TRUE> }
+
+: GP7
+ BASE @ >R MAX-BASE BASE !
+ <TRUE>
+ 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 -> <TRUE> }
+
+\ >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 }
+
+
--- /dev/null
+/* @(#) pf_all.h 98/01/26 1.2 */\r
+\r
+#ifndef _pf_all_h\r
+#define _pf_all_h\r
+\r
+/***************************************************************\r
+** Include all files needed for PForth\r
+**\r
+** Author: Phil Burk\r
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
+**\r
+** The pForth software code is dedicated to the public domain,\r
+** and any third party may reproduce, distribute and modify\r
+** the pForth software code or any derivative works thereof\r
+** without any compensation or license. The pForth software\r
+** code is provided on an "as is" basis without any warranty\r
+** of any kind, including, without limitation, the implied\r
+** warranties of merchantability and fitness for a particular\r
+** purpose and their equivalents under the laws of any jurisdiction.\r
+**\r
+** 940521 PLB Creation.\r
+**\r
+***************************************************************/\r
+\r
+/* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */\r
+#ifdef __MWERKS__\r
+ #define PF_USER_INC1 "pf_mac.h"\r
+ #define PF_SUPPORT_FP (1)\r
+#endif\r
+\r
+\r
+#ifdef WIN32\r
+ #define PF_USER_INC2 "pf_win32.h"\r
+#endif\r
+\r
+\r
+#if defined(PF_USER_INC1)\r
+ #include PF_USER_INC1\r
+#else\r
+/* Default to UNIX if no host speciied. */\r
+ #include "pf_unix.h"\r
+#endif\r
+\r
+#include "pf_types.h"\r
+#include "pf_io.h"\r
+#include "pf_guts.h"\r
+#include "pf_text.h"\r
+#include "pfcompil.h"\r
+#include "pf_clib.h"\r
+#include "pf_words.h"\r
+#include "pf_save.h"\r
+#include "pf_mem.h"\r
+#include "pf_cglue.h"\r
+#include "pf_core.h"\r
+\r
+#ifdef PF_USER_INC2\r
+/* This could be used to undef and redefine macros. */\r
+ #include PF_USER_INC2\r
+#endif\r
+\r
+#endif /* _pf_all_h */\r
+\r
--- /dev/null
+/* @(#) 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
--- /dev/null
+/* @(#) 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 */
--- /dev/null
+/* @(#) 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 */
+\r
+char pfCharToUpper( char c )\r
+{\r
+ return (char) ( ((c>='a') && (c<='z')) ? (c - ('a' - 'A')) : c );\r
+}\r
+\r
+char pfCharToLower( char c )\r
+{\r
+ return (char) ( ((c>='A') && (c<='Z')) ? (c + ('a' - 'A')) : c );\r
+}\r
--- /dev/null
+/* @(#) 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\r
+/* 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 */
+\r
+#ifdef __cplusplus\r
+extern "C" {\r
+#endif\r
+\r
+/* Always use my own functions to avoid macro expansion problems with tolower(*s++) */\r
+char pfCharToUpper( char c );\r
+char pfCharToLower( char c );\r
+\r
+#ifdef __cplusplus\r
+} \r
+#endif\r
+
+#endif /* _pf_clib_h */
--- /dev/null
+/* @(#) 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;\r
+\r
+/* Align dictionary segments to preserve alignment of floats across hosts. */
+#define DIC_ALIGNMENT_SIZE (0x10)\r
+#define DIC_ALIGN(addr) ((uint8 *)((((uint32)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1)))\r
+
+/* Allocate memory for header. */
+ if( HeaderSize > 0 )
+ {
+ dic->dic_HeaderBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) HeaderSize + DIC_ALIGNMENT_SIZE );
+ if( !dic->dic_HeaderBaseUnaligned ) goto nomem;\r
+/* Align header base. */\r
+ 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;\r
+ 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;
+ \r
+#ifdef PF_USER_INIT\r
+ Result = PF_USER_INIT;\r
+ if( Result < 0 ) goto error;\r
+#endif\r
+
+ 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;
+ \r
+ 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 );
+ }\r
+ \r
+#ifdef PF_USER_TERM\r
+ PF_USER_TERM;\r
+#endif\r
+
+ return Result;
+
+error:
+ MSG("pfDoForth: Error occured.\n");
+ pfDeleteTask( cftd );
+ return -1;
+}
--- /dev/null
+/* @(#) 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 */
--- /dev/null
+/* @(#) pf_float.h 98/01/28 1.1 */\r
+#ifndef _pf_float_h\r
+#define _pf_float_h\r
+\r
+/***************************************************************\r
+** Include file for PForth, a Forth based on 'C'\r
+**\r
+** Author: Phil Burk\r
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
+**\r
+** The pForth software code is dedicated to the public domain,\r
+** and any third party may reproduce, distribute and modify\r
+** the pForth software code or any derivative works thereof\r
+** without any compensation or license. The pForth software\r
+** code is provided on an "as is" basis without any warranty\r
+** of any kind, including, without limitation, the implied\r
+** warranties of merchantability and fitness for a particular\r
+** purpose and their equivalents under the laws of any jurisdiction.\r
+**\r
+***************************************************************/\r
+\r
+typedef double PF_FLOAT;\r
+\r
+/* Define pForth specific math functions. */\r
+\r
+#define fp_acos acos\r
+#define fp_asin asin\r
+#define fp_atan atan\r
+#define fp_atan2 atan2\r
+#define fp_cos cos\r
+#define fp_cosh cosh \r
+#define fp_fabs fabs\r
+#define fp_floor floor\r
+#define fp_log log \r
+#define fp_log10 log10\r
+#define fp_pow pow\r
+#define fp_sin sin\r
+#define fp_sinh sinh\r
+#define fp_sqrt sqrt\r
+#define fp_tan tan\r
+#define fp_tanh tanh\r
+\r
+#endif\r
--- /dev/null
+/* @(#) 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.\r
+** 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. */\r
+ uint8 *dic_HeaderBaseUnaligned;\r
+ uint8 *dic_HeaderBase;
+ union
+ {
+ cell *Cell;
+ uint8 *Byte;
+ } dic_HeaderPtr;
+ uint8 *dic_HeaderLimit;
+/* Code segment contains tokenized code and data. */\r
+ uint8 *dic_CodeBaseUnaligned;\r
+ 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
+***************************************************************/
+\r
+/* Endian specific macros for creating target dictionaries for machines with\r
+** different endian-ness.\r
+*/\r
+#if defined(PF_BIG_ENDIAN_DIC)\r
+#define WRITE_FLOAT_DIC WriteFloatBigEndian\r
+#define WRITE_LONG_DIC(addr,data) WriteLongBigEndian((uint32 *)(addr),(uint32)(data))\r
+#define WRITE_SHORT_DIC(addr,data) WriteShortBigEndian((uint16 *)(addr),(uint16)(data))\r
+#define READ_FLOAT_DIC ReadFloatBigEndian\r
+#define READ_LONG_DIC(addr) ReadLongBigEndian((uint32 *)(addr))\r
+#define READ_SHORT_DIC(addr) ReadShortBigEndian((uint16 *)(addr))\r
+#elif defined(PF_LITTLE_ENDIAN_DIC)\r
+#define WRITE_FLOAT_DIC WriteFloatLittleEndian\r
+#define WRITE_LONG_DIC(addr,data) WriteLongLittleEndian((uint32 *)(addr),(uint32)(data))\r
+#define WRITE_SHORT_DIC(addr,data) WriteShortLittleEndian((uint16 *)(addr),(uint16)(data))\r
+#define READ_FLOAT_DIC ReadFloatLittleEndian\r
+#define READ_LONG_DIC(addr) ReadLongLittleEndian((uint32 *)(addr))\r
+#define READ_SHORT_DIC(addr) ReadShortLittleEndian((uint16 *)(addr))\r
+#else\r
+#define WRITE_FLOAT_DIC(addr,data) { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); }\r
+#define WRITE_LONG_DIC(addr,data) { *((int32 *)(addr)) = (int32)(data); }\r
+#define WRITE_SHORT_DIC(addr,data) { *((int16 *)(addr)) = (int16)(data); }\r
+#define READ_FLOAT_DIC(addr) ( *((PF_FLOAT *)(addr)) )\r
+#define READ_LONG_DIC(addr) ( *((int32 *)(addr)) )\r
+#define READ_SHORT_DIC(addr) ( *((int16 *)(addr)) )\r
+#endif\r
+
+#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)\r
+\r
+#define IN_CODE_DIC(addr) ( ( ((uint8 *)(addr)) >= gCurrentDictionary->dic_CodeBase) && ( ((uint8 *)(addr)) < gCurrentDictionary->dic_CodeLimit) )\r
+#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))\r
+\r
+/* 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<gNumPrimitives) && (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 */
+
--- /dev/null
+/* @(#) 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 */
+
--- /dev/null
+/* @(#) 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; i<Level; i++ )
+ {
+ MSG( " " );
+ }
+ TypeName( DebugName );
+/* Space out to column N then .S */
+ NumSpaces = 30 - gCurrentTask->td_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<du1h) ? FALSE : ( (du2h==du1h) ? (du1l<du2l) : TRUE) )
+/* Perform 64/32 bit divide for 32 bit result, using shift and subtract. */
+ case ID_D_UMSMOD: /* UM/MOD ( al ah bdiv -- rem q ) */
+ {
+ ucell ah,al, q,di, bl,bh, sl,sh;
+ ah = M_POP;
+ al = M_POP;
+ bh = TOS;
+ bl = 0;
+ q = 0;
+ for( di=0; di<32; di++ )
+ {
+ if( !DULT(al,ah,bl,bh) )
+ {
+ sh = 0;
+ sl = al - bl;
+ if( al < bl ) sh = 1; /* Borrow */
+ sh = ah - bh - sh;
+ ah = sh;
+ al = sl;
+ q |= 1;
+ }
+ q = q << 1;
+ bl = (bl >> 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:\r
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
+ if( IN_DICS( TOS ) )\r
+ {\r
+ TOS = (cell) READ_LONG_DIC((cell *)TOS);\r
+ }\r
+ else\r
+ {\r
+ TOS = *((cell *)TOS);\r
+ }\r
+#else\r
+ TOS = *((cell *)TOS);\r
+#endif\r
+ 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 <local> -- n , fetch from local ) */
+ TOS = *(LocalsPtr - TOS);
+ endcase;
+
+#define LOCAL_FETCH_N(num) \
+ case ID_LOCAL_FETCH_##num: /* ( <local> -- 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 <local> -- , store n in local ) */
+ *(LocalsPtr - TOS) = M_POP;
+ M_DROP;
+ endcase;
+
+#define LOCAL_STORE_N(num) \
+ case ID_LOCAL_STORE_##num: /* ( n <local> -- , 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 <local> -- , add n to local ) */\r
+ *(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 ) */\r
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
+ if( IN_DICS( TOS ) )\r
+ {
+ Scratch = READ_LONG_DIC((cell *)TOS);\r
+ Scratch += M_POP;\r
+ WRITE_LONG_DIC((cell *)TOS,Scratch);\r
+ }\r
+ else\r
+ {\r
+ *((cell *)TOS) += M_POP;\r
+ }\r
+#else\r
+ *((cell *)TOS) += M_POP;\r
+#endif\r
+ 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; ri++ )
+ {
+ *dstPtr-- = *srcPtr--;
+ }
+ TOS = Scratch;
+ STKPTR++;
+ }
+ endcase;
+
+ case ID_ROT: /* ( a b c -- b c a ) */
+ Scratch = M_POP; /* b */
+ Temp = M_POP; /* a */
+ M_PUSH( Scratch ); /* b */
+ PUSH_TOS; /* c */
+ TOS = Temp; /* a */
+ endcase;
+
+/* Logical right shift */
+ case ID_RSHIFT: { TOS = ((uint32)M_POP) >> 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 ) */\r
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
+ if( IN_DICS( TOS ) )\r
+ {\r
+ WRITE_LONG_DIC((cell *)TOS,M_POP);\r
+ }\r
+ else\r
+ {\r
+ *((cell *)TOS) = M_POP;\r
+ }\r
+#else\r
+ *((cell *)TOS) = M_POP;\r
+#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 ) */\r
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
+ if( IN_DICS( TOS ) )\r
+ {\r
+ TOS = (uint16) READ_SHORT_DIC((uint16 *)TOS);\r
+ }\r
+ else\r
+ {\r
+ TOS = *((uint16 *)TOS);\r
+ }\r
+#else\r
+ TOS = *((uint16 *)TOS);\r
+#endif
+ endcase;
+
+ case ID_WORD_STORE: /* ( w waddr -- ) */\r
+ \r
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
+ if( IN_DICS( TOS ) )\r
+ {\r
+ WRITE_SHORT_DIC((uint16 *)TOS,(uint16)M_POP);\r
+ }\r
+ else\r
+ {\r
+ *((uint16 *)TOS) = (uint16) M_POP;\r
+ }\r
+#else\r
+ *((uint16 *)TOS) = (uint16) M_POP;\r
+#endif\r
+ M_DROP;\r
+ 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;
+}
--- /dev/null
+/* @(#) 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<n; i++)
+ {
+ ioEmit ( *s++ );
+ }
+}
+
+/***************************************************************
+** Return single character from input device, always keyboard.
+*/
+cell ioKey( void )
+{
+ return sdTerminalIn();
+}
+
+/**************************************************************
+** Receive line from input stream.
+** Return length, or -1 for EOF.
+*/
+#define BACKSPACE (8)
+cell ioAccept( char *Target, cell MaxLen, FileStream *stream )
+{
+ int32 c;
+ int32 Len;
+ char *p;
+
+DBUGX(("ioAccept(0x%x, 0x%x, 0x%x)\n", Target, Len, stream ));
+ p = Target;
+ Len = MaxLen;
+ while(Len > 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
+
--- /dev/null
+/* @(#) 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 */
--- /dev/null
+/* @(#) pf_mac.h 98/01/26 1.2 */\r
+#ifndef _pf_mac_h\r
+#define _pf_mac_h\r
+\r
+/***************************************************************\r
+** Macintosh dependant include file for PForth, a Forth based on 'C'\r
+**\r
+** Author: Phil Burk\r
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
+**\r
+** The pForth software code is dedicated to the public domain,\r
+** and any third party may reproduce, distribute and modify\r
+** the pForth software code or any derivative works thereof\r
+** without any compensation or license. The pForth software\r
+** code is provided on an "as is" basis without any warranty\r
+** of any kind, including, without limitation, the implied\r
+** warranties of merchantability and fitness for a particular\r
+** purpose and their equivalents under the laws of any jurisdiction.\r
+**\r
+***************************************************************/\r
+\r
+#include <CType.h>\r
+#include <String.h>\r
+\r
+#include <StdLib.h>\r
+#include <StdIO.h>\r
+\r
+\r
+#ifdef PF_SUPPORT_FP\r
+ #include <Math.h>\r
+ \r
+ #ifndef PF_USER_FP\r
+ #include "pf_float.h"\r
+ #else\r
+ #include PF_USER_FP\r
+ #endif\r
+#endif\r
+\r
+#endif /* _pf_mac_h */\r
--- /dev/null
+/* @(#) 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 <stdio.h>
+ #define ERR(msg) { printf msg; }
+#endif
+
+#include "pforth.h"
+
+#ifdef __MWERKS__
+ #include <console.h>
+ #include <sioux.h>
+#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; i<argc; i++ )
+ {
+ s = argv[i];
+
+ if( *s == '-' )
+ {
+ char c;
+ s++; /* past '-' */
+ c = *s++;
+ switch(c)
+ {
+ case 'i':
+ IfInit = TRUE;
+ DicName = NULL;
+ break;
+ case 'q':
+ pfSetQuiet( TRUE );
+ break;
+ case 'd':
+ DicName = s;
+ break;
+ default:
+ ERR(("Unrecognized option!\n"));
+ ERR(("pforth {-i} {-q} {-dfilename.dic} {sourcefilename}\n"));
+ Result = 1;
+ goto on_error;
+ break;
+ }
+ }
+ else
+ {
+ SourceName = s;
+ }
+ }
+/* Force Init */
+#ifdef PF_INIT_MODE
+ IfInit = TRUE;
+ DicName = NULL;
+#endif
+
+ Result = pfDoForth( DicName, SourceName, IfInit);
+
+on_error:
+ return Result;
+}
--- /dev/null
+/* @(#) pf_mem.c 98/01/26 1.3 */
+/***************************************************************
+** Memory allocator for systems that don't have real one.
+** This might be useful when bringing up a new computer with no OS.
+**
+** 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.
+**
+****************************************************************
+**
+***************************************************************/
+
+#include "pf_all.h"
+
+
+#ifdef PF_NO_MALLOC
+
+static char *gMemPoolPtr;
+static uint32 gMemPoolSize;
+
+/* CUSTOM: Make the memory pool bigger if you want. */
+#ifndef PF_MEM_POOL_SIZE
+ #define PF_MEM_POOL_SIZE (0x100000)
+#endif
+
+#define PF_MEM_BLOCK_SIZE (16)
+
+#ifndef PF_MALLOC_ADDRESS
+ static char MemoryPool[PF_MEM_POOL_SIZE];
+ #define PF_MALLOC_ADDRESS MemoryPool
+#endif
+
+/**********************************************************
+** Doubly Linked List Tools
+**********************************************************/
+
+typedef struct DoublyLinkedListNode
+{
+ struct DoublyLinkedListNode *dlln_Next;
+ struct DoublyLinkedListNode *dlln_Previous;
+} DoublyLinkedListNode;
+
+typedef struct DoublyLinkedList
+{
+ struct DoublyLinkedListNode *dll_First;
+ struct DoublyLinkedListNode *dll_Null;
+ struct DoublyLinkedListNode *dll_Last;
+} DoublyLinkedList;
+
+#define dllPreviousNode(n) ((n)->dlln_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 */
--- /dev/null
+/* @(#) 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\r
+ #define pfAllocMem malloc\r
+ #define pfFreeMem free
+ #endif
+
+#endif /* PF_NO_MALLOC */
+
+#endif /* _pf_mem_h */
--- /dev/null
+/* @(#) 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"
+\r
+int IsHostLittleEndian( void );\r
+
+/* 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.\r
+The dictionaries may be big or little endian.
+ 'FORM'
+ size
+ 'P4TH' - Form Identifier
+
+Chunks
+ 'P4DI'
+ size\r
+ 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
+\r
+\r
+/***************************************************************/\r
+/* Endian-ness tools. */\r
+uint32 ReadLongBigEndian( const uint32 *addr )\r
+{\r
+ const unsigned char *bp = (const unsigned char *) addr;\r
+ return (bp[0]<<24) | (bp[1]<<16) | (bp[2]<<8) | bp[3];\r
+}\r
+/***************************************************************/\r
+uint16 ReadShortBigEndian( const uint16 *addr )\r
+{\r
+ const unsigned char *bp = (const unsigned char *) addr;\r
+ return (uint16) ((bp[0]<<8) | bp[1]);\r
+}\r
+\r
+/***************************************************************/\r
+uint32 ReadLongLittleEndian( const uint32 *addr )\r
+{\r
+ const unsigned char *bp = (const unsigned char *) addr;\r
+ return (bp[3]<<24) | (bp[2]<<16) | (bp[1]<<8) | bp[0];\r
+}\r
+/***************************************************************/\r
+uint16 ReadShortLittleEndian( const uint16 *addr )\r
+{\r
+ const unsigned char *bp = (const unsigned char *) addr;\r
+ return (uint16) ((bp[1]<<8) | bp[0]);\r
+}\r
+\r
+#ifdef PF_SUPPORT_FP\r
+\r
+/***************************************************************/\r
+static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst );\r
+\r
+static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst )\r
+{\r
+ int i;\r
+ unsigned char *d = (unsigned char *) dst;\r
+ const unsigned char *s = (const unsigned char *) src;\r
+\r
+ for( i=0; i<sizeof(PF_FLOAT); i++ )\r
+ {\r
+ d[i] = s[sizeof(PF_FLOAT) - 1 - i];\r
+ }\r
+}\r
+\r
+/***************************************************************/\r
+void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data )\r
+{\r
+ if( IsHostLittleEndian() )\r
+ {\r
+ ReverseCopyFloat( &data, addr );\r
+ }\r
+ else\r
+ {\r
+ *addr = data;\r
+ }\r
+}\r
+\r
+/***************************************************************/\r
+PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr )\r
+{\r
+ PF_FLOAT data;\r
+ if( IsHostLittleEndian() )\r
+ {\r
+ ReverseCopyFloat( addr, &data );\r
+ return data;\r
+ }\r
+ else\r
+ {\r
+ return *addr;\r
+ }\r
+}\r
+\r
+/***************************************************************/\r
+void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data )\r
+{\r
+ if( IsHostLittleEndian() )\r
+ {\r
+ *addr = data;\r
+ }\r
+ else\r
+ {\r
+ ReverseCopyFloat( &data, addr );\r
+ }\r
+}\r
+\r
+/***************************************************************/\r
+PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr )\r
+{\r
+ PF_FLOAT data;\r
+ if( IsHostLittleEndian() )\r
+ {\r
+ return *addr;\r
+ }\r
+ else\r
+ {\r
+ ReverseCopyFloat( addr, &data );\r
+ return data;\r
+ }\r
+}\r
+\r
+#endif\r
+\r
+/***************************************************************/\r
+void WriteLongBigEndian( uint32 *addr, uint32 data )\r
+{\r
+ unsigned char *bp = (unsigned char *) addr;\r
+\r
+ bp[0] = (unsigned char) (data>>24);\r
+ bp[1] = (unsigned char) (data>>16);\r
+ bp[2] = (unsigned char) (data>>8);\r
+ bp[3] = (unsigned char) (data);\r
+}\r
+\r
+/***************************************************************/\r
+void WriteShortBigEndian( uint16 *addr, uint16 data )\r
+{\r
+ unsigned char *bp = (unsigned char *) addr;\r
+\r
+ bp[0] = (unsigned char) (data>>8);\r
+ bp[1] = (unsigned char) (data);\r
+}\r
+\r
+/***************************************************************/\r
+void WriteLongLittleEndian( uint32 *addr, uint32 data )\r
+{\r
+ unsigned char *bp = (unsigned char *) addr;\r
+\r
+ bp[0] = (unsigned char) (data);\r
+ bp[1] = (unsigned char) (data>>8);\r
+ bp[2] = (unsigned char) (data>>16);\r
+ bp[3] = (unsigned char) (data>>24);\r
+}\r
+/***************************************************************/\r
+void WriteShortLittleEndian( uint16 *addr, uint16 data )\r
+{\r
+ unsigned char *bp = (unsigned char *) addr;\r
+\r
+ bp[0] = (unsigned char) (data);\r
+ bp[1] = (unsigned char) (data>>8);\r
+}\r
+\r
+/***************************************************************/\r
+/* Return 1 if host CPU is Little Endian */\r
+int IsHostLittleEndian( void )\r
+{\r
+ uint16 gEndianCheck = 1;\r
+ unsigned char *bp = (unsigned char *) &gEndianCheck;\r
+ return *bp; /* Return byte pointed to by address. If LSB then == 1 */\r
+}\r
+
+#ifndef PF_STATIC_DIC
+
+#ifndef PF_NO_SHELL
+/***************************************************************/
+static int32 WriteLong( FileStream *fid, int32 Val )
+{
+ int32 numw;\r
+ uint32 pad;
+\r
+ 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;\r
+ uint32 rhp, rcp;\r
+ uint32 *p;\r
+ 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;
+\r
+ 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);\r
+ SD.sd_NumPrimitives = gNumPrimitives; /* Must match compiled dictionary. */\r
+\r
+#ifdef PF_SUPPORT_FP\r
+ SD.sd_FloatSize = sizeof(PF_FLOAT); /* Must match compiled dictionary. */\r
+#else\r
+ SD.sd_FloatSize = 0;\r
+#endif\r
+\r
+ SD.sd_Reserved = 0;\r
+\r
+/* Set bit that specifiec whether dictionary is BIG or LITTLE Endian. */\r
+ {\r
+#if defined(PF_BIG_ENDIAN_DIC)\r
+ int eflag = SD_F_BIG_ENDIAN_DIC;\r
+#elif defined(PF_LITTLE_ENDIAN_DIC)\r
+ int eflag = 0;\r
+#else\r
+ int eflag = IsHostLittleEndian() ? 0 : SD_F_BIG_ENDIAN_DIC;\r
+#endif
+ SD.sd_Flags = eflag;\r
+ }\r
+
+ 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);\r
+ rhp = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr.Byte);\r
+ 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;
+\r
+ \r
+/* Convert all fields in structure from Native to BigEndian. */\r
+ p = (uint32 *) &SD;\r
+ for( i=0; i<((int)(sizeof(SD)/sizeof(int32))); i++ )\r
+ {\r
+ WriteLongBigEndian( &p[i], p[i] );\r
+ }\r
+
+ 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;\r
+
+ numr = sdReadFile( &temp, 1, sizeof(int32), fid );
+ if( numr != sizeof(int32) ) return -1;\r
+ *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;\r
+ uint32 *p;\r
+ int i;\r
+ int isDicBigEndian;\r
+
+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;
+ \r
+/* Convert all fields in structure from BigEndian to Native. */\r
+ p = (uint32 *) sd;\r
+ for( i=0; i<((int)(sizeof(*sd)/sizeof(int32))); i++ )\r
+ {\r
+ p[i] = ReadLongBigEndian( &p[i] );\r
+ }\r
+\r
+ isDicBigEndian = sd->sd_Flags & SD_F_BIG_ENDIAN_DIC;\r
+
+ 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 );\r
+ MSG_NUM_D(" Entry Point = ", sd->sd_EntryPoint );\r
+ MSG( (isDicBigEndian ? " Big Endian Dictionary" :\r
+ " Little Endian Dictionary") );\r
+ if( isDicBigEndian == IsHostLittleEndian() ) MSG(" !!!!");\r
+ 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;
+ }
+\r
+/* Check to make sure that EndianNess of dictionary matches mode of pForth. */\r
+#if defined(PF_BIG_ENDIAN_DIC)\r
+ if(isDicBigEndian == 0)\r
+#elif defined(PF_LITTLE_ENDIAN_DIC)\r
+ if(isDicBigEndian == 1)\r
+#else\r
+ if( isDicBigEndian == IsHostLittleEndian() )\r
+#endif\r
+ {\r
+ pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT );\r
+ goto error;\r
+ }\r
+\r
+/* Check for compatible float size. */\r
+#ifdef PF_SUPPORT_FP\r
+ if( sd->sd_FloatSize != sizeof(PF_FLOAT) )\r
+#else\r
+ if( sd->sd_FloatSize != 0 )\r
+#endif\r
+ {\r
+ pfReportError("pfLoadDictionary", PF_ERR_FLOAT_CONFLICT );\r
+ goto error;\r
+ }\r
+
+ 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 *)\r
+ 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;
+}\r
+\r
+\r
+/***************************************************************/\r
+cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr )\r
+{\r
+ cfDictionary *dic;\r
+ int32 Result;\r
+ int32 NewNameSize, NewCodeSize;\r
+\r
+MSG("pfLoadDictionary - Filename ignored! Loading from static data.\n");\r
+\r
+ TOUCH(FileName);\r
+ TOUCH(EntryPointPtr);
+\r
+/* Check to make sure that EndianNess of dictionary matches mode of pForth. */\r
+#if defined(PF_BIG_ENDIAN_DIC)\r
+ if(IF_LITTLE_ENDIAN == 1)\r
+#elif defined(PF_LITTLE_ENDIAN_DIC)\r
+ if(IF_LITTLE_ENDIAN == 0)\r
+#else\r
+ if( IF_LITTLE_ENDIAN != IsHostLittleEndian() )\r
+#endif\r
+ {\r
+ pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT );\r
+ goto error;\r
+ }\r
+\r
+/* Static data too small. Copy it to larger array. */\r
+#ifndef PF_EXTRA_HEADERS\r
+ #define PF_EXTRA_HEADERS (20000)\r
+#endif\r
+#ifndef PF_EXTRA_CODE\r
+ #define PF_EXTRA_CODE (40000)\r
+#endif\r
+/* Copy static const data to allocated dictionaries. */\r
+ NewNameSize = sizeof(MinDicNames) + PF_EXTRA_HEADERS;\r
+ NewCodeSize = sizeof(MinDicCode) + PF_EXTRA_CODE;\r
+\r
+ gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize );\r
+ if( !dic ) goto nomem_error;\r
+\r
+ pfCopyMemory( dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) );\r
+ pfCopyMemory( dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) );\r
+ MSG("Static data copied to newly allocated dictionaries.\n");\r
+\r
+ dic->dic_CodePtr.Byte = (uint8 *) CODEREL_TO_ABS(CODEPTR);\r
+ gNumPrimitives = NUM_PRIMITIVES;\r
+\r
+ if( NAME_BASE != NULL)\r
+ {\r
+/* Setup name space. */\r
+ dic->dic_HeaderPtr.Byte = (uint8 *) NAMEREL_TO_ABS(HEADERPTR);\r
+ gVarContext = (char *) NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */\r
+\r
+/* Find special words in dictionary for global XTs. */\r
+ if( (Result = FindSpecialXTs()) < 0 )\r
+ {\r
+ pfReportError("pfLoadDictionary: FindSpecialXTs", Result);\r
+ goto error;\r
+ }\r
+ }\r
+\r
+ return dic;\r
+\r
+error:\r
+ pfReportError("pfLoadDictionary", -1);\r
+ return NULL;\r
+\r
+nomem_error:\r
+ pfReportError("pfLoadDictionary", PF_ERR_NO_MEM);\r
+ return NULL;\r
+}\r
+
+
+#endif /* PF_STATIC_DIC */
--- /dev/null
+/* @(#) 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
+{\r
+/* All fields are stored in BIG ENDIAN format for consistency in data files. */\r
+/* 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. */\r
+ uint32 sd_Flags;\r
+ int32 sd_FloatSize; /* In bytes. Must match code. 0 means no floats. */\r
+ uint32 sd_Reserved;
+} DictionaryInfoChunk;
+\r
+/* Bits in sd_Flags */\r
+#define SD_F_BIG_ENDIAN_DIC (1<<0)\r
+
+#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 );\r
+\r
+/* Endian-ness tools. */\r
+uint32 ReadLongBigEndian( const uint32 *addr );\r
+uint16 ReadShortBigEndian( const uint16 *addr );\r
+uint32 ReadLongLittleEndian( const uint32 *addr );\r
+uint16 ReadShortLittleEndian( const uint16 *addr );\r
+void WriteLongBigEndian( uint32 *addr, uint32 data );\r
+void WriteShortBigEndian( uint16 *addr, uint16 data );\r
+void WriteLongLittleEndian( uint32 *addr, uint32 data );\r
+void WriteShortLittleEndian( uint16 *addr, uint16 data );\r
+\r
+#ifdef PF_SUPPORT_FP\r
+void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data );\r
+PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr );\r
+void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data );\r
+PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr );\r
+#endif\r
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _pforth_save_h */
--- /dev/null
+/* @(#) pf_text.c 98/01/26 1.3 */\r
+/***************************************************************\r
+** Text Strings for Error Messages\r
+** Various Text tools.\r
+**\r
+** For PForth based on 'C'\r
+**\r
+** Author: Phil Burk\r
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
+**\r
+** The pForth software code is dedicated to the public domain,\r
+** and any third party may reproduce, distribute and modify\r
+** the pForth software code or any derivative works thereof\r
+** without any compensation or license. The pForth software\r
+** code is provided on an "as is" basis without any warranty\r
+** of any kind, including, without limitation, the implied\r
+** warranties of merchantability and fitness for a particular\r
+** purpose and their equivalents under the laws of any jurisdiction.\r
+**\r
+****************************************************************\r
+** 19970702 PLB Fixed ConvertNumberToText for unsigned numbers.\r
+** 19980522 PLB Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.\r
+***************************************************************/\r
+\r
+#include "pf_all.h"\r
+\r
+#define PF_ENGLISH\r
+\r
+/*\r
+** Define array of error messages.\r
+** These are defined in one place to make it easier to translate them.\r
+*/\r
+#ifdef PF_ENGLISH\r
+/***************************************************************/\r
+void pfReportError( const char *FunctionName, Err ErrCode )\r
+{\r
+ const char *s;\r
+ \r
+ MSG("Error in ");\r
+ MSG(FunctionName);\r
+ MSG(" - ");\r
+ \r
+ switch(ErrCode & 0xFF)\r
+ {\r
+ case PF_ERR_NO_MEM & 0xFF:\r
+ s = "insufficient memory"; break;\r
+ case PF_ERR_BAD_ADDR & 0xFF:\r
+ s = "address misaligned"; break;\r
+ case PF_ERR_TOO_BIG & 0xFF:\r
+ s = "data chunk too large"; break;\r
+ case PF_ERR_NUM_PARAMS & 0xFF:\r
+ s = "incorrect number of parameters"; break;\r
+ case PF_ERR_OPEN_FILE & 0xFF:\r
+ s = "could not open file"; break;\r
+ case PF_ERR_WRONG_FILE & 0xFF:\r
+ s = "wrong type of file format"; break;\r
+ case PF_ERR_BAD_FILE & 0xFF:\r
+ s = "badly formatted file"; break;\r
+ case PF_ERR_READ_FILE & 0xFF:\r
+ s = "file read failed"; break;\r
+ case PF_ERR_WRITE_FILE & 0xFF:\r
+ s = "file write failed"; break;\r
+ case PF_ERR_CORRUPT_DIC & 0xFF:\r
+ s = "corrupted dictionary"; break;\r
+ case PF_ERR_NOT_SUPPORTED & 0xFF:\r
+ s = "not supported in this version"; break;\r
+ case PF_ERR_VERSION_FUTURE & 0xFF:\r
+ s = "version from future"; break;\r
+ case PF_ERR_VERSION_PAST & 0xFF:\r
+ s = "version is obsolete. Rebuild new one."; break;\r
+ case PF_ERR_COLON_STACK & 0xFF:\r
+ s = "stack depth changed between : and ; . Probably unbalanced conditional"; break;\r
+ case PF_ERR_HEADER_ROOM & 0xFF:\r
+ s = "no room left in header space"; break;\r
+ case PF_ERR_CODE_ROOM & 0xFF:\r
+ s = "no room left in code space"; break;\r
+ case PF_ERR_NO_SHELL & 0xFF:\r
+ s = "attempt to use names in forth compiled with PF_NO_SHELL"; break;\r
+ case PF_ERR_NO_NAMES & 0xFF:\r
+ s = "dictionary has no names"; break;\r
+ case PF_ERR_OUT_OF_RANGE & 0xFF:\r
+ s = "parameter out of range"; break;\r
+ case PF_ERR_ENDIAN_CONFLICT & 0xFF:\r
+ s = "endian-ness of dictionary does not match code"; break;\r
+ case PF_ERR_FLOAT_CONFLICT & 0xFF:\r
+ s = "float support mismatch between .dic file and code"; break;\r
+ default:\r
+ s = "unrecognized error code!"; break;\r
+ }\r
+ MSG(s);\r
+ EMIT_CR;\r
+}\r
+#endif\r
+\r
+/**************************************************************\r
+** Copy a Forth String to a 'C' string.\r
+*/\r
+\r
+char *ForthStringToC( char *dst, const char *FString )\r
+{\r
+ int32 Len;\r
+\r
+ Len = (int32) *FString;\r
+ pfCopyMemory( dst, FString+1, Len );\r
+ dst[Len] = '\0';\r
+\r
+ return dst;\r
+}\r
+\r
+/**************************************************************\r
+** Copy a NUL terminated string to a Forth counted string.\r
+*/\r
+char *CStringToForth( char *dst, const char *CString )\r
+{\r
+ char *s;\r
+ int32 i;\r
+\r
+ s = dst+1;\r
+ for( i=0; *CString; i++ )\r
+ {\r
+ *s++ = *CString++;\r
+ }\r
+ *dst = (char ) i;\r
+ return dst;\r
+}\r
+\r
+/**************************************************************\r
+** Compare two test strings, case sensitive.\r
+** Return TRUE if they match.\r
+*/\r
+int32 ffCompareText( const char *s1, const char *s2, int32 len )\r
+{\r
+ int32 i, Result;\r
+ \r
+ Result = TRUE;\r
+ for( i=0; i<len; i++ )\r
+ {\r
+DBUGX(("ffCompareText: *s1 = 0x%x, *s2 = 0x%x\n", *s1, *s2 ));\r
+ if( *s1++ != *s2++ )\r
+ {\r
+ Result = FALSE;\r
+ break;\r
+ }\r
+ }\r
+DBUGX(("ffCompareText: return 0x%x\n", Result ));\r
+ return Result;\r
+}\r
+\r
+/**************************************************************\r
+** Compare two test strings, case INsensitive.\r
+** Return TRUE if they match.\r
+*/\r
+int32 ffCompareTextCaseN( const char *s1, const char *s2, int32 len )\r
+{\r
+ int32 i, Result;\r
+ char c1,c2;\r
+ \r
+ Result = TRUE;\r
+ for( i=0; i<len; i++ )\r
+ {\r
+ c1 = pfCharToLower(*s1++);\r
+ c2 = pfCharToLower(*s2++);\r
+DBUGX(("ffCompareText: c1 = 0x%x, c2 = 0x%x\n", c1, c2 ));\r
+ if( c1 != c2 )\r
+ {\r
+ Result = FALSE;\r
+ break;\r
+ }\r
+ }\r
+DBUGX(("ffCompareText: return 0x%x\n", Result ));\r
+ return Result;\r
+}\r
+\r
+/**************************************************************\r
+** Compare two strings, case sensitive.\r
+** Return zero if they match, -1 if s1<s2, +1 is s1>s2;\r
+*/\r
+int32 ffCompare( const char *s1, int32 len1, const char *s2, int32 len2 )\r
+{\r
+ int32 i, result, n, diff;\r
+ \r
+ result = 0;\r
+ n = MIN(len1,len2);\r
+ for( i=0; i<n; i++ )\r
+ {\r
+ if( (diff = (*s2++ - *s1++)) != 0 )\r
+ {\r
+ result = (diff > 0) ? -1 : 1 ;\r
+ break;\r
+ }\r
+ }\r
+ if( result == 0 ) /* Match up to MIN(len1,len2) */\r
+ {\r
+ if( len1 < len2 )\r
+ {\r
+ result = -1;\r
+ }\r
+ else if ( len1 > len2 )\r
+ {\r
+ result = 1;\r
+ }\r
+ }\r
+ return result;\r
+}\r
+\r
+/***************************************************************\r
+** Convert number to text.\r
+*/\r
+#define CNTT_PAD_SIZE ((sizeof(int32)*8)+2) /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */\r
+static char cnttPad[CNTT_PAD_SIZE];\r
+\r
+char *ConvertNumberToText( int32 Num, int32 Base, int32 IfSigned, int32 MinChars )\r
+{\r
+ int32 IfNegative = 0;\r
+ char *p,c;\r
+ uint32 NewNum, Rem, uNum;\r
+ int32 i = 0;\r
+ \r
+ uNum = Num;\r
+ if( IfSigned )\r
+ {\r
+/* Convert to positive and keep sign. */\r
+ if( Num < 0 )\r
+ {\r
+ IfNegative = TRUE;\r
+ uNum = -Num;\r
+ }\r
+ }\r
+ \r
+/* Point past end of Pad */\r
+ p = cnttPad + CNTT_PAD_SIZE;\r
+ *(--p) = (char) 0; /* NUL terminate */\r
+ \r
+ while( (i++<MinChars) || (uNum != 0) )\r
+ {\r
+ NewNum = uNum / Base;\r
+ Rem = uNum - (NewNum * Base);\r
+ c = (char) (( Rem < 10 ) ? (Rem + '0') : (Rem - 10 + 'A'));\r
+ *(--p) = c;\r
+ uNum = NewNum;\r
+ }\r
+ \r
+ if( IfSigned )\r
+ {\r
+ if( IfNegative ) *(--p) = '-';\r
+ }\r
+ return p;\r
+}\r
+\r
+/***************************************************************\r
+** Diagnostic routine that prints memory in table format.\r
+*/\r
+void DumpMemory( void *addr, int32 cnt)\r
+{\r
+ int32 ln, cn, nlines;\r
+ unsigned char *ptr, *cptr, c;\r
+\r
+ nlines = (cnt + 15) / 16;\r
+\r
+ ptr = (unsigned char *) addr;\r
+\r
+ EMIT_CR;\r
+ \r
+ for (ln=0; ln<nlines; ln++)\r
+ {\r
+ MSG( ConvertNumberToText( (int32) ptr, 16, FALSE, 8 ) );\r
+ MSG(": ");\r
+ cptr = ptr;\r
+ for (cn=0; cn<16; cn++)\r
+ {\r
+ MSG( ConvertNumberToText( (int32) *cptr++, 16, FALSE, 2 ) );\r
+ EMIT(' ');\r
+ }\r
+ EMIT(' ');\r
+ for (cn=0; cn<16; cn++)\r
+ {\r
+ c = *ptr++;\r
+ if ((c < ' ') || (c > '}')) c = '.';\r
+ EMIT(c);\r
+ }\r
+ EMIT_CR;\r
+ }\r
+}\r
+\r
+\r
+/* Print name, mask off any dictionary bits. */\r
+void TypeName( const char *Name )\r
+{\r
+ const char *FirstChar;\r
+ int32 Len;\r
+ \r
+ FirstChar = Name+1;\r
+ Len = *Name & 0x1F;\r
+ \r
+ ioType( FirstChar, Len );\r
+}\r
+\r
--- /dev/null
+/* @(#) 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)\r
+#define PF_ERR_OUT_OF_RANGE (PF_ERR_BASE | 18)\r
+#define PF_ERR_ENDIAN_CONFLICT (PF_ERR_BASE | 19)\r
+#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 */
--- /dev/null
+/* @(#) 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 */
--- /dev/null
+/* @(#) pf_unix.h 98/01/28 1.4 */\r
+#ifndef _pf_unix_h\r
+#define _pf_unix_h\r
+\r
+/***************************************************************\r
+** UNIX dependant include file for PForth, a Forth based on 'C'\r
+**\r
+** Author: Phil Burk\r
+** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
+**\r
+** The pForth software code is dedicated to the public domain,\r
+** and any third party may reproduce, distribute and modify\r
+** the pForth software code or any derivative works thereof\r
+** without any compensation or license. The pForth software\r
+** code is provided on an "as is" basis without any warranty\r
+** of any kind, including, without limitation, the implied\r
+** warranties of merchantability and fitness for a particular\r
+** purpose and their equivalents under the laws of any jurisdiction.\r
+**\r
+***************************************************************/\r
+\r
+#include <ctype.h>\r
+\r
+#ifndef PF_NO_CLIB\r
+ #include <string.h> /* Needed for strlen(), memcpy(), and memset(). */\r
+ #include <stdlib.h> /* Needed for exit(). */\r
+#endif\r
+\r
+#include <stdio.h> /* Needed for FILE and getc(). */\r
+\r
+#ifdef PF_SUPPORT_FP\r
+ #include <math.h>\r
+\r
+ #ifndef PF_USER_FP\r
+ #include "pf_float.h"\r
+ #else\r
+ #include PF_USER_FP\r
+ #endif\r
+#endif\r
+\r
+#endif /* _pf_unix_h */\r
--- /dev/null
+/* @(#) 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+")
+\r
+#define LITTLE_ENDIAN\r
+
+#endif /* _pf_win32_h */
--- /dev/null
+/* @(#) 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<Depth; i++ )
+ {
+/* Print as unsigned if not base 10. */
+ MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
+ EMIT(' ');
+ }
+ }
+ MSG("\n");
+}
+
+/* ( addr cnt char -- addr' cnt' , skip leading characters ) */
+cell ffSkip( char *AddrIn, cell Cnt, char c, char **AddrOut )
+{
+ char *s;
+
+ s = AddrIn;
+
+ if( c == BLANK )
+ {
+ while( ( Cnt > 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.
+***************************************************************/\r
+\r
+/* Convert a single digit to the corresponding hex number. */\r
+static cell HexDigitToNumber( char c )\r
+{ \r
+ if( (c >= '0') && (c <= '9') )\r
+ {\r
+ return( c - '0' );\r
+ }\r
+ else if ( (c >= 'A') && (c <= 'F') )\r
+ {\r
+ return( c - 'A' + 0x0A );\r
+ }\r
+ else\r
+ {\r
+ return -1;\r
+ }\r
+}\r
+
+/* 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<Len; i++)
+ {
+ n = HexDigitToNumber( *s++ );
+ if( (n < 0) || (n >= 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; i<nc; i++ )
+ {
+ gScratch[i+1] = pfCharToUpper( s2[i] );
+ }
+ }
+ else
+ {
+
+ gScratch[0] = 0;
+ }
+ gCurrentTask->td_IN += (n1-n3) + 1;
+ return &gScratch[0];
+}
--- /dev/null
+/* @(#) 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 */
--- /dev/null
+/* @(#) 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
--- /dev/null
+/* @(#) 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;\r
+ const cfNameLinks *cfnl;
+
+/* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (int32) NFA)); */\r
+ cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );\r
+
+ 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 )
+{\r
+ const cfNameLinks *cfnl;\r
+\r
+/* Convert absolute namefield address to absolute link field address. */\r
+ cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) );\r
+\r
+ 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;
+}
--- /dev/null
+/* @(#) 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 */
--- /dev/null
+/* @(#) 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 */
+
--- /dev/null
+/* @(#) 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 -- ) */\r
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
+ if( IN_CODE_DIC(TOS) )\r
+ {\r
+ WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );\r
+ }\r
+ else\r
+ {\r
+ *((PF_FLOAT *) TOS) = FP_TOS;\r
+ }\r
+#else\r
+ *((PF_FLOAT *) TOS) = FP_TOS;\r
+#endif\r
+ 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;\r
+ 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;\r
+#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
+ if( IN_CODE_DIC(TOS) )\r
+ {\r
+ FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );\r
+ }\r
+ else\r
+ {\r
+ FP_TOS = *((PF_FLOAT *) TOS);\r
+ }\r
+#else\r
+ FP_TOS = *((PF_FLOAT *) TOS);\r
+#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;\r
+ 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
--- /dev/null
+/* @(#) 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 */
--- /dev/null
+<HTML>\r
+<HEAD>\r
+ <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">\r
+ <META NAME="Author" CONTENT="Phil Burk">\r
+ <META NAME="GENERATOR" CONTENT="Mozilla/4.05 [en] (Win95; I) [Netscape]">\r
+ <META NAME="Description" CONTENT="Reference Manual for pForth, a Portable ANSI Forth environment written in ANSI 'C'.">\r
+ <META NAME="KeyWords" CONTENT="pForth, Forth, Reference, portable, ANS">\r
+ <TITLE> pForth Reference</TITLE>\r
+</HEAD>\r
+<BODY>\r
+\r
+<CENTER>\r
+<H1>\r
+\r
+<HR WIDTH="100%"></H1></CENTER>\r
+\r
+<CENTER>\r
+<H1>\r
+pForth Reference Manual</H1></CENTER>\r
+\r
+<CENTER>\r
+<HR WIDTH="100%"></CENTER>\r
+\r
+<H3>\r
+pForth - a Portable ANSI style Forth written in ANSI 'C'. <B>Last\r
+updated: August 20th, 1998 V20</B></H3>\r
+by <A HREF="mailto:philburk@softsynth.com">Phil Burk</A> with Larry Polansky,\r
+David Rosenboom. Special thanks to contributors Darren Gibbs, Herb Maeder,\r
+Gary Arakaki, Mike Haas.\r
+\r
+<P>PForth source code is freely available. The author is available\r
+for customization of pForth, porting to new platforms, or developing pForth\r
+applications on a contractual basis. If interested, contact \r
+Phil Burk at <A HREF="mailto:philburk@softsynth.com">philburk@softsynth.com</A>\r
+\r
+<P>Back to <A HREF="pforth.html">pForth Home Page</A>\r
+<CENTER>\r
+<H2>\r
+LEGAL NOTICE</H2></CENTER>\r
+The pForth software code is dedicated to the public domain, and any third\r
+party may reproduce, distribute and modify the pForth software code or\r
+any derivative works thereof without any compensation or license. The pForth\r
+software code is provided on an "as is" basis without any warranty of any\r
+kind, including, without limitation, the implied warranties of merchantability\r
+and fitness for a particular purpose and their equivalents under the laws\r
+of any jurisdiction.\r
+\r
+<P>\r
+<HR WIDTH="100%">\r
+<H2>\r
+Table of Contents</H2>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#What is pForth">What is pForth?</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Compiling pForth for your System">Compiling pForth for your System</A></LI>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#Description of Source Files">Description of Source Files</A></LI>\r
+</UL>\r
+\r
+<LI>\r
+<A HREF="#Running pForth">Running pForth</A></LI>\r
+\r
+<LI>\r
+<A HREF="#ANSI Compliance">ANSI Compliance</A></LI>\r
+\r
+<LI>\r
+<A HREF="#pForth Special Features">pForth Special Features</A></LI>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#Compiling from a File">Compiling from a File - INCLUDE</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Saving Precompiled Dictionaries">Saving Precompiled Dictionaries</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Recompiling Code - ANEW INCLUDE?">Recompiling Code - ANEW INCLUDE?</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Customising FORGET with [FORGET]">Customising Forget with [FORGET]</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Smart Conditionals">Smart Conditionals</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Development Tools">Development Tools</A></LI>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#WORDS.LIKE">WORDS.LIKE</A></LI>\r
+\r
+<LI>\r
+<A HREF="#FILE?">FILE?</A></LI>\r
+\r
+<LI>\r
+<A HREF="#SEE">SEE</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Single Step Trace">Single Step Trace and Debug</A></LI>\r
+</UL>\r
+\r
+<LI>\r
+<A HREF="#Conditional Compilation [IF] [ELSE] [THEN]">Conditional Compilation\r
+- [IF] [ELSE] [THEN]</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Miscellaneous Handy Words">Miscellaneous Handy Words</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Local Variables { foo --}">Local Variables { foo -- }</A></LI>\r
+\r
+<LI>\r
+<A HREF="#'C' like Structures. :STRUCT">'C' like Structures. :STRUCT</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Vectorred Execution - DEFER">Vectorred execution - DEFER</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Floating Point">Floating Point</A></LI>\r
+</UL>\r
+\r
+<LI>\r
+<A HREF="#pForth Design">pForth Design</A></LI>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#'C' kernel">'C' kernel</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Dictionary Structures">Dictionary Structures</A></LI>\r
+</UL>\r
+\r
+<LI>\r
+<A HREF="#Custom Compilation of pForth">Custom Compilation of pForth</A></LI>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#Compiler Options">Compiler Options</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Building pForth on Supported Hosts">Building pForth on Supported\r
+Hosts</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Compiling for Embedded Systems">Compiling for Embedded Systems</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Linking with Custom 'C' Functions">Linking with Custom 'C' Functions</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Minimal Executables - CLONE">Minimal executables. CLONE</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Testing your Compiled pForth">Testing your Compiled pForth</A></LI>\r
+</UL>\r
+</UL>\r
+\r
+<HR WIDTH="100%">\r
+<H2>\r
+<A NAME="What is pForth"></A>What is pForth?</H2>\r
+PForth is an ANSI style Forth designed to be portable across many platforms.\r
+The 'P' in pForth stands for "Portable". PForth is based on a Forth kernel\r
+written in ANSI standard 'C'.\r
+<H3>\r
+What is Forth?</H3>\r
+Forth is a stack based language invented by astronomer Charles Moore for\r
+controlling telescopes. Forth is an interactive language. You can enter\r
+commands at the keyboard and have them be immediately executed, similar\r
+to BASIC or LISP. Forth has a dictionary of words that can be executed\r
+or used to construct new words that are then added to the dictionary. Forth\r
+words operate on a data stack that contains numbers and addresses.\r
+\r
+<P>To learn more about Forth, see the <A HREF="pf_tut.htm">Forth Tutorial</A>.\r
+<H3>\r
+The Origins of pForth</H3>\r
+PForth began as a JSR threaded 68000 Forth called HForth that was used\r
+to support HMSL, the Hierarchical Music Specification Language. HMSL was\r
+a music experimentation language developed by Phil Burk, Larry Polansky\r
+and David Rosenboom while working at the Mills College Center for Contemporary\r
+Music. Phil moved from Mills to the 3DO Company where he ported the Forth\r
+kernel to 'C'. It was used at 3DO as a tool for verifying ASIC design and\r
+for bringing up new hardware platforms. At 3DO, the Forth had to run on\r
+many systems including SUN, SGI, Macintosh, PC, Amiga, the 3DO ARM based\r
+Opera system, and the 3DO PowerPC based M2 system. PForth is now being\r
+developed for use at CagEnt, a spinoff of 3DO.\r
+<H3>\r
+pForth Design Goals</H3>\r
+PForth has been designed with portability as the primary design goal. As\r
+a result, pForth avoids any fancy UNIX calls. pForth also avoids using\r
+any clever and original ways of constructing the Forth dictionary. It just\r
+compiles its kernel from ANSI compatible 'C' code then loads ANS compatible\r
+Forth code to build the dictionary. Very boring but very likely to work\r
+on almost any platform.\r
+\r
+<P>The dictionary files that can be saved from pForth are almost host independant.\r
+They can be compiled on one processor, and then run on another processor.\r
+as long as the endian-ness is the same. In other words, dictionaries built\r
+on a PC will only work on a PC. Dictionaries built on almost any other\r
+computer will work on almost any other computer.\r
+\r
+<P>PForth can be used to bring up minimal hardware systems that have very\r
+few system services implemented. It is possible to compile pForth for systems\r
+that only support routines to send and receive a single character. If malloc()\r
+and free() are not available, equivalent functions are available in standard\r
+'C' code. If file I/O is not available, the dictionary can be saved as\r
+a static data array in 'C' source format on a host system. The dictionary\r
+in 'C' source form is then compiled with a custom pForth kernel to avoid\r
+having to read the dictionary from disk.\r
+\r
+<P>\r
+<HR WIDTH="100%">\r
+<H2>\r
+<A NAME="Compiling pForth for your System"></A>Compiling pForth for your\r
+System</H2>\r
+The process of building pForth involves several steps. This process is\r
+typically handled automatically by the Makefile or IDE Project.\r
+<OL>\r
+<LI>\r
+Compile the 'C' based pForth kernel called "pforth".</LI>\r
+\r
+<LI>\r
+Execute "pforth" with the -i option to build the dictionary from scratch.</LI>\r
+\r
+<LI>\r
+Compile the "system.fth" file which will add all the top level Forth words.</LI>\r
+\r
+<LI>\r
+Save the compiled dictionary as "pforth.dic".</LI>\r
+\r
+<LI>\r
+The next time you run pforth, the precompiled pforth.dic file will be loaded\r
+automatically.</LI>\r
+</OL>\r
+\r
+<H3>\r
+UNIX</H3>\r
+A Makefile has been provided that should work on most UNIX platforms.\r
+<OL>\r
+<LI>\r
+cd to top directory of pForth</LI>\r
+\r
+<LI>\r
+Enter: make all</LI>\r
+</OL>\r
+\r
+<H3>\r
+Macintosh</H3>\r
+A precompiled PPC binary for pForth is provided. A Code Warrior Project\r
+has been provided that will rebuild pForth for PPC if desired. Alternatively\r
+you could use MPW to make pForth as an MPW Tool. Make sure that you\r
+provide at least 1 Meg of heap space. If you build for 68K, make sure you\r
+use 32 bit integers, and select the appropriate libraries. To rebuild\r
+pForth for PPC:\r
+<OL>\r
+<LI>\r
+Open pForthCW</LI>\r
+\r
+<LI>\r
+Make target "pForthApp"</LI>\r
+\r
+<LI>\r
+Run pForthApp</LI>\r
+\r
+<LI>\r
+Enter "-i" as Argumant in starting dialog to initialize dictionary.</LI>\r
+\r
+<LI>\r
+To compile system.fth, enter "loadsys".</LI>\r
+\r
+<LI>\r
+Quit pForth using File menu.</LI>\r
+\r
+<LI>\r
+From now on, just double click pForthApp icon to run pForth.</LI>\r
+</OL>\r
+\r
+<H3>\r
+PC Compatible</H3>\r
+A precompiled binary for pForth is provided. <FONT COLOR="#000000">To rebuild\r
+under Windows NT or Win95 using Microsoft Visual C++:</FONT>\r
+<OL>\r
+<LI>\r
+<FONT COLOR="#000000">Double click on the pForth.dsw icon in "pForth\pcbuild".</FONT></LI>\r
+\r
+<LI>\r
+<FONT COLOR="#000000">Select the "MakeDic" configuration.</FONT></LI>\r
+\r
+<LI>\r
+<FONT COLOR="#000000">Select "Rebuild All" from the Build menu.This will\r
+build the pForth.exe file.</FONT></LI>\r
+\r
+<LI>\r
+<FONT COLOR="#000000">Run the app with CTRL-F5 which will build the pforth.dic\r
+file.</FONT></LI>\r
+\r
+<LI>\r
+<FONT COLOR="#000000">Select the "Release" configuration.</FONT></LI>\r
+\r
+<LI>\r
+<FONT COLOR="#000000">Run the app with CTRL-F5 which will drop you into\r
+Forth.</FONT></LI>\r
+\r
+<LI>\r
+<FONT COLOR="#000000">From now on, to run pForth, just double click on\r
+the pforth.exe file.</FONT></LI>\r
+</OL>\r
+\r
+<H3>\r
+<A NAME="Description of Source Files"></A>Description of Source Files</H3>\r
+\r
+<H4>\r
+Forth Source</H4>\r
+\r
+<PRE>ansilocs.fth = support for ANSI (LOCAL) word\r
+c_struct.fth = 'C' like data structures\r
+case.fth = CASE OF ENDOF ENDCASE\r
+catch.fth = CATCH and THROW\r
+condcomp.fth = [IF] [ELSE] [THEN] conditional compiler\r
+filefind.fth = FILE?\r
+floats.fth = floating point support\r
+forget.fth = FORGET [FORGET] IF.FORGOTTEN\r
+loadp4th.fth = loads basic dictionary\r
+locals.fth = { } style locals using (LOCAL)\r
+math.fth = misc math words\r
+member.fth = additional 'C' like data structure support\r
+misc1.fth = miscellaneous words\r
+misc2.fth = miscellaneous words\r
+numberio.fth = formatted numeric input/output\r
+private.fth = hide low level words\r
+quit.fth = QUIT EVALUATE INTERPRET in high level\r
+smart_if.fth = allows conditionals outside colon definition\r
+see.fth = Forth "disassembler". Eg. SEE SPACES\r
+strings.fth = string support\r
+system.fth = bootstraps pForth dictionary\r
+trace.fth = single step trace for debugging</PRE>\r
+\r
+<H4>\r
+'C' Source</H4>\r
+csrc/pfcompil.c = pForth compiler support\r
+<BR>csrc/pfcustom.c = example of 'C' functions callable from pForth\r
+<BR>csrc/pfinnrfp.h = float extensions to interpreter\r
+<BR>csrc/pforth.h = include this in app that embeds pForth\r
+<BR>csrc/pf_cglue.c = glue for pForth calling 'C'\r
+<BR>csrc/pf_clib.c = replacement routines for 'C' stdlib\r
+<BR>csrc/pf_core.c = primary words called from 'C' app that embeds pForth\r
+<BR>csrc/pf_float.h = defines PF_FLOAT, and the floating point math functions\r
+such as fp_sin\r
+<BR>csrc/pf_inner.c = inner interpreter\r
+<BR>csrc/pf_guts.h = primary include file, define structures\r
+<BR>csrc/pf_io.c = input/output\r
+<BR>csrc/pf_main.c = basic application for standalone pForth\r
+<BR>csrc/pf_mem.c = optional malloc() implementation\r
+<BR>csrc/pf_save.c = save and load dictionaries\r
+<BR>csrc/pf_text.c = string tools, error message text\r
+<BR>csrc/pf_words.c = miscellaneous pForth words implemented\r
+<BR>\r
+<HR WIDTH="100%">\r
+<H2>\r
+<A NAME="Running pForth"></A>Running pForth</H2>\r
+PForth can be run from a shell or by double clicking on its icon, depending\r
+on the system you are using. The execution options for pForth are described\r
+assuming that you are running it from a shell.\r
+\r
+<P>Usage:\r
+<UL>\r
+<PRE>pforth [-i] [-dDictionaryFilename] [SourceFilename]</PRE>\r
+</UL>\r
+\r
+<DT>\r
+-i</DT>\r
+\r
+<DD>\r
+Initialize pForth by building dictionary from scratch. Used when building\r
+pForth or when debugging pForth on new systems.</DD>\r
+\r
+<DT>\r
+-dDictionaryFilename</DT>\r
+\r
+<DD>\r
+Specify a custom dictionary to be loaded in place of the default "pforth.dic".\r
+For example:</DD>\r
+\r
+<UL>\r
+<UL>\r
+<PRE>pforth -dgame.dic</PRE>\r
+</UL>\r
+</UL>\r
+\r
+<DT>\r
+SourceFilename</DT>\r
+\r
+<DD>\r
+A Forth source file can be automatically compiled by passing its name to\r
+pForth. This is useful when using Forth as an assembler or for automated\r
+hardware testing. Remember that the source file can compile code and execute\r
+it all in the same file.</DD>\r
+\r
+<H4>\r
+Quick Verification of pForth</H4>\r
+To verify that PForth is working, enter:\r
+<UL>\r
+<PRE>3 4 + .</PRE>\r
+</UL>\r
+It should print "7 ok". Now enter:\r
+<UL>WORDS</UL>\r
+You should see a long list of all the words in the pForth dictionary. Don't\r
+worry. You won't need to learn all of these. More tests are described\r
+in the README.txt file.\r
+\r
+<P>\r
+<HR WIDTH="100%">\r
+<H2>\r
+<A NAME="ANSI Compliance"></A>ANSI Compliance</H2>\r
+This Forth is intended to be ANS compatible. I will not claim that it is\r
+compatible until more people bang on it. If you find areas where it deviates\r
+from the standard, please let me know.\r
+\r
+<P>Word sets supported include:\r
+<UL>\r
+<LI>\r
+FLOAT</LI>\r
+\r
+<LI>\r
+LOCAL with support for { lv1 lv2 | lv3 -- } style locals</LI>\r
+\r
+<LI>\r
+EXCEPTION but standard throw codes not implemented</LI>\r
+\r
+<LI>\r
+FILE ACCESS</LI>\r
+\r
+<LI>\r
+MEMORY ALLOCATION</LI>\r
+</UL>\r
+Here are the areas that I know are not compatible:\r
+\r
+<P>The ENVIRONMENT queries are not implemented.\r
+\r
+<P>Word sets NOT supported include:\r
+<UL>\r
+<LI>\r
+BLOCK - a matter of religion</LI>\r
+\r
+<LI>\r
+SEARCH ORDER - coming soon</LI>\r
+\r
+<LI>\r
+PROGRAMMING TOOLS - only has .S ? DUMP WORDS BYE</LI>\r
+\r
+<LI>\r
+STRING - only has CMOVE CMOVE> COMPARE</LI>\r
+\r
+<LI>\r
+DOUBLE NUMBER - but cell is 32 bits</LI>\r
+</UL>\r
+\r
+<HR WIDTH="100%">\r
+<H2>\r
+<A NAME="pForth Special Features"></A>pForth Special Features</H2>\r
+These features are not part of the ANS standard for Forth. They have\r
+been added to assist developers.\r
+<H3>\r
+<A NAME="Compiling from a File"></A>Compiling from a File</H3>\r
+Use INCLUDE to compile source code from a file:\r
+<UL>\r
+<PRE>INCLUDE filename</PRE>\r
+</UL>\r
+You can nest calls to INCLUDE. INCLUDE simply redirects Forth to takes\r
+its input from the file instead of the keyboard so you can place any legal\r
+Forth code in the source code file.\r
+<H3>\r
+<A NAME="Saving Precompiled Dictionaries"></A>Saving Precompiled Dictionaries</H3>\r
+Use SAVE-FORTH save your precompiled code to a file. To save the current\r
+dictionary to a file called "custom.dic", enter:\r
+<UL>\r
+<PRE>c" custom.dic" SAVE-FORTH</PRE>\r
+</UL>\r
+You can then leave pForth and use your custom dictionary by enterring:\r
+<UL>\r
+<PRE>pforth -dcustom.dic</PRE>\r
+</UL>\r
+On icon based systems, you may wish to name your custom dictionary "pforth.dic"\r
+so that it will be loaded automatically.\r
+\r
+<P>Be careful that you do not leave absolute addresses stored in the dictionary\r
+because they will not work when you reload pForth at a different address.\r
+Use A! to store an address in a variable in a relocatable form and A@ to\r
+get it back if you need to.\r
+<UL>\r
+<PRE>VARIABLE DATA-PTR\r
+CREATE DATA 100 ALLOT\r
+DATA DATA-PTR ! \ storing absolute address! BAD\r
+DATA DATA-PTR A! \ storing relocatable address! GOOD\r
+DATA-PTR A@ \ fetch relocatable address</PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Recompiling Code - ANEW INCLUDE?"></A>Recompiling Code - ANEW\r
+INCLUDE?</H3>\r
+When you are testing a file full of code, you will probably recompile many\r
+times. You will probably want to FORGET the old code before loading the\r
+new code. You could put a line at the beginning of your file like this:\r
+<UL>\r
+<PRE>FORGET XXXX-MINE : XXXX-MINE ;</PRE>\r
+</UL>\r
+This would automatically FORGET for you every time you load. Unfortunately,\r
+you must define XXXX-MINE before you can ever load this file. We have a\r
+word that will automatically define a word for you the first time, then\r
+FORGET and redefine it each time after that. It is called ANEW and can\r
+be found at the beginning of most Forth source files. We use a prefix of\r
+TASK- followed by the filename just to be consistent. This TASK-name word\r
+is handy when working with INCLUDE? as well. Here is an example:\r
+<UL>\r
+<PRE>\ Start of file\r
+INCLUDE? TASK-MYTHING.FTH MYTHING.FTH\r
+ANEW TASK-THISFILE.FTH\r
+\ the rest of the file follows...</PRE>\r
+</UL>\r
+Notice that the INCLUDE? comes before the call to ANEW so that we don't\r
+FORGET MYTHING.FTH every time we recompile.\r
+\r
+<P>FORGET allows you to get rid of code that you have already compiled.\r
+This is an unusual feature in a programming language. It is very convenient\r
+in Forth but can cause problems. Most problems with FORGET involve leaving\r
+addresses that point to the forgotten code that are not themselves forgotten.\r
+This can occur if you set a deferred system word to your word then FORGET\r
+your word. The system word which is below your word in the dictionary is\r
+pointing up to code that no longer exists. It will probably crash if called.\r
+(See discussion of DEFER below.) Another problem is if your code allocates\r
+memory, opens files, or opens windows. If your code is forgotten you may\r
+have no way to free or close these thing. You could also have a problems\r
+if you add addresses from your code to a table that is below your code.\r
+This might be a jump table or data table.\r
+\r
+<P>Since this is a common problem we have provided a tool for handling\r
+it. If you have some code that you know could potentially cause a problem\r
+if forgotten, then write a cleanup word that will eliminate the problem.\r
+This word could UNdefer words, free memory, etc. Then tell the system to\r
+call this word if the code is forgotten. Here is how:\r
+<UL>\r
+<PRE>: MY.CLEANUP ( -- , do whatever )\r
+ MY-MEM @ FREE DROP\r
+ 0 MY-MEM !\r
+;\r
+IF.FORGOTTEN MY.CLEANUP</PRE>\r
+</UL>\r
+IF.FORGOTTEN creates a linked list node containing your CFA that is checked\r
+by FORGET. Any nodes that end up above HERE (the Forth pointer to the top\r
+of the dictionary) after FORGET is done are executed.\r
+<H3>\r
+<A NAME="Customising FORGET with [FORGET]"></A>Customising FORGET with\r
+[FORGET]</H3>\r
+Sometimes, you may need to extend the way that FORGET works. FORGET is\r
+not deferred, however, because that could cause some real problems. Instead,\r
+you can define a new version of [FORGET] which is searched for and executed\r
+by FORGET. You MUST call [FORGET] from your program or FORGET will not\r
+actually FORGET. Here is an example.\r
+<UL>\r
+<PRE>: [FORGET] ( -- , my version )\r
+ ." Change things around!" CR\r
+ [FORGET] ( must be called )\r
+ ." Now put them back!" CR\r
+;\r
+: FOO ." Hello!" ;\r
+FORGET FOO ( Will print "Change things around!", etc.)</PRE>\r
+</UL>\r
+This is recommended over redefining FORGET because words like ANEW that\r
+call FORGET will now pick up your changes.\r
+<H3>\r
+<A NAME="Smart Conditionals"></A>Smart Conditionals</H3>\r
+In pForth, you can use IF THEN DO LOOP and other conditionals outside of\r
+colon definitions. PForth will switch temporarily into the compile state,\r
+then automatically execute the conditional code. (Thank you Mitch Bradley)\r
+For example, just enter this at the keyboard.\r
+<UL>\r
+<PRE>10 0 DO I . LOOP</PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Development Tools"></A>Development Tools</H3>\r
+\r
+<H4>\r
+<A NAME="WORDS.LIKE"></A>WORDS.LIKE</H4>\r
+If you cannot remember the exact name of a word, you can use WORDS.LIKE\r
+to search the dictionary for all words that contain a substring. For an\r
+example, enter:\r
+<UL>\r
+<PRE>WORDS.LIKE FOR\r
+WORDS.LIKE EMIT</PRE>\r
+</UL>\r
+\r
+<H4>\r
+<A NAME="FILE?"></A>FILE?</H4>\r
+You can use FILE? to find out what file a word was compiled from. If a\r
+word was defined in multiple files then it will list each file. The execution\r
+token of each definition of the word is listed on the same line.\r
+<UL>FILE? IF\r
+<BR>FILE? AUTO.INIT</UL>\r
+\r
+<H4>\r
+<A NAME="SEE"></A>SEE</H4>\r
+You can use SEE to "disassemble" a word in the pForth dictionary. SEE will\r
+attempt to print out Forth source in a form that is similar to the source\r
+code. SEE will give you some idea of how the word was defined but is not\r
+perfect. Certain compiler words, like BEGIN and LITERAL, are difficult\r
+to disassemble and may not print properly. For an example, enter:\r
+<UL>\r
+<PRE>SEE SPACES\r
+SEE WORDS</PRE>\r
+</UL>\r
+\r
+<H4>\r
+<A NAME="Single Step Trace"></A>Single Step Trace and Debug</H4>\r
+It is often useful to proceed step by step through your code when debugging. \r
+PForth provides a simple single step trace facility for this purpose. \r
+Here is an example of using TRACE to debug a simple program. Enter\r
+the following program:\r
+<BR> \r
+<UL>\r
+<PRE>: SQUARE ( n -- n**2 )\r
+ DUP *\r
+;\r
+: TSQ ( n -- , test square )\r
+ ." Square of " DUP .\r
+ ." is " SQUARE . CR\r
+;</PRE>\r
+</UL>\r
+Even though this program should work, let's pretend it doesn't and try\r
+to debug it. Enter:\r
+<UL>7 TRACE TSQ</UL>\r
+You should see:\r
+<UL>\r
+<PRE>7 trace tsq\r
+<< TSQ +0 <10:1> 7 || (.") Square of " >> ok</PRE>\r
+</UL>\r
+The "TSQ +0" means that you are about to execute code at an offset of "+0"\r
+from the beginning of TSQ. The <10:1> means that we are in base\r
+10, and that there is 1 item on the stack, which is shown to be "7". The\r
+(.") is the word that is about to be executed. (.") is the word that\r
+is compiled when use use .". Now to single step, enter:\r
+<UL>\r
+<PRE>s</PRE>\r
+</UL>\r
+You should see:\r
+<UL>\r
+<PRE>Square of\r
+<< TSQ +16 <10:1> 7 || DUP >> ok</PRE>\r
+</UL>\r
+\r
+<PRE>The "Square os" was printed by (."). We can step multiple times using the "sm" command. Enter:</PRE>\r
+\r
+<UL>\r
+<PRE>3 sm</PRE>\r
+</UL>\r
+You should see:\r
+<UL>\r
+<PRE><< TSQ +20 <10:2> 7 7 || . >> 7 \r
+<< TSQ +24 <10:1> 7 || (.") is " >> is \r
+<< TSQ +32 <10:1> 7 || SQUARE >> ok</PRE>\r
+</UL>\r
+The "7" after the ">>" was printed by the . word. If we entered "s", we\r
+would step over the SQUARE word. If we want to dive down into SQUARE, we\r
+can enter:\r
+<UL>\r
+<PRE>sd</PRE>\r
+</UL>\r
+\r
+<PRE>You should see:</PRE>\r
+\r
+<UL>\r
+<PRE><< SQUARE +0 <10:1> 7 || DUP >> ok</PRE>\r
+</UL>\r
+\r
+<PRE>To step once in SQUARE, enter:</PRE>\r
+\r
+<UL>\r
+<PRE>s</PRE>\r
+</UL>\r
+You should see:\r
+<UL>\r
+<PRE><< SQUARE +4 <10:2> 7 7 || * >> ok</PRE>\r
+</UL>\r
+\r
+<PRE>To go to the end of the current word, enter:</PRE>\r
+\r
+<UL>\r
+<PRE>g</PRE>\r
+</UL>\r
+\r
+<PRE>You should see:</PRE>\r
+\r
+<UL>\r
+<PRE><< SQUARE +8 <10:1> 49 || EXIT >> \r
+<< TSQ +36 <10:1> 49 || . >> ok</PRE>\r
+</UL>\r
+EXIT is compiled at the end of every Forth word. For more information on\r
+TRACE, enter TRACE.HELP:\r
+<UL>\r
+<PRE>TRACE ( i*x <name> -- , setup trace for Forth word )\r
+S ( -- , step over )\r
+SM ( many -- , step over many times )\r
+SD ( -- , step down )\r
+G ( -- , go to end of word )\r
+GD ( n -- , go down N levels from current level,\r
+ stop at end of this level )</PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Conditional Compilation [IF] [ELSE] [THEN]"></A>Conditional Compilation\r
+[IF] [ELSE] [THEN]</H3>\r
+PForth supports conditional compilation words similar to 'C''s #if, #else,\r
+and #endif.\r
+<DT>\r
+[IF] ( flag -- , if true, skip to [ELSE] or [THEN] )</DT>\r
+\r
+<DT>\r
+[ELSE] ( -- , skip to [THEN] )</DT>\r
+\r
+<DT>\r
+[THEN] ( -- , noop, used to terminate [IF] and [ELSE] section )</DT>\r
+\r
+<BR> \r
+<BR>For example:\r
+<UL>\r
+<PRE>TRUE constant USE_FRENCH\r
+\r
+USE_FRENCH [IF]\r
+ : WELCOME ." Bienvenue!" cr ;\r
+[ELSE]\r
+ : WELCOME ." Welcome!" cr ;\r
+[THEN]</PRE>\r
+</UL>\r
+Here is how to conditionally compile within a colon definition by using\r
+[ and ].\r
+<UL>\r
+<PRE>: DOIT ( -- )\r
+ START.REACTOR\r
+ IF\r
+ [ USE_FRENCH [IF] ] ." Zut alors!"\r
+ [ [ELSE] ] ." Uh oh!"\r
+ [THEN]\r
+ THEN cr\r
+;</PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Miscellaneous Handy Words"></A>Miscellaneous Handy Words</H3>\r
+\r
+<DT>\r
+.HEX ( n -- , print N as hex number )</DT>\r
+\r
+<DT>\r
+CHOOSE ( n -- rand , select random number between 0 and N )</DT>\r
+\r
+<DT>\r
+MAP ( -- , print dictionary information )</DT>\r
+\r
+<H3>\r
+<A NAME="Local Variables { foo --}"></A>Local Variables { foo --}</H3>\r
+In a complicated Forth word it is sometimes hard to keep track of where\r
+things are on the stack. If you find you are doing a lot of stack operations\r
+like DUP SWAP ROT PICK etc. then you may want to use local variables. They\r
+can greatly simplify your code. You can declare local variables for a word\r
+using a syntax similar to the stack diagram. These variables will only\r
+be accessible within that word. Thus they are "local" as opposed to "global"\r
+like regular variables. Local variables are self-fetching. They automatically\r
+put their values on the stack when you give their name. You don't need\r
+to @ the contents. Local variables do not take up space in the dictionary.\r
+They reside on the return stack where space is made for them as needed.\r
+Words written with them can be reentrant and recursive.\r
+\r
+<P>Consider a word that calculates the difference of two squares, Here\r
+are two ways of writing the same word.\r
+<UL>\r
+<PRE>: DIFF.SQUARES ( A B -- A*A-B*B ) \r
+ DUP * \r
+ SWAP DUP * \r
+ SWAP - \r
+; \r
+ ( or ) \r
+: DIFF.SQUARES { A B -- A*A-B*B } \r
+ A A * \r
+ B B * - \r
+; \r
+3 2 DIFF.SQUARES ( would return 5 )</PRE>\r
+</UL>\r
+In the second definition of DIFF.SQUARES the curly bracket '{' told the\r
+compiler to start declaring local variables. Two locals were defined, A\r
+and B. The names could be as long as regular Forth words if desired. The\r
+"--" marked the end of the local variable list. When the word is executed,\r
+the values will automatically be pulled from the stack and placed in the\r
+local variables. When a local variable is executed it places its value\r
+on the stack instead of its address. This is called self-fetching. Since\r
+there is no address, you may wonder how you can store into a local variable.\r
+There is a special operator for local variables that does a store. It looks\r
+like -> and is pronounced "to".\r
+\r
+<P>Local variables need not be passed on the stack. You can declare a local\r
+variable by placing it after a "vertical bar" ( | )character. These are\r
+automatically set to zero when created. Here is a simple example that uses\r
+-> and | in a word:\r
+<UL>\r
+<PRE>: SHOW2* \r
+ { loc1 | unvar -- , 1 regular, 1 uninitialized }\r
+ LOC1 2* -> UNVAR \r
+ (set unver to 2*LOC1 )\r
+ UNVAR . ( print UNVAR )\r
+;\r
+3 SHOW2* ( pass only 1 parameter, prints 6 )</PRE>\r
+</UL>\r
+Since local variable often used as counters or accumulators, we have a\r
+special operator for adding to a local variable It is +-> which is pronounced\r
+"plus to". These next two lines are functionally equivalent but the second\r
+line is faster and smaller:\r
+<UL>\r
+<PRE>ACCUM 10 + -> ACCUM\r
+10 +-> ACCUM</PRE>\r
+</UL>\r
+If you name a local variable the same as a Forth word in the dictionary,\r
+eg. INDEX or COUNT, you will be given a warning message. The local variable\r
+will still work but one could easily get confused so we warn you about\r
+this. Other errors that can occur include, missing a closing '}', missing\r
+'--', or having too many local variables.\r
+<H3>\r
+<A NAME="'C' like Structures. :STRUCT"></A>'C' like Structures. :STRUCT</H3>\r
+You can define 'C' like data structures in pForth using :STRUCT. For example:\r
+<UL>\r
+<PRE>:STRUCT SONG\r
+ LONG SONG_NUMNOTES \ define 32 bit structure member named SONG_NUMNOTES\r
+ SHORT SONG_SECONDS \ define 16 bit structure member\r
+ BYTE SONG_QUALITY \ define 8 bit member\r
+ LONG SONG_NUMBYTES \ auto aligns after SHORT or BYTE\r
+ RPTR SONG_DATA \ relocatable pointer to data\r
+;STRUCT</PRE>\r
+\r
+<PRE>SONG HAPPY \ define a song structure called happy</PRE>\r
+\r
+<PRE>400 HAPPY S! SONG_NUMNOTES \ set number of notes to 400\r
+17 HAPPY S! SONG_SECONDS \ S! works with all size members</PRE>\r
+\r
+<PRE>CREATE SONG-DATA 23 , 17 , 19 , 27 ,\r
+SONG-DATA HAPPY S! SONG_DATA \ store pointer in relocatable form</PRE>\r
+\r
+<PRE>HAPPY DST SONG \ dump HAPPY as a SONG structure</PRE>\r
+\r
+<PRE>HAPPY S@ SONG_NUMNOTES . \ fetch numnotes and print</PRE>\r
+</UL>\r
+See the file "c_struct.fth" for more information.\r
+<H3>\r
+<A NAME="Vectorred Execution - DEFER"></A>Vectorred Execution - DEFER</H3>\r
+Using DEFER for vectored words. In Forth and other languages you can save\r
+the address of a function in a variable. You can later fetch from that\r
+variable and execute the function it points to.This is called vectored\r
+execution. PForth provides a tool that simplifies this process. You can\r
+define a word using DEFER. This word will contain the execution token of\r
+another Forth function. When you execute the deferred word, it will execute\r
+the function it points to. By changing the contents of this deferred word,\r
+you can change what it will do. There are several words that support this\r
+process.\r
+<DL>\r
+<DT>\r
+DEFER ( <name> -- , define a deferred word )</DT>\r
+\r
+<DT>\r
+IS ( CFA <name> -- , set the function for a deferred word )</DT>\r
+\r
+<DT>\r
+WHAT'S ( <name> -- CFA , return the CFA set by IS )</DT>\r
+</DL>\r
+\r
+<DD>\r
+Simple way to see the name of what's in a deferred word:</DD>\r
+\r
+<UL>\r
+<UL>\r
+<PRE>WHAT'S EMIT >NAME ID.</PRE>\r
+</UL>\r
+</UL>\r
+\r
+<DD>\r
+should print name of current word that's in EMIT.</DD>\r
+\r
+<BR> \r
+<BR>Here is an example that uses a deferred word.\r
+<UL>\r
+<PRE>DEFER PRINTIT\r
+' . IS PRINTIT ( make PRINTIT use . )\r
+8 3 + PRINTIT\r
+\r
+: COUNTUP ( -- , call deferred word )\r
+ ." Hit RETURN to stop!" CR\r
+ 0 ( first value )\r
+ BEGIN 1+ DUP PRINTIT CR\r
+ ?TERMINAL\r
+ UNTIL\r
+;\r
+COUNTUP ( uses simple . )\r
+\r
+: FANCY.PRINT ( N -- , print in DECIMAL and HEX)\r
+ DUP ." DECIMAL = " .\r
+ ." , HEX = " .HEX\r
+;\r
+' FANCY.PRINT IS PRINTIT ( change printit )\r
+WHAT'S PRINTIT >NAME ID. ( shows use of WHAT'S )\r
+8 3 + PRINTIT\r
+COUNTUP ( notice that it now uses FANCY.PRINT )</PRE>\r
+</UL>\r
+Many words in the system have been defined using DEFER which means that\r
+we can change how they work without recompiling the entire system. Here\r
+is a partial list of those words\r
+<UL>\r
+<PRE>ABORT EMIT NUMBER?</PRE>\r
+</UL>\r
+\r
+<H4>\r
+Potential Problems with Defer</H4>\r
+Deferred words are very handy to use, however, you must be careful with\r
+them. One problem that can occur is if you initialize a deferred system\r
+more than once. In the below example, suppose we called STUTTER twice.\r
+The first time we would save the original EMIT vector in OLD-EMIT and put\r
+in a new one. The second time we called it we would take our new function\r
+from EMIT and save it in OLD-EMIT overwriting what we had saved previously.\r
+Thus we would lose the original vector for EMIT . You can avoid this if\r
+you check to see whether you have already done the defer. Here's an example\r
+of this technique.\r
+<UL>\r
+<PRE>DEFER OLD-EMIT\r
+' QUIT IS OLD-EMIT ( set to known value )\r
+: EEMMIITT ( char --- , our fun EMIT )\r
+ DUP OLD-EMIT OLD-EMIT\r
+; \r
+: STUTTER ( --- )\r
+ WHAT'S OLD-EMIT 'C QUIT = ( still the same? )\r
+ IF ( this must be the first time )\r
+ WHAT'S EMIT ( get the current value of EMIT ) \r
+ IS OLD-EMIT ( save this value in OLD-EMIT ) \r
+ 'C EEMMIITT IS EMIT\r
+ ELSE ." Attempt to STUTTER twice!" CR\r
+ THEN\r
+; \r
+: STOP-IT! ( --- )\r
+ WHAT'S OLD-EMIT ' QUIT =\r
+ IF ." STUTTER not installed!" CR\r
+ ELSE WHAT'S OLD-EMIT IS EMIT\r
+ 'C QUIT IS OLD-EMIT \r
+ ( reset to show termination )\r
+ THEN\r
+;</PRE>\r
+</UL>\r
+In the above example, we could call STUTTER or STOP-IT! as many times as\r
+we want and still be safe.\r
+\r
+<P>Suppose you forget your word that EMIT now calls. As you compile new\r
+code you will overwrite the code that EMIT calls and it will crash miserably.\r
+You must reset any deferred words that call your code before you FORGET\r
+your code. The easiest way to do this is to use the word IF.FORGOTTEN to\r
+specify a cleanup word to be called if you ever FORGET the code in question.\r
+In the above example using EMIT , we could have said:\r
+<UL>\r
+<PRE>IF.FORGOTTEN STOP-IT!</PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Floating Point"></A>Floating Point</H3>\r
+PForth supports the FLOAT word set and much of the FLOATEXT word set as\r
+a compile time option. You can select single or double precision\r
+as the default by changing the typedef of PF_FLOAT.\r
+<DL>PForth has several options for floating point output.\r
+<DT>\r
+FS. ( r -f- , prints in scientific/exponential format )</DT>\r
+\r
+<DT>\r
+FE. ( r -f- , prints in engineering format, exponent if multiple of 3 \r
+)</DT>\r
+\r
+<DT>\r
+FG. ( r -f- , prints in normal or exponential format depending on size\r
+)</DT>\r
+\r
+<DT>\r
+F. ( r -f- , as defined by the standard )</DT>\r
+\r
+<DT>\r
+Here is an example of output from each word for a number ranging from large\r
+to very small.</DT>\r
+\r
+<DL>\r
+<PRE> FS. FE. FG. F.\r
+1.234000e+12 1.234000e+12 1.234e+12 1234000000000. \r
+1.234000e+11 123.4000e+09 1.234e+11 123400000000. \r
+1.234000e+10 12.34000e+09 1.234e+10 12340000000. \r
+1.234000e+09 1.234000e+09 1.234e+09 1234000000. \r
+1.234000e+08 123.4000e+06 1.234e+08 123400000. \r
+1.234000e+07 12.34000e+06 1.234e+07 12340000. \r
+1.234000e+06 1.234000e+06 1234000. 1234000. \r
+1.234000e+05 123.4000e+03 123400. 123400.0 \r
+1.234000e+04 12.34000e+03 12340. 12340.00 \r
+1.234000e+03 1.234000e+03 1234. 1234.000 \r
+1.234000e+02 123.4000e+00 123.4 123.4000 \r
+1.234000e+01 12.34000e+00 12.34 12.34000 \r
+1.234000e+00 1.234000e+00 1.234 1.234000 \r
+1.234000e-01 123.4000e-03 0.1234 0.1234000 \r
+1.234000e-02 12.34000e-03 0.01234 0.0123400 \r
+1.234000e-03 1.234000e-03 0.001234 0.0012340 \r
+1.234000e-04 123.4000e-06 0.0001234 0.0001234 \r
+1.234000e-05 12.34000e-06 1.234e-05 0.0000123 \r
+1.234000e-06 1.234000e-06 1.234e-06 0.0000012 \r
+1.234000e-07 123.4000e-09 1.234e-07 0.0000001 \r
+1.234000e-08 12.34000e-09 1.234e-08 0.0000000 \r
+1.234000e-09 1.234000e-09 1.234e-09 0.0000000 \r
+1.234000e-10 123.4000e-12 1.234e-10 0.0000000 \r
+1.234000e-11 12.34000e-12 1.234e-11 0.0000000\r
+\r
+1.234568e+12 1.234568e+12 1.234568e+12 1234567890000. \r
+1.234568e+11 123.4568e+09 1.234568e+11 123456789000. \r
+1.234568e+10 12.34568e+09 1.234568e+10 12345678900. \r
+1.234568e+09 1.234568e+09 1.234568e+09 1234567890. \r
+1.234568e+08 123.4568e+06 1.234568e+08 123456789. \r
+1.234568e+07 12.34568e+06 1.234568e+07 12345679. \r
+1.234568e+06 1.234568e+06 1234568. 1234568. \r
+1.234568e+05 123.4568e+03 123456.8 123456.8 \r
+1.234568e+04 12.34568e+03 12345.68 12345.68 \r
+1.234568e+03 1.234568e+03 1234.568 1234.568 \r
+1.234568e+02 123.4568e+00 123.4568 123.4568 \r
+1.234568e+01 12.34568e+00 12.34568 12.34568 \r
+1.234568e+00 1.234568e+00 1.234568 1.234568 \r
+1.234568e-01 123.4568e-03 0.1234568 0.1234568 \r
+1.234568e-02 12.34568e-03 0.01234568 0.0123456 \r
+1.234568e-03 1.234568e-03 0.001234568 0.0012345 \r
+1.234568e-04 123.4568e-06 0.0001234568 0.0001234 \r
+1.234568e-05 12.34568e-06 1.234568e-05 0.0000123 \r
+1.234568e-06 1.234568e-06 1.234568e-06 0.0000012 \r
+1.234568e-07 123.4568e-09 1.234568e-07 0.0000001 \r
+1.234568e-08 12.34568e-09 1.234568e-08 0.0000000 \r
+1.234568e-09 1.234568e-09 1.234568e-09 0.0000000 \r
+1.234568e-10 123.4568e-12 1.234568e-10 0.0000000 \r
+1.234568e-11 12.34568e-12 1.234568e-11 0.0000000</PRE>\r
+</DL>\r
+</DL>\r
+\r
+<PRE>\r
+<HR WIDTH="100%"></PRE>\r
+\r
+<H2>\r
+<A NAME="pForth Design"></A>pForth Design</H2>\r
+\r
+<H3>\r
+<A NAME="'C' kernel"></A>'C' kernel</H3>\r
+The pForth kernel is written in 'C' for portability. The inner interpreter\r
+is implemented in the function ExecuteToken() which is in pf_inner.c.\r
+<UL>\r
+<PRE>void pfExecuteToken( ExecToken XT );</PRE>\r
+</UL>\r
+It is passed an execution token the same as EXECUTE would accept. It handles\r
+threading of secondaries and also has a large switch() case statement to\r
+interpret primitives. It is in one huge routine to take advantage of register\r
+variables, and to reduce calling overhead. Hopefully, your compiler will\r
+optimise the switch() statement into a jump table so it will run fast.\r
+<H3>\r
+<A NAME="Dictionary Structures"></A>Dictionary Structures</H3>\r
+This Forth supports multiple dictionaries. Each dictionary consists of\r
+a header segment and a seperate code segment. The header segment contains\r
+link fields and names. The code segment contains tokens and data. The headers,\r
+as well as some entire dictionaries such as the compiler support words,\r
+can be discarded when creating a stand-alone app.\r
+\r
+<P>[NOT IMPLEMENTED] Dictionaries can be split so that the compile time\r
+words can be placed above the main dictionary. Thus they can use the same\r
+relative addressing but be discarded when turnkeying.\r
+\r
+<P>Execution tokens are either an index of a primitive ( n < NUM_PRIMITIVES),\r
+or the offset of a secondary in the code segment. ( n >= NUM_PRIMITIVES\r
+)\r
+\r
+<P>The NAME HEADER portion of the dictionary contains a structure for each\r
+named word in the dictionary. It contains the following fields:\r
+<UL>\r
+<PRE>bytes 4 Link Field relative address of previous name header\r
+4 Code Pointer relative address of corresponding code\r
+n Name Field name as counted string Headers are quad byte aligned.</PRE>\r
+</UL>\r
+The CODE portion of the dictionary consists of the following structures:\r
+<H4>\r
+Primitive</H4>\r
+No Forth code. 'C' code in "pf_inner.c".\r
+<H4>\r
+Secondary</H4>\r
+\r
+<UL>\r
+<PRE>4*n Parameter Field execution tokens\r
+4 ID_NEXT = 0 terminates secondary</PRE>\r
+</UL>\r
+\r
+<H4>\r
+CREATE DOES></H4>\r
+\r
+<UL>\r
+<PRE>4 ID_CREATE_P token\r
+4 Token for optional DOES> code, OR ID_NEXT = 0\r
+4 ID_NEXT = 0\r
+n Body = arbitrary data</PRE>\r
+</UL>\r
+\r
+<H4>\r
+Deferred Word</H4>\r
+\r
+<UL>\r
+<PRE>4 ID_DEFER_P same action as ID_NOOP, identifies deferred words\r
+4 Execution Token of word to execute.\r
+4 ID_NEXT = 0</PRE>\r
+</UL>\r
+\r
+<H4>\r
+Call to custom 'C' function.</H4>\r
+\r
+<UL>\r
+<PRE>4 ID_CALL_C\r
+4 Pack C Call Info Bits</PRE>\r
+\r
+<UL>\r
+<PRE>0-15 = Function Index Bits\r
+16-23 = FunctionTable Index (Unused) Bits\r
+24-30 = NumParams Bit\r
+31 = 1 if function returns value</PRE>\r
+</UL>\r
+\r
+<PRE>4 ID_NEXT = 0</PRE>\r
+</UL>\r
+\r
+<HR WIDTH="100%">\r
+<H2>\r
+<A NAME="Custom Compilation of pForth"></A>Custom Compilation of pForth</H2>\r
+\r
+<H3>\r
+<A NAME="Compiler Options"></A>Compiler Options</H3>\r
+There are several versions of PForth that can be built. By default, the\r
+full kernel will be built. For custom builds, define the following options\r
+in the Makefile before compiling the 'C' code:\r
+\r
+<P>PF_NO_INIT\r
+<UL>Don't compile the code used to initially build the dictionary. This\r
+can be used to save space if you already have a prebuilt dictionary.</UL>\r
+PF_NO_SHELL\r
+<UL>Don't compile the outer interpreter and Forth compiler. This can be\r
+used with Cloned dictionaries.</UL>\r
+PF_NO_MALLOC\r
+<UL>Replace malloc() and free() function with pForth's own version. See\r
+pf_mem.c for more details.</UL>\r
+PF_USER_MALLOC='"filename.h"'\r
+<UL>Replace malloc() and free() function with users custom version. See\r
+pf_mem.h for details.</UL>\r
+PF_MEM_POOL_SIZE=numbytes\r
+<UL>Size of array in bytes used by pForth custom allocator.</UL>\r
+PF_NO_GLOBAL_INIT\r
+<UL>Define this if you want pForth to not rely on initialization of global\r
+variables by the loader. This may be required for some embedded systems\r
+that may not have a fully functioning loader. Take a look in "pfcustom.c"\r
+for an example of its use.</UL>\r
+PF_USER_INC1='"filename.h"'\r
+<UL>File to include BEFORE other include files. Generally set to host dependent\r
+files such as "pf_mac.h".</UL>\r
+PF_USER_INC2='"filename.h"'\r
+<UL>File to include AFTER other include files. Generally used to #undef\r
+and re#define symbols. See "pf_win32.h" for an example.</UL>\r
+PF_NO_CLIB\r
+<UL>Replace 'C' lib calls like toupper and memcpy with pForth's own version.\r
+This is useful for embedded systems.</UL>\r
+PF_USER_CLIB='"filename.h"'\r
+<UL>Rreplace 'C' lib calls like toupper and memcpy with users custom version.\r
+See pf_clib.h for details.</UL>\r
+PF_NO_FILEIO\r
+<UL>System does not support standard file I/O so stub it out. Setting this\r
+flag will automatically set PF_STATIC_DIC.</UL>\r
+PF_USER_CHARIO='"filename.h"'\r
+<UL>Replace stdio terminal calls like getchar() and putchar() with users\r
+custom version. See pf_io.h for details.</UL>\r
+PF_USER_FILEIO='"filename.h"'\r
+<UL>Replace stdio file calls like fopen and fread with users custom version.\r
+See pf_io.h for details.</UL>\r
+PF_USER_FLOAT='"filename.h"'\r
+<UL>Replace floating point math calls like sin and pow with users custom\r
+version. Also defines PF_FLOAT.</UL>\r
+PF_USER_INIT=MyInit()\r
+<UL>Call a user defined initialization function that returns a negative\r
+error code if it fails.</UL>\r
+PF_USER_TERM=MyTerm()\r
+<UL>Call a user defined void termination function.</UL>\r
+PF_STATIC_DIC\r
+<UL>Compile in static dictionary instead of loading dictionary. from file.\r
+Use "utils/savedicd.fth" to save a dictionary as 'C' source code in a file\r
+called "pfdicdat.h".</UL>\r
+PF_SUPPORT_FP\r
+<UL>Compile ANSI floating point support.</UL>\r
+\r
+<H3>\r
+<A NAME="Building pForth on Supported Hosts"></A>Building pForth on Supported\r
+Hosts</H3>\r
+To build on UNIX, do nothing, system will default to "pf_unix.h".\r
+\r
+<P>To build on Macintosh:\r
+<UL>\r
+<PRE>-DPF_USER_INC1='"pf_mac.h"'</PRE>\r
+</UL>\r
+To build on PCs:\r
+<UL>\r
+<PRE>-DPF_USER_INC2='"pf_win32.h"'</PRE>\r
+</UL>\r
+To build a system that only runs turnkey or cloned binaries:\r
+<UL>\r
+<PRE>-DPF_NO_INIT -DPF_NO_SHELL</PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Compiling for Embedded Systems"></A>Compiling for Embedded Systems</H3>\r
+You may want to create a version of pForth that can be run on a small system\r
+that does not support file I/O. This is useful when bringing up new computer\r
+systems. On UNIX systems, you can use the supplied gmake target. Simply\r
+enter:\r
+<UL>\r
+<PRE>gmake pfemb</PRE>\r
+</UL>\r
+For other systems, here are the steps to create an embedded pForth.\r
+<OL>\r
+<LI>\r
+Determine whether your target system has a different endian-ness than your\r
+host system. If the address of a long word is the address of the\r
+most significant byte, then it is "big endian". Examples of big endian\r
+processors are Sparc, Motorola 680x0 and PowerPC60x. If the address\r
+of a long word is the address of the lest significant byte, then it is\r
+"Little Endian". Examples of little endian processors are Intel 8088 and\r
+derivatives such as the Intel Pentium.</LI>\r
+\r
+<LI>\r
+If your target system has a different endian-ness than your host system,\r
+then you must compile a version of pForth for your host that matches the\r
+target. Rebuild pForth with either PF_BIG_ENDIAN_DIC or PF_LITTLE_ENDIAN_DIC\r
+defined. You will need to rebuild pforth.dic as well as the executable\r
+Forth. If you do not specify one of these variables, then the dictionary\r
+will match the native endian-ness of the processor (and run faster as a\r
+result).</LI>\r
+\r
+<LI>\r
+Execute pForth. Notice the message regarding the endian-ness of the dictionary.</LI>\r
+\r
+<LI>\r
+Compile your custom Forth words on the host development system.</LI>\r
+\r
+<LI>\r
+Compile the pForth utulity "utils/savedicd.fth".</LI>\r
+\r
+<LI>\r
+Enter in pForth: SDAD</LI>\r
+\r
+<LI>\r
+SDAD will generate a file called "pfdicdat.h" that contains your dictionary\r
+in source code form.</LI>\r
+\r
+<LI>\r
+Rewrite the character primitives sdTerminalOut(), sdTerminalIn() and sdTerminalFlush()\r
+defined in pf_io.h to use your new computers communications port.</LI>\r
+\r
+<LI>\r
+Write a "user_chario.h" file based on the API defined in "pf_io.h".</LI>\r
+\r
+<LI>\r
+Compile a new version of pForth for your target machine with the following\r
+options:</LI>\r
+\r
+<OL>\r
+<PRE>-DPF_NO_INIT -DPF_NO_MALLOC -DPF_NO_FILEIO \\r
+-DPF_USER_CHARIO="user_chario.h" \\r
+-DPF_NO_CLIB -DPF_STATIC_DIC</PRE>\r
+</OL>\r
+\r
+<LI>\r
+The file "pfdicdat.h" will be compiled into this executable and your dictionary\r
+will thus be included in the pForth executable as a static array.</LI>\r
+\r
+<LI>\r
+Burn a ROM with your new pForth and run it on your target machine.</LI>\r
+\r
+<LI>\r
+If you compiled a version of pForth with different endian-ness than your\r
+host system, do not use it for daily operation because it will be much\r
+slower than a native version.</LI>\r
+</OL>\r
+\r
+<H3>\r
+<A NAME="Linking with Custom 'C' Functions"></A>Linking with Custom 'C'\r
+Functions</H3>\r
+You can call the pForth interpreter as an embedded tool in a 'C' application.\r
+For an example of this, see the file pf_main.c. This application does nothing\r
+but load the dictionary and call the pForth interpreter.\r
+\r
+<P>You can call 'C' from pForth by adding your own custom 'C' functions\r
+to a dispatch table, and then adding Forth words to the dictionary that\r
+call those functions. See the file "pfcustom.c" for more information.\r
+<H3>\r
+<A NAME="Testing your Compiled pForth"></A>Testing your Compiled pForth</H3>\r
+Once you have compiled pForth, you can test it using the small verification\r
+suite we provide. The first test you should run was written by John\r
+Hayes at John Hopkins University. Enter:\r
+<UL>\r
+<PRE>pforth\r
+include tester.fth\r
+include coretest.fth\r
+bye</PRE>\r
+</UL>\r
+The output will be self explanatory. There are also a number of tests\r
+that I have added that print the number of successes and failures. Enter:\r
+<UL>\r
+<PRE>pforth t_corex.fth\r
+pforth t_locals.fth\r
+pforth t_strings.fth\r
+pforth t_floats.ft</PRE>\r
+</UL>\r
+Note that t_corex.fth reveals an expected error because SAVE-INPUT is not\r
+fully implemented. (FIXME)\r
+<BR>\r
+<HR WIDTH="100%">\r
+<BR>PForth source code is freely available. The author is available\r
+for customization of pForth, porting to new platforms, or developing pForth\r
+applications on a contractual basis. If interested, contact \r
+Phil Burk at <A HREF="mailto:philburk@softsynth.com">philburk@softsynth.com</A>\r
+\r
+<P>Back to <A HREF="pforth.html">pForth Home Page</A>\r
+</BODY>\r
+</HTML>\r
--- /dev/null
+\ %Z% %M% %E% %I%\r
+File: pf_todo.txt\r
+\r
+To Do --------------------------------------------------------\r
+\r
+User Requests\r
+\r
+Peter Verbeke & Carmen Lams <peter@arrow.demon.nl>\r
+ search wordset, float ext wordset , file wordset\r
+ \r
+BUGS\r
+\r
+O- Fix NUMBER? in tutorial\r
+\r
+HIGH\r
+X- Add compile time selection for LittleEndian, BigEndian, or native dictionaries.\r
+X- detect and report endian conflicts in dictionary.\r
+O- add deferred user break to trace, allow stop, dump \r
+O- document more glossary words in pf_glos.htm\r
+O- pfInit() pfTerm(), pfTask()\r
+O- note that Special Feature" are the non-ANS words in document\r
+O- document stack diagram of words used with if.forgotten \r
+X- make sure "binary -1 u." is fixed, is string long enough?\r
+\r
+MEDIUM\r
+O- fix SAVE-INPUT and RESTORE-INPUT\r
+O- add ENVIRONMENT?\r
+O- fix t_corex.fth failures\r
+O- go through ANSI and add what's missing\r
+O- support more word sets\r
+O- support ANSI error codes\r
+O- add INCLUDED\r
+O- add better command line support, -d -e"commands" -i -b\r
+O- document all non-standard words\r
+O- review tutorial and docs\r
+\r
+LOW\r
+O- primitive that accepts, SP RSP and CFA, returns SP' and RSP'\r
+O- merge (LEAVE) and UNLOOP\r
+O- clear data stack in ABORT\r
+O- resolve problems with EOL in WORD\r
+\r
+O- integrate SAVE-FORTH, SDAD, and CLONE\r
+O- simplify dictionary management so that globals are tracked better\r
+O- move globals into task data structure\r
+\r
+O- research ROM requirements\r
+O- clean up C call mechanism\r
+O- research byte size tokens\r
+O- execute Forth QUIT automatically\r
+\r
+Maybe Do ---------\r
+O- defer interpret\r
+\r
+Done -------------\r
+V19\r
+X- warn if local name matches dictionary, : foo { count -- } ;\r
+X- TO -> and +-> now parse input stream. No longer use to-flag.\r
+X- TO -> and +-> now give error if used with non-immediate word.\r
+X- high level trace tool with step, alternative stack\r
+X- ?TERMINAL stub for embedded machines\r
+X- FIXED memory leak in pfDoForth()\r
+X- Add PF_USER_INIT for custom initialization.\r
+X- remove MM.FREE from docs\r
+X- include trace in normal release and document\r
+\r
+\r
+V18\r
+X- Make FILL a 'C' primitive.\r
+X- optimized locals with (1_LOCAL@)\r
+X- optimized inner interpreter by 15%\r
+X- fix tester.fth failures\r
+X- Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined.\r
+X- Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition.\r
+X- Fixed saving and restoring of TIB when nesting include files.\r
+\r
+V16\r
+X- add dictionary room to MAP command\r
+X- fix UM/MOD\r
+X- corex to kernel\r
+X- COMPARE to kernel\r
+X- integrate CATCH with ABORT and INTERPRET\r
+X- add WORDS.LIKE\r
+X- add list and description of files to README\r
+X- get floats to work with :STRUCT and FLPT\r
+X- add PD disclaimers to Forth code\r
+X- make script to build release package for UNIX/Mac\r
+X- clean up source files\r
+X- bump version number\r
+X- add PD disclaimers to 'C' code\r
+X- conditionally compile modes: full_build, compiler, turnkey\r
+X- save as turnkey or dev mode\r
+X- eliminate reliance on printf() for embedded systems\r
+X- funnel ALL I/O through pf_io.c\r
+X- add LoadDictionary\r
+X- add SAVEFORTH\r
+X- Add numeric entry\r
+X- call deferred word from Interpret\r
+X- Create Does\r
+X- Branch, 0branch\r
+X- add decimal numeric output\r
+X- add "OK"\r
+X- FIX EMIT !!!!! defer problem?!\r
+X- try to load dspp_asm.fth\r
+X- dictionary traversal, nfa->ffa\r
+X- fix BYE\r
+X- add CATCH and THROW\r
+X- REFILL\r
+X- SOURCE-ID\r
+X- EVALUATE\r
+X- push and pop source-id\r
+X- make .S deferred, redefine using current base\r
+X- revise trace to use level, stack trace\r
+X- allow minnamesize and mincodesize on save\r
+X- handle decimal point for double precision words.\r
+\r
--- /dev/null
+<HTML>\r
+<HEAD>\r
+ <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">\r
+ <META NAME="GENERATOR" CONTENT="Mozilla/4.05 [en] (Win95; I) [Netscape]">\r
+ <META NAME="Author" CONTENT="Phil Burk">\r
+ <META NAME="Description" CONTENT="Tutorial for pForth language.">\r
+ <META NAME="KeyWords" CONTENT="Forth, tutorial, pForth">\r
+ <TITLE>pForth Tutorial</TITLE>\r
+</HEAD>\r
+<BODY BACKGROUND="r2harch.gif">\r
+\r
+<HR size=4>\r
+<CENTER>\r
+<H1>\r
+Forth Tutorial</H1></CENTER>\r
+\r
+<HR WIDTH="100%">\r
+\r
+<P>by <A HREF="http://www.softsynth.com/philburk.html">Phil Burk</A>\r
+\r
+<P>To <A HREF="pforth.html">pForth Home Page</A>\r
+<H2>\r
+Table of Contents</H2>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#Forth Syntax">Forth Syntax</A></LI>\r
+\r
+<LI>\r
+<A HREF="#The Stack">Stack Manipulation</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Arithmetic">Arithmetic</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Defining a New Word">Defining a New Word</A></LI>\r
+\r
+<LI>\r
+<A HREF="#More Arithmetic">More Arithmetic</A></LI>\r
+\r
+<UL>\r
+<LI>\r
+<A HREF="#Arithmetic Overflow">Arithmetic Overflow</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Convert Algebraic Expressions to Forth">Convert Algebraic Expressions\r
+to Forth</A></LI>\r
+</UL>\r
+\r
+<LI>\r
+<A HREF="#Character Input and Output">Character Input and Output</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Compiling from Files">Compiling from Files</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Variables">Variables</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Constants">Constants</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Logical Operators">Logical Operators</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Conditionals - IF ELSE THEN CASE">Conditionals - IF ELSE THEN\r
+CASE</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Loops">Loops</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Text Input and Output">Text Input and Output</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Changing Numeric Base">Changing Numeric Base</A></LI>\r
+\r
+<LI>\r
+<A HREF="#Answers to Problems">Answers to Problems</A></LI>\r
+</UL>\r
+The intent of this tutorial is to provide a series of experiments that\r
+will introduce you to the major concepts of Forth. It is only a starting\r
+point. Feel free to deviate from the sequences I provide. A free form investigation\r
+that is based on your curiosity is probably the best way to learn any language.\r
+Forth is especially well adapted to this type of learning.\r
+\r
+<P>This tutorial is written for the PForth implementation of the ANS Forth\r
+standard. I have tried to restrict this tutorial to words that are part\r
+of the ANS standard but some PForth specific words may have crept in.\r
+\r
+<P>In the tutorials, I will print the things you need to type in upper\r
+case, and indent them. You can enter them in upper or lower case. At the\r
+end of each line, press the RETURN (or ENTER) key; this causes Forth to\r
+interpret what you've entered.\r
+<H2>\r
+<A NAME="Forth Syntax"></A>Forth Syntax</H2>\r
+Forth has one of the simplest syntaxes of any computer language. The syntax\r
+can be stated as follows, "<B>Forth code is a bunch of words with spaces\r
+between them.</B>" This is even simpler than English! Each <I>word</I>\r
+is equivalent to a function or subroutine in a language like 'C'. They\r
+are executed in the order they appear in the code. The following statement,\r
+for example, could appear in a Forth program:\r
+<UL>\r
+<PRE> <TT>WAKE.UP EAT.BREAKFAST WORK EAT.DINNER PLAY SLEEP</TT></PRE>\r
+</UL>\r
+Notice that WAKE.UP has a dot between the WAKE and UP. The dot has no particular\r
+meaning to the Forth compiler. I simply used a dot to connect the two words\r
+together to make one word. Forth word names can have any combination of\r
+letters, numbers, or punctuation. We will encounter words with names like:\r
+<UL>\r
+<PRE> ." #S SWAP ! @ ACCEPT . *</PRE>\r
+</UL>\r
+They are all called <I>words</I>. The word <B>$%%-GL7OP</B> is a legal\r
+Forth name, although not a very good one. It is up to the programmer to\r
+name words in a sensible manner.\r
+\r
+<P>Now it is time to run your Forth and begin experimenting. Please consult\r
+the manual for your Forth for instructions on how to run it.\r
+<H2>\r
+<A NAME="The Stack"></A>Stack Manipulation</H2>\r
+The Forth language is based on the concept of a <I>stack</I>. Imagine a\r
+stack of blocks with numbers on them. You can add or remove numbers from\r
+the top of the stack. You can also rearrange the order of the numbers.\r
+Forth uses several stacks. The <I>DataStack </I>is the one used for passing\r
+data between Forth words so we will concentrate our attention there. The\r
+<I>Return Stack</I> is another Forth stack that is primarily for internal\r
+system use. In this tutorial, when we refer to the "stack," we will be\r
+referring to the Data Stack.\r
+\r
+<P>The stack is initially empty. To put some numbers on the stack, enter:\r
+<UL>\r
+<PRE><TT>23 7 9182</TT></PRE>\r
+</UL>\r
+Let's now print the number on top of the stack using the Forth word ' <B>.</B>\r
+', which is pronounced " dot ". This is a hard word to write about in a\r
+manual because it is a single period.\r
+\r
+<P>Enter: <B>. </B>\r
+\r
+<P>You should see the last number you entered, 9182 , printed. Forth has\r
+a very handy word for showing you what's on the stack. It is <B>.S</B>\r
+, which is pronounced "dot S". The name was constructed from "dot" for\r
+print, and "S" for stack. (PForth will automatically print the stack after\r
+every line if the TRACE-STACK variable is set to TRUE.) If you enter:\r
+<UL>\r
+<PRE><TT>.S</TT></PRE>\r
+</UL>\r
+you will see your numbers in a list. The number at the far right is the\r
+one on top of the stack.\r
+\r
+<P>You will notice that the 9182 is not on the stack. The word ' . ' removes\r
+the number on top of the stack before printing it. In contrast, ' .S '\r
+leaves the stack untouched.\r
+\r
+<P>We have a way of documenting the effect of words on the stack with a\r
+<I>stack diagram</I>. A stack diagram is contained in parentheses. In Forth,\r
+the parentheses indicate a comment. In the examples that follow, you do\r
+not need to type in the comments. When you are programming, of course,\r
+we encourage the use of comments and stack diagrams to make your code more\r
+readable. In this manual, we often indicate stack diagrams in <B>bold text</B>\r
+like the one that follows. Do not type these in. The stack diagram for\r
+a word like ' . ' would be:\r
+<PRE><B><TT>. ( N -- , print number on top of stack )</TT></B></PRE>\r
+The symbols to the left of -- describe the parameters that a word expects\r
+to process. In this example, N stands for any integer number. To the right\r
+of --, up to the comma, is a description of the stack parameters when the\r
+word is finished, in this case there are none because 'dot' "eats" the\r
+N that was passed in. (Note that the stack descriptions are not necessary,\r
+but they are a great help when learning other peoples programs.)\r
+\r
+<P>The text following the comma is an English description of the word.\r
+You will note that after the -- , N is gone. You may be concerned about\r
+the fact that there were other numbers on the stack, namely 23 and 7 .\r
+The stack diagram, however, only describes the portion of the stack that\r
+is affected by the word. For a more detailed description of the stack diagrams,\r
+there is a special section on them in this manual right before the main\r
+glossary section.\r
+\r
+<P>Between examples, you will probably want to clear the stack. If you\r
+enter <B>0SP</B>, pronounced "zero S P", then the stack will be cleared.\r
+\r
+<P>Since the stack is central to Forth, it is important to be able to alter\r
+the stack easily. Let's look at some more words that manipulate the stack.\r
+Enter:\r
+<UL>\r
+<PRE><TT>0SP .S \ That's a 'zero' 0, not an 'oh' O.\r
+777 DUP .S</TT></PRE>\r
+</UL>\r
+You will notice that there are two copies of 777 on the stack. The word\r
+<B>DUP</B> duplicates the top item on the stack. This is useful when you\r
+want to use the number on top of the stack and still have a copy. The stack\r
+diagram for DUP would be:\r
+<PRE><B><TT>DUP ( n -- n n , DUPlicate top of stack )</TT></B></PRE>\r
+Another useful word, is <B>SWAP</B>. Enter:\r
+<UL>\r
+<PRE><TT>0SP \r
+23 7 .S \r
+SWAP .S \r
+SWAP .S</TT></PRE>\r
+</UL>\r
+The stack diagram for SWAP would be:\r
+<PRE><B><TT>SWAP ( a b -- b a , swap top two items on stack )</TT></B></PRE>\r
+Now enter:\r
+<UL>\r
+<PRE><TT>OVER .S\r
+OVER .S</TT></PRE>\r
+</UL>\r
+The word <B>OVER</B> causes a copy of the second item on the stack to leapfrog\r
+over the first. It's stack diagram would be:\r
+\r
+<P><B><TT>OVER ( a b -- a b a , copy second item on stack )</TT></B>\r
+\r
+<P>Here is another commonly used Forth word:\r
+\r
+<P><B><TT>DROP ( a -- , remove item from the stack )</TT></B>\r
+\r
+<P>Can you guess what we will see if we enter:\r
+<UL>\r
+<PRE><TT>0SP 11 22 .S\r
+DROP .S</TT></PRE>\r
+</UL>\r
+Another handy word for manipulating the stack is <B>ROT</B>. Enter:\r
+<UL>\r
+<PRE><TT>0SP\r
+11 22 33 44 .S\r
+ROT .S</TT></PRE>\r
+</UL>\r
+The stack diagram for ROT is, therefore:\r
+\r
+<P><B><TT>ROT ( a b c -- b c a , ROTate third item to top ) </TT></B>\r
+\r
+<P>You have now learned the more important stack manipulation words. You\r
+will see these in almost every Forth program. I should caution you that\r
+if you see too many stack manipulation words being used in your code then\r
+you may want to reexamine and perhaps reorganize your code. You will often\r
+find that you can avoid excessive stack manipulations by using <I>local\r
+or global VARIABLES</I> which will be discussed later.\r
+\r
+<P>If you want to grab any arbitrary item on the stack, use <B>PICK</B>\r
+. Try entering:\r
+<UL>\r
+<PRE><TT>0SP\r
+14 13 12 11 10\r
+3 PICK . ( prints 13 )\r
+0 PICK . ( prints 10 )\r
+4 PICK .</TT></PRE>\r
+</UL>\r
+PICK makes a copy of the Nth item on the stack. The numbering starts with\r
+zero, therefore:\r
+<UL><TT>0 PICK is equivalent to DUP</TT>\r
+<BR><TT>1 PICK is equivalent to OVER </TT></UL>\r
+<B><TT>PICK ( ... v3 v2 v1 v0 N -- ... v3 v2 v1 v0 vN ) </TT></B>\r
+\r
+<P>(Warning. The Forth-79 and FIG Forth standards differ from the ANS and\r
+Forth '83 standard in that their PICK numbering starts with one, not zero.)\r
+\r
+<P>I have included the stack diagrams for some other useful stack manipulation\r
+words. Try experimenting with them by putting numbers on the stack and\r
+calling them to get a feel for what they do. Again, the text in parentheses\r
+is just a comment and need not be entered.\r
+\r
+<P><B><TT>DROP ( n -- , remove top of stack ) </TT></B>\r
+\r
+<P><B><TT>?DUP ( n -- n n | 0 , duplicate only if non-zero, '|' means OR\r
+) </TT></B>\r
+\r
+<P><B><TT>-ROT ( a b c -- c a b , rotate top to third position ) </TT></B>\r
+\r
+<P><B><TT>2SWAP ( a b c d -- c d a b , swap pairs ) </TT></B>\r
+\r
+<P><B><TT>2OVER ( a b c d -- a b c d a b , leapfrog pair ) </TT></B>\r
+\r
+<P><B><TT>2DUP ( a b -- a b a b , duplicate pair ) </TT></B>\r
+\r
+<P><B><TT>2DROP ( a b -- , remove pair ) </TT></B>\r
+\r
+<P><B><TT>NIP ( a b -- b , remove second item from stack ) </TT></B>\r
+\r
+<P><B><TT>TUCK ( a b -- b a b , copy top item to third position ) </TT></B>\r
+<H3>\r
+<A NAME="Problems - Stack"></A>Problems:</H3>\r
+Start each problem by entering:\r
+<UL>\r
+<PRE><TT>0SP 11 22 33</TT></PRE>\r
+</UL>\r
+Then use the stack manipulation words you have learned to end up with the\r
+following numbers on the stack:\r
+<UL>\r
+<PRE><TT>1) 11 33 22 22</TT></PRE>\r
+\r
+<PRE><TT>2) 22 33</TT></PRE>\r
+\r
+<PRE><TT>3) 22 33 11 11 22</TT></PRE>\r
+\r
+<PRE><TT>4) 11 33 22 33 11</TT></PRE>\r
+\r
+<PRE><TT>5) 33 11 22 11 22</TT></PRE>\r
+</UL>\r
+<A HREF="#Answers to Problems">Answers to the problems</A> can be found\r
+at the end of this tutorial.\r
+<H2>\r
+<A NAME="Arithmetic"></A>Arithmetic</H2>\r
+Great joy can be derived from simply moving numbers around on a stack.\r
+Eventually, however, you'll want to do something useful with them. This\r
+section describes how to perform arithmetic operations in Forth.\r
+\r
+<P>The Forth arithmetic operators work on the numbers currently on top\r
+of the stack. If you want to add the top two numbers together, use the\r
+Forth word <B>+</B> , pronounced "plus". Enter:\r
+<UL>\r
+<PRE><TT>2 3 + .\r
+2 3 + 10 + .</TT></PRE>\r
+</UL>\r
+This style of expressing arithmetic operations is called <I>Reverse Polish\r
+Notation,</I> or<I> RPN</I>. It will already be familiar to those of you\r
+with HP calculators. In the following examples, I have put the algebraic\r
+equivalent representation in a comment.\r
+\r
+<P>Some other arithmetic operators are <B>- * /</B> . Enter:\r
+<UL>\r
+<PRE><TT>30 5 - . ( 25=30-5 )\r
+30 5 / . ( 6=30/5 )\r
+30 5 * . ( 150=30*5 )\r
+30 5 + 7 / . \ 5=(30+5)/7</TT></PRE>\r
+</UL>\r
+Some combinations of operations are very common and have been coded in\r
+assembly language for speed. For example, <B>2*</B> is short for 2 * .\r
+You should use these whenever possible to increase the speed of your program.\r
+These include:\r
+<UL>\r
+<PRE><TT>1+ 1- 2+ 2- 2* 2/</TT></PRE>\r
+</UL>\r
+Try entering:\r
+<UL>\r
+<PRE><TT>10 1- .\r
+7 2* 1+ . ( 15=7*2+1 )</TT></PRE>\r
+</UL>\r
+One thing that you should be aware of is that when you are doing division\r
+with integers using / , the remainder is lost. Enter:\r
+<UL>\r
+<PRE><TT>15 5 / .\r
+17 5 / .</TT></PRE>\r
+</UL>\r
+This is true in all languages on all computers. Later we will examine <B>/MOD</B>\r
+and <B>MOD</B> which do give the remainder.\r
+<H2>\r
+<A NAME="Defining a New Word"></A>Defining a New Word</H2>\r
+It's now time to write a <I>small program</I> in Forth. You can do this\r
+by defining a new word that is a combination of words we have already learned.\r
+Let's define and test a new word that takes the average of two numbers.\r
+<DT>\r
+We will make use of two new words, <B>:</B> ( "colon"), and <B>;</B> (\r
+"semicolon") . These words start and end a typical <I>Forth definition</I>.\r
+Enter:</DT>\r
+\r
+<UL>\r
+<PRE><TT>: AVERAGE ( a b -- avg ) + 2/ ;</TT></PRE>\r
+</UL>\r
+Congratulations. You have just written a Forth program. Let's look more\r
+closely at what just happened. The colon told Forth to add a new word to\r
+its list of words. This list is called the Forth dictionary. The name of\r
+the new word will be whatever name follows the colon. Any Forth words entered\r
+after the name will be compiled into the new word. This continues until\r
+the semicolon is reached which finishes the definition.\r
+\r
+<P>Let's test this word by entering:\r
+<UL>\r
+<PRE><TT>10 20 AVERAGE . ( should print 15 )</TT></PRE>\r
+</UL>\r
+Once a word has been defined, it can be used to define more words. Let's\r
+write a word that tests our word.. Enter:\r
+<UL>\r
+<PRE><TT>: TEST ( --) 50 60 AVERAGE . ;\r
+TEST</TT></PRE>\r
+</UL>\r
+Try combining some of the words you have learned into new Forth definitions\r
+of your choice. If you promise not to be overwhelmed, you can get a list\r
+of the words that are available for programming by entering:\r
+<UL>\r
+<PRE><TT>WORDS</TT></PRE>\r
+</UL>\r
+Don't worry, only a small fraction of these will be used directly in your\r
+programs.\r
+<H2>\r
+<A NAME="More Arithmetic"></A>More Arithmetic</H2>\r
+When you need to know the remainder of a divide operation. /MOD will return\r
+the remainder as well as the quotient. the word MOD will only return the\r
+remainder. Enter:\r
+<UL>\r
+<PRE><TT>0SP\r
+53 10 /MOD .S\r
+0SP\r
+7 5 MOD .S</TT></PRE>\r
+</UL>\r
+Two other handy words are <B>MIN</B> and <B>MAX</B> . They accept two numbers\r
+and return the MINimum or MAXimum value respectively. Try entering the\r
+following:\r
+<UL>\r
+<PRE><TT>56 34 MAX .\r
+56 34 MIN .\r
+-17 0 MIN .</TT></PRE>\r
+</UL>\r
+Some other useful words are:\r
+\r
+<P><B><TT>ABS ( n -- abs(n) , absolute value of n ) </TT></B>\r
+\r
+<P><B><TT>NEGATE ( n -- -n , negate value, faster then -1 * ) </TT></B>\r
+\r
+<P><B><TT>LSHIFT ( n c -- n<<c , left shift of n ) </TT></B>\r
+\r
+<P><B><TT>RSHIFT ( n c -- n>>c , logical right shift of n ) </TT></B>\r
+\r
+<P><B><TT>ARSHIFT ( n c -- n>>c ) , arithmetic right shift of n ) </TT></B>\r
+\r
+<P>ARSHIFT or LSHIFT can be used if you have to multiply quickly by a power\r
+of 2 . A right shift is like doing a divide by 2. This is often faster\r
+than doing a regular multiply or divide. Try entering:\r
+<UL>\r
+<PRE><TT>: 256* 8 LSHIFT ;\r
+3 256* .</TT></PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Arithmetic Overflow"></A>Arithmetic Overflow</H3>\r
+If you are having problems with your calculation overflowing the 32-bit\r
+precision of the stack, then you can use <B>*/</B> . This produces an intermediate\r
+result that is 64 bits long. Try the following three methods of doing the\r
+same calculation. Only the one using */ will yield the correct answer,\r
+5197799.\r
+<UL>\r
+<PRE><TT>34867312 99154 * 665134 / .\r
+34867312 665134 / 99154 * .\r
+34867312 99154 665134 */ .</TT></PRE>\r
+</UL>\r
+\r
+<H4>\r
+<A NAME="Convert Algebraic Expressions to Forth"></A>Convert Algebraic\r
+Expressions to Forth</H4>\r
+How do we express complex algebraic expressions in Forth? For example:\r
+20 + (3 * 4)\r
+\r
+<P>To convert this to Forth you must order the operations in the order\r
+of evaluation. In Forth, therefore, this would look like:\r
+<UL>\r
+<PRE><TT>3 4 * 20 +</TT></PRE>\r
+</UL>\r
+Evaluation proceeds from left to right in Forth so there is no ambiguity.\r
+Compare the following algebraic expressions and their Forth equivalents:\r
+(Do <B>not</B> enter these!)\r
+<UL>\r
+<PRE>(100+50)/2 ==> 100 50 + 2/\r
+((2*7) + (13*5)) ==> 2 7 * 13 5 * +</PRE>\r
+</UL>\r
+If any of these expressions puzzle you, try entering them one word at a\r
+time, while viewing the stack with .S .\r
+<H3>\r
+<A NAME="Problems - Square"></A>Problems:</H3>\r
+Convert the following algebraic expressions to their equivalent Forth expressions.\r
+(Do <B>not</B> enter these because they are not Forth code!)\r
+<UL>\r
+<PRE>(12 * ( 20 - 17 ))</PRE>\r
+\r
+<PRE>(1 - ( 4 * (-18) / 6) )</PRE>\r
+\r
+<PRE>( 6 * 13 ) - ( 4 * 2 * 7 )</PRE>\r
+</UL>\r
+Use the words you have learned to write these new words:\r
+<UL>\r
+<PRE><TT>SQUARE ( N -- N*N , calculate square )</TT></PRE>\r
+\r
+<PRE><TT>DIFF.SQUARES ( A B -- A*A-B*B , difference of squares )</TT></PRE>\r
+\r
+<PRE><TT>AVERAGE4 ( A B C D -- [A+B+C+D]/4 )</TT></PRE>\r
+\r
+<PRE>HMS>SECONDS ( HOURS MINUTES SECONDS -- TOTAL-SECONDS , convert )</PRE>\r
+</UL>\r
+<A HREF="#Answers to Problems">Answers to the problems</A> can be found\r
+at the end of this tutorial.\r
+<H2>\r
+<A NAME="Character Input and Output"></A>Character Input and Output</H2>\r
+The numbers on top of the stack can represent anything. The top number\r
+might be how many blue whales are left on Earth or your weight in kilograms.\r
+It can also be an ASCII character. Try entering the following:\r
+<UL>\r
+<PRE><TT>72 EMIT 105 EMIT</TT></PRE>\r
+</UL>\r
+You should see the word "Hi" appear before the OK. The 72 is an ASCII 'H'\r
+and 105 is an 'i'. EMIT takes the number on the stack and outputs it as\r
+a character. If you want to find the ASCII value for any character, you\r
+can use the word ASCII . Enter:\r
+<UL>\r
+<PRE><TT>CHAR W .\r
+CHAR % DUP . EMIT\r
+CHAR A DUP .\r
+32 + EMIT</TT></PRE>\r
+</UL>\r
+There is an ASCII chart in the back of this manual for a complete character\r
+list.\r
+\r
+<P>Notice that the word CHAR is a bit unusual because its input comes not\r
+from the stack, but from the following text. In a stack diagram, we represent\r
+that by putting the input in angle brackets, <input>. Here is the stack\r
+diagram for CHAR.\r
+\r
+<P><B><TT>CHAR ( <char> -- char , get ASCII value of a character ) </TT></B>\r
+\r
+<P>Using EMIT to output character strings would be very tedious. Luckily\r
+there is a better way. Enter:\r
+<UL>\r
+<PRE><TT>: TOFU ." Yummy bean curd!" ;\r
+TOFU</TT></PRE>\r
+</UL>\r
+The word <B>."</B> , pronounced "dot quote", will take everything up to\r
+the next quotation mark and print it to the screen. Make sure you leave\r
+a space after the first quotation mark. When you want to have text begin\r
+on a new line, you can issue a carriage return using the word <B>CR</B>\r
+. Enter:\r
+<UL>\r
+<PRE><TT>: SPROUTS ." Miniature vegetables." ;\r
+: MENU\r
+ CR TOFU CR SPROUTS CR\r
+;\r
+MENU</TT></PRE>\r
+</UL>\r
+You can emit a blank space with <B>SPACE</B> . A number of spaces can be\r
+output with SPACES . Enter:\r
+<UL>\r
+<PRE><TT>CR TOFU SPROUTS\r
+CR TOFU SPACE SPROUTS\r
+CR 10 SPACES TOFU CR 20 SPACES SPROUTS</TT></PRE>\r
+</UL>\r
+For character input, Forth uses the word <B>KEY</B> which corresponds to\r
+the word EMIT for output. KEY waits for the user to press a key then leaves\r
+its value on the stack. Try the following.\r
+<UL>\r
+<PRE><TT>: TESTKEY ( -- )\r
+ ." Hit a key: " KEY CR\r
+ ." That = " . CR\r
+;\r
+TESTKEY</TT></PRE>\r
+</UL>\r
+[Note: On some computers, the input if buffered so you will need to hit\r
+the ENTER key after typing your character.]\r
+\r
+<P><B><TT>EMIT ( char -- , output character ) </TT></B>\r
+\r
+<P><B><TT>KEY ( -- char , input character ) </TT></B>\r
+\r
+<P><B><TT>SPACE ( -- , output a space ) </TT></B>\r
+\r
+<P><B><TT>SPACES ( n -- , output n spaces ) </TT></B>\r
+\r
+<P><B><TT>CHAR ( <char> -- char , convert to ASCII ) </TT></B>\r
+\r
+<P><B><TT>CR ( -- , start new line , carriage return ) </TT></B>\r
+\r
+<P><B><TT>." ( -- , output " delimited text ) </TT></B>\r
+<H2>\r
+<BR>\r
+<BR>\r
+<A NAME="Compiling from Files"></A>Compiling from Files</H2>\r
+PForth can read read from ordinary text files so you can use any editor\r
+that you wish to write your programs.\r
+<H3>\r
+Sample Program</H3>\r
+Enter into your file, the following code.\r
+<UL>\r
+<PRE><TT>\ Sample Forth Code\r
+\ Author: <I>your name</I></TT></PRE>\r
+\r
+<PRE><TT>: SQUARE ( n -- n*n , square number )\r
+ DUP *\r
+;</TT></PRE>\r
+\r
+<PRE><TT>: TEST.SQUARE ( -- )\r
+ CR ." 7 squared = "\r
+ 7 SQUARE . CR\r
+;</TT></PRE>\r
+</UL>\r
+Now save the file to disk.\r
+\r
+<P>The text following the <B>\</B> character is treated as a comment. This\r
+would be a REM statement in BASIC or a /*---*/ in 'C'. The text in parentheses\r
+is also a comment.\r
+<H3>\r
+Using INCLUDE</H3>\r
+"INCLUDE" in Forth means to compile from a file.\r
+\r
+<P>You can compile this file using the INCLUDE command. If you saved your\r
+file as WORK:SAMPLE, then compile it by entering:\r
+<UL>\r
+<PRE><TT>INCLUDE SAMPLE.FTH</TT></PRE>\r
+</UL>\r
+Forth will compile your file and tell you how many bytes it has added to\r
+the dictionary. To test your word, enter:\r
+<UL>\r
+<PRE><TT>TEST.SQUARE</TT></PRE>\r
+</UL>\r
+Your two words, SQUARE and TEST.SQUARE are now in the Forth dictionary.\r
+We can now do something that is very unusual in a programming language.\r
+We can "uncompile" the code by telling Forth to <B>FORGET</B> it. Enter:\r
+<UL>\r
+<PRE><TT>FORGET SQUARE</TT></PRE>\r
+</UL>\r
+This removes SQUARE and everything that follows it, ie. TEST.SQUARE, from\r
+the dictionary. If you now try to execute TEST.SQUARE it won't be found.\r
+\r
+<P>Now let's make some changes to our file and reload it. Go back into\r
+the editor and make the following changes: (1) Change TEST.SQUARE to use\r
+15 instead of 7 then (2) Add this line right before the definition of SQUARE:\r
+<UL>\r
+<PRE><TT>ANEW TASK-SAMPLE.FTH</TT></PRE>\r
+</UL>\r
+Now Save your changes and go back to the Forth window.\r
+\r
+<P>You're probably wondering what the line starting with <B>ANEW</B> was\r
+for. ANEW is always used at the beginning of a file. It defines a special\r
+marker word in the dictionary before the code. The word typically has "TASK-"\r
+as a prefix followed by the name of the file. When you ReInclude a file,\r
+ANEW will automatically FORGET the old code starting after the ANEW statement.\r
+This allows you to Include a file over and over again without having to\r
+manually FORGET the first word. If the code was not forgotten, the dictionary\r
+would eventually fill up.\r
+\r
+<P>If you have a big project that needs lots of files, you can have a file\r
+that will load all the files you need. Sometimes you need some code to\r
+be loaded that may already be loaded. The word <B>INCLUDE?</B> will only\r
+load code if it isn't already in the dictionary. In this next example,\r
+I assume the file is on the volume WORK: and called SAMPLE. If not, please\r
+substitute the actual name. Enter:\r
+<UL>\r
+<PRE><TT>FORGET TASK-SAMPLE.FTH\r
+INCLUDE? SQUARE WORK:SAMPLE\r
+INCLUDE? SQUARE WORK:SAMPLE</TT></PRE>\r
+</UL>\r
+Only the first INCLUDE? will result in the file being loaded.\r
+<H2>\r
+<A NAME="Variables"></A>Variables</H2>\r
+Forth does not rely as heavily on the use of variables as other compiled\r
+languages. This is because values normally reside on the stack. There are\r
+situations, of course, where variables are required. To create a variable,\r
+use the word <B>VARIABLE</B> as follows:\r
+<UL>\r
+<PRE><TT>VARIABLE MY-VAR</TT></PRE>\r
+</UL>\r
+This created a variable named MY-VAR . A space in memory is now reserved\r
+to hold its 32-bit value. The word VARIABLE is what's known as a "defining\r
+word" since it creates new words in the dictionary. Now enter:\r
+<UL>\r
+<PRE><TT>MY-VAR .</TT></PRE>\r
+</UL>\r
+The number you see is the address, or location, of the memory that was\r
+reserved for MY-VAR. To store data into memory you use the word <B>!</B>\r
+, pronounced "store". It looks like an exclamation point, but to a Forth\r
+programmer it is the way to write 32-bit data to memory. To read the value\r
+contained in memory at a given address, use the Forth word <B>@</B> , pronounced\r
+"fetch". Try entering the following:\r
+<UL>\r
+<PRE><TT>513 MY-VAR !\r
+MY-VAR @ .</TT></PRE>\r
+</UL>\r
+This sets the variable MY-VAR to 513 , then reads the value back and prints\r
+it. The stack diagrams for these words follows:\r
+\r
+<P><B><TT>@ ( address -- value , FETCH value FROM address in memory ) </TT></B>\r
+\r
+<P><B><TT>! ( value address -- , STORE value TO address in memory )</TT></B>\r
+\r
+<P><B><TT>VARIABLE ( <name> -- , define a 4 byte memory storage location)</TT></B>\r
+\r
+<P>A handy word for checking the value of a variable is <B>? </B>, pronounced\r
+"question". Try entering:\r
+<UL>\r
+<PRE><TT>MY-VAR ?</TT></PRE>\r
+</UL>\r
+If ? wasn't defined, we could define it as:\r
+<UL>\r
+<PRE><TT>: ? ( address -- , look at variable )\r
+ @ .\r
+;</TT></PRE>\r
+</UL>\r
+Imagine you are writing a game and you want to keep track of the highest\r
+score. You could keep the highest score in a variable. When you reported\r
+a new score, you could check it aginst the highest score. Try entering\r
+this code in a file as described in the previous section:\r
+<UL>\r
+<PRE><TT>VARIABLE HIGH-SCORE</TT></PRE>\r
+\r
+<PRE><TT>: REPORT.SCORE ( score -- , print out score )\r
+ DUP CR ." Your Score = " . CR\r
+ HIGH-SCORE @ MAX ( calculate new high )\r
+ DUP ." Highest Score = " . CR\r
+ HIGH-SCORE ! ( update variable )\r
+;</TT></PRE>\r
+</UL>\r
+Save the file to disk, then compile this code using the INCLUDE word. Test\r
+your word as follows:\r
+<UL>\r
+<PRE><TT>123 REPORT.SCORE\r
+9845 REPORT.SCORE\r
+534 REPORT.SCORE</TT></PRE>\r
+</UL>\r
+The Forth words @ and ! work on 32-bit quantities. Some Forths are "16-bit"\r
+Forths. They fetch and store 16-bit quantities. Forth has some words that\r
+will work on 8 and 16-bit values. C@ and C! work characters which are usually\r
+for 8-bit bytes. The 'C' stands for "Character" since ASCII characters\r
+are 8-bit numbers. Use W@ and W! for 16-bit "Words."\r
+\r
+<P>Another useful word is <B>+!</B> , pronounced "plus store." It adds\r
+a value to a 32-bit value in memory. Try:\r
+<UL>\r
+<PRE><TT>20 MY-VAR !\r
+5 MY-VAR +!\r
+MY-VAR @ .</TT></PRE>\r
+</UL>\r
+Forth also provides some other words that are similar to VARIABLE. Look\r
+in the glossary for VALUE and ARRAY. Also look at the section on "<A HREF="pf_ref.htm#Local Variables { foo --}?">local\r
+variables</A>" which are variables which only exist on the stack while\r
+a Forth word is executing.\r
+\r
+<P><I>A word of warning about fetching and storing to memory</I>: You have\r
+now learned enough about Forth to be dangerous. The operation of a computer\r
+is based on having the right numbers in the right place in memory. You\r
+now know how to write new numbers to any place in memory. Since an address\r
+is just a number, you could, but shouldn't, enter:\r
+<UL>\r
+<PRE><TT>73 253000 ! ( Do NOT do this. )</TT></PRE>\r
+</UL>\r
+The 253000 would be treated as an address and you would set that memory\r
+location to 73. I have no idea what will happen after that, maybe nothing.\r
+This would be like firing a rifle through the walls of your apartment building.\r
+You don't know who or what you are going to hit. Since you share memory\r
+with other programs including the operating system, you could easily cause\r
+the computer to behave strangely, even crash. Don't let this bother you\r
+too much, however. Crashing a computer, unlike crashing a car, does not\r
+hurt the computer. You just have to reboot. The worst that could happen\r
+is that if you crash while the computer is writing to a disk, you could\r
+lose a file. That's why we make backups. This same potential problem exists\r
+in any powerful language, not just Forth. This might be less likely in\r
+BASIC, however, because BASIC protects you from a lot of things, including\r
+the danger of writing powerful programs.\r
+\r
+<P>Another way to get into trouble is to do what's called an "odd address\r
+memory access." The 68000 processor arranges words and longwords, 16 and\r
+32 bit numbers, on even addresses. If you do a <B>@</B> or <B>!</B> , or\r
+<B>W@</B> or <B>W!</B> , to an odd address, the 68000 processor will take\r
+exception to this and try to abort.\r
+\r
+<P>Forth gives you some protection from this by trapping this exception\r
+and returning you to the OK prompt. If you really need to access data on\r
+an odd address, check out the words <B>ODD@</B> and <B>ODD!</B> in the\r
+glossary. <B>C@</B> and <B>C!</B> work fine on both odd and even addresses.\r
+<H2>\r
+<A NAME="Constants"></A>Constants</H2>\r
+If you have a number that is appearing often in your program, we recommend\r
+that you define it as a "constant." Enter:\r
+<UL>\r
+<PRE><TT>128 CONSTANT MAX_CHARS\r
+MAX_CHARS .</TT></PRE>\r
+</UL>\r
+We just defined a word called MAX_CHARS that returns the value on the stack\r
+when it was defined. It cannot be changed unless you edit the program and\r
+recompile. Using <B>CONSTANT</B> can improve the readability of your programs\r
+and reduce some bugs. Imagine if you refer to the number 128 very often\r
+in your program, say 8 times. Then you decide to change this number to\r
+256. If you globally change 128 to 256 you might change something you didn't\r
+intend to. If you change it by hand you might miss one, especially if your\r
+program occupies more than one file. Using CONSTANT will make it easy to\r
+change. The code that results is equally as fast and small as putting the\r
+numbers in directly. I recommend defining a constant for almost any number.\r
+<H2>\r
+<A NAME="Logical Operators"></A>Logical Operators</H2>\r
+These next two sections are concerned with decision making. This first\r
+section deals with answering questions like "Is this value too large?"\r
+or "Does the guess match the answer?". The answers to questions like these\r
+are either TRUE or FALSE. Forth uses a 0 to represent <B>FALSE</B> and\r
+a -1 to represent <B>TRUE</B>. TRUE and FALSE have been capitalized because\r
+they have been defined as Forth constants. Try entering:\r
+<UL>\r
+<PRE><TT>23 71 = .\r
+18 18 = .</TT></PRE>\r
+</UL>\r
+You will notice that the first line printed a 0, or FALSE, and the second\r
+line a -1, or TRUE. The equal sign in Forth is used as a question, not\r
+a statement. It asks whether the top two items on the stack are equal.\r
+It does not set them equal. There are other questions that you can ask.\r
+Enter:\r
+<UL>\r
+<PRE><TT>23 198 < .\r
+23 198 > .\r
+254 15 > .</TT></PRE>\r
+</UL>\r
+In California, the drinking age for alcohol is 21. You could write a simple\r
+word now to help bartenders. Enter:\r
+<UL>\r
+<PRE><TT>: DRINK? ( age -- flag , can this person drink? )\r
+ 20 >\r
+;</TT></PRE>\r
+\r
+<PRE><TT>20 DRINK? .\r
+21 DRINK? .\r
+43 DRINK? .</TT></PRE>\r
+</UL>\r
+The word FLAG in the stack diagram above refers to a logical value.\r
+\r
+<P>Forth provides special words for comparing a number to 0. They are <B>0=</B>\r
+<B>0></B> and <B>0<</B> . Using 0> is faster than calling 0 and > separately.\r
+Enter:\r
+<UL><TT>23 0> . ( print -1 )</TT>\r
+<BR><TT>-23 0> . ( print 0 )</TT>\r
+<BR><TT>23 0= . ( print 0 )</TT></UL>\r
+For more complex decisions, you can use the <I>Boolean</I> operators <B>OR</B>\r
+, <B>AND</B> , and <B>NOT</B> . OR returns a TRUE if either one or both\r
+of the top two stack items are true.\r
+<UL>\r
+<PRE><TT>TRUE TRUE OR .\r
+TRUE FALSE OR .\r
+FALSE FALSE OR .</TT></PRE>\r
+</UL>\r
+AND only returns a TRUE if both of them are true.\r
+<UL>\r
+<PRE><TT>TRUE TRUE AND .\r
+TRUE FALSE AND .</TT></PRE>\r
+</UL>\r
+NOT reverses the value of the flag on the stack. Enter:\r
+<UL>\r
+<PRE><TT>TRUE .\r
+TRUE NOT .</TT></PRE>\r
+</UL>\r
+Logical operators can be combined.\r
+<UL>\r
+<PRE><TT>56 3 > 56 123 < AND .\r
+23 45 = 23 23 = OR .</TT></PRE>\r
+</UL>\r
+Here are stack diagrams for some of these words. See the glossary for a\r
+more complete list.\r
+\r
+<P><B><TT>< ( a b -- flag , flag is true if A is less than B )</TT></B>\r
+\r
+<P><B><TT>> ( a b -- flag , flag is true if A is greater than B )</TT></B>\r
+\r
+<P><B><TT>= ( a b -- flag , flag is true if A is equal to B )</TT></B>\r
+\r
+<P><B><TT>0= ( a -- flag , true if a equals zero )</TT></B>\r
+\r
+<P><B><TT>OR ( a b -- a||b , perform logical OR of bits in A and B )</TT></B>\r
+\r
+<P><B><TT>AND ( a b -- a&b , perform logical AND of bits in A and B\r
+)</TT></B>\r
+\r
+<P><B><TT>NOT ( flag -- opposite-flag , true if false, false if true )</TT></B>\r
+<H3>\r
+<A NAME="Problems - Logical"></A>Problems:</H3>\r
+1) Write a word called LOWERCASE? that returns TRUE if the number on top\r
+of the stack is an ASCII lowercase character. An ASCII 'a' is 97 . An ASCII\r
+'z' is 122 . Test using the characters " A ` a q z { ".\r
+<UL>\r
+<PRE><TT>CHAR A LOWERCASE? . ( should print 0 )\r
+CHAR a LOWERCASE? . ( should print -1 )</TT></PRE>\r
+</UL>\r
+<A HREF="#Answers to Problems">Answers to the problems</A> can be found\r
+at the end of this tutorial.\r
+<H2>\r
+<A NAME="Conditionals - IF ELSE THEN CASE"></A>Conditionals - IF ELSE THEN\r
+CASE</H2>\r
+You will now use the TRUE and FALSE flags you learned to generate in the\r
+last section. The "flow of control" words accept flags from the stack,\r
+and then possibly "branch" depending on the value. Enter the following\r
+code.\r
+<UL>\r
+<PRE><TT>: .L ( flag -- , print logical value )\r
+ IF ." True value on stack!"\r
+ ELSE ." False value on stack!"\r
+ THEN\r
+;</TT></PRE>\r
+\r
+<PRE><TT>0 .L\r
+FALSE .L\r
+TRUE .L\r
+23 7 < .L</TT></PRE>\r
+</UL>\r
+You can see that when a TRUE was on the stack, the first part got executed.\r
+If a FALSE was on the stack, then the first part was skipped, and the second\r
+part was executed. One thing you will find interesting is that if you enter:\r
+<UL>\r
+<PRE><TT>23 .L</TT></PRE>\r
+</UL>\r
+the value on the stack will be treated as true. The flow of control words\r
+consider any value that does not equal zero to be TRUE.\r
+\r
+<P>The <B>ELSE</B> word is optional in the <B>IF...THEN</B> construct.\r
+Try the following:\r
+<UL>\r
+<PRE><TT>: BIGBUCKS? ( ammount -- )\r
+ 1000 >\r
+ IF ." That's TOO expensive!"\r
+ THEN\r
+;</TT></PRE>\r
+\r
+<PRE><TT>531 BIGBUCKS?\r
+1021 BIGBUCKS?</TT></PRE>\r
+</UL>\r
+Many Forths also support a <B>CASE</B> statement similar to switch() in\r
+'C'. Enter:\r
+<UL>\r
+<PRE><TT>: TESTCASE ( N -- , respond appropriately )\r
+ CASE\r
+ 0 OF ." Just a zero!" ENDOF\r
+ 1 OF ." All is ONE!" ENDOF\r
+ 2 OF WORDS ENDOF\r
+ DUP . ." Invalid Input!"\r
+ ENDCASE CR\r
+;</TT></PRE>\r
+\r
+<PRE><TT>0 TESTCASE\r
+1 TESTCASE\r
+</TT>5 TESTCASE</PRE>\r
+</UL>\r
+See CASE in the glossary for more information.\r
+<H3>\r
+<A NAME="Problems - Conditionals"></A>Problems:</H3>\r
+1) Write a word called DEDUCT that subtracts a value from a variable containing\r
+your checking account balance. Assume the balance is in dollars. Print\r
+the balance. Print a warning if the balance is negative.\r
+<UL>\r
+<PRE><TT>VARIABLE ACCOUNT</TT></PRE>\r
+\r
+<PRE><TT>: DEDUCT ( n -- , subtract N from balance )\r
+ ????????????????????????????????? ( you fill this in )\r
+;</TT></PRE>\r
+\r
+<PRE><TT>300 ACCOUNT ! ( initial funds )\r
+40 DEDUCT ( prints 260 )\r
+200 DEDUCT ( print 60 )\r
+100 DEDUCT ( print -40 and give warning! )</TT></PRE>\r
+</UL>\r
+<A HREF="#Answers to Problems">Answers to the problems</A> can be found\r
+at the end of this tutorial.\r
+<H2>\r
+<A NAME="Loops"></A>Loops</H2>\r
+Another useful pair of words is <B>BEGIN...UNTIL</B> . These are used to\r
+loop until a given condition is true. Try this:\r
+<UL>\r
+<PRE><TT>: COUNTDOWN ( N -- )\r
+ BEGIN\r
+ DUP . CR ( print number on top of stack )\r
+ 1- DUP 0< ( loop until we go negative )\r
+ UNTIL\r
+;</TT></PRE>\r
+\r
+<PRE><TT>16 COUNTDOWN</TT></PRE>\r
+</UL>\r
+This word will count down from N to zero.\r
+\r
+<P>If you know how many times you want a loop to execute, you can use the\r
+<B>DO...LOOP</B> construct. Enter:\r
+<UL>\r
+<PRE><TT>: SPELL\r
+ ." ba"\r
+ 4 0 DO\r
+ ." na"\r
+ LOOP\r
+;</TT></PRE>\r
+</UL>\r
+This will print "ba" followed by four occurrences of "na". The ending value\r
+is placed on the stack before the beginning value. Be careful that you\r
+don't pass the values in reverse. Forth will go "the long way around" which\r
+could take awhile. The reason for this order is to make it easier to pass\r
+the loop count into a word on the stack. Consider the following word for\r
+doing character graphics. Enter:\r
+<UL>\r
+<PRE><TT>: PLOT# ( n -- )\r
+ 0 DO\r
+ [CHAR] - EMIT\r
+ LOOP CR\r
+;</TT></PRE>\r
+\r
+<PRE><TT>CR 9 PLOT# 37 PLOT#</TT></PRE>\r
+</UL>\r
+If you want to access the loop counter you can use the word I . Here is\r
+a simple word that dumps numbers and their associated ASCII characters.\r
+<UL>\r
+<PRE><TT>: .ASCII ( end start -- , dump characters )\r
+ DO\r
+ CR I . I EMIT\r
+ LOOP CR\r
+;</TT></PRE>\r
+\r
+<PRE><TT>80 64 .ASCII</TT></PRE>\r
+</UL>\r
+If you want to leave a DO LOOP before it finishes, you can use the word\r
+<B>LEAVE</B>. Enter:\r
+<UL>\r
+<PRE><TT>: TEST.LEAVE ( -- , show use of leave )\r
+ 100 0\r
+ DO\r
+ I . CR \ print loop index\r
+ I 20 > \ is I over 20\r
+ IF\r
+ LEAVE\r
+ THEN\r
+ LOOP\r
+;\r
+TEST.LEAVE \ will print 0 to 20</TT></PRE>\r
+</UL>\r
+Please consult the manual to learn about the following words <B>+LOOP</B>\r
+and <B>RETURN</B> . FIXME\r
+\r
+<P>Another useful looping construct is the <B>BEGIN WHILE REPEAT</B> loop.\r
+This allows you to make a test each time through the loop before you actually\r
+do something. The word WHILE will continue looping if the flag on the stack\r
+is True. Enter:\r
+<UL>\r
+<PRE><TT>: SUM.OF.N ( N -- SUM[N] , calculate sum of N integers )\r
+ 0 \ starting value of SUM\r
+ BEGIN\r
+ OVER 0> \ Is N greater than zero?\r
+ WHILE\r
+ OVER + \ add N to sum\r
+ SWAP 1- SWAP \ decrement N\r
+ REPEAT\r
+ SWAP DROP \ get rid on N\r
+;</TT></PRE>\r
+\r
+<PRE><TT>4 SUM.OF.N \ prints 10 ( 1+2+3+4 )</TT></PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A NAME="Problems - Loops"></A>Problems:</H3>\r
+1) Rewrite SUM.OF.N using a DO LOOP.\r
+\r
+<P>2) Rewrite SUM.OF.N using BEGIN UNTIL.\r
+\r
+<P>3) For bonus points, write SUM.OF.N without using any looping or conditional\r
+construct!\r
+\r
+<P><A HREF="#Answers to Problems">Answers to the problems</A> can be found\r
+at the end of this tutorial.\r
+<H2>\r
+<A NAME="Text Input and Output"></A>Text Input and Output</H2>\r
+You learned earlier how to do single character I/O. This section concentrates\r
+on using strings of characters. You can embed a text string in your program\r
+using S". Note that you must follow the S" by one space. The text string\r
+is terminated by an ending " .Enter:\r
+<UL>\r
+<PRE>: TEST S" Hello world!" ;\r
+TEST .S</PRE>\r
+</UL>\r
+Note that TEST leaves two numbers on the stack. The first number is the\r
+address of the first character. The second number is the number of characters\r
+in the string. You can print the characters of the string as follows.\r
+<UL>\r
+<PRE>TEST DROP \ get rid of number of characters\r
+DUP C@ EMIT \ prints first character, 'H'\r
+CHAR+ DUP C@ EMIT \ prints second character, 'e'\r
+\ and so on</PRE>\r
+</UL>\r
+CHAR+ advances the address to the next character. You can print the entire\r
+string using TYPE.\r
+<UL>\r
+<PRE>TEST TYPE\r
+TEST 2/ TYPE \ print half of string</PRE>\r
+</UL>\r
+It would be nice if we could simply use a single address to describe a\r
+string and not have to pass the number of characters around. 'C' does this\r
+by putting a zero at the end of the string to show when it ends. Forth\r
+has a different solution. A text string in Forth consists of a character\r
+count in the first byte, followed immediately by the characters themselves.\r
+This type of character string can be created using the Forth word C" ,\r
+pronounced 'c quote'. Enter:\r
+<UL>\r
+<PRE><TT>: T2 C" Greetings Fred" ;\r
+T2 .</TT></PRE>\r
+</UL>\r
+The number that was printed was the address of the start of the string.\r
+It should be a byte that contains the number of characters. Now enter:\r
+<UL>\r
+<PRE><TT>T2 C@ .</TT></PRE>\r
+</UL>\r
+You should see a 14 printed. Remember that C@ fetches one character/byte\r
+at the address on the stack. You can convert a counted Forth string to\r
+an address and count using COUNT.\r
+<UL>\r
+<PRE><TT>T2 COUNT .S\r
+TYPE</TT></PRE>\r
+</UL>\r
+The word <B>COUNT</B> extracts the number of characters and their starting\r
+address. COUNT will only work with strings of less than 256 characters,\r
+since 255 is the largest number that can be stored in the count byte. TYPE\r
+will, however, work with longer strings since the length is on the stack.\r
+Their stack diagrams follow:\r
+\r
+<P><B><TT>CHAR+ ( address -- address' , add the size of one character )</TT></B>\r
+\r
+<P><B><TT>COUNT ( $addr -- addr #bytes , extract string information ) </TT></B>\r
+\r
+<P><B><TT>TYPE ( addr #bytes -- , output characters at addr )</TT></B>\r
+\r
+<P>The $addr is the address of a count byte. The dollar sign is often used\r
+to mark words that relate to strings.\r
+\r
+<P>You can easily input a string using the word <B>ACCEPT</B>. (You may\r
+want to put these upcoming examples in a file since they are very handy.)\r
+The word <B>ACCEPT </B>receives characters from the keyboard and places\r
+them at any specified address. <B>ACCEPT </B>takes input characters until\r
+a maximum is reached or an end of line character is entered. <B>ACCEPT\r
+</B>returns the number of characters entered. You can write a word for\r
+entering text. Enter:\r
+<UL>\r
+<PRE><TT>: INPUT$ ( -- $addr )\r
+ PAD 1+ ( leave room for byte count )\r
+ 127 ACCEPT ( recieve a maximum of 127 chars )\r
+ PAD C! ( set byte count )\r
+ PAD ( return address of string )\r
+;</TT></PRE>\r
+\r
+<PRE><TT>INPUT$ COUNT TYPE</TT></PRE>\r
+</UL>\r
+Enter a string which should then be echoed. You could use this in a program\r
+that writes form letters.\r
+<UL>\r
+<PRE><TT>: FORM.LETTER ( -- )\r
+ ." Enter customer's name." CR\r
+ INPUT$\r
+ CR ." Dear " DUP COUNT TYPE CR\r
+ ." Your cup that says " COUNT TYPE\r
+ ." is in the mail!" CR\r
+;</TT></PRE>\r
+</UL>\r
+<B><TT>ACCEPT ( addr maxbytes -- numbytes , input text, save at address\r
+) </TT></B>\r
+\r
+<P>You can use your word INPUT$ to write a word that will read a number\r
+from the keyboard. Enter:\r
+<UL>\r
+<PRE><TT>: INPUT# ( -- N true | false )\r
+ INPUT$ ( get string )\r
+ NUMBER? ( convert to a string if valid )\r
+ IF DROP TRUE ( get rid of high cell )\r
+ ELSE FALSE\r
+ THEN\r
+;</TT></PRE>\r
+</UL>\r
+This word will return a single-precision number and a TRUE, or it will\r
+just return FALSE. The word <B>NUMBER?</B> returns a double precision number\r
+if the input string contains a valid number. Double precision numbers are\r
+64-bit so we DROP the top 32 bits to get a single-precision 32 bit number.\r
+<H2>\r
+<A NAME="Changing Numeric Base"></A>Changing Numeric Base</H2>\r
+Our numbering system is decimal, or "base 10." This means that a number\r
+like 527 is equal to (5*100 + 2*10 + 7*1). The use of 10 for the numeric\r
+base is a completely arbitrary decision. It no doubt has something to do\r
+with the fact that most people have 10 fingers (including thumbs). The\r
+Babylonians used base 60, which is where we got saddled with the concept\r
+of 60 minutes in an hour. Computer hardware uses base 2, or "binary". A\r
+computer number like 1101 is equal to (1*8 + 1*4 + 0*2 + 1*1). If you add\r
+these up, you get 8+4+1=13 . A 10 in binary is (1*2 + 0*1), or 2. Likewise\r
+10 in any base N is N .\r
+\r
+<P>Forth makes it very easy to explore different numeric bases because\r
+it can work in any base. Try entering the following:\r
+<UL>\r
+<PRE><TT>DECIMAL 6 BINARY .\r
+1 1 + .\r
+1101 DECIMAL .</TT></PRE>\r
+</UL>\r
+Another useful numeric base is <I>hexadecimal</I>. which is base 16. One\r
+problem with bases over 10 is that our normal numbering system only has\r
+digits 0 to 9. For hex numbers we use the letters A to F for the digits\r
+10 to 15. Thus the hex number 3E7 is equal to (3*256 + 14*16 + 7*1). Try\r
+entering:\r
+<UL>\r
+<PRE><TT>DECIMAL 12 HEX . \ print C\r
+DECIMAL 12 256 * 7 16 * + 10 + .S\r
+DUP BINARY .\r
+HEX .</TT></PRE>\r
+</UL>\r
+A variable called <B>BASE</B> is used to keep track of the current numeric\r
+base. The words HEX , <B>DECIMAL</B> , and <B>BINARY</B> work by changing\r
+this variable. You can change the base to anything you want. Try:\r
+<UL>\r
+<PRE><TT>7 BASE !\r
+6 1 + .\r
+BASE @ . \ surprise!</TT></PRE>\r
+</UL>\r
+You are now in base 7 . When you fetched and printed the value of BASE,\r
+it said 10 because 7, in base 7, is 10.\r
+\r
+<P>PForth defines a word called .HEX that prints a number as hexadecimal\r
+regardless of the current base.\r
+<UL>\r
+<PRE>DECIMAL 14 .HEX</PRE>\r
+</UL>\r
+You could define a word like .HEX for any base. What is needed is a way\r
+to temporarily set the base while a number is printed, then restore it\r
+when we are through. Try the following word:\r
+<UL>\r
+<PRE><TT>: .BIN ( N -- , print N in Binary )\r
+ BASE @ ( save current base )\r
+ 2 BASE ! ( set to binary )\r
+ SWAP . ( print number )\r
+ BASE ! ( restore base )\r
+;</TT></PRE>\r
+\r
+<PRE><TT>DECIMAL\r
+22 .BIN\r
+22 .</TT></PRE>\r
+</UL>\r
+\r
+<H2>\r
+<A NAME="Answers to Problems"></A>Answers to Problems</H2>\r
+If your answer doesn't exactly match these but it works, don't fret. In\r
+Forth, there are usually many ways to the same thing.\r
+<H3>\r
+<A HREF="#Problems - Stack">Stack Manipulations</A></H3>\r
+\r
+<UL>\r
+<PRE><TT>1) SWAP DUP\r
+2) ROT DROP\r
+3) ROT DUP 3 PICK\r
+4) SWAP OVER 3 PICK\r
+5) -ROT 2DUP</TT></PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A HREF="#Problems - Square">Arithmetic</A></H3>\r
+\r
+<UL>\r
+<PRE>(12 * (20 - 17)) ==> <TT>20 17 - 12 *\r
+</TT>(1 - (4 * (-18) / 6)) ==> <TT>1 4 -18 * 6 / -\r
+</TT>(6 * 13) - (4 * 2 * 7) ==> <TT>6 13 * 4 2 * 7 * -</TT></PRE>\r
+\r
+<PRE><TT>: SQUARE ( N -- N*N ) \r
+ DUP *\r
+;</TT></PRE>\r
+\r
+<PRE><TT>: DIFF.SQUARES ( A B -- A*A-B*B )\r
+SWAP SQUARE \r
+SWAP SQUARE - \r
+;</TT></PRE>\r
+\r
+<PRE><TT>: AVERAGE4 ( A B C D -- [A+B+C+D]/4 )\r
+ + + + ( add'em up )\r
+ -2 ashift ( divide by four the fast way, or 4 / )\r
+;</TT></PRE>\r
+\r
+<DT>\r
+<TT>: HMS>SECONDS ( HOURS MINUTES SECONDS -- TOTAL-SECONDS )</TT></DT>\r
+\r
+<BR><TT> -ROT SWAP ( -- seconds minutes hours )</TT>\r
+<BR><TT> 60 * + ( -- seconds total-minutes )</TT>\r
+<BR><TT> 60 * + ( -- seconds )</TT>\r
+<BR><TT>; </TT></UL>\r
+\r
+<H3>\r
+<A HREF="#Problems - Logical">Logical Operators</A></H3>\r
+\r
+<UL>\r
+<PRE><TT>: LOWERCASE? ( CHAR -- FLAG , true if lowercase )\r
+ DUP 123 <\r
+ SWAP 96 > AND\r
+;</TT></PRE>\r
+</UL>\r
+\r
+<H3>\r
+<A HREF="#Problems - Conditionals">Conditionals</A></H3>\r
+\r
+<UL>\r
+<PRE><TT>: DEDUCT ( n -- , subtract from account )\r
+ ACCOUNT @ ( -- n acc \r
+ SWAP - DUP ACCOUNT ! ( -- acc' , update variable )\r
+ ." Balance = $" DUP . CR ( -- acc' )\r
+ 0< ( are we broke? )\r
+ IF ." Warning!! Your account is overdrawn!" CR\r
+ THEN\r
+;</TT></PRE>\r
+</UL>\r
+\r
+<H3>\r
+<TT><A HREF="#Problems - Loops">Loops</A></TT></H3>\r
+\r
+<UL>\r
+<PRE><TT>: SUM.OF.N.1 ( N -- SUM[N] )\r
+ 0 SWAP \ starting value of SUM\r
+ 1+ 0 \ set indices for DO LOOP\r
+ ?DO \ safer than DO if N=0\r
+ I +\r
+ LOOP\r
+;</TT></PRE>\r
+\r
+<PRE><TT>: SUM.OF.N.2 ( N -- SUM[N] )\r
+ 0 \ starting value of SUM\r
+ BEGIN ( -- N' SUM )\r
+ OVER +\r
+ SWAP 1- SWAP\r
+ OVER 0<\r
+ UNTIL\r
+ SWAP DROP\r
+;</TT></PRE>\r
+\r
+<PRE><TT>: SUM.OF.N.3 ( NUM -- SUM[N] , Gauss' method )\r
+ DUP 1+ \ SUM(N) = N*(N+1)/2\r
+ * 2/\r
+;</TT></PRE>\r
+</UL>\r
+Back to <A HREF="pforth.html">pForth Home Page</A>\r
+</BODY>\r
+</HTML>\r
--- /dev/null
+UNFINISHED\r
+\r
+Manual for pForth - a Portable Forth\r
+\r
+The best reference for pForth is an ANSI Forth manual. pForth\r
+is built on an ANSI model. There are, however, some non-standard\r
+words which are documented here:\r
+\r
+{ ( i*x -- , declare local variables )\r
+ Local variables are only usable within a colon definition.\r
+ They are taken from the stack as they are defined.\r
+ They are self fetching. Use -> to set them.\r
+ They help you avoid excessive stack dancing. \r
+ Here is an example:\r
+\r
+ : SUMSQ { aa bb -- }\r
+ aa aa *\r
+ bb bb * +\r
+ ;\r
+ 3 4 SUMSQ . ( prints 25 )\r
+\r
+ Here is an example of using a temporary variable:\r
+\r
+ : SUMN { num | sum -- , sum up integers the dumb way }\r
+ 0 -> sum \ uses -> to set local variable\r
+ num 0\r
+ DO i sum +\r
+ -> sum \ write current TOS to sum\r
+ LOOP\r
+ sum\r
+ ;\r
+\r
+:STRUCT ( <name> -- , defines a 'C' like structure )\r
+ See end of "c_struct.fth" for an example.\r
+\r
+ANEW ( <name> -- )\r
+ Forgets NAME if it is already defined.\r
+ Then defines NAME. Put at beginning of file\r
+ so that file can be INCLUDEd multiple times\r
+ without redefining the contents.\r
+\r
+CASE OF ENDOF ENDCASE in the typical fashion. See "case.fth"\r
+ \r
+CHOOSE ( range -- random , pick random number, 0...range-1 )\r
+\r
+IF ELSE THEN DO LOOP etc. can be used outside colon definitions!\r
+\r
+IF.FORGOTTEN ( <name> -- , executes NAME if forgotten )\r
+ Put this at the end of a file to automatically\r
+ call your cleanup word if the code is forgotten.\r
+\r
+INCLUDE ( <filename> -- , interpret from file )\r
+ Write your Forth programs in a file then load them\r
+ using INCLUDE.\r
+ \r
+ INCLUDE myprog.fth\r
+ \r
+INCLUDE? ( <name> <filename> -- , interpret from file if needed )\r
+ INCLUDE the given file only if the named word is undefined.\r
+ The name should be of a Forth word defined in the file.\r
+ See "load_pforth.fth" for an example.\r
+ \r
+ INCLUDE? DO.MY.PROG myprog.fth\r
+ \r
+MAP ( -- , dumps info about dictionary )\r
+\r
+Other words\r
+\r
+FP.INIT\r
+FP.TERM\r
+F>S\r
+S>F\r
+EXISTS?\r
+STRINGS= \r
+\r
+S@\r
+S!\r
+;STRUCT\r
+:STRUCT \r
+STRUCT\r
+ULONG\r
+RPTR\r
+APTR\r
+FLPT\r
+USHORT \r
+UBYTE\r
+LONG\r
+SHORT\r
+BYTE\r
+BYTES\r
+SIZEOF() \r
+OB.STATS?\r
+OB.STATS\r
+OB.FINDIT \r
+OB.MEMBER\r
+}UNION\r
+}UNION{\r
+UNION{\r
+OB.MAKE.MEMBER \r
+MAP\r
+.HEX \r
+.DEC\r
+.BIN\r
+ARRAY\r
+WARRAY\r
+BARRAY\r
+-2SORT \r
+2SORT\r
+WCHOOSE\r
+CHOOSE\r
+RANDOM\r
+RAND-SEED \r
+MSEC\r
+MSEC-DELAY\r
+VALUE\r
+-> \r
+TO\r
+\r
+-- strings --\r
+TEXTROM\r
+$ROM\r
+$APPEND.CHAR\r
+INDEX\r
+$MATCH?\r
+TEXT=?\r
+TEXT= \r
+$=\r
+COMPARE\r
+$ARRAY\r
+\r
+-- case --\r
+ENDCASE ENDOF RANGEOF (RANGEOF?) OF \r
+?OF CASE OF-DEPTH CASE-DEPTH \r
+\r
+TOLOWER\r
+@EXECUTE\r
+>NAME \r
+CLOSEST-XT\r
+CLOSEST-NFA\r
+TAB \r
+TAB-WIDTH\r
+.HX\r
+$\r
+CR?\r
+#COLS\r
+?PAUSE\r
+ABORT" \r
+WARNING"\r
+CELL*\r
+<< \r
+>>\r
+\r
+TASK-MISC1.FTH .R . (.) \r
+(NUMBER?) \r
+((NUMBER?)) NUM_TYPE_DOUBLE NUM_TYPE_SINGLE \r
+NUM_TYPE_BAD >NUMBER DIGIT\r
+ \r
+ANEW FORGET [FORGET] IF.FORGOTTEN \r
+\r
+SAVE-FORTH \r
+INCLUDE?\r
+RI\r
+INCLUDE \r
+$INCLUDE\r
+$APPEND\r
+LWORD\r
+PARSE\r
+PARSE-WORD \r
+PLACE\r
+\r
+WHAT'S\r
+IS\r
+DEFER\r
+\r
+>NEWLINE \r
+0SP\r
+SPACES\r
+SPACE\r
+RECURSE\r
+UNLOOP\r
+\r
+-- user stack --\r
+0USP \r
+US@ US> >US USTACK 0STACKP STACK@ \r
+STACK> >STACK :STACK\r
+\r
+-- address storage and translation --\r
+A, A@ A! \r
+IF.REL->USE IF.USE->REL\r
+X! X@ \r
+>ABS >REL REL->USE USE->REL \r
+BODY> >BODY N>LINK CODE> >CODE NAME> \r
+NAMEBASE+ CODEBASE NAMEBASE \r
+N>NEXTLINK >NAME\r
+PREVNAME NAME> \r
+\r
+\r
+ID. \r
+\r
+OFF ON\r
+TRACE-STACK\r
+TRACE-LEVEL \r
+TRACE-FLAGS\r
+\r
+HEADERS-BASE \r
+HEADERS-PTR\r
+ECHO\r
+CODE-BASE \r
+\r
+POP-SOURCE-ID\r
+PUSH-SOURCE-ID\r
+SOURCE-ID \r
+SET-SOURCE\r
+SOURCE\r
+\r
+LOADSYS\r
+\r
+FLUSHEMIT \r
+FINDNFA\r
+BYE\r
+BODY_OFFSET\r
+BAIL \r
+ARSHIFT\r
--- /dev/null
+\ @(#) filefind.fth 98/01/26 1.2
+\ FILE? ( <name> -- , 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
+;
+
--- /dev/null
+\ @(#) 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 ( <name> -- , create with float aligned data )
+ falign.create
+ CREATE
+;
+
+: FVARIABLE ( <name> -- ) ( 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-OUT-OF-RANGE>" 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-OUT-OF-RANGE>" 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-OUT-OF-RANGE>" 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-OUT-OF-RANGE>" 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]
--- /dev/null
+\ @(#) 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) ( <name> -- )
+ 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 ( <name> -- , 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] ( <name> -- , 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 ( <name> -- , 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 ( <name> -- , 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
+;
--- /dev/null
+bincmp -m10 pforth.dic pforth_mac.dic \r
--- /dev/null
+\ @(#) 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
+
--- /dev/null
+\ @(#) $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
+
+: { ( <local-declaration}> -- )
+ 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
+;
--- /dev/null
+\ @(#) 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
+;
--- /dev/null
+\ @(#) 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 ( <thing> -- 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? ( <member> -- offset #bytes )
+ ob.findit ob.stats
+;
+
+: SIZEOF() ( <struct>OR<class> -- #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 ( <name> -- , declare space for a byte )
+ -1 bytes ;
+
+: SHORT ( <name> -- , declare space for a 16 bit value )
+ -2 bytes ;
+
+: LONG ( <name> -- )
+ cell bytes ;
+
+: UBYTE ( <name> -- , declare space for signed byte )
+ 1 bytes ;
+
+: USHORT ( <name> -- , declare space for signed 16 bit value )
+ 2 bytes ;
+
+
+\ Aliases
+: APTR ( <name> -- ) long ;
+: RPTR ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001
+: ULONG ( <name> -- ) long ;
+
+: STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
+ [compile] sizeof() bytes
+;
--- /dev/null
+#!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
--- /dev/null
+\ @(#) 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 <message> -- , 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 <message> -- , 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
+;
+
+: $ ( <number> -- 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
+;
--- /dev/null
+\ @(#) 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 ( <name> -- , 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 ( <name> -- 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<<n )
+ dup 0<
+ IF negate arshift
+ ELSE lshift
+ THEN
+;
+
+
+variable rand-seed here rand-seed !
+: random ( -- random_number )
+ rand-seed @
+ 31421 * 6927 +
+ 65535 and dup rand-seed !
+;
+: choose ( range -- random_number , in range )
+ random * -16 shift
+;
+
+: wchoose ( hi lo -- random_number )
+ tuck - choose +
+;
+
+
+\ sort top two items on stack.
+: 2sort ( a b -- a<b | b<a , largest on top of stack)
+ 2dup >
+ 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
+;
+
--- /dev/null
+\ @(#) 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
+;
--- /dev/null
+# Microsoft Developer Studio Project File - Name="pForth" - Package Owner=<4>\r
+# Microsoft Developer Studio Generated Build File, Format Version 5.00\r
+# ** DO NOT EDIT **\r
+\r
+# TARGTYPE "Win32 (x86) Console Application" 0x0103\r
+\r
+CFG=pForth - Win32 MakeDic\r
+!MESSAGE This is not a valid makefile. To build this project using NMAKE,\r
+!MESSAGE use the Export Makefile command and run\r
+!MESSAGE \r
+!MESSAGE NMAKE /f "pForth.mak".\r
+!MESSAGE \r
+!MESSAGE You can specify a configuration when running NMAKE\r
+!MESSAGE by defining the macro CFG on the command line. For example:\r
+!MESSAGE \r
+!MESSAGE NMAKE /f "pForth.mak" CFG="pForth - Win32 MakeDic"\r
+!MESSAGE \r
+!MESSAGE Possible choices for configuration are:\r
+!MESSAGE \r
+!MESSAGE "pForth - Win32 Release" (based on "Win32 (x86) Console Application")\r
+!MESSAGE "pForth - Win32 Debug" (based on "Win32 (x86) Console Application")\r
+!MESSAGE "pForth - Win32 MakeDic" (based on "Win32 (x86) Console Application")\r
+!MESSAGE \r
+\r
+# Begin Project\r
+# PROP Scc_ProjName ""\r
+# PROP Scc_LocalPath ""\r
+CPP=cl.exe\r
+RSC=rc.exe\r
+\r
+!IF "$(CFG)" == "pForth - Win32 Release"\r
+\r
+# PROP BASE Use_MFC 0\r
+# PROP BASE Use_Debug_Libraries 0\r
+# PROP BASE Output_Dir "Release"\r
+# PROP BASE Intermediate_Dir "Release"\r
+# PROP BASE Target_Dir ""\r
+# PROP Use_MFC 0\r
+# PROP Use_Debug_Libraries 0\r
+# PROP Output_Dir "Release"\r
+# PROP Intermediate_Dir "Release"\r
+# PROP Ignore_Export_Lib 0\r
+# PROP Target_Dir ""\r
+# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c\r
+# ADD CPP /nologo /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c\r
+# ADD BASE RSC /l 0x409 /d "NDEBUG"\r
+# ADD RSC /l 0x409 /d "NDEBUG"\r
+BSC32=bscmake.exe\r
+# ADD BASE BSC32 /nologo\r
+# ADD BSC32 /nologo\r
+LINK32=link.exe\r
+# 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\r
+# 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"\r
+\r
+!ELSEIF "$(CFG)" == "pForth - Win32 Debug"\r
+\r
+# PROP BASE Use_MFC 0\r
+# PROP BASE Use_Debug_Libraries 1\r
+# PROP BASE Output_Dir "Debug"\r
+# PROP BASE Intermediate_Dir "Debug"\r
+# PROP BASE Target_Dir ""\r
+# PROP Use_MFC 0\r
+# PROP Use_Debug_Libraries 1\r
+# PROP Output_Dir "Debug"\r
+# PROP Intermediate_Dir "Debug"\r
+# PROP Ignore_Export_Lib 0\r
+# PROP Target_Dir ""\r
+# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c\r
+# ADD CPP /nologo /W4 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c\r
+# ADD BASE RSC /l 0x409 /d "_DEBUG"\r
+# ADD RSC /l 0x409 /d "_DEBUG"\r
+BSC32=bscmake.exe\r
+# ADD BASE BSC32 /nologo\r
+# ADD BSC32 /nologo\r
+LINK32=link.exe\r
+# 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\r
+# 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\r
+\r
+!ELSEIF "$(CFG)" == "pForth - Win32 MakeDic"\r
+\r
+# PROP BASE Use_MFC 0\r
+# PROP BASE Use_Debug_Libraries 1\r
+# PROP BASE Output_Dir "pForth__"\r
+# PROP BASE Intermediate_Dir "pForth__"\r
+# PROP BASE Ignore_Export_Lib 0\r
+# PROP BASE Target_Dir ""\r
+# PROP Use_MFC 0\r
+# PROP Use_Debug_Libraries 1\r
+# PROP Output_Dir "pForth__"\r
+# PROP Intermediate_Dir "pForth__"\r
+# PROP Ignore_Export_Lib 0\r
+# PROP Target_Dir ""\r
+# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c\r
+# ADD CPP /nologo /W3 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c\r
+# ADD BASE RSC /l 0x409 /d "_DEBUG"\r
+# ADD RSC /l 0x409 /d "_DEBUG"\r
+BSC32=bscmake.exe\r
+# ADD BASE BSC32 /nologo\r
+# ADD BSC32 /nologo\r
+LINK32=link.exe\r
+# 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\r
+# 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\r
+\r
+!ENDIF \r
+\r
+# Begin Target\r
+\r
+# Name "pForth - Win32 Release"\r
+# Name "pForth - Win32 Debug"\r
+# Name "pForth - Win32 MakeDic"\r
+# Begin Group "Forth"\r
+\r
+# PROP Default_Filter ".fth, .j"\r
+# Begin Source File\r
+\r
+SOURCE=..\ansilocs.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\bench.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\c_struct.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\case.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\catch.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\condcomp.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\coretest.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\filefind.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\floats.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\forget.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\loadp4th.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\locals.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\math.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\member.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\misc1.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\misc2.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\numberio.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\private.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\quit.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\see.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\smart_if.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\strings.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\system.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\t_alloc.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\t_corex.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\t_locals.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\t_strings.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\t_tools.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\tester.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\trace.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\tut.fth\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\wordslik.fth\r
+# End Source File\r
+# End Group\r
+# Begin Group "docs"\r
+\r
+# PROP Default_Filter ".txt, .htm"\r
+# Begin Source File\r
+\r
+SOURCE=..\docs\pf_ref.htm\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\docs\pf_todo.txt\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\docs\pf_tut.htm\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\docs\pfmanual.txt\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\README.txt\r
+# End Source File\r
+# End Group\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_cglue.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_clib.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_core.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_inner.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_io.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_main.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_mem.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_save.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_text.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pf_words.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pfcompil.c\r
+# End Source File\r
+# Begin Source File\r
+\r
+SOURCE=..\csrc\pfcustom.c\r
+# End Source File\r
+# End Target\r
+# End Project\r
--- /dev/null
+Microsoft Developer Studio Workspace File, Format Version 5.00\r
+# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!\r
+\r
+###############################################################################\r
+\r
+Project: "pForth"=.\pForth.dsp - Package Owner=<4>\r
+\r
+Package=<5>\r
+{{{\r
+}}}\r
+\r
+Package=<4>\r
+{{{\r
+}}}\r
+\r
+###############################################################################\r
+\r
+Global:\r
+\r
+Package=<5>\r
+{{{\r
+}}}\r
+\r
+Package=<3>\r
+{{{\r
+}}}\r
+\r
+###############################################################################\r
+\r
--- /dev/null
+--------------------Configuration: pForth - Win32 Release--------------------\r
+Begining build with project "E:\nomad\pForth\pcbuild\pForth.dsp", at root.\r
+Active configuration is Win32 (x86) Console Application (based on Win32 (x86) Console Application)\r
+\r
+Project's tools are:\r
+ "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 "\r
+ "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" "\r
+ "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" "\r
+ "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" "\r
+ "Custom Build" with flags ""\r
+ "<Component 0xa>" with flags ""\r
+\r
+Creating temp file "C:\WINDOWS\TEMP\RSP62A2.TMP" with contents </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 \r
+"E:\nomad\pForth\csrc\pf_cglue.c"\r
+"E:\nomad\pForth\csrc\pf_clib.c"\r
+"E:\nomad\pForth\csrc\pf_core.c"\r
+"E:\nomad\pForth\csrc\pf_inner.c"\r
+"E:\nomad\pForth\csrc\pf_io.c"\r
+"E:\nomad\pForth\csrc\pf_main.c"\r
+"E:\nomad\pForth\csrc\pf_mem.c"\r
+"E:\nomad\pForth\csrc\pf_save.c"\r
+"E:\nomad\pForth\csrc\pf_text.c"\r
+"E:\nomad\pForth\csrc\pf_words.c"\r
+"E:\nomad\pForth\csrc\pfcompil.c"\r
+"E:\nomad\pForth\csrc\pfcustom.c"\r
+>\r
+Creating command line "cl.exe @C:\WINDOWS\TEMP\RSP62A2.TMP" \r
+Creating temp file "C:\WINDOWS\TEMP\RSP62A3.TMP" with contents <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" \r
+.\Release\pf_cglue.obj\r
+.\Release\pf_clib.obj\r
+.\Release\pf_core.obj\r
+.\Release\pf_inner.obj\r
+.\Release\pf_io.obj\r
+.\Release\pf_main.obj\r
+.\Release\pf_mem.obj\r
+.\Release\pf_save.obj\r
+.\Release\pf_text.obj\r
+.\Release\pf_words.obj\r
+.\Release\pfcompil.obj\r
+.\Release\pfcustom.obj>\r
+Creating command line "link.exe @C:\WINDOWS\TEMP\RSP62A3.TMP" \r
+Compiling...\r
+pf_cglue.c\r
+pf_clib.c\r
+pf_core.c\r
+pf_inner.c\r
+pf_io.c\r
+pf_main.c\r
+pf_mem.c\r
+pf_save.c\r
+pf_text.c\r
+pf_words.c\r
+pfcompil.c\r
+pfcustom.c\r
+Linking...\r
+\r
+\r
+\r
+pForth.exe - 0 error(s), 0 warning(s)\r
--- /dev/null
+\ @(#) 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 !
+;
--- /dev/null
+\ @(#) 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 ( <name> -- )
+ 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
+;
--- /dev/null
+\ @(#) see.fth 98/01/26 1.4
+\ SEE ( <name> -- , 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 ( <name> -- , 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]
--- /dev/null
+\ #! /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
+;
--- /dev/null
+\ #! /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
+;
--- /dev/null
+\ @(#) 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
--- /dev/null
+\ @(#) 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 ( <name> -- )
+ DOES> ( index -- $string ) ($rom)
+;
+
+: TEXTROM ( packed array of strings, unalterable )
+ CREATE ( <name> -- )
+ DOES> ( index -- address count ) ($rom) count
+;
+
+\ -----------------------------------------------
--- /dev/null
+: 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. )
+
+: \ ( <line> -- , 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] ( <name> -- , 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 ( <name> -- , 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 ( -- addr ) here ;
+: <RESOLVE ( addr -- ) here - , ;
+
+: ?COMP ( -- , error if not compiling )
+ state @ 0= err_executing ?error
+;
+: ?PAIRS ( n m -- )
+ - err_pairs ?error
+;
+\ conditional primitives
+: IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate
+: THEN ( f orig -- ) swap ?condition >resolve ; immediate
+: BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate
+: AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate
+: UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate
+: AHEAD ( -- f orig ) compile branch 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
+
+: ['] ( <name> -- xt , define compile time tick )
+ ?comp ' [compile] literal
+; immediate
+
+\ for example:
+\ compile time: compile create , (does>) then ;
+\ execution time: create <name>, ',' 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 ( <name> -- )
+ CREATE 0 , \ IMMEDIATE
+\ DOES> [compile] aliteral \ %Q This could be optimised
+;
+
+: 2VARIABLE ( <name> -c- ) ( -x- addr )
+ create 0 , 0 ,
+;
+
+: CONSTANT ( n <name> -c- ) ( -x- n )
+ CREATE , ( n -- )
+ DOES> @ ( -- n )
+;\r
+
+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\r
+
+: 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 <name> -- , 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 ( <name> -- 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> -- char , state smart )
+ bl parse drop c@
+ state @
+ IF [compile] literal
+ THEN
+; immediate
+
+: CHAR ( <char> -- char , interpret mode )
+ bl parse drop c@
+;
+
+: [CHAR] ( <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 ",
+;
+
+: .( ( <string> -- , type string delimited by parentheses )
+ [CHAR] ) PARSE TYPE
+; IMMEDIATE
+
+: ." ( <string> -- , type string )
+ state @
+ IF compile (.") ,"
+ ELSE [char] " parse type
+ THEN
+; immediate
+
+
+: .' ( <string> -- , type string delimited by single quote )
+ state @
+ IF compile (.") [char] ' parse ",
+ ELSE [char] ' parse type
+ THEN
+; immediate
+
+: C" ( <string> -- addr , return string address, ANSI )
+ state @
+ IF compile (c") ,"
+ ELSE [char] " parse pad place pad
+ THEN
+; immediate
+
+: S" ( <string> -- , -- addr , return string address, ANSI )
+ state @
+ IF compile (s") ,"
+ ELSE [char] " parse pad place pad count
+ THEN
+; immediate
+
+: " ( <string> -- , -- addr , return string address )
+ [compile] C"
+; immediate
+: P" ( <string> -- , -- addr , return string address )
+ [compile] C"
+; immediate
+
+: "" ( <string> -- 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 ( <fname> -- )
+ BL lword
+ dup include-save-name $move \ save for RI
+ $include
+;
+
+: RI ( -- , ReInclude previous file as a convenience )
+ include-save-name $include
+;
+
+: INCLUDE? ( <word> <file> -- , 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
--- /dev/null
+\ @(#) 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
+
--- /dev/null
+\ @(#) 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? ( <name> -- 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 <string>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
+
--- /dev/null
+\ @(#) 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 ;\r
+
+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
+
--- /dev/null
+\ @(#) 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
+
--- /dev/null
+\ @(#) 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
--- /dev/null
+\ @(#) 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
+;
--- /dev/null
+\ 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 ;
+
--- /dev/null
+\ @(#) trace.fth 98/01/28 1.2
+\ TRACE ( <name> -- , trace pForth word )
+\
+\ Single step debugger.
+\ 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 )
+\
+\ 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 <name> -- 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
+;
+\r
+defer trace.user ( IP -- stop? )\r
+' 0= is trace.user\r
+
+: gd { more_levels | stop_level -- }\r
+ here what's trace.user u< \ has it been forgotten?\r
+ IF\r
+ ." Resetting TRACE.USER !!!" cr\r
+ ['] 0= is trace.user\r
+ THEN\r
+
+ 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\r
+ trace_ip trace.user \ call deferred user word\r
+ dup \ leave flag for UNTIL\r
+ IF\r
+ ." TRACE.USER returned " dup . ." so stopping execution." cr\r
+ ELSE
+ trace_ip trace.next -> trace_ip
+ trace_level stop_level > not\r
+ THEN
+ UNTIL
+ THEN
+;
+
+: g ( -- , execute until end of word )
+ 0 gd
+;
+
+: TRACE.HELP ( -- )
+ ." TRACE ( i*x <name> -- , 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> . ;\r
+
+[THEN]
--- /dev/null
+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
+
--- /dev/null
+\ @(#) 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 ( <filename> -- )
+ bl word
+ ." Save cloned image in " dup count type
+ drop ." SAVE-CLONE unimplemented!" \ %Q
+;
+
+: CLONE ( <name> -- )
+ ' '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
+
--- /dev/null
+\ @(#) 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 <name> -- , 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
--- /dev/null
+\ 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 .
--- /dev/null
+\ @(#) 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
--- /dev/null
+\ @(#) 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
--- /dev/null
+\ @(#) trace.fth 98/01/08 1.1
+\ TRACE ( <name> -- , trace pForth word )
+\
+\ Single step debugger.
+\ 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 )
+\
+\ 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 <name> -- 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 <name> -- , 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]
--- /dev/null
+\ @(#) wordslik.fth 98/01/26 1.2
+\
+\ WORDS.LIKE ( <string> -- , 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 ( <name> -- , 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
+;
projects / debian / pforth / commitdiff