From: Bdale Garbee Date: Thu, 5 Jun 2008 23:31:28 +0000 (-0600) Subject: Imported Upstream version 21 X-Git-Tag: upstream/21^0 X-Git-Url: https://git.gag.com/?p=debian%2Fpforth;a=commitdiff_plain;h=996b4376343ecb0c7bb1be4d86ab5314806697e6 Imported Upstream version 21 --- 996b4376343ecb0c7bb1be4d86ab5314806697e6 diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..40a3fc3 --- /dev/null +++ b/Makefile @@ -0,0 +1,87 @@ +# @(#) rlsMakefile 97/12/10 1.1 +# makefile for pForth +# Portable Forth written in 'C' +# Phil Burk + +.SUFFIXES: .c .o + +# Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG +# See "docs/pf_ref.htm" file for more info. + +SOURCEDIR = csrc +OBJECTDIR = objects +EMBOBJECTDIR = embobjects + +FULL_WARNINGS = -O2 \ + -fsigned-char \ + -fno-builtin \ + -fno-unroll-loops \ + -fpeephole \ + -fno-keep-inline-functions \ + -x c++ \ + -Wcast-qual \ + -Wall \ + -Wwrite-strings \ + -Winline \ + -Wmissing-prototypes \ + -Wmissing-declarations + +CCOPTS = -DPF_SUPPORT_FP $(FULL_WARNINGS) +COMPILER = gcc + +EMBCCOPTS = -DPF_NO_INIT -DPF_NO_MALLOC -DPF_NO_FILEIO \ + -DPF_NO_CLIB -DPF_STATIC_DIC + +####################################### +# Build file lists from wildcards. +PFITEMP = ${wildcard ${SOURCEDIR}/*.h} +PFINCLUDES = ${PFITEMP:${SOURCEDIR}/pfdicdat.h=} +PFSOURCE = ${wildcard ${SOURCEDIR}/*.c} +PFTEMP = ${PFSOURCE:%.c=%.o} +PFOBJS = ${PFTEMP:${SOURCEDIR}/%=${OBJECTDIR}/%} +PFEMBOBJS = ${PFTEMP:${SOURCEDIR}/%=${EMBOBJECTDIR}/%} + +COMPILE = $(COMPILER) $(CCOPTS) $(CDEFS) + +${OBJECTDIR}/%.o: $(PFINCLUDES) ${SOURCEDIR}/%.c + $(COMPILE) -O -o ${OBJECTDIR}/$*.o -c ${SOURCEDIR}/$*.c + +${EMBOBJECTDIR}/%.o: $(PFINCLUDES) ${SOURCEDIR}/%.c ${SOURCEDIR}/pfdicdat.h + $(COMPILE) -O -o ${EMBOBJECTDIR}/$*.o -c ${SOURCEDIR}/$*.c $(EMBCCOPTS) + +all: pforth pforth.dic + +pffiles: + echo "ITEMP FILES -----------------" + echo ${PFITEMP} + echo "INCLUDE FILES -----------------" + echo ${PFINCLUDES} + echo "'C' FILES ---------------------" + echo ${PFSOURCE} + echo "OBJECT FILES ------------------" + echo ${PFOBJS} + echo "EMBEDDED OBJECT FILES ------------------" + echo ${PFEMBOBJS} + +# build pforth by compiling 'C' source +pforth: $(PFINCLUDES) $(PFOBJS) + $(COMPILER) $(PFOBJS) -lm -o pforth + +# build basic dictionary by running newly built pforth and including system.fth +pforth.dic: pforth + pforth -i system.fth + +${SOURCEDIR}/pfdicdat.h: pforth pforth.dic + @(echo 'INCLUDE utils/savedicd.fth'; \ + echo 'SDAD'; \ + echo 'bye') | \ + pforth -dpforth.dic + cp pfdicdat.h ${SOURCEDIR} + + +pfemb: $(PFINCLUDES) $(PFEMBOBJS) + $(COMPILER) $(PFEMBOBJS) -lm -o pfemb + +clean: + rm -f $(PFOBJS) $(PFEMBOBJS) pforth *.dic core ${SOURCEDIR}/pfdicdat.h pfemb + diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..b37e94f --- /dev/null +++ b/README.txt @@ -0,0 +1,291 @@ +README for pForth - a Portable ANS-like Forth written in ANSI 'C' + +by Phil Burk +with Larry Polansky, David Rosenboom and Darren Gibbs. + +Last updated: 4/6/98 V19 + +Please direct feedback, bug reports, and suggestions to: + + philburk@softsynth.com. + + +The author is available for customization of pForth, porting to new + +platforms, or developing pForth applications on a contractual basis. + +If interested, contact Phil Burk at philburk@softsynth.com. + + + +-- LEGAL NOTICE ----------------------------------------- + +The pForth software code is dedicated to the public domain, +and any third party may reproduce, distribute and modify +the pForth software code or any derivative works thereof +without any compensation or license. The pForth software +code is provided on an "as is" basis without any warranty +of any kind, including, without limitation, the implied +warranties of merchantability and fitness for a particular +purpose and their equivalents under the laws of any jurisdiction. + +-- How to run PForth ------------------------------------ + + +Note: Please refer to "pf_ref.htm" for more complete information. + + +Once you have compiled and built the dictionary, just enter: + pforth + + +To compile source code files use: INCLUDE filename + +To create a custom dictionary enter in pForth: + c" newfilename.dic" SAVE-FORTH +The name must end in ".dic". + +To run PForth with the new dictionary enter in the shell: + pforth -dnewfilename.dic + +To run PForth and automatically include a forth file: + pforth myprogram.fth + +-- How to run PForth ------------------------------------ + +You can test the Forth without loading a dictionary +which might be necessary if the dictionary can't be built. + + +Enter: pforth -i +In pForth, enter: 3 4 + . +In pForth, enter: loadsys +In pForth, enter: 10 0 do i . loop + +PForth comes with a small test suite. To test the Core words, +you can use the coretest developed by John Hayes. + +Enter: pforth +Enter: include tester.fth +Enter: include coretest.fth + +To run the other tests, enter: + + pforth t_corex.fth + pforth t_strings.fth + pforth t_locals.fth + pforth t_alloc.fth + +They will report the number of tests that pass or fail. + +-- Version History -------------------------------------- + +V1 - 5/94 + - built pForth from various Forths including HMSL + +V2 - 8/94 + - made improvements necessary for use with M2 Verilog testing + +V3 - 3/1/95 + - Added support for embedded systems: PF_NO_FILEIO + and PF_NO_MALLOC. + - Fixed bug in dictionary loader that treated HERE as name relative. + +V4 - 3/6/95 + - Added smart conditionals to allow IF THEN DO LOOP etc. + outside colon definitions. + - Fixed RSHIFT, made logical. + - Added ARSHIFT for arithmetic shift. + - Added proper M* + - Added <> U> U< + - Added FM/MOD SM/REM /MOD MOD */ */MOD + - Added +LOOP EVALUATE UNLOOP EXIT + - Everything passes "coretest.fth" except UM/MOD FIND and WORD + +V5 - 3/9/95 + - Added pfReportError() + - Fixed problem with NumPrimitives growing and breaking dictionaries + - Reduced size of saved dictionaries, 198K -> 28K in one instance + - Funnel all terminal I/O through ioKey() and ioEmit() + - Removed dependencies on printf() except for debugging + +V6 - 3/16/95 + - Added floating point + - Changed NUMBER? to return a numeric type + - Support double number entry, eg. 234. -> 234 0 + +V7 - 4/12/95 + - Converted to 3DO Teamware environment + - Added conditional compiler [IF] [ELSE] [THEN], use like #if + - Fixed W->S B->S for positive values + - Fixed ALLOCATE FREE validation. Was failing on some 'C' compilers. + - Added FILE-SIZE + - Fixed ERASE, now fills with zero instead of BL + +V8 - 5/1/95 + - Report line number and line dump when INCLUDE aborts + - Abort if stack depth changes in colon definition. Helps + detect unbalanced conditionals (IF without THEN). + - Print bytes added by include. Helps determine current file. + - Added RETURN-CODE which is returned to caller, eg. UNIX shell. + - Changed Header and Code sizes to 60000 and 150000 + - Added check for overflowing dictionary when creating secondaries. + +V9 - 10/13/95 + - Cleaned up and documented for alpha release. + - Added EXISTS? + - compile floats.fth if F* exists + - got PF_NO_SHELL working + - added TURNKEY to build headerless dictionary apps + - improved release script and rlsMakefile + - added FS@ and FS! for FLPT structure members + +V10 - 3/21/96 + - Close nested source files when INCLUDE aborts. + - Add PF_NO_CLIB option to reduce OS dependencies. + - Add CREATE-FILE, fix R/W access mode for OPEN-FILE. + - Use PF_FLOAT instead of FLOAT to avoid DOS problem. + - Add PF_HOST_DOS for compilation control. + - Shorten all long file names to fit in the 8.3 format + required by some primitive operating systems. My + apologies to those with modern computers who suffer + as a result. ;-) + +V11 - 11/14/96 + - Added support for AUTO.INIT and AUTO.TERM. These are called + automagically when the Forth starts and quits. + - Change all int to int32. + - Changed DO LOOP to ?DO LOOP in ENDCASE and LV.MATCH + to fix hang when zero local variables. + - Align long word members in :STRUCT to avoid bus errors. + +V12 - 12/1/96 + - Advance pointers in pfCopyMemory() and pfSetMemory() + to fix PF_NO_CLIB build. + - Increase size of array for PF_NO_MALLOC + - Eliminate many warnings involving type casts and (const char *) + - Fix error recovery in dictionary creation. + - Conditionally eliminate some include files for embedded builds. + - Cleanup some test files. + +V13 - 12/15/96 + - Add "extern 'C' {" to pf_mem.h for C++ + - Separate PF_STATIC_DIC from PF_NO_FILEIO so that we can use a static + dictionary but also have file I/O. + - Added PF_USER_FILEIO, PF_USER_CHARIO, PF_USER_CLIB. + - INCLUDE now aborts if file not found. + - Add +-> which allows you to add to a local variable, like +! . + - VALUE now works properly as a self fetching constant. + - Add CODE-SIZE and HEADERS-SIZE which lets you resize + dictionary saved using SAVE-FORTH. + - Added FILE?. Enter "FILE? THEN" to see what files THEN is defined in. + - Fixed bug in local variables that caused problems if compilation + aborted in a word with local variables. + - Added SEE which "disassembles" Forth words. See "see.fth". + - Added PRIVATE{ which can be used to hide low level support + words. See "private.fth". + +V14 - 12/23/96 + * pforth command now requires -d before dictionary name. + Eg. pforth -dcustom.dic test.fth + * PF_USER_* now need to be defined as include file names. + * PF_USER_CHARIO now requires different functions to be defined. + See "csrc/pf_io.h". + - Moved pfDoForth() from pf_main.c to pf_core.c to simplify + file with main(). + - Fix build with PF_NO_INIT + - Makefile now has target for embedded dictionary, "gmake pfemb". + +V15 - 2/15/97 + * If you use PF_USER_FILEIO, you must now define PF_STDIN and PF_STDOUT + among other additions. See "pf_io.h". + * COMPARE now matches ANS STRING word set! + - Added PF_USER_INC1 and PF_USER_INC2 for optional includes + and host customization. See "pf_all.h". + - Fixed more warnings. + - Fixed >NAME and WORDS for systems with high "negative" addresses. + - Added WORDS.LIKE utility. Enter: WORDS.LIKE EMIT + - Added stack check after every word in high level interpreter. + Enter QUIT to enter high level interpreter which uses this feature. + - THROW will no longer crash if not using high level interpreter. + - Isolated all host dependencies into "pf_unix.h", "pf_win32.h", + "pf_mac.h", etc. See "pf_all.h". + - Added tests for CORE EXT, STRINGS words sets. + - Added SEARCH + - Fixed WHILE and REPEAT for multiple WHILEs. + - Fixed .( ) for empty strings. + - Fixed FATAN2 which could not compile on some systems (Linux gcc). + +V16 + * Define PF_USER_CUSTOM if you are defining your own custom + 'C' glue routines. This will ifndef the published example. + - Fixed warning in pf_cglue.c. + - Fixed SDAD in savedicd.fth. It used to generate bogus 'C' code + if called when (BASE != 10), as in HEX mode. + - Fixed address comparisons in forget.fth and private.fth for + addresses above 0x80000000. Must be unsigned. + - Call FREEZE at end of system.fth to initialize rfence. + - Fixed 0.0 F. which used to leave 0.0 on FP stack. + - Added FPICK ( n -- ) ( i*f -- i*f f[n] ) + - .S now prints hex numbers as unsigned. + - Fixed internal number to text conversion for unsigned nums. + +V17 + - Fixed input of large floats. 0.7071234567 F. used to fail. + +V18 + - Make FILL a 'C' primitive. + - optimized locals with (1_LOCAL@) + - optimized inner interpreter by 15% + - fix tester.fth failures + - Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined. + - Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition. + - Fixed saving and restoring of TIB when nesting include files. + +V19 4/98 + + - Warn if local var name matches dictionary, : foo { count -- } ; + - TO -> and +-> now parse input stream. No longer use to-flag. + - TO -> and +-> now give error if used with non-immediate word. + - Added (FLITERAL) support to SEE. + - Aded TRACE facility for single step debugging of Forth words. + - Added stub for ?TERMINAL and KEY? for embedded systems. + - Added PF_NO_GLOBAL_INIT for no reliance on global initialization. + - Added PF_USER_FLOAT for customization of FP support. + - Added floating point to string conversion words (F.) (FS.) (FE.) + For example: : F. (F.) TYPE SPACE ; + - Reversed order that values are placed on return stack in 2>R + so that it matches ANS standard. 2>R is now same as SWAP >R >R + Thank you Leo Wong for reporting this bug. + + - Added PF_USER_INIT and PF_USER_TERM for user definable init and term calls. + + - FIXED memory leak in pfDoForth() + +V20 + - Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash. + Thank you Michael Connor of Vancouver for reporting this bug. + + - Removed FDROP in REPRESENT to fix stack underflow after "0.0 F.". + Thank you Jim Rosenow of Minnesota for reporting this bug. + - Changed pfCharToLower to function to prevent macro expansion bugs under VXWORKS + Thank you Jim Rosenow of Minnesota for reporting this bug. + + - "0.0 F~" now checks actual binary encoding of floats. Before this it used to just + compare value which was incorrect. Now "0.0 -0.0 0.0 F~" returns FALSE. + + - Fixed definition of INPUT$ in tutorial. + Thank you Hampton Miller of California for reporting this bug. + + - Added support for producing a target dictionary with a different + Endian-ness than the host CPU. See PF_BIG_ENDIAN_DIC and PF_LITTLE_ENDIAN_DIC. + + - PForth kernel now comes up in a mode that uses BASE for numeric input when + started with "-i" option. It used to always consider numeric input as HEX. + Initial BASE is decimal. + +V21 + - Fixed some compiler warnings. + +Enjoy, +Phil Burk diff --git a/ansilocs.fth b/ansilocs.fth new file mode 100644 index 0000000..a32ee93 --- /dev/null +++ b/ansilocs.fth @@ -0,0 +1,196 @@ +\ @(#) ansilocs.fth 98/01/26 1.3 +\ local variable support words +\ These support the ANSI standard (LOCAL) and TO words. +\ +\ They are built from the following low level primitives written in 'C': +\ (local@) ( i+1 -- n , fetch from ith local variable ) +\ (local!) ( n i+1 -- , store to ith local variable ) +\ (local.entry) ( num -- , allocate stack frame for num local variables ) +\ (local.exit) ( -- , free local variable stack frame ) +\ local-compiler ( -- addr , variable containing CFA of locals compiler ) +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-ansilocs.fth + +private{ + +decimal +16 constant LV_MAX_VARS \ maximum number of local variables +31 constant LV_MAX_CHARS \ maximum number of letters in name + +lv_max_vars lv_max_chars $array LV-NAMES +variable LV-#NAMES \ number of names currently defined + +\ Search name table for match +: LV.MATCH ( $string -- index true | $string false ) + 0 swap + lv-#names @ 0 + ?DO i lv-names + over $= + IF 2drop true i LEAVE + THEN + LOOP swap +; + +: LV.COMPILE.FETCH ( index -- ) + 1+ \ adjust for optimised (local@), LocalsPtr points above vars + CASE + 1 OF compile (1_local@) ENDOF + 2 OF compile (2_local@) ENDOF + 3 OF compile (3_local@) ENDOF + 4 OF compile (4_local@) ENDOF + 5 OF compile (5_local@) ENDOF + 6 OF compile (6_local@) ENDOF + 7 OF compile (7_local@) ENDOF + 8 OF compile (8_local@) ENDOF + dup [compile] literal compile (local@) + ENDCASE +; + +: LV.COMPILE.STORE ( index -- ) + 1+ \ adjust for optimised (local!), LocalsPtr points above vars + CASE + 1 OF compile (1_local!) ENDOF + 2 OF compile (2_local!) ENDOF + 3 OF compile (3_local!) ENDOF + 4 OF compile (4_local!) ENDOF + 5 OF compile (5_local!) ENDOF + 6 OF compile (6_local!) ENDOF + 7 OF compile (7_local!) ENDOF + 8 OF compile (8_local!) ENDOF + dup [compile] literal compile (local!) + ENDCASE +; + +: LV.COMPILE.LOCAL ( $name -- handled? , check for matching locals name ) +\ ." LV.COMPILER.LOCAL name = " dup count type cr + lv.match + IF ( index ) + lv.compile.fetch + true + ELSE + drop false + THEN +; + +: LV.CLEANUP ( -- , restore stack frame on exit from colon def ) + lv-#names @ + IF + compile (local.exit) + THEN +; +: LV.FINISH ( -- , restore stack frame on exit from colon def ) + lv.cleanup + lv-#names off + local-compiler off +; + +: LV.SETUP ( -- ) + 0 lv-#names ! +; + +: LV.TERM + ." Locals turned off" cr + lv-#names off + local-compiler off +; + +if.forgotten lv.term + +}private + +: (LOCAL) ( adr len -- , ANSI local primitive ) + dup + IF + lv-#names @ lv_max_vars >= abort" Too many local variables!" + lv-#names @ lv-names place +\ Warn programmer if local variable matches an existing dictionary name. + lv-#names @ lv-names find nip + IF + ." (LOCAL) - Note: " + lv-#names @ lv-names count type + ." redefined as a local variable in " + latest id. cr + THEN + 1 lv-#names +! + ELSE +\ Last local. Finish building local stack frame. + 2drop + lv-#names @ [compile] literal compile (local.entry) + ['] lv.compile.local local-compiler ! + THEN +; + + +: VALUE + CREATE ( n ) + , + immediate + DOES> + state @ + IF + [compile] aliteral + compile @ + ELSE + @ + THEN +; + +: TO ( val -- ) + bl word + lv.match + IF ( -- index ) + lv.compile.store + ELSE + find + 1 = 0= abort" TO or -> before non-local or non-value" + >body \ point to data + state @ + IF \ compiling ( -- pfa ) + [compile] aliteral + compile ! + ELSE \ executing ( -- val pfa ) + ! + THEN + THEN +; immediate + +: -> ( -- ) [compile] to ; immediate + +: +-> ( val -- ) + bl word + lv.match + IF ( -- index ) + 1+ \ adjust for optimised (local!), LocalsPtr points above vars + [compile] literal compile (local+!) + ELSE + find + 1 = 0= abort" +-> before non-local or non-value" + >body \ point to data + state @ + IF \ compiling ( -- pfa ) + [compile] aliteral + compile +! + ELSE \ executing ( -- val pfa ) + +! + THEN + THEN +; immediate + +: : lv.setup : ; +: ; lv.finish [compile] ; ; immediate +: exit lv.cleanup compile exit ; immediate +: does> lv.finish [compile] does> ; immediate + +privatize diff --git a/bench.fth b/bench.fth new file mode 100644 index 0000000..cc594c2 --- /dev/null +++ b/bench.fth @@ -0,0 +1,190 @@ +\ @(#) bench.fth 97/12/10 1.1 +\ Benchmark Forth +\ by Phil Burk +\ 11/17/95 +\ +\ pForthV9 on Indy, compiled with gcc +\ bench1 took 15 seconds +\ bench2 took 16 seconds +\ bench3 took 17 seconds +\ bench4 took 17 seconds +\ bench5 took 19 seconds +\ sieve took 4 seconds +\ +\ HForth on Mac Quadra 800, 68040 +\ bench1 took 1.73 seconds +\ bench2 took 6.48 seconds +\ bench3 took 2.65 seconds +\ bench4 took 2.50 seconds +\ bench5 took 1.91 seconds +\ sieve took 0.45 seconds +\ +\ pForthV9 on Mac Quadra 800 +\ bench1 took 40 seconds +\ bench2 took 43 seconds +\ bench3 took 43 seconds +\ bench4 took 44 seconds +\ bench5 took 42 seconds +\ sieve took 20 seconds +\ +\ pForthV9 on PB5300, 100 MHz PPC 603 based Mac Powerbook +\ bench1 took 8.6 seconds +\ bench2 took 9.0 seconds +\ bench3 took 9.7 seconds +\ bench4 took 8.8 seconds +\ bench5 took 10.3 seconds +\ sieve took 2.3 seconds +\ +\ HForth on PB5300 +\ bench1 took 1.1 seconds +\ bench2 took 3.6 seconds +\ bench3 took 1.7 seconds +\ bench4 took 1.2 seconds +\ bench5 took 1.3 seconds +\ sieve took 0.2 seconds + +anew task-bench.fth + +decimal + +\ benchmark primitives +create #do 2000000 , + +: t1 #do @ 0 do loop ; +: t2 23 45 #do @ 0 do swap loop 2drop ; +: t3 23 #do @ 0 do dup drop loop drop ; +: t4 23 45 #do @ 0 do over drop loop 2drop ; +: t5 #do @ 0 do 23 45 + drop loop ; +: t6 23 #do @ 0 do >r r> loop drop ; +: t7 23 45 67 #do @ 0 do rot loop 2drop drop ; +: t8 #do @ 0 do 23 2* drop loop ; +: t9 #do @ 10 / 0 do 23 5 /mod 2drop loop ; +: t10 #do #do @ 0 do dup @ drop loop drop ; + +: foo ( noop ) ; +: t11 #do @ 0 do foo loop ; + +\ more complex benchmarks ----------------------- + +\ BENCH1 - sum data --------------------------------------- +create data1 23 , 45 , 67 , 89 , 111 , 222 , 333 , 444 , +: sum.cells ( addr num -- sum ) + 0 swap \ sum + 0 DO + over \ get address + i cells + @ + + LOOP + swap drop +; + +: bench1 ( -- ) + 200000 0 + DO + data1 8 sum.cells drop + LOOP +; + +\ BENCH2 - recursive factorial -------------------------- +: factorial ( n -- n! ) + dup 1 > + IF + dup 1- recurse * + ELSE + drop 1 + THEN +; + +: bench2 ( -- ) + 200000 0 + DO + 10 factorial drop + LOOP +; + +\ BENCH3 - DEFER ---------------------------------- +defer calc.answer +: answer ( n -- m ) + dup + + $ a5a5 xor + 1000 max +; +' answer is calc.answer +: bench3 + 1500000 0 + DO + i calc.answer drop + LOOP +; + +\ BENCH4 - locals --------------------------------- +: use.locals { x1 x2 | aa bb -- result } + x1 2* -> aa + x2 2/ -> bb + x1 aa * + x2 bb * + +; + +: bench4 + 400000 0 + DO + 234 567 use.locals drop + LOOP +; + +\ BENCH5 - string compare ------------------------------- +: match.strings { $s1 $s2 | adr1 len1 adr2 len2 -- flag } + $s1 count -> len1 -> adr1 + $s2 count -> len2 -> adr2 + len1 len2 - + IF + FALSE + ELSE + TRUE + len1 0 + DO + adr1 i + c@ + adr2 i + c@ - + IF + drop FALSE + leave + THEN + LOOP + THEN +; + +: bench5 ( -- ) + 60000 0 + DO + " This is a string. X foo" + " This is a string. Y foo" match.strings drop + LOOP +; + +\ SIEVE OF ERATOSTHENES from BYTE magazine ----------------------- + +DECIMAL 8190 CONSTANT TSIZE + +VARIABLE FLAGS TSIZE ALLOT + +: ( --- #primes ) FLAGS TSIZE 1 FILL + 0 TSIZE 0 + DO ( n ) I FLAGS + C@ + IF I DUP + 3 + DUP I + ( I2*+3 I3*+3 ) + BEGIN DUP TSIZE < ( same flag ) + WHILE 0 OVER FLAGS + C! ( i' i'' ) OVER + + REPEAT 2DROP 1+ + THEN + LOOP ; + +: SIEVE ." 10 iterations " CR 0 10 0 + DO swap drop + LOOP . ." primes " CR ; + +: SIEVE50 ." 50 iterations " CR 0 50 0 + DO swap drop + LOOP . ." primes " CR ; + +\ 10 iterations +\ 21.5 sec Amiga Multi-Forth Indirect Threaded +\ 8.82 sec Amiga 1000 running JForth +\ ~5 sec SGI Indy running pForthV9 diff --git a/bloop.fth b/bloop.fth new file mode 100644 index 0000000..e0024fe --- /dev/null +++ b/bloop.fth @@ -0,0 +1,34 @@ + + +: BLOOP ( n -- n' ) + 0 swap 0 + DO + i + + i 1 and + IF + dup dup 2 + + swap - drop + THEN + LOOP +; + + +\ ." START" cr +\ 8000000 bloop . +\ ." END" cr + + +: uselocs { aa bb -- } + aa bb + + aa bb - + - drop +; + +: BLOCS ( N -- ) + 0 DO i 77 uselocs LOOP +; + + +." START" cr +2000000 blocs +." END" cr diff --git a/c_struct.fth b/c_struct.fth new file mode 100644 index 0000000..86062d7 --- /dev/null +++ b/c_struct.fth @@ -0,0 +1,242 @@ +\ @(#) c_struct.fth 98/01/26 1.2 +\ STRUCTUREs are for interfacing with 'C' programs. +\ Structures are created using :STRUCT and ;STRUCT +\ +\ This file must be loaded before loading any .J files. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ MOD: PLB 1/16/87 Use abort" instead of er.report +\ MDH 4/14/87 Added sign-extend words to ..@ +\ MOD: PLB 9/1/87 Add pointer to last member for debug. +\ MOD: MDH 4/30/88 Use fast addressing for ..@ and ..! +\ MOD: PLB/MDH 9/30/88 Fixed offsets for 16@+long and 8@+long +\ fixed OB.COMPILE.+@/! for 0 offset +\ MOD: PLB 1/11/89 Added EVEN-UP in case of last member BYTE +\ MOD: RDG 9/19/90 Added floating point member support +\ MOD: PLB 12/21/90 Optimized ..@ and ..! +\ 00001 PLB 11/20/91 Make structures IMMEDIATE with ALITERAL for speed +\ Don't need MOVEQ.L #0,D0 for 16@+WORD and 8@+WORD +\ 00002 PLB 8/3/92 Added S@ and S!, and support for RPTR +\ 951112 PLB Added FS@ and FS! +\ This version for the pForth system. + +ANEW TASK-C_STRUCT + +decimal +\ STRUCT ====================================================== +: <:STRUCT> ( pfa -- , run time action for a structure) + [COMPILE] CREATE + @ even-up here swap dup ( -- here # # ) + allot ( make room for ivars ) + 0 fill ( initialize to zero ) +\ immediate \ 00001 +\ DOES> [compile] aliteral \ 00001 +; + +\ Contents of a structure definition. +\ CELL 0 = size of instantiated structures +\ CELL 1 = #bytes to last member name in dictionary. +\ this is relative so it will work with structure +\ relocation schemes like MODULE + +: :STRUCT ( -- , Create a 'C' structure ) +\ Check pairs + ob-state @ + warning" :STRUCT - Previous :STRUCT or :CLASS unfinished!" + ob_def_struct ob-state ! ( set pair flags ) +\ +\ Create new struct defining word. + CREATE + here ob-current-class ! ( set current ) + 0 , ( initial ivar offset ) + 0 , ( location for #byte to last ) + DOES> <:STRUCT> +; + +: ;STRUCT ( -- , terminate structure ) + ob-state @ ob_def_struct = NOT + abort" ;STRUCT - Missing :STRUCT above!" + false ob-state ! + +\ Point to last member. + latest ob-current-class @ body> >name - ( byte difference of NFAs ) + ob-current-class @ cell+ ! +\ +\ Even up byte offset in case last member was BYTE. + ob-current-class @ dup @ even-up swap ! +; + +\ Member reference words. +: .. ( object -- member_address , calc addr of member ) + ob.stats? drop state @ + IF ?dup + IF [compile] literal compile + + THEN + ELSE + + THEN +; immediate + + +: (S+C!) ( val addr offset -- ) + c! ; +: (S+W!) ( val addr offset -- ) + w! ; +: (S+!) ( val addr offset -- ) + ! ; +: (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ; + +: compile+!bytes ( offset size -- ) +\ ." compile+!bytes ( " over . dup . ." )" cr + swap [compile] literal \ compile offset into word + CASE + cell OF compile (s+!) ENDOF + 2 OF compile (s+w!) ENDOF + 1 OF compile (s+c!) ENDOF + -4 OF compile (s+rel!) ENDOF \ 00002 + -2 OF compile (s+w!) ENDOF + -1 OF compile (s+c!) ENDOF + true abort" s! - illegal size!" + ENDCASE +; + +: !BYTES ( value address size -- ) + CASE + cell OF ! ENDOF + -4 OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002 + ABS + 2 OF w! ENDOF + 1 OF c! ENDOF + true abort" s! - illegal size!" + ENDCASE +; + +\ These provide ways of setting and reading members values +\ without knowing their size in bytes. +: (S!) ( offset size -- , compile proper fetch ) + state @ + IF compile+!bytes + ELSE ( -- value addr off size ) + >r + r> !bytes + THEN +; +: S! ( value object -- , store value in member ) + ob.stats? + (s!) +; immediate + +: @BYTES ( addr +/-size -- value ) + CASE + cell OF @ ENDOF + 2 OF w@ ENDOF + 1 OF c@ ENDOF + -4 OF @ if.rel->use ENDOF \ 00002 + -2 OF w@ w->s ENDOF + -1 OF c@ b->s ENDOF + true abort" s@ - illegal size!" + ENDCASE +; + +: (S+UC@) ( addr offset -- val ) + c@ ; +: (S+UW@) ( addr offset -- val ) + w@ ; +: (S+@) ( addr offset -- val ) + @ ; +: (S+REL@) ( addr offset -- val ) + @ if.rel->use ; +: (S+C@) ( addr offset -- val ) + c@ b->s ; +: (S+W@) ( addr offset -- val ) + w@ w->s ; + +: compile+@bytes ( offset size -- ) +\ ." compile+@bytes ( " over . dup . ." )" cr + swap [compile] literal \ compile offset into word + CASE + cell OF compile (s+@) ENDOF + 2 OF compile (s+uw@) ENDOF + 1 OF compile (s+uc@) ENDOF + -4 OF compile (s+rel@) ENDOF \ 00002 + -2 OF compile (s+w@) ENDOF + -1 OF compile (s+c@) ENDOF + true abort" s@ - illegal size!" + ENDCASE +; + +: (S@) ( offset size -- , compile proper fetch ) + state @ + IF compile+@bytes + ELSE >r + r> @bytes + THEN +; + +: S@ ( object -- value , fetch value from member ) + ob.stats? + (s@) +; immediate + + + +exists? F* [IF] +\ 951112 Floating Point support +: FLPT ( -- , declare space for a floating point value. ) + 1 floats bytes +; +: (S+F!) ( val addr offset -- ) + f! ; +: (S+F@) ( addr offset -- val ) + f@ ; + +: FS! ( value object -- , fetch value from member ) + ob.stats? + 1 floats <> abort" FS@ with non-float!" + state @ + IF + [compile] literal + compile (s+f!) + ELSE (s+f!) + THEN +; immediate +: FS@ ( object -- value , fetch value from member ) + ob.stats? + 1 floats <> abort" FS@ with non-float!" + state @ + IF + [compile] literal + compile (s+f@) + ELSE (s+f@) + THEN +; immediate +[THEN] + +0 [IF] +:struct mapper + long map_l1 + long map_l2 + aptr map_a1 + rptr map_r1 + flpt map_f1 + short map_s1 + ushort map_s2 + byte map_b1 + ubyte map_b2 +;struct +mapper map1 + +: TT + -500 map1 s! map_s1 + map1 s@ map_s1 -500 - abort" map_s1 failed!" + -500 map1 s! map_s2 + map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!" + -89 map1 s! map_b1 + map1 s@ map_b1 -89 - abort" map_s1 failed!" + here map1 s! map_r1 + map1 s@ map_r1 here - abort" map_r1 failed!" + -89 map1 s! map_b2 + map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!" + 23.45 map1 fs! map_f1 + map1 fs@ map_f1 f. ." =?= 23.45" cr +; +." Testing c_struct.fth" cr +TT +[THEN] diff --git a/case.fth b/case.fth new file mode 100644 index 0000000..205e650 --- /dev/null +++ b/case.fth @@ -0,0 +1,75 @@ +\ @(#) case.fth 98/01/26 1.2 +\ CASE Statement +\ +\ This definition is based upon Wil Baden's assertion that +\ >MARK >RESOLVE ?BRANCH etc. are not needed if one has IF ELSE THEN etc. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ MOD: PLB 6/24/91 Check for missing ENDOF +\ MOD: PLB 8/7/91 Add ?OF and RANGEOF + +anew TASK-CASE + +variable CASE-DEPTH +variable OF-DEPTH + +: CASE ( n -- , start case statement ) ( -c- case-depth ) + ?comp case-depth @ case-depth off ( allow nesting ) + 0 of-depth ! +; IMMEDIATE + +: ?OF ( n flag -- | n , doit if true ) ( -c- addr ) + [compile] IF + compile drop + 1 case-depth +! + 1 of-depth +! +; IMMEDIATE + +: OF ( n t -- | n , doit if match ) ( -c- addr ) + ?comp + compile over compile = + [compile] ?OF +; IMMEDIATE + +: (RANGEOF?) ( n lo hi -- | n flag ) + >r over ( n lo n ) <= + IF + dup r> ( n n hi ) <= + ELSE + rdrop false + THEN +; + +: RANGEOF ( n lo hi -- | n , doit if within ) ( -c- addr ) + compile (rangeof?) + [compile] ?OF +; IMMEDIATE + +: ENDOF ( -- ) ( addr -c- addr' ) + [compile] ELSE + -1 of-depth +! +; IMMEDIATE + +: ENDCASE ( n -- ) ( old-case-depth addr' addr' ??? -- ) + of-depth @ + IF >newline ." Missing ENDOF in CASE!" cr abort + THEN +\ + compile drop + case-depth @ 0 + ?DO [compile] THEN + LOOP + case-depth ! +; IMMEDIATE + diff --git a/catch.fth b/catch.fth new file mode 100644 index 0000000..99698bb --- /dev/null +++ b/catch.fth @@ -0,0 +1,61 @@ +\ @(#) catch.fth 98/01/26 1.2 +\ Catch and Throw support +\ +\ Lifted from X3J14 dpANS-6 document. + +anew task-catch.fth + +variable CATCH-HANDLER +0 catch-handler ! + +: CATCH ( xt -- exception# | 0 ) + sp@ >r ( xt ) \ save data stack pointer + catch-handler @ >r ( xt ) \ save previous handler + rp@ catch-handler ! ( xt ) \ set current handler + execute ( ) \ execute returns if no throw + r> catch-handler ! ( ) \ restore previous handler + r> drop ( ) \ discard saved stack pointer + 0 ( ) \ normal completion +; + +: THROW ( ???? exception# -- ???? exception# ) + ?dup ( exc# ) \ 0 THROW is a no-op + IF + catch-handler @ + dup 0= + IF + ." THROW has noone to catch!" cr + quit + THEN + rp! ( exc# ) \ restore prev return stack + r> catch-handler ! ( exc# ) \ restore prev handler + r> swap >r ( saved-sp ) \ exc# on return stack + sp! drop r> ( exc# ) \ restore stack + THEN + \ return to caller of catch +; + + +: (ABORT) ERR_ABORT throw ; +defer old.abort +what's abort is old.abort +' (abort) is abort +: restore.abort what's old.abort is abort ; +if.forgotten restore.abort + +hex +: BAD.WORD -5 throw ; +: NAIVE.WORD ( -- ) + 7777 8888 23 . cr + bad.word + ." After bad word!" cr +; + +: CATCH.BAD ( -- ) + ['] naive.word catch . +; + +: CATCH.GOOD ( -- ) + 777 ['] . catch . cr +; +decimal diff --git a/checkit.fth b/checkit.fth new file mode 100644 index 0000000..a4ff1d7 --- /dev/null +++ b/checkit.fth @@ -0,0 +1,32 @@ +\ compare dictionaries + +anew comp +hex + +: checksum { start end -- sum } + 0 + end start + DO + i @ + + 4 +LOOP +; + +: findword { target start end -- } + end start + DO + i @ target = + IF + ." found at " i u. cr + i 16 dump + THEN + 4 +LOOP +; + +echo on +hex +$ 01500fc4 codebase here findword +codebase here cr .s checksum u. cr +namebase context @ cr .s checksum u. cr +decimal + +echo off diff --git a/condcomp.fth b/condcomp.fth new file mode 100644 index 0000000..b95b005 --- /dev/null +++ b/condcomp.fth @@ -0,0 +1,50 @@ +\ @(#) condcomp.fth 98/01/26 1.2 +\ Conditional Compilation support +\ +\ Words: STRINGS= [IF] [ELSE] [THEN] EXISTS? +\ +\ Lifted from X3J14 dpANS-6 document. + +anew task-condcomp.fth + +: [ELSE] ( -- ) + 1 + BEGIN \ level + BEGIN + BL WORD \ level $word + COUNT DUP \ level adr len len + WHILE \ level adr len + 2DUP S" [IF]" COMPARE 0= + IF \ level adr len + 2DROP 1+ \ level' + ELSE \ level adr len + 2DUP S" [ELSE]" + COMPARE 0= \ level adr len flag + IF \ level adr len + 2DROP 1- DUP IF 1+ THEN \ level' + ELSE \ level adr len + S" [THEN]" COMPARE 0= + IF + 1- \ level' + THEN + THEN + THEN + ?DUP 0= IF EXIT THEN \ level' + REPEAT 2DROP \ level + REFILL 0= UNTIL \ level + DROP +; IMMEDIATE + +: [IF] ( flag -- ) + 0= + IF POSTPONE [ELSE] + THEN +; IMMEDIATE + +: [THEN] ( -- ) +; IMMEDIATE + +: EXISTS? ( -- flag , true if defined ) + bl word find + swap drop +; immediate diff --git a/coretest.fth b/coretest.fth new file mode 100644 index 0000000..e5e1a94 --- /dev/null +++ b/coretest.fth @@ -0,0 +1,996 @@ +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING BASIC ASSUMPTIONS + +{ -> } \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> } +{ 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR ) +{ 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +{ -1 BITSSET? -> 0 0 } + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +{ 0 0 AND -> 0 } +{ 0 1 AND -> 0 } +{ 1 0 AND -> 0 } +{ 1 1 AND -> 1 } + +{ 0 INVERT 1 AND -> 1 } +{ 1 INVERT 1 AND -> 0 } + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +{ 0S INVERT -> 1S } +{ 1S INVERT -> 0S } + +{ 0S 0S AND -> 0S } +{ 0S 1S AND -> 0S } +{ 1S 0S AND -> 0S } +{ 1S 1S AND -> 1S } + +{ 0S 0S OR -> 0S } +{ 0S 1S OR -> 1S } +{ 1S 0S OR -> 1S } +{ 1S 1S OR -> 1S } + +{ 0S 0S XOR -> 0S } +{ 0S 1S XOR -> 1S } +{ 1S 0S XOR -> 1S } +{ 1S 1S XOR -> 0S } + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +{ MSB BITSSET? -> 0 0 } + +{ 0S 2* -> 0S } +{ 1 2* -> 2 } +{ 4000 2* -> 8000 } +{ 1S 2* 1 XOR -> 1S } +{ MSB 2* -> 0S } + +{ 0S 2/ -> 0S } +{ 1 2/ -> 0 } +{ 4000 2/ -> 2000 } +{ 1S 2/ -> 1S } \ MSB PROPOGATED +{ 1S 1 XOR 2/ -> 1S } +{ MSB 2/ MSB AND -> MSB } + +{ 1 0 LSHIFT -> 1 } +{ 1 1 LSHIFT -> 2 } +{ 1 2 LSHIFT -> 4 } +{ 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT +{ 1S 1 LSHIFT 1 XOR -> 1S } +{ MSB 1 LSHIFT -> 0 } + +{ 1 0 RSHIFT -> 1 } +{ 1 1 RSHIFT -> 0 } +{ 2 1 RSHIFT -> 1 } +{ 4 2 RSHIFT -> 1 } +{ 8000 F RSHIFT -> 1 } \ BIGGEST +{ MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS +{ MSB 1 RSHIFT 2* -> MSB } + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + +{ 0 0= -> } +{ 1 0= -> } +{ 2 0= -> } +{ -1 0= -> } +{ MAX-UINT 0= -> } +{ MIN-INT 0= -> } +{ MAX-INT 0= -> } + +{ 0 0 = -> } +{ 1 1 = -> } +{ -1 -1 = -> } +{ 1 0 = -> } +{ -1 0 = -> } +{ 0 1 = -> } +{ 0 -1 = -> } + +{ 0 0< -> } +{ -1 0< -> } +{ MIN-INT 0< -> } +{ 1 0< -> } +{ MAX-INT 0< -> } + +{ 0 1 < -> } +{ 1 2 < -> } +{ -1 0 < -> } +{ -1 1 < -> } +{ MIN-INT 0 < -> } +{ MIN-INT MAX-INT < -> } +{ 0 MAX-INT < -> } +{ 0 0 < -> } +{ 1 1 < -> } +{ 1 0 < -> } +{ 2 1 < -> } +{ 0 -1 < -> } +{ 1 -1 < -> } +{ 0 MIN-INT < -> } +{ MAX-INT MIN-INT < -> } +{ MAX-INT 0 < -> } + +{ 0 1 > -> } +{ 1 2 > -> } +{ -1 0 > -> } +{ -1 1 > -> } +{ MIN-INT 0 > -> } +{ MIN-INT MAX-INT > -> } +{ 0 MAX-INT > -> } +{ 0 0 > -> } +{ 1 1 > -> } +{ 1 0 > -> } +{ 2 1 > -> } +{ 0 -1 > -> } +{ 1 -1 > -> } +{ 0 MIN-INT > -> } +{ MAX-INT MIN-INT > -> } +{ MAX-INT 0 > -> } + +{ 0 1 U< -> } +{ 1 2 U< -> } +{ 0 MID-UINT U< -> } +{ 0 MAX-UINT U< -> } +{ MID-UINT MAX-UINT U< -> } +{ 0 0 U< -> } +{ 1 1 U< -> } +{ 1 0 U< -> } +{ 2 1 U< -> } +{ MID-UINT 0 U< -> } +{ MAX-UINT 0 U< -> } +{ MAX-UINT MID-UINT U< -> } + +{ 0 1 MIN -> 0 } +{ 1 2 MIN -> 1 } +{ -1 0 MIN -> -1 } +{ -1 1 MIN -> -1 } +{ MIN-INT 0 MIN -> MIN-INT } +{ MIN-INT MAX-INT MIN -> MIN-INT } +{ 0 MAX-INT MIN -> 0 } +{ 0 0 MIN -> 0 } +{ 1 1 MIN -> 1 } +{ 1 0 MIN -> 0 } +{ 2 1 MIN -> 1 } +{ 0 -1 MIN -> -1 } +{ 1 -1 MIN -> -1 } +{ 0 MIN-INT MIN -> MIN-INT } +{ MAX-INT MIN-INT MIN -> MIN-INT } +{ MAX-INT 0 MIN -> 0 } + +{ 0 1 MAX -> 1 } +{ 1 2 MAX -> 2 } +{ -1 0 MAX -> 0 } +{ -1 1 MAX -> 1 } +{ MIN-INT 0 MAX -> 0 } +{ MIN-INT MAX-INT MAX -> MAX-INT } +{ 0 MAX-INT MAX -> MAX-INT } +{ 0 0 MAX -> 0 } +{ 1 1 MAX -> 1 } +{ 1 0 MAX -> 1 } +{ 2 1 MAX -> 2 } +{ 0 -1 MAX -> 0 } +{ 1 -1 MAX -> 1 } +{ 0 MIN-INT MAX -> 0 } +{ MAX-INT MIN-INT MAX -> MAX-INT } +{ MAX-INT 0 MAX -> MAX-INT } + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +{ 1 2 2DROP -> } +{ 1 2 2DUP -> 1 2 1 2 } +{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 } +{ 1 2 3 4 2SWAP -> 3 4 1 2 } +{ 0 ?DUP -> 0 } +{ 1 ?DUP -> 1 1 } +{ -1 ?DUP -> -1 -1 } +{ DEPTH -> 0 } +{ 0 DEPTH -> 0 1 } +{ 0 1 DEPTH -> 0 1 2 } +{ 0 DROP -> } +{ 1 2 DROP -> 1 } +{ 1 DUP -> 1 1 } +{ 1 2 OVER -> 1 2 1 } +{ 1 2 3 ROT -> 2 3 1 } +{ 1 2 SWAP -> 2 1 } + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +{ : GR1 >R R> ; -> } +{ : GR2 >R R@ R> DROP ; -> } +{ 123 GR1 -> 123 } +{ 123 GR2 -> 123 } +{ 1S GR1 -> 1S } ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +{ 0 5 + -> 5 } +{ 5 0 + -> 5 } +{ 0 -5 + -> -5 } +{ -5 0 + -> -5 } +{ 1 2 + -> 3 } +{ 1 -2 + -> -1 } +{ -1 2 + -> 1 } +{ -1 -2 + -> -3 } +{ -1 1 + -> 0 } +{ MID-UINT 1 + -> MID-UINT+1 } + +{ 0 5 - -> -5 } +{ 5 0 - -> 5 } +{ 0 -5 - -> 5 } +{ -5 0 - -> -5 } +{ 1 2 - -> -1 } +{ 1 -2 - -> 3 } +{ -1 2 - -> -3 } +{ -1 -2 - -> 1 } +{ 0 1 - -> -1 } +{ MID-UINT+1 1 - -> MID-UINT } + +{ 0 1+ -> 1 } +{ -1 1+ -> 0 } +{ 1 1+ -> 2 } +{ MID-UINT 1+ -> MID-UINT+1 } + +{ 2 1- -> 1 } +{ 1 1- -> 0 } +{ 0 1- -> -1 } +{ MID-UINT+1 1- -> MID-UINT } + +{ 0 NEGATE -> 0 } +{ 1 NEGATE -> -1 } +{ -1 NEGATE -> 1 } +{ 2 NEGATE -> -2 } +{ -2 NEGATE -> 2 } + +{ 0 ABS -> 0 } +{ 1 ABS -> 1 } +{ -1 ABS -> 1 } +{ MIN-INT ABS -> MID-UINT+1 } + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +{ 0 S>D -> 0 0 } +{ 1 S>D -> 1 0 } +{ 2 S>D -> 2 0 } +{ -1 S>D -> -1 -1 } +{ -2 S>D -> -2 -1 } +{ MIN-INT S>D -> MIN-INT -1 } +{ MAX-INT S>D -> MAX-INT 0 } + +{ 0 0 M* -> 0 S>D } +{ 0 1 M* -> 0 S>D } +{ 1 0 M* -> 0 S>D } +{ 1 2 M* -> 2 S>D } +{ 2 1 M* -> 2 S>D } +{ 3 3 M* -> 9 S>D } +{ -3 3 M* -> -9 S>D } +{ 3 -3 M* -> -9 S>D } +{ -3 -3 M* -> 9 S>D } +{ 0 MIN-INT M* -> 0 S>D } +{ 1 MIN-INT M* -> MIN-INT S>D } +{ 2 MIN-INT M* -> 0 1S } +{ 0 MAX-INT M* -> 0 S>D } +{ 1 MAX-INT M* -> MAX-INT S>D } +{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 } +{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT } +{ MAX-INT MIN-INT M* -> MSB MSB 2/ } +{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT } + +{ 0 0 * -> 0 } \ TEST IDENTITIES +{ 0 1 * -> 0 } +{ 1 0 * -> 0 } +{ 1 2 * -> 2 } +{ 2 1 * -> 2 } +{ 3 3 * -> 9 } +{ -3 3 * -> -9 } +{ 3 -3 * -> -9 } +{ -3 -3 * -> 9 } + +{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 } +{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 } +{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 } + +{ 0 0 UM* -> 0 0 } +{ 0 1 UM* -> 0 0 } +{ 1 0 UM* -> 0 0 } +{ 1 2 UM* -> 2 0 } +{ 2 1 UM* -> 2 0 } +{ 3 3 UM* -> 9 0 } + +{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 } +{ MID-UINT+1 2 UM* -> 0 1 } +{ MID-UINT+1 4 UM* -> 0 2 } +{ 1S 2 UM* -> 1S 1 LSHIFT 1 } +{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT } + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +{ 0 S>D 1 FM/MOD -> 0 0 } +{ 1 S>D 1 FM/MOD -> 0 1 } +{ 2 S>D 1 FM/MOD -> 0 2 } +{ -1 S>D 1 FM/MOD -> 0 -1 } +{ -2 S>D 1 FM/MOD -> 0 -2 } +{ 0 S>D -1 FM/MOD -> 0 0 } +{ 1 S>D -1 FM/MOD -> 0 -1 } +{ 2 S>D -1 FM/MOD -> 0 -2 } +{ -1 S>D -1 FM/MOD -> 0 1 } +{ -2 S>D -1 FM/MOD -> 0 2 } +{ 2 S>D 2 FM/MOD -> 0 1 } +{ -1 S>D -1 FM/MOD -> 0 1 } +{ -2 S>D -2 FM/MOD -> 0 1 } +{ 7 S>D 3 FM/MOD -> 1 2 } +{ 7 S>D -3 FM/MOD -> -2 -3 } +{ -7 S>D 3 FM/MOD -> 2 -3 } +{ -7 S>D -3 FM/MOD -> -1 2 } +{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT } +{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT } +{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 } +{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 } +{ 1S 1 4 FM/MOD -> 3 MAX-INT } +{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT } +{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 } +{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT } +{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 } +{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT } +{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 } +{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT } +{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 } +{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT } +{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT } +{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT } +{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT } + +{ 0 S>D 1 SM/REM -> 0 0 } +{ 1 S>D 1 SM/REM -> 0 1 } +{ 2 S>D 1 SM/REM -> 0 2 } +{ -1 S>D 1 SM/REM -> 0 -1 } +{ -2 S>D 1 SM/REM -> 0 -2 } +{ 0 S>D -1 SM/REM -> 0 0 } +{ 1 S>D -1 SM/REM -> 0 -1 } +{ 2 S>D -1 SM/REM -> 0 -2 } +{ -1 S>D -1 SM/REM -> 0 1 } +{ -2 S>D -1 SM/REM -> 0 2 } +{ 2 S>D 2 SM/REM -> 0 1 } +{ -1 S>D -1 SM/REM -> 0 1 } +{ -2 S>D -2 SM/REM -> 0 1 } +{ 7 S>D 3 SM/REM -> 1 2 } +{ 7 S>D -3 SM/REM -> 1 -2 } +{ -7 S>D 3 SM/REM -> -1 -2 } +{ -7 S>D -3 SM/REM -> -1 2 } +{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT } +{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT } +{ MAX-INT S>D MAX-INT SM/REM -> 0 1 } +{ MIN-INT S>D MIN-INT SM/REM -> 0 1 } +{ 1S 1 4 SM/REM -> 3 MAX-INT } +{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT } +{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 } +{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT } +{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 } +{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT } +{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT } +{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT } +{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT } + +{ 0 0 1 UM/MOD -> 0 0 } +{ 1 0 1 UM/MOD -> 0 1 } +{ 1 0 2 UM/MOD -> 1 0 } +{ 3 0 2 UM/MOD -> 1 1 } +{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT } +{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 } +{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT } + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +{ 0 1 /MOD -> 0 1 T/MOD } +{ 1 1 /MOD -> 1 1 T/MOD } +{ 2 1 /MOD -> 2 1 T/MOD } +{ -1 1 /MOD -> -1 1 T/MOD } +{ -2 1 /MOD -> -2 1 T/MOD } +{ 0 -1 /MOD -> 0 -1 T/MOD } +{ 1 -1 /MOD -> 1 -1 T/MOD } +{ 2 -1 /MOD -> 2 -1 T/MOD } +{ -1 -1 /MOD -> -1 -1 T/MOD } +{ -2 -1 /MOD -> -2 -1 T/MOD } +{ 2 2 /MOD -> 2 2 T/MOD } +{ -1 -1 /MOD -> -1 -1 T/MOD } +{ -2 -2 /MOD -> -2 -2 T/MOD } +{ 7 3 /MOD -> 7 3 T/MOD } +{ 7 -3 /MOD -> 7 -3 T/MOD } +{ -7 3 /MOD -> -7 3 T/MOD } +{ -7 -3 /MOD -> -7 -3 T/MOD } +{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD } +{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD } +{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD } +{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD } + +{ 0 1 / -> 0 1 T/ } +{ 1 1 / -> 1 1 T/ } +{ 2 1 / -> 2 1 T/ } +{ -1 1 / -> -1 1 T/ } +{ -2 1 / -> -2 1 T/ } +{ 0 -1 / -> 0 -1 T/ } +{ 1 -1 / -> 1 -1 T/ } +{ 2 -1 / -> 2 -1 T/ } +{ -1 -1 / -> -1 -1 T/ } +{ -2 -1 / -> -2 -1 T/ } +{ 2 2 / -> 2 2 T/ } +{ -1 -1 / -> -1 -1 T/ } +{ -2 -2 / -> -2 -2 T/ } +{ 7 3 / -> 7 3 T/ } +{ 7 -3 / -> 7 -3 T/ } +{ -7 3 / -> -7 3 T/ } +{ -7 -3 / -> -7 -3 T/ } +{ MAX-INT 1 / -> MAX-INT 1 T/ } +{ MIN-INT 1 / -> MIN-INT 1 T/ } +{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ } +{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ } + +{ 0 1 MOD -> 0 1 TMOD } +{ 1 1 MOD -> 1 1 TMOD } +{ 2 1 MOD -> 2 1 TMOD } +{ -1 1 MOD -> -1 1 TMOD } +{ -2 1 MOD -> -2 1 TMOD } +{ 0 -1 MOD -> 0 -1 TMOD } +{ 1 -1 MOD -> 1 -1 TMOD } +{ 2 -1 MOD -> 2 -1 TMOD } +{ -1 -1 MOD -> -1 -1 TMOD } +{ -2 -1 MOD -> -2 -1 TMOD } +{ 2 2 MOD -> 2 2 TMOD } +{ -1 -1 MOD -> -1 -1 TMOD } +{ -2 -2 MOD -> -2 -2 TMOD } +{ 7 3 MOD -> 7 3 TMOD } +{ 7 -3 MOD -> 7 -3 TMOD } +{ -7 3 MOD -> -7 3 TMOD } +{ -7 -3 MOD -> -7 -3 TMOD } +{ MAX-INT 1 MOD -> MAX-INT 1 TMOD } +{ MIN-INT 1 MOD -> MIN-INT 1 TMOD } +{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD } +{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD } + +{ 0 2 1 */ -> 0 2 1 T*/ } +{ 1 2 1 */ -> 1 2 1 T*/ } +{ 2 2 1 */ -> 2 2 1 T*/ } +{ -1 2 1 */ -> -1 2 1 T*/ } +{ -2 2 1 */ -> -2 2 1 T*/ } +{ 0 2 -1 */ -> 0 2 -1 T*/ } +{ 1 2 -1 */ -> 1 2 -1 T*/ } +{ 2 2 -1 */ -> 2 2 -1 T*/ } +{ -1 2 -1 */ -> -1 2 -1 T*/ } +{ -2 2 -1 */ -> -2 2 -1 T*/ } +{ 2 2 2 */ -> 2 2 2 T*/ } +{ -1 2 -1 */ -> -1 2 -1 T*/ } +{ -2 2 -2 */ -> -2 2 -2 T*/ } +{ 7 2 3 */ -> 7 2 3 T*/ } +{ 7 2 -3 */ -> 7 2 -3 T*/ } +{ -7 2 3 */ -> -7 2 3 T*/ } +{ -7 2 -3 */ -> -7 2 -3 T*/ } +{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ } +{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ } + +{ 0 2 1 */MOD -> 0 2 1 T*/MOD } +{ 1 2 1 */MOD -> 1 2 1 T*/MOD } +{ 2 2 1 */MOD -> 2 2 1 T*/MOD } +{ -1 2 1 */MOD -> -1 2 1 T*/MOD } +{ -2 2 1 */MOD -> -2 2 1 T*/MOD } +{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD } +{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD } +{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD } +{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD } +{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD } +{ 2 2 2 */MOD -> 2 2 2 T*/MOD } +{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD } +{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD } +{ 7 2 3 */MOD -> 7 2 3 T*/MOD } +{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD } +{ -7 2 3 */MOD -> -7 2 3 T*/MOD } +{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD } +{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD } +{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD } + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +{ 1STA 2NDA U< -> } \ HERE MUST GROW WITH ALLOT +{ 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +{ 1ST 2ND U< -> } \ HERE MUST GROW WITH ALLOT +{ 1ST CELL+ -> 2ND } \ ... BY ONE CELL +{ 1ST 1 CELLS + -> 2ND } +{ 1ST @ 2ND @ -> 1 2 } +{ 5 1ST ! -> } +{ 1ST @ 2ND @ -> 5 2 } +{ 6 2ND ! -> } +{ 1ST @ 2ND @ -> 5 6 } +{ 1ST 2@ -> 6 5 } +{ 2 1 1ST 2! -> } +{ 1ST 2@ -> 2 1 } +{ 1S 1ST ! 1ST @ -> 1S } \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +{ 1STC 2NDC U< -> } \ HERE MUST GROW WITH ALLOT +{ 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR +{ 1STC 1 CHARS + -> 2NDC } +{ 1STC C@ 2NDC C@ -> 1 2 } +{ 3 1STC C! -> } +{ 1STC C@ 2NDC C@ -> 3 2 } +{ 4 2NDC C! -> } +{ 1STC C@ 2NDC C@ -> 3 4 } + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +{ UA-ADDR ALIGNED -> A-ADDR } +{ 1 A-ADDR C! A-ADDR C@ -> 1 } +{ 1234 A-ADDR ! A-ADDR @ -> 1234 } +{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 } +{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 } +{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 } +{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 } +{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 } + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +{ 1 CHARS 1 < -> } +{ 1 CHARS 1 CELLS > -> } +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +{ 1 CELLS 1 < -> } +{ 1 CELLS 1 CHARS MOD -> 0 } +{ 1S BITS 10 < -> } + +{ 0 1ST ! -> } +{ 1 1ST +! -> } +{ 1ST @ -> 1 } +{ -1 1ST +! 1ST @ -> 0 } + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +{ BL -> 20 } +{ CHAR X -> 58 } +{ CHAR HELLO -> 48 } +{ : GC1 [CHAR] X ; -> } +{ : GC2 [CHAR] HELLO ; -> } +{ GC1 -> 58 } +{ GC2 -> 48 } +{ : GC3 [ GC1 ] LITERAL ; -> } +{ GC3 -> 58 } +{ : GC4 S" XY" ; -> } +{ GC4 SWAP DROP -> 2 } +{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 } + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +{ : GT1 123 ; -> } +{ ' GT1 EXECUTE -> 123 } +{ : GT2 ['] GT1 ; IMMEDIATE -> } +{ GT2 EXECUTE -> 123 } +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +{ GT1STRING FIND -> ' GT1 -1 } +{ GT2STRING FIND -> ' GT2 1 } +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +{ : GT3 GT2 LITERAL ; -> } +{ GT3 -> ' GT1 } +{ GT1STRING COUNT -> GT1STRING CHAR+ 3 } + +{ : GT4 POSTPONE GT1 ; IMMEDIATE -> } +{ : GT5 GT4 ; -> } +{ GT5 -> 123 } +{ : GT6 345 ; IMMEDIATE -> } +{ : GT7 POSTPONE GT6 ; -> } +{ GT7 -> 345 } + +{ : GT8 STATE @ ; IMMEDIATE -> } +{ GT8 -> 0 } +{ : GT9 GT8 LITERAL ; -> } +{ GT9 0= -> } + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +{ : GI1 IF 123 THEN ; -> } +{ : GI2 IF 123 ELSE 234 THEN ; -> } +{ 0 GI1 -> } +{ 1 GI1 -> 123 } +{ -1 GI1 -> 123 } +{ 0 GI2 -> 234 } +{ 1 GI2 -> 123 } +{ -1 GI1 -> 123 } + +{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> } +{ 0 GI3 -> 0 1 2 3 4 5 } +{ 4 GI3 -> 4 5 } +{ 5 GI3 -> 5 } +{ 6 GI3 -> 6 } + +{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> } +{ 3 GI4 -> 3 4 5 6 } +{ 5 GI4 -> 5 6 } +{ 6 GI4 -> 6 7 } + +{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> } +{ 1 GI5 -> 1 345 } +{ 2 GI5 -> 2 345 } +{ 3 GI5 -> 3 4 5 123 } +{ 4 GI5 -> 4 5 123 } +{ 5 GI5 -> 5 123 } + +{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> } +{ 0 GI6 -> 0 } +{ 1 GI6 -> 0 1 } +{ 2 GI6 -> 0 1 2 } +{ 3 GI6 -> 0 1 2 3 } +{ 4 GI6 -> 0 1 2 3 4 } + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +{ : GD1 DO I LOOP ; -> } +{ 4 1 GD1 -> 1 2 3 } +{ 2 -1 GD1 -> -1 0 1 } +{ MID-UINT+1 MID-UINT GD1 -> MID-UINT } + +{ : GD2 DO I -1 +LOOP ; -> } +{ 1 4 GD2 -> 4 3 2 1 } +{ -1 2 GD2 -> 2 1 0 -1 } +{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT } + +{ : GD3 DO 1 0 DO J LOOP LOOP ; -> } +{ 4 1 GD3 -> 1 2 3 } +{ 2 -1 GD3 -> -1 0 1 } +{ MID-UINT+1 MID-UINT GD3 -> MID-UINT } + +{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> } +{ 1 4 GD4 -> 4 3 2 1 } +{ -1 2 GD4 -> 2 1 0 -1 } +{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT } + +{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> } +{ 1 GD5 -> 123 } +{ 5 GD5 -> 123 } +{ 6 GD5 -> 234 } + +{ : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> } +{ 1 GD6 -> 1 } +{ 2 GD6 -> 3 } +{ 3 GD6 -> 4 1 2 } + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +{ 123 CONSTANT X123 -> } +{ X123 -> 123 } +{ : EQU CONSTANT ; -> } +{ X123 EQU Y123 -> } +{ Y123 -> 123 } + +{ VARIABLE V1 -> } +{ 123 V1 ! -> } +{ V1 @ -> 123 } + +{ : NOP : POSTPONE ; ; -> } +{ NOP NOP1 NOP NOP2 -> } +{ NOP1 -> } +{ NOP2 -> } + +{ : DOES1 DOES> @ 1 + ; -> } +{ : DOES2 DOES> @ 2 + ; -> } +{ CREATE CR1 -> } +{ CR1 -> HERE } +{ ' CR1 >BODY -> HERE } +{ 1 , -> } +{ CR1 @ -> 1 } +{ DOES1 -> } +{ CR1 -> 2 } +{ DOES2 -> } +{ CR1 -> 3 } + +{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> } +{ WEIRD: W1 -> } +{ ' W1 >BODY -> HERE } +{ W1 -> HERE 1 + } +{ W1 -> HERE 2 + } + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +: GE1 S" 123" ; IMMEDIATE +: GE2 S" 123 1+" ; IMMEDIATE +: GE3 S" : GE4 345 ;" ; +: GE5 EVALUATE ; IMMEDIATE + +{ GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE ) +{ GE2 EVALUATE -> 124 } +{ GE3 EVALUATE -> } +{ GE4 -> 345 } + +{ : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE ) +{ GE6 -> 123 } +{ : GE7 GE2 GE5 ; -> } +{ GE7 -> 124 } + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +: GS1 S" SOURCE" 2DUP EVALUATE + >R SWAP >R = R> R> = ; +{ GS1 -> } + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +{ 2 SCANS ! +345 RESCAN? +-> 345 345 } + +: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +{ GS2 -> 123 123 123 123 123 } + +: GS3 WORD COUNT SWAP C@ ; +{ BL GS3 HELLO -> 5 CHAR H } +{ CHAR " GS3 GOODBYE" -> 7 CHAR G } +{ BL GS3 +DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +{ GS4 123 456 +-> } + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +{ GP1 -> } + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +{ GP2 -> } + +: GP3 <# 1 0 # # #> S" 01" S= ; +{ GP3 -> } + +: GP4 <# 1 0 #S #> S" 1" S= ; +{ GP4 -> } + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +{ GP5 -> } + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +{ GP6 -> } + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND + LOOP + R> BASE ! ; + +{ GP7 -> } + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED } +{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED } +{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED } +{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE +{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING } +{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING } + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED } +{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING } +{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED } +{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING } +{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED } +{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED } + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +{ 0 0 2 GN1 -> 0 0 0 } +{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 } +{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 } +{ 0 0 MAX-BASE GN1 -> 0 0 0 } +{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 } +{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 } + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +{ GN2 -> 10 A } + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +{ FBUF 0 20 FILL -> } +{ SEEBUF -> 00 00 00 } + +{ FBUF 1 20 FILL -> } +{ SEEBUF -> 20 00 00 } + +{ FBUF 3 20 FILL -> } +{ SEEBUF -> 20 20 20 } + +{ FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE +{ SEEBUF -> 20 20 20 } + +{ SBUF FBUF 0 CHARS MOVE -> } +{ SEEBUF -> 20 20 20 } + +{ SBUF FBUF 1 CHARS MOVE -> } +{ SEEBUF -> 12 20 20 } + +{ SBUF FBUF 3 CHARS MOVE -> } +{ SEEBUF -> 12 34 56 } + +{ FBUF FBUF CHAR+ 2 CHARS MOVE -> } +{ SEEBUF -> 12 12 34 } + +{ FBUF CHAR+ FBUF 2 CHARS MOVE -> } +{ SEEBUF -> 12 34 34 } + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +{ OUTPUT-TEST -> } + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 80 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 80 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +{ ACCEPT-TEST -> } + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +{ : GDX 123 ; : GDX GDX 234 ; -> } + +{ GDX -> 123 234 } + + diff --git a/csrc/pf_all.h b/csrc/pf_all.h new file mode 100644 index 0000000..da2e603 --- /dev/null +++ b/csrc/pf_all.h @@ -0,0 +1,62 @@ +/* @(#) pf_all.h 98/01/26 1.2 */ + +#ifndef _pf_all_h +#define _pf_all_h + +/*************************************************************** +** Include all files needed for PForth +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** 940521 PLB Creation. +** +***************************************************************/ + +/* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */ +#ifdef __MWERKS__ + #define PF_USER_INC1 "pf_mac.h" + #define PF_SUPPORT_FP (1) +#endif + + +#ifdef WIN32 + #define PF_USER_INC2 "pf_win32.h" +#endif + + +#if defined(PF_USER_INC1) + #include PF_USER_INC1 +#else +/* Default to UNIX if no host speciied. */ + #include "pf_unix.h" +#endif + +#include "pf_types.h" +#include "pf_io.h" +#include "pf_guts.h" +#include "pf_text.h" +#include "pfcompil.h" +#include "pf_clib.h" +#include "pf_words.h" +#include "pf_save.h" +#include "pf_mem.h" +#include "pf_cglue.h" +#include "pf_core.h" + +#ifdef PF_USER_INC2 +/* This could be used to undef and redefine macros. */ + #include PF_USER_INC2 +#endif + +#endif /* _pf_all_h */ + diff --git a/csrc/pf_cglue.c b/csrc/pf_cglue.c new file mode 100644 index 0000000..0fe58b0 --- /dev/null +++ b/csrc/pf_cglue.c @@ -0,0 +1,108 @@ +/* @(#) pf_cglue.c 98/02/11 1.4 */ +/*************************************************************** +** 'C' Glue support for Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#include "pf_all.h" + +typedef cell (*CFunc0)( void ); +typedef cell (*CFunc1)( cell P1 ); +typedef cell (*CFunc2)( cell P1, cell P2 ); +typedef cell (*CFunc3)( cell P1, cell P2, cell P3 ); +typedef cell (*CFunc4)( cell P1, cell P2, cell P3, cell P4 ); +typedef cell (*CFunc5)( cell P1, cell P2, cell P3, cell P4, cell P5 ); + + +extern void *CustomFunctionTable[]; + +/***************************************************************/ +int32 CallUserFunction( int32 Index, int32 ReturnMode, int32 NumParams ) +{ + cell P1, P2, P3, P4, P5; + cell Result = 0; + void *CF; + +DBUG(("CallUserFunction: Index = %d, ReturnMode = %d, NumParams = %d\n", + Index, ReturnMode, NumParams )); + + CF = CustomFunctionTable[Index]; + + switch( NumParams ) + { + case 0: + Result = ((CFunc0) CF) ( ); + break; + case 1: + P1 = POP_DATA_STACK; + Result = ((CFunc1) CF) ( P1 ); + break; + case 2: + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc2) CF) ( P1, P2 ); + break; + case 3: + P3 = POP_DATA_STACK; + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc3) CF) ( P1, P2, P3 ); + break; + case 4: + P4 = POP_DATA_STACK; + P3 = POP_DATA_STACK; + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc4) CF) ( P1, P2, P3, P4 ); + break; + case 5: + P5 = POP_DATA_STACK; + P4 = POP_DATA_STACK; + P3 = POP_DATA_STACK; + P2 = POP_DATA_STACK; + P1 = POP_DATA_STACK; + Result = ((CFunc5) CF) ( P1, P2, P3, P4, P5 ); + break; + default: + pfReportError("CallUserFunction", PF_ERR_NUM_PARAMS); + EXIT(1); + } + +/* Push result on Forth stack if requested. */ + if(ReturnMode == C_RETURNS_VALUE) PUSH_DATA_STACK( Result ); + + return Result; +} + +#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) +/***************************************************************/ +Err CreateGlueToC( const char *CName, uint32 Index, int32 ReturnMode, int32 NumParams ) +{ + uint32 Packed; + char FName[40]; + + CStringToForth( FName, CName ); + Packed = (Index & 0xFFFF) | 0 | (NumParams << 24) | + (ReturnMode << 31); + DBUG(("Packed = 0x%8x\n", Packed)); + + ffCreateSecondaryHeader( FName ); + CODE_COMMA( ID_CALL_C ); + CODE_COMMA(Packed); + ffFinishSecondary(); + + return 0; +} +#endif diff --git a/csrc/pf_cglue.h b/csrc/pf_cglue.h new file mode 100644 index 0000000..eed6ae0 --- /dev/null +++ b/csrc/pf_cglue.h @@ -0,0 +1,39 @@ +/* @(#) pf_cglue.h 96/12/18 1.7 */ +#ifndef _pf_c_glue_h +#define _pf_c_glue_h + +/*************************************************************** +** Include file for PForth 'C' Glue support +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + + +#ifdef __cplusplus +extern "C" { +#endif + +Err CreateGlueToC( const char *CName, uint32 Index, int32 ReturnMode, int32 NumParams ); +Err CompileCustomFunctions( void ); +Err LoadCustomFunctionTable( void ); +int32 CallUserFunction( int32 Index, int32 ReturnMode, int32 NumParams ); + +#ifdef __cplusplus +} +#endif + +#define C_RETURNS_VOID (0) +#define C_RETURNS_VALUE (1) + +#endif /* _pf_c_glue_h */ diff --git a/csrc/pf_clib.c b/csrc/pf_clib.c new file mode 100644 index 0000000..34fcfb7 --- /dev/null +++ b/csrc/pf_clib.c @@ -0,0 +1,64 @@ +/* @(#) pf_clib.c 96/12/18 1.12 */ +/*************************************************************** +** Duplicate functions from stdlib for PForth based on 'C' +** +** This code duplicates some of the code in the 'C' lib +** because it reduces the dependency on foreign libraries +** for monitor mode where no OS is available. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 961124 PLB Advance pointers in pfCopyMemory() and pfSetMemory() +***************************************************************/ + +#include "pf_all.h" + +#ifdef PF_NO_CLIB +/* Count chars until NUL. Replace strlen() */ +#define NUL ((char) 0) +cell pfCStringLength( const char *s ) +{ + cell len = 0; + while( *s++ != NUL ) len++; + return len; +} + +/* void *memset (void *s, int32 c, size_t n); */ +void *pfSetMemory( void *s, cell c, cell n ) +{ + uint8 *p = s, byt = (uint8) c; + while( (n--) > 0) *p++ = byt; + return s; +} + +/* void *memccpy (void *s1, const void *s2, int32 c, size_t n); */ +void *pfCopyMemory( void *s1, const void *s2, cell n) +{ + uint8 *p1 = s1; + const uint8 *p2 = s2; + while( (n--) > 0) *p1++ = *p2++; + return s1; +} + +#endif /* PF_NO_CLIB */ + +char pfCharToUpper( char c ) +{ + return (char) ( ((c>='a') && (c<='z')) ? (c - ('a' - 'A')) : c ); +} + +char pfCharToLower( char c ) +{ + return (char) ( ((c>='A') && (c<='Z')) ? (c + ('a' - 'A')) : c ); +} diff --git a/csrc/pf_clib.h b/csrc/pf_clib.h new file mode 100644 index 0000000..3e58dd1 --- /dev/null +++ b/csrc/pf_clib.h @@ -0,0 +1,63 @@ +/* @(#) pf_clib.h 96/12/18 1.10 */ +#ifndef _pf_clib_h +#define _pf_clib_h + +/*************************************************************** +** Include file for PForth tools +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef PF_NO_CLIB + + #ifdef __cplusplus + extern "C" { + #endif + + cell pfCStringLength( const char *s ); + void *pfSetMemory( void *s, cell c, cell n ); + void *pfCopyMemory( void *s1, const void *s2, cell n); + #define EXIT(n) {while(1);} + + #ifdef __cplusplus + } + #endif + +#else /* PF_NO_CLIB */ + + #ifdef PF_USER_CLIB + #include PF_USER_CLIB + #else +/* Use stdlib functions if available because they are probably faster. */ + #define pfCStringLength strlen + #define pfSetMemory memset + #define pfCopyMemory memcpy + #define EXIT(n) exit(n) + #endif /* PF_USER_CLIB */ + +#endif /* !PF_NO_CLIB */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* Always use my own functions to avoid macro expansion problems with tolower(*s++) */ +char pfCharToUpper( char c ); +char pfCharToLower( char c ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pf_clib_h */ diff --git a/csrc/pf_core.c b/csrc/pf_core.c new file mode 100644 index 0000000..77f5a0f --- /dev/null +++ b/csrc/pf_core.c @@ -0,0 +1,422 @@ +/* @(#) pf_core.c 98/01/28 1.5 */ +/*************************************************************** +** Forth based on 'C' +** +** This file has the main entry points to the pForth library. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 940502 PLB Creation. +** 940505 PLB More macros. +** 940509 PLB Moved all stack handling into inner interpreter. +** Added Create, Colon, Semicolon, HNumberQ, etc. +** 940510 PLB Got inner interpreter working with secondaries. +** Added (LITERAL). Compiles colon definitions. +** 940511 PLB Added conditionals, LITERAL, CREATE DOES> +** 940512 PLB Added DO LOOP DEFER, fixed R> +** 940520 PLB Added INCLUDE +** 940521 PLB Added NUMBER? +** 940930 PLB Outer Interpreter now uses deferred NUMBER? +** 941005 PLB Added ANSI locals, LEAVE, modularised +** 950320 RDG Added underflow checking for FP stack +** 970702 PLB Added STACK_SAFETY to FP stack size. +***************************************************************/ + +#include "pf_all.h" + +/*************************************************************** +** Global Data +***************************************************************/ + +cfTaskData *gCurrentTask; +cfDictionary *gCurrentDictionary; +int32 gNumPrimitives; +char gScratch[TIB_SIZE]; +ExecToken gLocalCompiler_XT; /* custom compiler for local variables */ + +/* Depth of data stack when colon called. */ +int32 gDepthAtColon; + +/* Global Forth variables. */ +char *gVarContext; /* Points to last name field. */ +cell gVarState; /* 1 if compiling. */ +cell gVarBase; /* Numeric Base. */ +cell gVarEcho; /* Echo input. */ +cell gVarTraceLevel; /* Trace Level for Inner Interpreter. */ +cell gVarTraceStack; /* Dump Stack each time if true. */ +cell gVarTraceFlags; /* Enable various internal debug messages. */ +cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ +cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ + +#define DEFAULT_RETURN_DEPTH (512) +#define DEFAULT_USER_DEPTH (512) +#define DEFAULT_HEADER_SIZE (120000) +#define DEFAULT_CODE_SIZE (300000) + +/* Initialize non-zero globals in a function to simplify loading on + * embedded systems which may only support uninitialized data segments. + */ +void pfInitGlobals( void ) +{ + gVarBase = 10; + gVarTraceStack = 1; + gDepthAtColon = DEPTH_AT_COLON_INVALID; +} + +/*************************************************************** +** Task Management +***************************************************************/ + +void pfDeleteTask( cfTaskData *cftd ) +{ + FREE_VAR( cftd->td_ReturnLimit ); + FREE_VAR( cftd->td_StackLimit ); + pfFreeMem( cftd ); +} +/* Allocate some extra cells to protect against mild stack underflows. */ +#define STACK_SAFETY (8) +cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ) +{ + cfTaskData *cftd; + + cftd = ( cfTaskData * ) pfAllocMem( sizeof( cfTaskData ) ); + if( !cftd ) goto nomem; + pfSetMemory( cftd, 0, sizeof( cfTaskData )); + +/* Allocate User Stack */ + cftd->td_StackLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) * + (UserStackDepth + STACK_SAFETY))); + if( !cftd->td_StackLimit ) goto nomem; + cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth; + cftd->td_StackPtr = cftd->td_StackBase; + +/* Allocate Return Stack */ + cftd->td_ReturnLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) * ReturnStackDepth) ); + if( !cftd->td_ReturnLimit ) goto nomem; + cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth; + cftd->td_ReturnPtr = cftd->td_ReturnBase; + +/* Allocate Float Stack */ +#ifdef PF_SUPPORT_FP +/* Allocate room for as many Floats as we do regular data. */ + cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((uint32)(sizeof(PF_FLOAT) * + (UserStackDepth + STACK_SAFETY))); + if( !cftd->td_FloatStackLimit ) goto nomem; + cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth; + cftd->td_FloatStackPtr = cftd->td_FloatStackBase; +#endif + + cftd->td_InputStream = PF_STDIN; + + cftd->td_SourcePtr = &cftd->td_TIB[0]; + cftd->td_SourceNum = 0; + + return cftd; + +nomem: + ERR("CreateTaskContext: insufficient memory.\n"); + if( cftd ) pfDeleteTask( cftd ); + return NULL; +} + +/*************************************************************** +** Dictionary Management +***************************************************************/ + +void pfExecByName( const char *CString ) +{ + if( NAME_BASE != NULL) + { + ExecToken autoInitXT; + if( ffFindC( CString, &autoInitXT ) ) + { + pfExecuteToken( autoInitXT ); + } + } +} + +/*************************************************************** +** Delete a dictionary created by pfCreateDictionary() +*/ +void pfDeleteDictionary( cfDictionary *dic ) +{ + if( !dic ) return; + + if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS ) + { + FREE_VAR( dic->dic_HeaderBaseUnaligned ); + FREE_VAR( dic->dic_CodeBaseUnaligned ); + } + pfFreeMem( dic ); +} + +/*************************************************************** +** Create a complete dictionary. +** The dictionary consists of two parts, the header with the names, +** and the code portion. +** Delete using pfDeleteDictionary(). +** Return pointer to dictionary management structure. +*/ +cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize ) +{ +/* Allocate memory for initial dictionary. */ + cfDictionary *dic; + + dic = ( cfDictionary * ) pfAllocMem( sizeof( cfDictionary ) ); + if( !dic ) goto nomem; + pfSetMemory( dic, 0, sizeof( cfDictionary )); + + dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS; + +/* Align dictionary segments to preserve alignment of floats across hosts. */ +#define DIC_ALIGNMENT_SIZE (0x10) +#define DIC_ALIGN(addr) ((uint8 *)((((uint32)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))) + +/* Allocate memory for header. */ + if( HeaderSize > 0 ) + { + dic->dic_HeaderBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) HeaderSize + DIC_ALIGNMENT_SIZE ); + if( !dic->dic_HeaderBaseUnaligned ) goto nomem; +/* Align header base. */ + dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned); + pfSetMemory( dic->dic_HeaderBase, 0xA5, (uint32) HeaderSize); + dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize; + dic->dic_HeaderPtr.Byte = dic->dic_HeaderBase; + } + else + { + dic->dic_HeaderBase = NULL; + } + +/* Allocate memory for code. */ + dic->dic_CodeBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) CodeSize + DIC_ALIGNMENT_SIZE ); + if( !dic->dic_CodeBaseUnaligned ) goto nomem; + dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned); + pfSetMemory( dic->dic_CodeBase, 0x5A, (uint32) CodeSize); + + dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize; + dic->dic_CodePtr.Byte = dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES); + + return dic; +nomem: + pfDeleteDictionary( dic ); + return NULL; +} + +/*************************************************************** +** Used by Quit and other routines to restore system. +***************************************************************/ + +void ResetForthTask( void ) +{ +/* Go back to terminal input. */ + gCurrentTask->td_InputStream = PF_STDIN; + +/* Reset stacks. */ + gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase; + gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase; +#ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */ + gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase; +#endif + +/* Advance >IN to end of input. */ + gCurrentTask->td_IN = gCurrentTask->td_SourceNum; + gVarState = 0; +} + +/*************************************************************** +** Set current task context. +***************************************************************/ + +void pfSetCurrentTask( cfTaskData *cftd ) +{ + gCurrentTask = cftd; +} + +/*************************************************************** +** Set Quiet Flag. +***************************************************************/ + +void pfSetQuiet( int32 IfQuiet ) +{ + gVarQuiet = (cell) IfQuiet; +} + +/*************************************************************** +** Query message status. +***************************************************************/ + +int32 pfQueryQuiet( void ) +{ + return gVarQuiet; +} + +/*************************************************************** +** RunForth +***************************************************************/ + +int32 pfRunForth( void ) +{ + ffQuit(); + return gVarReturnCode; +} + +/*************************************************************** +** Include file based on 'C' name. +***************************************************************/ + +int32 pfIncludeFile( const char *FileName ) +{ + FileStream *fid; + int32 Result; + char buffer[32]; + int32 numChars, len; + +/* Open file. */ + fid = sdOpenFile( FileName, "r" ); + if( fid == NULL ) + { + ERR("pfIncludeFile could not open "); + ERR(FileName); + EMIT_CR; + return -1; + } + +/* Create a dictionary word named ::::FileName for FILE? */ + pfCopyMemory( &buffer[0], "::::", 4); + len = pfCStringLength(FileName); + numChars = ( len > (32-4-1) ) ? (32-4-1) : len; + pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 ); + CreateDicEntryC( ID_NOOP, buffer, 0 ); + + Result = ffIncludeFile( fid ); + +/* Create a dictionary word named ;;;; for FILE? */ + CreateDicEntryC( ID_NOOP, ";;;;", 0 ); + + sdCloseFile(fid); + return Result; +} + +/*************************************************************** +** Output 'C' string message. +** This is provided to help avoid the use of printf() and other I/O +** which may not be present on a small embedded system. +***************************************************************/ + +void pfMessage( const char *CString ) +{ + ioType( CString, pfCStringLength(CString) ); +} + +/************************************************************************** +** Main entry point fo pForth +*/ +int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ) +{ + cfTaskData *cftd; + cfDictionary *dic; + int32 Result = 0; + ExecToken EntryPoint = 0; + +#ifdef PF_USER_INIT + Result = PF_USER_INIT; + if( Result < 0 ) goto error; +#endif + + pfInitGlobals(); + +/* Allocate Task structure. */ + cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH ); + + if( cftd ) + { + pfSetCurrentTask( cftd ); + + if( !pfQueryQuiet() ) + { + MSG( "PForth V"PFORTH_VERSION"\n" ); + } + +#if 0 +/* Don't use MSG before task set. */ + if( IfInit ) MSG("Build dictionary from scratch.\n"); + + if( DicName ) + { + MSG("DicName = "); MSG(DicName); MSG("\n"); + } + if( SourceName ) + { + MSG("SourceName = "); MSG(SourceName); MSG("\n"); + } +#endif + + +#ifdef PF_NO_GLOBAL_INIT + if( LoadCustomFunctionTable() < 0 ) goto error; /* Init custom 'C' call array. */ +#endif + +#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) + if( IfInit ) + { + dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE ); + } + else +#else + TOUCH(IfInit); +#endif /* !PF_NO_INIT && !PF_NO_SHELL*/ + { + dic = pfLoadDictionary( DicName, &EntryPoint ); + } + if( dic == NULL ) goto error; + + pfExecByName("AUTO.INIT"); + + if( EntryPoint != 0 ) + { + pfExecuteToken( EntryPoint ); + } +#ifndef PF_NO_SHELL + else + { + if( SourceName == NULL ) + { + Result = pfRunForth(); + } + else + { + MSG("Including: "); + MSG(SourceName); + MSG("\n"); + Result = pfIncludeFile( SourceName ); + } + } +#endif /* PF_NO_SHELL */ + pfExecByName("AUTO.TERM"); + pfDeleteDictionary( dic ); + pfDeleteTask( cftd ); + } + +#ifdef PF_USER_TERM + PF_USER_TERM; +#endif + + return Result; + +error: + MSG("pfDoForth: Error occured.\n"); + pfDeleteTask( cftd ); + return -1; +} diff --git a/csrc/pf_core.h b/csrc/pf_core.h new file mode 100644 index 0000000..b55c9d4 --- /dev/null +++ b/csrc/pf_core.h @@ -0,0 +1,51 @@ +/* @(#) pf_core.h 98/01/26 1.3 */ +#ifndef _pf_core_h +#define _pf_core_h + +/*************************************************************** +** Include file for PForth 'C' Glue support +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +/* Main entry point fo pForth. */ +int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ); + +void pfInitGlobals( void ); +cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ); +void pfDeleteTask( cfTaskData *cftd ); +void pfSetCurrentTask( cfTaskData *cftd ); + +cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize ); +void pfDeleteDictionary( cfDictionary *dic ); + +void pfSetQuiet( int32 IfQuiet ); +int32 pfQueryQuiet( void ); +int32 pfRunForth( void ); +int32 pfIncludeFile( const char *FileName ); +void pfMessage( const char *CString ); +void pfExecByName( const char *CString ); + +void ResetForthTask( void ); + +#ifdef __cplusplus +} +#endif + + +#endif /* _pf_core_h */ diff --git a/csrc/pf_float.h b/csrc/pf_float.h new file mode 100644 index 0000000..ca5ef3d --- /dev/null +++ b/csrc/pf_float.h @@ -0,0 +1,43 @@ +/* @(#) pf_float.h 98/01/28 1.1 */ +#ifndef _pf_float_h +#define _pf_float_h + +/*************************************************************** +** Include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +typedef double PF_FLOAT; + +/* Define pForth specific math functions. */ + +#define fp_acos acos +#define fp_asin asin +#define fp_atan atan +#define fp_atan2 atan2 +#define fp_cos cos +#define fp_cosh cosh +#define fp_fabs fabs +#define fp_floor floor +#define fp_log log +#define fp_log10 log10 +#define fp_pow pow +#define fp_sin sin +#define fp_sinh sinh +#define fp_sqrt sqrt +#define fp_tan tan +#define fp_tanh tanh + +#endif diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h new file mode 100644 index 0000000..3a19f79 --- /dev/null +++ b/csrc/pf_guts.h @@ -0,0 +1,565 @@ +/* @(#) pf_guts.h 98/01/28 1.4 */ +#ifndef _pf_guts_h +#define _pf_guts_h + +/*************************************************************** +** Include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/* +** PFORTH_VERSION changes when PForth is modified and released. +** See README file for version info. +*/ +#define PFORTH_VERSION "21" + +/* +** PFORTH_FILE_VERSION changes when incompatible changes are made +** in the ".dic" file format. +** +** FV3 - 950225 - Use ABS_TO_CODEREL for CodePtr. See file "pf_save.c". +** FV4 - 950309 - Added NameSize and CodeSize to pfSaveForth(). +** FV5 - 950316 - Added Floats and reserved words. +** FV6 - 961213 - Added ID_LOCAL_PLUSSTORE, ID_COLON_P, etc. +** FV7 - 971203 - Added ID_FILL, (1LOCAL@), etc., ran out of reserved, resorted. +** FV8 - 980818 - Added Endian flag. +*/ +#define PF_FILE_VERSION (8) /* Bump this whenever primitives added. */ +#define PF_EARLIEST_FILE_VERSION (8) /* earliest one still compatible */ + +/*************************************************************** +** Sizes and other constants +***************************************************************/ + +#define TIB_SIZE (256) + +#ifndef FALSE + #define FALSE (0) +#endif +#ifndef TRUE + #define TRUE (1) +#endif + +#define FFALSE (0) +#define FTRUE (-1) +#define BLANK (' ') + +#define FLAG_PRECEDENCE (0x80) +#define FLAG_IMMEDIATE (0x40) +#define FLAG_SMUDGE (0x20) +#define MASK_NAME_SIZE (0x1F) + +/* Debug TRACE flags */ +#define TRACE_INNER (0x0002) +#define TRACE_COMPILE (0x0004) +#define TRACE_SPECIAL (0x0008) + +/* Numeric types returned by NUMBER? */ +#define NUM_TYPE_BAD (0) +#define NUM_TYPE_SINGLE (1) +#define NUM_TYPE_DOUBLE (2) +#define NUM_TYPE_FLOAT (3) + +#define CREATE_BODY_OFFSET (3*sizeof(cell)) + +/*************************************************************** +** Primitive Token IDS +** Do NOT change the order of these IDs or dictionary files will break! +***************************************************************/ +enum cforth_primitive_ids +{ + ID_EXIT = 0, /* ID_EXIT must always be zero. */ +/* Do NOT change the order of these IDs or dictionary files will break! */ + ID_1MINUS, + ID_1PLUS, + ID_2DUP, + ID_2LITERAL, + ID_2LITERAL_P, + ID_2MINUS, + ID_2OVER, + ID_2PLUS, + ID_2SWAP, + ID_2_R_FETCH, + ID_2_R_FROM, + ID_2_TO_R, + ID_ACCEPT, + ID_ALITERAL, + ID_ALITERAL_P, + ID_ALLOCATE, + ID_AND, + ID_ARSHIFT, + ID_BAIL, + ID_BODY_OFFSET, + ID_BRANCH, + ID_BYE, + ID_CALL_C, + ID_CFETCH, + ID_CMOVE, + ID_CMOVE_UP, + ID_COLON, + ID_COLON_P, + ID_COMPARE, + ID_COMP_EQUAL, + ID_COMP_GREATERTHAN, + ID_COMP_LESSTHAN, + ID_COMP_NOT_EQUAL, + ID_COMP_U_GREATERTHAN, + ID_COMP_U_LESSTHAN, + ID_COMP_ZERO_EQUAL, + ID_COMP_ZERO_GREATERTHAN, + ID_COMP_ZERO_LESSTHAN, + ID_COMP_ZERO_NOT_EQUAL, + ID_CR, + ID_CREATE, + ID_CREATE_P, + ID_CSTORE, + ID_DEFER, + ID_DEFER_P, + ID_DEPTH, + ID_DIVIDE, + ID_DOT, + ID_DOTS, + ID_DO_P, + ID_DROP, + ID_DUMP, + ID_DUP, + ID_D_MINUS, + ID_D_MTIMES, + ID_D_MUSMOD, + ID_D_PLUS, + ID_D_UMSMOD, + ID_D_UMTIMES, + ID_EMIT, + ID_EMIT_P, + ID_EOL, + ID_ERRORQ_P, + ID_EXECUTE, + ID_FETCH, + ID_FILE_CLOSE, + ID_FILE_CREATE, + ID_FILE_OPEN, + ID_FILE_POSITION, + ID_FILE_READ, + ID_FILE_REPOSITION, + ID_FILE_RO, + ID_FILE_RW, + ID_FILE_SIZE, + ID_FILE_WRITE, + ID_FILL, + ID_FIND, + ID_FINDNFA, + ID_FLUSHEMIT, + ID_FREE, + ID_HERE, + ID_NUMBERQ_P, + ID_I, + ID_INCLUDE_FILE, + ID_J, + ID_KEY, + ID_LEAVE_P, + ID_LITERAL, + ID_LITERAL_P, + ID_LOADSYS, + ID_LOCAL_COMPILER, + ID_LOCAL_ENTRY, + ID_LOCAL_EXIT, + ID_LOCAL_FETCH, + ID_LOCAL_FETCH_1, + ID_LOCAL_FETCH_2, + ID_LOCAL_FETCH_3, + ID_LOCAL_FETCH_4, + ID_LOCAL_FETCH_5, + ID_LOCAL_FETCH_6, + ID_LOCAL_FETCH_7, + ID_LOCAL_FETCH_8, + ID_LOCAL_PLUSSTORE, + ID_LOCAL_STORE, + ID_LOCAL_STORE_1, + ID_LOCAL_STORE_2, + ID_LOCAL_STORE_3, + ID_LOCAL_STORE_4, + ID_LOCAL_STORE_5, + ID_LOCAL_STORE_6, + ID_LOCAL_STORE_7, + ID_LOCAL_STORE_8, + ID_LOOP_P, + ID_LSHIFT, + ID_MAX, + ID_MIN, + ID_MINUS, + ID_NAME_TO_PREVIOUS, + ID_NAME_TO_TOKEN, + ID_NOOP, + ID_NUMBERQ, + ID_OR, + ID_OVER, + ID_PICK, + ID_PLUS, + ID_PLUSLOOP_P, + ID_PLUS_STORE, + ID_QDO_P, + ID_QDUP, + ID_QTERMINAL, + ID_QUIT_P, + ID_REFILL, + ID_RESIZE, + ID_RESTORE_INPUT, + ID_ROLL, + ID_ROT, + ID_RP_FETCH, + ID_RP_STORE, + ID_RSHIFT, + ID_R_DROP, + ID_R_FETCH, + ID_R_FROM, + ID_SAVE_FORTH_P, + ID_SAVE_INPUT, + ID_SCAN, + ID_SEMICOLON, + ID_SKIP, + ID_SOURCE, + ID_SOURCE_ID, + ID_SOURCE_ID_POP, + ID_SOURCE_ID_PUSH, + ID_SOURCE_SET, + ID_SP_FETCH, + ID_SP_STORE, + ID_STORE, + ID_SWAP, + ID_TEST1, + ID_TEST2, + ID_TEST3, + ID_TICK, + ID_TIMES, + ID_TO_R, + ID_TYPE, + ID_TYPE_P, + ID_VAR_BASE, + ID_VAR_CODE_BASE, + ID_VAR_CODE_LIMIT, + ID_VAR_CONTEXT, + ID_VAR_DP, + ID_VAR_ECHO, + ID_VAR_HEADERS_BASE, + ID_VAR_HEADERS_LIMIT, + ID_VAR_HEADERS_PTR, + ID_VAR_NUM_TIB, + ID_VAR_OUT, + ID_VAR_RETURN_CODE, + ID_VAR_SOURCE_ID, + ID_VAR_STATE, + ID_VAR_TO_IN, + ID_VAR_TRACE_FLAGS, + ID_VAR_TRACE_LEVEL, + ID_VAR_TRACE_STACK, + ID_VLIST, + ID_WORD, + ID_WORD_FETCH, + ID_WORD_STORE, + ID_XOR, + ID_ZERO_BRANCH, +/* If you add a word here, take away one reserved word below. */ +#ifdef PF_SUPPORT_FP +/* Only reserve space if we are adding FP so that we can detect +** unsupported primitives when loading dictionary. +*/ + ID_RESERVED01, + ID_RESERVED02, + ID_RESERVED03, + ID_RESERVED04, + ID_RESERVED05, + ID_RESERVED06, + ID_RESERVED07, + ID_RESERVED08, + ID_RESERVED09, + ID_RESERVED10, + ID_RESERVED11, + ID_RESERVED12, + ID_RESERVED13, + ID_RESERVED14, + ID_RESERVED15, + ID_RESERVED16, + ID_RESERVED17, + ID_RESERVED18, + ID_RESERVED19, + ID_RESERVED20, + ID_FP_D_TO_F, + ID_FP_FSTORE, + ID_FP_FTIMES, + ID_FP_FPLUS, + ID_FP_FMINUS, + ID_FP_FSLASH, + ID_FP_F_ZERO_LESS_THAN, + ID_FP_F_ZERO_EQUALS, + ID_FP_F_LESS_THAN, + ID_FP_F_TO_D, + ID_FP_FFETCH, + ID_FP_FDEPTH, + ID_FP_FDROP, + ID_FP_FDUP, + ID_FP_FLITERAL, + ID_FP_FLITERAL_P, + ID_FP_FLOAT_PLUS, + ID_FP_FLOATS, + ID_FP_FLOOR, + ID_FP_FMAX, + ID_FP_FMIN, + ID_FP_FNEGATE, + ID_FP_FOVER, + ID_FP_FROT, + ID_FP_FROUND, + ID_FP_FSWAP, + ID_FP_FSTAR_STAR, + ID_FP_FABS, + ID_FP_FACOS, + ID_FP_FACOSH, + ID_FP_FALOG, + ID_FP_FASIN, + ID_FP_FASINH, + ID_FP_FATAN, + ID_FP_FATAN2, + ID_FP_FATANH, + ID_FP_FCOS, + ID_FP_FCOSH, + ID_FP_FLN, + ID_FP_FLNP1, + ID_FP_FLOG, + ID_FP_FSIN, + ID_FP_FSINCOS, + ID_FP_FSINH, + ID_FP_FSQRT, + ID_FP_FTAN, + ID_FP_FTANH, + ID_FP_FPICK, +#endif +/* Add new IDs by replacing reserved IDs or extending FP routines. */ +/* Do NOT change the order of these IDs or dictionary files will break! */ + NUM_PRIMITIVES /* This must always be LAST */ +}; + + +/*************************************************************** +** Structures +***************************************************************/ +#define CFTD_FLAG_GO (0x0001) +/* This flag is true when ABORTing to cause the 'C' code to unravel. */ +#define CFTD_FLAG_ABORT (0x0002) + +typedef struct cfTaskData +{ + cell *td_StackPtr; /* Primary data stack */ + cell *td_StackBase; + cell *td_StackLimit; + cell *td_ReturnPtr; /* Return stack */ + cell *td_ReturnBase; + cell *td_ReturnLimit; +#ifdef PF_SUPPORT_FP + PF_FLOAT *td_FloatStackPtr; + PF_FLOAT *td_FloatStackBase; + PF_FLOAT *td_FloatStackLimit; +#endif + cell *td_InsPtr; /* Instruction pointer, "PC" */ + cell td_Flags; + FileStream *td_InputStream; +/* Terminal. */ + char td_TIB[TIB_SIZE]; /* Buffer for terminal input. */ + cell td_IN; /* Index into Source */ + cell td_SourceNum; /* #TIB after REFILL */ + char *td_SourcePtr; /* Pointer to TIB or other source. */ + int32 td_LineNumber; /* Incremented on every refill. */ + cell td_OUT; /* Current output column. */ +} cfTaskData; + +typedef struct pfNode +{ + struct pfNode *n_Next; + struct pfNode *n_Prev; +} pfNode; + +/* Structure of header entry in dictionary. These will be stored in dictionary specific endian format*/ +typedef struct cfNameLinks +{ + cell cfnl_PreviousName; /* name relative address of previous */ + ExecToken cfnl_ExecToken; /* Execution token for word. */ +/* Followed by variable length name field. */ +} cfNameLinks; + +#define PF_DICF_ALLOCATED_SEGMENTS ( 0x0001) +typedef struct cfDictionary +{ + pfNode dic_Node; + uint32 dic_Flags; +/* Headers contain pointers to names and dictionary. */ + uint8 *dic_HeaderBaseUnaligned; + uint8 *dic_HeaderBase; + union + { + cell *Cell; + uint8 *Byte; + } dic_HeaderPtr; + uint8 *dic_HeaderLimit; +/* Code segment contains tokenized code and data. */ + uint8 *dic_CodeBaseUnaligned; + uint8 *dic_CodeBase; + union + { + cell *Cell; + uint8 *Byte; + } dic_CodePtr; + uint8 *dic_CodeLimit; +} cfDictionary; + +/* Save state of include when nesting files. */ +typedef struct IncludeFrame +{ + FileStream *inf_FileID; + int32 inf_LineNumber; + int32 inf_SourceNum; + int32 inf_IN; + char inf_SaveTIB[TIB_SIZE]; +} IncludeFrame; + +#define MAX_INCLUDE_DEPTH (8) + +/*************************************************************** +** Prototypes +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +void pfExecuteToken( ExecToken XT ); + +#ifdef __cplusplus +} +#endif + +/*************************************************************** +** External Globals +***************************************************************/ +extern cfTaskData *gCurrentTask; +extern cfDictionary *gCurrentDictionary; +extern char gScratch[TIB_SIZE]; +extern int32 gNumPrimitives; + +extern ExecToken gLocalCompiler_XT; /* CFA of (LOCAL) compiler. */ + +#define DEPTH_AT_COLON_INVALID (-100) +extern int32 gDepthAtColon; + +/* Global variables. */ +extern char *gVarContext; /* Points to last name field. */ +extern cell gVarState; /* 1 if compiling. */ +extern cell gVarBase; /* Numeric Base. */ +extern cell gVarEcho; /* Echo input from file. */ +extern cell gVarEchoAccept; /* Echo input from ACCEPT. */ +extern cell gVarTraceLevel; +extern cell gVarTraceStack; +extern cell gVarTraceFlags; +extern cell gVarQuiet; /* Suppress unnecessary messages, OK, etc. */ +extern cell gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */ + +/*************************************************************** +** Macros +***************************************************************/ + +/* Endian specific macros for creating target dictionaries for machines with +** different endian-ness. +*/ +#if defined(PF_BIG_ENDIAN_DIC) +#define WRITE_FLOAT_DIC WriteFloatBigEndian +#define WRITE_LONG_DIC(addr,data) WriteLongBigEndian((uint32 *)(addr),(uint32)(data)) +#define WRITE_SHORT_DIC(addr,data) WriteShortBigEndian((uint16 *)(addr),(uint16)(data)) +#define READ_FLOAT_DIC ReadFloatBigEndian +#define READ_LONG_DIC(addr) ReadLongBigEndian((uint32 *)(addr)) +#define READ_SHORT_DIC(addr) ReadShortBigEndian((uint16 *)(addr)) +#elif defined(PF_LITTLE_ENDIAN_DIC) +#define WRITE_FLOAT_DIC WriteFloatLittleEndian +#define WRITE_LONG_DIC(addr,data) WriteLongLittleEndian((uint32 *)(addr),(uint32)(data)) +#define WRITE_SHORT_DIC(addr,data) WriteShortLittleEndian((uint16 *)(addr),(uint16)(data)) +#define READ_FLOAT_DIC ReadFloatLittleEndian +#define READ_LONG_DIC(addr) ReadLongLittleEndian((uint32 *)(addr)) +#define READ_SHORT_DIC(addr) ReadShortLittleEndian((uint16 *)(addr)) +#else +#define WRITE_FLOAT_DIC(addr,data) { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); } +#define WRITE_LONG_DIC(addr,data) { *((int32 *)(addr)) = (int32)(data); } +#define WRITE_SHORT_DIC(addr,data) { *((int16 *)(addr)) = (int16)(data); } +#define READ_FLOAT_DIC(addr) ( *((PF_FLOAT *)(addr)) ) +#define READ_LONG_DIC(addr) ( *((int32 *)(addr)) ) +#define READ_SHORT_DIC(addr) ( *((int16 *)(addr)) ) +#endif + +#define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell) +#define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell) +#define CODE_COMMA( N ) WRITE_LONG_DIC(CODE_HERE++,(N)) +#define NAME_BASE (gCurrentDictionary->dic_HeaderBase) +#define CODE_BASE (gCurrentDictionary->dic_CodeBase) +#define NAME_SIZE (gCurrentDictionary->dic_HeaderLimit - gCurrentDictionary->dic_HeaderBase) +#define CODE_SIZE (gCurrentDictionary->dic_CodeLimit - gCurrentDictionary->dic_CodeBase) + +#define IN_CODE_DIC(addr) ( ( ((uint8 *)(addr)) >= gCurrentDictionary->dic_CodeBase) && ( ((uint8 *)(addr)) < gCurrentDictionary->dic_CodeLimit) ) +#define IN_NAME_DIC(addr) ( ( ((uint8 *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8 *)(addr)) < gCurrentDictionary->dic_HeaderLimit) ) +#define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr)) + +/* Address conversion */ +#define ABS_TO_NAMEREL( a ) ((int32) (((uint8 *) a) - NAME_BASE )) +#define ABS_TO_CODEREL( a ) ((int32) (((uint8 *) a) - CODE_BASE )) +#define NAMEREL_TO_ABS( a ) ((char *) (((int32) a) + NAME_BASE)) +#define CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CODE_BASE)) + +/* The check for >0 is only needed for CLONE testing. !!! */ +#define IsTokenPrimitive(xt) ((xt=0)) + +#define SET_ABORT { gCurrentTask->td_Flags |= CFTD_FLAG_ABORT; } +#define CLEAR_ABORT { gCurrentTask->td_Flags &= ~CFTD_FLAG_ABORT; } +#define CHECK_ABORT (gCurrentTask->td_Flags & CFTD_FLAG_ABORT) + +#define FREE_VAR(v) { if (v) { pfFreeMem(v); v = NULL; } } + +#define DATA_STACK_DEPTH (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) +#define DROP_DATA_STACK (gCurrentTask->td_StackPtr++) +#define POP_DATA_STACK (*gCurrentTask->td_StackPtr++) +#define PUSH_DATA_STACK(x) {*(--(gCurrentTask->td_StackPtr)) = (cell) x; } + +/* Force Quad alignment. */ +#define QUADUP(x) (((x)+3)&~3) + +#define MIN(a,b) ( ((a)<(b)) ? (a) : (b) ) +#define MAX(a,b) ( ((a)>(b)) ? (a) : (b) ) + + +#ifndef TOUCH + #define TOUCH(argument) ((void)argument) +#endif + +/*************************************************************** +** I/O related macros +***************************************************************/ + +#define EMIT(c) ioEmit(c) +#define EMIT_CR EMIT('\n'); + +#define DBUG(x) /* PRT(x) */ +#define DBUGX(x) /* DBUG(x) */ + +#define MSG(cs) pfMessage(cs) +#define ERR(x) MSG(x) + +#define MSG_NUM_D(msg,num) { MSG(msg); ffDot((int32) num); EMIT_CR; } +#define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((int32) num); EMIT_CR; } + +#endif /* _pf_guts_h */ + diff --git a/csrc/pf_host.h b/csrc/pf_host.h new file mode 100644 index 0000000..fe44cb2 --- /dev/null +++ b/csrc/pf_host.h @@ -0,0 +1,24 @@ +/* @(#) pf_host.h 96/12/18 1.12 */ +#ifndef _pf_system_h +#define _pf_system_h + +/*************************************************************** +** System Dependant Includes for PForth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +***************************************************************/ + +#endif /* _pf_system_h */ + diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c new file mode 100644 index 0000000..131bfdc --- /dev/null +++ b/csrc/pf_inner.c @@ -0,0 +1,1563 @@ +/* @(#) pf_inner.c 98/03/16 1.7 */ +/*************************************************************** +** Inner Interpreter for Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +** 940502 PLB Creation. +** 940505 PLB More macros. +** 940509 PLB Moved all stack stuff into pfExecuteToken. +** 941014 PLB Converted to flat secondary strusture. +** 941027 rdg added casts to ID_SP_FETCH, ID_RP_FETCH, +** and ID_HERE for armcc +** 941130 PLB Made w@ unsigned +** +***************************************************************/ + +#include "pf_all.h" + +#define SYSTEM_LOAD_FILE "system.fth" + +/*************************************************************** +** Macros for data stack access. +** TOS is cached in a register in pfExecuteToken. +***************************************************************/ + +#define STKPTR (DataStackPtr) +#define M_POP (*(STKPTR++)) +#define M_PUSH(n) {*(--(STKPTR)) = (cell) (n);} +#define M_STACK(n) (STKPTR[n]) + +#define TOS (TopOfStack) +#define PUSH_TOS M_PUSH(TOS) +#define M_DUP PUSH_TOS; +#define M_DROP { TOS = M_POP; } + + +/*************************************************************** +** Macros for Floating Point stack access. +***************************************************************/ +#ifdef PF_SUPPORT_FP +#define FP_STKPTR (FloatStackPtr) +#define M_FP_SPZERO (gCurrentTask->td_FloatStackBase) +#define M_FP_POP (*(FP_STKPTR++)) +#define M_FP_PUSH(n) {*(--(FP_STKPTR)) = (PF_FLOAT) (n);} +#define M_FP_STACK(n) (FP_STKPTR[n]) + +#define FP_TOS (fpTopOfStack) +#define PUSH_FP_TOS M_FP_PUSH(FP_TOS) +#define M_FP_DUP PUSH_FP_TOS; +#define M_FP_DROP { FP_TOS = M_FP_POP; } +#endif + +/*************************************************************** +** Macros for return stack access. +***************************************************************/ + +#define TORPTR (ReturnStackPtr) +#define M_R_DROP {TORPTR++;} +#define M_R_POP (*(TORPTR++)) +#define M_R_PICK(n) (TORPTR[n]) +#define M_R_PUSH(n) {*(--(TORPTR)) = (cell) (n);} + +/*************************************************************** +** Misc Forth macros +***************************************************************/ + +#define M_BRANCH { InsPtr = (cell *) (((uint8 *) InsPtr) + READ_LONG_DIC(InsPtr)); } + +/* Cache top of data stack like in JForth. */ +#ifdef PF_SUPPORT_FP +#define LOAD_REGISTERS \ + { \ + STKPTR = gCurrentTask->td_StackPtr; \ + TOS = M_POP; \ + FP_STKPTR = gCurrentTask->td_FloatStackPtr; \ + FP_TOS = M_FP_POP; \ + TORPTR = gCurrentTask->td_ReturnPtr; \ + } + +#define SAVE_REGISTERS \ + { \ + gCurrentTask->td_ReturnPtr = TORPTR; \ + M_PUSH( TOS ); \ + gCurrentTask->td_StackPtr = STKPTR; \ + M_FP_PUSH( FP_TOS ); \ + gCurrentTask->td_FloatStackPtr = FP_STKPTR; \ + } + +#else +/* Cache top of data stack like in JForth. */ +#define LOAD_REGISTERS \ + { \ + STKPTR = gCurrentTask->td_StackPtr; \ + TOS = M_POP; \ + TORPTR = gCurrentTask->td_ReturnPtr; \ + } + +#define SAVE_REGISTERS \ + { \ + gCurrentTask->td_ReturnPtr = TORPTR; \ + M_PUSH( TOS ); \ + gCurrentTask->td_StackPtr = STKPTR; \ + } +#endif + +#define M_DOTS \ + SAVE_REGISTERS; \ + ffDotS( ); \ + LOAD_REGISTERS; + +#define DO_VAR(varname) { PUSH_TOS; TOS = (cell) &varname; } + +#define M_QUIT \ + { \ + ResetForthTask( ); \ + LOAD_REGISTERS; \ + } + +/*************************************************************** +** Other macros +***************************************************************/ + +#define BINARY_OP( op ) { TOS = M_POP op TOS; } + +#define endcase break + +#if defined(PF_NO_SHELL) || !defined(PF_SUPPORT_TRACE) + #define TRACENAMES /* no names */ +#else +/* Display name of executing routine. */ +static void TraceNames( ExecToken Token, int32 Level ) +{ + char *DebugName; + int32 i; + + if( ffTokenToName( Token, &DebugName ) ) + { + cell NumSpaces; + if( gCurrentTask->td_OUT > 0 ) EMIT_CR; + EMIT( '>' ); + for( i=0; itd_OUT; + for( i=0; i < NumSpaces; i++ ) + { + EMIT( ' ' ); + } + ffDotS(); +/* No longer needed? gCurrentTask->td_OUT = 0; */ /* !!! Hack for ffDotS() */ + + } + else + { + MSG_NUM_H("Couldn't find Name for ", Token); + } +} + +#define TRACENAMES \ + if( (gVarTraceLevel > Level) ) \ + { SAVE_REGISTERS; TraceNames( Token, Level ); LOAD_REGISTERS; } +#endif /* PF_NO_SHELL */ + +/* Use local copy of CODE_BASE for speed. */ +#define LOCAL_CODEREL_TO_ABS( a ) ((cell *) (((int32) a) + CodeBase)) + +/**************************************************************/ +void pfExecuteToken( ExecToken XT ) +{ + register cell TopOfStack; /* Cache for faster execution. */ + register cell *DataStackPtr; + register cell *ReturnStackPtr; +#ifdef PF_SUPPORT_FP + register PF_FLOAT fpTopOfStack; + PF_FLOAT *FloatStackPtr; + register PF_FLOAT fpScratch; + register PF_FLOAT fpTemp; +#endif + register cell *InsPtr = NULL; + register cell Token; + register cell Scratch; +#ifdef PF_SUPPORT_TRACE + register int32 Level = 0; +#endif + cell *LocalsPtr = NULL; + cell Temp; + cell *InitialReturnStack; + cell FakeSecondary[2]; + char *CharPtr; + cell *CellPtr; + FileStream *FileID; + uint8 *CodeBase = CODE_BASE; + +/* +** Initialize FakeSecondary this way to avoid having stuff in the data section, +** which is not supported for some embedded system loaders. +*/ + FakeSecondary[0] = 0; + FakeSecondary[1] = ID_EXIT; /* For EXECUTE */ + +/* Move data from task structure to registers for speed. */ + LOAD_REGISTERS; + InitialReturnStack = TORPTR; + Token = XT; + + do + { +DBUG(("pfExecuteToken: Token = 0x%x\n", Token )); + + +/* --------------------------------------------------------------- */ +/* If secondary, thread down code tree until we hit a primitive. */ + while( !IsTokenPrimitive( Token ) ) + { +#ifdef PF_SUPPORT_TRACE + if((gVarTraceFlags & TRACE_INNER) ) + { + MSG("pfExecuteToken: Secondary Token = 0x"); + ffDotHex(Token); + MSG_NUM_H(", InsPtr = 0x", InsPtr); + } + TRACENAMES; +#endif + +/* Save IP on return stack like a JSR. */ + M_R_PUSH( InsPtr ); + +/* Convert execution token to absolute address. */ + InsPtr = (cell *) ( LOCAL_CODEREL_TO_ABS(Token) ); + +/* Fetch token at IP. */ + Token = READ_LONG_DIC(InsPtr++); + +#ifdef PF_SUPPORT_TRACE +/* Bump level for trace display */ + Level++; +#endif + } + + +#ifdef PF_SUPPORT_TRACE + TRACENAMES; +#endif + +/* Execute primitive Token. */ + switch( Token ) + { + + /* Pop up a level. Put first in switch because ID_EXIT==0 */ + case ID_EXIT: + InsPtr = ( cell *) M_R_POP; +#ifdef PF_SUPPORT_TRACE + Level--; +#endif + endcase; + + case ID_1MINUS: TOS--; endcase; + + case ID_1PLUS: TOS++; endcase; + +#ifndef PF_NO_SHELL + case ID_2LITERAL: + ff2Literal( TOS, M_POP ); + M_DROP; + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_2LITERAL_P: +/* hi part stored first, put on top of stack */ + PUSH_TOS; + TOS = READ_LONG_DIC(InsPtr++); + M_PUSH(READ_LONG_DIC(InsPtr++)); + endcase; + + case ID_2MINUS: TOS -= 2; endcase; + + case ID_2PLUS: TOS += 2; endcase; + + + case ID_2OVER: /* ( a b c d -- a b c d a b ) */ + PUSH_TOS; + Scratch = M_STACK(3); + M_PUSH(Scratch); + TOS = M_STACK(3); + endcase; + + case ID_2SWAP: /* ( a b c d -- c d a b ) */ + Scratch = M_STACK(0); /* c */ + M_STACK(0) = M_STACK(2); /* a */ + M_STACK(2) = Scratch; /* c */ + Scratch = TOS; /* d */ + TOS = M_STACK(1); /* b */ + M_STACK(1) = Scratch; /* d */ + endcase; + + case ID_2DUP: /* ( a b -- a b a b ) */ + PUSH_TOS; + Scratch = M_STACK(1); + M_PUSH(Scratch); + endcase; + + case ID_2_R_FETCH: + PUSH_TOS; + M_PUSH( (*(TORPTR+1)) ); + TOS = (*(TORPTR)); + endcase; + + case ID_2_R_FROM: + PUSH_TOS; + TOS = M_R_POP; + M_PUSH( M_R_POP ); + endcase; + + case ID_2_TO_R: + M_R_PUSH( M_POP ); + M_R_PUSH( TOS ); + M_DROP; + endcase; + + case ID_ACCEPT: /* ( c-addr +n1 -- +n2 ) */ + CharPtr = (char *) M_POP; + TOS = ioAccept( CharPtr, TOS, PF_STDIN ); + endcase; + +#ifndef PF_NO_SHELL + case ID_ALITERAL: + ffALiteral( ABS_TO_CODEREL(TOS) ); + M_DROP; + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_ALITERAL_P: + PUSH_TOS; + TOS = (cell) LOCAL_CODEREL_TO_ABS( READ_LONG_DIC(InsPtr++) ); + endcase; + +/* Allocate some extra and put validation identifier at base */ +#define PF_MEMORY_VALIDATOR (0xA81B4D69) + case ID_ALLOCATE: + CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) ); + if( CellPtr ) + { +/* This was broken into two steps because different compilers incremented +** CellPtr before or after the XOR step. */ + Temp = (int32)CellPtr ^ PF_MEMORY_VALIDATOR; + *CellPtr++ = Temp; + M_PUSH( (cell) CellPtr ); + TOS = 0; + } + else + { + M_PUSH( 0 ); + TOS = -1; /* FIXME Fix error code. */ + } + endcase; + + case ID_AND: BINARY_OP( & ); endcase; + + case ID_ARSHIFT: BINARY_OP( >> ); endcase; /* Arithmetic right shift */ + + case ID_BODY_OFFSET: + PUSH_TOS; + TOS = CREATE_BODY_OFFSET; + endcase; + +/* Branch is followed by an offset relative to address of offset. */ + case ID_BRANCH: +DBUGX(("Before Branch: IP = 0x%x\n", InsPtr )); + M_BRANCH; +DBUGX(("After Branch: IP = 0x%x\n", InsPtr )); + endcase; + +/* Clear GO flag to tell QUIT to return. */ + case ID_BYE: + gCurrentTask->td_Flags &= ~CFTD_FLAG_GO; + endcase; + + case ID_BAIL: + MSG("Emergency exit.\n"); + EXIT(1); + endcase; + + case ID_CALL_C: + SAVE_REGISTERS; + Scratch = READ_LONG_DIC(InsPtr++); + CallUserFunction( Scratch & 0xFFFF, + (Scratch >> 31) & 1, + (Scratch >> 24) & 0x7F ); + LOAD_REGISTERS; + endcase; + + case ID_CFETCH: TOS = *((uint8 *) TOS); endcase; + + case ID_CMOVE: /* ( src dst n -- ) */ + { + register char *DstPtr = (char *) M_POP; /* dst */ + CharPtr = (char *) M_POP; /* src */ + for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ ) + { + *DstPtr++ = *CharPtr++; + } + M_DROP; + } + endcase; + + case ID_CMOVE_UP: /* ( src dst n -- ) */ + { + register char *DstPtr = ((char *) M_POP) + TOS; /* dst */ + CharPtr = ((char *) M_POP) + TOS;; /* src */ + for( Scratch=0; (uint32) Scratch < (uint32) TOS ; Scratch++ ) + { + *(--DstPtr) = *(--CharPtr); + } + M_DROP; + } + endcase; + +#ifndef PF_NO_SHELL + case ID_COLON: + ffColon( ); + endcase; + case ID_COLON_P: /* ( $name xt -- ) */ + CreateDicEntry( TOS, (char *) M_POP, 0 ); + M_DROP; + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_COMPARE: + { + const char *s1, *s2; + int32 len1; + s2 = (const char *) M_POP; + len1 = M_POP; + s1 = (const char *) M_POP; + TOS = ffCompare( s1, len1, s2, TOS ); + } + endcase; + +/* ( a b -- flag , Comparisons ) */ + case ID_COMP_EQUAL: + TOS = ( TOS == M_POP ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_NOT_EQUAL: + TOS = ( TOS != M_POP ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_GREATERTHAN: + TOS = ( M_POP > TOS ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_LESSTHAN: + TOS = ( M_POP < TOS ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_U_GREATERTHAN: + TOS = ( ((uint32)M_POP) > ((uint32)TOS) ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_U_LESSTHAN: + TOS = ( ((uint32)M_POP) < ((uint32)TOS) ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_ZERO_EQUAL: + TOS = ( TOS == 0 ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_ZERO_NOT_EQUAL: + TOS = ( TOS != 0 ) ? FTRUE : FALSE ; + endcase; + case ID_COMP_ZERO_GREATERTHAN: + TOS = ( TOS > 0 ) ? FTRUE : FFALSE ; + endcase; + case ID_COMP_ZERO_LESSTHAN: + TOS = ( TOS < 0 ) ? FTRUE : FFALSE ; + endcase; + + case ID_CR: + EMIT_CR; + endcase; + +#ifndef PF_NO_SHELL + case ID_CREATE: + ffCreate(); + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_CREATE_P: + PUSH_TOS; +/* Put address of body on stack. Insptr points after code start. */ + TOS = (cell) ((char *)InsPtr - sizeof(cell) + CREATE_BODY_OFFSET ); + endcase; + + case ID_CSTORE: /* ( c caddr -- ) */ + *((uint8 *) TOS) = (uint8) M_POP; + M_DROP; + endcase; + +/* Double precision add. */ + case ID_D_PLUS: /* D+ ( al ah bl bh -- sl sh ) */ + { + register ucell ah,al,bl,sh,sl; +#define bh TOS + bl = M_POP; + ah = M_POP; + al = M_POP; + sh = 0; + sl = al + bl; + if( sl < bl ) sh = 1; /* Carry */ + sh += ah + bh; + M_PUSH( sl ); + TOS = sh; +#undef bh + } + endcase; + +/* Double precision subtract. */ + case ID_D_MINUS: /* D- ( al ah bl bh -- sl sh ) */ + { + register ucell ah,al,bl,sh,sl; +#define bh TOS + bl = M_POP; + ah = M_POP; + al = M_POP; + sh = 0; + sl = al - bl; + if( al < bl ) sh = 1; /* Borrow */ + sh = ah - bh - sh; + M_PUSH( sl ); + TOS = sh; +#undef bh + } + endcase; + +/* Perform 32*32 bit multiply for 64 bit result, using shift and add. */ +/* This seems crazy. There must be an easier way. !!! */ + case ID_D_UMTIMES: /* M* ( a b -- pl ph ) */ + { + register ucell a, b; + register ucell pl, ph, mi; + a = M_POP; + b = TOS; + ph = pl = 0; + for( mi=0; mi<32; mi++ ) + { +/* Shift B to left, checking bits. */ +/* Shift Product to left and add AP. */ + ph = (ph << 1) | (pl >> 31); /* 64 bit shift */ + pl = pl << 1; + if( b & 0x80000000 ) + { + register ucell temp; + temp = pl + a; + if( (temp < pl) || (temp < a) ) ph += 1; /* Carry */ + pl = temp; + } + b = b << 1; +DBUG(("UM* : mi = %d, a = 0x%08x, b = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, a, b, ph, pl )); + } + M_PUSH( pl ); + TOS = ph; + } + endcase; + +/* Perform 32*32 bit multiply for 64 bit result, using shift and add. */ +/* This seems crazy. There must be an easier way. !!! */ + case ID_D_MTIMES: /* M* ( a b -- pl ph ) */ + { + register cell a, b; + register ucell pl, ph, mi, ap, bp; + a = M_POP; + ap = (a < 0) ? -a : a ; /* Positive A */ + b = TOS; + bp = (b < 0) ? -b : b ; /* Positive B */ + ph = pl = 0; + for( mi=0; mi<32; mi++ ) + { +/* Shift B to left, checking bits. */ +/* Shift Product to left and add AP. */ + ph = (ph << 1) | (pl >> 31); /* 64 bit shift */ + pl = pl << 1; + if( bp & 0x80000000 ) + { + register ucell temp; + temp = pl + ap; + if( (temp < pl) && (temp < ap) ) ph += 1; /* Carry */ + pl = temp; + } + bp = bp << 1; +DBUG(("M* : mi = %d, ap = 0x%08x, bp = 0x%08x, ph = 0x%08x, pl = 0x%08x\n", mi, ap, bp, ph, pl )); + } +/* Negate product if one operand negative. */ + if( ((a ^ b) & 0x80000000) ) + { + pl = 0-pl; +DBUG(("M* : -pl = 0x%08x\n", pl )); + if( pl & 0x80000000 ) + { + ph = -1 - ph; /* Borrow */ + } + else + { + ph = 0 - ph; + } +DBUG(("M* : -ph = 0x%08x\n", ph )); + } + M_PUSH( pl ); + TOS = ph; + } + endcase; + +#define DULT(du1l,du1h,du2l,du2h) ( (du2h> 1) | (bh << 31); + bh = bh >> 1; + } + if( !DULT(al,ah,bl,bh) ) + { + + al = al - bl; + q |= 1; + } + M_PUSH( al ); /* rem */ + TOS = q; + } + endcase; + +/* Perform 64/32 bit divide for 64 bit result, using shift and subtract. */ + case ID_D_MUSMOD: /* MU/MOD ( al am bdiv -- rem ql qh ) */ + { + register ucell ah,am,al,ql,qh,di; +#define bdiv ((ucell)TOS) + ah = 0; + am = M_POP; + al = M_POP; + qh = ql = 0; + for( di=0; di<64; di++ ) + { + if( bdiv <= ah ) + { + ah = ah - bdiv; + ql |= 1; + } + qh = (qh << 1) | (ql >> 31); + ql = ql << 1; + ah = (ah << 1) | (am >> 31); + am = (am << 1) | (al >> 31); + al = al << 1; +DBUG(("XX ah,m,l = 0x%8x,%8x,%8x - qh,l = 0x%8x,%8x\n", ah,am,al, qh,ql )); + } + if( bdiv <= ah ) + { + ah = ah - bdiv; + ql |= 1; + } + M_PUSH( ah ); /* rem */ + M_PUSH( ql ); + TOS = qh; +#undef bdiv + } + endcase; + +#ifndef PF_NO_SHELL + case ID_DEFER: + ffDefer( ); + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_DEFER_P: + endcase; + + case ID_DEPTH: + PUSH_TOS; + TOS = gCurrentTask->td_StackBase - STKPTR; + endcase; + + case ID_DIVIDE: BINARY_OP( / ); endcase; + + case ID_DOT: + ffDot( TOS ); + M_DROP; + endcase; + + case ID_DOTS: + M_DOTS; + endcase; + + case ID_DROP: M_DROP; endcase; + + case ID_DUMP: + Scratch = M_POP; + DumpMemory( (char *) Scratch, TOS ); + M_DROP; + endcase; + + case ID_DUP: M_DUP; endcase; + + case ID_DO_P: /* ( limit start -- ) ( R: -- start limit ) */ + M_R_PUSH( TOS ); + M_R_PUSH( M_POP ); + M_DROP; + endcase; + + case ID_EOL: /* ( -- end_of_line_char ) */ + PUSH_TOS; + TOS = (cell) '\n'; + endcase; + + case ID_ERRORQ_P: /* ( flag num -- , quit if flag true ) */ + Scratch = TOS; + M_DROP; + if(TOS) + { + MSG_NUM_D("Error: ", (int32) Scratch); + M_QUIT; + } + else + { + M_DROP; + } + endcase; + + case ID_EMIT_P: + EMIT( (char) TOS ); + M_DROP; + endcase; + + case ID_EXECUTE: +/* Save IP on return stack like a JSR. */ + M_R_PUSH( InsPtr ); +#ifdef PF_SUPPORT_TRACE +/* Bump level for trace. */ + Level++; +#endif + if( IsTokenPrimitive( TOS ) ) + { + WRITE_LONG_DIC( (cell *) &FakeSecondary[0], TOS); /* Build a fake secondary and execute it. */ + InsPtr = &FakeSecondary[0]; + } + else + { + InsPtr = (cell *) LOCAL_CODEREL_TO_ABS(TOS); + } + M_DROP; + endcase; + + case ID_FETCH: +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + TOS = (cell) READ_LONG_DIC((cell *)TOS); + } + else + { + TOS = *((cell *)TOS); + } +#else + TOS = *((cell *)TOS); +#endif + endcase; + + case ID_FILE_CREATE: /* ( c-addr u fam -- fid ior ) */ +/* Build NUL terminated name string. */ + Scratch = M_POP; /* u */ + Temp = M_POP; /* caddr */ + if( Scratch < TIB_SIZE-2 ) + { + pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch ); + gScratch[Scratch] = '\0'; + DBUG(("Create file = %s\n", gScratch )); + FileID = sdOpenFile( gScratch, PF_FAM_CREATE ); + TOS = ( FileID == NULL ) ? -1 : 0 ; + M_PUSH( (cell) FileID ); + } + else + { + ERR("Filename too large for name buffer.\n"); + M_PUSH( 0 ); + TOS = -2; + } + endcase; + + case ID_FILE_OPEN: /* ( c-addr u fam -- fid ior ) */ +/* Build NUL terminated name string. */ + Scratch = M_POP; /* u */ + Temp = M_POP; /* caddr */ + if( Scratch < TIB_SIZE-2 ) + { + const char *fam; + + pfCopyMemory( gScratch, (char *) Temp, (uint32) Scratch ); + gScratch[Scratch] = '\0'; + DBUG(("Open file = %s\n", gScratch )); + fam = ( TOS == PF_FAM_READ_ONLY ) ? PF_FAM_OPEN_RO : PF_FAM_OPEN_RW ; + FileID = sdOpenFile( gScratch, fam ); + TOS = ( FileID == NULL ) ? -1 : 0 ; + M_PUSH( (cell) FileID ); + } + else + { + ERR("Filename too large for name buffer.\n"); + M_PUSH( 0 ); + TOS = -2; + } + endcase; + + case ID_FILE_CLOSE: /* ( fid -- ior ) */ + TOS = sdCloseFile( (FileStream *) TOS ); + endcase; + + case ID_FILE_READ: /* ( addr len fid -- u2 ior ) */ + FileID = (FileStream *) TOS; + Scratch = M_POP; + CharPtr = (char *) M_POP; + Temp = sdReadFile( CharPtr, 1, Scratch, FileID ); + M_PUSH(Temp); + TOS = 0; + endcase; + + case ID_FILE_SIZE: /* ( fid -- ud ior ) */ +/* Determine file size by seeking to end and returning position. */ + FileID = (FileStream *) TOS; + Scratch = sdTellFile( FileID ); + sdSeekFile( FileID, 0, PF_SEEK_END ); + M_PUSH( sdTellFile( FileID )); + sdSeekFile( FileID, Scratch, PF_SEEK_SET ); + TOS = (Scratch < 0) ? -4 : 0 ; /* !!! err num */ + endcase; + + case ID_FILE_WRITE: /* ( addr len fid -- ior ) */ + FileID = (FileStream *) TOS; + Scratch = M_POP; + CharPtr = (char *) M_POP; + Temp = sdWriteFile( CharPtr, 1, Scratch, FileID ); + TOS = (Temp != Scratch) ? -3 : 0; + endcase; + + case ID_FILE_REPOSITION: /* ( pos fid -- ior ) */ + FileID = (FileStream *) TOS; + Scratch = M_POP; + TOS = sdSeekFile( FileID, Scratch, PF_SEEK_SET ); + endcase; + + case ID_FILE_POSITION: /* ( pos fid -- ior ) */ + M_PUSH( sdTellFile( (FileStream *) TOS )); + TOS = 0; + endcase; + + case ID_FILE_RO: /* ( -- fam ) */ + PUSH_TOS; + TOS = PF_FAM_READ_ONLY; + endcase; + + case ID_FILE_RW: /* ( -- fam ) */ + PUSH_TOS; + TOS = PF_FAM_READ_WRITE; + endcase; + + case ID_FILL: /* ( caddr num charval -- ) */ + { + register char *DstPtr; + Temp = M_POP; /* num */ + DstPtr = (char *) M_POP; /* dst */ + for( Scratch=0; (uint32) Scratch < (uint32) Temp ; Scratch++ ) + { + *DstPtr++ = (char) TOS; + } + M_DROP; + } + endcase; + +#ifndef PF_NO_SHELL + case ID_FIND: /* ( $addr -- $addr 0 | xt +-1 ) */ + TOS = ffFind( (char *) TOS, (ExecToken *) &Temp ); + M_PUSH( Temp ); + endcase; + + case ID_FINDNFA: + TOS = ffFindNFA( (const ForthString *) TOS, (const ForthString **) &Temp ); + M_PUSH( (cell) Temp ); + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_FLUSHEMIT: + sdTerminalFlush(); + endcase; + +/* Validate memory before freeing. Clobber validator and first word. */ + case ID_FREE: /* ( addr -- result ) */ + if( TOS == 0 ) + { + ERR("FREE passed NULL!\n"); + TOS = -2; /* FIXME error code */ + } + else + { + CellPtr = (cell *) TOS; + CellPtr--; + if( ((uint32)*CellPtr) != ((uint32)CellPtr ^ PF_MEMORY_VALIDATOR)) + { + TOS = -2; /* FIXME error code */ + } + else + { + CellPtr[0] = 0xDeadBeef; + CellPtr[1] = 0xDeadBeef; + pfFreeMem((char *)CellPtr); + TOS = 0; + } + } + endcase; + +#include "pfinnrfp.h" + + case ID_HERE: + PUSH_TOS; + TOS = (cell)CODE_HERE; + endcase; + + case ID_NUMBERQ_P: /* ( addr -- 0 | n 1 ) */ +/* Convert using number converter in 'C'. +** Only supports single precision for bootstrap. +*/ + TOS = (cell) ffNumberQ( (char *) TOS, &Temp ); + if( TOS == NUM_TYPE_SINGLE) + { + M_PUSH( Temp ); /* Push single number */ + } + endcase; + + case ID_I: /* ( -- i , DO LOOP index ) */ + PUSH_TOS; + TOS = M_R_PICK(1); + endcase; + +#ifndef PF_NO_SHELL + case ID_INCLUDE_FILE: + FileID = (FileStream *) TOS; + M_DROP; /* Drop now so that INCLUDE has a clean stack. */ + SAVE_REGISTERS; + ffIncludeFile( FileID ); + LOAD_REGISTERS; +#endif /* !PF_NO_SHELL */ + endcase; + + case ID_J: /* ( -- j , second DO LOOP index ) */ + PUSH_TOS; + TOS = M_R_PICK(3); + endcase; + + case ID_KEY: + PUSH_TOS; + TOS = ioKey(); + endcase; + +#ifndef PF_NO_SHELL + case ID_LITERAL: + ffLiteral( TOS ); + M_DROP; + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_LITERAL_P: + DBUG(("ID_LITERAL_P: InsPtr = 0x%x, *InsPtr = 0x%x\n", InsPtr, *InsPtr )); + PUSH_TOS; + TOS = READ_LONG_DIC(InsPtr++); + endcase; + +#ifndef PF_NO_SHELL + case ID_LOCAL_COMPILER: DO_VAR(gLocalCompiler_XT); endcase; +#endif /* !PF_NO_SHELL */ + + case ID_LOCAL_FETCH: /* ( i -- n , fetch from local ) */ + TOS = *(LocalsPtr - TOS); + endcase; + +#define LOCAL_FETCH_N(num) \ + case ID_LOCAL_FETCH_##num: /* ( -- n , fetch from local ) */ \ + PUSH_TOS; \ + TOS = *(LocalsPtr -(num)); \ + endcase; + + LOCAL_FETCH_N(1); + LOCAL_FETCH_N(2); + LOCAL_FETCH_N(3); + LOCAL_FETCH_N(4); + LOCAL_FETCH_N(5); + LOCAL_FETCH_N(6); + LOCAL_FETCH_N(7); + LOCAL_FETCH_N(8); + + case ID_LOCAL_STORE: /* ( n i -- , store n in local ) */ + *(LocalsPtr - TOS) = M_POP; + M_DROP; + endcase; + +#define LOCAL_STORE_N(num) \ + case ID_LOCAL_STORE_##num: /* ( n -- , store n in local ) */ \ + *(LocalsPtr - (num)) = TOS; \ + M_DROP; \ + endcase; + + LOCAL_STORE_N(1); + LOCAL_STORE_N(2); + LOCAL_STORE_N(3); + LOCAL_STORE_N(4); + LOCAL_STORE_N(5); + LOCAL_STORE_N(6); + LOCAL_STORE_N(7); + LOCAL_STORE_N(8); + + case ID_LOCAL_PLUSSTORE: /* ( n i -- , add n to local ) */ + *(LocalsPtr - TOS) += M_POP; + M_DROP; + endcase; + + case ID_LOCAL_ENTRY: /* ( x0 x1 ... xn n -- ) */ + /* create local stack frame */ + { + int32 i = TOS; + cell *lp; + DBUG(("LocalEntry: n = %d\n", TOS)); + /* End of locals. Create stack frame */ + DBUG(("LocalEntry: before RP@ = 0x%x, LP = 0x%x\n", + TORPTR, LocalsPtr)); + M_R_PUSH(LocalsPtr); + LocalsPtr = TORPTR; + TORPTR -= TOS; + DBUG(("LocalEntry: after RP@ = 0x%x, LP = 0x%x\n", + TORPTR, LocalsPtr)); + lp = TORPTR; + while(i-- > 0) + { + *lp++ = M_POP; /* Load local vars from stack */ + } + M_DROP; + } + endcase; + + case ID_LOCAL_EXIT: /* cleanup up local stack frame */ + DBUG(("LocalExit: before RP@ = 0x%x, LP = 0x%x\n", + TORPTR, LocalsPtr)); + TORPTR = LocalsPtr; + LocalsPtr = (cell *) M_R_POP; + DBUG(("LocalExit: after RP@ = 0x%x, LP = 0x%x\n", + TORPTR, LocalsPtr)); + endcase; + +#ifndef PF_NO_SHELL + case ID_LOADSYS: + MSG("Load "); MSG(SYSTEM_LOAD_FILE); EMIT_CR; + FileID = sdOpenFile(SYSTEM_LOAD_FILE, "r"); + if( FileID ) + { + SAVE_REGISTERS; + ffIncludeFile( FileID ); + LOAD_REGISTERS; + sdCloseFile( FileID ); + } + else + { + ERR(SYSTEM_LOAD_FILE); ERR(" could not be opened!\n"); + } + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_LEAVE_P: /* ( R: index limit -- ) */ + M_R_DROP; + M_R_DROP; + M_BRANCH; + endcase; + + case ID_LOOP_P: /* ( R: index limit -- | index limit ) */ + Temp = M_R_POP; /* limit */ + Scratch = M_R_POP + 1; /* index */ + if( Scratch == Temp ) + { + InsPtr++; /* skip branch offset, exit loop */ + } + else + { +/* Push index and limit back to R */ + M_R_PUSH( Scratch ); + M_R_PUSH( Temp ); +/* Branch back to just after (DO) */ + M_BRANCH; + } + endcase; + + case ID_LSHIFT: BINARY_OP( << ); endcase; + + case ID_MAX: + Scratch = M_POP; + TOS = ( TOS > Scratch ) ? TOS : Scratch ; + endcase; + + case ID_MIN: + Scratch = M_POP; + TOS = ( TOS < Scratch ) ? TOS : Scratch ; + endcase; + + case ID_MINUS: BINARY_OP( - ); endcase; + +#ifndef PF_NO_SHELL + case ID_NAME_TO_TOKEN: + TOS = (cell) NameToToken((ForthString *)TOS); + endcase; + + case ID_NAME_TO_PREVIOUS: + TOS = (cell) NameToPrevious((ForthString *)TOS); + endcase; +#endif + + case ID_NOOP: + endcase; + + case ID_OR: BINARY_OP( | ); endcase; + + case ID_OVER: + PUSH_TOS; + TOS = M_STACK(1); + endcase; + + case ID_PICK: /* ( ... n -- sp(n) ) */ + TOS = M_STACK(TOS); + endcase; + + case ID_PLUS: BINARY_OP( + ); endcase; + + case ID_PLUS_STORE: /* ( n addr -- , add n to *addr ) */ +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + Scratch = READ_LONG_DIC((cell *)TOS); + Scratch += M_POP; + WRITE_LONG_DIC((cell *)TOS,Scratch); + } + else + { + *((cell *)TOS) += M_POP; + } +#else + *((cell *)TOS) += M_POP; +#endif + M_DROP; + endcase; + + case ID_PLUSLOOP_P: /* ( delta -- ) ( R: index limit -- | index limit ) */ + { + ucell OldIndex, NewIndex, Limit; + + Limit = M_R_POP; + OldIndex = M_R_POP; + NewIndex = OldIndex + TOS; /* add TOS to index, not 1 */ +/* Do indices cross boundary between LIMIT-1 and LIMIT ? */ + if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) || + ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) ) + { + InsPtr++; /* skip branch offset, exit loop */ + } + else + { +/* Push index and limit back to R */ + M_R_PUSH( NewIndex ); + M_R_PUSH( Limit ); +/* Branch back to just after (DO) */ + M_BRANCH; + } + M_DROP; + } + endcase; + + case ID_QDO_P: /* (?DO) ( limit start -- ) ( R: -- start limit ) */ + Scratch = M_POP; /* limit */ + if( Scratch == TOS ) + { +/* Branch to just after (LOOP) */ + M_BRANCH; + } + else + { + M_R_PUSH( TOS ); + M_R_PUSH( Scratch ); + InsPtr++; /* skip branch offset, enter loop */ + } + M_DROP; + endcase; + + case ID_QDUP: if( TOS ) M_DUP; endcase; + + case ID_QTERMINAL: /* WARNING: Typically not implemented! */ + PUSH_TOS; + TOS = sdQueryTerminal(); + endcase; + + case ID_QUIT_P: /* Stop inner interpreter, go back to user. */ +#ifdef PF_SUPPORT_TRACE + Level = 0; +#endif + ffAbort(); + endcase; + + case ID_R_DROP: + M_R_DROP; + endcase; + + case ID_R_FETCH: + PUSH_TOS; + TOS = (*(TORPTR)); + endcase; + + case ID_R_FROM: + PUSH_TOS; + TOS = M_R_POP; + endcase; + + case ID_REFILL: + PUSH_TOS; + TOS = ffRefill(); + endcase; + +/* Resize memory allocated by ALLOCATE. */ + case ID_RESIZE: /* ( addr1 u -- addr2 result ) */ + { + cell *FreePtr; + + FreePtr = (cell *) ( M_POP - sizeof(cell) ); + if( ((uint32)*FreePtr) != ((uint32)FreePtr ^ PF_MEMORY_VALIDATOR)) + { + M_PUSH( 0 ); + TOS = -3; + } + else + { + /* Try to allocate. */ + CellPtr = (cell *) pfAllocMem( TOS + sizeof(cell) ); + if( CellPtr ) + { + /* Copy memory including validation. */ + pfCopyMemory( (char *) CellPtr, (char *) FreePtr, TOS + sizeof(cell) ); + *CellPtr++ = ((int32)CellPtr ^ PF_MEMORY_VALIDATOR); + M_PUSH( (cell) ++CellPtr ); + TOS = 0; + FreePtr[0] = 0xDeadBeef; + FreePtr[1] = 0xDeadBeef; + pfFreeMem((char *) FreePtr); + } + else + { + M_PUSH( 0 ); + TOS = -4; /* FIXME Fix error code. */ + } + } + } + endcase; + +/* +** RP@ and RP! are called secondaries so we must +** account for the return address pushed before calling. +*/ + case ID_RP_FETCH: /* ( -- rp , address of top of return stack ) */ + PUSH_TOS; + TOS = (cell)TORPTR; /* value before calling RP@ */ + endcase; + + case ID_RP_STORE: /* ( rp -- , address of top of return stack ) */ + TORPTR = (cell *) TOS; + M_DROP; + endcase; + + case ID_ROLL: /* ( xu xu-1 xu-1 ... x0 u -- xu-1 xu-1 ... x0 xu ) */ + { + int32 ri; + cell *srcPtr, *dstPtr; + Scratch = M_STACK(TOS); + srcPtr = &M_STACK(TOS-1); + dstPtr = &M_STACK(TOS); + for( ri=0; ri> TOS; } endcase; + +#ifndef PF_NO_SHELL + case ID_SAVE_FORTH_P: /* ( $name Entry NameSize CodeSize -- err ) */ + { + int32 NameSize, CodeSize, EntryPoint; + CodeSize = TOS; + NameSize = M_POP; + EntryPoint = M_POP; + ForthStringToC( gScratch, (char *) M_POP ); + TOS = ffSaveForth( gScratch, EntryPoint, NameSize, CodeSize ); + } + endcase; +#endif + +/* Source Stack +** EVALUATE >IN SourceID=(-1) 1111 +** keyboard >IN SourceID=(0) 2222 +** file >IN lineNumber filePos SourceID=(fileID) +*/ + case ID_SAVE_INPUT: /* FIXME - finish */ + { + } + endcase; + + case ID_SP_FETCH: /* ( -- sp , address of top of stack, sorta ) */ + PUSH_TOS; + TOS = (cell)STKPTR; + endcase; + + case ID_SP_STORE: /* ( sp -- , address of top of stack, sorta ) */ + STKPTR = (cell *) TOS; + M_DROP; + endcase; + + case ID_STORE: /* ( n addr -- , write n to addr ) */ +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + WRITE_LONG_DIC((cell *)TOS,M_POP); + } + else + { + *((cell *)TOS) = M_POP; + } +#else + *((cell *)TOS) = M_POP; +#endif + M_DROP; + endcase; + + case ID_SCAN: /* ( addr cnt char -- addr' cnt' ) */ + Scratch = M_POP; /* cnt */ + Temp = M_POP; /* addr */ + TOS = ffScan( (char *) Temp, Scratch, (char) TOS, &CharPtr ); + M_PUSH((cell) CharPtr); + endcase; + +#ifndef PF_NO_SHELL + case ID_SEMICOLON: + ffSemiColon( ); + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_SKIP: /* ( addr cnt char -- addr' cnt' ) */ + Scratch = M_POP; /* cnt */ + Temp = M_POP; /* addr */ + TOS = ffSkip( (char *) Temp, Scratch, (char) TOS, &CharPtr ); + M_PUSH((cell) CharPtr); + endcase; + + case ID_SOURCE: /* ( -- c-addr num ) */ + PUSH_TOS; + M_PUSH( (cell) gCurrentTask->td_SourcePtr ); + TOS = (cell) gCurrentTask->td_SourceNum; + endcase; + + case ID_SOURCE_SET: /* ( c-addr num -- ) */ + gCurrentTask->td_SourcePtr = (char *) M_POP; + gCurrentTask->td_SourceNum = TOS; + M_DROP; + endcase; + + case ID_SOURCE_ID: + PUSH_TOS; + TOS = ffConvertStreamToSourceID( gCurrentTask->td_InputStream ) ; + endcase; + + case ID_SOURCE_ID_POP: + PUSH_TOS; + TOS = ffConvertStreamToSourceID( ffPopInputStream() ) ; + endcase; + + case ID_SOURCE_ID_PUSH: /* ( source-id -- ) */ + TOS = (cell)ffConvertSourceIDToStream( TOS ); + if( ffPushInputStream((FileStream *) TOS ) ) + { + M_QUIT; + TOUCH(TOS); + } + M_DROP; + endcase; + + case ID_SWAP: + Scratch = TOS; + TOS = *STKPTR; + *STKPTR = Scratch; + endcase; + + case ID_TEST1: + PUSH_TOS; + M_PUSH( 0x11 ); + M_PUSH( 0x22 ); + TOS = 0x33; + endcase; + +#ifndef PF_NO_SHELL + case ID_TICK: + PUSH_TOS; + CharPtr = (char *) ffWord( (char) ' ' ); + TOS = ffFind( CharPtr, (ExecToken *) &Temp ); + if( TOS == 0 ) + { + ERR("' could not find "); + ioType( (char *) CharPtr+1, *CharPtr ); + M_QUIT; + } + else + { + TOS = Temp; + } + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_TIMES: BINARY_OP( * ); endcase; + + case ID_TYPE: + Scratch = M_POP; /* addr */ + ioType( (char *) Scratch, TOS ); + M_DROP; + endcase; + + case ID_TO_R: + M_R_PUSH( TOS ); + M_DROP; + endcase; + + case ID_VAR_BASE: DO_VAR(gVarBase); endcase; + case ID_VAR_CODE_BASE: DO_VAR(gCurrentDictionary->dic_CodeBase); endcase; + case ID_VAR_CODE_LIMIT: DO_VAR(gCurrentDictionary->dic_CodeLimit); endcase; + case ID_VAR_CONTEXT: DO_VAR(gVarContext); endcase; + case ID_VAR_DP: DO_VAR(gCurrentDictionary->dic_CodePtr.Cell); endcase; + case ID_VAR_ECHO: DO_VAR(gVarEcho); endcase; + case ID_VAR_HEADERS_BASE: DO_VAR(gCurrentDictionary->dic_HeaderBase); endcase; + case ID_VAR_HEADERS_LIMIT: DO_VAR(gCurrentDictionary->dic_HeaderLimit); endcase; + case ID_VAR_HEADERS_PTR: DO_VAR(gCurrentDictionary->dic_HeaderPtr.Cell); endcase; + case ID_VAR_NUM_TIB: DO_VAR(gCurrentTask->td_SourceNum); endcase; + case ID_VAR_OUT: DO_VAR(gCurrentTask->td_OUT); endcase; + case ID_VAR_STATE: DO_VAR(gVarState); endcase; + case ID_VAR_TO_IN: DO_VAR(gCurrentTask->td_IN); endcase; + case ID_VAR_TRACE_FLAGS: DO_VAR(gVarTraceFlags); endcase; + case ID_VAR_TRACE_LEVEL: DO_VAR(gVarTraceLevel); endcase; + case ID_VAR_TRACE_STACK: DO_VAR(gVarTraceStack); endcase; + case ID_VAR_RETURN_CODE: DO_VAR(gVarReturnCode); endcase; + + case ID_WORD: + TOS = (cell) ffWord( (char) TOS ); + endcase; + + case ID_WORD_FETCH: /* ( waddr -- w ) */ +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + TOS = (uint16) READ_SHORT_DIC((uint16 *)TOS); + } + else + { + TOS = *((uint16 *)TOS); + } +#else + TOS = *((uint16 *)TOS); +#endif + endcase; + + case ID_WORD_STORE: /* ( w waddr -- ) */ + +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_DICS( TOS ) ) + { + WRITE_SHORT_DIC((uint16 *)TOS,(uint16)M_POP); + } + else + { + *((uint16 *)TOS) = (uint16) M_POP; + } +#else + *((uint16 *)TOS) = (uint16) M_POP; +#endif + M_DROP; + endcase; + + case ID_XOR: BINARY_OP( ^ ); endcase; + + +/* Branch is followed by an offset relative to address of offset. */ + case ID_ZERO_BRANCH: +DBUGX(("Before 0Branch: IP = 0x%x\n", InsPtr )); + if( TOS == 0 ) + { + M_BRANCH; + } + else + { + InsPtr++; /* skip over offset */ + } + M_DROP; +DBUGX(("After 0Branch: IP = 0x%x\n", InsPtr )); + endcase; + + default: + ERR("pfExecuteToken: Unrecognised token = 0x"); + ffDotHex(Token); + ERR(" at 0x"); + ffDotHex((int32) InsPtr); + EMIT_CR; + InsPtr = 0; + endcase; + } + + if(InsPtr) Token = READ_LONG_DIC(InsPtr++); /* Traverse to next token in secondary. */ + +#ifdef PF_DEBUG + M_DOTS; +#endif + + } while( (( InitialReturnStack - TORPTR) > 0 ) && (!CHECK_ABORT) ); + + SAVE_REGISTERS; +} diff --git a/csrc/pf_io.c b/csrc/pf_io.c new file mode 100644 index 0000000..da6e6a3 --- /dev/null +++ b/csrc/pf_io.c @@ -0,0 +1,211 @@ +/* @(#) pf_io.c 96/12/23 1.12 */ +/*************************************************************** +** I/O subsystem for PForth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 941004 PLB Extracted IO calls from pforth_main.c +***************************************************************/ + +#include "pf_all.h" + +/*************************************************************** +** Send single character to output stream. +*/ +void ioEmit( char c ) +{ + int32 Result; + Result = sdTerminalOut(c); + + if( Result < 0 ) EXIT(1); + if(c == '\n') + { + gCurrentTask->td_OUT = 0; + sdTerminalFlush(); + } + else + { + gCurrentTask->td_OUT++; + } +} + +void ioType( const char *s, int32 n ) +{ + int32 i; + + for( i=0; i 0) + { + if( stream == PF_STDIN ) + { + c = ioKey(); +/* If KEY does not echo, then echo here. If using getchar(), KEY will echo. */ +#ifndef PF_KEY_ECHOS + ioEmit( c ); + if( c == '\r') ioEmit('\n'); /* Send LF after CR */ +#endif + } + else + { + c = sdInputChar(stream); + } + switch(c) + { + case EOF: + DBUG(("EOF\n")); + return -1; + break; + + case '\r': + case '\n': + *p++ = (char) c; + DBUGX(("EOL\n")); + goto gotline; + break; + + case BACKSPACE: + if( Len < MaxLen ) /* Don't go beyond beginning of line. */ + { + EMIT(' '); + EMIT(BACKSPACE); + p--; + Len++; + } + break; + + default: + *p++ = (char) c; + Len--; + break; + } + + } +gotline: + *p = '\0'; + + return pfCStringLength( Target ); +} + +#define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); } + +#ifdef PF_NO_CHARIO +int sdTerminalOut( char c ) +{ + TOUCH(c); + return 0; +} +int sdTerminalIn( void ) +{ + return -1; +} +int sdTerminalFlush( void ) +{ + return -1; +} +#endif + +/***********************************************************************************/ +#ifdef PF_NO_FILEIO + +/* Provide stubs for standard file I/O */ + +FileStream *PF_STDIN; +FileStream *PF_STDOUT; + +int32 sdInputChar( FileStream *stream ) +{ + UNIMPLEMENTED("sdInputChar"); + TOUCH(stream); + return -1; +} + +FileStream *sdOpenFile( const char *FileName, const char *Mode ) +{ + UNIMPLEMENTED("sdOpenFile"); + TOUCH(FileName); + TOUCH(Mode); + return NULL; +} +int32 sdFlushFile( FileStream * Stream ) +{ + TOUCH(Stream); + return 0; +} +int32 sdReadFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ) +{ + UNIMPLEMENTED("sdReadFile"); + TOUCH(ptr); + TOUCH(Size); + TOUCH(nItems); + TOUCH(Stream); + return 0; +} +int32 sdWriteFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ) +{ + UNIMPLEMENTED("sdWriteFile"); + TOUCH(ptr); + TOUCH(Size); + TOUCH(nItems); + TOUCH(Stream); + return 0; +} +int32 sdSeekFile( FileStream * Stream, int32 Position, int32 Mode ) +{ + UNIMPLEMENTED("sdSeekFile"); + TOUCH(Stream); + TOUCH(Position); + TOUCH(Mode); + return 0; +} +int32 sdTellFile( FileStream * Stream ) +{ + UNIMPLEMENTED("sdTellFile"); + TOUCH(Stream); + return 0; +} +int32 sdCloseFile( FileStream * Stream ) +{ + UNIMPLEMENTED("sdCloseFile"); + TOUCH(Stream); + return 0; +} +#endif + diff --git a/csrc/pf_io.h b/csrc/pf_io.h new file mode 100644 index 0000000..d07c0f6 --- /dev/null +++ b/csrc/pf_io.h @@ -0,0 +1,146 @@ +/* @(#) pf_io.h 98/01/26 1.2 */ +#ifndef _pf_io_h +#define _pf_io_h + +/*************************************************************** +** Include file for PForth IO +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef PF_NO_CHARIO + int sdTerminalOut( char c ); + int sdTerminalFlush( void ); + int sdTerminalIn( void ); + int sdQueryTerminal( void ); +#else /* PF_NO_CHARIO */ + #ifdef PF_USER_CHARIO +/* Get user prototypes or macros from include file. +** API must match that defined above for the stubs. +*/ +/* If your sdTerminalIn echos, define PF_KEY_ECHOS. */ + #include PF_USER_CHARIO + #else + #define sdTerminalOut(c) putchar(c) + #define sdTerminalIn getchar +/* Since getchar() echos, define PF_KEY_ECHOS. */ + #define PF_KEY_ECHOS +/* + * If you know a way to implement ?TERMINAL in STANDARD ANSI 'C', + * please let me know. ?TERMINAL ( -- charAvailable? ) + */ + #define sdQueryTerminal() (0) + #ifdef PF_NO_FILEIO + #define sdTerminalFlush() /* fflush(PF_STDOUT) */ + #else + #define sdTerminalFlush() fflush(PF_STDOUT) + #endif + #endif +#endif /* PF_NO_CHARIO */ + + +/* Define file access modes. */ +/* User can #undef and re#define using PF_USER_FILEIO if needed. */ +#define PF_FAM_READ_ONLY (0) +#define PF_FAM_READ_WRITE (1) + +#define PF_FAM_CREATE ("w+") +#define PF_FAM_OPEN_RO ("r") +#define PF_FAM_OPEN_RW ("r+") + +#ifdef PF_NO_FILEIO + + typedef void FileStream; + + extern FileStream *PF_STDIN; + extern FileStream *PF_STDOUT; + + #ifdef __cplusplus + extern "C" { + #endif + + /* Prototypes for stubs. */ + FileStream *sdOpenFile( const char *FileName, const char *Mode ); + int32 sdFlushFile( FileStream * Stream ); + int32 sdReadFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ); + int32 sdWriteFile( void *ptr, int32 Size, int32 nItems, FileStream * Stream ); + int32 sdSeekFile( FileStream * Stream, int32 Position, int32 Mode ); + int32 sdTellFile( FileStream * Stream ); + int32 sdCloseFile( FileStream * Stream ); + int32 sdInputChar( FileStream *stream ); + + #ifdef __cplusplus + } + #endif + + #define PF_SEEK_SET (0) + #define PF_SEEK_CUR (1) + #define PF_SEEK_END (2) + /* + ** printf() is only used for debugging purposes. + ** It is not required for normal operation. + */ + #define PRT(x) /* No printf(). */ + +#else + + #ifdef PF_USER_FILEIO +/* Get user prototypes or macros from include file. +** API must match that defined above for the stubs. +*/ + #include PF_USER_FILEIO + + #else + typedef FILE FileStream; + + #define sdOpenFile fopen + #define sdFlushFile fflush + #define sdReadFile fread + #define sdWriteFile fwrite + #define sdSeekFile fseek + #define sdTellFile ftell + #define sdCloseFile fclose + #define sdInputChar fgetc + + #define PF_STDIN ((FileStream *) stdin) + #define PF_STDOUT ((FileStream *) stdout) + + #define PF_SEEK_SET (0) + #define PF_SEEK_CUR (1) + #define PF_SEEK_END (2) + + /* + ** printf() is only used for debugging purposes. + ** It is not required for normal operation. + */ + #define PRT(x) { printf x; sdFlushFile(PF_STDOUT); } + #endif + +#endif /* PF_NO_FILEIO */ + + +#ifdef __cplusplus +extern "C" { +#endif + +cell ioAccept( char *Target, cell n1, FileStream *Stream ); +cell ioKey( void); +void ioEmit( char c ); +void ioType( const char *s, int32 n); + +#ifdef __cplusplus +} +#endif + +#endif /* _pf_io_h */ diff --git a/csrc/pf_mac.h b/csrc/pf_mac.h new file mode 100644 index 0000000..80e9188 --- /dev/null +++ b/csrc/pf_mac.h @@ -0,0 +1,39 @@ +/* @(#) pf_mac.h 98/01/26 1.2 */ +#ifndef _pf_mac_h +#define _pf_mac_h + +/*************************************************************** +** Macintosh dependant include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#include +#include + +#include +#include + + +#ifdef PF_SUPPORT_FP + #include + + #ifndef PF_USER_FP + #include "pf_float.h" + #else + #include PF_USER_FP + #endif +#endif + +#endif /* _pf_mac_h */ diff --git a/csrc/pf_main.c b/csrc/pf_main.c new file mode 100644 index 0000000..e834f14 --- /dev/null +++ b/csrc/pf_main.c @@ -0,0 +1,102 @@ +/* @(#) pf_main.c 98/01/26 1.2 */ +/*************************************************************** +** Forth based on 'C' +** +** main() routine that demonstrates how to call PForth as +** a module from 'C' based application. +** Customize this as needed for your application. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef PF_NO_STDIO + #define NULL ((void *) 0) + #define ERR(msg) /* { printf msg; } */ +#else + #include + #define ERR(msg) { printf msg; } +#endif + +#include "pforth.h" + +#ifdef __MWERKS__ + #include + #include +#endif + +#ifndef TRUE +#define TRUE (1) +#define FALSE (0) +#endif + +int main( int argc, char **argv ) +{ + const char *DicName = "pforth.dic"; + const char *SourceName = NULL; + char IfInit = FALSE; + char *s; + int32 i; + int Result; + +/* For Metroworks on Mac */ + #ifdef __MWERKS__ + argc = ccommand(&argv); + #endif + +/* Parse command line. */ + for( i=1; idlln_Previous) +#define dllNextNode(n) ((n)->dlln_Next) + +void dllSetupList( DoublyLinkedList *dll ) +{ + dll->dll_First = (DoublyLinkedListNode *) &(dll->dll_Null); + dll->dll_Null = (DoublyLinkedListNode *) NULL; + dll->dll_Last = (DoublyLinkedListNode *) &(dll->dll_First); +} + +void dllLinkNodes( DoublyLinkedListNode *Node0, DoublyLinkedListNode *Node1 ) +{ + Node0->dlln_Next = Node1; + Node1->dlln_Previous = Node0; +} + +void dllInsertNodeBefore( DoublyLinkedListNode *NewNodePtr, + DoublyLinkedListNode *NodeInListPtr ) +{ + DoublyLinkedListNode *NodePreviousPtr = dllPreviousNode( NodeInListPtr ); + dllLinkNodes( NodePreviousPtr, NewNodePtr ); + dllLinkNodes( NewNodePtr, NodeInListPtr ); +} + +void dllInsertNodeAfter( DoublyLinkedListNode *NewNodePtr, + DoublyLinkedListNode *NodeInListPtr ) +{ + DoublyLinkedListNode *NodeNextPtr = dllNextNode( NodeInListPtr ); + dllLinkNodes( NodeInListPtr, NewNodePtr ); + dllLinkNodes( NewNodePtr, NodeNextPtr ); +} + +void dllDumpNode( DoublyLinkedListNode *NodePtr ) +{ + TOUCH(NodePtr); + DBUG((" 0x%x -> (0x%x) -> 0x%x\n", + dllPreviousNode( NodePtr ), NodePtr, + dllNextNode( NodePtr ) )); +} + +int32 dllCheckNode( DoublyLinkedListNode *NodePtr ) +{ + if( (NodePtr->dlln_Next->dlln_Previous != NodePtr) || + (NodePtr->dlln_Previous->dlln_Next != NodePtr)) + { + ERR("dllCheckNode: Bad Node!\n"); + dllDumpNode( dllPreviousNode( NodePtr ) ); + dllDumpNode( NodePtr ); + dllDumpNode( dllNextNode( NodePtr ) ); + return -1; + } + else + { + return 0; + } +} +void dllRemoveNode( DoublyLinkedListNode *NodePtr ) +{ + if( dllCheckNode( NodePtr ) == 0 ) + { + dllLinkNodes( dllPreviousNode( NodePtr ), dllNextNode( NodePtr ) ); + } +} + +void dllAddNodeToHead( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr ) +{ + dllInsertNodeBefore( NewNodePtr, ListPtr->dll_First ); +} + +void dllAddNodeToTail( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr ) +{ + dllInsertNodeAfter( NewNodePtr, ListPtr->dll_Last ); +} + +#define dllIsNodeInList( n ) (!((n)->dlln_Next == NULL) ) +#define dllIsLastNode( n ) ((n)->dlln_Next->dll_nNext == NULL ) +#define dllIsListEmpty( l ) ((l)->dll_First == ((DoublyLinkedListNode *) &((l)->dll_Null)) ) +#define dllFirstNode( l ) ((l)->dll_First) + +static DoublyLinkedList gMemList; +static int32 gIfMemListInit; + +typedef struct MemListNode +{ + DoublyLinkedListNode mln_Node; + int32 mln_Size; +} MemListNode; + +#ifdef PF_DEBUG +/*************************************************************** +** Dump memory list. +*/ +void maDumpList( void ) +{ + MemListNode *mln; + + MSG("PForth MemList\n"); + + for( mln = (MemListNode *) dllFirstNode( &gMemList ); + dllIsNodeInList( (DoublyLinkedListNode *) mln); + mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) + { + MSG(" Node at = 0x"); ffDotHex(mln); + MSG_NUM_H(", size = 0x", mln->mln_Size); + } +} +#endif + + +/*************************************************************** +** Free mem of any size. +*/ +static void pfFreeRawMem( char *Mem, int32 NumBytes ) +{ + MemListNode *mln, *FreeNode; + MemListNode *AdjacentLower = NULL; + MemListNode *AdjacentHigher = NULL; + MemListNode *NextBiggest = NULL; + +/* Allocate in whole blocks of 16 bytes */ + DBUG(("\npfFreeRawMem( 0x%x, 0x%x )\n", Mem, NumBytes )); + NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1); + DBUG(("\npfFreeRawMem: Align NumBytes to 0x%x\n", NumBytes )); + +/* Check memory alignment. */ + if( ( ((int32)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0) + { + MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (int32) Mem ); + return; + } + +/* Scan list from low to high looking for various nodes. */ + for( mln = (MemListNode *) dllFirstNode( &gMemList ); + dllIsNodeInList( (DoublyLinkedListNode *) mln); + mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) + { + if( (((char *) mln) + mln->mln_Size) == Mem ) + { + AdjacentLower = mln; + } + else if( ((char *) mln) == ( Mem + NumBytes )) + { + AdjacentHigher = mln; + } +/* is this the next biggest node. */ + else if( (NextBiggest == NULL) && (mln->mln_Size >= NumBytes) ) + { + NextBiggest = mln; + } + } + +/* Check to see if we can merge nodes. */ + if( AdjacentHigher ) + { +DBUG((" Merge (0x%x) -> 0x%x\n", Mem, AdjacentHigher )); + NumBytes += AdjacentHigher->mln_Size; + dllRemoveNode( (DoublyLinkedListNode *) AdjacentHigher ); + } + if( AdjacentLower ) + { +DBUG((" Merge 0x%x -> (0x%x)\n", AdjacentLower, Mem )); + AdjacentLower->mln_Size += NumBytes; + } + else + { +DBUG((" Link before 0x%x\n", NextBiggest )); + FreeNode = (MemListNode *) Mem; + FreeNode->mln_Size = NumBytes; + if( NextBiggest == NULL ) + { +/* Nothing bigger so add to end of list. */ + dllAddNodeToTail( &gMemList, (DoublyLinkedListNode *) FreeNode ); + } + else + { +/* Add this node before the next biggest one we found. */ + dllInsertNodeBefore( (DoublyLinkedListNode *) FreeNode, + (DoublyLinkedListNode *) NextBiggest ); + } + } + +/* maDumpList(); */ +} + + + +/*************************************************************** +** Setup memory list. Initialize allocator. +*/ +void pfInitMemAllocator( void *addr, uint32 poolSize ) +{ + char *AlignedMemory; + int32 AlignedSize; + +/* Set globals. */ + gMemPoolPtr = addr; + gMemPoolSize = poolSize; + + dllSetupList( &gMemList ); + gIfMemListInit = TRUE; + +/* Adjust to next highest aligned memory location. */ + AlignedMemory = (char *) ((((int32)gMemPoolPtr) + PF_MEM_BLOCK_SIZE - 1) & + ~(PF_MEM_BLOCK_SIZE - 1)); + +/* Adjust size to reflect aligned memory. */ + AlignedSize = gMemPoolSize - (AlignedMemory - gMemPoolPtr); + +/* Align size of pool. */ + AlignedSize = AlignedSize & ~(PF_MEM_BLOCK_SIZE - 1); + +/* Free to pool. */ + pfFreeRawMem( AlignedMemory, AlignedSize ); + +} + +/*************************************************************** +** Allocate mem from list of free nodes. +*/ +static char *pfAllocRawMem( int32 NumBytes ) +{ + char *Mem = NULL; + MemListNode *mln; + + if( NumBytes <= 0 ) return NULL; + + if( gIfMemListInit == 0 ) pfInitMemAllocator( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE ); + +/* Allocate in whole blocks of 16 bytes */ + NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1); + + DBUG(("\npfAllocRawMem( 0x%x )\n", NumBytes )); + +/* Scan list from low to high until we find a node big enough. */ + for( mln = (MemListNode *) dllFirstNode( &gMemList ); + dllIsNodeInList( (DoublyLinkedListNode *) mln); + mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) ) + { + if( mln->mln_Size >= NumBytes ) + { + int32 RemSize; + + Mem = (char *) mln; + +/* Remove this node from list. */ + dllRemoveNode( (DoublyLinkedListNode *) mln ); + +/* Is there enough left in block to make it worth splitting? */ + RemSize = mln->mln_Size - NumBytes; + if( RemSize >= PF_MEM_BLOCK_SIZE ) + { + pfFreeRawMem( (Mem + NumBytes), RemSize ); + } + break; + } + + } +/* maDumpList(); */ + DBUG(("Allocate mem at 0x%x.\n", Mem )); + return Mem; +} + +/*************************************************************** +** Keep mem size at first cell. +*/ +char *pfAllocMem( int32 NumBytes ) +{ + int32 *IntMem; + + if( NumBytes <= 0 ) return NULL; + +/* Allocate an extra cell for size. */ + NumBytes += sizeof(int32); + + IntMem = (int32 *)pfAllocRawMem( NumBytes ); + + if( IntMem != NULL ) *IntMem++ = NumBytes; + + return (char *) IntMem; +} + +/*************************************************************** +** Free mem with mem size at first cell. +*/ +void pfFreeMem( void *Mem ) +{ + int32 *IntMem; + int32 NumBytes; + + if( Mem == NULL ) return; + +/* Allocate an extra cell for size. */ + IntMem = (int32 *) Mem; + IntMem--; + NumBytes = *IntMem; + + pfFreeRawMem( (char *) IntMem, NumBytes ); + +} + +#endif /* PF_NO_MALLOC */ diff --git a/csrc/pf_mem.h b/csrc/pf_mem.h new file mode 100644 index 0000000..dabacfe --- /dev/null +++ b/csrc/pf_mem.h @@ -0,0 +1,46 @@ +/* @(#) pf_mem.h 98/01/26 1.3 */ +#ifndef _pf_mem_h +#define _pf_mem_h + +/*************************************************************** +** Include file for PForth Fake Memory Allocator +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +***************************************************************/ + +#ifdef PF_NO_MALLOC + + #ifdef __cplusplus + extern "C" { + #endif + + void pfInitMemAllocator( void *addr, uint32 poolSize ); + char *pfAllocMem( int32 NumBytes ); + void pfFreeMem( void *Mem ); + + #ifdef __cplusplus + } + #endif + +#else + + #ifdef PF_USER_MALLOC +/* Get user prototypes or macros from include file. +** API must match that defined above for the stubs. +*/ + #include PF_USER_MALLOC + #else + #define pfAllocMem malloc + #define pfFreeMem free + #endif + +#endif /* PF_NO_MALLOC */ + +#endif /* _pf_mem_h */ diff --git a/csrc/pf_save.c b/csrc/pf_save.c new file mode 100644 index 0000000..c330b4f --- /dev/null +++ b/csrc/pf_save.c @@ -0,0 +1,726 @@ +/* @(#) pf_save.c 98/01/26 1.3 */ +/*************************************************************** +** Save and Load Dictionary +** for PForth based on 'C' +** +** Compile file based version or static data based version +** depending on PF_NO_FILEIO switch. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 940225 PLB Fixed CodePtr save, was using NAMEREL instead of CODEREL +** This would only work if the relative location +** of names and code was the same when saved and reloaded. +** 940228 PLB Added PF_NO_FILEIO version +** 961204 PLB Added PF_STATIC_DIC +***************************************************************/ + +#include "pf_all.h" + +int IsHostLittleEndian( void ); + +/* If no File I/O, then force static dictionary. */ +#ifdef PF_NO_FILEIO + #ifndef PF_STATIC_DIC + #define PF_STATIC_DIC + #endif +#endif + +#if 0 +Dictionary File Format based on IFF standard. +The chunk IDs, sizes, and data values are all Big Endian in conformance with the IFF standard. +The dictionaries may be big or little endian. + 'FORM' + size + 'P4TH' - Form Identifier + +Chunks + 'P4DI' + size + struct DictionaryInfoChunk + + 'P4NM' + size + Name and Header portion of dictionary. (Big or Little Endian) (Optional) + + 'P4CD' + size + Code portion of dictionary. (Big or Little Endian) +#endif + + +/***************************************************************/ +/* Endian-ness tools. */ +uint32 ReadLongBigEndian( const uint32 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (bp[0]<<24) | (bp[1]<<16) | (bp[2]<<8) | bp[3]; +} +/***************************************************************/ +uint16 ReadShortBigEndian( const uint16 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (uint16) ((bp[0]<<8) | bp[1]); +} + +/***************************************************************/ +uint32 ReadLongLittleEndian( const uint32 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (bp[3]<<24) | (bp[2]<<16) | (bp[1]<<8) | bp[0]; +} +/***************************************************************/ +uint16 ReadShortLittleEndian( const uint16 *addr ) +{ + const unsigned char *bp = (const unsigned char *) addr; + return (uint16) ((bp[1]<<8) | bp[0]); +} + +#ifdef PF_SUPPORT_FP + +/***************************************************************/ +static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst ); + +static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst ) +{ + int i; + unsigned char *d = (unsigned char *) dst; + const unsigned char *s = (const unsigned char *) src; + + for( i=0; i>24); + bp[1] = (unsigned char) (data>>16); + bp[2] = (unsigned char) (data>>8); + bp[3] = (unsigned char) (data); +} + +/***************************************************************/ +void WriteShortBigEndian( uint16 *addr, uint16 data ) +{ + unsigned char *bp = (unsigned char *) addr; + + bp[0] = (unsigned char) (data>>8); + bp[1] = (unsigned char) (data); +} + +/***************************************************************/ +void WriteLongLittleEndian( uint32 *addr, uint32 data ) +{ + unsigned char *bp = (unsigned char *) addr; + + bp[0] = (unsigned char) (data); + bp[1] = (unsigned char) (data>>8); + bp[2] = (unsigned char) (data>>16); + bp[3] = (unsigned char) (data>>24); +} +/***************************************************************/ +void WriteShortLittleEndian( uint16 *addr, uint16 data ) +{ + unsigned char *bp = (unsigned char *) addr; + + bp[0] = (unsigned char) (data); + bp[1] = (unsigned char) (data>>8); +} + +/***************************************************************/ +/* Return 1 if host CPU is Little Endian */ +int IsHostLittleEndian( void ) +{ + uint16 gEndianCheck = 1; + unsigned char *bp = (unsigned char *) &gEndianCheck; + return *bp; /* Return byte pointed to by address. If LSB then == 1 */ +} + +#ifndef PF_STATIC_DIC + +#ifndef PF_NO_SHELL +/***************************************************************/ +static int32 WriteLong( FileStream *fid, int32 Val ) +{ + int32 numw; + uint32 pad; + + WriteLongBigEndian(&pad,Val); + numw = sdWriteFile( (char *) &pad, 1, sizeof(int32), fid ); + if( numw != sizeof(int32) ) return -1; + return 0; +} + +/***************************************************************/ +static int32 WriteChunk( FileStream *fid, int32 ID, char *Data, int32 NumBytes ) +{ + int32 numw; + int32 EvenNumW; + + EvenNumW = EVENUP(NumBytes); + + if( WriteLong( fid, ID ) < 0 ) goto error; + if( WriteLong( fid, EvenNumW ) < 0 ) goto error; + + numw = sdWriteFile( Data, 1, EvenNumW, fid ); + if( numw != EvenNumW ) goto error; + return 0; +error: + pfReportError("WriteChunk", PF_ERR_WRITE_FILE); + return -1; +} + +/**************************************************************** +** Save Dictionary in File. +** If EntryPoint is NULL, save as development environment. +** If EntryPoint is non-NULL, save as turnKey environment with no names. +*/ +int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize) +{ + FileStream *fid; + DictionaryInfoChunk SD; + int32 FormSize; + int32 NameChunkSize = 0; + int32 CodeChunkSize; + uint32 rhp, rcp; + uint32 *p; + int i; + + fid = sdOpenFile( FileName, "wb" ); + if( fid == NULL ) + { + pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE); + return -1; + } + +/* Save in uninitialized form. */ + pfExecByName("AUTO.TERM"); + +/* Write FORM Header ---------------------------- */ + if( WriteLong( fid, ID_FORM ) < 0 ) goto error; + if( WriteLong( fid, 0 ) < 0 ) goto error; + if( WriteLong( fid, ID_P4TH ) < 0 ) goto error; + +/* Write P4DI Dictionary Info ------------------ */ + SD.sd_Version = PF_FILE_VERSION; + + rcp = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */ + SD.sd_RelCodePtr = rcp; + SD.sd_UserStackSize = sizeof(cell) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit); + SD.sd_ReturnStackSize = sizeof(cell) * (gCurrentTask->td_ReturnBase - gCurrentTask->td_ReturnLimit); + SD.sd_NumPrimitives = gNumPrimitives; /* Must match compiled dictionary. */ + +#ifdef PF_SUPPORT_FP + SD.sd_FloatSize = sizeof(PF_FLOAT); /* Must match compiled dictionary. */ +#else + SD.sd_FloatSize = 0; +#endif + + SD.sd_Reserved = 0; + +/* Set bit that specifiec whether dictionary is BIG or LITTLE Endian. */ + { +#if defined(PF_BIG_ENDIAN_DIC) + int eflag = SD_F_BIG_ENDIAN_DIC; +#elif defined(PF_LITTLE_ENDIAN_DIC) + int eflag = 0; +#else + int eflag = IsHostLittleEndian() ? 0 : SD_F_BIG_ENDIAN_DIC; +#endif + SD.sd_Flags = eflag; + } + + if( EntryPoint ) + { + SD.sd_EntryPoint = EntryPoint; /* Turnkey! */ + } + else + { + SD.sd_EntryPoint = 0; + } + +/* Do we save names? */ + if( NameSize == 0 ) + { + SD.sd_RelContext = 0; + SD.sd_RelHeaderPtr = 0; + SD.sd_NameSize = 0; + } + else + { +/* Development mode. */ + SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext); + rhp = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr.Byte); + SD.sd_RelHeaderPtr = rhp; + +/* How much real name space is there? */ + NameChunkSize = QUADUP(rhp); /* Align */ + +/* NameSize must be 0 or greater than NameChunkSize + 1K */ + NameSize = QUADUP(NameSize); /* Align */ + if( NameSize > 0 ) + { + NameSize = MAX( NameSize, (NameChunkSize + 1024) ); + } + SD.sd_NameSize = NameSize; + } + +/* How much real code is there? */ + CodeChunkSize = QUADUP(rcp); + CodeSize = QUADUP(CodeSize); /* Align */ + CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) ); + SD.sd_CodeSize = CodeSize; + + +/* Convert all fields in structure from Native to BigEndian. */ + p = (uint32 *) &SD; + for( i=0; i<((int)(sizeof(SD)/sizeof(int32))); i++ ) + { + WriteLongBigEndian( &p[i], p[i] ); + } + + if( WriteChunk( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error; + +/* Write Name Fields if NameSize non-zero ------- */ + if( NameSize > 0 ) + { + if( WriteChunk( fid, ID_P4NM, (char *) NAME_BASE, + NameChunkSize ) < 0 ) goto error; + } + +/* Write Code Fields ---------------------------- */ + if( WriteChunk( fid, ID_P4CD, (char *) CODE_BASE, + CodeChunkSize ) < 0 ) goto error; + + FormSize = sdTellFile( fid ) - 8; + sdSeekFile( fid, 4, PF_SEEK_SET ); + if( WriteLong( fid, FormSize ) < 0 ) goto error; + + sdCloseFile( fid ); + + + +/* Restore initialization. */ + + pfExecByName("AUTO.INIT"); + + return 0; + +error: + sdSeekFile( fid, 0, PF_SEEK_SET ); + WriteLong( fid, ID_BADF ); /* Mark file as bad. */ + sdCloseFile( fid ); + +/* Restore initialization. */ + + pfExecByName("AUTO.INIT"); + + return -1; +} +#endif /* !PF_NO_SHELL */ + +/***************************************************************/ +static int32 ReadLong( FileStream *fid, int32 *ValPtr ) +{ + int32 numr; + uint32 temp; + + numr = sdReadFile( &temp, 1, sizeof(int32), fid ); + if( numr != sizeof(int32) ) return -1; + *ValPtr = ReadLongBigEndian( &temp ); + return 0; +} + +/***************************************************************/ +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) +{ + cfDictionary *dic = NULL; + FileStream *fid; + DictionaryInfoChunk *sd; + int32 ChunkID; + int32 ChunkSize; + int32 FormSize; + int32 BytesLeft; + int32 numr; + uint32 *p; + int i; + int isDicBigEndian; + +DBUG(("pfLoadDictionary( %s )\n", FileName )); + +/* Open file. */ + fid = sdOpenFile( FileName, "rb" ); + if( fid == NULL ) + { + pfReportError("pfLoadDictionary", PF_ERR_OPEN_FILE); + goto xt_error; + } + +/* Read FORM, Size, ID */ + if (ReadLong( fid, &ChunkID ) < 0) goto read_error; + if( ChunkID != ID_FORM ) + { + pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE); + goto error; + } + + if (ReadLong( fid, &FormSize ) < 0) goto read_error; + BytesLeft = FormSize; + + if (ReadLong( fid, &ChunkID ) < 0) goto read_error; + BytesLeft -= 4; + if( ChunkID != ID_P4TH ) + { + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE); + goto error; + } + +/* Scan and parse all chunks in file. */ + while( BytesLeft > 0 ) + { + if (ReadLong( fid, &ChunkID ) < 0) goto read_error; + if (ReadLong( fid, &ChunkSize ) < 0) goto read_error; + BytesLeft -= 8; + + DBUG(("ChunkID = %4s, Size = %d\n", &ChunkID, ChunkSize )); + + switch( ChunkID ) + { + case ID_P4DI: + sd = (DictionaryInfoChunk *) pfAllocMem( ChunkSize ); + if( sd == NULL ) goto nomem_error; + + numr = sdReadFile( sd, 1, ChunkSize, fid ); + if( numr != ChunkSize ) goto read_error; + BytesLeft -= ChunkSize; + +/* Convert all fields in structure from BigEndian to Native. */ + p = (uint32 *) sd; + for( i=0; i<((int)(sizeof(*sd)/sizeof(int32))); i++ ) + { + p[i] = ReadLongBigEndian( &p[i] ); + } + + isDicBigEndian = sd->sd_Flags & SD_F_BIG_ENDIAN_DIC; + + if( !gVarQuiet ) + { + MSG("pForth loading dictionary from file "); MSG(FileName); + EMIT_CR; + MSG_NUM_D(" File format version is ", sd->sd_Version ); + MSG_NUM_D(" Name space size = ", sd->sd_NameSize ); + MSG_NUM_D(" Code space size = ", sd->sd_CodeSize ); + MSG_NUM_D(" Entry Point = ", sd->sd_EntryPoint ); + MSG( (isDicBigEndian ? " Big Endian Dictionary" : + " Little Endian Dictionary") ); + if( isDicBigEndian == IsHostLittleEndian() ) MSG(" !!!!"); + EMIT_CR; + } + + if( sd->sd_Version > PF_FILE_VERSION ) + { + pfReportError("pfLoadDictionary", PF_ERR_VERSION_FUTURE ); + goto error; + } + if( sd->sd_Version < PF_EARLIEST_FILE_VERSION ) + { + pfReportError("pfLoadDictionary", PF_ERR_VERSION_PAST ); + goto error; + } + if( sd->sd_NumPrimitives > NUM_PRIMITIVES ) + { + pfReportError("pfLoadDictionary", PF_ERR_NOT_SUPPORTED ); + goto error; + } + +/* Check to make sure that EndianNess of dictionary matches mode of pForth. */ +#if defined(PF_BIG_ENDIAN_DIC) + if(isDicBigEndian == 0) +#elif defined(PF_LITTLE_ENDIAN_DIC) + if(isDicBigEndian == 1) +#else + if( isDicBigEndian == IsHostLittleEndian() ) +#endif + { + pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT ); + goto error; + } + +/* Check for compatible float size. */ +#ifdef PF_SUPPORT_FP + if( sd->sd_FloatSize != sizeof(PF_FLOAT) ) +#else + if( sd->sd_FloatSize != 0 ) +#endif + { + pfReportError("pfLoadDictionary", PF_ERR_FLOAT_CONFLICT ); + goto error; + } + + dic = pfCreateDictionary( sd->sd_NameSize, sd->sd_CodeSize ); + if( dic == NULL ) goto nomem_error; + gCurrentDictionary = dic; + if( sd->sd_NameSize > 0 ) + { + gVarContext = (char *) NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */ + gCurrentDictionary->dic_HeaderPtr.Byte = (uint8 *) + NAMEREL_TO_ABS(sd->sd_RelHeaderPtr); + } + else + { + gVarContext = 0; + gCurrentDictionary->dic_HeaderPtr.Byte = NULL; + } + gCurrentDictionary->dic_CodePtr.Byte = (uint8 *) CODEREL_TO_ABS(sd->sd_RelCodePtr); + gNumPrimitives = sd->sd_NumPrimitives; /* Must match compiled dictionary. */ +/* Pass EntryPoint back to caller. */ + if( EntryPointPtr != NULL ) *EntryPointPtr = sd->sd_EntryPoint; + pfFreeMem(sd); + break; + + case ID_P4NM: +#ifdef PF_NO_SHELL + pfReportError("pfLoadDictionary", PF_ERR_NO_SHELL ); + goto error; +#else + if( NAME_BASE == NULL ) + { + pfReportError("pfLoadDictionary", PF_ERR_NO_NAMES ); + goto error; + } + if( gCurrentDictionary == NULL ) + { + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); + goto error; + } + if( ChunkSize > NAME_SIZE ) + { + pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG); + goto error; + } + numr = sdReadFile( NAME_BASE, 1, ChunkSize, fid ); + if( numr != ChunkSize ) goto read_error; + BytesLeft -= ChunkSize; +#endif /* PF_NO_SHELL */ + break; + + case ID_P4CD: + if( gCurrentDictionary == NULL ) + { + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); + goto error; + } + if( ChunkSize > CODE_SIZE ) + { + pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG); + goto error; + } + numr = sdReadFile( CODE_BASE, 1, ChunkSize, fid ); + if( numr != ChunkSize ) goto read_error; + BytesLeft -= ChunkSize; + break; + + default: + pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE ); + sdSeekFile( fid, ChunkSize, PF_SEEK_CUR ); + break; + } + } + + sdCloseFile( fid ); + + if( NAME_BASE != NULL) + { + int32 Result; +/* Find special words in dictionary for global XTs. */ + if( (Result = FindSpecialXTs()) < 0 ) + { + pfReportError("pfLoadDictionary: FindSpecialXTs", Result); + goto error; + } + } + +DBUG(("pfLoadDictionary: return 0x%x\n", dic)); + return dic; + +nomem_error: + pfReportError("pfLoadDictionary", PF_ERR_NO_MEM); + sdCloseFile( fid ); + return NULL; + +read_error: + pfReportError("pfLoadDictionary", PF_ERR_READ_FILE); +error: + sdCloseFile( fid ); +xt_error: + return NULL; +} + +#else /* PF_STATIC_DIC ============================================== */ + +/* +** Dictionary must come from data array because there is no file I/O. +*/ +#ifndef HEADERPTR + #include "pfdicdat.h" +#endif + +int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize) +{ + TOUCH(FileName); + TOUCH(EntryPoint); + TOUCH(NameSize); + TOUCH(CodeSize); + + pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED); + return -1; +} + + +/***************************************************************/ +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ) +{ + cfDictionary *dic; + int32 Result; + int32 NewNameSize, NewCodeSize; + +MSG("pfLoadDictionary - Filename ignored! Loading from static data.\n"); + + TOUCH(FileName); + TOUCH(EntryPointPtr); + +/* Check to make sure that EndianNess of dictionary matches mode of pForth. */ +#if defined(PF_BIG_ENDIAN_DIC) + if(IF_LITTLE_ENDIAN == 1) +#elif defined(PF_LITTLE_ENDIAN_DIC) + if(IF_LITTLE_ENDIAN == 0) +#else + if( IF_LITTLE_ENDIAN != IsHostLittleEndian() ) +#endif + { + pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT ); + goto error; + } + +/* Static data too small. Copy it to larger array. */ +#ifndef PF_EXTRA_HEADERS + #define PF_EXTRA_HEADERS (20000) +#endif +#ifndef PF_EXTRA_CODE + #define PF_EXTRA_CODE (40000) +#endif +/* Copy static const data to allocated dictionaries. */ + NewNameSize = sizeof(MinDicNames) + PF_EXTRA_HEADERS; + NewCodeSize = sizeof(MinDicCode) + PF_EXTRA_CODE; + + gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize ); + if( !dic ) goto nomem_error; + + pfCopyMemory( dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) ); + pfCopyMemory( dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) ); + MSG("Static data copied to newly allocated dictionaries.\n"); + + dic->dic_CodePtr.Byte = (uint8 *) CODEREL_TO_ABS(CODEPTR); + gNumPrimitives = NUM_PRIMITIVES; + + if( NAME_BASE != NULL) + { +/* Setup name space. */ + dic->dic_HeaderPtr.Byte = (uint8 *) NAMEREL_TO_ABS(HEADERPTR); + gVarContext = (char *) NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */ + +/* Find special words in dictionary for global XTs. */ + if( (Result = FindSpecialXTs()) < 0 ) + { + pfReportError("pfLoadDictionary: FindSpecialXTs", Result); + goto error; + } + } + + return dic; + +error: + pfReportError("pfLoadDictionary", -1); + return NULL; + +nomem_error: + pfReportError("pfLoadDictionary", PF_ERR_NO_MEM); + return NULL; +} + + +#endif /* PF_STATIC_DIC */ diff --git a/csrc/pf_save.h b/csrc/pf_save.h new file mode 100644 index 0000000..d5e21ce --- /dev/null +++ b/csrc/pf_save.h @@ -0,0 +1,90 @@ +/* @(#) pf_save.h 96/12/18 1.8 */ +#ifndef _pforth_save_h +#define _pforth_save_h + +/*************************************************************** +** Include file for PForth SaveForth +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** 941031 rdg fix redefinition of MAKE_ID and EVENUP to be conditional +** +***************************************************************/ + + +typedef struct DictionaryInfoChunk +{ +/* All fields are stored in BIG ENDIAN format for consistency in data files. */ +/* All fileds must be the same size as int32 for easy endian conversion. */ + int32 sd_Version; + int32 sd_RelContext; /* relative ptr to Dictionary Context */ + int32 sd_RelHeaderPtr; /* relative ptr to Dictionary Header Ptr */ + int32 sd_RelCodePtr; /* relative ptr to Dictionary Header Ptr */ + ExecToken sd_EntryPoint; /* relative ptr to entry point or NULL */ + int32 sd_UserStackSize; /* in bytes */ + int32 sd_ReturnStackSize; /* in bytes */ + int32 sd_NameSize; /* in bytes */ + int32 sd_CodeSize; /* in bytes */ + int32 sd_NumPrimitives; /* To distinguish between primitive and secondary. */ + uint32 sd_Flags; + int32 sd_FloatSize; /* In bytes. Must match code. 0 means no floats. */ + uint32 sd_Reserved; +} DictionaryInfoChunk; + +/* Bits in sd_Flags */ +#define SD_F_BIG_ENDIAN_DIC (1<<0) + +#ifndef MAKE_ID +#define MAKE_ID(a,b,c,d) ((a<<24)|(b<<16)|(c<<8)|d) +#endif + +#define ID_FORM MAKE_ID('F','O','R','M') +#define ID_P4TH MAKE_ID('P','4','T','H') +#define ID_P4DI MAKE_ID('P','4','D','I') +#define ID_P4NM MAKE_ID('P','4','N','M') +#define ID_P4CD MAKE_ID('P','4','C','D') +#define ID_BADF MAKE_ID('B','A','D','F') + +#ifndef EVENUP +#define EVENUP(n) ((n+1)&(~1)) +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +int32 ffSaveForth( const char *FileName, ExecToken EntryPoint, int32 NameSize, int32 CodeSize ); +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); + +/* Endian-ness tools. */ +uint32 ReadLongBigEndian( const uint32 *addr ); +uint16 ReadShortBigEndian( const uint16 *addr ); +uint32 ReadLongLittleEndian( const uint32 *addr ); +uint16 ReadShortLittleEndian( const uint16 *addr ); +void WriteLongBigEndian( uint32 *addr, uint32 data ); +void WriteShortBigEndian( uint16 *addr, uint16 data ); +void WriteLongLittleEndian( uint32 *addr, uint32 data ); +void WriteShortLittleEndian( uint16 *addr, uint16 data ); + +#ifdef PF_SUPPORT_FP +void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data ); +PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr ); +void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data ); +PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr ); +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_save_h */ diff --git a/csrc/pf_text.c b/csrc/pf_text.c new file mode 100644 index 0000000..51d0610 --- /dev/null +++ b/csrc/pf_text.c @@ -0,0 +1,297 @@ +/* @(#) pf_text.c 98/01/26 1.3 */ +/*************************************************************** +** Text Strings for Error Messages +** Various Text tools. +** +** For PForth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 19970702 PLB Fixed ConvertNumberToText for unsigned numbers. +** 19980522 PLB Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash. +***************************************************************/ + +#include "pf_all.h" + +#define PF_ENGLISH + +/* +** Define array of error messages. +** These are defined in one place to make it easier to translate them. +*/ +#ifdef PF_ENGLISH +/***************************************************************/ +void pfReportError( const char *FunctionName, Err ErrCode ) +{ + const char *s; + + MSG("Error in "); + MSG(FunctionName); + MSG(" - "); + + switch(ErrCode & 0xFF) + { + case PF_ERR_NO_MEM & 0xFF: + s = "insufficient memory"; break; + case PF_ERR_BAD_ADDR & 0xFF: + s = "address misaligned"; break; + case PF_ERR_TOO_BIG & 0xFF: + s = "data chunk too large"; break; + case PF_ERR_NUM_PARAMS & 0xFF: + s = "incorrect number of parameters"; break; + case PF_ERR_OPEN_FILE & 0xFF: + s = "could not open file"; break; + case PF_ERR_WRONG_FILE & 0xFF: + s = "wrong type of file format"; break; + case PF_ERR_BAD_FILE & 0xFF: + s = "badly formatted file"; break; + case PF_ERR_READ_FILE & 0xFF: + s = "file read failed"; break; + case PF_ERR_WRITE_FILE & 0xFF: + s = "file write failed"; break; + case PF_ERR_CORRUPT_DIC & 0xFF: + s = "corrupted dictionary"; break; + case PF_ERR_NOT_SUPPORTED & 0xFF: + s = "not supported in this version"; break; + case PF_ERR_VERSION_FUTURE & 0xFF: + s = "version from future"; break; + case PF_ERR_VERSION_PAST & 0xFF: + s = "version is obsolete. Rebuild new one."; break; + case PF_ERR_COLON_STACK & 0xFF: + s = "stack depth changed between : and ; . Probably unbalanced conditional"; break; + case PF_ERR_HEADER_ROOM & 0xFF: + s = "no room left in header space"; break; + case PF_ERR_CODE_ROOM & 0xFF: + s = "no room left in code space"; break; + case PF_ERR_NO_SHELL & 0xFF: + s = "attempt to use names in forth compiled with PF_NO_SHELL"; break; + case PF_ERR_NO_NAMES & 0xFF: + s = "dictionary has no names"; break; + case PF_ERR_OUT_OF_RANGE & 0xFF: + s = "parameter out of range"; break; + case PF_ERR_ENDIAN_CONFLICT & 0xFF: + s = "endian-ness of dictionary does not match code"; break; + case PF_ERR_FLOAT_CONFLICT & 0xFF: + s = "float support mismatch between .dic file and code"; break; + default: + s = "unrecognized error code!"; break; + } + MSG(s); + EMIT_CR; +} +#endif + +/************************************************************** +** Copy a Forth String to a 'C' string. +*/ + +char *ForthStringToC( char *dst, const char *FString ) +{ + int32 Len; + + Len = (int32) *FString; + pfCopyMemory( dst, FString+1, Len ); + dst[Len] = '\0'; + + return dst; +} + +/************************************************************** +** Copy a NUL terminated string to a Forth counted string. +*/ +char *CStringToForth( char *dst, const char *CString ) +{ + char *s; + int32 i; + + s = dst+1; + for( i=0; *CString; i++ ) + { + *s++ = *CString++; + } + *dst = (char ) i; + return dst; +} + +/************************************************************** +** Compare two test strings, case sensitive. +** Return TRUE if they match. +*/ +int32 ffCompareText( const char *s1, const char *s2, int32 len ) +{ + int32 i, Result; + + Result = TRUE; + for( i=0; is2; +*/ +int32 ffCompare( const char *s1, int32 len1, const char *s2, int32 len2 ) +{ + int32 i, result, n, diff; + + result = 0; + n = MIN(len1,len2); + for( i=0; i 0) ? -1 : 1 ; + break; + } + } + if( result == 0 ) /* Match up to MIN(len1,len2) */ + { + if( len1 < len2 ) + { + result = -1; + } + else if ( len1 > len2 ) + { + result = 1; + } + } + return result; +} + +/*************************************************************** +** Convert number to text. +*/ +#define CNTT_PAD_SIZE ((sizeof(int32)*8)+2) /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */ +static char cnttPad[CNTT_PAD_SIZE]; + +char *ConvertNumberToText( int32 Num, int32 Base, int32 IfSigned, int32 MinChars ) +{ + int32 IfNegative = 0; + char *p,c; + uint32 NewNum, Rem, uNum; + int32 i = 0; + + uNum = Num; + if( IfSigned ) + { +/* Convert to positive and keep sign. */ + if( Num < 0 ) + { + IfNegative = TRUE; + uNum = -Num; + } + } + +/* Point past end of Pad */ + p = cnttPad + CNTT_PAD_SIZE; + *(--p) = (char) 0; /* NUL terminate */ + + while( (i++ '}')) c = '.'; + EMIT(c); + } + EMIT_CR; + } +} + + +/* Print name, mask off any dictionary bits. */ +void TypeName( const char *Name ) +{ + const char *FirstChar; + int32 Len; + + FirstChar = Name+1; + Len = *Name & 0x1F; + + ioType( FirstChar, Len ); +} + diff --git a/csrc/pf_text.h b/csrc/pf_text.h new file mode 100644 index 0000000..7ea2378 --- /dev/null +++ b/csrc/pf_text.h @@ -0,0 +1,68 @@ +/* @(#) pf_text.h 96/12/18 1.10 */ +#ifndef _pforth_text_h +#define _pforth_text_h + +/*************************************************************** +** Include file for PForth Text +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#define PF_ERR_INDEX_MASK (0xFFFF) +#define PF_ERR_BASE (0x80000000) +#define PF_ERR_NO_MEM (PF_ERR_BASE | 0) +#define PF_ERR_BAD_ADDR (PF_ERR_BASE | 1) +#define PF_ERR_TOO_BIG (PF_ERR_BASE | 2) +#define PF_ERR_NUM_PARAMS (PF_ERR_BASE | 3) +#define PF_ERR_OPEN_FILE (PF_ERR_BASE | 4) +#define PF_ERR_WRONG_FILE (PF_ERR_BASE | 5) +#define PF_ERR_BAD_FILE (PF_ERR_BASE | 6) +#define PF_ERR_READ_FILE (PF_ERR_BASE | 7) +#define PF_ERR_WRITE_FILE (PF_ERR_BASE | 8) +#define PF_ERR_CORRUPT_DIC (PF_ERR_BASE | 9) +#define PF_ERR_NOT_SUPPORTED (PF_ERR_BASE | 10) +#define PF_ERR_VERSION_FUTURE (PF_ERR_BASE | 11) +#define PF_ERR_VERSION_PAST (PF_ERR_BASE | 12) +#define PF_ERR_COLON_STACK (PF_ERR_BASE | 13) +#define PF_ERR_HEADER_ROOM (PF_ERR_BASE | 14) +#define PF_ERR_CODE_ROOM (PF_ERR_BASE | 15) +#define PF_ERR_NO_SHELL (PF_ERR_BASE | 16) +#define PF_ERR_NO_NAMES (PF_ERR_BASE | 17) +#define PF_ERR_OUT_OF_RANGE (PF_ERR_BASE | 18) +#define PF_ERR_ENDIAN_CONFLICT (PF_ERR_BASE | 19) +#define PF_ERR_FLOAT_CONFLICT (PF_ERR_BASE | 20) +/* If you add an error code here, also add a text message in "pf_text.c". */ + +#ifdef __cplusplus +extern "C" { +#endif + +void pfReportError( const char *FunctionName, Err ErrCode ); + +char *ForthStringToC( char *dst, const char *FString ); +char *CStringToForth( char *dst, const char *CString ); + +int32 ffCompare( const char *s1, int32 len1, const char *s2, int32 len2 ); +int32 ffCompareText( const char *s1, const char *s2, int32 len ); +int32 ffCompareTextCaseN( const char *s1, const char *s2, int32 len ); + +void DumpMemory( void *addr, int32 cnt); +char *ConvertNumberToText( int32 Num, int32 Base, int32 IfSigned, int32 MinChars ); +void TypeName( const char *Name ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_text_h */ diff --git a/csrc/pf_types.h b/csrc/pf_types.h new file mode 100644 index 0000000..e727e41 --- /dev/null +++ b/csrc/pf_types.h @@ -0,0 +1,58 @@ +/* @(#) pf_types.h 96/12/18 1.3 */ +#ifndef _pf_types_h +#define _pf_types_h + +/*************************************************************** +** Type declarations for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/*************************************************************** +** Type Declarations +***************************************************************/ + +#ifndef int32 + typedef signed long int32; +#endif +#ifndef uint32 + typedef unsigned long uint32; +#endif +#ifndef int16 + typedef signed short int16; +#endif +#ifndef uint16 + typedef unsigned short uint16; +#endif +#ifndef int8 + typedef signed char int8; +#endif +#ifndef uint8 + typedef unsigned char uint8; +#endif +#ifndef Err + typedef long Err; +#endif + +typedef uint32 ExecToken; /* Execution Token */ +typedef int32 cell; +typedef uint32 ucell; +typedef cell *dicptr; + +typedef char ForthString; +typedef char *ForthStringPtr; + + + +#endif /* _pf_types_h */ diff --git a/csrc/pf_unix.h b/csrc/pf_unix.h new file mode 100644 index 0000000..67fbf36 --- /dev/null +++ b/csrc/pf_unix.h @@ -0,0 +1,41 @@ +/* @(#) pf_unix.h 98/01/28 1.4 */ +#ifndef _pf_unix_h +#define _pf_unix_h + +/*************************************************************** +** UNIX dependant include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#include + +#ifndef PF_NO_CLIB + #include /* Needed for strlen(), memcpy(), and memset(). */ + #include /* Needed for exit(). */ +#endif + +#include /* Needed for FILE and getc(). */ + +#ifdef PF_SUPPORT_FP + #include + + #ifndef PF_USER_FP + #include "pf_float.h" + #else + #include PF_USER_FP + #endif +#endif + +#endif /* _pf_unix_h */ diff --git a/csrc/pf_win32.h b/csrc/pf_win32.h new file mode 100644 index 0000000..e42e65d --- /dev/null +++ b/csrc/pf_win32.h @@ -0,0 +1,40 @@ +/* @(#) pf_win32.h 98/01/26 1.2 */ +#ifndef _pf_win32_h +#define _pf_win32_h + +/*************************************************************** +** WIN32 dependant include file for PForth, a Forth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +/* Include as PF_USER_INC2 for PCs */ + +/* Modify some existing defines. */ +/* +** The PC will insert LF characters into the dictionary files unless +** we use "b" mode! +*/ +#undef PF_FAM_CREATE +#define PF_FAM_CREATE ("wb+") + +#undef PF_FAM_OPEN_RO +#define PF_FAM_OPEN_RO ("rb") + +#undef PF_FAM_OPEN_RW +#define PF_FAM_OPEN_RW ("rb+") + +#define LITTLE_ENDIAN + +#endif /* _pf_win32_h */ diff --git a/csrc/pf_words.c b/csrc/pf_words.c new file mode 100644 index 0000000..b385861 --- /dev/null +++ b/csrc/pf_words.c @@ -0,0 +1,223 @@ +/* @(#) pf_words.c 96/12/18 1.10 */ +/*************************************************************** +** Forth words for PForth based on 'C' +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** +** 941031 rdg fix ffScan() to look for CRs and LFs +** +***************************************************************/ + +#include "pf_all.h" + + +/*************************************************************** +** Print number in current base to output stream. +** This version does not handle double precision. +*/ +void ffDot( int32 n ) +{ + MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) ); + EMIT(' '); +} + +/*************************************************************** +** Print number in current base to output stream. +** This version does not handle double precision. +*/ +void ffDotHex( int32 n ) +{ + MSG( ConvertNumberToText( n, 16, FALSE, 1 ) ); + EMIT(' '); +} + +/* ( ... --- ... , print stack ) */ +void ffDotS( void ) +{ + cell *sp; + int32 i, Depth; + + MSG("Stack<"); + MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */ + MSG("> "); + + Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr; + sp = gCurrentTask->td_StackBase; + + if( Depth < 0 ) + { + MSG("UNDERFLOW!"); + } + else + { + for( i=0; i 0 ) && + (( *s == BLANK) || ( *s == '\t')) ) + { +DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt )); + s++; + Cnt--; + } + } + else + { + while(( Cnt > 0 ) && ( *s == c )) + { +DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt )); + s++; + Cnt--; + } + } + *AddrOut = s; + return Cnt; +} + +/* ( addr cnt char -- addr' cnt' , scan for char ) */ +cell ffScan( char *AddrIn, cell Cnt, char c, char **AddrOut ) +{ + char *s; + + s = AddrIn; + + if( c == BLANK ) + { + while(( Cnt > 0 ) && + ( *s != BLANK) && + ( *s != '\r') && + ( *s != '\n') && + ( *s != '\t')) + { +DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt )); + s++; + Cnt--; + } + } + else + { + while(( Cnt > 0 ) && ( *s != c )) + { +DBUGX(("ffScan: %c, %d\n", *s, Cnt )); + s++; + Cnt--; + } + } + *AddrOut = s; + return Cnt; +} + +/*************************************************************** +** Forth equivalent 'C' functions. +***************************************************************/ + +/* Convert a single digit to the corresponding hex number. */ +static cell HexDigitToNumber( char c ) +{ + if( (c >= '0') && (c <= '9') ) + { + return( c - '0' ); + } + else if ( (c >= 'A') && (c <= 'F') ) + { + return( c - 'A' + 0x0A ); + } + else + { + return -1; + } +} + +/* Convert a string to the corresponding number using BASE. */ +cell ffNumberQ( const char *FWord, cell *Num ) +{ + int32 Len, i, Accum=0, n, Sign=1; + const char *s; + +/* get count */ + Len = *FWord++; + s = FWord; + +/* process initial minus sign */ + if( *s == '-' ) + { + Sign = -1; + s++; + Len--; + } + + for( i=0; i= gVarBase) ) + { + return NUM_TYPE_BAD; + } + + Accum = (Accum * gVarBase) + n; + } + *Num = Accum * Sign; + return NUM_TYPE_SINGLE; +} + +/*************************************************************** +** Compiler Support +***************************************************************/ + +/* ( char -- c-addr , parse word ) */ +char * ffWord( char c ) +{ + char *s1,*s2,*s3; + int32 n1, n2, n3; + int32 i, nc; + + s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN; + n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN; + n2 = ffSkip( s1, n1, c, &s2 ); +DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 )); + n3 = ffScan( s2, n2, c, &s3 ); +DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 )); + nc = n2-n3; + if (nc > 0) + { + gScratch[0] = (char) nc; + for( i=0; itd_IN += (n1-n3) + 1; + return &gScratch[0]; +} diff --git a/csrc/pf_words.h b/csrc/pf_words.h new file mode 100644 index 0000000..48729dc --- /dev/null +++ b/csrc/pf_words.h @@ -0,0 +1,36 @@ +/* @(#) pf_words.h 96/12/18 1.7 */ +#ifndef _pforth_words_h +#define _pforth_words_h + +/*************************************************************** +** Include file for PForth Words +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +void ffDot( int32 n ); +void ffDotHex( int32 n ); +void ffDotS( void ); +cell ffSkip( char *AddrIn, cell Cnt, char c, char **AddrOut ); +cell ffScan( char *AddrIn, cell Cnt, char c, char **AddrOut ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_words_h */ diff --git a/csrc/pfcompfp.h b/csrc/pfcompfp.h new file mode 100644 index 0000000..1e5b773 --- /dev/null +++ b/csrc/pfcompfp.h @@ -0,0 +1,78 @@ +/* @(#) pfcompfp.h 96/12/18 1.6 */ +/*************************************************************** +** Compile FP routines. +** This file is included from "pf_compile.c" +** +** These routines could be left out of an execute only version. +** +** Author: Darren Gibbs, Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +***************************************************************/ + + +#ifdef PF_SUPPORT_FP +/* Core words */ + CreateDicEntryC( ID_FP_D_TO_F, "D>F", 0 ); + CreateDicEntryC( ID_FP_FSTORE, "F!", 0 ); + CreateDicEntryC( ID_FP_FTIMES, "F*", 0 ); + CreateDicEntryC( ID_FP_FPLUS, "F+", 0 ); + CreateDicEntryC( ID_FP_FMINUS, "F-", 0 ); + CreateDicEntryC( ID_FP_FSLASH, "F/", 0 ); + CreateDicEntryC( ID_FP_F_ZERO_LESS_THAN, "F0<", 0 ); + CreateDicEntryC( ID_FP_F_ZERO_EQUALS, "F0=", 0 ); + CreateDicEntryC( ID_FP_F_LESS_THAN, "F<", 0 ); + CreateDicEntryC( ID_FP_F_TO_D, "F>D", 0 ); + CreateDicEntryC( ID_FP_FFETCH, "F@", 0 ); + CreateDicEntryC( ID_FP_FDEPTH, "FDEPTH", 0 ); + CreateDicEntryC( ID_FP_FDROP, "FDROP", 0 ); + CreateDicEntryC( ID_FP_FDUP, "FDUP", 0 ); + CreateDicEntryC( ID_FP_FLITERAL, "FLITERAL", 0 ); + CreateDicEntryC( ID_FP_FLITERAL_P, "(FLITERAL)", 0 ); + CreateDicEntryC( ID_FP_FLOAT_PLUS, "FLOAT+", 0 ); + CreateDicEntryC( ID_FP_FLOATS, "FLOATS", 0 ); + CreateDicEntryC( ID_FP_FLOOR, "FLOOR", 0 ); + CreateDicEntryC( ID_FP_FMAX, "FMAX", 0 ); + CreateDicEntryC( ID_FP_FMIN, "FMIN", 0 ); + CreateDicEntryC( ID_FP_FNEGATE, "FNEGATE", 0 ); + CreateDicEntryC( ID_FP_FOVER, "FOVER", 0 ); + CreateDicEntryC( ID_FP_FROT, "FROT", 0 ); + CreateDicEntryC( ID_FP_FROUND, "FROUND", 0 ); + CreateDicEntryC( ID_FP_FSWAP, "FSWAP", 0 ); + +/* Extended words */ + CreateDicEntryC( ID_FP_FSTAR_STAR, "F**", 0 ); + CreateDicEntryC( ID_FP_FABS, "FABS", 0 ); + CreateDicEntryC( ID_FP_FACOS, "FACOS", 0 ); + CreateDicEntryC( ID_FP_FACOSH, "FACOSH", 0 ); + CreateDicEntryC( ID_FP_FALOG, "FALOG", 0 ); + CreateDicEntryC( ID_FP_FASIN, "FASIN", 0 ); + CreateDicEntryC( ID_FP_FASINH, "FASINH", 0 ); + CreateDicEntryC( ID_FP_FATAN, "FATAN", 0 ); + CreateDicEntryC( ID_FP_FATAN2, "FATAN2", 0 ); + CreateDicEntryC( ID_FP_FATANH, "FATANH", 0 ); + CreateDicEntryC( ID_FP_FCOS, "FCOS", 0 ); + CreateDicEntryC( ID_FP_FCOSH, "FCOSH", 0 ); + CreateDicEntryC( ID_FP_FLN, "FLN", 0 ); + CreateDicEntryC( ID_FP_FLNP1, "FLNP1", 0 ); + CreateDicEntryC( ID_FP_FLOG, "FLOG", 0 ); + CreateDicEntryC( ID_FP_FSIN, "FSIN", 0 ); + CreateDicEntryC( ID_FP_FSINCOS, "FSINCOS", 0 ); + CreateDicEntryC( ID_FP_FSINH, "FSINH", 0 ); + CreateDicEntryC( ID_FP_FSQRT, "FSQRT", 0 ); + CreateDicEntryC( ID_FP_FTAN, "FTAN", 0 ); + CreateDicEntryC( ID_FP_FTANH, "FTANH", 0 ); + CreateDicEntryC( ID_FP_FPICK, "FPICK", 0 ); + +#endif diff --git a/csrc/pfcompil.c b/csrc/pfcompil.c new file mode 100644 index 0000000..5bbb218 --- /dev/null +++ b/csrc/pfcompil.c @@ -0,0 +1,1104 @@ +/* @(#) pfcompil.c 98/01/26 1.5 */ +/*************************************************************** +** Compiler for PForth based on 'C' +** +** These routines could be left out of an execute only version. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** 941004 PLB Extracted IO calls from pforth_main.c +** 950320 RDG Added underflow checking for FP stack +***************************************************************/ + +#include "pf_all.h" +#include "pfcompil.h" + +#define ABORT_RETURN_CODE (10) + +/***************************************************************/ +/************** GLOBAL DATA ************************************/ +/***************************************************************/ +/* data for INCLUDE that allows multiple nested files. */ +static IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH]; +static int32 gIncludeIndex; + +static ExecToken gNumberQ_XT; /* XT of NUMBER? */ +static ExecToken gQuitP_XT; /* XT of (QUIT) */ + +/***************************************************************/ +/************** Static Prototypes ******************************/ +/***************************************************************/ + +static void ffStringColon( const ForthStringPtr FName ); +static int32 CheckRedefinition( const ForthStringPtr FName ); +static void ReportIncludeState( void ); +static void ffUnSmudge( void ); +static void FindAndCompile( const char *theWord ); +static int32 ffCheckDicRoom( void ); +static void ffCleanIncludeStack( void ); + +#ifndef PF_NO_INIT + static void CreateDeferredC( ExecToken DefaultXT, const char *CName ); +#endif + +int32 NotCompiled( const char *FunctionName ) +{ + MSG("Function "); + MSG(FunctionName); + MSG(" not compiled in this version of PForth.\n"); + return -1; +} + +#ifndef PF_NO_SHELL +/*************************************************************** +** Create an entry in the Dictionary for the given ExecutionToken. +** FName is name in Forth format. +*/ +void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, uint32 Flags ) +{ + cfNameLinks *cfnl; + + cfnl = (cfNameLinks *) gCurrentDictionary->dic_HeaderPtr.Byte; + +/* Set link to previous header, if any. */ + if( gVarContext ) + { + WRITE_LONG_DIC( &cfnl->cfnl_PreviousName, ABS_TO_NAMEREL( gVarContext ) ); + } + else + { + cfnl->cfnl_PreviousName = 0; + } + +/* Put Execution token in header. */ + WRITE_LONG_DIC( &cfnl->cfnl_ExecToken, XT ); + +/* Advance Header Dictionary Pointer */ + gCurrentDictionary->dic_HeaderPtr.Byte += sizeof(cfNameLinks); + +/* Laydown name. */ + gVarContext = (char *) gCurrentDictionary->dic_HeaderPtr.Byte; + pfCopyMemory( gCurrentDictionary->dic_HeaderPtr.Byte, FName, (*FName)+1 ); + gCurrentDictionary->dic_HeaderPtr.Byte += (*FName)+1; + +/* Set flags. */ + *gVarContext |= (char) Flags; + +/* Align to quad byte boundaries with zeroes. */ + while( ((uint32) gCurrentDictionary->dic_HeaderPtr.Byte) & 3) + { + *gCurrentDictionary->dic_HeaderPtr.Byte++ = 0; + } +} + +/*************************************************************** +** Convert name then create dictionary entry. +*/ +void CreateDicEntryC( ExecToken XT, const char *CName, uint32 Flags ) +{ + ForthString FName[40]; + CStringToForth( FName, CName ); + CreateDicEntry( XT, FName, Flags ); +} + +/*************************************************************** +** Convert absolute namefield address to previous absolute name +** field address or NULL. +*/ +const ForthString *NameToPrevious( const ForthString *NFA ) +{ + cell RelNamePtr; + const cfNameLinks *cfnl; + +/* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (int32) NFA)); */ + cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) ); + + RelNamePtr = READ_LONG_DIC((const cell *) (&cfnl->cfnl_PreviousName)); +/* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (int32) RelNamePtr )); */ + if( RelNamePtr ) + { + return ( NAMEREL_TO_ABS( RelNamePtr ) ); + } + else + { + return NULL; + } +} +/*************************************************************** +** Convert NFA to ExecToken. +*/ +ExecToken NameToToken( const ForthString *NFA ) +{ + const cfNameLinks *cfnl; + +/* Convert absolute namefield address to absolute link field address. */ + cfnl = (const cfNameLinks *) ( ((const char *) NFA) - sizeof(cfNameLinks) ); + + return READ_LONG_DIC((const cell *) (&cfnl->cfnl_ExecToken)); +} + +/*************************************************************** +** Find XTs needed by compiler. +*/ +int32 FindSpecialXTs( void ) +{ + + if( ffFindC( "(QUIT)", &gQuitP_XT ) == 0) goto nofind; + if( ffFindC( "NUMBER?", &gNumberQ_XT ) == 0) goto nofind; +DBUG(("gNumberQ_XT = 0x%x\n", gNumberQ_XT )); + return 0; + +nofind: + ERR("FindSpecialXTs failed!\n"); + return -1; +} + +/*************************************************************** +** Build a dictionary from scratch. +*/ +#ifndef PF_NO_INIT +cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ) +{ + cfDictionary *dic; + + dic = pfCreateDictionary( HeaderSize, CodeSize ); + if( !dic ) goto nomem; + + gCurrentDictionary = dic; + gNumPrimitives = NUM_PRIMITIVES; + + CreateDicEntryC( ID_EXIT, "EXIT", 0 ); + CreateDicEntryC( ID_1MINUS, "1-", 0 ); + CreateDicEntryC( ID_1PLUS, "1+", 0 ); + CreateDicEntryC( ID_2_R_FETCH, "2R@", 0 ); + CreateDicEntryC( ID_2_R_FROM, "2R>", 0 ); + CreateDicEntryC( ID_2_TO_R, "2>R", 0 ); + CreateDicEntryC( ID_2DUP, "2DUP", 0 ); + CreateDicEntryC( ID_2LITERAL, "2LITERAL", FLAG_IMMEDIATE ); + CreateDicEntryC( ID_2LITERAL_P, "(2LITERAL)", 0 ); + CreateDicEntryC( ID_2MINUS, "2-", 0 ); + CreateDicEntryC( ID_2PLUS, "2+", 0 ); + CreateDicEntryC( ID_2OVER, "2OVER", 0 ); + CreateDicEntryC( ID_2SWAP, "2SWAP", 0 ); + CreateDicEntryC( ID_ACCEPT, "ACCEPT", 0 ); + CreateDicEntryC( ID_ALITERAL, "ALITERAL", FLAG_IMMEDIATE ); + CreateDicEntryC( ID_ALITERAL_P, "(ALITERAL)", 0 ); + CreateDicEntryC( ID_ALLOCATE, "ALLOCATE", 0 ); + CreateDicEntryC( ID_ARSHIFT, "ARSHIFT", 0 ); + CreateDicEntryC( ID_AND, "AND", 0 ); + CreateDicEntryC( ID_BAIL, "BAIL", 0 ); + CreateDicEntryC( ID_BRANCH, "BRANCH", 0 ); + CreateDicEntryC( ID_BODY_OFFSET, "BODY_OFFSET", 0 ); + CreateDicEntryC( ID_BYE, "BYE", 0 ); + CreateDicEntryC( ID_CFETCH, "C@", 0 ); + CreateDicEntryC( ID_CMOVE, "CMOVE", 0 ); + CreateDicEntryC( ID_CMOVE_UP, "CMOVE>", 0 ); + CreateDicEntryC( ID_COLON, ":", 0 ); + CreateDicEntryC( ID_COLON_P, "(:)", 0 ); + CreateDicEntryC( ID_COMPARE, "COMPARE", 0 ); + CreateDicEntryC( ID_COMP_EQUAL, "=", 0 ); + CreateDicEntryC( ID_COMP_NOT_EQUAL, "<>", 0 ); + CreateDicEntryC( ID_COMP_GREATERTHAN, ">", 0 ); + CreateDicEntryC( ID_COMP_U_GREATERTHAN, "U>", 0 ); + CreateDicEntryC( ID_COMP_LESSTHAN, "<", 0 ); + CreateDicEntryC( ID_COMP_U_LESSTHAN, "U<", 0 ); + CreateDicEntryC( ID_COMP_ZERO_EQUAL, "0=", 0 ); + CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL, "0<>", 0 ); + CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN, "0>", 0 ); + CreateDicEntryC( ID_COMP_ZERO_LESSTHAN, "0<", 0 ); + CreateDicEntryC( ID_CR, "CR", 0 ); + CreateDicEntryC( ID_CREATE, "CREATE", 0 ); + CreateDicEntryC( ID_CREATE_P, "(CREATE)", 0 ); + CreateDicEntryC( ID_D_PLUS, "D+", 0 ); + CreateDicEntryC( ID_D_MINUS, "D-", 0 ); + CreateDicEntryC( ID_D_UMSMOD, "UM/MOD", 0 ); + CreateDicEntryC( ID_D_MUSMOD, "MU/MOD", 0 ); + CreateDicEntryC( ID_D_MTIMES, "M*", 0 ); + CreateDicEntryC( ID_D_UMTIMES, "UM*", 0 ); + CreateDicEntryC( ID_DEFER, "DEFER", 0 ); + CreateDicEntryC( ID_CSTORE, "C!", 0 ); + CreateDicEntryC( ID_DEPTH, "DEPTH", 0 ); + CreateDicEntryC( ID_DIVIDE, "/", 0 ); + CreateDicEntryC( ID_DOT, ".", 0 ); + CreateDicEntryC( ID_DOTS, ".S", 0 ); + CreateDicEntryC( ID_DO_P, "(DO)", 0 ); + CreateDicEntryC( ID_DROP, "DROP", 0 ); + CreateDicEntryC( ID_DUMP, "DUMP", 0 ); + CreateDicEntryC( ID_DUP, "DUP", 0 ); + CreateDicEntryC( ID_EMIT_P, "(EMIT)", 0 ); + CreateDeferredC( ID_EMIT_P, "EMIT"); + CreateDicEntryC( ID_EOL, "EOL", 0 ); + CreateDicEntryC( ID_ERRORQ_P, "(?ERROR)", 0 ); + CreateDicEntryC( ID_ERRORQ_P, "?ERROR", 0 ); + CreateDicEntryC( ID_EXECUTE, "EXECUTE", 0 ); + CreateDicEntryC( ID_FETCH, "@", 0 ); + CreateDicEntryC( ID_FILL, "FILL", 0 ); + CreateDicEntryC( ID_FIND, "FIND", 0 ); + CreateDicEntryC( ID_FILE_CREATE, "CREATE-FILE", 0 ); + CreateDicEntryC( ID_FILE_OPEN, "OPEN-FILE", 0 ); + CreateDicEntryC( ID_FILE_CLOSE, "CLOSE-FILE", 0 ); + CreateDicEntryC( ID_FILE_READ, "READ-FILE", 0 ); + CreateDicEntryC( ID_FILE_SIZE, "FILE-SIZE", 0 ); + CreateDicEntryC( ID_FILE_WRITE, "WRITE-FILE", 0 ); + CreateDicEntryC( ID_FILE_POSITION, "FILE-POSITION", 0 ); + CreateDicEntryC( ID_FILE_REPOSITION, "REPOSITION-FILE", 0 ); + CreateDicEntryC( ID_FILE_RO, "R/O", 0 ); + CreateDicEntryC( ID_FILE_RW, "R/W", 0 ); + CreateDicEntryC( ID_FINDNFA, "FINDNFA", 0 ); + CreateDicEntryC( ID_FLUSHEMIT, "FLUSHEMIT", 0 ); + CreateDicEntryC( ID_FREE, "FREE", 0 ); +#include "pfcompfp.h" + CreateDicEntryC( ID_HERE, "HERE", 0 ); + CreateDicEntryC( ID_NUMBERQ_P, "(SNUMBER?)", 0 ); + CreateDicEntryC( ID_I, "I", 0 ); + CreateDicEntryC( ID_J, "J", 0 ); + CreateDicEntryC( ID_INCLUDE_FILE, "INCLUDE-FILE", 0 ); + CreateDicEntryC( ID_KEY, "KEY", 0 ); + CreateDicEntryC( ID_LEAVE_P, "(LEAVE)", 0 ); + CreateDicEntryC( ID_LITERAL, "LITERAL", FLAG_IMMEDIATE ); + CreateDicEntryC( ID_LITERAL_P, "(LITERAL)", 0 ); + CreateDicEntryC( ID_LOADSYS, "LOADSYS", 0 ); + CreateDicEntryC( ID_LOCAL_COMPILER, "LOCAL-COMPILER", 0 ); + CreateDicEntryC( ID_LOCAL_ENTRY, "(LOCAL.ENTRY)", 0 ); + CreateDicEntryC( ID_LOCAL_EXIT, "(LOCAL.EXIT)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH, "(LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_1, "(1_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_2, "(2_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_3, "(3_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_4, "(4_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_5, "(5_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_6, "(6_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_7, "(7_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_FETCH_8, "(8_LOCAL@)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE, "(LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_1, "(1_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_2, "(2_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_3, "(3_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_4, "(4_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_5, "(5_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_6, "(6_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_7, "(7_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_STORE_8, "(8_LOCAL!)", 0 ); + CreateDicEntryC( ID_LOCAL_PLUSSTORE, "(LOCAL+!)", 0 ); + CreateDicEntryC( ID_LOOP_P, "(LOOP)", 0 ); + CreateDicEntryC( ID_LSHIFT, "LSHIFT", 0 ); + CreateDicEntryC( ID_MAX, "MAX", 0 ); + CreateDicEntryC( ID_MIN, "MIN", 0 ); + CreateDicEntryC( ID_MINUS, "-", 0 ); + CreateDicEntryC( ID_NAME_TO_TOKEN, "NAME>", 0 ); + CreateDicEntryC( ID_NAME_TO_PREVIOUS, "PREVNAME", 0 ); + CreateDicEntryC( ID_NOOP, "NOOP", 0 ); + CreateDeferredC( ID_NUMBERQ_P, "NUMBER?" ); + CreateDicEntryC( ID_OR, "OR", 0 ); + CreateDicEntryC( ID_OVER, "OVER", 0 ); + CreateDicEntryC( ID_PICK, "PICK", 0 ); + CreateDicEntryC( ID_PLUS, "+", 0 ); + CreateDicEntryC( ID_PLUSLOOP_P, "(+LOOP)", 0 ); + CreateDicEntryC( ID_PLUS_STORE, "+!", 0 ); + CreateDicEntryC( ID_QUIT_P, "(QUIT)", 0 ); + CreateDeferredC( ID_QUIT_P, "QUIT" ); + CreateDicEntryC( ID_QDO_P, "(?DO)", 0 ); + CreateDicEntryC( ID_QDUP, "?DUP", 0 ); + CreateDicEntryC( ID_QTERMINAL, "?TERMINAL", 0 ); + CreateDicEntryC( ID_QTERMINAL, "KEY?", 0 ); + CreateDicEntryC( ID_REFILL, "REFILL", 0 ); + CreateDicEntryC( ID_RESIZE, "RESIZE", 0 ); + CreateDicEntryC( ID_ROLL, "ROLL", 0 ); + CreateDicEntryC( ID_ROT, "ROT", 0 ); + CreateDicEntryC( ID_RSHIFT, "RSHIFT", 0 ); + CreateDicEntryC( ID_R_DROP, "RDROP", 0 ); + CreateDicEntryC( ID_R_FETCH, "R@", 0 ); + CreateDicEntryC( ID_R_FROM, "R>", 0 ); + CreateDicEntryC( ID_RP_FETCH, "RP@", 0 ); + CreateDicEntryC( ID_RP_STORE, "RP!", 0 ); + CreateDicEntryC( ID_SEMICOLON, ";", FLAG_IMMEDIATE ); + CreateDicEntryC( ID_SP_FETCH, "SP@", 0 ); + CreateDicEntryC( ID_SP_STORE, "SP!", 0 ); + CreateDicEntryC( ID_STORE, "!", 0 ); + CreateDicEntryC( ID_SAVE_FORTH_P, "(SAVE-FORTH)", 0 ); + CreateDicEntryC( ID_SCAN, "SCAN", 0 ); + CreateDicEntryC( ID_SKIP, "SKIP", 0 ); + CreateDicEntryC( ID_SOURCE, "SOURCE", 0 ); + CreateDicEntryC( ID_SOURCE_SET, "SET-SOURCE", 0 ); + CreateDicEntryC( ID_SOURCE_ID, "SOURCE-ID", 0 ); + CreateDicEntryC( ID_SOURCE_ID_PUSH, "PUSH-SOURCE-ID", 0 ); + CreateDicEntryC( ID_SOURCE_ID_POP, "POP-SOURCE-ID", 0 ); + CreateDicEntryC( ID_SWAP, "SWAP", 0 ); + CreateDicEntryC( ID_TEST1, "TEST1", 0 ); + CreateDicEntryC( ID_TICK, "'", 0 ); + CreateDicEntryC( ID_TIMES, "*", 0 ); + CreateDicEntryC( ID_TO_R, ">R", 0 ); + CreateDicEntryC( ID_TYPE, "TYPE", 0 ); + CreateDicEntryC( ID_VAR_BASE, "BASE", 0 ); + CreateDicEntryC( ID_VAR_CODE_BASE, "CODE-BASE", 0 ); + CreateDicEntryC( ID_VAR_CODE_LIMIT, "CODE-LIMIT", 0 ); + CreateDicEntryC( ID_VAR_CONTEXT, "CONTEXT", 0 ); + CreateDicEntryC( ID_VAR_DP, "DP", 0 ); + CreateDicEntryC( ID_VAR_ECHO, "ECHO", 0 ); + CreateDicEntryC( ID_VAR_HEADERS_PTR, "HEADERS-PTR", 0 ); + CreateDicEntryC( ID_VAR_HEADERS_BASE, "HEADERS-BASE", 0 ); + CreateDicEntryC( ID_VAR_HEADERS_LIMIT, "HEADERS-LIMIT", 0 ); + CreateDicEntryC( ID_VAR_NUM_TIB, "#TIB", 0 ); + CreateDicEntryC( ID_VAR_RETURN_CODE, "RETURN-CODE", 0 ); + CreateDicEntryC( ID_VAR_TRACE_FLAGS, "TRACE-FLAGS", 0 ); + CreateDicEntryC( ID_VAR_TRACE_LEVEL, "TRACE-LEVEL", 0 ); + CreateDicEntryC( ID_VAR_TRACE_STACK, "TRACE-STACK", 0 ); + CreateDicEntryC( ID_VAR_OUT, "OUT", 0 ); + CreateDicEntryC( ID_VAR_STATE, "STATE", 0 ); + CreateDicEntryC( ID_VAR_TO_IN, ">IN", 0 ); + CreateDicEntryC( ID_VLIST, "VLIST", 0 ); + CreateDicEntryC( ID_WORD, "WORD", 0 ); + CreateDicEntryC( ID_WORD_FETCH, "W@", 0 ); + CreateDicEntryC( ID_WORD_STORE, "W!", 0 ); + CreateDicEntryC( ID_XOR, "XOR", 0 ); + CreateDicEntryC( ID_ZERO_BRANCH, "0BRANCH", 0 ); + + if( FindSpecialXTs() < 0 ) goto error; + + if( CompileCustomFunctions() < 0 ) goto error; /* Call custom 'C' call builder. */ + +#ifdef PF_DEBUG + DumpMemory( dic->dic_HeaderBase, 256 ); + DumpMemory( dic->dic_CodeBase, 256 ); +#endif + + return dic; + +error: + pfDeleteDictionary( dic ); + return NULL; + +nomem: + return NULL; +} +#endif /* !PF_NO_INIT */ + +/* +** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT ) +** 1 for IMMEDIATE values +*/ +cell ffTokenToName( ExecToken XT, const ForthString **NFAPtr ) +{ + const ForthString *NameField; + int32 Searching = TRUE; + cell Result = 0; + ExecToken TempXT; + + NameField = gVarContext; +DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext)); + + do + { + TempXT = NameToToken( NameField ); + + if( TempXT == XT ) + { +DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField)); + *NFAPtr = NameField ; + Result = 1; + Searching = FALSE; + } + else + { + NameField = NameToPrevious( NameField ); + if( NameField == NULL ) + { + *NFAPtr = 0; + Searching = FALSE; + } + } + } while ( Searching); + + return Result; +} + +/* +** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary ) +** 1 for IMMEDIATE values +*/ +cell ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ) +{ + const ForthString *WordChar; + uint8 WordLen; + const char *NameField, *NameChar; + int8 NameLen; + int32 Searching = TRUE; + cell Result = 0; + + WordLen = (uint8) ((uint32)*WordName & 0x1F); + WordChar = WordName+1; + + NameField = gVarContext; +DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen, WordLen, WordChar )); +DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext)); + do + { + NameLen = (uint8) ((uint32)(*NameField) & MASK_NAME_SIZE); + NameChar = NameField+1; +/* DBUG((" %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */ + if( ((*NameField & FLAG_SMUDGE) == 0) && + (NameLen == WordLen) && + ffCompareTextCaseN( NameChar, WordChar, WordLen ) ) /* FIXME - slow */ + { +DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField)); + *NFAPtr = NameField ; + Result = ((*NameField) & FLAG_IMMEDIATE) ? 1 : -1; + Searching = FALSE; + } + else + { + NameField = NameToPrevious( NameField ); + if( NameField == NULL ) + { + *NFAPtr = WordName; + Searching = FALSE; + } + } + } while ( Searching); +DBUG(("ffFindNFA: returns 0x%x\n", Result)); + return Result; +} + + +/*************************************************************** +** ( $name -- $name 0 | xt -1 | xt 1 ) +** 1 for IMMEDIATE values +*/ +cell ffFind( const ForthString *WordName, ExecToken *pXT ) +{ + const ForthString *NFA; + int32 Result; + + Result = ffFindNFA( WordName, &NFA ); +DBUG(("ffFind: %8s at 0x%x\n", WordName+1, NFA)); /* WARNING, not NUL terminated. %Q */ + if( Result ) + { + *pXT = NameToToken( NFA ); + } + else + { + *pXT = (ExecToken) WordName; + } + + return Result; +} + +/**************************************************************** +** Find name when passed 'C' string. +*/ +cell ffFindC( const char *WordName, ExecToken *pXT ) +{ +DBUG(("ffFindC: %s\n", WordName )); + CStringToForth( gScratch, WordName ); + return ffFind( gScratch, pXT ); +} + + +/***********************************************************/ +/********* Compiling New Words *****************************/ +/***********************************************************/ +#define DIC_SAFETY_MARGIN (400) + +/************************************************************* +** Check for dictionary overflow. +*/ +static int32 ffCheckDicRoom( void ) +{ + int32 RoomLeft; + RoomLeft = gCurrentDictionary->dic_HeaderLimit - + gCurrentDictionary->dic_HeaderPtr.Byte; + if( RoomLeft < DIC_SAFETY_MARGIN ) + { + pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM); + return PF_ERR_HEADER_ROOM; + } + + RoomLeft = gCurrentDictionary->dic_CodeLimit - + gCurrentDictionary->dic_CodePtr.Byte; + if( RoomLeft < DIC_SAFETY_MARGIN ) + { + pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM); + return PF_ERR_CODE_ROOM; + } + return 0; +} + +/************************************************************* +** Create a dictionary entry given a string name. +*/ +void ffCreateSecondaryHeader( const ForthStringPtr FName) +{ +/* Check for dictionary overflow. */ + if( ffCheckDicRoom() ) return; + + CheckRedefinition( FName ); +/* Align CODE_HERE */ + CODE_HERE = (cell *)( (((uint32)CODE_HERE) + 3) & ~3); + CreateDicEntry( (ExecToken) ABS_TO_CODEREL(CODE_HERE), FName, FLAG_SMUDGE ); +DBUG(("ffCreateSecondaryHeader, XT = 0x%x, Name = %8s\n")); +} + +/************************************************************* +** Begin compiling a secondary word. +*/ +static void ffStringColon( const ForthStringPtr FName) +{ + ffCreateSecondaryHeader( FName ); + gVarState = 1; +} + +/************************************************************* +** Read the next ExecToken from the Source and create a word. +*/ +void ffColon( void ) +{ + char *FName; + + gDepthAtColon = DATA_STACK_DEPTH; + + FName = ffWord( BLANK ); + if( *FName > 0 ) + { + ffStringColon( FName ); + } +} + +/************************************************************* +** Check to see if name is already in dictionary. +*/ +static int32 CheckRedefinition( const ForthStringPtr FName ) +{ + int32 Flag; + ExecToken XT; + + Flag = ffFind( FName, &XT); + if( Flag ) + { + ioType( FName+1, (int32) *FName ); + MSG( " already defined.\n" ); + } + return Flag; +} + +void ffStringCreate( char *FName) +{ + ffCreateSecondaryHeader( FName ); + + CODE_COMMA( ID_CREATE_P ); + CODE_COMMA( ID_EXIT ); + ffFinishSecondary(); + +} + +/* Read the next ExecToken from the Source and create a word. */ +void ffCreate( void ) +{ + char *FName; + + FName = ffWord( BLANK ); + if( *FName > 0 ) + { + ffStringCreate( FName ); + } +} + +void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ) +{ + + ffCreateSecondaryHeader( FName ); + + CODE_COMMA( ID_DEFER_P ); + CODE_COMMA( DefaultXT ); + + ffFinishSecondary(); + +} +#ifndef PF_NO_INIT +/* Convert name then create deferred dictionary entry. */ +static void CreateDeferredC( ExecToken DefaultXT, const char *CName ) +{ + char FName[40]; + CStringToForth( FName, CName ); + ffStringDefer( FName, DefaultXT ); +} +#endif + +/* Read the next token from the Source and create a word. */ +void ffDefer( void ) +{ + char *FName; + + FName = ffWord( BLANK ); + if( *FName > 0 ) + { + ffStringDefer( FName, ID_QUIT_P ); + } +} + +/* Unsmudge the word to make it visible. */ +void ffUnSmudge( void ) +{ + *gVarContext &= ~FLAG_SMUDGE; +} + +/* Implement ; */ +void ffSemiColon( void ) +{ + gVarState = 0; + + if( (gDepthAtColon != DATA_STACK_DEPTH) && + (gDepthAtColon != DEPTH_AT_COLON_INVALID) ) /* Ignore if no ':' */ + { + pfReportError("ffSemiColon", PF_ERR_COLON_STACK); + ffAbort(); + } + else + { + ffFinishSecondary(); + } + gDepthAtColon = DEPTH_AT_COLON_INVALID; +} + +/* Finish the definition of a Forth word. */ +void ffFinishSecondary( void ) +{ + CODE_COMMA( ID_EXIT ); + ffUnSmudge(); +} + +/**************************************************************/ +/* Used to pull a number from the dictionary to the stack */ +void ff2Literal( cell dHi, cell dLo ) +{ + CODE_COMMA( ID_2LITERAL_P ); + CODE_COMMA( dHi ); + CODE_COMMA( dLo ); +} +void ffALiteral( cell Num ) +{ + CODE_COMMA( ID_ALITERAL_P ); + CODE_COMMA( Num ); +} +void ffLiteral( cell Num ) +{ + CODE_COMMA( ID_LITERAL_P ); + CODE_COMMA( Num ); +} + +#ifdef PF_SUPPORT_FP +void ffFPLiteral( PF_FLOAT fnum ) +{ + /* Hack for Metrowerks complier which won't compile the + * original expression. + */ + PF_FLOAT *temp; + cell *dicPtr; + +/* Make sure that literal float data is float aligned. */ + dicPtr = CODE_HERE + 1; + while( (((uint32) dicPtr++) & (sizeof(PF_FLOAT) - 1)) != 0) + { + DBUG((" comma NOOP to align FPLiteral\n")); + CODE_COMMA( ID_NOOP ); + } + CODE_COMMA( ID_FP_FLITERAL_P ); + + temp = (PF_FLOAT *)CODE_HERE; + WRITE_FLOAT_DIC(temp,fnum); /* Write to dictionary. */ + temp++; + CODE_HERE = (cell *) temp; +} +#endif /* PF_SUPPORT_FP */ + +/**************************************************************/ +void FindAndCompile( const char *theWord ) +{ + int32 Flag; + ExecToken XT; + cell Num; + + Flag = ffFind( theWord, &XT); +DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord, XT, Flag )); + +/* Is it a normal word ? */ + if( Flag == -1 ) + { + if( gVarState ) /* compiling? */ + { + CODE_COMMA( XT ); + } + else + { + pfExecuteToken( XT ); + } + } + else if ( Flag == 1 ) /* or is it IMMEDIATE ? */ + { +DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord )); + pfExecuteToken( XT ); + } + else /* try to interpret it as a number. */ + { +/* Call deferred NUMBER? */ + int32 NumResult; + +DBUG(("FindAndCompile: not found, try number?\n" )); + PUSH_DATA_STACK( theWord ); /* Push text of number */ + pfExecuteToken( gNumberQ_XT ); +DBUG(("FindAndCompile: after number?\n" )); + NumResult = POP_DATA_STACK; /* Success? */ + switch( NumResult ) + { + case NUM_TYPE_SINGLE: + if( gVarState ) /* compiling? */ + { + Num = POP_DATA_STACK; + ffLiteral( Num ); + } + break; + + case NUM_TYPE_DOUBLE: + if( gVarState ) /* compiling? */ + { + Num = POP_DATA_STACK; /* get hi portion */ + ff2Literal( Num, POP_DATA_STACK ); + } + break; + +#ifdef PF_SUPPORT_FP + case NUM_TYPE_FLOAT: + if( gVarState ) /* compiling? */ + { + ffFPLiteral( *gCurrentTask->td_FloatStackPtr++ ); + } + break; +#endif + + case NUM_TYPE_BAD: + default: + ioType( theWord+1, *theWord ); + MSG( " ? - unrecognized word!\n" ); + ffAbort( ); + break; + + } + } +} +/************************************************************** +** Forth outer interpreter. Parses words from Source. +** Executes them or compiles them based on STATE. +*/ +int32 ffInterpret( void ) +{ + int32 Flag; + char *theWord; + +/* Is there any text left in Source ? */ + while( (gCurrentTask->td_IN < (gCurrentTask->td_SourceNum-1) ) && + !CHECK_ABORT) + { +DBUGX(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask->td_IN, + gCurrentTask->td_SourceNum ) ); + theWord = ffWord( BLANK ); +DBUGX(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord, *theWord )); + if( *theWord > 0 ) + { + Flag = 0; + if( gLocalCompiler_XT ) + { + PUSH_DATA_STACK( theWord ); /* Push word. */ + pfExecuteToken( gLocalCompiler_XT ); + Flag = POP_DATA_STACK; /* Compiled local? */ + } + if( Flag == 0 ) + { + FindAndCompile( theWord ); + } + } + } + DBUG(("ffInterpret: CHECK_ABORT = %d\n", CHECK_ABORT)); + return( CHECK_ABORT ? -1 : 0 ); +} + +/**************************************************************/ +void ffOK( void ) +{ +/* Check for stack underflow. %Q what about overflows? */ + if( (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr) < 0 ) + { + MSG("Stack underflow!\n"); + ResetForthTask( ); + } +#ifdef PF_SUPPORT_FP /* Check floating point stack too! */ + else if((gCurrentTask->td_FloatStackBase - gCurrentTask->td_FloatStackPtr) < 0) + { + MSG("FP stack underflow!\n"); + ResetForthTask( ); + } +#endif + else if( gCurrentTask->td_InputStream == PF_STDIN) + { + if( !gVarState ) /* executing? */ + { + if( !gVarQuiet ) + { + MSG( " ok\n" ); + if(gVarTraceStack) ffDotS(); + } + else + { + EMIT_CR; + } + } + } +} + +/*************************************************************** +** Report state of include stack. +***************************************************************/ +static void ReportIncludeState( void ) +{ + int32 i; +/* If not INCLUDing, just return. */ + if( gIncludeIndex == 0 ) return; + +/* Report line number and nesting level. */ + MSG_NUM_D("INCLUDE error on line #", gCurrentTask->td_LineNumber ); + MSG_NUM_D("INCLUDE nesting level = ", gIncludeIndex ); + +/* Dump line of error and show offset in line for >IN */ + MSG( gCurrentTask->td_SourcePtr ); + for( i=0; i<(gCurrentTask->td_IN - 1); i++ ) EMIT('^'); + EMIT_CR; +} + + +/*************************************************************** +** Interpret input in a loop. +***************************************************************/ +void ffQuit( void ) +{ + gCurrentTask->td_Flags |= CFTD_FLAG_GO; + + while( gCurrentTask->td_Flags & CFTD_FLAG_GO ) + { + if(!ffRefill()) + { +/* gCurrentTask->td_Flags &= ~CFTD_FLAG_GO; */ + return; + } + ffInterpret(); + DBUG(("gCurrentTask->td_Flags = 0x%x\n", gCurrentTask->td_Flags)); + if(CHECK_ABORT) + { + CLEAR_ABORT; + } + else + { + ffOK( ); + } + } +} + +/*************************************************************** +** Include a file +***************************************************************/ + +cell ffIncludeFile( FileStream *InputFile ) +{ + cell Result; + +/* Push file stream. */ + Result = ffPushInputStream( InputFile ); + if( Result < 0 ) return Result; + +/* Run outer interpreter for stream. */ + ffQuit(); + +/* Pop file stream. */ + ffPopInputStream(); + + return gVarReturnCode; +} + +#endif /* !PF_NO_SHELL */ + +/*************************************************************** +** Save current input stream on stack, use this new one. +***************************************************************/ +Err ffPushInputStream( FileStream *InputFile ) +{ + cell Result = 0; + IncludeFrame *inf; + +/* Push current input state onto special include stack. */ + if( gIncludeIndex < MAX_INCLUDE_DEPTH ) + { + inf = &gIncludeStack[gIncludeIndex++]; + inf->inf_FileID = gCurrentTask->td_InputStream; + inf->inf_IN = gCurrentTask->td_IN; + inf->inf_LineNumber = gCurrentTask->td_LineNumber; + inf->inf_SourceNum = gCurrentTask->td_SourceNum; +/* Copy TIB plus any NUL terminator into saved area. */ + if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) ) + { + pfCopyMemory( inf->inf_SaveTIB, gCurrentTask->td_TIB, inf->inf_SourceNum+1 ); + } + +/* Set new current input. */ + DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile )); + gCurrentTask->td_InputStream = InputFile; + gCurrentTask->td_LineNumber = 0; + } + else + { + ERR("ffPushInputStream: max depth exceeded.\n"); + return -1; + } + + + return Result; +} + +/*************************************************************** +** Go back to reading previous stream. +** Just return gCurrentTask->td_InputStream upon underflow. +***************************************************************/ +FileStream *ffPopInputStream( void ) +{ + IncludeFrame *inf; + FileStream *Result; + +DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex)); + Result = gCurrentTask->td_InputStream; + +/* Restore input state. */ + if( gIncludeIndex > 0 ) + { + inf = &gIncludeStack[--gIncludeIndex]; + gCurrentTask->td_InputStream = inf->inf_FileID; + DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask->td_InputStream )); + gCurrentTask->td_IN = inf->inf_IN; + gCurrentTask->td_LineNumber = inf->inf_LineNumber; + gCurrentTask->td_SourceNum = inf->inf_SourceNum; +/* Copy TIB plus any NUL terminator into saved area. */ + if( (inf->inf_SourceNum > 0) && (inf->inf_SourceNum < (TIB_SIZE-1)) ) + { + pfCopyMemory( gCurrentTask->td_TIB, inf->inf_SaveTIB, inf->inf_SourceNum+1 ); + } + + } +DBUG(("ffPopInputStream: return = 0x%x\n", Result )); + + return Result; +} + +/*************************************************************** +** Convert file pointer to value consistent with SOURCE-ID. +***************************************************************/ +cell ffConvertStreamToSourceID( FileStream *Stream ) +{ + cell Result; + if(Stream == PF_STDIN) + { + Result = 0; + } + else if(Stream == NULL) + { + Result = -1; + } + else + { + Result = (cell) Stream; + } + return Result; +} + +/*************************************************************** +** Convert file pointer to value consistent with SOURCE-ID. +***************************************************************/ +FileStream * ffConvertSourceIDToStream( cell id ) +{ + FileStream *stream; + + if( id == 0 ) + { + stream = PF_STDIN; + } + else if( id == -1 ) + { + stream = NULL; + } + else + { + stream = (FileStream *) id; + } + return stream; +} + +/*************************************************************** +** Cleanup Include stack by popping and closing files. +***************************************************************/ +static void ffCleanIncludeStack( void ) +{ + FileStream *cur; + + while( (cur = ffPopInputStream()) != PF_STDIN) + { + DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur )); + sdCloseFile(cur); + } +} + +/**************************************************************/ +void ffAbort( void ) +{ +#ifndef PF_NO_SHELL + ReportIncludeState(); +#endif /* PF_NO_SHELL */ + ffCleanIncludeStack(); + ResetForthTask(); + SET_ABORT; + if( gVarReturnCode == 0 ) gVarReturnCode = ABORT_RETURN_CODE; +} + +/**************************************************************/ +/* ( -- , fill Source from current stream ) */ +/* Return FFALSE if no characters. */ +cell ffRefill( void ) +{ + cell Num, Result = FTRUE; + +/* get line from current stream */ + Num = ioAccept( gCurrentTask->td_SourcePtr, + TIB_SIZE, gCurrentTask->td_InputStream ); + if( Num < 0 ) + { + Result = FFALSE; + Num = 0; + } + +/* reset >IN for parser */ + gCurrentTask->td_IN = 0; + gCurrentTask->td_SourceNum = Num; + gCurrentTask->td_LineNumber++; /* Bump for include. */ + +/* echo input if requested */ + if( gVarEcho && ( Num > 0)) + { + MSG( gCurrentTask->td_SourcePtr ); + } + + return Result; +} diff --git a/csrc/pfcompil.h b/csrc/pfcompil.h new file mode 100644 index 0000000..76bd289 --- /dev/null +++ b/csrc/pfcompil.h @@ -0,0 +1,72 @@ +/* @(#) pfcompil.h 96/12/18 1.11 */ + +#ifndef _pforth_compile_h +#define _pforth_compile_h + +/*************************************************************** +** Include file for PForth Compiler +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + +#ifdef __cplusplus +extern "C" { +#endif + +Err ffPushInputStream( FileStream *InputFile ); +ExecToken NameToToken( const ForthString *NFA ); +FileStream * ffConvertSourceIDToStream( cell id ); +FileStream *ffPopInputStream( void ); +cell ffConvertStreamToSourceID( FileStream *Stream ); +cell ffFind( const ForthString *WordName, ExecToken *pXT ); +cell ffFindC( const char *WordName, ExecToken *pXT ); +cell ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr ); +cell ffIncludeFile( FileStream *InputFile ); +cell ffNumberQ( const char *FWord, cell *Num ); +cell ffRefill( void ); +cell ffTokenToName( ExecToken XT, const ForthString **NFAPtr ); +cell *NameToCode( ForthString *NFA ); +cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ); +char *ffWord( char c ); +const ForthString *NameToPrevious( const ForthString *NFA ); +int32 FindSpecialCFAs( void ); +int32 FindSpecialXTs( void ); +int32 NotCompiled( const char *FunctionName ); +int32 ffInterpret( void ); +void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, uint32 Flags ); +void CreateDicEntryC( ExecToken XT, const char *CName, uint32 Flags ); +void ff2Literal( cell dHi, cell dLo ); +void ffALiteral( cell Num ); +void ffAbort( void ); +void ffColon( void ); +void ffCreate( void ); +void ffCreateSecondaryHeader( const ForthStringPtr FName); +void ffDefer( void ); +void ffFinishSecondary( void ); +void ffLiteral( cell Num ); +void ffOK( void ); +void ffQuit( void ); +void ffSemiColon( void ); +void ffStringCreate( ForthStringPtr FName); +void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT ); + +#ifdef PF_SUPPORT_FP +void ffFPLiteral( PF_FLOAT fnum ); +#endif + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_compile_h */ diff --git a/csrc/pfcustom.c b/csrc/pfcustom.c new file mode 100644 index 0000000..1973336 --- /dev/null +++ b/csrc/pfcustom.c @@ -0,0 +1,122 @@ +/* @(#) pfcustom.c 98/01/26 1.3 */ + +#ifndef PF_USER_CUSTOM + +/*************************************************************** +** Call Custom Functions for pForth +** +** Create a file similar to this and compile it into pForth +** by setting -DPF_USER_CUSTOM="mycustom.c" +** +** Using this, you could, for example, call X11 from Forth. +** See "pf_cglue.c" for more information. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +***************************************************************/ + + +#include "pf_all.h" + +static int32 CTest0( int32 Val ); +static void CTest1( int32 Val1, cell Val2 ); + +/**************************************************************** +** Step 1: Put your own special glue routines here +** or link them in from another file or library. +****************************************************************/ +static int32 CTest0( int32 Val ) +{ + MSG_NUM_D("CTest0: Val = ", Val); + return Val+1; +} + +static void CTest1( int32 Val1, cell Val2 ) +{ + + MSG("CTest1: Val1 = "); ffDot(Val1); + MSG_NUM_D(", Val2 = ", Val2); +} + +/**************************************************************** +** Step 2: Create CustomFunctionTable. +** Do not change the name of CustomFunctionTable! +** It is used by the pForth kernel. +****************************************************************/ + +#ifdef PF_NO_GLOBAL_INIT +/****************** +** If your loader does not support global initialization, then you +** must define PF_NO_GLOBAL_INIT and provide a function to fill +** the table. Some embedded system loaders require this! +** Do not change the name of LoadCustomFunctionTable()! +** It is called by the pForth kernel. +*/ +#define NUM_CUSTOM_FUNCTIONS (2) +void *CustomFunctionTable[NUM_CUSTOM_FUNCTIONS]; + +Err LoadCustomFunctionTable( void ) +{ + CustomFunctionTable[0] = CTest0; + CustomFunctionTable[1] = CTest1; + return 0; +} + +#else +/****************** +** If your loader supports global initialization (most do.) then just +** create the table like this. +*/ + +void *CustomFunctionTable[] = +{ + (void *)CTest0, + (void *)CTest1 +}; +#endif + +/**************************************************************** +** Step 3: Add custom functions to the dictionary. +** Do not change the name of CompileCustomFunctions! +** It is called by the pForth kernel. +****************************************************************/ + +#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL)) +Err CompileCustomFunctions( void ) +{ + Err err; + +/* Compile Forth words that call your custom functions. +** Make sure order of functions matches that in LoadCustomFunctionTable(). +** Parameters are: Name in UPPER CASE, Function, Index, Mode, NumParams +*/ + err = CreateGlueToC( "CTEST0", 0, C_RETURNS_VALUE, 1 ); + if( err < 0 ) return err; + err = CreateGlueToC( "CTEST1", 1, C_RETURNS_VOID, 2 ); + if( err < 0 ) return err; + + return 0; +} +#else +Err CompileCustomFunctions( void ) { return 0; } +#endif + +/**************************************************************** +** Step 4: Recompile using compiler option PF_USER_CUSTOM +** and link with your code. +** Then rebuild the Forth using "pforth -i" +** Test: 10 Ctest0 ( should print message then '11' ) +****************************************************************/ + +#endif /* PF_USER_CUSTOM */ + diff --git a/csrc/pfinnrfp.h b/csrc/pfinnrfp.h new file mode 100644 index 0000000..82a34f1 --- /dev/null +++ b/csrc/pfinnrfp.h @@ -0,0 +1,336 @@ +/* @(#) pfinnrfp.h 98/02/26 1.4 */ +/*************************************************************** +** Compile FP routines. +** This file is included from "pf_inner.c" +** +** These routines could be left out of an execute only version. +** +** Author: Darren Gibbs, Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +**************************************************************** +** +***************************************************************/ + +#ifdef PF_SUPPORT_FP + +#define FP_DHI1 (((PF_FLOAT)0x40000000)*4.0) + + case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */ + PUSH_FP_TOS; + Scratch = M_POP; /* dlo */ + DBUG(("dlo = 0x%8x , ", Scratch)); + DBUG(("dhi = 0x%8x\n", TOS)); + + if( ((TOS == 0) && (Scratch >= 0)) || + ((TOS == -1) && (Scratch < 0))) + { + /* <= 32 bit precision. */ + FP_TOS = ((PF_FLOAT) Scratch); /* Convert dlo and push on FP stack. */ + } + else /* > 32 bit precision. */ + { + fpTemp = ((PF_FLOAT) TOS); /* dhi */ + fpTemp *= FP_DHI1; + fpScratch = ( (PF_FLOAT) ((unsigned int)Scratch) ); /* Convert TOS and push on FP stack. */ + FP_TOS = fpTemp + fpScratch; + } + M_DROP; + /* printf("d2f = %g\n", FP_TOS); */ + break; + + case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */ +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_CODE_DIC(TOS) ) + { + WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS ); + } + else + { + *((PF_FLOAT *) TOS) = FP_TOS; + } +#else + *((PF_FLOAT *) TOS) = FP_TOS; +#endif + M_FP_DROP; /* drop FP value */ + M_DROP; /* drop addr */ + break; + + case ID_FP_FTIMES: /* ( F: r1 r2 -- r1*r2 ) */ + FP_TOS = M_FP_POP * FP_TOS; + break; + + case ID_FP_FPLUS: /* ( F: r1 r2 -- r1+r2 ) */ + FP_TOS = M_FP_POP + FP_TOS; + break; + + case ID_FP_FMINUS: /* ( F: r1 r2 -- r1-r2 ) */ + FP_TOS = M_FP_POP - FP_TOS; + break; + + case ID_FP_FSLASH: /* ( F: r1 r2 -- r1/r2 ) */ + FP_TOS = M_FP_POP / FP_TOS; + break; + + case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag ) ( F: r -- ) */ + PUSH_TOS; + TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ; + M_FP_DROP; + break; + + case ID_FP_F_ZERO_EQUALS: /* ( -- flag ) ( F: r -- ) */ + PUSH_TOS; + TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ; + M_FP_DROP; + break; + + case ID_FP_F_LESS_THAN: /* ( -- flag ) ( F: r1 r2 -- ) */ + PUSH_TOS; + TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ; + M_FP_DROP; + break; + + case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */ + /* printf("f2d = %g\n", FP_TOS); */ + { + uint32 dlo; + int32 dhi; + int ifNeg; + /* Convert absolute value, then negate D if negative. */ + PUSH_TOS; /* Save old TOS */ + fpTemp = FP_TOS; + M_FP_DROP; + ifNeg = (fpTemp < 0.0); + if( ifNeg ) + { + fpTemp = 0.0 - fpTemp; + } + fpScratch = fpTemp / FP_DHI1; + /* printf("f2d - fpScratch = %g\n", fpScratch); */ + dhi = (int32) fpScratch; /* dhi */ + fpScratch = ((PF_FLOAT) dhi) * FP_DHI1; + /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */ + + fpTemp = fpTemp - fpScratch; /* Remainder */ + dlo = (uint32) fpTemp; + /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */ + if( ifNeg ) + { + dlo = 0 - dlo; + dhi = 0 - dhi - 1; + } + /* Push onto stack. */ + TOS = dlo; + PUSH_TOS; + TOS = dhi; + } + break; + + case ID_FP_FFETCH: /* ( addr -- ) ( F: -- r ) */ + PUSH_FP_TOS; +#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC)) + if( IN_CODE_DIC(TOS) ) + { + FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS ); + } + else + { + FP_TOS = *((PF_FLOAT *) TOS); + } +#else + FP_TOS = *((PF_FLOAT *) TOS); +#endif + M_DROP; + break; + + case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */ + PUSH_TOS; + /* Add 1 to account for FP_TOS in cached in register. */ + TOS = (( M_FP_SPZERO - FP_STKPTR) + 1); + break; + + case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */ + M_FP_DROP; + break; + + case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */ + PUSH_FP_TOS; + break; + + case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */ + TOS = TOS + sizeof(PF_FLOAT); + break; + + case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */ + TOS = TOS * sizeof(PF_FLOAT); + break; + + case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_floor( FP_TOS ); + break; + + case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */ + fpScratch = M_FP_POP; + FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ; + break; + + case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */ + fpScratch = M_FP_POP; + FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ; + break; + + case ID_FP_FNEGATE: + FP_TOS = -FP_TOS; + break; + + case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */ + PUSH_FP_TOS; + FP_TOS = M_FP_STACK(1); + break; + + case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */ + fpScratch = M_FP_POP; /* r2 */ + fpTemp = M_FP_POP; /* r1 */ + M_FP_PUSH( fpScratch ); /* r2 */ + PUSH_FP_TOS; /* r3 */ + FP_TOS = fpTemp; /* r1 */ + break; + + case ID_FP_FROUND: + ERR("\nID_FP_FROUND - Not Yet!! FIXME\n"); + break; + + case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */ + fpScratch = FP_TOS; + FP_TOS = *FP_STKPTR; + *FP_STKPTR = fpScratch; + break; + + case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */ + fpScratch = M_FP_POP; + FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS); + break; + + case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS ); + break; + + case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_acos( FP_TOS ); + break; + + case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */ + /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */ + FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1))); + break; + + case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS); + break; + + case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_asin( FP_TOS ); + break; + + case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */ + /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */ + FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1))); + break; + + case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_atan( FP_TOS ); + break; + + case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */ + fpTemp = M_FP_POP; + FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS ); + break; + + case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS))); + break; + + case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_cos( FP_TOS ); + break; + + case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS ); + break; + +#ifndef PF_NO_SHELL + case ID_FP_FLITERAL: + ffFPLiteral( FP_TOS ); + M_FP_DROP; + endcase; +#endif /* !PF_NO_SHELL */ + + case ID_FP_FLITERAL_P: + PUSH_FP_TOS; +#if 0 +/* Some wimpy compilers can't handle this! */ + FP_TOS = *(((PF_FLOAT *)InsPtr)++); +#else + { + PF_FLOAT *fptr; + fptr = (PF_FLOAT *)InsPtr; + FP_TOS = READ_FLOAT_DIC( fptr++ ); + InsPtr = (cell *) fptr; + } +#endif + endcase; + + case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_log(FP_TOS); + break; + + case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0); + break; + + case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_log10( FP_TOS ); + break; + + case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_sin( FP_TOS ); + break; + + case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */ + M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS)); + FP_TOS = (PF_FLOAT) fp_cos(FP_TOS); + break; + + case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS ); + break; + + case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS ); + break; + + case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_tan( FP_TOS ); + break; + + case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */ + FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS ); + break; + + case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */ + PUSH_FP_TOS; /* push cached floats into RAM */ + FP_TOS = FP_STKPTR[TOS]; /* 0 FPICK gets top of FP stack */ + M_DROP; + break; + + +#endif diff --git a/csrc/pforth.h b/csrc/pforth.h new file mode 100644 index 0000000..e94be1b --- /dev/null +++ b/csrc/pforth.h @@ -0,0 +1,88 @@ +/* @(#) pforth.h 98/01/26 1.2 */ +#ifndef _pforth_h +#define _pforth_h + +/*************************************************************** +** Include file for pForth, a portable Forth based on 'C' +** +** This file is included in any application that uses pForth as a tool. +** +** Author: Phil Burk +** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +** +** The pForth software code is dedicated to the public domain, +** and any third party may reproduce, distribute and modify +** the pForth software code or any derivative works thereof +** without any compensation or license. The pForth software +** code is provided on an "as is" basis without any warranty +** of any kind, including, without limitation, the implied +** warranties of merchantability and fitness for a particular +** purpose and their equivalents under the laws of any jurisdiction. +** +** +***************************************************************/ + +/* Define stubs for data types so we can pass pointers but not touch inside. */ +typedef struct cfTaskData cfTaskData; +typedef struct cfDictionary cfDictionary; + +typedef unsigned long ExecToken; /* Execution Token */ + +#ifndef int32 + typedef long int32; +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/* Main entry point to pForth. */ +int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit ); + +/* Turn off messages. */ +void pfSetQuiet( int32 IfQuiet ); + +/* Query message status. */ +int32 pfQueryQuiet( void ); + +/* Send a message using low level I/O of pForth */ +void pfMessage( const char *CString ); + +/* Create a task used to maintain context of execution. */ +cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth ); + +/* Establish this task as the current task. */ +void pfSetCurrentTask( cfTaskData *cftd ); + +/* Delete task created by pfCreateTask */ +void pfDeleteTask( cfTaskData *cftd ); + +/* Build a dictionary with all the basic kernel words. */ +cfDictionary *pfBuildDictionary( int32 HeaderSize, int32 CodeSize ); + +/* Create an empty dictionary. */ +cfDictionary *pfCreateDictionary( int32 HeaderSize, int32 CodeSize ); + +/* Load dictionary from a file. */ +cfDictionary *pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr ); + +/* Delete dictionary data. */ +void pfDeleteDictionary( cfDictionary *dic ); + +/* Execute the pForth interpreter. */ +int32 pfRunForth( void ); + +/* Execute a single execution token in the current task. */ +void pfExecuteToken( ExecToken XT ); + +/* Include the given pForth source code file. */ +int32 pfIncludeFile( const char *FileName ); + +/* Execute a Forth word by name. */ +void pfExecByName( const char *CString ); + +#ifdef __cplusplus +} +#endif + +#endif /* _pforth_h */ diff --git a/docs/pf_ref.htm b/docs/pf_ref.htm new file mode 100644 index 0000000..859d354 --- /dev/null +++ b/docs/pf_ref.htm @@ -0,0 +1,1333 @@ + + + + + + + + pForth Reference + + + +
+

+ +

+ +
+

+pForth Reference Manual

+ +
+
+ +

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

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

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

Back to pForth Home Page +

+

+LEGAL NOTICE

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

+

+

+Table of Contents

+ + + +
+

+What is pForth?

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

+What is Forth?

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

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

+The Origins of pForth

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

+pForth Design Goals

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

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

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

+

+

+Compiling pForth for your +System

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

+UNIX

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

+Macintosh

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

+PC Compatible

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

+Description of Source Files

+ +

+Forth Source

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

+'C' Source

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

+Running pForth

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

Usage: +

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

+Quick Verification of pForth

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

+

+

+ANSI Compliance

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

Word sets supported include: +

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

The ENVIRONMENT queries are not implemented. + +

Word sets NOT supported include: +

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

+pForth Special Features

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

+Compiling from a File

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

+Saving Precompiled Dictionaries

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

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

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

+Recompiling Code - ANEW +INCLUDE?

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

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

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

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

+Customising FORGET with +[FORGET]

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

+Smart Conditionals

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

+Development Tools

+ +

+WORDS.LIKE

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

+FILE?

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

+SEE

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

+Single Step Trace and Debug

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

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

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

+Miscellaneous Handy Words

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

+Local Variables { foo --}

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

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

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

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

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

+'C' like Structures. :STRUCT

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

+Vectorred Execution - DEFER

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

+Potential Problems with Defer

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

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

    +
    IF.FORGOTTEN STOP-IT!
    +
+ +

+Floating Point

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

+pForth Design

+ +

+'C' kernel

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

+Dictionary Structures

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

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

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

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

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

+Primitive

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

+Secondary

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

+CREATE DOES>

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

+Deferred Word

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

+Call to custom 'C' function.

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

+Custom Compilation of pForth

+ +

+Compiler Options

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

PF_NO_INIT +

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

+Building pForth on Supported +Hosts

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

To build on Macintosh: +

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

+Compiling for Embedded Systems

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

+Linking with Custom 'C' +Functions

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

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

+Testing your Compiled pForth

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

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

+
+

+Forth Tutorial

+ +
+ +

by Phil Burk + +

To pForth Home Page +

+Table of Contents

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

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

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

+Forth Syntax

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

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

+Stack Manipulation

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

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

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

Enter: .  + +

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

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

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

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

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

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

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

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

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

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

Here is another commonly used Forth word: + +

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

+Problems:

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

+Arithmetic

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

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

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

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

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

+Defining a New Word

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

Let's test this word by entering: +

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

+More Arithmetic

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

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

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

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

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

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

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

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

+Arithmetic Overflow

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

+Convert Algebraic +Expressions to Forth

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

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

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

+Problems:

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

+Character Input and Output

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

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

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

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

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

EMIT ( char -- , output character )  + +

KEY ( -- char , input character )  + +

SPACE ( -- , output a space )  + +

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

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

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

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

+
+
+Compiling from Files

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

+Sample Program

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

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

+Using INCLUDE

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

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

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

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

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

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

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

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

+Variables

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

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

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

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

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

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

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

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

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

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

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

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

+Constants

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

+Logical Operators

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

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

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

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

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

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

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

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

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

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

+Problems:

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

+Conditionals - IF ELSE THEN +CASE

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

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

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

+Problems:

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

+Loops

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

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

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

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

    +
    : SUM.OF.N ( N -- SUM[N] , calculate sum of N integers )
+    0  \ starting value of SUM
+    BEGIN
+        OVER 0>   \ Is N greater than zero?
+    WHILE
+        OVER +  \ add N to sum
+        SWAP 1- SWAP  \ decrement N
+    REPEAT
+    SWAP DROP  \ get rid on N
+;
    + +
    4 SUM.OF.N    \ prints 10   ( 1+2+3+4 )
    +
+ +

+Problems:

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

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

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

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

+Text Input and Output

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

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

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

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

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

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

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

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

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

+Changing Numeric Base

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

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

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

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

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

+Answers to Problems

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

+Stack Manipulations

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

+Arithmetic

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

+Logical Operators

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

+Conditionals

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

+Loops

+ +
    +
    : SUM.OF.N.1 ( N -- SUM[N] )
+    0 SWAP \ starting value of SUM
+    1+ 0 \ set indices for DO LOOP
+    ?DO \ safer than DO if N=0
+        I +
+    LOOP
+;
    + +
    : SUM.OF.N.2 ( N -- SUM[N] )
+    0 \ starting value of SUM
+    BEGIN ( -- N' SUM )
+        OVER +
+        SWAP 1- SWAP
+        OVER 0<
+    UNTIL
+    SWAP DROP
+;
    + +
    : SUM.OF.N.3 ( NUM -- SUM[N] , Gauss' method )
+    DUP 1+   \ SUM(N) = N*(N+1)/2
+    * 2/
+;
    +
+Back to pForth Home Page + + diff --git a/docs/pfmanual.txt b/docs/pfmanual.txt new file mode 100644 index 0000000..79b5941 --- /dev/null +++ b/docs/pfmanual.txt @@ -0,0 +1,223 @@ +UNFINISHED + +Manual for pForth - a Portable Forth + +The best reference for pForth is an ANSI Forth manual. pForth +is built on an ANSI model. There are, however, some non-standard +words which are documented here: + +{ ( i*x -- , declare local variables ) + Local variables are only usable within a colon definition. + They are taken from the stack as they are defined. + They are self fetching. Use -> to set them. + They help you avoid excessive stack dancing. + Here is an example: + + : SUMSQ { aa bb -- } + aa aa * + bb bb * + + ; + 3 4 SUMSQ . ( prints 25 ) + + Here is an example of using a temporary variable: + + : SUMN { num | sum -- , sum up integers the dumb way } + 0 -> sum \ uses -> to set local variable + num 0 + DO i sum + + -> sum \ write current TOS to sum + LOOP + sum + ; + +:STRUCT ( -- , defines a 'C' like structure ) + See end of "c_struct.fth" for an example. + +ANEW ( -- ) + Forgets NAME if it is already defined. + Then defines NAME. Put at beginning of file + so that file can be INCLUDEd multiple times + without redefining the contents. + +CASE OF ENDOF ENDCASE in the typical fashion. See "case.fth" + +CHOOSE ( range -- random , pick random number, 0...range-1 ) + +IF ELSE THEN DO LOOP etc. can be used outside colon definitions! + +IF.FORGOTTEN ( -- , executes NAME if forgotten ) + Put this at the end of a file to automatically + call your cleanup word if the code is forgotten. + +INCLUDE ( -- , interpret from file ) + Write your Forth programs in a file then load them + using INCLUDE. + + INCLUDE myprog.fth + +INCLUDE? ( -- , interpret from file if needed ) + INCLUDE the given file only if the named word is undefined. + The name should be of a Forth word defined in the file. + See "load_pforth.fth" for an example. + + INCLUDE? DO.MY.PROG myprog.fth + +MAP ( -- , dumps info about dictionary ) + +Other words + +FP.INIT +FP.TERM +F>S +S>F +EXISTS? +STRINGS= + +S@ +S! +;STRUCT +:STRUCT +STRUCT +ULONG +RPTR +APTR +FLPT +USHORT +UBYTE +LONG +SHORT +BYTE +BYTES +SIZEOF() +OB.STATS? +OB.STATS +OB.FINDIT +OB.MEMBER +}UNION +}UNION{ +UNION{ +OB.MAKE.MEMBER +MAP +.HEX +.DEC +.BIN +ARRAY +WARRAY +BARRAY +-2SORT +2SORT +WCHOOSE +CHOOSE +RANDOM +RAND-SEED +MSEC +MSEC-DELAY +VALUE +-> +TO + +-- strings -- +TEXTROM +$ROM +$APPEND.CHAR +INDEX +$MATCH? +TEXT=? +TEXT= +$= +COMPARE +$ARRAY + +-- case -- +ENDCASE ENDOF RANGEOF (RANGEOF?) OF +?OF CASE OF-DEPTH CASE-DEPTH + +TOLOWER +@EXECUTE +>NAME +CLOSEST-XT +CLOSEST-NFA +TAB +TAB-WIDTH +.HX +$ +CR? +#COLS +?PAUSE +ABORT" +WARNING" +CELL* +<< +>> + +TASK-MISC1.FTH .R . (.) +(NUMBER?) +((NUMBER?)) NUM_TYPE_DOUBLE NUM_TYPE_SINGLE +NUM_TYPE_BAD >NUMBER DIGIT + +ANEW FORGET [FORGET] IF.FORGOTTEN + +SAVE-FORTH +INCLUDE? +RI +INCLUDE +$INCLUDE +$APPEND +LWORD +PARSE +PARSE-WORD +PLACE + +WHAT'S +IS +DEFER + +>NEWLINE +0SP +SPACES +SPACE +RECURSE +UNLOOP + +-- user stack -- +0USP +US@ US> >US USTACK 0STACKP STACK@ +STACK> >STACK :STACK + +-- address storage and translation -- +A, A@ A! +IF.REL->USE IF.USE->REL +X! X@ +>ABS >REL REL->USE USE->REL +BODY> >BODY N>LINK CODE> >CODE NAME> +NAMEBASE+ CODEBASE NAMEBASE +N>NEXTLINK >NAME +PREVNAME NAME> + + +ID. + +OFF ON +TRACE-STACK +TRACE-LEVEL +TRACE-FLAGS + +HEADERS-BASE +HEADERS-PTR +ECHO +CODE-BASE + +POP-SOURCE-ID +PUSH-SOURCE-ID +SOURCE-ID +SET-SOURCE +SOURCE + +LOADSYS + +FLUSHEMIT +FINDNFA +BYE +BODY_OFFSET +BAIL +ARSHIFT diff --git a/filefind.fth b/filefind.fth new file mode 100644 index 0000000..8d0dd4a --- /dev/null +++ b/filefind.fth @@ -0,0 +1,102 @@ +\ @(#) filefind.fth 98/01/26 1.2 +\ FILE? ( -- , report which file this Forth word was defined in ) +\ +\ FILE? looks for ::::Filename and ;;;; in the dictionary +\ that have been left by INCLUDE. It figures out nested +\ includes and reports each file that defines the word. +\ +\ Author: Phil Burk +\ Copyright 1992 Phil Burk +\ +\ 00001 PLB 2/21/92 Handle words from kernel or keyboard. +\ Support EACH.FILE? +\ 961213 PLB Port to pForth. + +ANEW TASK-FILEFIND.FTH + +: ODD@ { addr | val -- val , fetch from odd aligned address, IBM PCs??? } + 4 0 + DO + addr i + c@ + val 8 lshift or -> val + LOOP + val +; + +\ scan dictionary from NFA for filename +: F?.SEARCH.NFA { nfa | dpth stoploop keyb nfa0 -- addr count } + 0 -> dpth + 0 -> stoploop + 0 -> keyb + nfa -> nfa0 + BEGIN + nfa prevname -> nfa + nfa 0> + IF + nfa 1+ odd@ + CASE + $ 3a3a3a3a ( :::: ) + OF + dpth 0= + IF + nfa count 31 and + 4 - swap 4 + swap + true -> stoploop + ELSE + -1 dpth + -> dpth + THEN + ENDOF + $ 3b3b3b3b ( ;;;; ) + OF + 1 dpth + -> dpth + true -> keyb \ maybe from keyboard + ENDOF + ENDCASE + ELSE + true -> stoploop + keyb + IF + " keyboard" + ELSE + " 'C' kernel" + THEN + count + THEN + stoploop + UNTIL +; + +: FINDNFA.FROM { $name start_nfa -- nfa true | $word false } + context @ >r + start_nfa context ! + $name findnfa + r> context ! +; + +\ Search entire dictionary for all occurences of named word. +: FILE? { | $word nfa done? -- , take name from input } + 0 -> done? + bl word -> $word + $word findnfa + IF ( -- nfa ) + $word count type ." from:" cr + -> nfa + BEGIN + nfa f?.search.nfa ( addr cnt ) + nfa name> 12 .r \ print xt + 4 spaces type cr + nfa prevname dup -> nfa + 0> + IF + $word nfa findnfa.from \ search from one behind found nfa + swap -> nfa + not + ELSE + true + THEN + UNTIL + ELSE ( -- $word ) + count type ." not found!" cr + THEN +; + diff --git a/floats.fth b/floats.fth new file mode 100644 index 0000000..b3afe23 --- /dev/null +++ b/floats.fth @@ -0,0 +1,497 @@ +\ @(#) floats.fth 98/02/26 1.4 17:51:40 +\ High Level Forth support for Floating Point +\ +\ Author: Phil Burk and Darren Gibbs +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 19970702 PLB Drop 0.0 in REPRESENT to fix 0.0 F. +\ 19980220 PLB Added FG. , fixed up large and small formatting +\ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix 0.0 F. (!!!) +\ Fixed F~ by using (F.EXACTLY) + +ANEW TASK-FLOATS.FTH + +: FALIGNED ( addr -- a-addr ) + 1 floats 1- + + 1 floats / + 1 floats * +; + +: FALIGN ( -- , align DP ) + dp @ faligned dp ! +; + +\ account for size of create when aligning floats +here +create fp-create-size +fp-create-size swap - constant CREATE_SIZE + +: FALIGN.CREATE ( -- , align DP for float after CREATE ) + dp @ + CREATE_SIZE + + faligned + CREATE_SIZE - + dp ! +; + +: FCREATE ( -- , create with float aligned data ) + falign.create + CREATE +; + +: FVARIABLE ( -- ) ( F: -- ) + FCREATE 1 floats allot +; + +: FCONSTANT + FCREATE here 1 floats allot f! + DOES> f@ +; + +: F0SP ( -- ) ( F: ? -- ) + fdepth 0 max 0 ?DO fdrop LOOP +; + +\ Convert between single precision and floating point +: S>F ( s -- ) ( F: -- r ) + s>d d>f +; +: F>S ( -- s ) ( F: r -- ) + f>d d>s +; + +: (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells } + 1 floats -> fsize + fsize cell 1- + cell 1- invert and \ round up to nearest multiple of stack size + cell / -> fcells ( number of cells per float ) +\ make room on data stack for floats data + fcells 0 ?DO 0 LOOP + sp@ -> caddr1 + fcells 0 ?DO 0 LOOP + sp@ -> caddr2 +\ compare bit representation + caddr1 f! + caddr2 f! + caddr1 fsize caddr2 fsize compare 0= + >r fcells 2* 0 ?DO drop LOOP r> \ drop float bits +; + +: F~ ( -0- flag ) ( r1 r2 r3 -f- ) + fdup F0< + IF + frot frot ( -- r3 r1 r2 ) + fover fover ( -- r3 r1 r2 r1 r2 ) + f- fabs ( -- r3 r1 r2 |r1-r2| ) + frot frot ( -- r3 |r1-r2| r1 r2 ) + fabs fswap fabs f+ ( -- r3 |r1-r2| |r1|+|r2| ) + frot fabs f* ( -- |r1-r2| |r1|+|r2|*|r3| ) + f< + ELSE + fdup f0= + IF + fdrop + (f.exactly) \ f- f0= \ 19980812 Used to cheat. Now actually compares bit patterns. + ELSE + frot frot ( -- r3 r1 r2 ) + f- fabs ( -- r3 |r1-r2| ) + fswap f< + THEN + THEN +; + +\ FP Output -------------------------------------------------------- +fvariable FVAR-REP \ scratch var for represent +: REPRESENT { c-addr u | n flag1 flag2 -- n flag1 flag2 , FLOATING } ( F: r -- ) + TRUE -> flag2 \ FIXME - need to check range + fvar-rep f! +\ + fvar-rep f@ f0< + IF + -1 -> flag1 + fvar-rep f@ fabs fvar-rep f! \ absolute value + ELSE + 0 -> flag1 + THEN +\ + fvar-rep f@ f0= + IF +\ fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F." + c-addr u [char] 0 fill + 0 -> n + ELSE + fvar-rep f@ + flog + fdup f0< not + IF + 1 s>f f+ \ round up exponent + THEN + f>s -> n +\ ." REP - n = " n . cr +\ normalize r to u digits + fvar-rep f@ + 10 s>f u n - s>f f** f* + 1 s>f 2 s>f f/ f+ \ round result +\ +\ convert float to double_int then convert to text + f>d +\ ." REP - d = " over . dup . cr + <# u 1- 0 ?DO # loop #s #> \ ( -- addr cnt ) +\ Adjust exponent if rounding caused number of digits to increase. +\ For example from 9999 to 10000. + u - +-> n + c-addr u move + THEN +\ + n flag1 flag2 +; + +variable FP-PRECISION + +\ Set maximum digits that are meaningful for the precision that we use. +1 FLOATS 4 / 7 * constant FP_PRECISION_MAX + +: PRECISION ( -- u ) + fp-precision @ +; +: SET-PRECISION ( u -- ) + fp_precision_max min + fp-precision ! +; +7 set-precision + +32 constant FP_REPRESENT_SIZE +64 constant FP_OUTPUT_SIZE + +create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot \ used with REPRESENT +create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot \ used to assemble final output +variable FP-OUTPUT-PTR \ points into FP-OUTPUT-PAD + +: FP.HOLD ( char -- , add char to output ) + fp-output-ptr @ fp-output-pad 64 + < + IF + fp-output-ptr @ tuck c! + 1+ fp-output-ptr ! + ELSE + drop + THEN +; +: FP.APPEND { addr cnt -- , add string to output } + cnt 0 max 0 + ?DO + addr i + c@ fp.hold + LOOP +; + +: FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output ) + BEGIN + fp-output-ptr @ fp-output-pad u> + fp-output-ptr @ 1- c@ [char] 0 = + and + WHILE + -1 fp-output-ptr +! + REPEAT +; + +: FP.APPEND.ZEROS ( numZeros -- ) + 0 max 0 + ?DO [char] 0 fp.hold + LOOP +; + +: FP.MOVE.DECIMAL { n prec -- , append with decimal point shifted } + fp-represent-pad n prec min fp.append + n prec - fp.append.zeros + [char] . fp.hold + fp-represent-pad n + + prec n - 0 max fp.append +; + +: (EXP.) ( n -- addr cnt , convert exponent to two digit value ) + dup abs 0 + <# # #s + rot 0< + IF [char] - HOLD + ELSE [char] + hold + THEN + #> +; + +: FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- ) +; + +: (FS.) ( -- addr cnt ) ( F: r -- , scientific notation ) + fp-output-pad fp-output-ptr ! \ setup pointer + fp-represent-pad precision represent +\ ." (FS.) - represent " fp-represent-pad precision type cr + ( -- n flag1 flag2 ) + IF + IF [char] - fp.hold + THEN + 1 precision fp.move.decimal + [char] e fp.hold + 1- (exp.) fp.append \ n + ELSE + 2drop + s" " fp.append + THEN + fp-output-pad fp-output-ptr @ over - +; + +: FS. ( F: r -- , scientific notation ) + (fs.) type space +; + +: (FE.) ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- } + fp-output-pad fp-output-ptr ! \ setup pointer + fp-represent-pad precision represent + ( -- n flag1 flag2 ) + IF + IF [char] - fp.hold + THEN +\ convert exponent to multiple of three + -> n + n 1- s>d 3 fm/mod \ use floored divide + 3 * -> n3 + 1+ precision fp.move.decimal \ amount to move decimal point + [char] e fp.hold + n3 (exp.) fp.append \ n + ELSE + 2drop + s" " fp.append + THEN + fp-output-pad fp-output-ptr @ over - +; + +: FE. ( F: r -- , engineering notation ) + (FE.) type space +; + +: (FG.) ( F: r -- , normal or scientific ) { | n n3 ndiff -- } + fp-output-pad fp-output-ptr ! \ setup pointer + fp-represent-pad precision represent + ( -- n flag1 flag2 ) + IF + IF [char] - fp.hold + THEN +\ compare n with precision to see whether we do scientific display + dup precision > + over -3 < OR + IF \ use exponential notation + 1 precision fp.move.decimal + fp.strip.trailing.zeros + [char] e fp.hold + 1- (exp.) fp.append \ n + ELSE + dup 0> + IF +\ POSITIVE EXPONENT - place decimal point in middle + precision fp.move.decimal + ELSE +\ NEGATIVE EXPONENT - use 0.000???? + s" 0." fp.append +\ output leading zeros + negate fp.append.zeros + fp-represent-pad precision fp.append + THEN + fp.strip.trailing.zeros + THEN + ELSE + 2drop + s" " fp.append + THEN + fp-output-pad fp-output-ptr @ over - +; + +: FG. ( F: r -- ) + (fg.) type space +; + +: (F.) ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- } + fp-output-pad fp-output-ptr ! \ setup pointer + fp-represent-pad \ place to put number + fdup flog 1 s>f f+ f>s precision max + fp_precision_max min dup -> prec' + represent + ( -- n flag1 flag2 ) + IF +\ add '-' sign if negative + IF [char] - fp.hold + THEN +\ compare n with precision to see whether we must do scientific display + dup fp_precision_max > + IF \ use exponential notation + 1 precision fp.move.decimal + fp.strip.trailing.zeros + [char] e fp.hold + 1- (exp.) fp.append \ n + ELSE + dup 0> + IF + \ POSITIVE EXPONENT - place decimal point in middle + prec' fp.move.decimal + ELSE + \ NEGATIVE EXPONENT - use 0.000???? + s" 0." fp.append + \ output leading zeros + dup negate precision min + fp.append.zeros + fp-represent-pad precision rot + fp.append + THEN + THEN + ELSE + 2drop + s" " fp.append + THEN + fp-output-pad fp-output-ptr @ over - +; + +: F. ( F: r -- ) + (f.) type space +; + +: F.S ( -- , print FP stack ) + ." FP> " + fdepth 0> + IF + fdepth 0 + DO + cr? + fdepth i - 1- \ index of next float + fpick f. cr? + LOOP + ELSE + ." empty" + THEN + cr +; + +\ FP Input ---------------------------------------------------------- +variable FP-REQUIRE-E \ must we put an E in FP numbers? +false fp-require-e ! \ violate ANSI !! + +: >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag } + u 0= IF 0 s>f true exit THEN + false -> flag + 0 -> nshift +\ +\ check for minus sign + c-addr c@ [char] - = dup -> fsign + c-addr c@ [char] + = OR + IF 1 +-> c-addr -1 +-> u \ skip char + THEN +\ +\ convert first set of digits + 0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo + u' 0> + IF +\ convert optional second set of digits + c-addr c@ [char] . = + IF + dlo dhi c-addr 1+ u' 1- dup -> nshift >number + dup nshift - -> nshift + -> u' -> c-addr -> dhi -> dlo + THEN +\ convert exponent + u' 0> + IF + c-addr c@ [char] E = + c-addr c@ [char] e = OR + IF + 1 +-> c-addr -1 +-> u' \ skip char + c-addr c@ [char] + = \ ignore + on exponent + IF + 1 +-> c-addr -1 +-> u' \ skip char + THEN + c-addr u' ((number?)) + num_type_single = + IF + nshift + -> nshift + true -> flag + THEN + THEN + ELSE +\ only require E field if this variable is true + fp-require-e @ not -> flag + THEN + THEN +\ convert double precision int to float + flag + IF + dlo dhi d>f + 10 s>f nshift s>f f** f* \ apply exponent + fsign + IF + fnegate + THEN + THEN + flag +; + +3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER? + +: (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number ) +\ check to see if it is a valid float, if not use old (NUMBER?) + dup count >float + IF + drop NUM_TYPE_FLOAT + ELSE + (number?) + THEN +; + +defer fp.old.number? +variable FP-IF-INIT + +: FP.TERM ( -- , deinstall fp conversion ) + fp-if-init @ + IF + what's fp.old.number? is number? + fp-if-init off + THEN +; + +: FP.INIT ( -- , install FP converion ) + fp.term + what's number? is fp.old.number? + ['] (fp.number?) is number? + fp-if-init on + ." Floating point numeric conversion installed." cr +; + +FP.INIT +if.forgotten fp.term + + +0 [IF] + +23.8e-9 fconstant fsmall +1.0 fsmall f- fconstant falmost1 +." Should be 1.0 = " falmost1 f. cr + +: TSEGF ( r -f- , print in all formats ) +." --------------------------------" cr + 34 0 + DO + fdup fs. 4 spaces fdup fe. 4 spaces + fdup fg. 4 spaces fdup f. cr + 10.0 f/ + LOOP + fdrop +; + +: TFP + 1.234e+22 tsegf + 1.23456789e+22 tsegf + 0.927 fsin 1.234e+22 f* tsegf +; + +[THEN] diff --git a/forget.fth b/forget.fth new file mode 100644 index 0000000..4b872ac --- /dev/null +++ b/forget.fth @@ -0,0 +1,97 @@ +\ @(#) forget.fth 98/01/26 1.2 +\ forget.fth +\ +\ forget part of dictionary +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 19970701 PLB Use unsigned compares for machines with "negative" addresses. + +variable RFENCE \ relocatable value below which we won't forget + +: FREEZE ( -- , protect below here ) + here rfence a! +; + +: FORGET.NFA ( nfa -- , set DP etc. ) + dup name> >code dp ! + prevname ( dup current ! ) dup context ! n>nextlink headers-ptr ! +; + +: VERIFY.FORGET ( nfa -- , ask for verification if below fence ) + dup name> >code rfence a@ u< \ 19970701 + IF + >newline dup id. ." is below fence!!" cr + drop + ELSE forget.nfa + THEN +; + +: (FORGET) ( -- ) + BL word findnfa + IF verify.forget + ELSE ." FORGET - couldn't find " count type cr abort + THEN +; + +variable LAST-FORGET \ contains address of last if.forgotten frame +0 last-forget ! + +: IF.FORGOTTEN ( -- , place links in dictionary without header ) + bl word find + IF ( xt ) + here \ start of frame + last-forget a@ a, \ Cell[0] = rel address of previous frame + last-forget a! \ point to this frame + compile, \ Cell[1] = xt for this frame + ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort + THEN +; +if.forgotten noop + +: [FORGET] ( -- , forget then exec forgotten words ) + (forget) + last-forget + BEGIN a@ dup 0<> \ 19970701 + IF dup here u> \ 19970701 + IF dup cell+ x@ execute false + ELSE dup last-forget a! true + THEN + ELSE true + THEN + UNTIL drop +; + +: FORGET ( -- , execute latest [FORGET] ) + " [FORGET]" find + IF execute + ELSE ." FORGET - couldn't find " count type cr abort + THEN +; + +: ANEW ( -- , forget if defined then redefine ) + >in @ + bl word find + IF over >in ! forget + THEN drop + >in ! variable +; + +: MARKER ( -- , define a word that forgets itself when executed, ANS ) + CREATE + latest namebase - \ convert to relocatable + , \ save for DOES> + DOES> ( -- body ) + @ namebase + \ convert back to NFA + verify.forget +; diff --git a/go.bat b/go.bat new file mode 100644 index 0000000..8146ef0 --- /dev/null +++ b/go.bat @@ -0,0 +1 @@ +bincmp -m10 pforth.dic pforth_mac.dic diff --git a/loadp4th.fth b/loadp4th.fth new file mode 100644 index 0000000..8ffc1be --- /dev/null +++ b/loadp4th.fth @@ -0,0 +1,47 @@ +\ @(#) loadp4th.fth 98/01/28 1.3 +\ Load various files needed by PForth +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +include? forget forget.fth +include? >number numberio.fth +include? task-misc1.fth misc1.fth +include? case case.fth +include? $= strings.fth +include? privatize private.fth +include? (local) ansilocs.fth +include? { locals.fth +include? fm/mod math.fth +include? task-misc2.fth misc2.fth +include? catch catch.fth +include? task-quit.fth quit.fth + +\ useful but optional stuff follows -------------------- + +include? [if] condcomp.fth + +\ load floating point support if basic support is in kernel +exists? F* + [IF] include? task-floats.fth floats.fth + [THEN] + +include? task-member.fth member.fth +include? :struct c_struct.fth +include? smif{ smart_if.fth +include? file? filefind.fth +include? see see.fth +include? words.like wordslik.fth +include? trace trace.fth + +map + diff --git a/locals.fth b/locals.fth new file mode 100644 index 0000000..8beddab --- /dev/null +++ b/locals.fth @@ -0,0 +1,69 @@ +\ @(#) $M$ 98/01/26 1.2 +\ standard { v0 v1 ... vn | l0 l1 .. lm -- } syntax +\ based on ANSI basis words (LOCAL) and TO +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-locals.fth + +private{ +variable loc-temp-mode \ if true, declaring temporary variables +variable loc-comment-mode \ if true, in comment section +variable loc-done +}private + +: { ( -- ) + loc-done off + loc-temp-mode off + loc-comment-mode off + BEGIN + bl word count + over c@ + CASE +\ handle special characters + ascii } OF loc-done on 2drop ENDOF + ascii | OF loc-temp-mode on 2drop ENDOF + ascii - OF loc-comment-mode on 2drop ENDOF + ascii ) OF ." { ... ) imbalance!" cr abort ENDOF + +\ process name + >r ( save char ) + ( addr len ) + loc-comment-mode @ + IF + 2drop + ELSE +\ if in temporary mode, assign local var = 0 + loc-temp-mode @ + IF compile false + THEN +\ otherwise take value from stack + (local) + THEN + r> + ENDCASE + loc-done @ + UNTIL + 0 0 (local) +; immediate + +privatize + +\ tests +: tlv1 { n -- } n dup n * dup n * ; + +: tlv2 { v1 v2 | l1 l2 -- } + v1 . v2 . cr + v1 v2 + -> l1 + l1 . l2 . cr +; diff --git a/math.fth b/math.fth new file mode 100644 index 0000000..e1852e2 --- /dev/null +++ b/math.fth @@ -0,0 +1,89 @@ +\ @(#) math.fth 98/01/26 1.2 +\ Extended Math routines +\ FM/MOD SM/REM +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-math.fth +decimal + +: FM/MOD { dl dh nn | dlp dhp nnp rem quo -- rem quo , floored } + dl dh dabs -> dhp -> dlp + nn abs -> nnp + dlp dhp nnp um/mod -> quo -> rem + dh 0< + IF \ negative dividend + nn 0< + IF \ negative divisor + rem negate -> rem + ELSE \ positive divisor + rem 0= + IF + quo negate -> quo + ELSE + quo 1+ negate -> quo + nnp rem - -> rem + THEN + THEN + ELSE \ positive dividend + nn 0< + IF \ negative divisor + rem 0= + IF + quo negate -> quo + ELSE + nnp rem - negate -> rem + quo 1+ negate -> quo + THEN + THEN + THEN + rem quo +; + +: SM/REM { dl dh nn | dlp dhp nnp rem quo -- rem quo , symmetric } + dl dh dabs -> dhp -> dlp + nn abs -> nnp + dlp dhp nnp um/mod -> quo -> rem + dh 0< + IF \ negative dividend + rem negate -> rem + nn 0> + IF \ positive divisor + quo negate -> quo + THEN + ELSE \ positive dividend + nn 0< + IF \ negative divisor + quo negate -> quo + THEN + THEN + rem quo +; + + +: /MOD ( a b -- rem quo ) + >r s>d r> sm/rem +; + +: MOD ( a b -- rem ) + /mod drop +; + +: */MOD ( a b c -- rem a*b/c , use double precision intermediate value ) + >r m* + r> sm/rem +; +: */ ( a b c -- a*b/c , use double precision intermediate value ) + */mod + nip +; diff --git a/member.fth b/member.fth new file mode 100644 index 0000000..6aeb36e --- /dev/null +++ b/member.fth @@ -0,0 +1,155 @@ +\ @(#) member.fth 98/01/26 1.2 +\ This files, along with c_struct.fth, supports the definition of +\ structure members similar to those used in 'C'. +\ +\ Some of this same code is also used by ODE, +\ the Object Development Environment. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ MOD: PLB 1/16/87 Use abort" instead of er.report. +\ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal. +\ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs. +\ MOD: PLB 7/31/88 Add USHORT and UBYTE. +\ MOD: PLB 1/20/89 Treat LITERAL as state sensitive. +\ MOD: RDG 9/19/90 Add floating point member support. +\ MOD: PLB 6/10/91 Add RPTR +\ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S! +\ 941102 RDG port to pforth +\ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal. +\ 960710 PLB align long members for SUN + +ANEW TASK-MEMBER.FTH +decimal + +: FIND.BODY ( -- , pfa true | $name false , look for word in dict. ) +\ Return address of parameter data. + 32 word find + IF >body true + ELSE false + THEN +; + +\ Variables shared with object oriented code. + VARIABLE OB-STATE ( Compilation state. ) + VARIABLE OB-CURRENT-CLASS ( ABS_CLASS_BASE of current class ) + 1 constant OB_DEF_CLASS ( defining a class ) + 2 constant OB_DEF_STRUCT ( defining a structure ) + +4 constant OB_OFFSET_SIZE + +: OB.OFFSET@ ( member_def -- offset ) @ ; +: OB.OFFSET, ( value -- ) , ; +: OB.SIZE@ ( member_def -- offset ) + ob_offset_size + @ ; +: OB.SIZE, ( value -- ) , ; + +( Members are associated with an offset from the base of a structure. ) +: OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time) + dup >r ( -- +-b , save #bytes ) + ABS ( -- |+-b| ) + ob-current-class @ ( -- b addr-space) + tuck @ ( as #b c , current space needed ) + over 3 and 0= ( multiple of four? ) + IF + aligned + ELSE + over 1 and 0= ( multiple of two? ) + IF + even-up + THEN + THEN + swap over + rot ! ( update space needed ) +\ Save data in member definition. %M + ob.offset, ( save old offset for ivar ) + r> ob.size, ( store size in bytes for ..! and ..@ ) +; + +\ Unions allow one to address the same memory as different members. +\ Unions work by saving the current offset for members on +\ the stack and then reusing it for different members. +: UNION{ ( -- offset , Start union definition. ) + ob-current-class @ @ +; + +: }UNION{ ( old-offset -- new-offset , Middle of union ) + union{ ( Get current for }UNION to compare ) + swap ob-current-class @ ! ( Set back to old ) +; + +: }UNION ( offset -- , Terminate union definition, check lengths. ) + union{ = NOT + abort" }UNION - Two parts of UNION are not the same size!" +; + +\ Make members compile their offset, for "disposable includes". +: OB.MEMBER ( #bytes -- , make room in an object at compile time) + ( -- offset , run time for structure ) + CREATE ob.make.member immediate + DOES> ob.offset@ ( get offset ) ?literal +; + +: OB.FINDIT ( -- pfa , get pfa of thing or error ) + find.body not + IF cr count type ." ???" + true abort" OB.FINDIT - Word not found!" + THEN +; + +: OB.STATS ( member_pfa -- offset #bytes ) + dup ob.offset@ swap + ob.size@ +; + +: OB.STATS? ( -- offset #bytes ) + ob.findit ob.stats +; + +: SIZEOF() ( OR -- #bytes , lookup size of object ) + ob.findit @ + ?literal +; immediate + +\ Basic word for defining structure members. +: BYTES ( #bytes -- , error check for structure only ) + ob-state @ ob_def_struct = not + abort" BYTES - Only valid in :STRUCT definitions." + ob.member +; + +\ Declare various types of structure members. +\ Negative size indicates a signed member. +: BYTE ( -- , declare space for a byte ) + -1 bytes ; + +: SHORT ( -- , declare space for a 16 bit value ) + -2 bytes ; + +: LONG ( -- ) + cell bytes ; + +: UBYTE ( -- , declare space for signed byte ) + 1 bytes ; + +: USHORT ( -- , declare space for signed 16 bit value ) + 2 bytes ; + + +\ Aliases +: APTR ( -- ) long ; +: RPTR ( -- ) -4 bytes ; \ relative relocatable pointer 00001 +: ULONG ( -- ) long ; + +: STRUCT ( -- , define a structure as an ivar ) + [compile] sizeof() bytes +; diff --git a/mipsBuild/pforth.bld b/mipsBuild/pforth.bld new file mode 100644 index 0000000..65898d4 --- /dev/null +++ b/mipsBuild/pforth.bld @@ -0,0 +1,79 @@ +#!build +default: + program + :check=bounds + :check=assignbound + :check=nilderef + :check=switch + :check=zerodivide + :check=usevariable + :check=return + :mips_option=littleendian + :mips_cputype=r5000 + :defines=PF_SUPPORT_FLOAT +e:\nomad\pforth\csrc\pf_all.h + include_file +e:\nomad\pforth\csrc\pf_cglue.c + C +e:\nomad\pforth\csrc\pf_cglue.h + include_file +e:\nomad\pforth\csrc\pf_clib.c + C +e:\nomad\pforth\csrc\pf_clib.h + include_file +e:\nomad\pforth\csrc\pf_core.c + C +e:\nomad\pforth\csrc\pf_core.h + include_file +e:\nomad\pforth\csrc\pf_float.h + include_file +e:\nomad\pforth\csrc\pf_guts.h + include_file +e:\nomad\pforth\csrc\pf_host.h + include_file +e:\nomad\pforth\csrc\pf_inner.c + C +e:\nomad\pforth\csrc\pf_io.c + C +e:\nomad\pforth\csrc\pf_io.h + include_file +e:\nomad\pforth\csrc\pf_mac.h + include_file +e:\nomad\pforth\csrc\pf_main.c + C +e:\nomad\pforth\csrc\pf_mem.c + C +e:\nomad\pforth\csrc\pf_mem.h + include_file +e:\nomad\pforth\csrc\pf_save.c + C +e:\nomad\pforth\csrc\pf_save.h + include_file +e:\nomad\pforth\csrc\pf_text.c + C + :c_option=needprototype + :c_mode=ansi +e:\nomad\pforth\csrc\pf_text.h + include_file +e:\nomad\pforth\csrc\pf_types.h + include_file +e:\nomad\pforth\csrc\pf_unix.h + include_file +e:\nomad\pforth\csrc\pf_win32.h + include_file +e:\nomad\pforth\csrc\pf_words.c + C +e:\nomad\pforth\csrc\pf_words.h + include_file +e:\nomad\pforth\csrc\pfcompfp.h + include_file +e:\nomad\pforth\csrc\pfcompil.c + C +e:\nomad\pforth\csrc\pfcompil.h + include_file +e:\nomad\pforth\csrc\pfcustom.c + C +e:\nomad\pforth\csrc\pfinnrfp.h + include_file +e:\nomad\pforth\csrc\pforth.h + include_file diff --git a/misc1.fth b/misc1.fth new file mode 100644 index 0000000..53728b6 --- /dev/null +++ b/misc1.fth @@ -0,0 +1,150 @@ +\ @(#) misc1.fth 98/01/26 1.2 +\ miscellaneous words +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-misc1.fth +decimal + +: >> rshift ; +: << lshift ; +: CELL* ( n -- n*cell ) 2 lshift ; + +: (WARNING") ( flag $message -- ) + swap + IF count type + ELSE drop + THEN +; + +: WARNING" ( flag -- , print warning if true. ) + [compile] " ( compile message ) + state @ + IF compile (warning") + ELSE (warning") + THEN +; IMMEDIATE + +: (ABORT") ( flag $message -- ) + swap + IF count type cr abort + ELSE drop + THEN +; + +: ABORT" ( flag -- , print warning if true. ) + [compile] " ( compile message ) + state @ + IF compile (abort") + ELSE (abort") + THEN +; IMMEDIATE + + +: ?PAUSE ( -- , Pause if key hit. ) + ?terminal + IF key drop cr ." Hit space to continue, any other key to abort:" + key dup emit BL = not abort" Terminated" + THEN +; + +60 constant #cols + +: CR? ( -- , do CR if near end ) + OUT @ #cols 16 - 10 max > + IF cr + THEN +; + +: CLS ( -- clear screen ) + 40 0 do cr loop +; +: PAGE ( -- , clear screen, compatible with Brodie ) + cls +; + +: $ ( -- N , convert next number as hex ) + base @ hex + 32 lword number? num_type_single = not + abort" Not a single number!" + swap base ! + state @ + IF [compile] literal + THEN +; immediate + +: .HX ( nibble -- ) + dup 9 > + IF $ 37 + ELSE $ 30 + THEN + emit +; + +variable TAB-WIDTH 8 TAB-WIDTH ! +: TAB ( -- , tab over to next stop ) + out @ tab-width @ mod + tab-width @ swap - spaces +; + +\ Vocabulary listing +: WORDS ( -- ) + 0 latest + BEGIN dup 0<> + WHILE dup id. tab cr? ?pause + prevname + swap 1+ swap + REPEAT drop + cr . ." words" cr +; + +variable CLOSEST-NFA +variable CLOSEST-XT + +: >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! ) + 0 closest-nfa ! + 0 closest-xt ! + latest + BEGIN dup 0<> + IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) < + IF true ( addr below this cfa, can't be it) + ELSE ( -- addr nfa ) + 2dup name> ( addr nfa addr xt ) = + IF ( found it ! ) dup closest-nfa ! false + ELSE dup name> closest-xt @ > + IF dup closest-nfa ! dup name> closest-xt ! + THEN + true + THEN + THEN + ELSE false + THEN + WHILE + prevname + REPEAT ( -- cfa nfa ) + 2drop + closest-nfa @ +; + +: @EXECUTE ( addr -- , execute if non-zero ) + x@ ?dup + IF execute + THEN +; + +: TOLOWER ( char -- char_lower ) + dup ascii [ < + IF dup ascii @ > + IF ascii A - ascii a + + THEN + THEN +; diff --git a/misc2.fth b/misc2.fth new file mode 100644 index 0000000..cd4ccbf --- /dev/null +++ b/misc2.fth @@ -0,0 +1,232 @@ +\ @(#) misc2.fth 98/01/26 1.2 +\ Utilities for PForth extracted from HMSL +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ +\ 00001 9/14/92 Added call, 'c w->s +\ 00002 11/23/92 Moved redef of : to loadcom.fth + +anew task-misc2.fth + +: 'N ( -- , make 'n state smart ) + bl word find + IF + state @ + IF namebase - ( make nfa relocatable ) + [compile] literal ( store nfa of word to be compiled ) + compile namebase+ + THEN + THEN +; IMMEDIATE + +: ?LITERAL ( n -- , do literal if compiling ) + state @ + IF [compile] literal + THEN +; + +: 'c ( -- xt , state sensitive ' ) + ' ?literal +; immediate + +variable if-debug + +decimal +create msec-delay 1000 , ( default for SUN ) +: msec ( #msecs -- ) + 0 + do msec-delay @ 0 + do loop + loop +; + +: SHIFT ( val n -- val< + if swap + then +; + +\ sort top two items on stack. +: -2sort ( a b -- a>b | b>a , smallest on top of stack) + 2dup < + if swap + then +; + +: barray ( #bytes -- ) ( index -- addr ) + create allot + does> + +; + +: warray ( #words -- ) ( index -- addr ) + create 2* allot + does> swap 2* + +; + +: array ( #cells -- ) ( index -- addr ) + create cell* allot + does> swap cell* + +; + +: .bin ( n -- , print in binary ) + base @ binary swap . base ! +; +: .dec ( n -- ) + base @ decimal swap . base ! +; +: .hex ( n -- ) + base @ hex swap . base ! +; + +: B->S ( c -- c' , sign extend byte ) + dup $ 80 and + IF + $ FFFFFF00 or + ELSE + $ 000000FF and + THEN +; +: W->S ( 16bit-signed -- 32bit-signed ) + dup $ 8000 and + if + $ FFFF0000 or + ELSE + $ 0000FFFF and + then +; + +: WITHIN { n1 n2 n3 -- flag } + n2 n3 <= + IF + n2 n1 <= + n1 n3 < AND + ELSE + n2 n1 <= + n1 n3 < OR + THEN +; + +: MOVE ( src dst num -- ) + >r 2dup - 0< + IF + r> CMOVE> + ELSE + r> CMOVE + THEN +; + +: ERASE ( caddr num -- ) + dup 0> + IF + 0 fill + ELSE + 2drop + THEN +; + +: BLANK ( addr u -- , set memory to blank ) + DUP 0> + IF + BL FILL + ELSE + 2DROP + THEN +; + +\ Obsolete but included for CORE EXT word set. +: QUERY REFILL DROP ; +VARIABLE SPAN +: EXPECT accept span ! ; +: TIB source drop ; + + +: UNUSED ( -- unused , dictionary space ) + CODELIMIT HERE - +; + +: MAP ( -- , dump interesting dictionary info ) + ." Code Segment" cr + ." CODEBASE = " codebase .hex cr + ." HERE = " here .hex cr + ." CODELIMIT = " codelimit .hex cr + ." Compiled Code Size = " here codebase - . cr + ." CODE-SIZE = " code-size @ . cr + ." Code Room UNUSED = " UNUSED . cr + ." Name Segment" cr + ." NAMEBASE = " namebase .hex cr + ." HEADERS-PTR @ = " headers-ptr @ .hex cr + ." NAMELIMIT = " namelimit .hex cr + ." CONTEXT @ = " context @ .hex cr + ." LATEST = " latest .hex ." = " latest id. cr + ." Compiled Name size = " headers-ptr @ namebase - . cr + ." HEADERS-SIZE = " headers-size @ . cr + ." Name Room Left = " namelimit headers-ptr @ - . cr +; + + +\ Search for substring S2 in S1 +: SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag } +\ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr +\ if true, s1 contains s2 at addr3 with cnt3 chars remaining +\ if false, s3 = s1 + addr1 -> addr3 + cnt1 -> cnt3 + cnt1 cnt2 < not + IF + cnt1 cnt2 - 1+ 0 + DO + true -> flag + cnt2 0 + ?DO + addr2 i chars + c@ + addr1 i j + chars + c@ <> \ mismatch? + IF + false -> flag + LEAVE + THEN + LOOP + flag + IF + addr1 i chars + -> addr3 + cnt1 i - -> cnt3 + LEAVE + THEN + LOOP + THEN + addr3 cnt3 flag +; + diff --git a/numberio.fth b/numberio.fth new file mode 100644 index 0000000..f17f4d7 --- /dev/null +++ b/numberio.fth @@ -0,0 +1,204 @@ +\ @(#) numberio.fth 98/01/26 1.2 +\ numberic_io.fth +\ +\ numeric conversion +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-numeric_io.fth +decimal + +\ ------------------------ INPUT ------------------------------- +\ Convert a single character to a number in the given base. +: DIGIT ( char base -- n true | char false ) + >r +\ convert lower to upper + dup ascii a < not + IF + ascii a - ascii A + + THEN +\ + dup dup ascii A 1- > + IF ascii A - ascii 9 + 1+ + ELSE ( char char ) + dup ascii 9 > + IF + ( between 9 and A is bad ) + drop 0 ( trigger error below ) + THEN + THEN + ascii 0 - + dup r> < + IF dup 1+ 0> + IF nip true + ELSE drop FALSE + THEN + ELSE drop FALSE + THEN +; + +: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE ) + >r + BEGIN + r@ 0> \ any characters left? + IF + dup c@ base @ + digit ( ud1 c-addr , n true | char false ) + IF + TRUE + ELSE + drop FALSE + THEN + ELSE + false + THEN + WHILE ( -- ud1 c-addr n ) + swap >r ( -- ud1lo ud1hi n ) + swap base @ ( -- ud1lo n ud1hi base ) + um* drop ( -- ud1lo n ud1hi*baselo ) + rot base @ ( -- n ud1hi*baselo ud1lo base ) + um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi ) + d+ ( -- ud2 ) + r> 1+ \ increment char* + r> 1- >r \ decrement count + REPEAT + r> +; + +\ obsolete +: CONVERT ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT ) + 256 >NUMBER DROP +; + +0 constant NUM_TYPE_BAD +1 constant NUM_TYPE_SINGLE +2 constant NUM_TYPE_DOUBLE + +\ This is similar to the F83 NUMBER? except that it returns a number type +\ and then either a single or double precision number. +: ((NUMBER?)) ( c-addr u -- 0 | n 1 | d 2 , convert string to number ) + dup 0= IF drop NUM_TYPE_BAD exit THEN \ any chars? + +\ prepare for >number + 0 0 2swap ( 0 0 c-addr cnt ) + +\ check for '-' at beginning, skip if present + over c@ ascii - = \ is it a '-' + dup >r \ save flag + IF 1- >r 1+ r> ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign ) + THEN +\ + >number dup 0= \ convert as much as we can + IF + 2drop \ drop addr cnt + drop \ drop hi part of num + r@ \ check flag to see if '-' sign used + IF negate + THEN + NUM_TYPE_SINGLE + ELSE ( -- d addr cnt ) + 1 = swap \ if final character is '.' then double + c@ ascii . = AND + IF + r@ \ check flag to see if '-' sign used + IF dnegate + THEN + NUM_TYPE_DOUBLE + ELSE + 2drop + NUM_TYPE_BAD + THEN + THEN + rdrop +; + +: (NUMBER?) ( $addr -- 0 | n 1 | d 2 , convert string to number ) + count ((number?)) +; + +' (number?) is number? +\ hex +\ 0sp c" xyz" (number?) .s +\ 0sp c" 234" (number?) .s +\ 0sp c" -234" (number?) .s +\ 0sp c" 234." (number?) .s +\ 0sp c" -234." (number?) .s +\ 0sp c" 1234567855554444." (number?) .s + + +\ ------------------------ OUTPUT ------------------------------ +\ Number output based on F83 +variable HLD \ points to last character added + +: hold ( char -- , add character to text representation) + -1 hld +! + hld @ c! +; +: <# ( -- , setup conversion ) + pad hld ! +; +: #> ( d -- addr len , finish conversion ) + 2drop hld @ pad over - +; +: sign ( n -- , add '-' if negative ) + 0< if ascii - hold then +; +: # ( d -- d , convert one digit ) + base @ mu/mod rot 9 over < + IF 7 + + THEN + ascii 0 + hold +; +: #s ( d -- d , convert remaining digits ) + BEGIN # 2dup or 0= + UNTIL +; + + +: (UD.) ( ud -- c-addr cnt ) + <# #s #> +; +: UD. ( ud -- , print unsigned double number ) + (ud.) type space +; +: UD.R ( ud n -- ) + >r (ud.) r> over - spaces type +; +: (D.) ( d -- c-addr cnt ) + tuck dabs <# #s rot sign #> +; +: D. ( d -- ) + (d.) type space +; +: D.R ( d n -- , right justified ) + >r (d.) r> over - spaces type +; + +: (U.) ( u -- c-addr cnt ) + 0 (ud.) +; +: U. ( u -- , print unsigned number ) + 0 ud. +; +: U.R ( u n -- , print right justified ) + >r (u.) r> over - spaces type +; +: (.) ( n -- c-addr cnt ) + dup abs 0 <# #s rot sign #> +; +: . ( n -- , print signed number) + (.) type space +; +: .R ( n l -- , print right justified) + >r (.) r> over - spaces type +; diff --git a/pcbuild/pForth.dsp b/pcbuild/pForth.dsp new file mode 100644 index 0000000..c2de9ee --- /dev/null +++ b/pcbuild/pForth.dsp @@ -0,0 +1,316 @@ +# Microsoft Developer Studio Project File - Name="pForth" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 5.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Console Application" 0x0103 + +CFG=pForth - Win32 MakeDic +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "pForth.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "pForth.mak" CFG="pForth - Win32 MakeDic" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "pForth - Win32 Release" (based on "Win32 (x86) Console Application") +!MESSAGE "pForth - Win32 Debug" (based on "Win32 (x86) Console Application") +!MESSAGE "pForth - Win32 MakeDic" (based on "Win32 (x86) Console Application") +!MESSAGE + +# Begin Project +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +RSC=rc.exe + +!IF "$(CFG)" == "pForth - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c +# ADD CPP /nologo /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c +# ADD BASE RSC /l 0x409 /d "NDEBUG" +# ADD RSC /l 0x409 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386 +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /machine:I386 /out:"../pForth.exe" + +!ELSEIF "$(CFG)" == "pForth - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "Debug" +# PROP BASE Intermediate_Dir "Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c +# ADD CPP /nologo /W4 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /pdbtype:sept +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept + +!ELSEIF "$(CFG)" == "pForth - Win32 MakeDic" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "pForth__" +# PROP BASE Intermediate_Dir "pForth__" +# PROP BASE Ignore_Export_Lib 0 +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "pForth__" +# PROP Intermediate_Dir "pForth__" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /W3 /Gm /GX /Zi /Od /D "WIN32" /D "_DEBUG" /D "_CONSOLE" /D "_MBCS" /YX /FD /c +# ADD CPP /nologo /W3 /Gm /GX /Zi /Od /D "_DEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /YX /FD /c +# ADD BASE RSC /l 0x409 /d "_DEBUG" +# ADD RSC /l 0x409 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /debug /machine:I386 /out:"../pForth.exe" /pdbtype:sept + +!ENDIF + +# Begin Target + +# Name "pForth - Win32 Release" +# Name "pForth - Win32 Debug" +# Name "pForth - Win32 MakeDic" +# Begin Group "Forth" + +# PROP Default_Filter ".fth, .j" +# Begin Source File + +SOURCE=..\ansilocs.fth +# End Source File +# Begin Source File + +SOURCE=..\bench.fth +# End Source File +# Begin Source File + +SOURCE=..\c_struct.fth +# End Source File +# Begin Source File + +SOURCE=..\case.fth +# End Source File +# Begin Source File + +SOURCE=..\catch.fth +# End Source File +# Begin Source File + +SOURCE=..\condcomp.fth +# End Source File +# Begin Source File + +SOURCE=..\coretest.fth +# End Source File +# Begin Source File + +SOURCE=..\filefind.fth +# End Source File +# Begin Source File + +SOURCE=..\floats.fth +# End Source File +# Begin Source File + +SOURCE=..\forget.fth +# End Source File +# Begin Source File + +SOURCE=..\loadp4th.fth +# End Source File +# Begin Source File + +SOURCE=..\locals.fth +# End Source File +# Begin Source File + +SOURCE=..\math.fth +# End Source File +# Begin Source File + +SOURCE=..\member.fth +# End Source File +# Begin Source File + +SOURCE=..\misc1.fth +# End Source File +# Begin Source File + +SOURCE=..\misc2.fth +# End Source File +# Begin Source File + +SOURCE=..\numberio.fth +# End Source File +# Begin Source File + +SOURCE=..\private.fth +# End Source File +# Begin Source File + +SOURCE=..\quit.fth +# End Source File +# Begin Source File + +SOURCE=..\see.fth +# End Source File +# Begin Source File + +SOURCE=..\smart_if.fth +# End Source File +# Begin Source File + +SOURCE=..\strings.fth +# End Source File +# Begin Source File + +SOURCE=..\system.fth +# End Source File +# Begin Source File + +SOURCE=..\t_alloc.fth +# End Source File +# Begin Source File + +SOURCE=..\t_corex.fth +# End Source File +# Begin Source File + +SOURCE=..\t_locals.fth +# End Source File +# Begin Source File + +SOURCE=..\t_strings.fth +# End Source File +# Begin Source File + +SOURCE=..\t_tools.fth +# End Source File +# Begin Source File + +SOURCE=..\tester.fth +# End Source File +# Begin Source File + +SOURCE=..\trace.fth +# End Source File +# Begin Source File + +SOURCE=..\tut.fth +# End Source File +# Begin Source File + +SOURCE=..\wordslik.fth +# End Source File +# End Group +# Begin Group "docs" + +# PROP Default_Filter ".txt, .htm" +# Begin Source File + +SOURCE=..\docs\pf_ref.htm +# End Source File +# Begin Source File + +SOURCE=..\docs\pf_todo.txt +# End Source File +# Begin Source File + +SOURCE=..\docs\pf_tut.htm +# End Source File +# Begin Source File + +SOURCE=..\docs\pfmanual.txt +# End Source File +# Begin Source File + +SOURCE=..\README.txt +# End Source File +# End Group +# Begin Source File + +SOURCE=..\csrc\pf_cglue.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_clib.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_core.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_inner.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_io.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_main.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_mem.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_save.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_text.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pf_words.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pfcompil.c +# End Source File +# Begin Source File + +SOURCE=..\csrc\pfcustom.c +# End Source File +# End Target +# End Project diff --git a/pcbuild/pForth.dsw b/pcbuild/pForth.dsw new file mode 100644 index 0000000..985e77c --- /dev/null +++ b/pcbuild/pForth.dsw @@ -0,0 +1,29 @@ +Microsoft Developer Studio Workspace File, Format Version 5.00 +# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! + +############################################################################### + +Project: "pForth"=.\pForth.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ +}}} + +############################################################################### + +Global: + +Package=<5> +{{{ +}}} + +Package=<3> +{{{ +}}} + +############################################################################### + diff --git a/pcbuild/pForth.ncb b/pcbuild/pForth.ncb new file mode 100644 index 0000000..63bc88a Binary files /dev/null and b/pcbuild/pForth.ncb differ diff --git a/pcbuild/pForth.opt b/pcbuild/pForth.opt new file mode 100644 index 0000000..8ad6203 Binary files /dev/null and b/pcbuild/pForth.opt differ diff --git a/pcbuild/pForth.plg b/pcbuild/pForth.plg new file mode 100644 index 0000000..1d12217 --- /dev/null +++ b/pcbuild/pForth.plg @@ -0,0 +1,59 @@ +--------------------Configuration: pForth - Win32 Release-------------------- +Begining build with project "E:\nomad\pForth\pcbuild\pForth.dsp", at root. +Active configuration is Win32 (x86) Console Application (based on Win32 (x86) Console Application) + +Project's tools are: + "32-bit C/C++ Compiler for 80x86" with flags "/nologo /ML /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_CONSOLE" /D "_MBCS" /D "PF_SUPPORT_FP" /Fp"Release/pForth.pch" /YX /Fo"Release/" /Fd"Release/" /FD /c " + "Win32 Resource Compiler" with flags "/l 0x409 /d "NDEBUG" " + "Browser Database Maker" with flags "/nologo /o"Release/pForth.bsc" " + "COFF Linker for 80x86" with flags "kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:console /incremental:no /pdb:"Release/pForth.pdb" /machine:I386 /out:"../pForth.exe" " + "Custom Build" with flags "" + "" with flags "" + +Creating temp file "C:\WINDOWS\TEMP\RSP62A2.TMP" with contents +Creating command line "cl.exe @C:\WINDOWS\TEMP\RSP62A2.TMP" +Creating temp file "C:\WINDOWS\TEMP\RSP62A3.TMP" with contents +Creating command line "link.exe @C:\WINDOWS\TEMP\RSP62A3.TMP" +Compiling... +pf_cglue.c +pf_clib.c +pf_core.c +pf_inner.c +pf_io.c +pf_main.c +pf_mem.c +pf_save.c +pf_text.c +pf_words.c +pfcompil.c +pfcustom.c +Linking... + + + +pForth.exe - 0 error(s), 0 warning(s) diff --git a/private.fth b/private.fth new file mode 100644 index 0000000..0f843f8 --- /dev/null +++ b/private.fth @@ -0,0 +1,48 @@ +\ @(#) private.fth 98/01/26 1.2 +\ PRIVATIZE +\ +\ Privatize words that are only needed within the file +\ and do not need to be exported. +\ +\ Usage: +\ PRIVATE{ +\ : FOO ; \ Everything between PRIVATE{ and }PRIVATE will become private. +\ : MOO ; +\ }PRIVATE +\ : GOO foo moo ; \ can use foo and moo +\ PRIVATIZE \ smudge foo and moo +\ ' foo \ will fail +\ +\ Copyright 1996 Phil Burk +\ +\ 19970701 PLB Use unsigned compares for machines with "negative" addresses. + +anew task-private.fth + +variable private-start +variable private-stop +$ 20 constant FLAG_SMUDGE + +: PRIVATE{ + latest private-start ! + 0 private-stop ! +; +: }PRIVATE + private-stop @ 0= not abort" Extra }PRIVATE" + latest private-stop ! +; +: PRIVATIZE ( -- , smudge all words between PRIVATE{ and }PRIVATE ) + private-start @ 0= abort" Missing PRIVATE{" + private-stop @ 0= abort" Missing }PRIVATE" + private-stop @ + BEGIN + dup private-start @ u> \ 19970701 + WHILE +\ ." Smudge " dup id. cr + dup c@ flag_smudge or over c! + prevname + REPEAT + drop + 0 private-start ! + 0 private-stop ! +; diff --git a/quit.fth b/quit.fth new file mode 100644 index 0000000..2a96365 --- /dev/null +++ b/quit.fth @@ -0,0 +1,136 @@ +\ @(#) quit.fth 98/01/26 1.2 +\ Outer Interpreter in Forth +\ +\ This used so that THROW can be caught by QUIT. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +include? catch catch.fth + +anew task-quit.fth + +: FIND&COMPILE ( $word -- {n} , find word in dictionary and handle it ) + dup >r \ save in case needed + find ( -- xt flag | $word 0 ) + + CASE + -1 OF \ not immediate + state @ \ compiling? + IF compile, + ELSE execute + THEN + ENDOF + + 1 OF execute \ immediate, so execute regardless of STATE + ENDOF + + 0 OF + number? \ is it a number? + num_type_single = + IF ?literal \ compile it or leave it on stack + ELSE + r@ count type ." is not recognized!!" cr + abort + THEN + ENDOF + ENDCASE + + rdrop +; + +: CHECK.STACK \ throw exception if stack underflows + depth 0< + IF + ." QUIT: Stack underflow!" cr + depth negate 0 \ restore depth + ?DO 0 + LOOP + ERR_UNDERFLOW throw + THEN +; + +\ interpret whatever is in source +: INTERPRET ( ?? -- ?? ) + BEGIN + >in @ source nip ( 1- ) < \ any input left? !!! is -1 needed? + WHILE + bl word + dup c@ 0> + IF + 0 >r \ flag + local-compiler @ + IF + dup local-compiler @ execute ( ?? -- ?? ) + r> drop TRUE >r + THEN + r> 0= + IF + find&compile ( -- {n} , may leave numbers on stack ) + THEN + ELSE + drop + THEN + check.stack + REPEAT +; + +: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth ) +\ save current input state and switch to pased in string + source >r >r + set-source + -1 push-source-id + >in @ >r + 0 >in ! +\ interpret the string + interpret +\ restore input state + pop-source-id drop + r> >in ! + r> r> set-source +; + +: POSTPONE ( -- ) + bl word find + CASE + 0 OF ." Postpone could not find " count type cr abort ENDOF + 1 OF compile, ENDOF \ immediate + -1 OF (compile) ENDOF \ normal + ENDCASE +; immediate + +: OK + ." OK " + trace-stack @ + IF .s + ELSE cr + THEN +; + +variable QUIT-QUIT + +: QUIT ( -- , interpret input until none left ) + quit-quit off + postpone [ + BEGIN + refill + quit-quit @ 0= and + WHILE +\ ." TIB = " source type cr + ['] interpret catch ?dup + IF + ." Exception # " . cr + ELSE + state @ 0= IF ok THEN + THEN + REPEAT +; diff --git a/see.fth b/see.fth new file mode 100644 index 0000000..9d866ad --- /dev/null +++ b/see.fth @@ -0,0 +1,218 @@ +\ @(#) see.fth 98/01/26 1.4 +\ SEE ( -- , disassemble pForth word ) +\ +\ Copyright 1996 Phil Burk + +' file? >code rfence a! + +anew task-see.fth + +: .XT ( xt -- , print execution tokens name ) + >name + dup c@ flag_immediate and + IF + ." POSTPONE " + THEN + id. space +; + +\ dictionary may be defined as byte code or cell code +0 constant BYTE_CODE + +BYTE_CODE [IF] + : CODE@ ( addr -- xt , fetch from code space ) C@ ; + 1 constant CODE_CELL + .( BYTE_CODE not implemented) abort +[ELSE] + : CODE@ ( addr -- xt , fetch from code space ) @ ; + CELL constant CODE_CELL +[THEN] + +private{ + +0 value see_level \ level of conditional imdentation +0 value see_addr \ address of next token +0 value see_out + +: SEE.INDENT.BY ( -- n ) + see_level 1+ 1 max 4 * +; + +: SEE.CR + >newline + see_addr ." ( ".hex ." )" + see.indent.by spaces + 0 -> see_out +; +: SEE.NEWLINE + see_out 0> + IF see.cr + THEN +; +: SEE.CR? + see_out 6 > + IF + see.newline + THEN +; +: SEE.OUT+ + 1 +-> see_out +; + +: SEE.ADVANCE + code_cell +-> see_addr +; +: SEE.GET.INLINE ( -- n ) + see_addr @ +; + +: SEE.GET.TARGET ( -- branch-target-addr ) + see_addr @ see_addr + +; + +: SEE.SHOW.LIT ( -- ) + see.get.inline . + see.advance + see.out+ +; + +exists? F* [IF] +: SEE.SHOW.FLIT ( -- ) + see_addr f@ f. + 1 floats +-> see_addr + see.out+ +; +[THEN] + +: SEE.SHOW.ALIT ( -- ) + see.get.inline >name id. space + see.advance + see.out+ +; + +: SEE.SHOW.STRING ( -- ) + see_addr count 2dup + aligned -> see_addr type + see.out+ +; +: SEE.SHOW.TARGET ( -- ) + see.get.target .hex see.advance +; + +: SEE.BRANCH ( -- addr | , handle branch ) + -1 +-> see_level + see.newline + see.get.inline 0> + IF \ forward branch + ." ELSE " + see.get.target \ calculate address of target + 1 +-> see_level + nip \ remove old address for THEN + ELSE + ." REPEAT " see.get.target .hex + drop \ remove old address for THEN + THEN + see.advance + see.cr +; + +: SEE.0BRANCH ( -- addr | , handle 0branch ) + see.newline + see.get.inline 0> + IF \ forward branch + ." IF or WHILE " + see.get.target \ calculate adress of target + 1 +-> see_level + ELSE + ." UNTIL=>" see.get.target .hex + THEN + see.advance + see.cr +; + +: SEE.XT { xt -- } + xt + CASE + 0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0 -> see_addr THEN ENDOF + ['] (LITERAL) OF see.show.lit ENDOF + ['] (ALITERAL) OF see.show.alit ENDOF +[ exists? (FLITERAL) [IF] ] + ['] (FLITERAL) OF see.show.flit ENDOF +[ [THEN] ] + ['] BRANCH OF see.branch ENDOF + ['] 0BRANCH OF see.0branch ENDOF + ['] (LOOP) OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr ENDOF + ['] (+LOOP) OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr ENDOF + ['] (DO) OF see.newline ." DO" 1 +-> see_level see.cr ENDOF + ['] (?DO) OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF + ['] (.") OF .' ." ' see.show.string .' " ' ENDOF + ['] (C") OF .' C" ' see.show.string .' " ' ENDOF + ['] (S") OF .' S" ' see.show.string .' " ' ENDOF + + see.cr? xt .xt see.out+ + ENDCASE +; + +: (SEE) { cfa | xt -- } + 0 -> see_level + cfa -> see_addr + see.cr + 0 \ fake address for THEN handler + BEGIN + see_addr code@ -> xt + BEGIN + dup see_addr ( >newline .s ) = + WHILE + -1 +-> see_level see.newline + ." THEN " see.cr + drop + REPEAT + CODE_CELL +-> see_addr + xt see.xt + see_addr 0= + UNTIL + cr + 0= not abort" SEE conditional analyser nesting failed!" +; + +}PRIVATE + +: SEE ( -- , disassemble ) + ' + dup ['] FIRST_COLON > + IF + >code (see) + ELSE + >name id. + ." is primitive defined in 'C' kernel." cr + THEN +; + +PRIVATIZE + +0 [IF] + +: SEE.JOKE + dup swap drop +; + +: SEE.IF + IF + ." hello" cr + ELSE + ." bye" cr + THEN + see.joke +; +: SEE.DO + 4 0 + DO + i . cr + LOOP +; +: SEE." + ." Here are some strings." cr + c" Forth string." count type cr + s" Addr/Cnt string" type cr +; + +[THEN] diff --git a/siev.fs b/siev.fs new file mode 100644 index 0000000..323715c --- /dev/null +++ b/siev.fs @@ -0,0 +1,23 @@ +\ #! /usr/stud/paysan/bin/forth + +DECIMAL +\ : SECS TIME&DATE SWAP 60 * + SWAP 3600 * + NIP NIP NIP ; +CREATE FLAGS 8190 ALLOT +variable eflag +\ FLAGS 8190 + CONSTANT EFLAG + +: PRIMES ( -- n ) FLAGS 8190 1 FILL 0 3 EFLAG @ FLAGS + DO I C@ + IF DUP I + DUP EFLAG @ < + IF EFLAG @ SWAP + DO 0 I C! DUP +LOOP + ELSE DROP THEN SWAP 1+ SWAP + THEN 2 + + LOOP DROP ; + +: BENCHMARK 0 1000 0 DO PRIMES NIP LOOP ; +\ SECS BENCHMARK . SECS SWAP - CR . .( secs) +: main + flags 8190 + eflag ! + benchmark ( . ) drop +; diff --git a/siev.fth b/siev.fth new file mode 100644 index 0000000..579bf91 --- /dev/null +++ b/siev.fth @@ -0,0 +1,31 @@ +\ #! /usr/stud/paysan/bin/forth + +DECIMAL +\ : SECS TIME&DATE SWAP 60 * + SWAP 3600 * + NIP NIP NIP ; +CREATE FLAGS 8190 ALLOT +variable eflag +\ FLAGS 8190 + CONSTANT EFLAG + +\ use secondary fill like pForth !!! +: FILL { caddr num charval -- } + num 0 + ?DO + charval caddr i + c! + LOOP +; + +: PRIMES ( -- n ) FLAGS 8190 1 FILL 0 3 EFLAG @ FLAGS + DO I C@ + IF DUP I + DUP EFLAG @ < + IF EFLAG @ SWAP + DO 0 I C! DUP +LOOP + ELSE DROP THEN SWAP 1+ SWAP + THEN 2 + + LOOP DROP ; + +: BENCHMARK 0 100 0 DO PRIMES NIP LOOP ; \ !!! ONLY 100 +\ SECS BENCHMARK . SECS SWAP - CR . .( secs) +: main + flags 8190 + eflag ! + benchmark ( . ) drop +; diff --git a/smart_if.fth b/smart_if.fth new file mode 100644 index 0000000..17c1b61 --- /dev/null +++ b/smart_if.fth @@ -0,0 +1,57 @@ +\ @(#) smart_if.fth 98/01/26 1.2 +\ Smart Conditionals +\ Allow use of if, do, begin, etc.outside of colon definitions. +\ +\ Thanks to Mitch Bradley for the idea. +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-smart_if.fth + +variable SMIF-XT \ execution token for conditional code +variable SMIF-DEPTH \ depth of nested conditionals + +: SMIF{ ( -- , if executing, start compiling, setup depth ) + state @ 0= + IF + :noname smif-xt ! + 1 smif-depth ! + ELSE + 1 smif-depth +! + THEN +; + +: }SMIF ( -- , unnest, stop compiling, execute code and forget ) + smif-xt @ + IF + -1 smif-depth +! + smif-depth @ 0 <= + IF + postpone ; \ stop compiling + smif-xt @ execute \ execute conditional code + smif-xt @ >code dp ! \ forget conditional code + 0 smif-xt ! \ clear so we don't mess up later + THEN + THEN +; + +\ redefine conditionals to use smart mode +: IF smif{ postpone if ; immediate +: DO smif{ postpone do ; immediate +: ?DO smif{ postpone ?do ; immediate +: BEGIN smif{ postpone begin ; immediate +: THEN postpone then }smif ; immediate +: REPEAT postpone repeat }smif ; immediate +: UNTIL postpone until }smif ; immediate +: LOOP postpone loop }smif ; immediate +: +LOOP postpone +loop }smif ; immediate diff --git a/strings.fth b/strings.fth new file mode 100644 index 0000000..08426c5 --- /dev/null +++ b/strings.fth @@ -0,0 +1,97 @@ +\ @(#) strings.fth 98/01/26 1.2 +\ String support for PForth +\ +\ Copyright Phil Burk 1994 + +ANEW TASK-STRINGS.FTH + +: -TRAILING ( c-addr u1 -- c-addr u2 , strip trailing blanks ) + dup 0> + IF + BEGIN + 2dup 1- chars + c@ bl = + over 0> and + WHILE + 1- + REPEAT + THEN +; + +\ Structure of string table +: $ARRAY ( ) + CREATE ( #strings #chars_max -- ) + dup , + 2+ * even-up allot + DOES> ( index -- $addr ) + dup @ ( get #chars ) + rot * + 4 + +; + +\ Compare two strings +: $= ( $1 $2 -- flag , true if equal ) + -1 -rot + dup c@ 1+ 0 + DO dup c@ tolower + 2 pick c@ tolower - + IF rot drop 0 -rot LEAVE + THEN + 1+ swap 1+ swap + LOOP 2drop +; + +: TEXT= ( addr1 addr2 count -- flag ) + >r -1 -rot + r> 0 + DO dup c@ tolower + 2 pick c@ tolower - + IF rot drop 0 -rot LEAVE + THEN + 1+ swap 1+ swap + LOOP 2drop +; + +: TEXT=? ( addr1 count addr2 -- flag , for JForth compatibility ) + swap text= +; + +: $MATCH? ( $string1 $string2 -- flag , case INsensitive ) + dup c@ 1+ text= +; + + +: INDEX ( $string char -- false | address_char true , search for char in string ) + >r >r 0 r> r> + over c@ 1+ 1 + DO over i + c@ over = + IF rot drop + over i + rot rot LEAVE + THEN + LOOP 2drop + ?dup 0= 0= +; + + +: $APPEND.CHAR ( $string char -- ) \ ugly stack diagram + over count chars + c! + dup c@ 1+ swap c! +; + +\ ---------------------------------------------- +: ($ROM) ( index address -- $string ) + ( -- index address ) + swap 0 + DO dup c@ 1+ + aligned + LOOP +; + +: $ROM ( packed array of strings, unalterable ) + CREATE ( -- ) + DOES> ( index -- $string ) ($rom) +; + +: TEXTROM ( packed array of strings, unalterable ) + CREATE ( -- ) + DOES> ( index -- address count ) ($rom) count +; + +\ ----------------------------------------------- diff --git a/system.fth b/system.fth new file mode 100644 index 0000000..b2e04aa --- /dev/null +++ b/system.fth @@ -0,0 +1,805 @@ +: FIRST_COLON ; + +: LATEST context @ ; + +: FLAG_IMMEDIATE 64 ; + +: IMMEDIATE + latest dup c@ flag_immediate OR + swap c! +; + +: ( 41 word drop ; immediate +( That was the definition for the comment word. ) +( Now we can add comments to what we are doing! ) +( Note that we are in decimal numeric input mode. ) + +: \ ( -- , comment out rest of line ) + EOL word drop +; immediate + +\ This is another style of comment that is common in Forth. + +\ @(#) system.fth 98/01/26 1.4 +\ ********************************************************************* +\ pFORTH - Portable Forth System +\ Based on HMSL Forth +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. +\ ********************************************************************* + +: COUNT dup 1+ swap c@ ; + +\ Miscellaneous support words +: ON ( addr -- , set true ) + -1 swap ! +; +: OFF ( addr -- , set false ) + 0 swap ! +; + +\ size of data items +\ FIXME - move these into 'C' code for portability ???? +: CELL ( -- size_of_stack_item ) 4 ; + +: CELL+ ( n -- n+cell ) cell + ; +: CELL- ( n -- n+cell ) cell - ; +: CELLS ( n -- n*cell ) 2 lshift ; + +: CHAR+ ( n -- n+size_of_char ) 1+ ; +: CHARS ( n -- n*size_of_char , don't do anything) ; immediate + +\ useful stack manipulation words +: -ROT ( a b c -- c a b ) + rot rot +; +: 3DUP ( a b c -- a b c a b c ) + 2 pick 2 pick 2 pick +; +: 2DROP ( a b -- ) + drop drop +; +: NIP ( a b -- b ) + swap drop +; +: TUCK ( a b -- b a b ) + swap over +; + +: <= ( a b -- f , true if A <= b ) + > 0= +; +: >= ( a b -- f , true if A >= b ) + < 0= +; + +: INVERT ( n -- 1'comp ) + -1 xor +; + +: NOT ( n -- !n , logical negation ) + 0= +; + +: NEGATE ( n -- -n ) + 0 swap - +; + +: DNEGATE ( d -- -d , negate by doing 0-d ) + 0 0 2swap d- +; + + +\ -------------------------------------------------------------------- + +: ID. ( nfa -- ) + count 31 and type +; + +: DECIMAL 10 base ! ; +: OCTAL 8 base ! ; +: HEX 16 base ! ; +: BINARY 2 base ! ; + +: PAD ( -- addr ) + here 128 + +; + +: $MOVE ( $src $dst -- ) + over c@ 1+ cmove +; +: BETWEEN ( n lo hi -- flag , true if between lo & hi ) + >r over r> > >r + < r> or 0= +; +: [ ( -- , enter interpreter mode ) + 0 state ! +; immediate +: ] ( -- enter compile mode ) + 1 state ! +; + +: EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ; +: ALIGNED ( addr -- a-addr ) + [ cell 1- ] literal + + [ cell 1- invert ] literal and +; +: ALIGN ( -- , align DP ) dp @ aligned dp ! ; +: ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ; + +: C, ( c -- ) here c! 1 chars dp +! ; +: W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ; +: , ( n -- , lay into dictionary ) align here ! cell allot ; + +\ Dictionary conversions ------------------------------------------ + +: N>NEXTLINK ( nfa -- nextlink , traverses name field ) + dup c@ 31 and 1+ + aligned +; + +: NAMEBASE ( -- base-of-names ) + Headers-Base @ +; +: CODEBASE ( -- base-of-code dictionary ) + Code-Base @ +; + +: NAMELIMIT ( -- limit-of-names ) + Headers-limit @ +; +: CODELIMIT ( -- limit-of-code, last address in dictionary ) + Code-limit @ +; + +: NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual ) + namebase + +; + +: >CODE ( xt -- secondary_code_address, not valid for primitives ) + codebase + +; + +: CODE> ( secondary_code_address -- xt , not valid for primitives ) + codebase - +; + +: N>LINK ( nfa -- lfa ) + 8 - +; + +: >BODY ( xt -- pfa ) + >code body_offset + +; + +: BODY> ( pfa -- xt ) + body_offset - code> +; + +\ convert between addresses useable by @, and relocatable addresses. +: USE->REL ( useable_addr -- rel_addr ) + codebase - +; +: REL->USE ( rel_addr -- useable_addr ) + codebase + +; + +\ for JForth code +\ : >REL ( adr -- adr ) ; immediate +\ : >ABS ( adr -- adr ) ; immediate + +: X@ ( addr -- xt , fetch execution token from relocatable ) @ ; +: X! ( addr -- xt , store execution token as relocatable ) ! ; + +\ Compiler support ------------------------------------------------ +: COMPILE, ( xt -- , compile call to xt ) + , +; + +( Compiler support , based on FIG ) +: [COMPILE] ( -- , compile now even if immediate ) + ' compile, +; IMMEDIATE + +: (COMPILE) ( xt -- , postpone compilation of token ) + [compile] literal ( compile a call to literal ) + ( store xt of word to be compiled ) + + [ ' compile, ] literal \ compile call to compile, + compile, +; + +: COMPILE ( -- , save xt and compile later ) + ' (compile) +; IMMEDIATE + + +: :NONAME ( -- xt , begin compilation of headerless secondary ) + align + here code> \ convert here to execution token + ] +; + +\ Error codes +: ERR_ABORT -1 ; \ general abort +: ERR_CONDITIONAL -2 ; \ stack error during conditional +: ERR_EXECUTING -3 ; \ compile time word while not compiling +: ERR_PAIRS -4 ; \ mismatch in conditional +: ERR_DEFER -5 ; \ not a deferred word +: ERR_UNDERFLOW -6 ; + +\ Conditionals in '83 form ----------------------------------------- +: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ; +: ?CONDITION ( f -- ) conditional_key - err_conditional ?error ; +: >MARK ( -- addr ) here 0 , ; +: >RESOLVE ( addr -- ) here over - swap ! ; +: mark ; immediate +: THEN ( f orig -- ) swap ?condition >resolve ; immediate +: BEGIN ( -- f dest ) ?comp conditional_key mark ; immediate + +\ conditionals built from primitives +: ELSE ( f orig1 -- f orig2 ) + [compile] AHEAD 2swap [compile] THEN ; immediate +: WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate +: REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate + +: ['] ( -- xt , define compile time tick ) + ?comp ' [compile] literal +; immediate + +\ for example: +\ compile time: compile create , (does>) then ; +\ execution time: create , ',' data, then patch pi to point to @ +\ : con create , does> @ ; +\ 345 con pi +\ pi +\ +: (DOES>) ( xt -- , modify previous definition to execute code at xt ) + latest name> >code \ get address of code for new word + cell + \ offset to second cell in create word + ! \ store execution token of DOES> code in new word +; + +: DOES> ( -- , define execution code for CREATE word ) + 0 [compile] literal \ dummy literal to hold xt + here cell- \ address of zero in literal + compile (does>) \ call (DOES>) from new creation word + [compile] ; \ terminate part of code before does> + :noname ( addrz xt ) + swap ! \ save execution token in literal +; immediate + +: VARIABLE ( -- ) + CREATE 0 , \ IMMEDIATE +\ DOES> [compile] aliteral \ %Q This could be optimised +; + +: 2VARIABLE ( -c- ) ( -x- addr ) + create 0 , 0 , +; + +: CONSTANT ( n -c- ) ( -x- n ) + CREATE , ( n -- ) + DOES> @ ( -- n ) +; + +0 1- constant -1 +0 2- constant -2 + +: 2! ( x1 x2 addr -- , store x2 followed by x1 ) + swap over ! cell+ ! +; +: 2@ ( addr -- x1 x2 ) + dup cell+ @ swap @ +; + + +: ABS ( n -- |n| ) + dup 0< + IF negate + THEN +; +: DABS ( d -- |d| ) + dup 0< + IF dnegate + THEN +; + +: S>D ( s -- d , extend signed single precision to double ) + dup 0< + IF -1 + ELSE 0 + THEN +; + +: D>S ( d -- s ) drop ; + +: /MOD ( a b -- rem quo , unsigned version, FIXME ) + >r s>d r> um/mod +; + +: MOD ( a b -- rem ) + /mod drop +; + +: 2* ( n -- n*2 ) + 1 lshift +; +: 2/ ( n -- n/2 ) + 1 arshift +; + +: D2* ( d -- d*2 ) + 2* over 31 rshift or swap + 2* swap +; + +\ define some useful constants ------------------------------ +1 0= constant FALSE +0 0= constant TRUE +32 constant BL + +\ Store and Fetch relocatable data addresses. --------------- +: IF.USE->REL ( use -- rel , preserve zero ) + dup IF use->rel THEN +; +: IF.REL->USE ( rel -- use , preserve zero ) + dup IF rel->use THEN +; + +: A! ( dictionary_address addr -- ) + >r if.use->rel r> ! +; +: A@ ( addr -- dictionary_address ) + @ if.rel->use +; + +: A, ( dictionary_address -- ) + if.use->rel , +; + +\ Stack data structure ---------------------------------------- +\ This is a general purpose stack utility used to implement necessary +\ stacks for the compiler or the user. Not real fast. +\ These stacks grow up which is different then normal. +\ cell 0 - stack pointer, offset from pfa of word +\ cell 1 - limit for range checking +\ cell 2 - first data location + +: :STACK ( #cells -- ) + CREATE 2 cells , ( offset of first data location ) + dup , ( limit for range checking, not currently used ) + cells cell+ allot ( allot an extra cell for safety ) +; + +: >STACK ( n stack -- , push onto stack, postincrement ) + dup @ 2dup cell+ swap ! ( -- n stack offset ) + + ! +; + +: STACK> ( stack -- n , pop , predecrement ) + dup @ cell- 2dup swap ! + + @ +; + +: STACK@ ( stack -- n , copy ) + dup @ cell- + @ +; + +: STACK.PICK ( index stack -- n , grab Nth from top of stack ) + dup @ cell- + + swap cells - \ offset for index + @ +; +: STACKP ( stack -- ptr , to next empty location on stack ) + dup @ + +; + +: 0STACKP ( stack -- , clear stack) + 8 swap ! +; + +32 :stack ustack +ustack 0stackp + +\ Define JForth like words. +: >US ustack >stack ; +: US> ustack stack> ; +: US@ ustack stack@ ; +: 0USP ustack 0stackp ; + + +\ DO LOOP ------------------------------------------------ + +3 constant do_flag +4 constant leave_flag +5 constant ?do_flag + +: DO ( -- , loop-back do_flag jump-from ?do_flag ) + ?comp + compile (do) + here >us do_flag >us ( for backward branch ) +; immediate + +: ?DO ( -- , loop-back do_flag jump-from ?do_flag , on user stack ) + ?comp + ( leave address to set for forward branch ) + compile (?do) + here 0 , + here >us do_flag >us ( for backward branch ) + >us ( for forward branch ) ?do_flag >us +; immediate + +: LEAVE ( -- addr leave_flag ) + compile (leave) + here 0 , >us + leave_flag >us +; immediate + +: LOOP-FORWARD ( -us- jump-from ?do_flag -- ) + BEGIN + us@ leave_flag = + us@ ?do_flag = + OR + WHILE + us> leave_flag = + IF + us> here over - cell+ swap ! + ELSE + us> dup + here swap - + cell+ swap ! + THEN + REPEAT +; + +: LOOP-BACK ( loop-addr do_flag -us- ) + us> do_flag ?pairs + us> here - here + ! + cell allot +; + +: LOOP ( -- , loop-back do_flag jump-from ?do_flag ) + compile (loop) + loop-forward loop-back +; immediate + +\ : DOTEST 5 0 do 333 . loop 888 . ; +\ : ?DOTEST0 0 0 ?do 333 . loop 888 . ; +\ : ?DOTEST1 5 0 ?do 333 . loop 888 . ; + +: +LOOP ( -- , loop-back do_flag jump-from ?do_flag ) + compile (+loop) + loop-forward loop-back +; immediate + +: UNLOOP ( loop-sys -r- ) + r> \ save return pointer + rdrop rdrop + >r +; + +: RECURSE ( ? -- ? , call the word currently being defined ) + latest name> compile, +; immediate + +: SPACE bl emit ; +: SPACES 512 min 0 max 0 ?DO space LOOP ; +: 0SP depth 0 ?do drop loop ; + +: >NEWLINE ( -- , CR if needed ) + out @ 0> + IF cr + THEN +; + + +\ Support for DEFER -------------------- +: CHECK.DEFER ( xt -- , error if not a deferred word by comparing to type ) + >code @ + ['] emit >code @ + - err_defer ?error +; + +: >is ( xt -- address_of_vector ) + >code + cell + +; + +: (IS) ( xt_do xt_deferred -- ) + >is ! +; + +: IS ( xt -- , act like normal IS ) + ' \ xt + dup check.defer + state @ + IF [compile] literal compile (is) + ELSE (is) + THEN +; immediate + +: (WHAT'S) ( xt -- xt_do ) + >is @ +; +: WHAT'S ( -- xt , what will deferred word call? ) + ' \ xt + dup check.defer + state @ + IF [compile] literal compile (what's) + ELSE (what's) + THEN +; immediate + +defer ABORT \ will default to QUIT + +: /STRING ( addr len n -- addr' len' ) + over min rot over + -rot - +; +: PLACE ( addr len to -- , move string ) + 3dup 1+ swap cmove c! drop +; + +: PARSE-WORD ( char -- addr len ) + >r source tuck >in @ /string r@ skip over swap r> scan + >r over - rot r> dup 0<> + - >in ! +; +: PARSE ( char -- addr len ) + >r source >in @ /string over swap r> scan + >r over - dup r> 0<> - >in +! +; + +: LWORD ( char -- addr ) + parse-word here place here \ 00002 , use PARSE-WORD +; + +: ASCII ( -- char , state smart ) + bl parse drop c@ + state @ + IF [compile] literal + THEN +; immediate + +: CHAR ( -- char , interpret mode ) + bl parse drop c@ +; + +: [CHAR] ( -- char , for compile mode ) + char [compile] literal +; immediate + +: $TYPE ( $string -- ) + count type +; + +: 'word ( -- addr ) here ; + +: EVEN ( addr -- addr' ) dup 1 and + ; + +: (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?) + r> dup count + aligned >r +; +: (S") ( -- c-addr cnt ) + r> count 2dup + aligned >r +; + +: (.") ( -- , type following string ) + r> count 2dup + aligned >r type +; + +: ", ( adr len -- , place string into dictionary ) + tuck 'word place 1+ allot align +; +: ," ( -- ) + [char] " parse ", +; + +: .( ( -- , type string delimited by parentheses ) + [CHAR] ) PARSE TYPE +; IMMEDIATE + +: ." ( -- , type string ) + state @ + IF compile (.") ," + ELSE [char] " parse type + THEN +; immediate + + +: .' ( -- , type string delimited by single quote ) + state @ + IF compile (.") [char] ' parse ", + ELSE [char] ' parse type + THEN +; immediate + +: C" ( -- addr , return string address, ANSI ) + state @ + IF compile (c") ," + ELSE [char] " parse pad place pad + THEN +; immediate + +: S" ( -- , -- addr , return string address, ANSI ) + state @ + IF compile (s") ," + ELSE [char] " parse pad place pad count + THEN +; immediate + +: " ( -- , -- addr , return string address ) + [compile] C" +; immediate +: P" ( -- , -- addr , return string address ) + [compile] C" +; immediate + +: "" ( -- addr ) + state @ + IF + compile (C") + bl parse-word ", + ELSE + bl parse-word pad place pad + THEN +; immediate + +: SLITERAL ( addr cnt -- , compile string ) + compile (S") + ", +; IMMEDIATE + +: $APPEND ( addr count $1 -- , append text to $1 ) + over >r + dup >r + count + ( -- a2 c2 end1 ) + swap cmove + r> dup c@ ( a1 c1 ) + r> + ( -- a1 totalcount ) + swap c! +; + +\ ----------------------------------------------------------------- +\ Auto Initialization +: AUTO.INIT ( -- ) +\ Kernel finds AUTO.INIT and executes it after loading dictionary. + ." Begin AUTO.INIT ------" cr +; +: AUTO.TERM ( -- ) +\ Kernel finds AUTO.TERM and executes it on bye. + ." End AUTO.TERM ------" cr +; + +\ -------------- INCLUDE ------------------------------------------ +variable TRACE-INCLUDE + +: INCLUDE.MARK.START ( $filename -- , mark start of include for FILE?) + " ::::" pad $MOVE + count pad $APPEND + pad ['] noop (:) +; + +: INCLUDE.MARK.END ( -- , mark end of include ) + " ;;;;" ['] noop (:) +; + +: $INCLUDE ( $filename -- ) +\ Print messages. + trace-include @ + IF + >newline ." Include " dup count type cr + THEN + here >r + dup + count r/o open-file + IF ( -- $filename bad-fid ) + drop ." Could not find file " $type cr abort + ELSE ( -- $filename good-fid ) + swap include.mark.start + dup >r \ save fid for close-file + depth >r + include-file + depth 1+ r> - + IF + ." Warning: stack depth changed during include!" cr + .s cr + 0sp + THEN + r> close-file drop + include.mark.end + THEN + trace-include @ + IF + ." include added " here r@ - . ." bytes," + codelimit here - . ." left." cr + THEN + rdrop +; + +create INCLUDE-SAVE-NAME 128 allot +: INCLUDE ( -- ) + BL lword + dup include-save-name $move \ save for RI + $include +; + +: RI ( -- , ReInclude previous file as a convenience ) + include-save-name $include +; + +: INCLUDE? ( -- , load file if word not defined ) + bl word find + IF drop bl word drop ( eat word from source ) + ELSE drop include + THEN +; + +\ desired sizes for dictionary loaded after SAVE-FORTH +variable HEADERS-SIZE +variable CODE-SIZE + +: AUTO.INIT + auto.init + codelimit codebase - code-size ! + namelimit namebase - headers-size ! +; +auto.init + +: SAVE-FORTH ( $name -- ) + 0 \ Entry point + headers-ptr @ namebase - 65536 + \ NameSize + headers-size @ MAX + here codebase - 131072 + \ CodeSize + code-size @ MAX + (save-forth) + IF + ." SAVE-FORTH failed!" cr abort + THEN +; + +: TURNKEY ( $name entry-token-- ) + 0 \ NameSize = 0, names not saved in turnkey dictionary + here codebase - 131072 + \ CodeSize, remember that base is HEX + (save-forth) + IF + ." TURNKEY failed!" cr abort + THEN +; + +\ load remainder of dictionary + +trace-include on +trace-stack on + +include loadp4th.fth + +decimal + +: ;;;; ; \ Mark end of this file so FILE? can find things in here. +FREEZE \ prevent forgetting below this point + +.( Dictionary compiled, save in "pforth.dic".) cr +c" pforth.dic" save-forth diff --git a/t_alloc.fth b/t_alloc.fth new file mode 100644 index 0000000..4f20917 --- /dev/null +++ b/t_alloc.fth @@ -0,0 +1,116 @@ +\ @(#) t_alloc.fth 97/01/28 1.4 +\ Test PForth ALLOCATE +\ +\ Copyright 1994 3DO, Phil Burk + +anew task-t_alloc.fth +decimal + +64 constant NUM_TAF_SLOTS + +variable TAF-MAX-ALLOC +variable TAF-MAX-SLOT + +\ hold addresses and sizes +NUM_TAF_SLOTS array TAF-ADDRESSES +NUM_TAF_SLOTS array TAF-SIZES + +: TAF.MAX.ALLOC? { | numb addr ior maxb -- max } + 0 -> maxb +\ determine maximum amount we can allocate + 1024 40 * -> numb + BEGIN + numb 0> + WHILE + numb allocate -> ior -> addr + ior 0= + IF \ success + addr free abort" Free failed!" + numb -> maxb + 0 -> numb + ELSE + numb 1024 - -> numb + THEN + REPEAT + maxb +; + +: TAF.INIT ( -- ) + NUM_TAF_SLOTS 0 + DO + 0 i taf-addresses ! + LOOP +\ + taf.max.alloc? ." Total Avail = " dup . cr + dup taf-max-alloc ! + NUM_TAF_SLOTS / taf-max-slot ! +; + +: TAF.ALLOC.SLOT { slotnum | addr size -- } +\ allocate some RAM + taf-max-slot @ 8 - + choose 8 + + dup allocate abort" Allocation failed!" + -> addr + -> size + addr slotnum taf-addresses ! + size slotnum taf-sizes ! +\ +\ paint RAM with slot number + addr size slotnum fill +; + +: TAF.FREE.SLOT { slotnum | addr size -- } + slotnum taf-addresses @ -> addr +\ something allocated so check it and free it. + slotnum taf-sizes @ 0 + DO + addr i + c@ slotnum - + IF + ." Error at " addr i + . + ." , slot# " slotnum . cr + abort + THEN + LOOP + addr free abort" Free failed!" + 0 slotnum taf-addresses ! +; + +: TAF.DO.SLOT { slotnum -- } + slotnum taf-addresses @ 0= + IF + slotnum taf.alloc.slot + ELSE + slotnum taf.free.slot + THEN +; + +: TAF.TERM + NUM_TAF_SLOTS 0 + DO + i taf-addresses @ + IF + i taf.free.slot + THEN + LOOP +\ + taf.max.alloc? dup ." Final MAX = " . cr + ." Original MAX = " taf-max-alloc @ dup . cr + = IF ." Test PASSED." ELSE ." Test FAILED!" THEN cr + +; + +: TAF.TEST ( NumTests -- ) + 1 max + dup . ." tests" cr \ flushemit + taf.init + ." Please wait for test to complete..." cr + 0 + DO NUM_TAF_SLOTS choose taf.do.slot + LOOP + taf.term +; + +.( Testing ALLOCATE and FREE) cr +10000 taf.test + diff --git a/t_corex.fth b/t_corex.fth new file mode 100644 index 0000000..1f383c4 --- /dev/null +++ b/t_corex.fth @@ -0,0 +1,226 @@ +\ @(#) t_corex.fth 98/03/16 1.2 +\ Test ANS Forth Core Extensions +\ +\ Copyright 1994 3DO, Phil Burk + +INCLUDE? }T{ t_tools.fth + +ANEW TASK-T_COREX.FTH + +DECIMAL + +\ STUB because missing definition in pForth - FIXME +: SAVE-INPUT ; +: RESTORE-INPUT -1 ; + +TEST{ + +\ ========================================================== +T{ 1 2 3 }T{ 1 2 3 }T + +\ ----------------------------------------------------- .( +T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T + +CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR + +T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T + +\ ----------------------------------------------------- 0<> +T{ 5 0<> }T{ TRUE }T +T{ 0 0<> }T{ 0 }T +T{ -1000 0<> }T{ TRUE }T + +\ ----------------------------------------------------- 2>R 2R> 2R@ +: T2>R ( -- .... ) + 17 + 20 5 2>R + 19 + 2R@ + 37 + 2R> +\ 2>R should be the equivalent of SWAP >R >R so this next construct +\ should reduce to a SWAP. + 88 77 2>R R> R> +; +T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T + +\ ----------------------------------------------------- :NONAME +T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T + +\ ----------------------------------------------------- <> +T{ 12345 12305 <> }T{ TRUE }T +T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T + +\ ----------------------------------------------------- ?DO +: T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ; +T{ 0 T?DO }T{ 0 }T +T{ 4 T?DO }T{ 10 }T + +\ ----------------------------------------------------- AGAIN +: T.AGAIN ( n -- ) + BEGIN + DUP . + DUP 6 < IF EXIT THEN + 1- + AGAIN +; +T{ 10 T.AGAIN CR }T{ 5 }T + +\ ----------------------------------------------------- C" +: T.C" ( -- $STRING ) + C" x5&" +; +T{ T.C" C@ }T{ 3 }T +T{ T.C" COUNT DROP C@ }T{ CHAR x }T +T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T +T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T + +\ ----------------------------------------------------- CASE +: T.CASE ( N -- ) + CASE + 1 OF 101 ENDOF + 27 OF 892 ENDOF + 941 SWAP \ default + ENDCASE +; +T{ 1 T.CASE }T{ 101 }T +T{ 27 T.CASE }T{ 892 }T +T{ 49 T.CASE }T{ 941 }T + +\ ----------------------------------------------------- COMPILE, +: COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE +: T.COMPILE, + 19 20 27 COMPILE.SWAP 39 +; +T{ T.COMPILE, }T{ 19 27 20 39 }T + +\ ----------------------------------------------------- CONVERT +: T.CONVERT + 0 S>D S" 1234xyz" DROP CONVERT + >R + D>S + R> C@ +; +T{ T.CONVERT }T{ 1234 CHAR x }T + +\ ----------------------------------------------------- ERASE +: T.COMMA.SEQ ( n -- , lay down N sequential bytes ) + 0 ?DO I C, LOOP +; +CREATE T-ERASE-DATA 64 T.COMMA.SEQ +T{ T-ERASE-DATA 8 + C@ }T{ 8 }T +T{ T-ERASE-DATA 7 + 3 ERASE +T{ T-ERASE-DATA 6 + C@ }T{ 6 }T +T{ T-ERASE-DATA 7 + C@ }T{ 0 }T +T{ T-ERASE-DATA 8 + C@ }T{ 0 }T +T{ T-ERASE-DATA 9 + C@ }T{ 0 }T +T{ T-ERASE-DATA 10 + C@ }T{ 10 }T + +\ ----------------------------------------------------- FALSE +T{ FALSE }T{ 0 }T + +\ ----------------------------------------------------- HEX +T{ HEX 10 DECIMAL }T{ 16 }T + +\ ----------------------------------------------------- MARKER +: INDIC? ( -- ifInDic , is the following word defined? ) + bl word find + swap drop 0= 0= +; +create FOOBAR +MARKER MYMARK \ create word that forgets itself +create GOOFBALL +MYMARK +T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T + +\ ----------------------------------------------------- NIP +T{ 33 44 55 NIP }T{ 33 55 }T + +\ ----------------------------------------------------- PARSE +: T.PARSE ( char char -- addr num ) + PARSE + >R \ save length + PAD R@ CMOVE \ move string to pad + PAD R> +; +T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T + +\ ----------------------------------------------------- PICK +T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T + +\ ----------------------------------------------------- QUERY +T{ ' QUERY 0<> }T{ TRUE }T + +\ ----------------------------------------------------- REFILL +T{ ' REFILL 0<> }T{ TRUE }T + +\ ----------------------------------------------------- RESTORE-INPUT +T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE + +\ ----------------------------------------------------- ROLL +T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T +T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T +T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T +T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T +T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T + +\ ----------------------------------------------------- SOURCE-ID +T{ SOURCE-ID 0<> }T{ TRUE }T +T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T + +\ ----------------------------------------------------- SPAN +T{ ' SPAN 0<> }T{ TRUE }T + +\ ----------------------------------------------------- TO VALUE +333 VALUE MY-VALUE +T{ MY-VALUE }T{ 333 }T +T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T +: TEST.VALUE ( -- 19 100 ) + 100 TO MY-VALUE + 19 + MY-VALUE +; +T{ TEST.VALUE }T{ 19 100 }T + +\ ----------------------------------------------------- TRUE +T{ TRUE }T{ 0 0= }T + +\ ----------------------------------------------------- TUCK +T{ 44 55 66 TUCK }T{ 44 66 55 66 }T + +\ ----------------------------------------------------- U.R +HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR +ABCD4321 C U.R CR DECIMAL + +\ ----------------------------------------------------- U> +T{ -5 3 U> }T{ TRUE }T +T{ 10 8 U> }T{ TRUE }T + +\ ----------------------------------------------------- UNUSED +T{ UNUSED 0> }T{ TRUE }T + +\ ----------------------------------------------------- WITHIN +T{ 4 5 10 WITHIN }T{ 0 }T +T{ 5 5 10 WITHIN }T{ TRUE }T +T{ 9 5 10 WITHIN }T{ TRUE }T +T{ 10 5 10 WITHIN }T{ 0 }T + +T{ 4 10 5 WITHIN }T{ TRUE }T +T{ 5 10 5 WITHIN }T{ 0 }T +T{ 9 10 5 WITHIN }T{ 0 }T +T{ 10 10 5 WITHIN }T{ TRUE }T + +T{ -6 -5 10 WITHIN }T{ 0 }T +T{ -5 -5 10 WITHIN }T{ TRUE }T +T{ 9 -5 10 WITHIN }T{ TRUE }T +T{ 10 -5 10 WITHIN }T{ 0 }T + + +\ ----------------------------------------------------- [COMPILE] +: T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE +: T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ; +T{ T.[COMPILE] }T{ TRUE }T + +\ ----------------------------------------------------- \ +}TEST + diff --git a/t_floats.fth b/t_floats.fth new file mode 100644 index 0000000..866d8e1 --- /dev/null +++ b/t_floats.fth @@ -0,0 +1,134 @@ +\ @(#) t_floats.fth 98/02/26 1.1 17:46:04 +\ Test ANS Forth FLOAT words. +\ +\ Copyright 1994 3DO, Phil Burk + +INCLUDE? }T{ t_tools.fth + +ANEW TASK-T_FLOATS.FTH + +DECIMAL +3.14159265 fconstant PI + +TEST{ +\ ========================================================== +T{ 1 2 3 }T{ 1 2 3 }T +\ ----------------------------------------------------- D>F F>D +\ test some basic floating point <> integer conversion +T{ 4 0 D>F F>D }T{ 4 0 }T +T{ 835 0 D>F F>D }T{ 835 0 }T +T{ -57 -1 D>F F>D }T{ -57 -1 }T +T{ 15 S>F 2 S>F F/ F>S }T{ 7 }T \ 15.0/2.0 -> 7.5 + +\ ----------------------------------------------------- input +T{ 79.2 F>S }T{ 79 }T +T{ 0.003 F>S }T{ 0 }T + +\ ------------------------------------------------------ F~ +T{ 23.4 23.5 0.2 f~ }T{ true }T +T{ 23.4 23.7 0.2 f~ }T{ false }T +T{ 922.3 922.3 0.0 f~ }T{ true }T +T{ 922.3 922.31 0.0 f~ }T{ false }T +T{ 0.0 0.0 0.0 f~ }T{ true }T +T{ 0.0 -0.0 0.0 f~ }T{ false }T +T{ 50.0 51.0 -0.02 f~ }T{ true }T +T{ 50.0 51.0 -0.002 f~ }T{ false }T +T{ 500.0 510.0 -0.02 f~ }T{ true }T +T{ 500.0 510.0 -0.002 f~ }T{ false }T + +\ convert number to text representation and then back to float +: T_F. ( -- ok? ) ( r ftol -f- ) + fover (f.) >float fswap f~ + AND +; +: T_FS. ( -- ok? ) ( r -f- ) + fover (fs.) >float fswap f~ + AND +; +: T_FE. ( -- ok? ) ( r -f- ) + fover (fe.) >float fswap f~ + AND +; + +: T_FG. ( -- ok? ) ( r -f- ) + fover (f.) >float fswap f~ + AND +; + +: T_F>D ( -- ok? ) ( r -f- ) + fover f>d d>f fswap f~ +; + +T{ 0.0 0.00001 T_F. }T{ true }T +T{ 0.0 0.00001 T_FS. }T{ true }T +T{ 0.0 0.00001 T_FE. }T{ true }T +T{ 0.0 0.00001 T_FG. }T{ true }T +T{ 0.0 0.00001 T_F>D }T{ true }T + +T{ 12.34 -0.0001 T_F. }T{ true }T +T{ 12.34 -0.0001 T_FS. }T{ true }T +T{ 12.34 -0.0001 T_FE. }T{ true }T +T{ 12.34 -0.0001 T_FG. }T{ true }T +T{ 1234.0 -0.0001 T_F>D }T{ true }T + +T{ 2345 S>F 79 S>F F/ -0.0001 T_F. }T{ true }T +T{ 511 S>F -294 S>F F/ -0.0001 T_F. }T{ true }T + +: T.SERIES { N matchCFA | flag -- ok? } ( fstart fmult -f- ) + fswap ( -- fmust fstart ) + true -> flag + N 0 + ?DO + fdup -0.0001 matchCFA execute not + IF + false -> flag + ." T_F_SERIES failed for " i . fdup f. cr + leave + THEN +\ i . fdup f. cr + fover f* + LOOP + matchCFA >name id. ." T.SERIES final = " fs. cr + flag +; + +: T.SERIES_F. ['] t_f. t.series ; +: T.SERIES_FS. ['] t_fs. t.series ; +: T.SERIES_FG. ['] t_fg. t.series ; +: T.SERIES_FE. ['] t_fe. t.series ; +: T.SERIES_F>D ['] t_f>d t.series ; + +T{ 1.0 1.3 150 t.series_f. }T{ true }T +T{ 1.0 -1.3 150 t.series_f. }T{ true }T +T{ 2.3456789 1.3719 150 t.series_f. }T{ true }T + +T{ 3000.0 1.298 120 t.series_f>d }T{ true }T + +T{ 1.2 1.27751 150 t.series_fs. }T{ true }T +T{ 7.43 0.812255 200 t.series_fs. }T{ true }T + +T{ 1.195 1.30071 150 t.series_fe. }T{ true }T +T{ 5.913 0.80644 200 t.series_fe. }T{ true }T + +T{ 1.395 1.55071 120 t.series_fe. }T{ true }T +T{ 5.413 0.83644 160 t.series_fe. }T{ true }T + +\ ----------------------------------------------------- FABS +T{ 0.0 FABS 0.0 0.00001 F~ }T{ true }T +T{ 7.0 FABS 7.0 0.00001 F~ }T{ true }T +T{ -47.3 FABS 47.3 0.00001 F~ }T{ true }T + +\ ----------------------------------------------------- FSQRT +T{ 49.0 FSQRT 7.0 -0.0001 F~ }T{ true }T +T{ 2.0 FSQRT 1.414214 -0.0001 F~ }T{ true }T + +\ ----------------------------------------------------- FSIN +T{ 0.0 FSIN 0.0 0.00001 F~ }T{ true }T +T{ PI FSIN 0.0 0.00001 F~ }T{ true }T +T{ PI 2.0 F* FSIN 0.0 0.00001 F~ }T{ true }T +T{ PI 0.5 F* FSIN 1.0 0.00001 F~ }T{ true }T +T{ PI 6.0 F/ FSIN 0.5 0.00001 F~ }T{ true }T + +\ ----------------------------------------------------- \ +}TEST + diff --git a/t_locals.fth b/t_locals.fth new file mode 100644 index 0000000..7198ba7 --- /dev/null +++ b/t_locals.fth @@ -0,0 +1,41 @@ +\ @(#) t_locals.fth 97/01/28 1.1 +\ Test PForth LOCAL variables. +\ +\ Copyright 1996 3DO, Phil Burk + +include? }T{ t_tools.fth + +anew task-t_locals.fth +decimal + +test{ + +echo off + + +\ test value and locals +T{ 333 value my-value my-value }T{ 333 }T +T{ 1000 -> my-value my-value }T{ 1000 }T +T{ 35 +-> my-value my-value }T{ 1035 }T +: test.value ( -- ok ) + 100 -> my-value + my-value 100 = + 47 +-> my-value + my-value 147 = AND +; +T{ test.value }T{ TRUE }T + +\ test locals in a word +: test.locs { aa bb | cc -- ok } + cc 0= + aa bb + -> cc + aa bb + cc = AND + aa -> cc + bb +-> cc + aa bb + cc = AND +; +T{ 200 59 test.locs }T{ TRUE }T + + +}test + diff --git a/t_strings.fth b/t_strings.fth new file mode 100644 index 0000000..be75379 --- /dev/null +++ b/t_strings.fth @@ -0,0 +1,106 @@ +\ @(#) t_strings.fth 97/12/10 1.1 +\ Test ANS Forth String Word Set +\ +\ Copyright 1994 3DO, Phil Burk + +include? }T{ t_tools.fth + +marker task-t_string.fth + +decimal + +test{ + +echo off + +\ ========================================================== +\ test is.ok? +T{ 1 2 3 }T{ 1 2 3 }T + +: STR1 S" Hello " ; +: STR2 S" Hello World" ; +: STR3 S" " ; + +\ ----------------------------------------------------- -TRAILING +T{ STR1 -TRAILING }T{ STR1 DROP 5 }T +T{ STR2 -TRAILING }T{ STR2 }T +T{ STR3 -TRAILING }T{ STR3 }T + +\ ----------------------------------------------------- /STRING +T{ STR2 6 /STRING }T{ STR2 DROP 6 CHARS + STR2 NIP 6 - }T + + +\ ----------------------------------------------------- BLANK +: T.COMMA.SEQ ( n -- , lay down N sequential bytes ) + 0 ?DO I C, LOOP +; +CREATE T-BLANK-DATA 64 T.COMMA.SEQ +T{ T-BLANK-DATA 8 + C@ }T{ 8 }T +T-BLANK-DATA 7 + 3 BLANK +T{ T-BLANK-DATA 6 + C@ }T{ 6 }T +T{ T-BLANK-DATA 7 + C@ }T{ BL }T +T{ T-BLANK-DATA 8 + C@ }T{ BL }T +T{ T-BLANK-DATA 9 + C@ }T{ BL }T +T{ T-BLANK-DATA 10 + C@ }T{ 10 }T +FORGET T.COMMA.SEQ + +\ ----------------------------------------------------- CMOVE +: T.COMMA.SEQ ( n -- , lay down N sequential bytes ) + 0 ?DO I C, LOOP +; +CREATE T-BLANK-DATA 64 T.COMMA.SEQ +T-BLANK-DATA 7 + T-BLANK-DATA 6 + 3 CMOVE +T{ T-BLANK-DATA 5 + C@ }T{ 5 }T +T{ T-BLANK-DATA 6 + C@ }T{ 7 }T +T{ T-BLANK-DATA 7 + C@ }T{ 8 }T +T{ T-BLANK-DATA 8 + C@ }T{ 9 }T +T{ T-BLANK-DATA 9 + C@ }T{ 9 }T +FORGET T.COMMA.SEQ + +\ ----------------------------------------------------- CMOVE> +: T.COMMA.SEQ ( n -- , lay down N sequential bytes ) + 0 ?DO I C, LOOP +; +CREATE T-BLANK-DATA 64 T.COMMA.SEQ +T{ T-BLANK-DATA 6 + T-BLANK-DATA 7 + 3 CMOVE> +T{ T-BLANK-DATA 5 + C@ }T{ 5 }T +T{ T-BLANK-DATA 6 + C@ }T{ 6 }T +T{ T-BLANK-DATA 7 + C@ }T{ 6 }T +T{ T-BLANK-DATA 8 + C@ }T{ 7 }T +T{ T-BLANK-DATA 9 + C@ }T{ 8 }T +T{ T-BLANK-DATA 10 + C@ }T{ 10 }T +FORGET T.COMMA.SEQ + +\ ----------------------------------------------------- COMPARE +T{ : T.COMPARE.1 S" abcd" S" abcd" compare ; t.compare.1 }T{ 0 }T +T{ : T.COMPARE.2 S" abcd" S" abcde" compare ; t.compare.2 }T{ -1 }T +T{ : T.COMPARE.3 S" abcdef" S" abcde" compare ; t.compare.3 }T{ 1 }T +T{ : T.COMPARE.4 S" abGd" S" abcde" compare ; t.compare.4 }T{ -1 }T +T{ : T.COMPARE.5 S" abcd" S" aXcde" compare ; t.compare.5 }T{ 1 }T +T{ : T.COMPARE.6 S" abGd" S" abcd" compare ; t.compare.6 }T{ -1 }T +T{ : T.COMPARE.7 S" World" S" World" compare ; t.compare.7 }T{ 0 }T +FORGET T.COMPARE.1 + +\ ----------------------------------------------------- SEARCH +: STR-SEARCH S" ABCDefghIJKL" ; +T{ : T.SEARCH.1 STR-SEARCH S" ABCD" SEARCH ; T.SEARCH.1 }T{ STR-SEARCH TRUE }T +T{ : T.SEARCH.2 STR-SEARCH S" efg" SEARCH ; T.SEARCH.2 }T{ + STR-SEARCH 4 - SWAP 4 CHARS + SWAP TRUE }T +T{ : T.SEARCH.3 STR-SEARCH S" IJKL" SEARCH ; T.SEARCH.3 }T{ + STR-SEARCH DROP 8 CHARS + 4 TRUE }T +T{ : T.SEARCH.4 STR-SEARCH STR-SEARCH SEARCH ; T.SEARCH.4 }T{ + STR-SEARCH TRUE }T + +T{ : T.SEARCH.5 STR-SEARCH S" CDex" SEARCH ; T.SEARCH.5 }T{ + STR-SEARCH FALSE }T +T{ : T.SEARCH.6 STR-SEARCH S" KLM" SEARCH ; T.SEARCH.6 }T{ + STR-SEARCH FALSE }T +FORGET STR-SEARCH + +\ ----------------------------------------------------- SLITERAL +CREATE FAKE-STRING CHAR H C, CHAR e C, CHAR l C, CHAR l C, CHAR o C, +ALIGN +T{ : T.SLITERAL.1 [ FAKE-STRING 5 ] SLITERAL ; T.SLITERAL.1 FAKE-STRING 5 COMPARE + }T{ 0 }T + +}test diff --git a/t_tools.fth b/t_tools.fth new file mode 100644 index 0000000..a165c3b --- /dev/null +++ b/t_tools.fth @@ -0,0 +1,83 @@ +\ @(#) t_tools.fth 97/12/10 1.1 +\ Test Tools for pForth +\ +\ Based on testing tools from John Hayes +\ (c) 1993 Johns Hopkins University / Applied Physics Laboratory +\ +\ Syntax was changed to avoid conflict with { -> and } for local variables. +\ Also added tracking of #successes and #errors. + +anew task-t_tools.fth + +decimal + +variable TEST-DEPTH +variable TEST-PASSED +variable TEST-FAILED + +: TEST{ + depth test-depth ! + 0 test-passed ! + 0 test-failed ! +; + + +: }TEST + test-passed @ 4 .r ." passed, " + test-failed @ 4 .r ." failed." cr +; + + +VARIABLE actual-depth \ stack record +CREATE actual-results 20 CELLS ALLOT + +: empty-stack \ ( ... -- ) Empty stack. + DEPTH dup 0> + IF 0 DO DROP LOOP + ELSE drop + THEN ; + +CREATE the-test 128 CHARS ALLOT + +: ERROR \ ( c-addr u -- ) Display an error message followed by + \ the line that had the error. + TYPE the-test COUNT TYPE CR \ display line corresponding to error + empty-stack \ throw away every thing else +; + + +: T{ + source the-test place + empty-stack +; + +: }T{ \ ( ... -- ) Record depth and content of stack. + DEPTH actual-depth ! \ record depth + DEPTH 0 + ?DO + actual-results I CELLS + ! + LOOP \ save them +; + +: }T \ ( ... -- ) Compare stack (expected) contents with saved + \ (actual) contents. + DEPTH + actual-depth @ = + IF \ if depths match + 1 test-passed +! \ assume will pass + DEPTH 0 + ?DO \ for each stack item + actual-results I CELLS + @ \ compare actual with expected + <> + IF + -1 test-passed +! + 1 test-failed +! + S" INCORRECT RESULT: " error + LEAVE + THEN + LOOP + ELSE \ depth mismatch + 1 test-failed +! + S" WRONG NUMBER OF RESULTS: " error + THEN +; diff --git a/tester.fth b/tester.fth new file mode 100644 index 0000000..f4f2dd8 --- /dev/null +++ b/tester.fth @@ -0,0 +1,54 @@ +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.1 +HEX + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. +VARIABLE VERBOSE + FALSE VERBOSE ! + +: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. + DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; + +: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY + \ THE LINE THAT HAD THE ERROR. + TYPE SOURCE TYPE CR \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE +; + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: { \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + +: } \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED + \ (ACTUAL) CONTENTS. + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN + ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR + THEN ; + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP + THEN ; + diff --git a/trace.fth b/trace.fth new file mode 100644 index 0000000..c5c96c3 --- /dev/null +++ b/trace.fth @@ -0,0 +1,455 @@ +\ @(#) trace.fth 98/01/28 1.2 +\ TRACE ( -- , trace pForth word ) +\ +\ Single step debugger. +\ TRACE ( i*x -- , setup trace for Forth word ) +\ S ( -- , step over ) +\ SM ( many -- , step over many times ) +\ SD ( -- , step down ) +\ G ( -- , go to end of word ) +\ GD ( n -- , go down N levels from current level, stop at end of this level ) +\ +\ This debugger works by emulating the inner interpreter of pForth. +\ It executes code and maintains a separate return stack for the +\ program under test. Thus all primitives that operate on the return +\ stack, such as DO and R> must be trapped. Local variables must +\ also be handled specially. Several state variables are also +\ saved and restored to establish the context for the program being +\ tested. +\ +\ Copyright 1997 Phil Burk + +anew task-trace.fth + +: SPACE.TO.COLUMN ( col -- ) + out @ - spaces +; + +: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive ) + ['] first_colon < +; + +0 value TRACE_IP \ instruction pointer +0 value TRACE_LEVEL \ level of descent for inner interpreter +0 value TRACE_LEVEL_MAX \ maximum level of descent + +private{ + +\ use fake return stack +128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes +create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot +variable TRACE-RSP +: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n +: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++ +: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp +: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index] +: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ; +: TRACE.RDROP ( -- ) cell trace-rsp +! ; +: TRACE.RCHECK ( -- , abort if return stack out of range ) + trace-rsp @ trace-return-stack u< + abort" TRACE return stack OVERFLOW!" + trace-rsp @ trace-return-stack trace_return_size + 12 + u> + abort" TRACE return stack UNDERFLOW!" +; + +\ save and restore several state variables +10 cells constant TRACE_STATE_SIZE +create TRACE-STATE-1 TRACE_STATE_SIZE allot +create TRACE-STATE-2 TRACE_STATE_SIZE allot + +variable TRACE-STATE-PTR +: TRACE.SAVE++ ( addr -- , save next thing ) + @ trace-state-ptr @ ! + cell trace-state-ptr +! +; + +: TRACE.SAVE.STATE ( -- ) + state trace.save++ + hld trace.save++ + base trace.save++ +; + +: TRACE.SAVE.STATE1 ( -- , save normal state ) + trace-state-1 trace-state-ptr ! + trace.save.state +; +: TRACE.SAVE.STATE2 ( -- , save state of word being debugged ) + trace-state-2 trace-state-ptr ! + trace.save.state +; + + +: TRACE.RESTORE++ ( addr -- , restore next thing ) + trace-state-ptr @ @ swap ! + cell trace-state-ptr +! +; + +: TRACE.RESTORE.STATE ( -- ) + state trace.restore++ + hld trace.restore++ + base trace.restore++ +; + +: TRACE.RESTORE.STATE1 ( -- ) + trace-state-1 trace-state-ptr ! + trace.restore.state +; +: TRACE.RESTORE.STATE2 ( -- ) + trace-state-2 trace-state-ptr ! + trace.restore.state +; + +\ The implementation of these pForth primitives is specific to pForth. + +variable TRACE-LOCALS-PTR \ point to top of local frame + +\ create a return stack frame for NUM local variables +: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- } + trace-locals-ptr @ trace.>r + trace-rsp @ trace-locals-ptr ! + trace-rsp @ num cells - trace-rsp ! \ make room for locals + trace-rsp @ -> lp + num 0 + DO + lp ! + cell +-> lp \ move data into locals frame on return stack + LOOP +; + +: TRACE.(LOCAL.EXIT) ( -- ) + trace-locals-ptr @ trace-rsp ! + trace.r> trace-locals-ptr ! +; +: TRACE.(LOCAL@) ( l# -- n , fetch from local frame ) + trace-locals-ptr @ swap cells - @ +; +: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ; +: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ; +: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ; +: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ; +: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ; +: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ; +: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ; +: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ; + +: TRACE.(LOCAL!) ( n l# -- , store into local frame ) + trace-locals-ptr @ swap cells - ! +; +: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ; +: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ; +: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ; +: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ; +: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ; +: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ; +: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ; +: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ; + +: TRACE.(LOCAL+!) ( n l# -- , store into local frame ) + trace-locals-ptr @ swap cells - +! +; +: TRACE.(?DO) { limit start ip -- ip' } + limit start = + IF + ip @ +-> ip \ BRANCH + ELSE + start trace.>r + limit trace.>r + cell +-> ip + THEN + ip +; + +: TRACE.(LOOP) { ip | limit indx -- ip' } + trace.r> -> limit + trace.r> 1+ -> indx + limit indx = + IF + cell +-> ip + ELSE + indx trace.>r + limit trace.>r + ip @ +-> ip + THEN + ip +; + +: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' } + trace.r> -> limit + trace.r> -> oldindx + oldindx delta + -> indx +\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */ +\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) || +\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) ) + oldindx limit - limit 1- indx - AND $ 80000000 AND + indx limit - limit 1- oldindx - AND $ 80000000 AND OR + IF + cell +-> ip + ELSE + indx trace.>r + limit trace.>r + ip @ +-> ip + THEN + ip +; + +: TRACE.CHECK.IP { ip -- } + ip ['] first_colon u< + ip here u> OR + IF + ." TRACE - IP out of range = " ip .hex cr + abort + THEN +; + +: TRACE.SHOW.IP { ip -- , print name and offset } + ip code> >name dup id. + name> >code ip swap - ." +" . +; + +: TRACE.SHOW.STACK { | mdepth -- } + base @ >r + ." <" base @ decimal 1 .r ." :" + depth 1 .r ." > " + r> base ! + depth 5 min -> mdepth + depth mdepth - + IF + ." ... " \ if we don't show entire stack + THEN + mdepth 0 + ?DO + mdepth i 1+ - pick . \ show numbers in current base + LOOP +; + +: TRACE.SHOW.NEXT { ip -- } + >newline + ip trace.check.ip +\ show word name and offset + ." << " + ip trace.show.ip + 30 space.to.column +\ show data stack + trace.show.stack + 65 space.to.column ." ||" + trace_level 2* spaces + ip code@ + cell +-> ip +\ show primitive about to be executed + dup .xt space +\ trap any primitives that are followed by inline data + CASE + ['] (LITERAL) OF ip @ . ENDOF + ['] (ALITERAL) OF ip a@ . ENDOF +[ exists? (FLITERAL) [IF] ] + ['] (FLITERAL) OF ip f@ f. ENDOF +[ [THEN] ] + ['] BRANCH OF ip @ . ENDOF + ['] 0BRANCH OF ip @ . ENDOF + ['] (.") OF ip count type .' "' ENDOF + ['] (C") OF ip count type .' "' ENDOF + ['] (S") OF ip count type .' "' ENDOF + ENDCASE + 100 space.to.column ." >> " +; + +: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip } + xt + CASE + 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT + ['] (CREATE) OF ip cell- body_offset + ENDOF + ['] (LITERAL) OF ip @ cell +-> ip ENDOF + ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF +[ exists? (FLITERAL) [IF] ] + ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF +[ [THEN] ] + ['] BRANCH OF ip @ +-> ip ENDOF + ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF + ['] >R OF trace.>r ENDOF + ['] R> OF trace.r> ENDOF + ['] R@ OF trace.r@ ENDOF + ['] RDROP OF trace.rdrop ENDOF + ['] 2>R OF trace.>r trace.>r ENDOF + ['] 2R> OF trace.r> trace.r> ENDOF + ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF + ['] i OF 1 trace.rpick ENDOF + ['] j OF 3 trace.rpick ENDOF + ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF + ['] (LOOP) OF ip trace.(loop) -> ip ENDOF + ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF + ['] (DO) OF trace.>r trace.>r ENDOF + ['] (?DO) OF ip trace.(?do) -> ip ENDOF + ['] (.") OF ip count type ip count + aligned -> ip ENDOF + ['] (C") OF ip ip count + aligned -> ip ENDOF + ['] (S") OF ip count ip count + aligned -> ip ENDOF + ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF + ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF + ['] (LOCAL@) OF trace.(local@) ENDOF + ['] (1_LOCAL@) OF trace.(1_local@) ENDOF + ['] (2_LOCAL@) OF trace.(2_local@) ENDOF + ['] (3_LOCAL@) OF trace.(3_local@) ENDOF + ['] (4_LOCAL@) OF trace.(4_local@) ENDOF + ['] (5_LOCAL@) OF trace.(5_local@) ENDOF + ['] (6_LOCAL@) OF trace.(6_local@) ENDOF + ['] (7_LOCAL@) OF trace.(7_local@) ENDOF + ['] (8_LOCAL@) OF trace.(8_local@) ENDOF + ['] (LOCAL!) OF trace.(local!) ENDOF + ['] (1_LOCAL!) OF trace.(1_local!) ENDOF + ['] (2_LOCAL!) OF trace.(2_local!) ENDOF + ['] (3_LOCAL!) OF trace.(3_local!) ENDOF + ['] (4_LOCAL!) OF trace.(4_local!) ENDOF + ['] (5_LOCAL!) OF trace.(5_local!) ENDOF + ['] (6_LOCAL!) OF trace.(6_local!) ENDOF + ['] (7_LOCAL!) OF trace.(7_local!) ENDOF + ['] (8_LOCAL!) OF trace.(8_local!) ENDOF + ['] (LOCAL+!) OF trace.(local+!) ENDOF + >r xt EXECUTE r> + ENDCASE + ip +; + +: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip } + ip trace.check.ip +\ set context for word under test + trace.save.state1 + here -> oldhere + trace.restore.state2 + oldhere 256 + dp ! +\ get execution token + ip code@ -> xt + cell +-> ip +\ execute token + xt is.primitive? + IF \ primitive + ip xt trace.do.primitive -> ip + ELSE \ secondary + trace_level trace_level_max < + IF + ip trace.>r \ threaded execution + 1 +-> trace_level + xt codebase + -> ip + ELSE + \ treat it as a primitive + ip xt trace.do.primitive -> ip + THEN + THEN +\ restore original context + trace.rcheck + trace.save.state2 + trace.restore.state1 + oldhere dp ! + ip +; + +: TRACE.NEXT { ip | xt -- ip' } + trace_level 0> + IF + ip trace.do.next -> ip + THEN + trace_level 0> + IF + ip trace.show.next + ELSE + ." Finished." cr + THEN + ip +; + +}private + +: TRACE ( i*x -- i*x , setup trace environment ) + ' dup is.primitive? + IF + drop ." Sorry. You can't trace a primitive." cr + ELSE + 1 -> trace_level + trace_level -> trace_level_max + trace.0rp + >code -> trace_ip + trace_ip trace.show.next + trace-stack off + trace.save.state2 + THEN +; + +: s ( -- , step over ) + trace_level -> trace_level_max + trace_ip trace.next -> trace_ip +; + +: sd ( -- , step down ) + trace_level 1+ -> trace_level_max + trace_ip trace.next -> trace_ip +; + +: sm ( many -- , step many times ) + trace_level -> trace_level_max + 0 + ?DO + trace_ip trace.next -> trace_ip + LOOP +; + +defer trace.user ( IP -- stop? ) +' 0= is trace.user + +: gd { more_levels | stop_level -- } + here what's trace.user u< \ has it been forgotten? + IF + ." Resetting TRACE.USER !!!" cr + ['] 0= is trace.user + THEN + + more_levels 0< + more_levels 10 > + IF + ." GD level out of range (0-10), = " more_levels . cr + ELSE + trace_level more_levels + -> trace_level_max + trace_level 1- -> stop_level + BEGIN + trace_ip trace.user \ call deferred user word + dup \ leave flag for UNTIL + IF + ." TRACE.USER returned " dup . ." so stopping execution." cr + ELSE + trace_ip trace.next -> trace_ip + trace_level stop_level > not + THEN + UNTIL + THEN +; + +: g ( -- , execute until end of word ) + 0 gd +; + +: TRACE.HELP ( -- ) + ." TRACE ( i*x -- , setup trace for Forth word )" cr + ." S ( -- , step over )" cr + ." SM ( many -- , step over many times )" cr + ." SD ( -- , step down )" cr + ." G ( -- , go to end of word )" cr + ." GD ( n -- , go down N levels from current level," cr + ." stop at end of this level )" cr +; + +privatize + +1 [IF] +variable var1 +100 var1 ! +: FOO dup IF 1 + . THEN 77 var1 @ + . ; +: ZOO 29 foo 99 22 + . ; +: ROO 92 >r 1 r@ + . r> . ; +: MOO c" hello" count type + ." This is a message." cr + s" another message" type cr +; +: KOO 7 FOO ." DONE" ; +: TR.DO 4 0 DO i . LOOP ; +: TR.?DO 0 ?DO i . LOOP ; +: TR.LOC1 { aa bb } aa bb + . ; +: TR.LOC2 789 >r 4 5 tr.loc1 r> . ; + +[THEN] diff --git a/tut.fth b/tut.fth new file mode 100644 index 0000000..957ae34 --- /dev/null +++ b/tut.fth @@ -0,0 +1,70 @@ +anew task-tut.fth + +: SUM.OF.N.A ( N -- SUM[N] , calculate sum of N integers ) + 0 \ starting value of SUM + BEGIN + OVER 0> \ Is N greater than zero? + WHILE + OVER + \ add N to sum + SWAP 1- SWAP \ decrement N + REPEAT + SWAP DROP \ get rid on N + ; + +: SUM.OF.N.B ( N -- SUM[N] ) + 0 SWAP \ starting value of SUM + 1+ 0 \ set indices for DO LOOP + ?DO \ safer than DO if N=0 + I + + LOOP +; + +: SUM.OF.N.C ( N -- SUM[N] ) + 0 \ starting value of SUM + BEGIN ( -- N' SUM ) + OVER + + SWAP 1- SWAP + OVER 0< + UNTIL + SWAP DROP +; + +: SUM.OF.N.D ( N -- SUM[N] ) + >R \ put NUM on return stack + 0 \ starting value of SUM + BEGIN ( -- SUM ) + R@ + \ add num to sum + R> 1- DUP >R + 0< + UNTIL + RDROP \ get rid of NUM +; + +: SUM.OF.N.E { NUM | SUM -- SUM[N] , use return stack } + BEGIN + NUM +-> SUM \ add NUM to SUM + -1 +-> NUM \ decrement NUM + NUM 0< + UNTIL + SUM \ return SUM +; + +: SUM.OF.N.F ( NUM -- SUM[N] , Gauss' method ) + DUP 1+ * 2/ +; + + +: TTT + 10 0 + DO + I SUM.OF.N.A . + I SUM.OF.N.B . + I SUM.OF.N.C . + I SUM.OF.N.D . + I SUM.OF.N.E . + I SUM.OF.N.F . + CR + LOOP +; +TTT + diff --git a/utils/clone.fth b/utils/clone.fth new file mode 100644 index 0000000..377d363 --- /dev/null +++ b/utils/clone.fth @@ -0,0 +1,489 @@ +\ @(#) clone.fth 97/12/10 1.1 +\ Clone for PForth +\ +\ Create the smallest dictionary required to run an application. +\ +\ Clone decompiles the Forth dictionary starting with the top +\ word in the program. It then moves all referenced secondaries +\ into a new dictionary. +\ +\ This work was inspired by the CLONE feature that Mike Haas wrote +\ for JForth. Mike's CLONE disassembled 68000 machine code then +\ reassembled it which is much more difficult. +\ +\ Copyright Phil Burk & 3DO 1994 +\ +\ O- trap custom 'C' calls +\ O- investigate ALITERAL, XLITERAL, use XLITERAL in ['] + +anew task-clone.fth +decimal + +\ move to 'C' +: PRIMITIVE? ( xt -- flag , true if primitive ) + ['] FIRST_COLON < +; + +: 'SELF ( -- xt , return xt of word being compiled ) + ?comp + latest name> + [compile] literal +; immediate + + +:struct CL.REFERENCE + long clr_OriginalXT \ original XT of word + long clr_NewXT \ corresponding XT in cloned dictionary + long clr_TotalSize \ size including data in body +;struct + +variable CL-INITIAL-REFS \ initial number of refs to allocate +100 cl-initial-refs ! +variable CL-REF-LEVEL \ level of threading while scanning +variable CL-NUM-REFS \ number of secondaries referenced +variable CL-MAX-REFS \ max number of secondaries allocated +variable CL-LEVEL-MAX \ max level reached while scanning +variable CL-LEVEL-ABORT \ max level before aborting +10 cl-level-abort ! +variable CL-REFERENCES \ pointer to cl.reference array +variable CL-TRACE \ print debug stuff if true + +\ Cloned dictionary builds in allocated memory but XTs are relative +\ to normal code-base, if CL-TEST-MODE true. +variable CL-TEST-MODE + +variable CL-INITIAL-DICT \ initial size of dict to allocate +20 1024 * cl-initial-dict ! +variable CL-DICT-SIZE \ size of allocated cloned dictionary +variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary +variable CL-DICT-ALLOC \ pointer to allocated dictionary memory +variable CL-DICT-PTR \ rel pointer index into cloned dictionary +0 cl-dict-base ! + + +: CL.INDENT ( -- ) + cl-ref-level @ 2* 2* spaces +; +: CL.DUMP.NAME ( xt -- ) + cl.indent + >name id. cr +; + +: CL.DICT[] ( relptr -- addr ) + cl-dict-base @ + +; + +: CL, ( cell -- , comma into clone dictionary ) + cl-dict-ptr @ cl.dict[] ! + cell cl-dict-ptr +! +; + + +: CL.FREE.DICT ( -- , free dictionary we built into ) + cl-dict-alloc @ ?dup + IF + free dup ?error + 0 cl-dict-alloc ! + THEN +; + +: CL.FREE.REFS ( -- , free dictionary we built into ) + cl-references @ ?dup + IF + free dup ?error + 0 cl-references ! + THEN +; + +: CL.ALLOC.REFS ( -- , allocate references to track ) + cl-initial-refs @ \ initial number of references + dup cl-max-refs ! \ maximum allowed + sizeof() cl.reference * + allocate dup ?error + cl-references ! +; + +: CL.RESIZE.REFS ( -- , allocate references to track ) + cl-max-refs @ \ current number of references allocated + 5 * 4 / dup cl-max-refs ! \ new maximum allowed +\ cl.indent ." Resize # references to " dup . cr + sizeof() cl.reference * + cl-references @ swap resize dup ?error + cl-references ! +; + + +: CL.ALLOC.DICT ( -- , allocate dictionary to build into ) + cl-initial-dict @ \ initial dictionary size + dup cl-dict-size ! + allocate dup ?error + cl-dict-alloc ! +\ +\ kludge dictionary if testing + cl-test-mode @ + IF + cl-dict-alloc @ code-base @ - cl-dict-ptr +! + code-base @ cl-dict-base ! + ELSE + cl-dict-alloc @ cl-dict-base ! + THEN + ." CL.ALLOC.DICT" cr + ." cl-dict-alloc = $" cl-dict-alloc @ .hex cr + ." cl-dict-base = $" cl-dict-base @ .hex cr + ." cl-dict-ptr = $" cl-dict-ptr @ .hex cr +; + +: CODEADDR>DATASIZE { code-addr -- datasize } +\ Determine size of any literal data following execution token. +\ Examples are text following (."), or branch offsets. + code-addr @ + CASE + ['] (literal) OF cell ENDOF \ a number + ['] 0branch OF cell ENDOF \ branch offset + ['] branch OF cell ENDOF + ['] (do) OF 0 ENDOF + ['] (?do) OF cell ENDOF + ['] (loop) OF cell ENDOF + ['] (+loop) OF cell ENDOF + ['] (.") OF code-addr cell+ c@ 1+ ENDOF \ text + ['] (s") OF code-addr cell+ c@ 1+ ENDOF + ['] (c") OF code-addr cell+ c@ 1+ ENDOF + 0 swap + ENDCASE +; + +: XT>SIZE ( xt -- wordsize , including code and data ) + dup >code + swap >name + dup latest = + IF + drop here + ELSE + dup c@ 1+ + aligned 8 + \ get next name + name> >code \ where is next word + THEN + swap - +; + +\ ------------------------------------------------------------------ +: CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize -- } +\ scan secondary and pass each code-address to ca-process +\ CA-PROCESS ( code-addr -- , required stack action for vector ) + 1 cl-ref-level +! + cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL" + BEGIN + code-addr @ -> xt +\ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr + code-addr codeaddr>datasize -> dsize \ any data after this? + code-addr ca-process execute \ process it + code-addr cell+ dsize + aligned -> code-addr \ skip past data +\ !!! Bummer! EXIT called in middle of secondary will cause early stop. + xt ['] EXIT = \ stop when we get to EXIT + UNTIL + -1 cl-ref-level +! +; + +\ ------------------------------------------------------------------ + +: CL.DUMP.XT ( xt -- ) + cl-trace @ + IF + dup primitive? + IF ." PRI: " + ELSE ." SEC: " + THEN + cl.dump.name + ELSE + drop + THEN +; + +\ ------------------------------------------------------------------ +: CL.REF[] ( index -- clref ) + sizeof() cl.reference * + cl-references @ + +; + +: CL.DUMP.REFS ( -- , print references ) + cl-num-refs @ 0 + DO + i 3 .r ." : " + i cl.ref[] + dup s@ clr_OriginalXT >name id. ." => " + dup s@ clr_NewXT . + ." , size = " + dup s@ clr_TotalSize . cr + drop \ clref + loop +; + +: CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found } + BEGIN +\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr + indx cl-num-refs @ >= + IF + true + ELSE + indx cl.ref[] s@ clr_OriginalXT +\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr + xt = + IF + true + dup -> flag + ELSE + false + indx 1+ -> indx + THEN + THEN + UNTIL + indx flag +\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr +; + +: CL.ADD.REF { xt | clref -- , add referenced secondary to list } + cl-references @ 0= abort" CL.ADD.REF - References not allocated!" +\ +\ do we need to allocate more room? + cl-num-refs @ cl-max-refs @ >= + IF + cl.resize.refs + THEN +\ + cl-num-refs @ cl.ref[] -> clref \ index into array + xt clref s! clr_OriginalXT + 0 clref s! clr_NewXT + xt xt>size clref s! clr_TotalSize +\ + 1 cl-num-refs +! +; + +\ ------------------------------------------------------------------ + +\ called by cl.traverse.secondary to compile each piece of secondary +: CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- , } +\ recompile to new location +\ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr + code-addr @ -> xt +\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr + xt cl.dump.xt + xt primitive? + IF + xt cl, + ELSE + xt CL.XT>REF_INDEX + IF + cl.ref[] -> clref + clref s@ clr_NewXT + dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT" + cl, + ELSE + cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr + abort + THEN + THEN +\ +\ transfer any literal data + code-addr codeaddr>datasize -> dsize + dsize 0> + IF +\ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr + code-addr cell+ cl-dict-ptr @ cl.dict[] dsize move + cl-dict-ptr @ dsize + aligned cl-dict-ptr ! + THEN +\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr +; + +: CL.RECOMPILE.REF { indx | clref codesize datasize -- } +\ all references have been resolved so recompile new secondary + depth >r + indx cl.ref[] -> clref + cl-trace @ + IF + cl.indent + clref s@ clr_OriginalXT >name id. ." recompiled at $" + cl-dict-ptr @ .hex cr \ new address + THEN + cl-dict-ptr @ clref s! clr_NewXT +\ +\ traverse this secondary and compile into new dictionary + clref s@ clr_OriginalXT + >code ['] cl.recompile.secondary cl.traverse.secondary +\ +\ determine whether there is any data following definition + cl-dict-ptr @ + clref s@ clr_NewXT - -> codesize \ size of cloned code + clref s@ clr_TotalSize \ total bytes + codesize - -> datasize + cl-trace @ + IF + cl.indent + ." Move data: data size = " datasize . ." codesize = " codesize . cr + THEN +\ +\ copy any data that followed definition + datasize 0> + IF + clref s@ clr_OriginalXT >code codesize + + clref s@ clr_NewXT cl-dict-base @ + codesize + + datasize move + datasize cl-dict-ptr +! \ allot space in clone dictionary + THEN + + depth r> - abort" Stack depth change in CL.RECOMPILE.REF" +; + +\ ------------------------------------------------------------------ +: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list ) + depth 1- >r +\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr + cl-ref-level @ cl-level-max @ MAX cl-level-max ! + @ ( get xt ) +\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr + dup cl.dump.xt + dup primitive? + IF + drop +\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr + ELSE + dup CL.XT>REF_INDEX + IF + drop \ indx \ already referenced once so ignore + drop \ xt + ELSE + >r \ indx + dup cl.add.ref + >code 'self cl.traverse.secondary \ use 'self for recursion! + r> cl.recompile.ref \ now that all refs resolved, recompile + THEN + THEN +\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr + depth r> - abort" Stack depth change in CL.SCAN.SECONDARY" +; + +: CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list ) + dup primitive? abort" Cannot CLONE a PRIMITIVE word!" + 0 cl-ref-level ! + 0 cl-level-max ! + 0 cl-num-refs ! + dup cl.add.ref \ word being cloned is top of ref list + >code ['] cl.scan.secondary cl.traverse.secondary + 0 cl.recompile.ref +; + +\ ------------------------------------------------------------------ +: CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict ) + cl.xt>ref_index 0= abort" not in cloned dictionary!" + cl.ref[] s@ clr_NewXT +; +: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict ) + cl.xt>New_XT + cl-dict-base @ + +; + +: CL.REPORT ( -- ) + ." Clone scan went " cl-level-max @ . ." levels deep." cr + ." Clone scanned " cl-num-refs @ . ." secondaries." cr + ." New dictionary size = " cl-dict-ptr @ cl-dict-base @ - . cr +; + + +\ ------------------------------------------------------------------ +: CL.TERM ( -- , cleanup ) + cl.free.refs + cl.free.dict +; + +: CL.INIT ( -- ) + cl.term + 0 cl-dict-size ! + ['] first_colon cl-dict-ptr ! + cl.alloc.dict + cl.alloc.refs +; + +: 'CLONE ( xt -- , clone dictionary from this word ) + cl.init + cl.clone.xt + cl.report + cl.dump.refs + cl-test-mode @ + IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr + THEN +; + +: SAVE-CLONE ( -- ) + bl word + ." Save cloned image in " dup count type + drop ." SAVE-CLONE unimplemented!" \ %Q +; + +: CLONE ( -- ) + ' 'clone +; + +if.forgotten cl.term + +\ ---------------------------------- TESTS -------------------- + + +: TEST.CLONE ( -- ) + cl-test-mode @ not abort" CL-TEST-MODE not on!" + 0 cl.ref[] s@ clr_NewXT execute +; + + +: TEST.CLONE.REAL ( -- ) + cl-test-mode @ abort" CL-TEST-MODE on!" + code-base @ + 0 cl.ref[] s@ clr_NewXT \ get cloned execution token + cl-dict-base @ code-base ! +\ WARNING - code-base munged, only execute primitives or cloned code + execute + code-base ! \ restore code base for normal +; + + +: TCL1 + 34 dup + +; + +: TCL2 + ." Hello " tcl1 . cr +; + +: TCL3 + 4 0 + DO + tcl2 + i . cr + i 100 + . cr + LOOP +; + +create VAR1 567 , +: TCL4 + 345 var1 ! + ." VAR1 = " var1 @ . cr + var1 @ 345 - + IF + ." TCL4 failed!" cr + ELSE + ." TCL4 succeded! Yay!" cr + THEN +; + +\ do deferred words get cloned! +defer tcl.vector + +: TCL.DOIT ." Hello Fred!" cr ; +' tcl.doit is tcl.vector + +: TCL.DEFER + 12 . cr + tcl.vector + 999 dup + . cr +; + +trace-stack on +cl-test-mode on + diff --git a/utils/dump_struct.fth b/utils/dump_struct.fth new file mode 100644 index 0000000..58c051f --- /dev/null +++ b/utils/dump_struct.fth @@ -0,0 +1,120 @@ +\ @(#) dump_struct.fth 97/12/10 1.1 +\ Dump contents of structure showing values and member names. +\ +\ Author: Phil Burk +\ Copyright 1987 Phil Burk +\ All Rights Reserved. +\ +\ MOD: PLB 9/4/88 Print size too. +\ MOD: PLB 9/9/88 Print U/S , add ADST +\ MOD: PLB 12/6/90 Modified to work with H4th +\ 941109 PLB Converted to pforth. Added RP detection. + +include? task-member member.fth +include? task-c_struct c_struct.fth + +ANEW TASK-DUMP_STRUCT + +: EMIT-TO-COLUMN ( char col -- ) + out @ - 0 max 80 min 0 + DO dup emit + LOOP drop +; + +VARIABLE SN-FENCE +: STACK.NFAS ( fencenfa topnfa -- 0 nfa0 nfa1 ... ) +\ Fill stack with nfas of words until fence hit. + >r sn-fence ! + 0 r> ( set terminator ) + BEGIN ( -- 0 n0 n1 ... top ) + dup sn-fence @ > + WHILE +\ dup n>link @ \ JForth + dup prevname \ HForth + REPEAT + drop +; + +: DST.DUMP.TYPE ( +-size -- , dump data type, 941109) + dup abs 4 = + IF + 0< + IF ." RP" + ELSE ." U4" + THEN + ELSE + dup 0< + IF ascii U + ELSE ascii S + THEN emit abs 1 .r + THEN +; + +: DUMP.MEMBER ( addr member-pfa -- , dump member of structure) + ob.stats ( -- addr offset size ) + >r + r> ( -- addr' size ) + dup ABS 4 > ( -- addr' size flag ) + IF cr 2dup swap . . ABS dump + ELSE tuck @bytes 10 .r ( -- size ) + 3 spaces dst.dump.type + THEN +; + +VARIABLE DS-ADDR +: DUMP.STRUCT ( addr-data addr-structure -- ) + >newline swap >r ( -- as , save addr-data for dumping ) +\ dup cell+ @ over + \ JForth + dup code> >name swap cell+ @ over + \ HForth + stack.nfas ( fill stack with nfas of members ) + BEGIN + dup + WHILE ( continue until non-zero ) + dup name> >body r@ swap dump.member + bl 18 emit-to-column id. cr + ?pause + REPEAT drop rdrop +; + +: DST ( addr -- , dump contents of structure ) + ob.findit + state @ + IF [compile] literal compile dump.struct + ELSE dump.struct + THEN +; immediate + +: ADST ( absolute_address -- , dump structure ) + >rel [compile] dst +; immediate + +\ For Testing Purposes +false .IF +:STRUCT GOO + LONG DATAPTR + SHORT GOO_WIDTH + USHORT GOO_HEIGHT +;STRUCT + +:STRUCT FOO + LONG ALONG1 + STRUCT GOO AGOO + SHORT ASHORT1 + BYTE ABYTE + BYTE ABYTE2 +;STRUCT + +FOO AFOO +: AFOO.INIT + $ 12345678 afoo ..! along1 + $ -665 afoo ..! ashort1 + $ 21 afoo ..! abyte + $ 43 afoo ..! abyte2 + -234 afoo .. agoo ..! goo_height +; +afoo.init + +: TDS ( afoo -- ) + dst foo +; + +.THEN diff --git a/utils/load_file.fth b/utils/load_file.fth new file mode 100644 index 0000000..71f5e56 --- /dev/null +++ b/utils/load_file.fth @@ -0,0 +1,39 @@ +\ Load a file into an allocated memory image. +\ +\ Author: Phil Burk +\ Copyright 3DO 1995 + +anew task-load_file.fth + +: $LOAD.FILE { $filename | fid numbytes numread err data -- data-addr 0 | 0 err } + 0 -> data +\ open file + $filename count r/o open-file -> err -> fid + err + IF + ." $LOAD.FILE - Could not open input file!" cr + ELSE +\ determine size of file + fid file-size -> err -> numbytes + err + IF + ." $LOAD.FILE - File size failed!" cr + ELSE + ." File size = " numbytes . cr +\ allocate memory for sample, when done free memory using FREE + numbytes allocate -> err -> data + err + IF + ." $LOAD.FILE - Memory allocation failed!" cr + ELSE +\ read data + data numbytes fid read-file -> err + ." Read " . ." bytes from file " $filename count type cr + THEN + THEN + fid close-file drop + THEN + data err +; + +\ Example: c" myfile" $load.file abort" Oops!" free . diff --git a/utils/make_all256.fth b/utils/make_all256.fth new file mode 100644 index 0000000..87f2a75 --- /dev/null +++ b/utils/make_all256.fth @@ -0,0 +1,57 @@ +\ @(#) make_all256.fth 97/12/10 1.1 +\ Make a file with all possible 256 bytes in random order. +\ +\ Author: Phil Burk +\ Copyright 1987 Phil Burk +\ All Rights Reserved. + +ANEW TASK-MAKE_ALL256 + +variable RAND8-SEED +19 rand8-seed ! +: RANDOM8 ( -- r8 , generate random bytes, repeat every 256 ) + RAND8-SEED @ + 77 * 55 + + $ FF and + dup RAND8-SEED ! +; + +create rand8-pad 256 allot +: make.256.data + 256 0 + DO + random8 rand8-pad i + c! + LOOP +; + +: SHUFFLE.DATA { num | ind1 ind2 -- } + num 0 + DO + 256 choose -> ind1 + 256 choose -> ind2 + ind1 rand8-pad + c@ + ind2 rand8-pad + c@ + ind1 rand8-pad + c! + ind2 rand8-pad + c! + LOOP +; + +: WRITE.256.FILE { | fid -- } + p" all256.raw" count r/w create-file + IF + drop ." Could not create file." cr + ELSE + -> fid + fid . cr + rand8-pad 256 fid write-file abort" write failed!" + fid close-file drop + THEN +; + +: MAKE.256.FILE + make.256.data + 1000 shuffle.data + write.256.file +; + +MAKE.256.FILE diff --git a/utils/savedicd.fth b/utils/savedicd.fth new file mode 100644 index 0000000..482ec72 --- /dev/null +++ b/utils/savedicd.fth @@ -0,0 +1,170 @@ +\ @(#) savedicd.fth 98/01/26 1.2 +\ Save dictionary as data table. +\ +\ Author: Phil Burk +\ Copyright 1987 Phil Burk +\ All Rights Reserved. +\ +\ 970311 PLB Fixed problem with calling SDAD when in HEX mode. + +decimal +ANEW TASK-SAVE_DIC_AS_DATA + +\ !!! set to 4 for minimally sized dictionary to prevent DIAB +\ compiler from crashing! Allocate more space in pForth. +4 constant SDAD_NAMES_EXTRA \ space for additional names +4 constant SDAD_CODE_EXTRA \ space for additional names + +\ buffer the file I/O for better performance +256 constant SDAD_BUFFER_SIZE +create SDAD-BUFFER SDAD_BUFFER_SIZE allot +variable SDAD-BUFFER-INDEX +variable SDAD-BUFFER-FID + 0 SDAD-BUFFER-FID ! + +: SDAD.FLUSH ( -- ior ) + sdad-buffer sdad-buffer-index @ \ data +\ 2dup type + sdad-buffer-fid @ write-file + 0 sdad-buffer-index ! +; + +: SDAD.EMIT ( char -- ) + sdad-buffer-index @ sdad_buffer_size >= + IF + sdad.flush abort" SDAD.FLUSH failed!" + THEN +\ + sdad-buffer sdad-buffer-index @ + c! + 1 sdad-buffer-index +! +; + +: SDAD.TYPE ( c-addr cnt -- ) + 0 DO + dup c@ sdad.emit \ char to buffer + 1+ \ advance char pointer + LOOP + drop +; + +: $SDAD.LINE ( $addr -- ) + count sdad.type + EOL sdad.emit +; + +: (U8.) ( u -- a l , unsigned conversion, at least 8 digits ) + 0 <# # # # # # # # #S #> +; +: (U2.) ( u -- a l , unsigned conversion, at least 2 digits ) + 0 <# # #S #> +; + +: SDAD.CLOSE ( -- ) + SDAD-BUFFER-FID @ ?dup + IF + sdad.flush abort" SDAD.FLUSH failed!" + close-file drop + 0 SDAD-BUFFER-FID ! + THEN +; + +: SDAD.OPEN ( -- ior, open file ) + sdad.close + s" pfdicdat.h" r/w create-file dup >r + IF + drop ." Could not create file pfdicdat.h" cr + ELSE + SDAD-BUFFER-FID ! + THEN + r> +; + +: SDAD.DUMP.HEX { val -- } + base @ >r hex + s" 0x" sdad.type + val (u8.) sdad.type + r> base ! +; +: SDAD.DUMP.HEX, + s" " sdad.type + sdad.dump.hex + ascii , sdad.emit +; + +: SDAD.DUMP.HEX.BYTE { val -- } + base @ >r hex + s" 0x" sdad.type + val (u2.) sdad.type + r> base ! +; +: SDAD.DUMP.HEX.BYTE, + sdad.dump.hex.byte + ascii , sdad.emit +; + +: SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- } + end-address start-address - -> num-bytes + num-bytes 0 + ?DO + i $ 7FF and 0= IF ." 0x" i .hex cr THEN \ progress report + i 15 and 0= + IF + + EOL sdad.emit + s" /* " sdad.type + i sdad.dump.hex + s" : */ " sdad.type + THEN \ 16 bytes per line, print offset + start-address i + c@ + sdad.dump.hex.byte, + LOOP +\ + num-zeros 0 + ?DO + i $ 7FF and 0= IF i . cr THEN \ progress report + i 15 and 0= IF EOL sdad.emit THEN \ 15 numbers per line + 0 sdad.dump.hex.byte, + LOOP +; + +: SDAD.DEFINE { $name val -- } + s" #define " sdad.type + $name count sdad.type + s" (" sdad.type + val sdad.dump.hex + c" )" $sdad.line +; + +: IS.LITTLE.ENDIAN? ( -- flag , is Forth in Little Endian mode? ) + 1 pad ! + pad c@ +; + +: SDAD { | fid -- } + sdad.open abort" sdad.open failed!" +\ Write headers. + c" /* This file generated by the Forth command SAVE-DIC-AS-DATA */" $sdad.line + + c" HEADERPTR" headers-ptr @ namebase - sdad.define + c" RELCONTEXT" context @ namebase - sdad.define + c" CODEPTR" here codebase - sdad.define + c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define + +." Saving Names" cr + s" static const uint8 MinDicNames[] = {" sdad.type + namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data + EOL sdad.emit + c" };" $sdad.line + +." Saving Code" cr + s" static const uint8 MinDicCode[] = {" sdad.type + codebase here SDAD_CODE_EXTRA sdad.dump.data + EOL sdad.emit + c" };" $sdad.line + + sdad.close +; + +if.forgotten sdad.close + +." Enter: SDAD" cr diff --git a/utils/trace.fth b/utils/trace.fth new file mode 100644 index 0000000..e2b948d --- /dev/null +++ b/utils/trace.fth @@ -0,0 +1,438 @@ +\ @(#) trace.fth 98/01/08 1.1 +\ TRACE ( -- , trace pForth word ) +\ +\ Single step debugger. +\ TRACE ( i*x -- , setup trace for Forth word ) +\ S ( -- , step over ) +\ SM ( many -- , step over many times ) +\ SD ( -- , step down ) +\ G ( -- , go to end of word ) +\ GD ( n -- , go down N levels from current level, stop at end of this level ) +\ +\ This debugger works by emulating the inner interpreter of pForth. +\ It executes code and maintains a separate return stack for the +\ program under test. Thus all primitives that operate on the return +\ stack, such as DO and R> must be trapped. Local variables must +\ also be handled specially. Several state variables are also +\ saved and restored to establish the context for the program being +\ tested. +\ +\ Copyright 1997 Phil Burk + +anew task-trace.fth + +: SPACE.TO.COLUMN ( col -- ) + out @ - spaces +; + +: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive ) + ['] first_colon < +; + +0 value TRACE_IP \ instruction pointer +0 value TRACE_LEVEL \ level of descent for inner interpreter +0 value TRACE_LEVEL_MAX \ maximum level of descent + +private{ + +\ use fake return stack +128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes +create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot +variable TRACE-RSP +: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n +: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++ +: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp +: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index] +: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ; +: TRACE.RDROP ( -- ) cell trace-rsp +! ; +: TRACE.RCHECK ( -- , abort if return stack out of range ) + trace-rsp @ trace-return-stack u< + abort" TRACE return stack OVERFLOW!" + trace-rsp @ trace-return-stack trace_return_size + 12 + u> + abort" TRACE return stack UNDERFLOW!" +; + +\ save and restore several state variables +10 cells constant TRACE_STATE_SIZE +create TRACE-STATE-1 TRACE_STATE_SIZE allot +create TRACE-STATE-2 TRACE_STATE_SIZE allot + +variable TRACE-STATE-PTR +: TRACE.SAVE++ ( addr -- , save next thing ) + @ trace-state-ptr @ ! + cell trace-state-ptr +! +; + +: TRACE.SAVE.STATE ( -- ) + state trace.save++ + hld trace.save++ + base trace.save++ +; + +: TRACE.SAVE.STATE1 ( -- , save normal state ) + trace-state-1 trace-state-ptr ! + trace.save.state +; +: TRACE.SAVE.STATE2 ( -- , save state of word being debugged ) + trace-state-2 trace-state-ptr ! + trace.save.state +; + + +: TRACE.RESTORE++ ( addr -- , restore next thing ) + trace-state-ptr @ @ swap ! + cell trace-state-ptr +! +; + +: TRACE.RESTORE.STATE ( -- ) + state trace.restore++ + hld trace.restore++ + base trace.restore++ +; + +: TRACE.RESTORE.STATE1 ( -- ) + trace-state-1 trace-state-ptr ! + trace.restore.state +; +: TRACE.RESTORE.STATE2 ( -- ) + trace-state-2 trace-state-ptr ! + trace.restore.state +; + +\ The implementation of these pForth primitives is specific to pForth. + +variable TRACE-LOCALS-PTR \ point to top of local frame + +\ create a return stack frame for NUM local variables +: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- } + trace-locals-ptr @ trace.>r + trace-rsp @ trace-locals-ptr ! + trace-rsp @ num cells - trace-rsp ! \ make room for locals + trace-rsp @ -> lp + num 0 + DO + lp ! + cell +-> lp \ move data into locals frame on return stack + LOOP +; + +: TRACE.(LOCAL.EXIT) ( -- ) + trace-locals-ptr @ trace-rsp ! + trace.r> trace-locals-ptr ! +; +: TRACE.(LOCAL@) ( l# -- n , fetch from local frame ) + trace-locals-ptr @ swap cells - @ +; +: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ; +: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ; +: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ; +: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ; +: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ; +: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ; +: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ; +: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ; + +: TRACE.(LOCAL!) ( n l# -- , store into local frame ) + trace-locals-ptr @ swap cells - ! +; +: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ; +: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ; +: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ; +: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ; +: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ; +: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ; +: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ; +: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ; + +: TRACE.(LOCAL+!) ( n l# -- , store into local frame ) + trace-locals-ptr @ swap cells - +! +; +: TRACE.(?DO) { limit start ip -- ip' } + limit start = + IF + ip @ +-> ip \ BRANCH + ELSE + start trace.>r + limit trace.>r + cell +-> ip + THEN + ip +; + +: TRACE.(LOOP) { ip | limit indx -- ip' } + trace.r> -> limit + trace.r> 1+ -> indx + limit indx = + IF + cell +-> ip + ELSE + indx trace.>r + limit trace.>r + ip @ +-> ip + THEN + ip +; + +: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' } + trace.r> -> limit + trace.r> -> oldindx + oldindx delta + -> indx +\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */ +\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) || +\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) ) + oldindx limit - limit 1- indx - AND $ 80000000 AND + indx limit - limit 1- oldindx - AND $ 80000000 AND OR + IF + cell +-> ip + ELSE + indx trace.>r + limit trace.>r + ip @ +-> ip + THEN + ip +; + +: TRACE.CHECK.IP { ip -- } + ip ['] first_colon u< + ip here u> OR + IF + ." TRACE - IP out of range = " ip .hex cr + abort + THEN +; + +: TRACE.SHOW.IP { ip -- , print name and offset } + ip code> >name dup id. + name> >code ip swap - ." +" . +; + +: TRACE.SHOW.STACK { | mdepth -- } + base @ >r + ." <" base @ decimal 1 .r ." :" + depth 1 .r ." > " + r> base ! + depth 5 min -> mdepth + depth mdepth - + IF + ." ... " \ if we don't show entire stack + THEN + mdepth 0 + ?DO + mdepth i 1+ - pick . \ show numbers in current base + LOOP +; + +: TRACE.SHOW.NEXT { ip -- } + >newline + ip trace.check.ip +\ show word name and offset + ." << " + ip trace.show.ip + 30 space.to.column +\ show data stack + trace.show.stack + 65 space.to.column ." ||" + trace_level 2* spaces + ip code@ + cell +-> ip +\ show primitive about to be executed + dup .xt space +\ trap any primitives that are followed by inline data + CASE + ['] (LITERAL) OF ip @ . ENDOF + ['] (ALITERAL) OF ip a@ . ENDOF +[ exists? (FLITERAL) [IF] ] + ['] (FLITERAL) OF ip f@ f. ENDOF +[ [THEN] ] + ['] BRANCH OF ip @ . ENDOF + ['] 0BRANCH OF ip @ . ENDOF + ['] (.") OF ip count type .' "' ENDOF + ['] (C") OF ip count type .' "' ENDOF + ['] (S") OF ip count type .' "' ENDOF + ENDCASE + 100 space.to.column ." >> " +; + +: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip } + xt + CASE + 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT + ['] (CREATE) OF ip cell- body_offset + ENDOF + ['] (LITERAL) OF ip @ cell +-> ip ENDOF + ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF +[ exists? (FLITERAL) [IF] ] + ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF +[ [THEN] ] + ['] BRANCH OF ip @ +-> ip ENDOF + ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF + ['] >R OF trace.>r ENDOF + ['] R> OF trace.r> ENDOF + ['] R@ OF trace.r@ ENDOF + ['] RDROP OF trace.rdrop ENDOF + ['] 2>R OF trace.>r trace.>r ENDOF + ['] 2R> OF trace.r> trace.r> ENDOF + ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF + ['] i OF 1 trace.rpick ENDOF + ['] j OF 3 trace.rpick ENDOF + ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF + ['] (LOOP) OF ip trace.(loop) -> ip ENDOF + ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF + ['] (DO) OF trace.>r trace.>r ENDOF + ['] (?DO) OF ip trace.(?do) -> ip ENDOF + ['] (.") OF ip count type ip count + aligned -> ip ENDOF + ['] (C") OF ip ip count + aligned -> ip ENDOF + ['] (S") OF ip count ip count + aligned -> ip ENDOF + ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF + ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF + ['] (LOCAL@) OF trace.(local@) ENDOF + ['] (1_LOCAL@) OF trace.(1_local@) ENDOF + ['] (2_LOCAL@) OF trace.(2_local@) ENDOF + ['] (3_LOCAL@) OF trace.(3_local@) ENDOF + ['] (4_LOCAL@) OF trace.(4_local@) ENDOF + ['] (5_LOCAL@) OF trace.(5_local@) ENDOF + ['] (6_LOCAL@) OF trace.(6_local@) ENDOF + ['] (7_LOCAL@) OF trace.(7_local@) ENDOF + ['] (8_LOCAL@) OF trace.(8_local@) ENDOF + ['] (LOCAL!) OF trace.(local!) ENDOF + ['] (1_LOCAL!) OF trace.(1_local!) ENDOF + ['] (2_LOCAL!) OF trace.(2_local!) ENDOF + ['] (3_LOCAL!) OF trace.(3_local!) ENDOF + ['] (4_LOCAL!) OF trace.(4_local!) ENDOF + ['] (5_LOCAL!) OF trace.(5_local!) ENDOF + ['] (6_LOCAL!) OF trace.(6_local!) ENDOF + ['] (7_LOCAL!) OF trace.(7_local!) ENDOF + ['] (8_LOCAL!) OF trace.(8_local!) ENDOF + ['] (LOCAL+!) OF trace.(local+!) ENDOF + >r xt EXECUTE r> + ENDCASE + ip +; + +: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip } + ip trace.check.ip +\ set context for word under test + trace.save.state1 + here -> oldhere + trace.restore.state2 + oldhere 256 + dp ! +\ get execution token + ip code@ -> xt + cell +-> ip +\ execute token + xt is.primitive? + IF \ primitive + ip xt trace.do.primitive -> ip + ELSE \ secondary + trace_level trace_level_max < + IF + ip trace.>r \ threaded execution + 1 +-> trace_level + xt codebase + -> ip + ELSE + \ treat it as a primitive + ip xt trace.do.primitive -> ip + THEN + THEN +\ restore original context + trace.rcheck + trace.save.state2 + trace.restore.state1 + oldhere dp ! + ip +; + +: TRACE.NEXT { ip | xt -- ip' } + trace_level 0> + IF + ip trace.do.next -> ip + THEN + trace_level 0> + IF + ip trace.show.next + ELSE + ." Finished." cr + THEN + ip +; + +}private + +: TRACE ( i*x -- i*x , setup trace environment ) + ' dup is.primitive? + IF + drop ." Sorry. You can't trace a primitive." cr + ELSE + 1 -> trace_level + trace_level -> trace_level_max + trace.0rp + >code -> trace_ip + trace_ip trace.show.next + trace-stack off + trace.save.state2 + THEN +; + +: s ( -- , step over ) + trace_level -> trace_level_max + trace_ip trace.next -> trace_ip +; + +: sd ( -- , step down ) + trace_level 1+ -> trace_level_max + trace_ip trace.next -> trace_ip +; + +: sm ( many -- , step down ) + trace_level -> trace_level_max + 0 + ?DO + trace_ip trace.next -> trace_ip + LOOP +; + +: gd { more_levels | stop_level -- } + depth 1 < + IF + ." GD requires a MORE_LEVELS parameter." cr + ELSE + trace_level more_levels + -> trace_level_max + trace_level 1- -> stop_level + BEGIN + trace_ip trace.next -> trace_ip + trace_level stop_level > not + UNTIL + THEN +; + +: g ( -- , execute until end of word ) + 0 gd +; + +: TRACE.HELP ( -- ) + ." TRACE ( i*x -- , setup trace for Forth word )" cr + ." S ( -- , step over )" cr + ." SM ( many -- , step over many times )" cr + ." SD ( -- , step down )" cr + ." G ( -- , go to end of word )" cr + ." GD ( n -- , go down N levels from current level," cr + ." stop at end of this level )" cr +; + +privatize + +0 [IF] +variable var1 +100 var1 ! +: FOO dup IF 1 + . THEN 77 var1 @ + . ; +: ZOO 29 foo 99 22 + . ; +: ROO 92 >r 1 r@ + . r> . ; +: MOO c" hello" count type + ." This is a message." cr + s" another message" type cr +; +: KOO 7 FOO ." DONE" ; +: TR.DO 4 0 DO i . LOOP ; +: TR.?DO 0 ?DO i . LOOP ; +: TR.LOC1 { aa bb } aa bb + . ; +: TR.LOC2 789 >r 4 5 tr.loc1 r> . ; +[THEN] diff --git a/wordslik.fth b/wordslik.fth new file mode 100644 index 0000000..adaa74f --- /dev/null +++ b/wordslik.fth @@ -0,0 +1,44 @@ +\ @(#) wordslik.fth 98/01/26 1.2 +\ +\ WORDS.LIKE ( -- , search for words that contain string ) +\ +\ Enter: WORDS.LIKE + +\ Enter: WORDS.LIKE EMIT +\ +\ Author: Phil Burk +\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom +\ +\ The pForth software code is dedicated to the public domain, +\ and any third party may reproduce, distribute and modify +\ the pForth software code or any derivative works thereof +\ without any compensation or license. The pForth software +\ code is provided on an "as is" basis without any warranty +\ of any kind, including, without limitation, the implied +\ warranties of merchantability and fitness for a particular +\ purpose and their equivalents under the laws of any jurisdiction. + +anew task-wordslik.fth +decimal + + +: PARTIAL.MATCH.NAME ( $str1 nfa -- flag , is $str1 in nfa ??? ) + count $ 1F and + rot count + search + >r 2drop r> +; + +: WORDS.LIKE ( -- , print all words containing substring ) + BL word latest + >newline + BEGIN + prevname dup 0<> \ get previous name in dictionary + WHILE + 2dup partial.match.name + IF + dup id. tab + cr? + THEN + REPEAT 2drop + >newline +;