sambuc/retrobsd
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Import from SVN

Browse Source
This commit is contained in:
Matt Jenkins
2014-04-09 14:27:18 +01:00
parent 8976e834c4
commit 895f96d2f7
3153 changed files with 748589 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/cmd/pforth/..bin
BIN
View File
Binary file not shown.
src/cmd/pforth/Makefile
+50
View File
@@ -0,0 +1,50 @@
# makefile for pForth
# Portable Forth written in 'C'
# by Phil Burk
# For more info visit http://www.softsynth.com/pforth/
#
# Use 'make all' to build standalone pForth executable.
# PForth can be built in several stages using these targets:
# - pfdicapp = executable pForth with minimal dictionary. All from 'C'.
# - pfdicdat = image of full dictionary build by compiling Forth code.
# - pforthapp = executable with embedded dictionary image. DEFAULT 'all' target.
#
# The file 'pfdicdat.h' is generated by pForth. It contains a binary image of the Forth dictionary.
# It allows pForth to work as a standalone image that does not need to load a dictionary file.
TOPSRC = $(shell cd ../..; pwd)
include $(TOPSRC)/target.mk
#include $(TOPSRC)/cross.mk
# Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG
# See "docs/pf_ref.htm" file for more info.
CFLAGS += -Wall -Os
#CFLAGS += -DPF_SUPPORT_FP
CFLAGS += -DPF_STATIC_DIC
LIBS += -lm
OBJS = pf_cglue.o pf_clib.o pf_core.o pf_inner.o \
pf_io.o pf_io_none.o pf_main.o pf_mem.o pf_save.o \
pf_text.o pf_words.o pfcompil.o pfcustom.o
#OBJS += pf_io_posix.o
OBJS += pf_io_stdio.o
all: ../pforth ../../lib/pforth.dic
../pforth: ${OBJS}
${CC} ${LDFLAGS} -o pforth.elf ${OBJS} ${LIBS}
${OBJDUMP} -S pforth.elf > pforth.dis
${SIZE} pforth.elf
${ELF2AOUT} pforth.elf $@
pfdicdat.h pforth.dic:
(cd fth; ../pforth.elf -i system.fth)
mv fth/pforth.dic pforth.dic
mv fth/pfdicdat.h $@
../../lib/pforth.dic: pforth.dic
cp -p $< $@
clean:
rm -f *.o ${MAN} ../id ../groups ../whoami *.elf *.dis tags *~
src/cmd/pforth/Makefile-orig
+110
View File
@@ -0,0 +1,110 @@
# makefile for pForth
# Portable Forth written in 'C'
# by Phil Burk
# For more info visit http://www.softsynth.com/pforth/
#
# See "help" target below.
.POSIX:
# Options include: PF_SUPPORT_FP PF_NO_MALLOC PF_NO_INIT PF_DEBUG
# See "docs/pf_ref.htm" file for more info.
TOPSRC = $(shell cd ../..; pwd)
include $(TOPSRC)/target.mk
FULL_WARNINGS = \
# -c89 \
-fsigned-char \
-fno-builtin \
-fno-unroll-loops \
-fpeephole \
-fno-keep-inline-functions \
-pedantic \
-Wcast-qual \
-Wall \
-Wwrite-strings \
-Winline \
-Wmissing-prototypes \
-Wmissing-declarations
CCOPTS = -DPF_SUPPORT_FP -O2 -g $(FULL_WARNINGS)
IO_SOURCE = pf_io_posix.c
#IO_SOURCE = pf_io_stdio.c
EMBCCOPTS = -DPF_STATIC_DIC
#######################################
PFBASESOURCE = pf_cglue.c pf_clib.c pf_core.c pf_inner.c \
pf_io.c pf_io_none.c pf_main.c pf_mem.c pf_save.c \
pf_text.c pf_words.c pfcompil.c pfcustom.c
PFSOURCE = $(PFBASESOURCE) $(IO_SOURCE)
XCPPFLAGS = $(CDEFS) -I.
COMPILE = $(CC) $(CCOPTS) $(CFLAGS) $(XCPPFLAGS) $(CPPFLAGS)
LINK = $(CC) $(LDFLAGS)
.SUFFIXES: .c .o .eo
PFOBJS = $(PFSOURCE:.c=.o)
PFEMBOBJS = $(PFSOURCE:.c=.eo)
.c.o:
$(COMPILE) -c -o $@ $<
.c.eo:
$(COMPILE) $(EMBCCOPTS) -c -o $@ $<
all: pforth_standalone
# Build pforth by compiling 'C' source.
pforth: $(PFOBJS)
$(LINK) -o $@ $(PFOBJS)
# Build basic dictionary image by running newly built pforth and including "system.fth".
pfdicdat.h: pforth
wd=$$(pwd); (cd fth; $${wd}/pforth -i system.fth)
mv fth/pforth.dic pforth.dic
mv fth/pfdicdat.h $@
pforth_standalone: pfdicdat.h $(PFEMBOBJS)
$(LINK) -o $@ $(PFEMBOBJS) -lm
mv pforth ..
mv pforth.dic ..
@echo ""
@echo "Standalone pForth executable written to pforth_standalone"
# target aliases
pfdicapp: pforth
pfdicdat: pfdicdat.h
pforthapp: pforth_standalone
help:
@echo "Use 'make all' to build standalone pForth executable."
@echo "PForth can be built in several stages using these targets:"
@echo " pfdicapp = executable pForth with minimal dictionary. All from 'C'."
@echo " pfdicdat = image of full dictionary build by compiling Forth code."
@echo " pforthapp = executable with embedded dictionary image. DEFAULT 'all' target."
@echo ""
@echo " The file 'pfdicdat.h' is generated by pForth. It contains a binary image of the Forth dictionary."
@echo " It allows pForth to work as a standalone image that does not need to load a dictionary file."
install:
install -s -m 755 pforth ${DESTDIR}/bin/pforth
install -c -o bin -g bin -m 444 pforth.dic ${DESTDIR}/bin/pforth.dic
install -c -o bin -g bin -m 444 pfdicdat.h ${DESTDIR}/bin/pfdicdat.h
test:
wd=$$(pwd); (cd fth; $${wd}/pforth_standalone -q t_corex.fth)
wd=$$(pwd); (cd fth; $${wd}/pforth_standalone -q t_strings.fth)
wd=$$(pwd); (cd fth; $${wd}/pforth_standalone -q t_locals.fth)
wd=$$(pwd); (cd fth; $${wd}/pforth_standalone -q t_alloc.fth)
wd=$$(pwd); (cd fth; $${wd}/pforth_standalone -q t_floats.fth)
clean:
rm -f *.o *~ pforth_standalone pfdicdat.h ../pforth.dic ../pforth
src/cmd/pforth/fth/ansilocs.fth
+203
View File
@@ -0,0 +1,203 @@
\ @(#) 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.
\
\ 10/27/99 Fixed : foo { -- } 55 ; was entering local frame but not exiting.
anew task-ansilocs.fth
private{
decimal
16 constant LV_MAX_VARS \ maximum number of local variables
31 constant LV_MAX_CHARS \ maximum number of letters in name
lv_max_vars lv_max_chars $array LV-NAMES
variable LV-#NAMES \ number of names currently defined
\ Search name table for match
: LV.MATCH ( $string -- index true | $string false )
0 swap
lv-#names @ 0
?DO i lv-names
over $=
IF 2drop true i LEAVE
THEN
LOOP swap
;
: LV.COMPILE.FETCH ( index -- )
1+ \ adjust for optimised (local@), LocalsPtr points above vars
CASE
1 OF compile (1_local@) ENDOF
2 OF compile (2_local@) ENDOF
3 OF compile (3_local@) ENDOF
4 OF compile (4_local@) ENDOF
5 OF compile (5_local@) ENDOF
6 OF compile (6_local@) ENDOF
7 OF compile (7_local@) ENDOF
8 OF compile (8_local@) ENDOF
dup [compile] literal compile (local@)
ENDCASE
;
: LV.COMPILE.STORE ( index -- )
1+ \ adjust for optimised (local!), LocalsPtr points above vars
CASE
1 OF compile (1_local!) ENDOF
2 OF compile (2_local!) ENDOF
3 OF compile (3_local!) ENDOF
4 OF compile (4_local!) ENDOF
5 OF compile (5_local!) ENDOF
6 OF compile (6_local!) ENDOF
7 OF compile (7_local!) ENDOF
8 OF compile (8_local!) ENDOF
dup [compile] literal compile (local!)
ENDCASE
;
: LV.COMPILE.LOCAL ( $name -- handled? , check for matching locals name )
\ ." LV.COMPILER.LOCAL name = " dup count type cr
lv.match
IF ( index )
lv.compile.fetch
true
ELSE
drop false
THEN
;
: LV.CLEANUP ( -- , restore stack frame on exit from colon def )
lv-#names @
IF
compile (local.exit)
THEN
;
: LV.FINISH ( -- , restore stack frame on exit from colon def )
lv.cleanup
lv-#names off
local-compiler off
;
: LV.SETUP ( -- )
0 lv-#names !
;
: LV.TERM
." Locals turned off" cr
lv-#names off
local-compiler off
;
if.forgotten lv.term
}private
: (LOCAL) ( adr len -- , ANSI local primitive )
dup
IF
lv-#names @ lv_max_vars >= abort" Too many local variables!"
lv-#names @ lv-names place
\ Warn programmer if local variable matches an existing dictionary name.
lv-#names @ lv-names find nip
IF
." (LOCAL) - Note: "
lv-#names @ lv-names count type
." redefined as a local variable in "
latest id. cr
THEN
1 lv-#names +!
ELSE
\ Last local. Finish building local stack frame.
2drop
lv-#names @ dup 0= \ fixed 10/27/99, Thanks to John Providenza
IF
drop ." (LOCAL) - Warning: no locals defined!" cr
ELSE
[compile] literal compile (local.entry)
['] lv.compile.local local-compiler !
THEN
THEN
;
: VALUE
CREATE ( n <name> )
,
immediate
DOES>
state @
IF
[compile] aliteral
compile @
ELSE
@
THEN
;
: TO ( val <name> -- )
bl word
lv.match
IF ( -- index )
lv.compile.store
ELSE
find
1 = 0= abort" TO or -> before non-local or non-value"
>body \ point to data
state @
IF \ compiling ( -- pfa )
[compile] aliteral
compile !
ELSE \ executing ( -- val pfa )
!
THEN
THEN
; immediate
: -> ( -- ) [compile] to ; immediate
: +-> ( val <name> -- )
bl word
lv.match
IF ( -- index )
1+ \ adjust for optimised (local!), LocalsPtr points above vars
[compile] literal compile (local+!)
ELSE
find
1 = 0= abort" +-> before non-local or non-value"
>body \ point to data
state @
IF \ compiling ( -- pfa )
[compile] aliteral
compile +!
ELSE \ executing ( -- val pfa )
+!
THEN
THEN
; immediate
: : lv.setup : ;
: ; lv.finish [compile] ; ; immediate
: exit lv.cleanup compile exit ; immediate
: does> lv.finish [compile] does> ; immediate
privatize
src/cmd/pforth/fth/bench.fth
+198
View File
@@ -0,0 +1,198 @@
\ @(#) bench.fth 97/12/10 1.1
\ Benchmark Forth
\ by Phil Burk
\ 11/17/95
\
\ pForthV9 on Indy, compiled with gcc
\ bench1 took 15 seconds
\ bench2 took 16 seconds
\ bench3 took 17 seconds
\ bench4 took 17 seconds
\ bench5 took 19 seconds
\ sieve took 4 seconds
\
\ Darren Gibbs reports that on an SGI Octane loaded with multiple users:
\ bench1 took 2.8sec
\ bench2 took 2.7
\ bench3 took 2.9
\ bench4 took 2.1
\ bench 5 took 2.5
\ seive took .6
\
\ HForth on Mac Quadra 800, 68040
\ bench1 took 1.73 seconds
\ bench2 took 6.48 seconds
\ bench3 took 2.65 seconds
\ bench4 took 2.50 seconds
\ bench5 took 1.91 seconds
\ sieve took 0.45 seconds
\
\ pForthV9 on Mac Quadra 800
\ bench1 took 40 seconds
\ bench2 took 43 seconds
\ bench3 took 43 seconds
\ bench4 took 44 seconds
\ bench5 took 42 seconds
\ sieve took 20 seconds
\
\ pForthV9 on PB5300, 100 MHz PPC 603 based Mac Powerbook
\ bench1 took 8.6 seconds
\ bench2 took 9.0 seconds
\ bench3 took 9.7 seconds
\ bench4 took 8.8 seconds
\ bench5 took 10.3 seconds
\ sieve took 2.3 seconds
\
\ HForth on PB5300
\ bench1 took 1.1 seconds
\ bench2 took 3.6 seconds
\ bench3 took 1.7 seconds
\ bench4 took 1.2 seconds
\ bench5 took 1.3 seconds
\ sieve took 0.2 seconds
anew task-bench.fth
decimal
\ benchmark primitives
create #do 2000000 ,
: t1 #do @ 0 do loop ;
: t2 23 45 #do @ 0 do swap loop 2drop ;
: t3 23 #do @ 0 do dup drop loop drop ;
: t4 23 45 #do @ 0 do over drop loop 2drop ;
: t5 #do @ 0 do 23 45 + drop loop ;
: t6 23 #do @ 0 do >r r> loop drop ;
: t7 23 45 67 #do @ 0 do rot loop 2drop drop ;
: t8 #do @ 0 do 23 2* drop loop ;
: t9 #do @ 10 / 0 do 23 5 /mod 2drop loop ;
: t10 #do #do @ 0 do dup @ drop loop drop ;
: foo ( noop ) ;
: t11 #do @ 0 do foo loop ;
\ more complex benchmarks -----------------------
\ BENCH1 - sum data ---------------------------------------
create data1 23 , 45 , 67 , 89 , 111 , 222 , 333 , 444 ,
: sum.cells ( addr num -- sum )
0 swap \ sum
0 DO
over \ get address
i cells + @ +
LOOP
swap drop
;
: bench1 ( -- )
200000 0
DO
data1 8 sum.cells drop
LOOP
;
\ BENCH2 - recursive factorial --------------------------
: factorial ( n -- n! )
dup 1 >
IF
dup 1- recurse *
ELSE
drop 1
THEN
;
: bench2 ( -- )
200000 0
DO
10 factorial drop
LOOP
;
\ BENCH3 - DEFER ----------------------------------
defer calc.answer
: answer ( n -- m )
dup +
$ a5a5 xor
1000 max
;
' answer is calc.answer
: bench3
1500000 0
DO
i calc.answer drop
LOOP
;
\ BENCH4 - locals ---------------------------------
: use.locals { x1 x2 | aa bb -- result }
x1 2* -> aa
x2 2/ -> bb
x1 aa *
x2 bb * +
;
: bench4
400000 0
DO
234 567 use.locals drop
LOOP
;
\ BENCH5 - string compare -------------------------------
: match.strings { $s1 $s2 | adr1 len1 adr2 len2 -- flag }
$s1 count -> len1 -> adr1
$s2 count -> len2 -> adr2
len1 len2 -
IF
FALSE
ELSE
TRUE
len1 0
DO
adr1 i + c@
adr2 i + c@ -
IF
drop FALSE
leave
THEN
LOOP
THEN
;
: bench5 ( -- )
60000 0
DO
" This is a string. X foo"
" This is a string. Y foo" match.strings drop
LOOP
;
\ SIEVE OF ERATOSTHENES from BYTE magazine -----------------------
DECIMAL 8190 CONSTANT TSIZE
VARIABLE FLAGS TSIZE ALLOT
: <SIEVE> ( --- #primes ) FLAGS TSIZE 1 FILL
0 TSIZE 0
DO ( n ) I FLAGS + C@
IF I DUP + 3 + DUP I + ( I2*+3 I3*+3 )
BEGIN DUP TSIZE < ( same flag )
WHILE 0 OVER FLAGS + C! ( i' i'' ) OVER +
REPEAT 2DROP 1+
THEN
LOOP ;
: SIEVE ." 10 iterations " CR 0 10 0
DO <SIEVE> swap drop
LOOP . ." primes " CR ;
: SIEVE50 ." 50 iterations " CR 0 50 0
DO <SIEVE> swap drop
LOOP . ." primes " CR ;
\ 10 iterations
\ 21.5 sec Amiga Multi-Forth Indirect Threaded
\ 8.82 sec Amiga 1000 running JForth
\ ~5 sec SGI Indy running pForthV9
src/cmd/pforth/fth/c_struct.fth
+242
View File
@@ -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> -- member_address , calc addr of member )
ob.stats? drop state @
IF ?dup
IF [compile] literal compile +
THEN
ELSE +
THEN
; immediate
: (S+C!) ( val addr offset -- ) + c! ;
: (S+W!) ( val addr offset -- ) + w! ;
: (S+!) ( val addr offset -- ) + ! ;
: (S+REL!) ( ptr addr offset -- ) + >r if.use->rel r> ! ;
: compile+!bytes ( offset size -- )
\ ." compile+!bytes ( " over . dup . ." )" cr
swap [compile] literal \ compile offset into word
CASE
cell OF compile (s+!) ENDOF
2 OF compile (s+w!) ENDOF
1 OF compile (s+c!) ENDOF
-4 OF compile (s+rel!) ENDOF \ 00002
-2 OF compile (s+w!) ENDOF
-1 OF compile (s+c!) ENDOF
true abort" s! - illegal size!"
ENDCASE
;
: !BYTES ( value address size -- )
CASE
cell OF ! ENDOF
-4 OF ( aptr addr ) swap if.use->rel swap ! ENDOF \ 00002
ABS
2 OF w! ENDOF
1 OF c! ENDOF
true abort" s! - illegal size!"
ENDCASE
;
\ These provide ways of setting and reading members values
\ without knowing their size in bytes.
: (S!) ( offset size -- , compile proper fetch )
state @
IF compile+!bytes
ELSE ( -- value addr off size )
>r + r> !bytes
THEN
;
: S! ( value object <member> -- , store value in member )
ob.stats?
(s!)
; immediate
: @BYTES ( addr +/-size -- value )
CASE
cell OF @ ENDOF
2 OF w@ ENDOF
1 OF c@ ENDOF
-4 OF @ if.rel->use ENDOF \ 00002
-2 OF w@ w->s ENDOF
-1 OF c@ b->s ENDOF
true abort" s@ - illegal size!"
ENDCASE
;
: (S+UC@) ( addr offset -- val ) + c@ ;
: (S+UW@) ( addr offset -- val ) + w@ ;
: (S+@) ( addr offset -- val ) + @ ;
: (S+REL@) ( addr offset -- val ) + @ if.rel->use ;
: (S+C@) ( addr offset -- val ) + c@ b->s ;
: (S+W@) ( addr offset -- val ) + w@ w->s ;
: compile+@bytes ( offset size -- )
\ ." compile+@bytes ( " over . dup . ." )" cr
swap [compile] literal \ compile offset into word
CASE
cell OF compile (s+@) ENDOF
2 OF compile (s+uw@) ENDOF
1 OF compile (s+uc@) ENDOF
-4 OF compile (s+rel@) ENDOF \ 00002
-2 OF compile (s+w@) ENDOF
-1 OF compile (s+c@) ENDOF
true abort" s@ - illegal size!"
ENDCASE
;
: (S@) ( offset size -- , compile proper fetch )
state @
IF compile+@bytes
ELSE >r + r> @bytes
THEN
;
: S@ ( object <member> -- value , fetch value from member )
ob.stats?
(s@)
; immediate
exists? F* [IF]
\ 951112 Floating Point support
: FLPT ( <name> -- , declare space for a floating point value. )
1 floats bytes
;
: (S+F!) ( val addr offset -- ) + f! ;
: (S+F@) ( addr offset -- val ) + f@ ;
: FS! ( value object <member> -- , fetch value from member )
ob.stats?
1 floats <> abort" FS@ with non-float!"
state @
IF
[compile] literal
compile (s+f!)
ELSE (s+f!)
THEN
; immediate
: FS@ ( object <member> -- value , fetch value from member )
ob.stats?
1 floats <> abort" FS@ with non-float!"
state @
IF
[compile] literal
compile (s+f@)
ELSE (s+f@)
THEN
; immediate
[THEN]
0 [IF]
:struct mapper
long map_l1
long map_l2
aptr map_a1
rptr map_r1
flpt map_f1
short map_s1
ushort map_s2
byte map_b1
ubyte map_b2
;struct
mapper map1
: TT
-500 map1 s! map_s1
map1 s@ map_s1 -500 - abort" map_s1 failed!"
-500 map1 s! map_s2
map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"
-89 map1 s! map_b1
map1 s@ map_b1 -89 - abort" map_s1 failed!"
here map1 s! map_r1
map1 s@ map_r1 here - abort" map_r1 failed!"
-89 map1 s! map_b2
map1 s@ map_b2 -89 $ FF and - abort" map_s2 failed!"
23.45 map1 fs! map_f1
map1 fs@ map_f1 f. ." =?= 23.45" cr
;
." Testing c_struct.fth" cr
TT
[THEN]
src/cmd/pforth/fth/case.fth
+78
View File
@@ -0,0 +1,78 @@
\ @(#) 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
\ MOD: PLB 11/2/99 Fixed nesting of CASE. Needed to save of-depth on stack as well as case-depth.
anew TASK-CASE
variable CASE-DEPTH
variable OF-DEPTH
: CASE ( n -- , start case statement ) ( -c- case-depth )
?comp
of-depth @ 0 of-depth ! \ 11/2/99
case-depth @ 0 case-depth ! ( allow nesting )
; IMMEDIATE
: ?OF ( n flag -- | n , doit if true ) ( -c- addr )
[compile] IF
compile drop
1 case-depth +!
1 of-depth +!
; IMMEDIATE
: OF ( n t -- | n , doit if match ) ( -c- addr )
?comp
compile over compile =
[compile] ?OF
; IMMEDIATE
: (RANGEOF?) ( n lo hi -- | n flag )
>r over ( n lo n ) <=
IF
dup r> ( n n hi ) <=
ELSE
rdrop false
THEN
;
: RANGEOF ( n lo hi -- | n , doit if within ) ( -c- addr )
compile (rangeof?)
[compile] ?OF
; IMMEDIATE
: ENDOF ( -- ) ( addr -c- addr' )
[compile] ELSE
-1 of-depth +!
; IMMEDIATE
: ENDCASE ( n -- ) ( old-case-depth addr' addr' ??? -- )
of-depth @
IF >newline ." Missing ENDOF in CASE!" cr abort
THEN
\
compile drop
case-depth @ 0
?DO [compile] THEN
LOOP
case-depth !
of-depth !
; IMMEDIATE
src/cmd/pforth/fth/condcomp.fth
+50
View File
@@ -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? ( <name> -- flag , true if defined )
bl word find
swap drop
; immediate
src/cmd/pforth/fth/coretest.fth
+999
View File
@@ -0,0 +1,999 @@
\ From: John Hayes S1I
\ Subject: core.fr
\ Date: Mon, 27 Nov 95 13:10
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
\ VERSION 1.2
\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
\ Load test tools - Phil Burk
include? testing tester.fth
TESTING CORE WORDS
HEX
\ ------------------------------------------------------------------------
TESTING BASIC ASSUMPTIONS
{ -> } \ START WITH CLEAN SLATE
( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }
{ 0 BITSSET? -> 0 } ( ZERO IS ALL BITS CLEAR )
{ 1 BITSSET? -> 0 0 } ( OTHER NUMBER HAVE AT LEAST ONE BIT )
{ -1 BITSSET? -> 0 0 }
\ ------------------------------------------------------------------------
TESTING BOOLEANS: INVERT AND OR XOR
{ 0 0 AND -> 0 }
{ 0 1 AND -> 0 }
{ 1 0 AND -> 0 }
{ 1 1 AND -> 1 }
{ 0 INVERT 1 AND -> 1 }
{ 1 INVERT 1 AND -> 0 }
0 CONSTANT 0S
0 INVERT CONSTANT 1S
{ 0S INVERT -> 1S }
{ 1S INVERT -> 0S }
{ 0S 0S AND -> 0S }
{ 0S 1S AND -> 0S }
{ 1S 0S AND -> 0S }
{ 1S 1S AND -> 1S }
{ 0S 0S OR -> 0S }
{ 0S 1S OR -> 1S }
{ 1S 0S OR -> 1S }
{ 1S 1S OR -> 1S }
{ 0S 0S XOR -> 0S }
{ 0S 1S XOR -> 1S }
{ 1S 0S XOR -> 1S }
{ 1S 1S XOR -> 0S }
\ ------------------------------------------------------------------------
TESTING 2* 2/ LSHIFT RSHIFT
( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
1S 1 RSHIFT INVERT CONSTANT MSB
{ MSB BITSSET? -> 0 0 }
{ 0S 2* -> 0S }
{ 1 2* -> 2 }
{ 4000 2* -> 8000 }
{ 1S 2* 1 XOR -> 1S }
{ MSB 2* -> 0S }
{ 0S 2/ -> 0S }
{ 1 2/ -> 0 }
{ 4000 2/ -> 2000 }
{ 1S 2/ -> 1S } \ MSB PROPOGATED
{ 1S 1 XOR 2/ -> 1S }
{ MSB 2/ MSB AND -> MSB }
{ 1 0 LSHIFT -> 1 }
{ 1 1 LSHIFT -> 2 }
{ 1 2 LSHIFT -> 4 }
{ 1 F LSHIFT -> 8000 } \ BIGGEST GUARANTEED SHIFT
{ 1S 1 LSHIFT 1 XOR -> 1S }
{ MSB 1 LSHIFT -> 0 }
{ 1 0 RSHIFT -> 1 }
{ 1 1 RSHIFT -> 0 }
{ 2 1 RSHIFT -> 1 }
{ 4 2 RSHIFT -> 1 }
{ 8000 F RSHIFT -> 1 } \ BIGGEST
{ MSB 1 RSHIFT MSB AND -> 0 } \ RSHIFT ZERO FILLS MSBS
{ MSB 1 RSHIFT 2* -> MSB }
\ ------------------------------------------------------------------------
TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
0 INVERT CONSTANT MAX-UINT
0 INVERT 1 RSHIFT CONSTANT MAX-INT
0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT
0 INVERT 1 RSHIFT CONSTANT MID-UINT
0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1
0S CONSTANT <FALSE>
1S CONSTANT <TRUE>
{ 0 0= -> <TRUE> }
{ 1 0= -> <FALSE> }
{ 2 0= -> <FALSE> }
{ -1 0= -> <FALSE> }
{ MAX-UINT 0= -> <FALSE> }
{ MIN-INT 0= -> <FALSE> }
{ MAX-INT 0= -> <FALSE> }
{ 0 0 = -> <TRUE> }
{ 1 1 = -> <TRUE> }
{ -1 -1 = -> <TRUE> }
{ 1 0 = -> <FALSE> }
{ -1 0 = -> <FALSE> }
{ 0 1 = -> <FALSE> }
{ 0 -1 = -> <FALSE> }
{ 0 0< -> <FALSE> }
{ -1 0< -> <TRUE> }
{ MIN-INT 0< -> <TRUE> }
{ 1 0< -> <FALSE> }
{ MAX-INT 0< -> <FALSE> }
{ 0 1 < -> <TRUE> }
{ 1 2 < -> <TRUE> }
{ -1 0 < -> <TRUE> }
{ -1 1 < -> <TRUE> }
{ MIN-INT 0 < -> <TRUE> }
{ MIN-INT MAX-INT < -> <TRUE> }
{ 0 MAX-INT < -> <TRUE> }
{ 0 0 < -> <FALSE> }
{ 1 1 < -> <FALSE> }
{ 1 0 < -> <FALSE> }
{ 2 1 < -> <FALSE> }
{ 0 -1 < -> <FALSE> }
{ 1 -1 < -> <FALSE> }
{ 0 MIN-INT < -> <FALSE> }
{ MAX-INT MIN-INT < -> <FALSE> }
{ MAX-INT 0 < -> <FALSE> }
{ 0 1 > -> <FALSE> }
{ 1 2 > -> <FALSE> }
{ -1 0 > -> <FALSE> }
{ -1 1 > -> <FALSE> }
{ MIN-INT 0 > -> <FALSE> }
{ MIN-INT MAX-INT > -> <FALSE> }
{ 0 MAX-INT > -> <FALSE> }
{ 0 0 > -> <FALSE> }
{ 1 1 > -> <FALSE> }
{ 1 0 > -> <TRUE> }
{ 2 1 > -> <TRUE> }
{ 0 -1 > -> <TRUE> }
{ 1 -1 > -> <TRUE> }
{ 0 MIN-INT > -> <TRUE> }
{ MAX-INT MIN-INT > -> <TRUE> }
{ MAX-INT 0 > -> <TRUE> }
{ 0 1 U< -> <TRUE> }
{ 1 2 U< -> <TRUE> }
{ 0 MID-UINT U< -> <TRUE> }
{ 0 MAX-UINT U< -> <TRUE> }
{ MID-UINT MAX-UINT U< -> <TRUE> }
{ 0 0 U< -> <FALSE> }
{ 1 1 U< -> <FALSE> }
{ 1 0 U< -> <FALSE> }
{ 2 1 U< -> <FALSE> }
{ MID-UINT 0 U< -> <FALSE> }
{ MAX-UINT 0 U< -> <FALSE> }
{ MAX-UINT MID-UINT U< -> <FALSE> }
{ 0 1 MIN -> 0 }
{ 1 2 MIN -> 1 }
{ -1 0 MIN -> -1 }
{ -1 1 MIN -> -1 }
{ MIN-INT 0 MIN -> MIN-INT }
{ MIN-INT MAX-INT MIN -> MIN-INT }
{ 0 MAX-INT MIN -> 0 }
{ 0 0 MIN -> 0 }
{ 1 1 MIN -> 1 }
{ 1 0 MIN -> 0 }
{ 2 1 MIN -> 1 }
{ 0 -1 MIN -> -1 }
{ 1 -1 MIN -> -1 }
{ 0 MIN-INT MIN -> MIN-INT }
{ MAX-INT MIN-INT MIN -> MIN-INT }
{ MAX-INT 0 MIN -> 0 }
{ 0 1 MAX -> 1 }
{ 1 2 MAX -> 2 }
{ -1 0 MAX -> 0 }
{ -1 1 MAX -> 1 }
{ MIN-INT 0 MAX -> 0 }
{ MIN-INT MAX-INT MAX -> MAX-INT }
{ 0 MAX-INT MAX -> MAX-INT }
{ 0 0 MAX -> 0 }
{ 1 1 MAX -> 1 }
{ 1 0 MAX -> 1 }
{ 2 1 MAX -> 2 }
{ 0 -1 MAX -> 0 }
{ 1 -1 MAX -> 1 }
{ 0 MIN-INT MAX -> 0 }
{ MAX-INT MIN-INT MAX -> MAX-INT }
{ MAX-INT 0 MAX -> MAX-INT }
\ ------------------------------------------------------------------------
TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
{ 1 2 2DROP -> }
{ 1 2 2DUP -> 1 2 1 2 }
{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }
{ 1 2 3 4 2SWAP -> 3 4 1 2 }
{ 0 ?DUP -> 0 }
{ 1 ?DUP -> 1 1 }
{ -1 ?DUP -> -1 -1 }
{ DEPTH -> 0 }
{ 0 DEPTH -> 0 1 }
{ 0 1 DEPTH -> 0 1 2 }
{ 0 DROP -> }
{ 1 2 DROP -> 1 }
{ 1 DUP -> 1 1 }
{ 1 2 OVER -> 1 2 1 }
{ 1 2 3 ROT -> 2 3 1 }
{ 1 2 SWAP -> 2 1 }
\ ------------------------------------------------------------------------
TESTING >R R> R@
{ : GR1 >R R> ; -> }
{ : GR2 >R R@ R> DROP ; -> }
{ 123 GR1 -> 123 }
{ 123 GR2 -> 123 }
{ 1S GR1 -> 1S } ( RETURN STACK HOLDS CELLS )
\ ------------------------------------------------------------------------
TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
{ 0 5 + -> 5 }
{ 5 0 + -> 5 }
{ 0 -5 + -> -5 }
{ -5 0 + -> -5 }
{ 1 2 + -> 3 }
{ 1 -2 + -> -1 }
{ -1 2 + -> 1 }
{ -1 -2 + -> -3 }
{ -1 1 + -> 0 }
{ MID-UINT 1 + -> MID-UINT+1 }
{ 0 5 - -> -5 }
{ 5 0 - -> 5 }
{ 0 -5 - -> 5 }
{ -5 0 - -> -5 }
{ 1 2 - -> -1 }
{ 1 -2 - -> 3 }
{ -1 2 - -> -3 }
{ -1 -2 - -> 1 }
{ 0 1 - -> -1 }
{ MID-UINT+1 1 - -> MID-UINT }
{ 0 1+ -> 1 }
{ -1 1+ -> 0 }
{ 1 1+ -> 2 }
{ MID-UINT 1+ -> MID-UINT+1 }
{ 2 1- -> 1 }
{ 1 1- -> 0 }
{ 0 1- -> -1 }
{ MID-UINT+1 1- -> MID-UINT }
{ 0 NEGATE -> 0 }
{ 1 NEGATE -> -1 }
{ -1 NEGATE -> 1 }
{ 2 NEGATE -> -2 }
{ -2 NEGATE -> 2 }
{ 0 ABS -> 0 }
{ 1 ABS -> 1 }
{ -1 ABS -> 1 }
{ MIN-INT ABS -> MID-UINT+1 }
\ ------------------------------------------------------------------------
TESTING MULTIPLY: S>D * M* UM*
{ 0 S>D -> 0 0 }
{ 1 S>D -> 1 0 }
{ 2 S>D -> 2 0 }
{ -1 S>D -> -1 -1 }
{ -2 S>D -> -2 -1 }
{ MIN-INT S>D -> MIN-INT -1 }
{ MAX-INT S>D -> MAX-INT 0 }
{ 0 0 M* -> 0 S>D }
{ 0 1 M* -> 0 S>D }
{ 1 0 M* -> 0 S>D }
{ 1 2 M* -> 2 S>D }
{ 2 1 M* -> 2 S>D }
{ 3 3 M* -> 9 S>D }
{ -3 3 M* -> -9 S>D }
{ 3 -3 M* -> -9 S>D }
{ -3 -3 M* -> 9 S>D }
{ 0 MIN-INT M* -> 0 S>D }
{ 1 MIN-INT M* -> MIN-INT S>D }
{ 2 MIN-INT M* -> 0 1S }
{ 0 MAX-INT M* -> 0 S>D }
{ 1 MAX-INT M* -> MAX-INT S>D }
{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }
{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }
{ MAX-INT MIN-INT M* -> MSB MSB 2/ }
{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }
{ 0 0 * -> 0 } \ TEST IDENTITIES
{ 0 1 * -> 0 }
{ 1 0 * -> 0 }
{ 1 2 * -> 2 }
{ 2 1 * -> 2 }
{ 3 3 * -> 9 }
{ -3 3 * -> -9 }
{ 3 -3 * -> -9 }
{ -3 -3 * -> 9 }
{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }
{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }
{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }
{ 0 0 UM* -> 0 0 }
{ 0 1 UM* -> 0 0 }
{ 1 0 UM* -> 0 0 }
{ 1 2 UM* -> 2 0 }
{ 2 1 UM* -> 2 0 }
{ 3 3 UM* -> 9 0 }
{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }
{ MID-UINT+1 2 UM* -> 0 1 }
{ MID-UINT+1 4 UM* -> 0 2 }
{ 1S 2 UM* -> 1S 1 LSHIFT 1 }
{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }
\ ------------------------------------------------------------------------
TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
{ 0 S>D 1 FM/MOD -> 0 0 }
{ 1 S>D 1 FM/MOD -> 0 1 }
{ 2 S>D 1 FM/MOD -> 0 2 }
{ -1 S>D 1 FM/MOD -> 0 -1 }
{ -2 S>D 1 FM/MOD -> 0 -2 }
{ 0 S>D -1 FM/MOD -> 0 0 }
{ 1 S>D -1 FM/MOD -> 0 -1 }
{ 2 S>D -1 FM/MOD -> 0 -2 }
{ -1 S>D -1 FM/MOD -> 0 1 }
{ -2 S>D -1 FM/MOD -> 0 2 }
{ 2 S>D 2 FM/MOD -> 0 1 }
{ -1 S>D -1 FM/MOD -> 0 1 }
{ -2 S>D -2 FM/MOD -> 0 1 }
{ 7 S>D 3 FM/MOD -> 1 2 }
{ 7 S>D -3 FM/MOD -> -2 -3 }
{ -7 S>D 3 FM/MOD -> 2 -3 }
{ -7 S>D -3 FM/MOD -> -1 2 }
{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }
{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }
{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }
{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }
{ 1S 1 4 FM/MOD -> 3 MAX-INT }
{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }
{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }
{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }
{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }
{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }
{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }
{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }
{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }
{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }
{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }
{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }
{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }
{ 0 S>D 1 SM/REM -> 0 0 }
{ 1 S>D 1 SM/REM -> 0 1 }
{ 2 S>D 1 SM/REM -> 0 2 }
{ -1 S>D 1 SM/REM -> 0 -1 }
{ -2 S>D 1 SM/REM -> 0 -2 }
{ 0 S>D -1 SM/REM -> 0 0 }
{ 1 S>D -1 SM/REM -> 0 -1 }
{ 2 S>D -1 SM/REM -> 0 -2 }
{ -1 S>D -1 SM/REM -> 0 1 }
{ -2 S>D -1 SM/REM -> 0 2 }
{ 2 S>D 2 SM/REM -> 0 1 }
{ -1 S>D -1 SM/REM -> 0 1 }
{ -2 S>D -2 SM/REM -> 0 1 }
{ 7 S>D 3 SM/REM -> 1 2 }
{ 7 S>D -3 SM/REM -> 1 -2 }
{ -7 S>D 3 SM/REM -> -1 -2 }
{ -7 S>D -3 SM/REM -> -1 2 }
{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }
{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }
{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }
{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }
{ 1S 1 4 SM/REM -> 3 MAX-INT }
{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }
{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }
{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }
{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }
{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }
{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }
{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }
{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }
{ 0 0 1 UM/MOD -> 0 0 }
{ 1 0 1 UM/MOD -> 0 1 }
{ 1 0 2 UM/MOD -> 1 0 }
{ 3 0 2 UM/MOD -> 1 1 }
{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }
{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }
{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }
: IFFLOORED
[ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
: IFSYM
[ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
IFFLOORED : T/MOD >R S>D R> FM/MOD ;
IFFLOORED : T/ T/MOD SWAP DROP ;
IFFLOORED : TMOD T/MOD DROP ;
IFFLOORED : T*/MOD >R M* R> FM/MOD ;
IFFLOORED : T*/ T*/MOD SWAP DROP ;
IFSYM : T/MOD >R S>D R> SM/REM ;
IFSYM : T/ T/MOD SWAP DROP ;
IFSYM : TMOD T/MOD DROP ;
IFSYM : T*/MOD >R M* R> SM/REM ;
IFSYM : T*/ T*/MOD SWAP DROP ;
{ 0 1 /MOD -> 0 1 T/MOD }
{ 1 1 /MOD -> 1 1 T/MOD }
{ 2 1 /MOD -> 2 1 T/MOD }
{ -1 1 /MOD -> -1 1 T/MOD }
{ -2 1 /MOD -> -2 1 T/MOD }
{ 0 -1 /MOD -> 0 -1 T/MOD }
{ 1 -1 /MOD -> 1 -1 T/MOD }
{ 2 -1 /MOD -> 2 -1 T/MOD }
{ -1 -1 /MOD -> -1 -1 T/MOD }
{ -2 -1 /MOD -> -2 -1 T/MOD }
{ 2 2 /MOD -> 2 2 T/MOD }
{ -1 -1 /MOD -> -1 -1 T/MOD }
{ -2 -2 /MOD -> -2 -2 T/MOD }
{ 7 3 /MOD -> 7 3 T/MOD }
{ 7 -3 /MOD -> 7 -3 T/MOD }
{ -7 3 /MOD -> -7 3 T/MOD }
{ -7 -3 /MOD -> -7 -3 T/MOD }
{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }
{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }
{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }
{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }
{ 0 1 / -> 0 1 T/ }
{ 1 1 / -> 1 1 T/ }
{ 2 1 / -> 2 1 T/ }
{ -1 1 / -> -1 1 T/ }
{ -2 1 / -> -2 1 T/ }
{ 0 -1 / -> 0 -1 T/ }
{ 1 -1 / -> 1 -1 T/ }
{ 2 -1 / -> 2 -1 T/ }
{ -1 -1 / -> -1 -1 T/ }
{ -2 -1 / -> -2 -1 T/ }
{ 2 2 / -> 2 2 T/ }
{ -1 -1 / -> -1 -1 T/ }
{ -2 -2 / -> -2 -2 T/ }
{ 7 3 / -> 7 3 T/ }
{ 7 -3 / -> 7 -3 T/ }
{ -7 3 / -> -7 3 T/ }
{ -7 -3 / -> -7 -3 T/ }
{ MAX-INT 1 / -> MAX-INT 1 T/ }
{ MIN-INT 1 / -> MIN-INT 1 T/ }
{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }
{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }
{ 0 1 MOD -> 0 1 TMOD }
{ 1 1 MOD -> 1 1 TMOD }
{ 2 1 MOD -> 2 1 TMOD }
{ -1 1 MOD -> -1 1 TMOD }
{ -2 1 MOD -> -2 1 TMOD }
{ 0 -1 MOD -> 0 -1 TMOD }
{ 1 -1 MOD -> 1 -1 TMOD }
{ 2 -1 MOD -> 2 -1 TMOD }
{ -1 -1 MOD -> -1 -1 TMOD }
{ -2 -1 MOD -> -2 -1 TMOD }
{ 2 2 MOD -> 2 2 TMOD }
{ -1 -1 MOD -> -1 -1 TMOD }
{ -2 -2 MOD -> -2 -2 TMOD }
{ 7 3 MOD -> 7 3 TMOD }
{ 7 -3 MOD -> 7 -3 TMOD }
{ -7 3 MOD -> -7 3 TMOD }
{ -7 -3 MOD -> -7 -3 TMOD }
{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }
{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }
{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }
{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }
{ 0 2 1 */ -> 0 2 1 T*/ }
{ 1 2 1 */ -> 1 2 1 T*/ }
{ 2 2 1 */ -> 2 2 1 T*/ }
{ -1 2 1 */ -> -1 2 1 T*/ }
{ -2 2 1 */ -> -2 2 1 T*/ }
{ 0 2 -1 */ -> 0 2 -1 T*/ }
{ 1 2 -1 */ -> 1 2 -1 T*/ }
{ 2 2 -1 */ -> 2 2 -1 T*/ }
{ -1 2 -1 */ -> -1 2 -1 T*/ }
{ -2 2 -1 */ -> -2 2 -1 T*/ }
{ 2 2 2 */ -> 2 2 2 T*/ }
{ -1 2 -1 */ -> -1 2 -1 T*/ }
{ -2 2 -2 */ -> -2 2 -2 T*/ }
{ 7 2 3 */ -> 7 2 3 T*/ }
{ 7 2 -3 */ -> 7 2 -3 T*/ }
{ -7 2 3 */ -> -7 2 3 T*/ }
{ -7 2 -3 */ -> -7 2 -3 T*/ }
{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }
{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }
{ 0 2 1 */MOD -> 0 2 1 T*/MOD }
{ 1 2 1 */MOD -> 1 2 1 T*/MOD }
{ 2 2 1 */MOD -> 2 2 1 T*/MOD }
{ -1 2 1 */MOD -> -1 2 1 T*/MOD }
{ -2 2 1 */MOD -> -2 2 1 T*/MOD }
{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }
{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }
{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }
{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }
{ 2 2 2 */MOD -> 2 2 2 T*/MOD }
{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }
{ 7 2 3 */MOD -> 7 2 3 T*/MOD }
{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }
{ -7 2 3 */MOD -> -7 2 3 T*/MOD }
{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }
{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }
{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }
\ ------------------------------------------------------------------------
TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
HERE 1 ALLOT
HERE
CONSTANT 2NDA
CONSTANT 1STA
{ 1STA 2NDA U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
{ 1STA 1+ -> 2NDA } \ ... BY ONE ADDRESS UNIT
( MISSING TEST: NEGATIVE ALLOT )
HERE 1 ,
HERE 2 ,
CONSTANT 2ND
CONSTANT 1ST
{ 1ST 2ND U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
{ 1ST CELL+ -> 2ND } \ ... BY ONE CELL
{ 1ST 1 CELLS + -> 2ND }
{ 1ST @ 2ND @ -> 1 2 }
{ 5 1ST ! -> }
{ 1ST @ 2ND @ -> 5 2 }
{ 6 2ND ! -> }
{ 1ST @ 2ND @ -> 5 6 }
{ 1ST 2@ -> 6 5 }
{ 2 1 1ST 2! -> }
{ 1ST 2@ -> 2 1 }
{ 1S 1ST ! 1ST @ -> 1S } \ CAN STORE CELL-WIDE VALUE
HERE 1 C,
HERE 2 C,
CONSTANT 2NDC
CONSTANT 1STC
{ 1STC 2NDC U< -> <TRUE> } \ HERE MUST GROW WITH ALLOT
{ 1STC CHAR+ -> 2NDC } \ ... BY ONE CHAR
{ 1STC 1 CHARS + -> 2NDC }
{ 1STC C@ 2NDC C@ -> 1 2 }
{ 3 1STC C! -> }
{ 1STC C@ 2NDC C@ -> 3 2 }
{ 4 2NDC C! -> }
{ 1STC C@ 2NDC C@ -> 3 4 }
ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
CONSTANT A-ADDR CONSTANT UA-ADDR
{ UA-ADDR ALIGNED -> A-ADDR }
{ 1 A-ADDR C! A-ADDR C@ -> 1 }
{ 1234 A-ADDR ! A-ADDR @ -> 1234 }
{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }
{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }
{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }
{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }
{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }
: BITS ( X -- U )
0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
{ 1 CHARS 1 < -> <FALSE> }
{ 1 CHARS 1 CELLS > -> <FALSE> }
( TBD: HOW TO FIND NUMBER OF BITS? )
( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
{ 1 CELLS 1 < -> <FALSE> }
{ 1 CELLS 1 CHARS MOD -> 0 }
{ 1S BITS 10 < -> <FALSE> }
{ 0 1ST ! -> }
{ 1 1ST +! -> }
{ 1ST @ -> 1 }
{ -1 1ST +! 1ST @ -> 0 }
\ ------------------------------------------------------------------------
TESTING CHAR [CHAR] [ ] BL S"
{ BL -> 20 }
{ CHAR X -> 58 }
{ CHAR HELLO -> 48 }
{ : GC1 [CHAR] X ; -> }
{ : GC2 [CHAR] HELLO ; -> }
{ GC1 -> 58 }
{ GC2 -> 48 }
{ : GC3 [ GC1 ] LITERAL ; -> }
{ GC3 -> 58 }
{ : GC4 S" XY" ; -> }
{ GC4 SWAP DROP -> 2 }
{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
\ ------------------------------------------------------------------------
TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
{ : GT1 123 ; -> }
{ ' GT1 EXECUTE -> 123 }
{ : GT2 ['] GT1 ; IMMEDIATE -> }
{ GT2 EXECUTE -> 123 }
HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
{ GT1STRING FIND -> ' GT1 -1 }
{ GT2STRING FIND -> ' GT2 1 }
( HOW TO SEARCH FOR NON-EXISTENT WORD? )
{ : GT3 GT2 LITERAL ; -> }
{ GT3 -> ' GT1 }
{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }
{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }
{ : GT5 GT4 ; -> }
{ GT5 -> 123 }
{ : GT6 345 ; IMMEDIATE -> }
{ : GT7 POSTPONE GT6 ; -> }
{ GT7 -> 345 }
{ : GT8 STATE @ ; IMMEDIATE -> }
{ GT8 -> 0 }
{ : GT9 GT8 LITERAL ; -> }
{ GT9 0= -> <FALSE> }
\ ------------------------------------------------------------------------
TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
{ : GI1 IF 123 THEN ; -> }
{ : GI2 IF 123 ELSE 234 THEN ; -> }
{ 0 GI1 -> }
{ 1 GI1 -> 123 }
{ -1 GI1 -> 123 }
{ 0 GI2 -> 234 }
{ 1 GI2 -> 123 }
{ -1 GI1 -> 123 }
{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }
{ 0 GI3 -> 0 1 2 3 4 5 }
{ 4 GI3 -> 4 5 }
{ 5 GI3 -> 5 }
{ 6 GI3 -> 6 }
{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }
{ 3 GI4 -> 3 4 5 6 }
{ 5 GI4 -> 5 6 }
{ 6 GI4 -> 6 7 }
{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
{ 1 GI5 -> 1 345 }
{ 2 GI5 -> 2 345 }
{ 3 GI5 -> 3 4 5 123 }
{ 4 GI5 -> 4 5 123 }
{ 5 GI5 -> 5 123 }
{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }
{ 0 GI6 -> 0 }
{ 1 GI6 -> 0 1 }
{ 2 GI6 -> 0 1 2 }
{ 3 GI6 -> 0 1 2 3 }
{ 4 GI6 -> 0 1 2 3 4 }
\ ------------------------------------------------------------------------
TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
{ : GD1 DO I LOOP ; -> }
{ 4 1 GD1 -> 1 2 3 }
{ 2 -1 GD1 -> -1 0 1 }
{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }
{ : GD2 DO I -1 +LOOP ; -> }
{ 1 4 GD2 -> 4 3 2 1 }
{ -1 2 GD2 -> 2 1 0 -1 }
{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }
{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }
{ 4 1 GD3 -> 1 2 3 }
{ 2 -1 GD3 -> -1 0 1 }
{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }
{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }
{ 1 4 GD4 -> 4 3 2 1 }
{ -1 2 GD4 -> 2 1 0 -1 }
{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }
{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
{ 1 GD5 -> 123 }
{ 5 GD5 -> 123 }
{ 6 GD5 -> 234 }
{ : GD6 ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
0 SWAP 0 DO
I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
LOOP ; -> }
{ 1 GD6 -> 1 }
{ 2 GD6 -> 3 }
{ 3 GD6 -> 4 1 2 }
\ ------------------------------------------------------------------------
TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
{ 123 CONSTANT X123 -> }
{ X123 -> 123 }
{ : EQU CONSTANT ; -> }
{ X123 EQU Y123 -> }
{ Y123 -> 123 }
{ VARIABLE V1 -> }
{ 123 V1 ! -> }
{ V1 @ -> 123 }
{ : NOP : POSTPONE ; ; -> }
{ NOP NOP1 NOP NOP2 -> }
{ NOP1 -> }
{ NOP2 -> }
{ : DOES1 DOES> @ 1 + ; -> }
{ : DOES2 DOES> @ 2 + ; -> }
{ CREATE CR1 -> }
{ CR1 -> HERE }
{ ' CR1 >BODY -> HERE }
{ 1 , -> }
{ CR1 @ -> 1 }
{ DOES1 -> }
{ CR1 -> 2 }
{ DOES2 -> }
{ CR1 -> 3 }
{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }
{ WEIRD: W1 -> }
{ ' W1 >BODY -> HERE }
{ W1 -> HERE 1 + }
{ W1 -> HERE 2 + }
\ ------------------------------------------------------------------------
TESTING EVALUATE
: GE1 S" 123" ; IMMEDIATE
: GE2 S" 123 1+" ; IMMEDIATE
: GE3 S" : GE4 345 ;" ;
: GE5 EVALUATE ; IMMEDIATE
{ GE1 EVALUATE -> 123 } ( TEST EVALUATE IN INTERP. STATE )
{ GE2 EVALUATE -> 124 }
{ GE3 EVALUATE -> }
{ GE4 -> 345 }
{ : GE6 GE1 GE5 ; -> } ( TEST EVALUATE IN COMPILE STATE )
{ GE6 -> 123 }
{ : GE7 GE2 GE5 ; -> }
{ GE7 -> 124 }
\ ------------------------------------------------------------------------
TESTING SOURCE >IN WORD
: GS1 S" SOURCE" 2DUP EVALUATE
>R SWAP >R = R> R> = ;
{ GS1 -> <TRUE> <TRUE> }
VARIABLE SCANS
: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
{ 2 SCANS !
345 RESCAN?
-> 345 345 }
: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ;
{ GS2 -> 123 123 123 123 123 }
: GS3 WORD COUNT SWAP C@ ;
{ BL GS3 HELLO -> 5 CHAR H }
{ CHAR " GS3 GOODBYE" -> 7 CHAR G }
{ BL GS3
DROP -> 0 } \ BLANK LINE RETURN ZERO-LENGTH STRING
: GS4 SOURCE >IN ! DROP ;
{ GS4 123 456
-> }
\ ------------------------------------------------------------------------
TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
>R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH
R> ?DUP IF \ IF NON-EMPTY STRINGS
0 DO
OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
SWAP CHAR+ SWAP CHAR+
LOOP
THEN
2DROP <TRUE> \ IF WE GET HERE, STRINGS MATCH
ELSE
R> DROP 2DROP <FALSE> \ LENGTHS MISMATCH
THEN ;
: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
{ GP1 -> <TRUE> }
: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
{ GP2 -> <TRUE> }
: GP3 <# 1 0 # # #> S" 01" S= ;
{ GP3 -> <TRUE> }
: GP4 <# 1 0 #S #> S" 1" S= ;
{ GP4 -> <TRUE> }
24 CONSTANT MAX-BASE \ BASE 2 .. 36
: COUNT-BITS
0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD
: GP5
BASE @ <TRUE>
MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE
I BASE ! \ TBD: ASSUMES BASE WORKS
I 0 <# #S #> S" 10" S= AND
LOOP
SWAP BASE ! ;
{ GP5 -> <TRUE> }
: GP6
BASE @ >R 2 BASE !
MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY
R> BASE ! \ S: C-ADDR U
DUP #BITS-UD = SWAP
0 DO \ S: C-ADDR FLAG
OVER C@ [CHAR] 1 = AND \ ALL ONES
>R CHAR+ R>
LOOP SWAP DROP ;
{ GP6 -> <TRUE> }
: GP7
BASE @ >R MAX-BASE BASE !
<TRUE>
A 0 DO
I 0 <# #S #>
1 = SWAP C@ I 30 + = AND AND
LOOP
MAX-BASE A DO
I 0 <# #S #>
1 = SWAP C@ 41 I A - + = AND AND
LOOP
R> BASE ! ;
{ GP7 -> <TRUE> }
\ >NUMBER TESTS
CREATE GN-BUF 0 C,
: GN-STRING GN-BUF 1 ;
: GN-CONSUMED GN-BUF CHAR+ 0 ;
: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ;
{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }
{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }
{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }
{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING } \ SHOULD FAIL TO CONVERT THESE
{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }
{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }
: >NUMBER-BASED
BASE @ >R BASE ! >NUMBER R> BASE ! ;
{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }
{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }
{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }
{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }
{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }
{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }
: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
BASE @ >R BASE !
<# #S #>
0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY
R> BASE ! ;
{ 0 0 2 GN1 -> 0 0 0 }
{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }
{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }
{ 0 0 MAX-BASE GN1 -> 0 0 0 }
{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }
{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }
: GN2 \ ( -- 16 10 )
BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ;
{ GN2 -> 10 A }
\ ------------------------------------------------------------------------
TESTING FILL MOVE
CREATE FBUF 00 C, 00 C, 00 C,
CREATE SBUF 12 C, 34 C, 56 C,
: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ;
{ FBUF 0 20 FILL -> }
{ SEEBUF -> 00 00 00 }
{ FBUF 1 20 FILL -> }
{ SEEBUF -> 20 00 00 }
{ FBUF 3 20 FILL -> }
{ SEEBUF -> 20 20 20 }
{ FBUF FBUF 3 CHARS MOVE -> } \ BIZARRE SPECIAL CASE
{ SEEBUF -> 20 20 20 }
{ SBUF FBUF 0 CHARS MOVE -> }
{ SEEBUF -> 20 20 20 }
{ SBUF FBUF 1 CHARS MOVE -> }
{ SEEBUF -> 12 20 20 }
{ SBUF FBUF 3 CHARS MOVE -> }
{ SEEBUF -> 12 34 56 }
{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }
{ SEEBUF -> 12 12 34 }
{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }
{ SEEBUF -> 12 34 34 }
\ ------------------------------------------------------------------------
TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
: OUTPUT-TEST
." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
41 BL DO I EMIT LOOP CR
61 41 DO I EMIT LOOP CR
7F 61 DO I EMIT LOOP CR
." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
9 1+ 0 DO I . LOOP CR
." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
[CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
[CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
." YOU SHOULD SEE TWO SEPARATE LINES:" CR
S" LINE 1" TYPE CR S" LINE 2" TYPE CR
." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
." SIGNED: " MIN-INT . MAX-INT . CR
." UNSIGNED: " 0 U. MAX-UINT U. CR
;
{ OUTPUT-TEST -> }
\ ------------------------------------------------------------------------
TESTING INPUT: ACCEPT
CREATE ABUF 80 CHARS ALLOT
: ACCEPT-TEST
CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
ABUF 80 ACCEPT
CR ." RECEIVED: " [CHAR] " EMIT
ABUF SWAP TYPE [CHAR] " EMIT CR
;
{ ACCEPT-TEST -> }
\ ------------------------------------------------------------------------
TESTING DICTIONARY SEARCH RULES
{ : GDX 123 ; : GDX GDX 234 ; -> }
{ GDX -> 123 234 }
src/cmd/pforth/fth/filefind.fth
+119
View File
@@ -0,0 +1,119 @@
\ @(#) filefind.fth 98/01/26 1.2
\ FILE? ( <name> -- , report which file this Forth word was defined in )
\
\ FILE? looks for ::::Filename and ;;;; in the dictionary
\ that have been left by INCLUDE. It figures out nested
\ includes and reports each file that defines the word.
\
\ Author: Phil Burk
\ Copyright 1992 Phil Burk
\
\ 00001 PLB 2/21/92 Handle words from kernel or keyboard.
\ Support EACH.FILE?
\ 961213 PLB Port to pForth.
ANEW TASK-FILEFIND.FTH
: BE@ { addr | val -- val , fetch from unaligned address in BigEndian order }
4 0
DO
addr i + c@
val 8 lshift or -> val
LOOP
val
;
: BE! { val addr -- , store to unaligned address in BigEndian order }
4 0
DO
val 3 i - 8 * rshift
addr i + c!
LOOP
;
: BEW@ { addr -- , fetch word from unaligned address in BigEndian order }
addr c@ 8 lshift
addr 1+ c@ OR
;
: BEW! { val addr -- , store word to unaligned address in BigEndian order }
val 8 rshift addr c!
val addr 1+ c!
;
\ scan dictionary from NFA for filename
: F?.SEARCH.NFA { nfa | dpth stoploop keyb nfa0 -- addr count }
0 -> dpth
0 -> stoploop
0 -> keyb
nfa -> nfa0
BEGIN
nfa prevname -> nfa
nfa 0>
IF
nfa 1+ be@
CASE
$ 3a3a3a3a ( :::: )
OF
dpth 0=
IF
nfa count 31 and
4 - swap 4 + swap
true -> stoploop
ELSE
-1 dpth + -> dpth
THEN
ENDOF
$ 3b3b3b3b ( ;;;; )
OF
1 dpth + -> dpth
true -> keyb \ maybe from keyboard
ENDOF
ENDCASE
ELSE
true -> stoploop
keyb
IF
" keyboard"
ELSE
" 'C' kernel"
THEN
count
THEN
stoploop
UNTIL
;
: FINDNFA.FROM { $name start_nfa -- nfa true | $word false }
context @ >r
start_nfa context !
$name findnfa
r> context !
;
\ Search entire dictionary for all occurences of named word.
: FILE? { | $word nfa done? -- , take name from input }
0 -> done?
bl word -> $word
$word findnfa
IF ( -- nfa )
$word count type ." from:" cr
-> nfa
BEGIN
nfa f?.search.nfa ( addr cnt )
nfa name> 12 .r \ print xt
4 spaces type cr
nfa prevname dup -> nfa
0>
IF
$word nfa findnfa.from \ search from one behind found nfa
swap -> nfa
not
ELSE
true
THEN
UNTIL
ELSE ( -- $word )
count type ." not found!" cr
THEN
;
src/cmd/pforth/fth/floats.fth
+502
View File
@@ -0,0 +1,502 @@
\ @(#) floats.fth 98/02/26 1.4 17:51:40
\ High Level Forth support for Floating Point
\
\ Author: Phil Burk and Darren Gibbs
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license. The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.
\
\ 19970702 PLB Drop 0.0 in REPRESENT to fix 0.0 F.
\ 19980220 PLB Added FG. , fixed up large and small formatting
\ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix 0.0 F. (!!!)
\ Fixed F~ by using (F.EXACTLY)
ANEW TASK-FLOATS.FTH
: FALIGNED ( addr -- a-addr )
1 floats 1- +
1 floats /
1 floats *
;
: FALIGN ( -- , align DP )
dp @ faligned dp !
;
\ account for size of create when aligning floats
here
create fp-create-size
fp-create-size swap - constant CREATE_SIZE
: FALIGN.CREATE ( -- , align DP for float after CREATE )
dp @
CREATE_SIZE +
faligned
CREATE_SIZE -
dp !
;
: FCREATE ( <name> -- , create with float aligned data )
falign.create
CREATE
;
: FVARIABLE ( <name> -- ) ( F: -- )
FCREATE 1 floats allot
;
: FCONSTANT
FCREATE here 1 floats allot f!
DOES> f@
;
: F0SP ( -- ) ( F: ? -- )
fdepth 0 max 0 ?DO fdrop LOOP
;
\ Convert between single precision and floating point
: S>F ( s -- ) ( F: -- r )
s>d d>f
;
: F>S ( -- s ) ( F: r -- )
f>d d>s
;
: (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells }
1 floats -> fsize
fsize cell 1- + cell 1- invert and \ round up to nearest multiple of stack size
cell / -> fcells ( number of cells per float )
\ make room on data stack for floats data
fcells 0 ?DO 0 LOOP
sp@ -> caddr1
fcells 0 ?DO 0 LOOP
sp@ -> caddr2
\ compare bit representation
caddr1 f!
caddr2 f!
caddr1 fsize caddr2 fsize compare 0=
>r fcells 2* 0 ?DO drop LOOP r> \ drop float bits
;
: F~ ( -0- flag ) ( r1 r2 r3 -f- )
fdup F0<
IF
frot frot ( -- r3 r1 r2 )
fover fover ( -- r3 r1 r2 r1 r2 )
f- fabs ( -- r3 r1 r2 |r1-r2| )
frot frot ( -- r3 |r1-r2| r1 r2 )
fabs fswap fabs f+ ( -- r3 |r1-r2| |r1|+|r2| )
frot fabs f* ( -- |r1-r2| |r1|+|r2|*|r3| )
f<
ELSE
fdup f0=
IF
fdrop
(f.exactly) \ f- f0= \ 19980812 Used to cheat. Now actually compares bit patterns.
ELSE
frot frot ( -- r3 r1 r2 )
f- fabs ( -- r3 |r1-r2| )
fswap f<
THEN
THEN
;
\ FP Output --------------------------------------------------------
fvariable FVAR-REP \ scratch var for represent
: REPRESENT { c-addr u | n flag1 flag2 -- n flag1 flag2 , FLOATING } ( F: r -- )
TRUE -> flag2 \ FIXME - need to check range
fvar-rep f!
\
fvar-rep f@ f0<
IF
-1 -> flag1
fvar-rep f@ fabs fvar-rep f! \ absolute value
ELSE
0 -> flag1
THEN
\
fvar-rep f@ f0=
IF
\ fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F."
c-addr u [char] 0 fill
0 -> n
ELSE
fvar-rep f@
flog
fdup f0< not
IF
1 s>f f+ \ round up exponent
THEN
f>s -> n
\ ." REP - n = " n . cr
\ normalize r to u digits
fvar-rep f@
10 s>f u n - s>f f** f*
1 s>f 2 s>f f/ f+ \ round result
\
\ convert float to double_int then convert to text
f>d
\ ." REP - d = " over . dup . cr
<# u 1- 0 ?DO # loop #s #> \ ( -- addr cnt )
\ Adjust exponent if rounding caused number of digits to increase.
\ For example from 9999 to 10000.
u - +-> n
c-addr u move
THEN
\
n flag1 flag2
;
variable FP-PRECISION
\ Set maximum digits that are meaningful for the precision that we use.
1 FLOATS 4 / 7 * constant FP_PRECISION_MAX
: PRECISION ( -- u )
fp-precision @
;
: SET-PRECISION ( u -- )
fp_precision_max min
fp-precision !
;
7 set-precision
32 constant FP_REPRESENT_SIZE
64 constant FP_OUTPUT_SIZE
create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot \ used with REPRESENT
create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot \ used to assemble final output
variable FP-OUTPUT-PTR \ points into FP-OUTPUT-PAD
: FP.HOLD ( char -- , add char to output )
fp-output-ptr @ fp-output-pad 64 + <
IF
fp-output-ptr @ tuck c!
1+ fp-output-ptr !
ELSE
drop
THEN
;
: FP.APPEND { addr cnt -- , add string to output }
cnt 0 max 0
?DO
addr i + c@ fp.hold
LOOP
;
: FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output )
BEGIN
fp-output-ptr @ fp-output-pad u>
fp-output-ptr @ 1- c@ [char] 0 =
and
WHILE
-1 fp-output-ptr +!
REPEAT
;
: FP.APPEND.ZEROS ( numZeros -- )
0 max 0
?DO [char] 0 fp.hold
LOOP
;
: FP.MOVE.DECIMAL { n prec -- , append with decimal point shifted }
fp-represent-pad n prec min fp.append
n prec - fp.append.zeros
[char] . fp.hold
fp-represent-pad n +
prec n - 0 max fp.append
;
: (EXP.) ( n -- addr cnt , convert exponent to two digit value )
dup abs 0
<# # #s
rot 0<
IF [char] - HOLD
ELSE [char] + hold
THEN
#>
;
: FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- )
;
: (FS.) ( -- addr cnt ) ( F: r -- , scientific notation )
fp-output-pad fp-output-ptr ! \ setup pointer
fp-represent-pad precision represent
\ ." (FS.) - represent " fp-represent-pad precision type cr
( -- n flag1 flag2 )
IF
IF [char] - fp.hold
THEN
1 precision fp.move.decimal
[char] e fp.hold
1- (exp.) fp.append \ n
ELSE
2drop
s" <FP-OUT-OF-RANGE>" fp.append
THEN
fp-output-pad fp-output-ptr @ over -
;
: FS. ( F: r -- , scientific notation )
(fs.) type space
;
: (FE.) ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- }
fp-output-pad fp-output-ptr ! \ setup pointer
fp-represent-pad precision represent
( -- n flag1 flag2 )
IF
IF [char] - fp.hold
THEN
\ convert exponent to multiple of three
-> n
n 1- s>d 3 fm/mod \ use floored divide
3 * -> n3
1+ precision fp.move.decimal \ amount to move decimal point
[char] e fp.hold
n3 (exp.) fp.append \ n
ELSE
2drop
s" <FP-OUT-OF-RANGE>" fp.append
THEN
fp-output-pad fp-output-ptr @ over -
;
: FE. ( F: r -- , engineering notation )
(FE.) type space
;
: (FG.) ( F: r -- , normal or scientific ) { | n n3 ndiff -- }
fp-output-pad fp-output-ptr ! \ setup pointer
fp-represent-pad precision represent
( -- n flag1 flag2 )
IF
IF [char] - fp.hold
THEN
\ compare n with precision to see whether we do scientific display
dup precision >
over -3 < OR
IF \ use exponential notation
1 precision fp.move.decimal
fp.strip.trailing.zeros
[char] e fp.hold
1- (exp.) fp.append \ n
ELSE
dup 0>
IF
\ POSITIVE EXPONENT - place decimal point in middle
precision fp.move.decimal
ELSE
\ NEGATIVE EXPONENT - use 0.000????
s" 0." fp.append
\ output leading zeros
negate fp.append.zeros
fp-represent-pad precision fp.append
THEN
fp.strip.trailing.zeros
THEN
ELSE
2drop
s" <FP-OUT-OF-RANGE>" fp.append
THEN
fp-output-pad fp-output-ptr @ over -
;
: FG. ( F: r -- )
(fg.) type space
;
: (F.) ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- }
fp-output-pad fp-output-ptr ! \ setup pointer
fp-represent-pad \ place to put number
fdup flog 1 s>f f+ f>s precision max
fp_precision_max min dup -> prec'
represent
( -- n flag1 flag2 )
IF
\ add '-' sign if negative
IF [char] - fp.hold
THEN
\ compare n with precision to see whether we must do scientific display
dup fp_precision_max >
IF \ use exponential notation
1 precision fp.move.decimal
fp.strip.trailing.zeros
[char] e fp.hold
1- (exp.) fp.append \ n
ELSE
dup 0>
IF
\ POSITIVE EXPONENT - place decimal point in middle
prec' fp.move.decimal
ELSE
\ NEGATIVE EXPONENT - use 0.000????
s" 0." fp.append
\ output leading zeros
dup negate precision min
fp.append.zeros
fp-represent-pad precision rot + fp.append
THEN
THEN
ELSE
2drop
s" <FP-OUT-OF-RANGE>" fp.append
THEN
fp-output-pad fp-output-ptr @ over -
;
: F. ( F: r -- )
(f.) type space
;
: F.S ( -- , print FP stack )
." FP> "
fdepth 0>
IF
fdepth 0
DO
cr?
fdepth i - 1- \ index of next float
fpick f. cr?
LOOP
ELSE
." empty"
THEN
cr
;
\ FP Input ----------------------------------------------------------
variable FP-REQUIRE-E \ must we put an E in FP numbers?
false fp-require-e ! \ violate ANSI !!
: >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag }
u 0= IF false exit THEN
false -> flag
0 -> nshift
\
\ check for minus sign
c-addr c@ [char] - = dup -> fsign
c-addr c@ [char] + = OR
IF 1 +-> c-addr -1 +-> u \ skip char
THEN
\
\ convert first set of digits
0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo
u' 0>
IF
\ convert optional second set of digits
c-addr c@ [char] . =
IF
dlo dhi c-addr 1+ u' 1- dup -> nshift >number
dup nshift - -> nshift
-> u' -> c-addr -> dhi -> dlo
THEN
\ convert exponent
u' 0>
IF
c-addr c@ [char] E =
c-addr c@ [char] e = OR
IF
1 +-> c-addr -1 +-> u' \ skip E char
u' 0>
IF
c-addr c@ [char] + = \ ignore + on exponent
IF
1 +-> c-addr -1 +-> u' \ skip char
THEN
c-addr u' ((number?))
num_type_single =
IF
nshift + -> nshift
true -> flag
THEN
ELSE
true -> flag \ allow "1E"
THEN
THEN
ELSE
\ only require E field if this variable is true
fp-require-e @ not -> flag
THEN
THEN
\ convert double precision int to float
flag
IF
dlo dhi d>f
10 s>f nshift s>f f** f* \ apply exponent
fsign
IF
fnegate
THEN
THEN
flag
;
3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER?
: (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number )
\ check to see if it is a valid float, if not use old (NUMBER?)
dup count >float
IF
drop NUM_TYPE_FLOAT
ELSE
(number?)
THEN
;
defer fp.old.number?
variable FP-IF-INIT
: FP.TERM ( -- , deinstall fp conversion )
fp-if-init @
IF
what's fp.old.number? is number?
fp-if-init off
THEN
;
: FP.INIT ( -- , install FP converion )
fp.term
what's number? is fp.old.number?
['] (fp.number?) is number?
fp-if-init on
." Floating point numeric conversion installed." cr
;
FP.INIT
if.forgotten fp.term
0 [IF]
23.8e-9 fconstant fsmall
1.0 fsmall f- fconstant falmost1
." Should be 1.0 = " falmost1 f. cr
: TSEGF ( r -f- , print in all formats )
." --------------------------------" cr
34 0
DO
fdup fs. 4 spaces fdup fe. 4 spaces
fdup fg. 4 spaces fdup f. cr
10.0 f/
LOOP
fdrop
;
: TFP
1.234e+22 tsegf
1.23456789e+22 tsegf
0.927 fsin 1.234e+22 f* tsegf
;
[THEN]
src/cmd/pforth/fth/forget.fth
+97
View File
@@ -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) ( <name> -- )
BL word findnfa
IF verify.forget
ELSE ." FORGET - couldn't find " count type cr abort
THEN
;
variable LAST-FORGET \ contains address of last if.forgotten frame
0 last-forget !
: IF.FORGOTTEN ( <name> -- , place links in dictionary without header )
bl word find
IF ( xt )
here \ start of frame
last-forget a@ a, \ Cell[0] = rel address of previous frame
last-forget a! \ point to this frame
compile, \ Cell[1] = xt for this frame
ELSE ." IF.FORGOTTEN - couldn't find " dup 9 dump cr count type cr abort
THEN
;
if.forgotten noop
: [FORGET] ( <name> -- , forget then exec forgotten words )
(forget)
last-forget
BEGIN a@ dup 0<> \ 19970701
IF dup here u> \ 19970701
IF dup cell+ x@ execute false
ELSE dup last-forget a! true
THEN
ELSE true
THEN
UNTIL drop
;
: FORGET ( <name> -- , execute latest [FORGET] )
" [FORGET]" find
IF execute
ELSE ." FORGET - couldn't find " count type cr abort
THEN
;
: ANEW ( -- , forget if defined then redefine )
>in @
bl word find
IF over >in ! forget
THEN drop
>in ! variable
;
: MARKER ( <name> -- , define a word that forgets itself when executed, ANS )
CREATE
latest namebase - \ convert to relocatable
, \ save for DOES>
DOES> ( -- body )
@ namebase + \ convert back to NFA
verify.forget
;
src/cmd/pforth/fth/history.fth
+513
View File
@@ -0,0 +1,513 @@
\ Command Line History
\
\ Author: Phil Burk
\ Copyright 1988 Phil Burk
\ Revised 2001 for pForth
0 [IF]
Requires an ANSI compatible terminal.
To get Windows computers to use ANSI mode in their DOS windows,
Add this line to "C:\CONFIG.SYS" then reboot.
device=c:\windows\command\ansi.sys
When command line history is on, you can use the UP and DOWN arrow to scroll
through previous commands. Use the LEFT and RIGHT arrows to edit within a line.
CONTROL-A moves to beginning of line.
CONTROL-E moves to end of line.
CONTROL-X erases entire line.
HISTORY# ( -- , dump history buffer with numbers)
HISTORY ( -- , dump history buffer )
XX ( line# -- , execute line x of history )
HISTORY.RESET ( -- , clear history tables )
HISTORY.ON ( -- , install history vectors )
HISTORY.OFF ( -- , uninstall history vectors )
[THEN]
include? ESC[ termio.fth
ANEW TASK-HISTORY.FTH
decimal
private{
\ You can expand the history buffer by increasing this constant!!!!!!!!!!
2048 constant KH_HISTORY_SIZE
create KH-HISTORY kh_history_size allot
KH-HISTORY kh_history_size erase
\ An entry in the history buffer consists of
\ byte - Count byte = N,
\ chars - N chars,
\ short - line number in Big Endian format,
\ byte - another Count byte = N, for reverse scan
\
\ The most recent entry is put at the beginning,
\ older entries are shifted up.
4 constant KH_LINE_EXTRA_SIZE ( 2 count bytes plus 2 size bytes )
: KH-END ( -- addr , end of history buffer )
kh-history kh_history_size +
;
: LINENUM@ ( addr -- w , stores in BigEndian format )
dup c@ 8 shift
swap 1+ c@ or
;
: LINENUM! ( w addr -- )
over -8 shift over c!
1+ c!
;
variable KH-LOOK ( cursor offset into history, point to 1st count byte of line )
variable KH-MAX
variable KH-COUNTER ( 16 bit counter for line # )
variable KH-SPAN ( total number of characters in line )
variable KH-MATCH-SPAN ( span for matching on shift-up )
variable KH-CURSOR ( points to next insertion point )
variable KH-ADDRESS ( address to store chars )
variable KH-INSIDE ( true if we are scrolling inside the history buffer )
: KH.MAKE.ROOM ( N -- , make room for N more bytes at beginning)
>r ( save N )
kh-history dup r@ + ( source dest )
kh_history_size r> - 0 max move
;
: KH.NEWEST.LINE ( -- addr count , most recent line )
kh-history count
;
: KH.REWIND ( -- , move cursor to most recent line )
0 kh-look !
;
: KH.CURRENT.ADDR ( -- $addr , count byte of current line )
kh-look @ kh-history +
;
: KH.CURRENT.LINE ( -- addr count )
kh.current.addr count
;
: KH.COMPARE ( addr count -- flag , true if redundant )
kh.newest.line compare 0= \ note: ANSI COMPARE is different than JForth days
;
: KH.NUM.ADDR ( -- addr , address of current line's line count )
kh.current.line +
;
: KH.CURRENT.NUM ( -- # , number of current line )
kh.num.addr LINENUM@
;
: KH.ADDR++ ( $addr -- $addr' , convert one kh to previous )
count + 3 +
;
: KH.ADDR-- ( $addr -- $addr' , convert one kh to next )
dup 1- c@ \ get next lines endcount
4 + \ account for lineNum and two count bytes
- \ calc previous address
;
: KH.ENDCOUNT.ADDR ( -- addr , address of current end count )
kh.num.addr 2+
;
: KH.ADD.LINE ( addr count -- )
dup 256 >
IF ." KH.ADD.LINE - Too big for history!" 2drop
ELSE ( add to end )
\ Compare with most recent line.
2dup kh.compare
IF 2drop
ELSE
>r ( save count )
\ Set look pointer to point to first count byte of last string.
0 kh-look !
\ Make room for this line of text and line header.
\ PLB20100823 Was cell+ which broke on 64-bit code.
r@ KH_LINE_EXTRA_SIZE + kh.make.room
\ Set count bytes at beginning and end.
r@ kh-history c! ( start count )
r@ kh.endcount.addr c!
kh-counter @ kh.num.addr LINENUM! ( line )
\ Number lines modulo 1024
kh-counter @ 1+ $ 3FF and kh-counter !
kh-history 1+ ( calc destination )
r> cmove ( copy chars into space )
THEN
THEN
;
: KH.BACKUP.LINE { | cantmove addr' -- cantmove , advance KH-LOOK if in bounds }
true -> cantmove ( default flag, at end of history )
\ KH-LOOK points to count at start of current line
kh.current.addr c@ \ do we have any lines?
IF
kh.current.addr kh.addr++ -> addr'
addr' kh-end U< \ within bounds?
IF
addr' c@ \ older line has chars?
IF
addr' kh-history - kh-look !
false -> cantmove
THEN
THEN
THEN
cantmove
;
: KH.FORWARD.LINE ( -- cantmove? )
kh-look @ 0= dup not
IF kh.current.addr kh.addr--
kh-history - kh-look !
THEN
;
: KH.OLDEST.LINE ( -- addr count | 0, oldest in buffer )
BEGIN kh.backup.line
UNTIL
kh.current.line dup 0=
IF
nip
THEN
;
: KH.FIND.LINE ( line# -- $addr )
kh.rewind
BEGIN kh.current.num over -
WHILE kh.backup.line
IF ." Line not in History Buffer!" cr drop 0 exit
THEN
REPEAT
drop kh.current.addr
;
: KH-BUFFER ( -- buffer )
kh-address @
;
: KH.RETURN ( -- , move to beginning of line )
0 out !
13 emit
;
: KH.REPLACE.LINE ( addr count -- , make this the current line of input )
kh.return
tio.erase.eol
dup kh-span !
dup kh-cursor !
2dup kh-buffer swap cmove
type
;
: KH.GET.MATCH ( -- , search for line with same start )
kh-match-span @ 0= ( keep length for multiple matches )
IF kh-span @ kh-match-span !
THEN
BEGIN
kh.backup.line not
WHILE
kh.current.line drop
kh-buffer kh-match-span @ text=
IF kh.current.line kh.replace.line
exit
THEN
REPEAT
;
: KH.FAR.RIGHT
kh-span @ kh-cursor @ - dup 0>
IF
tio.forwards
kh-span @ kh-cursor !
ELSE drop
THEN
;
: KH.FAR.LEFT ( -- )
kh.return
kh-cursor off
;
: KH.GET.OLDER ( -- , goto previous line )
kh-inside @
IF kh.backup.line drop
THEN
kh.current.line kh.replace.line
kh-inside on
;
: KH.GET.NEWER ( -- , next line )
kh.forward.line
IF
kh-inside off
tib 0
ELSE kh.current.line
THEN
kh.replace.line
;
: KH.CLEAR.LINE ( -- , rewind history scrolling and clear line )
kh.rewind
tib 0 kh.replace.line
kh-inside off
;
: KH.GO.RIGHT ( -- )
kh-cursor @ kh-span @ <
IF 1 kh-cursor +!
1 tio.forwards
THEN
;
: KH.GO.LEFT ( -- )
kh-cursor @ ?dup
IF 1- kh-cursor !
1 tio.backwards
THEN
;
: KH.REFRESH ( -- , redraw current line as is )
kh.return
kh-buffer kh-span @ type
tio.erase.eol
kh.return
kh-cursor @ ?dup
IF tio.forwards
THEN
kh-span @ out !
;
: KH.BACKSPACE ( -- , backspace character from buffer and screen )
kh-cursor @ ?dup ( past 0? )
IF kh-span @ <
IF ( inside line )
kh-buffer kh-cursor @ + ( -- source )
dup 1- ( -- source dest )
kh-span @ kh-cursor @ - cmove
\ ." Deleted!" cr
ELSE
backspace
THEN
-1 kh-span +!
-1 kh-cursor +!
ELSE bell
THEN
kh.refresh
;
: KH.DELETE ( -- , forward delete )
kh-cursor @ kh-span @ < ( before end )
IF ( inside line )
kh-buffer kh-cursor @ + 1+ ( -- source )
dup 1- ( -- source dest )
kh-span @ kh-cursor @ - 0 max cmove
-1 kh-span +!
kh.refresh
THEN
;
: KH.HANDLE.WINDOWS.KEY ( char -- , handle fkeys or arrows used by Windows ANSI.SYS )
CASE
$ 8D OF kh.get.match ENDOF
0 kh-match-span ! ( reset if any other key )
$ 48 OF kh.get.older ENDOF
$ 50 OF kh.get.newer ENDOF
$ 4D OF kh.go.right ENDOF
$ 4B OF kh.go.left ENDOF
$ 91 OF kh.clear.line ENDOF
$ 74 OF kh.far.right ENDOF
$ 73 OF kh.far.left ENDOF
$ 53 OF kh.delete ENDOF
ENDCASE
;
: KH.HANDLE.ANSI.KEY ( char -- , handle fkeys or arrows used by ANSI terminal )
CASE
$ 41 OF kh.get.older ENDOF
$ 42 OF kh.get.newer ENDOF
$ 43 OF kh.go.right ENDOF
$ 44 OF kh.go.left ENDOF
ENDCASE
;
: KH.SPECIAL.KEY ( char -- true | false , handle fkeys or arrows, true if handled )
true >r
CASE
$ E0 OF key kh.handle.windows.key
ENDOF
ASCII_ESCAPE OF
key dup $ 4F = \ for TELNET
$ 5B = OR \ for regular ANSI terminals
IF
key kh.handle.ansi.key
ELSE
rdrop false >r
THEN
ENDOF
ASCII_BACKSPACE OF kh.backspace ENDOF
ASCII_DELETE OF kh.backspace ENDOF
ASCII_CTRL_X OF kh.clear.line ENDOF
ASCII_CTRL_A OF kh.far.left ENDOF
ASCII_CTRL_E OF kh.far.right ENDOF
rdrop false >r
ENDCASE
r>
;
: KH.SMART.KEY ( -- char )
BEGIN
key dup kh.special.key
WHILE
drop
REPEAT
;
: KH.INSCHAR { charc | repaint -- }
false -> repaint
kh-cursor @ kh-span @ <
IF
\ Move characters up
kh-buffer kh-cursor @ + ( -- source )
dup 1+ ( -- source dest )
kh-span @ kh-cursor @ - cmove>
true -> repaint
THEN
\ write character to buffer
charc kh-buffer kh-cursor @ + c!
1 kh-cursor +!
1 kh-span +!
repaint
IF kh.refresh
ELSE charc emit
THEN
;
: EOL? ( char -- flag , true if an end of line character )
dup 13 =
swap 10 = OR
;
: KH.GETLINE ( max -- )
kh-max !
kh-span off
kh-cursor off
kh-inside off
kh.rewind
0 kh-match-span !
BEGIN
kh-max @ kh-span @ >
IF kh.smart.key
dup EOL? not ( <cr?> )
ELSE 0 false
THEN ( -- char flag )
WHILE ( -- char )
kh.inschar
REPEAT drop
kh-span @ kh-cursor @ - ?dup
IF tio.forwards ( move to end of line )
THEN
space
flushemit
;
: KH.ACCEPT ( addr max -- numChars )
swap kh-address !
kh.getline
kh-span @ 0>
IF kh-buffer kh-span @ kh.add.line
THEN
kh-span @
;
: TEST.HISTORY
4 0 DO
pad 128 kh.accept
cr pad swap type cr
LOOP
;
}private
: HISTORY# ( -- , dump history buffer with numbers)
cr kh.oldest.line ?dup
IF
BEGIN kh.current.num 3 .r ." ) " type ?pause cr
kh.forward.line 0=
WHILE kh.current.line
REPEAT
THEN
;
: HISTORY ( -- , dump history buffer )
cr kh.oldest.line ?dup
IF
BEGIN type ?pause cr
kh.forward.line 0=
WHILE kh.current.line
REPEAT
THEN
;
: XX ( line# -- , execute line x of history )
kh.find.line ?dup
IF count evaluate
THEN
;
: HISTORY.RESET ( -- , clear history tables )
kh-history kh_history_size erase
kh-counter off
;
: HISTORY.ON ( -- , install history vectors )
history.reset
what's accept ['] (accept) =
IF ['] kh.accept is accept
THEN
;
: HISTORY.OFF ( -- , uninstall history vectors )
what's accept ['] kh.accept =
IF ['] (accept) is accept
THEN
;
: AUTO.INIT
auto.init
history.on
;
: AUTO.TERM
history.off
auto.init
;
if.forgotten history.off
0 [IF]
history.reset
history.on
[THEN]
src/cmd/pforth/fth/loadhist.fth
+7
View File
@@ -0,0 +1,7 @@
\ Load history and save new dictionary.
\ This is not part of the standard build because some computers
\ do not support ANSI terminal I/O.
include? ESC[ termio.fth
include? HISTORY history.fth
c" pforth.dic" save-forth
src/cmd/pforth/fth/loadp4th.fth
+46
View File
@@ -0,0 +1,46 @@
\ @(#) 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? [if] condcomp.fth
\ load floating point support if basic support is in kernel
exists? F*
[IF] include? task-floats.fth floats.fth
[THEN]
\ useful but optional stuff follows --------------------
include? task-member.fth member.fth
include? :struct c_struct.fth
include? smif{ smart_if.fth
include? file? filefind.fth
include? see see.fth
include? words.like wordslik.fth
include? trace trace.fth
include? ESC[ termio.fth
include? HISTORY history.fth
include? SDAD savedicd.fth
map
src/cmd/pforth/fth/locals.fth
+77
View File
@@ -0,0 +1,77 @@
\ @(#) $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.
\ MOD: PLB 2/11/00 Allow EOL and \ between { }.
anew task-locals.fth
private{
variable loc-temp-mode \ if true, declaring temporary variables
variable loc-comment-mode \ if true, in comment section
variable loc-done
}private
: { ( <local-declaration}> -- )
loc-done off
loc-temp-mode off
loc-comment-mode off
BEGIN
bl word count
dup 0> \ make sure we are not at the end of a line
IF
over c@
CASE
\ handle special characters
ascii } OF loc-done on 2drop ENDOF
ascii | OF loc-temp-mode on 2drop ENDOF
ascii - OF loc-comment-mode on 2drop ENDOF
ascii ) OF ." { ... ) imbalance!" cr abort ENDOF
ascii \ OF postpone \ 2drop ENDOF \ Forth comment
\ process name
>r ( save char )
( addr len )
loc-comment-mode @
IF
2drop
ELSE
\ if in temporary mode, assign local var = 0
loc-temp-mode @
IF compile false
THEN
\ otherwise take value from stack
(local)
THEN
r>
ENDCASE
ELSE
2drop refill 0= abort" End of input while defining local variables!"
THEN
loc-done @
UNTIL
0 0 (local)
; immediate
privatize
\ tests
: tlv1 { n -- } n dup n * dup n * ;
: tlv2 { v1 v2 | l1 l2 -- }
v1 . v2 . cr
v1 v2 + -> l1
l1 . l2 . cr
;
src/cmd/pforth/fth/math.fth
+89
View File
@@ -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
;
src/cmd/pforth/fth/member.fth
+155
View File
@@ -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 ( <thing> -- pfa , get pfa of thing or error )
find.body not
IF cr count type ." ???"
true abort" OB.FINDIT - Word not found!"
THEN
;
: OB.STATS ( member_pfa -- offset #bytes )
dup ob.offset@ swap
ob.size@
;
: OB.STATS? ( <member> -- offset #bytes )
ob.findit ob.stats
;
: SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )
ob.findit @
?literal
; immediate
\ Basic word for defining structure members.
: BYTES ( #bytes -- , error check for structure only )
ob-state @ ob_def_struct = not
abort" BYTES - Only valid in :STRUCT definitions."
ob.member
;
\ Declare various types of structure members.
\ Negative size indicates a signed member.
: BYTE ( <name> -- , declare space for a byte )
-1 bytes ;
: SHORT ( <name> -- , declare space for a 16 bit value )
-2 bytes ;
: LONG ( <name> -- )
cell bytes ;
: UBYTE ( <name> -- , declare space for signed byte )
1 bytes ;
: USHORT ( <name> -- , declare space for signed 16 bit value )
2 bytes ;
\ Aliases
: APTR ( <name> -- ) long ;
: RPTR ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001
: ULONG ( <name> -- ) long ;
: STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
[compile] sizeof() bytes
;
src/cmd/pforth/fth/misc1.fth
+175
View File
@@ -0,0 +1,175 @@
\ @(#) 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 ;
: (WARNING") ( flag $message -- )
swap
IF count type
ELSE drop
THEN
;
: WARNING" ( flag <message> -- , print warning if true. )
[compile] " ( compile message )
state @
IF compile (warning")
ELSE (warning")
THEN
; IMMEDIATE
: (ABORT") ( flag $message -- )
swap
IF count type cr abort
ELSE drop
THEN
;
: ABORT" ( flag <message> -- , print warning if true. )
[compile] " ( compile message )
state @
IF compile (abort")
ELSE (abort")
THEN
; IMMEDIATE
: ?PAUSE ( -- , Pause if key hit. )
?terminal
IF key drop cr ." Hit space to continue, any other key to abort:"
key dup emit BL = not abort" Terminated"
THEN
;
60 constant #cols
: CR? ( -- , do CR if near end )
OUT @ #cols 16 - 10 max >
IF cr
THEN
;
: CLS ( -- clear screen )
40 0 do cr loop
;
: PAGE ( -- , clear screen, compatible with Brodie )
cls
;
: $ ( <number> -- N , convert next number as hex )
base @ hex
32 lword number? num_type_single = not
abort" Not a single number!"
swap base !
state @
IF [compile] literal
THEN
; immediate
: .HX ( nibble -- )
dup 9 >
IF $ 37
ELSE $ 30
THEN + emit
;
variable TAB-WIDTH 8 TAB-WIDTH !
: TAB ( -- , tab over to next stop )
out @ tab-width @ mod
tab-width @ swap - spaces
;
\ Vocabulary listing
: WORDS ( -- )
0 latest
BEGIN dup 0<>
WHILE dup id. tab cr? ?pause
prevname
swap 1+ swap
REPEAT drop
cr . ." words" cr
;
: VLIST words ;
variable CLOSEST-NFA
variable CLOSEST-XT
: >NAME ( xt -- nfa , scans dictionary for closest nfa, SLOW! )
0 closest-nfa !
0 closest-xt !
latest
BEGIN dup 0<>
IF ( -- addr nfa ) 2dup name> ( addr nfa addr xt ) <
IF true ( addr below this cfa, can't be it)
ELSE ( -- addr nfa )
2dup name> ( addr nfa addr xt ) =
IF ( found it ! ) dup closest-nfa ! false
ELSE dup name> closest-xt @ >
IF dup closest-nfa ! dup name> closest-xt !
THEN
true
THEN
THEN
ELSE false
THEN
WHILE
prevname
REPEAT ( -- cfa nfa )
2drop
closest-nfa @
;
: @EXECUTE ( addr -- , execute if non-zero )
x@ ?dup
IF execute
THEN
;
: TOLOWER ( char -- char_lower )
dup ascii [ <
IF dup ascii @ >
IF ascii A - ascii a +
THEN
THEN
;
: EVALUATE ( i*x c-addr num -- j*x , evaluate string of Forth )
\ save current input state and switch to passed in string
source >r >r
set-source
-1 push-source-id
>in @ >r
0 >in !
\ interpret the string
interpret
\ restore input state
pop-source-id drop
r> >in !
r> r> set-source
;
: \S ( -- , comment out rest of file )
source-id
IF
BEGIN \ using REFILL is safer than popping SOURCE-ID
refill 0=
UNTIL
THEN
;
src/cmd/pforth/fth/misc2.fth
+235
View File
@@ -0,0 +1,235 @@
\ @(#) misc2.fth 98/01/26 1.2
\ Utilities for PForth extracted from HMSL
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license. The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.
\
\ 00001 9/14/92 Added call, 'c w->s
\ 00002 11/23/92 Moved redef of : to loadcom.fth
anew task-misc2.fth
: 'N ( <name> -- , make 'n state smart )
bl word find
IF
state @
IF namebase - ( make nfa relocatable )
[compile] literal ( store nfa of word to be compiled )
compile namebase+
THEN
THEN
; IMMEDIATE
: ?LITERAL ( n -- , do literal if compiling )
state @
IF [compile] literal
THEN
;
: 'c ( <name> -- xt , state sensitive ' )
' ?literal
; immediate
variable if-debug
decimal
create msec-delay 10000 , ( default for SUN )
: (MSEC) ( #msecs -- )
0
do msec-delay @ 0
do loop
loop
;
defer msec
' (msec) is msec
: SHIFT ( val n -- val<<n )
dup 0<
IF negate arshift
ELSE lshift
THEN
;
variable rand-seed here rand-seed !
: random ( -- random_number )
rand-seed @
31421 * 6927 +
65535 and dup rand-seed !
;
: choose ( range -- random_number , in range )
random * -16 shift
;
: wchoose ( hi lo -- random_number )
tuck - choose +
;
\ sort top two items on stack.
: 2sort ( a b -- a<b | b<a , largest on top of stack)
2dup >
if swap
then
;
\ sort top two items on stack.
: -2sort ( a b -- a>b | b>a , smallest on top of stack)
2dup <
if swap
then
;
: barray ( #bytes -- ) ( index -- addr )
create allot
does> +
;
: warray ( #words -- ) ( index -- addr )
create 2* allot
does> swap 2* +
;
: array ( #cells -- ) ( index -- addr )
create cell* allot
does> swap cell* +
;
: .bin ( n -- , print in binary )
base @ binary swap . base !
;
: .dec ( n -- )
base @ decimal swap . base !
;
: .hex ( n -- )
base @ hex swap . base !
;
: B->S ( c -- c' , sign extend byte )
dup $ 80 and
IF
$ FFFFFF00 or
ELSE
$ 000000FF and
THEN
;
: W->S ( 16bit-signed -- 32bit-signed )
dup $ 8000 and
if
$ FFFF0000 or
ELSE
$ 0000FFFF and
then
;
: WITHIN { n1 n2 n3 -- flag }
n2 n3 <=
IF
n2 n1 <=
n1 n3 < AND
ELSE
n2 n1 <=
n1 n3 < OR
THEN
;
: MOVE ( src dst num -- )
>r 2dup - 0<
IF
r> CMOVE>
ELSE
r> CMOVE
THEN
;
: ERASE ( caddr num -- )
dup 0>
IF
0 fill
ELSE
2drop
THEN
;
: BLANK ( addr u -- , set memory to blank )
DUP 0>
IF
BL FILL
ELSE
2DROP
THEN
;
\ Obsolete but included for CORE EXT word set.
: QUERY REFILL DROP ;
VARIABLE SPAN
: EXPECT accept span ! ;
: TIB source drop ;
: UNUSED ( -- unused , dictionary space )
CODELIMIT HERE -
;
: MAP ( -- , dump interesting dictionary info )
." Code Segment" cr
." CODEBASE = " codebase .hex cr
." HERE = " here .hex cr
." CODELIMIT = " codelimit .hex cr
." Compiled Code Size = " here codebase - . cr
." CODE-SIZE = " code-size @ . cr
." Code Room UNUSED = " UNUSED . cr
." Name Segment" cr
." NAMEBASE = " namebase .hex cr
." HEADERS-PTR @ = " headers-ptr @ .hex cr
." NAMELIMIT = " namelimit .hex cr
." CONTEXT @ = " context @ .hex cr
." LATEST = " latest .hex ." = " latest id. cr
." Compiled Name size = " headers-ptr @ namebase - . cr
." HEADERS-SIZE = " headers-size @ . cr
." Name Room Left = " namelimit headers-ptr @ - . cr
;
\ Search for substring S2 in S1
: SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag }
\ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr
\ if true, s1 contains s2 at addr3 with cnt3 chars remaining
\ if false, s3 = s1
addr1 -> addr3
cnt1 -> cnt3
cnt1 cnt2 < not
IF
cnt1 cnt2 - 1+ 0
DO
true -> flag
cnt2 0
?DO
addr2 i chars + c@
addr1 i j + chars + c@ <> \ mismatch?
IF
false -> flag
LEAVE
THEN
LOOP
flag
IF
addr1 i chars + -> addr3
cnt1 i - -> cnt3
LEAVE
THEN
LOOP
THEN
addr3 cnt3 flag
;
src/cmd/pforth/fth/numberio.fth
+204
View File
@@ -0,0 +1,204 @@
\ @(#) numberio.fth 98/01/26 1.2
\ numberio.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-numberio.fth
decimal
\ ------------------------ INPUT -------------------------------
\ Convert a single character to a number in the given base.
: DIGIT ( char base -- n true | char false )
>r
\ convert lower to upper
dup ascii a < not
IF
ascii a - ascii A +
THEN
\
dup dup ascii A 1- >
IF ascii A - ascii 9 + 1+
ELSE ( char char )
dup ascii 9 >
IF
( between 9 and A is bad )
drop 0 ( trigger error below )
THEN
THEN
ascii 0 -
dup r> <
IF dup 1+ 0>
IF nip true
ELSE drop FALSE
THEN
ELSE drop FALSE
THEN
;
: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )
>r
BEGIN
r@ 0> \ any characters left?
IF
dup c@ base @
digit ( ud1 c-addr , n true | char false )
IF
TRUE
ELSE
drop FALSE
THEN
ELSE
false
THEN
WHILE ( -- ud1 c-addr n )
swap >r ( -- ud1lo ud1hi n )
swap base @ ( -- ud1lo n ud1hi base )
um* drop ( -- ud1lo n ud1hi*baselo )
rot base @ ( -- n ud1hi*baselo ud1lo base )
um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )
d+ ( -- ud2 )
r> 1+ \ increment char*
r> 1- >r \ decrement count
REPEAT
r>
;
\ obsolete
: CONVERT ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )
256 >NUMBER DROP
;
0 constant NUM_TYPE_BAD
1 constant NUM_TYPE_SINGLE
2 constant NUM_TYPE_DOUBLE
\ This is similar to the F83 NUMBER? except that it returns a number type
\ and then either a single or double precision number.
: ((NUMBER?)) ( c-addr u -- 0 | n 1 | d 2 , convert string to number )
dup 0= IF 2drop NUM_TYPE_BAD exit THEN \ any chars?
\ prepare for >number
0 0 2swap ( 0 0 c-addr cnt )
\ 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
;
src/cmd/pforth/fth/private.fth
+48
View File
@@ -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 !
;
src/cmd/pforth/fth/savedicd.fth
+177
View File
@@ -0,0 +1,177 @@
\ @(#) savedicd.fth 98/01/26 1.2
\ Save dictionary as data table.
\
\ Author: Phil Burk
\ Copyright 1987 Phil Burk
\ All Rights Reserved.
\
\ 970311 PLB Fixed problem with calling SDAD when in HEX mode.
\ 20010606 PLB Fixed AUTO.INIT , started with ';' !!
decimal
ANEW TASK-SAVE_DIC_AS_DATA
\ !!! set to 4 for minimally sized dictionary to prevent DIAB
\ compiler from crashing! Allocate more space in pForth.
4 constant SDAD_NAMES_EXTRA \ space for additional names
4 constant SDAD_CODE_EXTRA \ space for additional names
\ buffer the file I/O for better performance
256 constant SDAD_BUFFER_SIZE
create SDAD-BUFFER SDAD_BUFFER_SIZE allot
variable SDAD-BUFFER-INDEX
variable SDAD-BUFFER-FID
0 SDAD-BUFFER-FID !
: SDAD.FLUSH ( -- ior )
sdad-buffer sdad-buffer-index @ \ data
\ 2dup type
sdad-buffer-fid @ write-file
0 sdad-buffer-index !
;
: SDAD.EMIT ( char -- )
sdad-buffer-index @ sdad_buffer_size >=
IF
sdad.flush abort" SDAD.FLUSH failed!"
THEN
\
sdad-buffer sdad-buffer-index @ + c!
1 sdad-buffer-index +!
;
: SDAD.TYPE ( c-addr cnt -- )
0 DO
dup c@ sdad.emit \ char to buffer
1+ \ advance char pointer
LOOP
drop
;
: $SDAD.LINE ( $addr -- )
count sdad.type
EOL sdad.emit
;
: (U8.) ( u -- a l , unsigned conversion, at least 8 digits )
0 <# # # # # # # # #S #>
;
: (U2.) ( u -- a l , unsigned conversion, at least 2 digits )
0 <# # #S #>
;
: SDAD.CLOSE ( -- )
SDAD-BUFFER-FID @ ?dup
IF
sdad.flush abort" SDAD.FLUSH failed!"
close-file drop
0 SDAD-BUFFER-FID !
THEN
;
: SDAD.OPEN ( -- ior, open file )
sdad.close
s" pfdicdat.h" r/w create-file dup >r
IF
drop ." Could not create file pfdicdat.h" cr
ELSE
SDAD-BUFFER-FID !
THEN
r>
;
: SDAD.DUMP.HEX { val -- }
base @ >r hex
s" 0x" sdad.type
val (u8.) sdad.type
r> base !
;
: SDAD.DUMP.HEX,
s" " sdad.type
sdad.dump.hex
ascii , sdad.emit
;
: SDAD.DUMP.HEX.BYTE { val -- }
base @ >r hex
s" 0x" sdad.type
val (u2.) sdad.type
r> base !
;
: SDAD.DUMP.HEX.BYTE,
sdad.dump.hex.byte
ascii , sdad.emit
;
: SDAD.DUMP.DATA { start-address end-address num-zeros | num-bytes -- }
end-address start-address - -> num-bytes
num-bytes 0
?DO
i $ 7FF and 0= IF ." 0x" i .hex cr THEN \ progress report
i 15 and 0=
IF
EOL sdad.emit
s" /* " sdad.type
i sdad.dump.hex
s" : */ " sdad.type
THEN \ 16 bytes per line, print offset
start-address i + c@
sdad.dump.hex.byte,
LOOP
\
num-zeros 0
?DO
i $ 7FF and 0= IF i . cr THEN \ progress report
i 15 and 0= IF EOL sdad.emit THEN \ 15 numbers per line
0 sdad.dump.hex.byte,
LOOP
;
: SDAD.DEFINE { $name val -- }
s" #define " sdad.type
$name count sdad.type
s" (" sdad.type
val sdad.dump.hex
c" )" $sdad.line
;
: IS.LITTLE.ENDIAN? ( -- flag , is Forth in Little Endian mode? )
1 pad !
pad c@
;
: SDAD { | fid -- }
sdad.open abort" sdad.open failed!"
\ Write headers.
c" /* This file generated by the Forth command SDAD */" $sdad.line
c" HEADERPTR" headers-ptr @ namebase - sdad.define
c" RELCONTEXT" context @ namebase - sdad.define
c" CODEPTR" here codebase - sdad.define
c" IF_LITTLE_ENDIAN" IS.LITTLE.ENDIAN? IF 1 ELSE 0 THEN sdad.define
." Saving Names" cr
s" static const uint8_t MinDicNames[] = {" sdad.type
namebase headers-ptr @ SDAD_NAMES_EXTRA sdad.dump.data
EOL sdad.emit
c" };" $sdad.line
." Saving Code" cr
s" static const uint8_t MinDicCode[] = {" sdad.type
codebase here SDAD_CODE_EXTRA sdad.dump.data
EOL sdad.emit
c" };" $sdad.line
sdad.close
;
if.forgotten sdad.close
: AUTO.INIT ( -- , init at launch )
auto.init \ daisy chain initialization
0 SDAD-BUFFER-FID !
0 SDAD-BUFFER-INDEX !
;
." Enter: SDAD" cr
src/cmd/pforth/fth/see.fth
+218
View File
@@ -0,0 +1,218 @@
\ @(#) see.fth 98/01/26 1.4
\ SEE ( <name> -- , disassemble pForth word )
\
\ Copyright 1996 Phil Burk
' file? >code rfence a!
anew task-see.fth
: .XT ( xt -- , print execution tokens name )
>name
dup c@ flag_immediate and
IF
." POSTPONE "
THEN
id. space
;
\ dictionary may be defined as byte code or cell code
0 constant BYTE_CODE
BYTE_CODE [IF]
: CODE@ ( addr -- xt , fetch from code space ) C@ ;
1 constant CODE_CELL
.( BYTE_CODE not implemented) abort
[ELSE]
: CODE@ ( addr -- xt , fetch from code space ) @ ;
CELL constant CODE_CELL
[THEN]
private{
0 value see_level \ level of conditional imdentation
0 value see_addr \ address of next token
0 value see_out
: SEE.INDENT.BY ( -- n )
see_level 1+ 1 max 4 *
;
: SEE.CR
>newline
see_addr ." ( ".hex ." )"
see.indent.by spaces
0 -> see_out
;
: SEE.NEWLINE
see_out 0>
IF see.cr
THEN
;
: SEE.CR?
see_out 6 >
IF
see.newline
THEN
;
: SEE.OUT+
1 +-> see_out
;
: SEE.ADVANCE
code_cell +-> see_addr
;
: SEE.GET.INLINE ( -- n )
see_addr @
;
: SEE.GET.TARGET ( -- branch-target-addr )
see_addr @ see_addr +
;
: SEE.SHOW.LIT ( -- )
see.get.inline .
see.advance
see.out+
;
exists? F* [IF]
: SEE.SHOW.FLIT ( -- )
see_addr f@ f.
1 floats +-> see_addr
see.out+
;
[THEN]
: SEE.SHOW.ALIT ( -- )
see.get.inline >name id. space
see.advance
see.out+
;
: SEE.SHOW.STRING ( -- )
see_addr count 2dup + aligned -> see_addr type
see.out+
;
: SEE.SHOW.TARGET ( -- )
see.get.target .hex see.advance
;
: SEE.BRANCH ( -- addr | , handle branch )
-1 +-> see_level
see.newline
see.get.inline 0>
IF \ forward branch
." ELSE "
see.get.target \ calculate address of target
1 +-> see_level
nip \ remove old address for THEN
ELSE
." REPEAT " see.get.target .hex
drop \ remove old address for THEN
THEN
see.advance
see.cr
;
: SEE.0BRANCH ( -- addr | , handle 0branch )
see.newline
see.get.inline 0>
IF \ forward branch
." IF or WHILE "
see.get.target \ calculate adress of target
1 +-> see_level
ELSE
." UNTIL=>" see.get.target .hex
THEN
see.advance
see.cr
;
: SEE.XT { xt -- }
xt
CASE
0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0 -> see_addr THEN ENDOF
['] (LITERAL) OF see.show.lit ENDOF
['] (ALITERAL) OF see.show.alit ENDOF
[ exists? (FLITERAL) [IF] ]
['] (FLITERAL) OF see.show.flit ENDOF
[ [THEN] ]
['] BRANCH OF see.branch ENDOF
['] 0BRANCH OF see.0branch ENDOF
['] (LOOP) OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr ENDOF
['] (+LOOP) OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr ENDOF
['] (DO) OF see.newline ." DO" 1 +-> see_level see.cr ENDOF
['] (?DO) OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF
['] (.") OF .' ." ' see.show.string .' " ' ENDOF
['] (C") OF .' C" ' see.show.string .' " ' ENDOF
['] (S") OF .' S" ' see.show.string .' " ' ENDOF
see.cr? xt .xt see.out+
ENDCASE
;
: (SEE) { cfa | xt -- }
0 -> see_level
cfa -> see_addr
see.cr
0 \ fake address for THEN handler
BEGIN
see_addr code@ -> xt
BEGIN
dup see_addr ( >newline .s ) =
WHILE
-1 +-> see_level see.newline
." THEN " see.cr
drop
REPEAT
CODE_CELL +-> see_addr
xt see.xt
see_addr 0=
UNTIL
cr
0= not abort" SEE conditional analyser nesting failed!"
;
}PRIVATE
: SEE ( <name> -- , disassemble )
'
dup ['] FIRST_COLON >
IF
>code (see)
ELSE
>name id.
." is primitive defined in 'C' kernel." cr
THEN
;
PRIVATIZE
0 [IF]
: SEE.JOKE
dup swap drop
;
: SEE.IF
IF
." hello" cr
ELSE
." bye" cr
THEN
see.joke
;
: SEE.DO
4 0
DO
i . cr
LOOP
;
: SEE."
." Here are some strings." cr
c" Forth string." count type cr
s" Addr/Cnt string" type cr
;
[THEN]
src/cmd/pforth/fth/siev.fth
+31
View File
@@ -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
;
src/cmd/pforth/fth/smart_if.fth
+57
View File
@@ -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
src/cmd/pforth/fth/strings.fth
+97
View File
@@ -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 * + cell+
;
\ Compare two strings
: $= ( $1 $2 -- flag , true if equal )
-1 -rot
dup c@ 1+ 0
DO dup c@ tolower
2 pick c@ tolower -
IF rot drop 0 -rot LEAVE
THEN
1+ swap 1+ swap
LOOP 2drop
;
: TEXT= ( addr1 addr2 count -- flag )
>r -1 -rot
r> 0
DO dup c@ tolower
2 pick c@ tolower -
IF rot drop 0 -rot LEAVE
THEN
1+ swap 1+ swap
LOOP 2drop
;
: TEXT=? ( addr1 count addr2 -- flag , for JForth compatibility )
swap text=
;
: $MATCH? ( $string1 $string2 -- flag , case INsensitive )
dup c@ 1+ text=
;
: INDEX ( $string char -- false | address_char true , search for char in string )
>r >r 0 r> r>
over c@ 1+ 1
DO over i + c@ over =
IF rot drop
over i + rot rot LEAVE
THEN
LOOP 2drop
?dup 0= 0=
;
: $APPEND.CHAR ( $string char -- ) \ ugly stack diagram
over count chars + c!
dup c@ 1+ swap c!
;
\ ----------------------------------------------
: ($ROM) ( index address -- $string )
( -- index address )
swap 0
DO dup c@ 1+ + aligned
LOOP
;
: $ROM ( packed array of strings, unalterable )
CREATE ( <name> -- )
DOES> ( index -- $string ) ($rom)
;
: TEXTROM ( packed array of strings, unalterable )
CREATE ( <name> -- )
DOES> ( index -- address count ) ($rom) count
;
\ -----------------------------------------------
src/cmd/pforth/fth/system.fth
+825
View File
@@ -0,0 +1,825 @@
: FIRST_COLON ;
: LATEST context @ ;
: FLAG_IMMEDIATE 64 ;
: IMMEDIATE
latest dup c@ flag_immediate OR
swap c!
;
: ( 41 word drop ; immediate
( That was the definition for the comment word. )
( Now we can add comments to what we are doing! )
( Note that we are in decimal numeric input mode. )
: \ ( <line> -- , comment out rest of line )
EOL word drop
; immediate
\ 1 echo ! \ Uncomment this line to echo Forth code while compiling.
\ *********************************************************************
\ This is another style of comment that is common in Forth.
\ pFORTH - Portable Forth System
\ Based on HMSL Forth
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, 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 !
;
: CELL+ ( n -- n+cell ) cell + ;
: CELL- ( n -- n+cell ) cell - ;
: CELL* ( n -- n*cell ) cells ;
: CHAR+ ( n -- n+size_of_char ) 1+ ;
: CHARS ( n -- n*size_of_char , don't do anything) ; immediate
\ useful stack manipulation words
: -ROT ( a b c -- c a b )
rot rot
;
: 3DUP ( a b c -- a b c a b c )
2 pick 2 pick 2 pick
;
: 2DROP ( a b -- )
drop drop
;
: NIP ( a b -- b )
swap drop
;
: TUCK ( a b -- b a b )
swap over
;
: <= ( a b -- f , true if A <= b )
> 0=
;
: >= ( a b -- f , true if A >= b )
< 0=
;
: INVERT ( n -- 1'comp )
-1 xor
;
: NOT ( n -- !n , logical negation )
0=
;
: NEGATE ( n -- -n )
0 swap -
;
: DNEGATE ( d -- -d , negate by doing 0-d )
0 0 2swap d-
;
\ --------------------------------------------------------------------
: ID. ( nfa -- )
count 31 and type
;
: DECIMAL 10 base ! ;
: OCTAL 8 base ! ;
: HEX 16 base ! ;
: BINARY 2 base ! ;
: PAD ( -- addr )
here 128 +
;
: $MOVE ( $src $dst -- )
over c@ 1+ cmove
;
: BETWEEN ( n lo hi -- flag , true if between lo & hi )
>r over r> > >r
< r> or 0=
;
: [ ( -- , enter interpreter mode )
0 state !
; immediate
: ] ( -- enter compile mode )
1 state !
;
: EVEN-UP ( n -- n | n+1 , make even ) dup 1 and + ;
: ALIGNED ( addr -- a-addr )
[ cell 1- ] literal +
[ cell 1- invert ] literal and
;
: ALIGN ( -- , align DP ) dp @ aligned dp ! ;
: ALLOT ( nbytes -- , allot space in dictionary ) dp +! ( align ) ;
: C, ( c -- ) here c! 1 chars dp +! ;
: W, ( w -- ) dp @ even-up dup dp ! w! 2 chars dp +! ;
: , ( n -- , lay into dictionary ) align here ! cell allot ;
\ Dictionary conversions ------------------------------------------
: N>NEXTLINK ( nfa -- nextlink , traverses name field )
dup c@ 31 and 1+ + aligned
;
: NAMEBASE ( -- base-of-names )
Headers-Base @
;
: CODEBASE ( -- base-of-code dictionary )
Code-Base @
;
: NAMELIMIT ( -- limit-of-names )
Headers-limit @
;
: CODELIMIT ( -- limit-of-code, last address in dictionary )
Code-limit @
;
: NAMEBASE+ ( rnfa -- nfa , convert relocatable nfa to actual )
namebase +
;
: >CODE ( xt -- secondary_code_address, not valid for primitives )
codebase +
;
: CODE> ( secondary_code_address -- xt , not valid for primitives )
codebase -
;
: N>LINK ( nfa -- lfa )
2 CELLS -
;
: >BODY ( xt -- pfa )
>code body_offset +
;
: BODY> ( pfa -- xt )
body_offset - code>
;
\ convert between addresses useable by @, and relocatable addresses.
: USE->REL ( useable_addr -- rel_addr )
codebase -
;
: REL->USE ( rel_addr -- useable_addr )
codebase +
;
\ for JForth code
\ : >REL ( adr -- adr ) ; immediate
\ : >ABS ( adr -- adr ) ; immediate
: X@ ( addr -- xt , fetch execution token from relocatable ) @ ;
: X! ( addr -- xt , store execution token as relocatable ) ! ;
\ Compiler support ------------------------------------------------
: COMPILE, ( xt -- , compile call to xt )
,
;
( Compiler support , based on FIG )
: [COMPILE] ( <name> -- , compile now even if immediate )
' compile,
; IMMEDIATE
: (COMPILE) ( xt -- , postpone compilation of token )
[compile] literal ( compile a call to literal )
( store xt of word to be compiled )
[ ' compile, ] literal \ compile call to compile,
compile,
;
: COMPILE ( <name> -- , save xt and compile later )
' (compile)
; IMMEDIATE
: :NONAME ( -- xt , begin compilation of headerless secondary )
align
here code> \ convert here to execution token
]
;
\ Error codes defined in ANSI Exception word set.
: ERR_ABORT -1 ; \ general abort
: ERR_EXECUTING -14 ; \ compile time word while not compiling
: ERR_PAIRS -22 ; \ mismatch in conditional
: ERR_DEFER -258 ; \ not a deferred word
: ABORT ( i*x -- )
ERR_ABORT throw
;
\ Conditionals in '83 form -----------------------------------------
: CONDITIONAL_KEY ( -- , lazy constant ) 29521 ;
: ?CONDITION ( f -- ) conditional_key - err_pairs ?error ;
: >MARK ( -- addr ) here 0 , ;
: >RESOLVE ( addr -- ) here over - swap ! ;
: <MARK ( -- addr ) here ;
: <RESOLVE ( addr -- ) here - , ;
: ?COMP ( -- , error if not compiling )
state @ 0= err_executing ?error
;
: ?PAIRS ( n m -- )
- err_pairs ?error
;
\ conditional primitives
: IF ( -- f orig ) ?comp compile 0branch conditional_key >mark ; immediate
: THEN ( f orig -- ) swap ?condition >resolve ; immediate
: BEGIN ( -- f dest ) ?comp conditional_key <mark ; immediate
: AGAIN ( f dest -- ) compile branch swap ?condition <resolve ; immediate
: UNTIL ( f dest -- ) compile 0branch swap ?condition <resolve ; immediate
: AHEAD ( -- f orig ) compile branch conditional_key >mark ; immediate
\ conditionals built from primitives
: ELSE ( f orig1 -- f orig2 )
[compile] AHEAD 2swap [compile] THEN ; immediate
: WHILE ( f dest -- f orig f dest ) [compile] if 2swap ; immediate
: REPEAT ( -- f orig f dest ) [compile] again [compile] then ; immediate
: ['] ( <name> -- xt , define compile time tick )
?comp ' [compile] literal
; immediate
\ for example:
\ compile time: compile create , (does>) then ;
\ execution time: create <name>, ',' data, then patch pi to point to @
\ : con create , does> @ ;
\ 345 con pi
\ pi
\
: (DOES>) ( xt -- , modify previous definition to execute code at xt )
latest name> >code \ get address of code for new word
cell + \ offset to second cell in create word
! \ store execution token of DOES> code in new word
;
: DOES> ( -- , define execution code for CREATE word )
0 [compile] literal \ dummy literal to hold xt
here cell- \ address of zero in literal
compile (does>) \ call (DOES>) from new creation word
>r \ move addrz to return stack so ; doesn't see stack garbage
[compile] ; \ terminate part of code before does>
r>
:noname ( addrz xt )
swap ! \ save execution token in literal
; immediate
: VARIABLE ( <name> -- )
CREATE 0 , \ IMMEDIATE
\ DOES> [compile] aliteral \ %Q This could be optimised
;
: 2VARIABLE ( <name> -c- ) ( -x- addr )
create 0 , 0 ,
;
: CONSTANT ( n <name> -c- ) ( -x- n )
CREATE , ( n -- )
DOES> @ ( -- n )
;
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
cell 8 * 1- 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 <name> -- , act like normal IS )
' \ xt
dup check.defer
state @
IF [compile] literal compile (is)
ELSE (is)
THEN
; immediate
: (WHAT'S) ( xt -- xt_do )
>is @
;
: WHAT'S ( <name> -- xt , what will deferred word call? )
' \ xt
dup check.defer
state @
IF [compile] literal compile (what's)
ELSE (what's)
THEN
; immediate
: /STRING ( addr len n -- addr' len' )
over min rot over + -rot -
;
: PLACE ( addr len to -- , move string )
3dup 1+ swap cmove c! drop
;
: PARSE-WORD ( char -- addr len )
>r source tuck >in @ /string r@ skip over swap r> scan
>r over - rot r> dup 0<> + - >in !
;
: PARSE ( char -- addr len )
>r source >in @ /string over swap r> scan
>r over - dup r> 0<> - >in +!
;
: LWORD ( char -- addr )
parse-word here place here \ 00002 , use PARSE-WORD
;
: ASCII ( <char> -- char , state smart )
bl parse drop c@
state @
IF [compile] literal
THEN
; immediate
: CHAR ( <char> -- char , interpret mode )
bl parse drop c@
;
: [CHAR] ( <char> -- char , for compile mode )
char [compile] literal
; immediate
: $TYPE ( $string -- )
count type
;
: 'word ( -- addr ) here ;
: EVEN ( addr -- addr' ) dup 1 and + ;
: (C") ( -- $addr , some Forths return addr AND count, OBSOLETE?)
r> dup count + aligned >r
;
: (S") ( -- c-addr cnt )
r> count 2dup + aligned >r
;
: (.") ( -- , type following string )
r> count 2dup + aligned >r type
;
: ", ( adr len -- , place string into dictionary )
tuck 'word place 1+ allot align
;
: ," ( -- )
[char] " parse ",
;
: .( ( <string> -- , type string delimited by parentheses )
[CHAR] ) PARSE TYPE
; IMMEDIATE
: ." ( <string> -- , type string )
state @
IF compile (.") ,"
ELSE [char] " parse type
THEN
; immediate
: .' ( <string> -- , type string delimited by single quote )
state @
IF compile (.") [char] ' parse ",
ELSE [char] ' parse type
THEN
; immediate
: C" ( <string> -- addr , return string address, ANSI )
state @
IF compile (c") ,"
ELSE [char] " parse pad place pad
THEN
; immediate
: S" ( <string> -- , -- addr , return string address, ANSI )
state @
IF compile (s") ,"
ELSE [char] " parse pad place pad count
THEN
; immediate
: " ( <string> -- , -- addr , return string address )
[compile] C"
; immediate
: P" ( <string> -- , -- addr , return string address )
[compile] C"
; immediate
: "" ( <string> -- addr )
state @
IF
compile (C")
bl parse-word ",
ELSE
bl parse-word pad place pad
THEN
; immediate
: SLITERAL ( addr cnt -- , compile string )
compile (S")
",
; IMMEDIATE
: $APPEND ( addr count $1 -- , append text to $1 )
over >r
dup >r
count + ( -- a2 c2 end1 )
swap cmove
r> dup c@ ( a1 c1 )
r> + ( -- a1 totalcount )
swap c!
;
\ ANSI word to replace [COMPILE] and COMPILE ----------------
: POSTPONE ( <name> -- )
bl word find
dup 0=
IF
." Postpone could not find " count type cr abort
ELSE
0>
IF compile, \ immediate
ELSE (compile) \ normal
THEN
THEN
; immediate
\ -----------------------------------------------------------------
\ Auto Initialization
: AUTO.INIT ( -- )
\ Kernel finds AUTO.INIT and executes it after loading dictionary.
\ ." Begin AUTO.INIT ------" cr
;
: AUTO.TERM ( -- )
\ Kernel finds AUTO.TERM and executes it on bye.
\ ." End AUTO.TERM ------" cr
;
\ -------------- INCLUDE ------------------------------------------
variable TRACE-INCLUDE
: INCLUDE.MARK.START ( $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
depth >r
include-file \ will also close the file
depth 1+ r> -
IF
." Warning: stack depth changed during include!" cr
.s cr
0sp
THEN
include.mark.end
THEN
trace-include @
IF
." include added " here r@ - . ." bytes,"
codelimit here - . ." left." cr
THEN
rdrop
;
create INCLUDE-SAVE-NAME 128 allot
: INCLUDE ( <fname> -- )
BL lword
dup include-save-name $move \ save for RI
$include
;
: RI ( -- , ReInclude previous file as a convenience )
include-save-name $include
;
: INCLUDE? ( <word> <file> -- , load file if word not defined )
bl word find
IF drop bl word drop ( eat word from source )
ELSE drop include
THEN
;
\ desired sizes for dictionary loaded after SAVE-FORTH
variable HEADERS-SIZE
variable CODE-SIZE
: AUTO.INIT
auto.init
codelimit codebase - code-size !
namelimit namebase - headers-size !
;
auto.init
: SAVE-FORTH ( $name -- )
0 \ Entry point
headers-ptr @ namebase - 65536 + \ NameSize
headers-size @ MAX
here codebase - 131072 + \ CodeSize
code-size @ MAX
(save-forth)
IF
." SAVE-FORTH failed!" cr abort
THEN
;
: TURNKEY ( $name entry-token-- )
0 \ NameSize = 0, names not saved in turnkey dictionary
here codebase - 131072 + \ CodeSize, remember that base is HEX
(save-forth)
IF
." TURNKEY failed!" cr abort
THEN
;
\ Now that we can load from files, 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
\ Save the dictionary in "pfdicdat.h" file so pForth can be compiled for standalone mode.
SDAD
src/cmd/pforth/fth/t_alloc.fth
+116
View File
@@ -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
src/cmd/pforth/fth/t_case.fth
+16
View File
@@ -0,0 +1,16 @@
\ test CASE
anew test-case
: TCASE ( N -- )
CASE
0 OF ." is zero" ENDOF
1 OF
2 choose
CASE
0 OF ." chose zero" ENDOF
1 OF ." chose one" ENDOF
[ .s cr ." of-depth = " of-depth @ . cr ]
ENDCASE
ENDOF
[ .s cr ." of-depth = " of-depth @ . cr ]
ENDCASE
;
src/cmd/pforth/fth/t_corex.fth
+226
View File
@@ -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? ( <name> -- ifInDic , is the following word defined? )
bl word find
swap drop 0= 0=
;
create FOOBAR
MARKER MYMARK \ create word that forgets itself
create GOOFBALL
MYMARK
T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T
\ ----------------------------------------------------- NIP
T{ 33 44 55 NIP }T{ 33 55 }T
\ ----------------------------------------------------- PARSE
: T.PARSE ( char <string>char -- addr num )
PARSE
>R \ save length
PAD R@ CMOVE \ move string to pad
PAD R>
;
T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T
\ ----------------------------------------------------- PICK
T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T
\ ----------------------------------------------------- QUERY
T{ ' QUERY 0<> }T{ TRUE }T
\ ----------------------------------------------------- REFILL
T{ ' REFILL 0<> }T{ TRUE }T
\ ----------------------------------------------------- RESTORE-INPUT
T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE
\ ----------------------------------------------------- ROLL
T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T
T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T
T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T
T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T
T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T
\ ----------------------------------------------------- SOURCE-ID
T{ SOURCE-ID 0<> }T{ TRUE }T
T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T
\ ----------------------------------------------------- SPAN
T{ ' SPAN 0<> }T{ TRUE }T
\ ----------------------------------------------------- TO VALUE
333 VALUE MY-VALUE
T{ MY-VALUE }T{ 333 }T
T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T
: TEST.VALUE ( -- 19 100 )
100 TO MY-VALUE
19
MY-VALUE
;
T{ TEST.VALUE }T{ 19 100 }T
\ ----------------------------------------------------- TRUE
T{ TRUE }T{ 0 0= }T
\ ----------------------------------------------------- TUCK
T{ 44 55 66 TUCK }T{ 44 66 55 66 }T
\ ----------------------------------------------------- U.R
HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR
ABCD4321 C U.R CR DECIMAL
\ ----------------------------------------------------- U>
T{ -5 3 U> }T{ TRUE }T
T{ 10 8 U> }T{ TRUE }T
\ ----------------------------------------------------- UNUSED
T{ UNUSED 0> }T{ TRUE }T
\ ----------------------------------------------------- WITHIN
T{ 4 5 10 WITHIN }T{ 0 }T
T{ 5 5 10 WITHIN }T{ TRUE }T
T{ 9 5 10 WITHIN }T{ TRUE }T
T{ 10 5 10 WITHIN }T{ 0 }T
T{ 4 10 5 WITHIN }T{ TRUE }T
T{ 5 10 5 WITHIN }T{ 0 }T
T{ 9 10 5 WITHIN }T{ 0 }T
T{ 10 10 5 WITHIN }T{ TRUE }T
T{ -6 -5 10 WITHIN }T{ 0 }T
T{ -5 -5 10 WITHIN }T{ TRUE }T
T{ 9 -5 10 WITHIN }T{ TRUE }T
T{ 10 -5 10 WITHIN }T{ 0 }T
\ ----------------------------------------------------- [COMPILE]
: T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE
: T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;
T{ T.[COMPILE] }T{ TRUE }T
\ ----------------------------------------------------- \
}TEST
src/cmd/pforth/fth/t_floats.fth
+134
View File
@@ -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
src/cmd/pforth/fth/t_include.fth
+18
View File
@@ -0,0 +1,18 @@
\ Test INCLUDE errors.
\
\ Copyright 2001Phil Burk
include? }T{ t_tools.fth
marker task-t_string.fth
decimal
: F_UNDEF " t_load_undef.fth" ;
test{
T{ F_UNDEF ' $include catch }T{ F_UNDEF -13 }T
}test
src/cmd/pforth/fth/t_load.fth
+7
View File
@@ -0,0 +1,7 @@
\ Test nested INCLUDE errors.
\
\ Copyright 2001Phil Burk
\ include t_load_undef.fth
\ include t_load_semi.fth
include t_load_defer.fth
src/cmd/pforth/fth/t_load_defer.fth
+5
View File
@@ -0,0 +1,5 @@
\ Test INCLUDE errors.
what's dup >name id. \ but DUP is not deferred!
We should never reach this text.
src/cmd/pforth/fth/t_load_pairs.fth
+5
View File
@@ -0,0 +1,5 @@
\ Test INCLUDE errors.
: T.LOAD.PAIRS
10 0 DO i . THEN
;
src/cmd/pforth/fth/t_load_semi.fth
+6
View File
@@ -0,0 +1,6 @@
\ Test INCLUDE errors.
: T.LOAD.PAIRS
1 IF
." hello" cr
; \ missing a THEN
src/cmd/pforth/fth/t_load_undef.fth
+5
View File
@@ -0,0 +1,5 @@
\ Test INCLUDE errors.
: T.LOAD.UNDEF
23 45 swap BADWORD \ reference an undefined word!
;
src/cmd/pforth/fth/t_locals.fth
+52
View File
@@ -0,0 +1,52 @@
\ @(#) t_locals.fth 97/01/28 1.1
\ Test PForth LOCAL variables.
\
\ Copyright 1996 3DO, Phil Burk
include? }T{ t_tools.fth
anew task-t_locals.fth
decimal
test{
\ test value and locals
T{ 333 value my-value my-value }T{ 333 }T
T{ 1000 -> my-value my-value }T{ 1000 }T
T{ 35 +-> my-value my-value }T{ 1035 }T
: 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 warning when no locals defined.) cr
: loc.nonames { -- } 1234 ;
T{ loc.nonames }T{ 1234 }T
\ try to put EOLs and comments in variable list
: calc.area {
width \ horizontal dimension
height \ vertical dimension
-- area , calculate area of a rectangle }
width height *
;
T{ 5 20 calc.area }T{ 100 }T
}test
src/cmd/pforth/fth/t_nolf.fth
+4
View File
@@ -0,0 +1,4 @@
\ Test behavior of pForth when line encountered with no EOF at end.
." First Line of Two" cr
." Second Line of Two" cr
src/cmd/pforth/fth/t_strings.fth
+106
View File
@@ -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
src/cmd/pforth/fth/t_tools.fth
+83
View File
@@ -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
;
src/cmd/pforth/fth/termio.fth
+88
View File
@@ -0,0 +1,88 @@
\ Terminal I/O
\
\ Requires an ANSI compatible terminal.
\
\ To get Windows computers to use ANSI mode in their DOS windows,
\ Add this line to "C:\CONFIG.SYS" then reboot.
\
\ device=c:\windows\command\ansi.sys
\
\ Author: Phil Burk
\ Copyright 1988 Phil Burk
\ Revised 2001 for pForth
ANEW TASK-TERMIO.FTH
decimal
$ 08 constant ASCII_BACKSPACE
$ 7F constant ASCII_DELETE
$ 1B constant ASCII_ESCAPE
$ 01 constant ASCII_CTRL_A
$ 05 constant ASCII_CTRL_E
$ 18 constant ASCII_CTRL_X
\ ANSI Terminal Control
: ESC[ ( send ESCAPE and [ )
ASCII_ESCAPE emit
ascii [ emit
;
: CLS ( -- , clear screen )
ESC[ ." 2J"
;
: TIO.BACKWARDS ( n -- , move cursor backwards )
ESC[
base @ >r decimal
0 .r
r> base !
ascii D emit
;
: TIO.FORWARDS ( n -- , move cursor forwards )
ESC[
base @ >r decimal
0 .r
r> base !
ascii C emit
;
: TIO.ERASE.EOL ( -- , erase to the end of the line )
ESC[
ascii K emit
;
: BELL ( -- , ring the terminal bell )
7 emit
;
: BACKSPACE ( -- , backspace action )
8 emit space 8 emit
;
0 [IF] \ for testing
: SHOWKEYS ( -- , show keys pressed in hex )
BEGIN
key
dup .
." , $ " dup .hex cr
ascii q =
UNTIL
;
: AZ ascii z 1+ ascii a DO i emit LOOP ;
: TEST.BACK1
AZ 5 tio.backwards
1000 msec
tio.erase.eol
;
: TEST.BACK2
AZ 10 tio.backwards
1000 msec
." 12345"
1000 msec
;
[THEN]
src/cmd/pforth/fth/tester.fth
+54
View File
@@ -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 ;
src/cmd/pforth/fth/trace.fth
+460
View File
@@ -0,0 +1,460 @@
\ @(#) trace.fth 98/01/28 1.2
\ TRACE ( <name> -- , trace pForth word )
\
\ Single step debugger.
\ TRACE ( i*x <name> -- , setup trace for Forth word )
\ S ( -- , step over )
\ SM ( many -- , step over many times )
\ SD ( -- , step down )
\ G ( -- , go to end of word )
\ GD ( n -- , go down N levels from current level, stop at end of this level )
\
\ This debugger works by emulating the inner interpreter of pForth.
\ It executes code and maintains a separate return stack for the
\ program under test. Thus all primitives that operate on the return
\ stack, such as DO and R> must be trapped. Local variables must
\ also be handled specially. Several state variables are also
\ saved and restored to establish the context for the program being
\ tested.
\
\ Copyright 1997 Phil Burk
\
\ Modifications:
\ 19990930 John Providenza - Fixed stack bugs in GD
anew task-trace.fth
: SPACE.TO.COLUMN ( col -- )
out @ - spaces
;
: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
['] first_colon <
;
0 value TRACE_IP \ instruction pointer
0 value TRACE_LEVEL \ level of descent for inner interpreter
0 value TRACE_LEVEL_MAX \ maximum level of descent
private{
\ use fake return stack
128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
variable TRACE-RSP
: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n
: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++
: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
: TRACE.RDROP ( -- ) cell trace-rsp +! ;
: TRACE.RCHECK ( -- , abort if return stack out of range )
trace-rsp @ trace-return-stack u<
abort" TRACE return stack OVERFLOW!"
trace-rsp @ trace-return-stack trace_return_size + 12 + u>
abort" TRACE return stack UNDERFLOW!"
;
\ save and restore several state variables
10 cells constant TRACE_STATE_SIZE
create TRACE-STATE-1 TRACE_STATE_SIZE allot
create TRACE-STATE-2 TRACE_STATE_SIZE allot
variable TRACE-STATE-PTR
: TRACE.SAVE++ ( addr -- , save next thing )
@ trace-state-ptr @ !
cell trace-state-ptr +!
;
: TRACE.SAVE.STATE ( -- )
state trace.save++
hld trace.save++
base trace.save++
;
: TRACE.SAVE.STATE1 ( -- , save normal state )
trace-state-1 trace-state-ptr !
trace.save.state
;
: TRACE.SAVE.STATE2 ( -- , save state of word being debugged )
trace-state-2 trace-state-ptr !
trace.save.state
;
: TRACE.RESTORE++ ( addr -- , restore next thing )
trace-state-ptr @ @ swap !
cell trace-state-ptr +!
;
: TRACE.RESTORE.STATE ( -- )
state trace.restore++
hld trace.restore++
base trace.restore++
;
: TRACE.RESTORE.STATE1 ( -- )
trace-state-1 trace-state-ptr !
trace.restore.state
;
: TRACE.RESTORE.STATE2 ( -- )
trace-state-2 trace-state-ptr !
trace.restore.state
;
\ The implementation of these pForth primitives is specific to pForth.
variable TRACE-LOCALS-PTR \ point to top of local frame
\ create a return stack frame for NUM local variables
: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- }
trace-locals-ptr @ trace.>r
trace-rsp @ trace-locals-ptr !
trace-rsp @ num cells - trace-rsp ! \ make room for locals
trace-rsp @ -> lp
num 0
DO
lp !
cell +-> lp \ move data into locals frame on return stack
LOOP
;
: TRACE.(LOCAL.EXIT) ( -- )
trace-locals-ptr @ trace-rsp !
trace.r> trace-locals-ptr !
;
: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
trace-locals-ptr @ swap cells - @
;
: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
: TRACE.(LOCAL!) ( n l# -- , store into local frame )
trace-locals-ptr @ swap cells - !
;
: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
: TRACE.(LOCAL+!) ( n l# -- , store into local frame )
trace-locals-ptr @ swap cells - +!
;
: TRACE.(?DO) { limit start ip -- ip' }
limit start =
IF
ip @ +-> ip \ BRANCH
ELSE
start trace.>r
limit trace.>r
cell +-> ip
THEN
ip
;
: TRACE.(LOOP) { ip | limit indx -- ip' }
trace.r> -> limit
trace.r> 1+ -> indx
limit indx =
IF
cell +-> ip
ELSE
indx trace.>r
limit trace.>r
ip @ +-> ip
THEN
ip
;
: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' }
trace.r> -> limit
trace.r> -> oldindx
oldindx delta + -> indx
\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
oldindx limit - limit 1- indx - AND $ 80000000 AND
indx limit - limit 1- oldindx - AND $ 80000000 AND OR
IF
cell +-> ip
ELSE
indx trace.>r
limit trace.>r
ip @ +-> ip
THEN
ip
;
: TRACE.CHECK.IP { ip -- }
ip ['] first_colon u<
ip here u> OR
IF
." TRACE - IP out of range = " ip .hex cr
abort
THEN
;
: TRACE.SHOW.IP { ip -- , print name and offset }
ip code> >name dup id.
name> >code ip swap - ." +" .
;
: TRACE.SHOW.STACK { | mdepth -- }
base @ >r
." <" base @ decimal 1 .r ." :"
depth 1 .r ." > "
r> base !
depth 5 min -> mdepth
depth mdepth -
IF
." ... " \ if we don't show entire stack
THEN
mdepth 0
?DO
mdepth i 1+ - pick . \ show numbers in current base
LOOP
;
: TRACE.SHOW.NEXT { ip -- }
>newline
ip trace.check.ip
\ show word name and offset
." << "
ip trace.show.ip
16 space.to.column
\ show data stack
trace.show.stack
40 space.to.column ." ||"
trace_level 2* spaces
ip code@
cell +-> ip
\ show primitive about to be executed
dup .xt space
\ trap any primitives that are followed by inline data
CASE
['] (LITERAL) OF ip @ . ENDOF
['] (ALITERAL) OF ip a@ . ENDOF
[ exists? (FLITERAL) [IF] ]
['] (FLITERAL) OF ip f@ f. ENDOF
[ [THEN] ]
['] BRANCH OF ip @ . ENDOF
['] 0BRANCH OF ip @ . ENDOF
['] (.") OF ip count type .' "' ENDOF
['] (C") OF ip count type .' "' ENDOF
['] (S") OF ip count type .' "' ENDOF
ENDCASE
65 space.to.column ." >> "
;
: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip }
xt
CASE
0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT
['] (CREATE) OF ip cell- body_offset + ENDOF
['] (LITERAL) OF ip @ cell +-> ip ENDOF
['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
[ exists? (FLITERAL) [IF] ]
['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
[ [THEN] ]
['] BRANCH OF ip @ +-> ip ENDOF
['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
['] >R OF trace.>r ENDOF
['] R> OF trace.r> ENDOF
['] R@ OF trace.r@ ENDOF
['] RDROP OF trace.rdrop ENDOF
['] 2>R OF trace.>r trace.>r ENDOF
['] 2R> OF trace.r> trace.r> ENDOF
['] 2R@ OF trace.r@ 1 trace.rpick ENDOF
['] i OF 1 trace.rpick ENDOF
['] j OF 3 trace.rpick ENDOF
['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF
['] (LOOP) OF ip trace.(loop) -> ip ENDOF
['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF
['] (DO) OF trace.>r trace.>r ENDOF
['] (?DO) OF ip trace.(?do) -> ip ENDOF
['] (.") OF ip count type ip count + aligned -> ip ENDOF
['] (C") OF ip ip count + aligned -> ip ENDOF
['] (S") OF ip count ip count + aligned -> ip ENDOF
['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
['] (LOCAL@) OF trace.(local@) ENDOF
['] (1_LOCAL@) OF trace.(1_local@) ENDOF
['] (2_LOCAL@) OF trace.(2_local@) ENDOF
['] (3_LOCAL@) OF trace.(3_local@) ENDOF
['] (4_LOCAL@) OF trace.(4_local@) ENDOF
['] (5_LOCAL@) OF trace.(5_local@) ENDOF
['] (6_LOCAL@) OF trace.(6_local@) ENDOF
['] (7_LOCAL@) OF trace.(7_local@) ENDOF
['] (8_LOCAL@) OF trace.(8_local@) ENDOF
['] (LOCAL!) OF trace.(local!) ENDOF
['] (1_LOCAL!) OF trace.(1_local!) ENDOF
['] (2_LOCAL!) OF trace.(2_local!) ENDOF
['] (3_LOCAL!) OF trace.(3_local!) ENDOF
['] (4_LOCAL!) OF trace.(4_local!) ENDOF
['] (5_LOCAL!) OF trace.(5_local!) ENDOF
['] (6_LOCAL!) OF trace.(6_local!) ENDOF
['] (7_LOCAL!) OF trace.(7_local!) ENDOF
['] (8_LOCAL!) OF trace.(8_local!) ENDOF
['] (LOCAL+!) OF trace.(local+!) ENDOF
>r xt EXECUTE r>
ENDCASE
ip
;
: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip }
ip trace.check.ip
\ set context for word under test
trace.save.state1
here -> oldhere
trace.restore.state2
oldhere 256 + dp !
\ get execution token
ip code@ -> xt
cell +-> ip
\ execute token
xt is.primitive?
IF \ primitive
ip xt trace.do.primitive -> ip
ELSE \ secondary
trace_level trace_level_max <
IF
ip trace.>r \ threaded execution
1 +-> trace_level
xt codebase + -> ip
ELSE
\ treat it as a primitive
ip xt trace.do.primitive -> ip
THEN
THEN
\ restore original context
trace.rcheck
trace.save.state2
trace.restore.state1
oldhere dp !
ip
;
: TRACE.NEXT { ip | xt -- ip' }
trace_level 0>
IF
ip trace.do.next -> ip
THEN
trace_level 0>
IF
ip trace.show.next
ELSE
trace-stack on
." Finished." cr
THEN
ip
;
}private
: TRACE ( i*x <name> -- i*x , setup trace environment )
' dup is.primitive?
IF
drop ." Sorry. You can't trace a primitive." cr
ELSE
1 -> trace_level
trace_level -> trace_level_max
trace.0rp
>code -> trace_ip
trace_ip trace.show.next
trace-stack off
trace.save.state2
THEN
;
: s ( -- , step over )
trace_level -> trace_level_max
trace_ip trace.next -> trace_ip
;
: sd ( -- , step down )
trace_level 1+ -> trace_level_max
trace_ip trace.next -> trace_ip
;
: sm ( many -- , step many times )
trace_level -> trace_level_max
0
?DO
trace_ip trace.next -> trace_ip
LOOP
;
defer trace.user ( IP -- stop? )
' 0= is trace.user
: gd { more_levels | stop_level -- }
here what's trace.user u< \ has it been forgotten?
IF
." Resetting TRACE.USER !!!" cr
['] 0= is trace.user
THEN
more_levels 0<
more_levels 10 >
or \ 19990930 - OR was missing
IF
." GD level out of range (0-10), = " more_levels . cr
ELSE
trace_level more_levels + -> trace_level_max
trace_level 1- -> stop_level
BEGIN
trace_ip trace.user \ call deferred user word
?dup \ leave flag for UNTIL \ 19990930 - was DUP
IF
." TRACE.USER returned " dup . ." so stopping execution." cr
ELSE
trace_ip trace.next -> trace_ip
trace_level stop_level > not
THEN
UNTIL
THEN
;
: g ( -- , execute until end of word )
0 gd
;
: TRACE.HELP ( -- )
." TRACE ( i*x <name> -- , setup trace for Forth word )" cr
." S ( -- , step over )" cr
." SM ( many -- , step over many times )" cr
." SD ( -- , step down )" cr
." G ( -- , go to end of word )" cr
." GD ( n -- , go down N levels from current level," cr
." stop at end of this level )" cr
;
privatize
0 [IF]
variable var1
100 var1 !
: FOO dup IF 1 + . THEN 77 var1 @ + . ;
: ZOO 29 foo 99 22 + . ;
: ROO 92 >r 1 r@ + . r> . ;
: MOO c" hello" count type
." This is a message." cr
s" another message" type cr
;
: KOO 7 FOO ." DONE" ;
: TR.DO 4 0 DO i . LOOP ;
: TR.?DO 0 ?DO i . LOOP ;
: TR.LOC1 { aa bb } aa bb + . ;
: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;
[THEN]
src/cmd/pforth/fth/tut.fth
+70
View File
@@ -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
src/cmd/pforth/fth/utils/clone.fth
+489
View File
@@ -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 ( <filename> -- )
bl word
." Save cloned image in " dup count type
drop ." SAVE-CLONE unimplemented!" \ %Q
;
: CLONE ( <name> -- )
' 'clone
;
if.forgotten cl.term
\ ---------------------------------- TESTS --------------------
: TEST.CLONE ( -- )
cl-test-mode @ not abort" CL-TEST-MODE not on!"
0 cl.ref[] s@ clr_NewXT execute
;
: TEST.CLONE.REAL ( -- )
cl-test-mode @ abort" CL-TEST-MODE on!"
code-base @
0 cl.ref[] s@ clr_NewXT \ get cloned execution token
cl-dict-base @ code-base !
\ WARNING - code-base munged, only execute primitives or cloned code
execute
code-base ! \ restore code base for normal
;
: TCL1
34 dup +
;
: TCL2
." Hello " tcl1 . cr
;
: TCL3
4 0
DO
tcl2
i . cr
i 100 + . cr
LOOP
;
create VAR1 567 ,
: TCL4
345 var1 !
." VAR1 = " var1 @ . cr
var1 @ 345 -
IF
." TCL4 failed!" cr
ELSE
." TCL4 succeded! Yay!" cr
THEN
;
\ do deferred words get cloned!
defer tcl.vector
: TCL.DOIT ." Hello Fred!" cr ;
' tcl.doit is tcl.vector
: TCL.DEFER
12 . cr
tcl.vector
999 dup + . cr
;
trace-stack on
cl-test-mode on
src/cmd/pforth/fth/utils/dump_struct.fth
+122
View File
@@ -0,0 +1,122 @@
\ @(#) dump_struct.fth 97/12/10 1.1
\ Dump contents of structure showing values and member names.
\
\ Author: Phil Burk
\ Copyright 1987 Phil Burk
\ All Rights Reserved.
\
\ MOD: PLB 9/4/88 Print size too.
\ MOD: PLB 9/9/88 Print U/S , add ADST
\ MOD: PLB 12/6/90 Modified to work with H4th
\ 941109 PLB Converted to pforth. Added RP detection.
\ 090609 PLB Convert >rel to use->rel and ..! to s!
include? task-member.fth member.fth
include? task-c_struct c_struct.fth
ANEW TASK-DUMP_STRUCT
: EMIT-TO-COLUMN ( char col -- )
out @ - 0 max 80 min 0
DO dup emit
LOOP drop
;
VARIABLE SN-FENCE
: STACK.NFAS ( fencenfa topnfa -- 0 nfa0 nfa1 ... )
\ Fill stack with nfas of words until fence hit.
>r sn-fence !
0 r> ( set terminator )
BEGIN ( -- 0 n0 n1 ... top )
dup sn-fence @ >
WHILE
\ dup n>link @ \ JForth
dup prevname \ HForth
REPEAT
drop
;
: DST.DUMP.TYPE ( +-size -- , dump data type, 941109)
dup abs 4 =
IF
0<
IF ." RP"
ELSE ." U4"
THEN
ELSE
dup 0<
IF ascii U
ELSE ascii S
THEN emit abs 1 .r
THEN
;
: DUMP.MEMBER ( addr member-pfa -- , dump member of structure)
ob.stats ( -- addr offset size )
>r + r> ( -- addr' size )
dup ABS 4 > ( -- addr' size flag )
IF cr 2dup swap . . ABS dump
ELSE tuck @bytes 10 .r ( -- size )
3 spaces dst.dump.type
THEN
;
VARIABLE DS-ADDR
: DUMP.STRUCT ( addr-data addr-structure -- )
>newline swap >r ( -- as , save addr-data for dumping )
\ dup cell+ @ over + \ JForth
dup code> >name swap cell+ @ over + \ HForth
stack.nfas ( fill stack with nfas of members )
BEGIN
dup
WHILE ( continue until non-zero )
dup name> >body r@ swap dump.member
bl 18 emit-to-column id. cr
?pause
REPEAT drop rdrop
;
: DST ( addr <name> -- , dump contents of structure )
ob.findit
state @
IF [compile] literal compile dump.struct
ELSE dump.struct
THEN
; immediate
: ADST ( absolute_address -- , dump structure )
use->rel [compile] dst \ mod 090609
; immediate
\ For Testing Purposes
false [IF]
:STRUCT GOO
LONG DATAPTR
SHORT GOO_WIDTH
USHORT GOO_HEIGHT
;STRUCT
:STRUCT FOO
LONG ALONG1
STRUCT GOO AGOO
SHORT ASHORT1
BYTE ABYTE
BYTE ABYTE2
;STRUCT
FOO AFOO
: AFOO.INIT
$ 12345678 afoo s! along1
$ -665 afoo s! ashort1
$ 21 afoo s! abyte
$ 43 afoo s! abyte2
-234 afoo .. agoo s! goo_height
;
afoo.init
: TDS ( afoo -- )
dst foo
;
[THEN]
src/cmd/pforth/fth/utils/load_file.fth
+39
View File
@@ -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 .
src/cmd/pforth/fth/utils/make_all256.fth
+57
View File
@@ -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
src/cmd/pforth/fth/utils/trace.fth
+438
View File
@@ -0,0 +1,438 @@
\ @(#) trace.fth 98/01/08 1.1
\ TRACE ( <name> -- , trace pForth word )
\
\ Single step debugger.
\ TRACE ( i*x <name> -- , setup trace for Forth word )
\ S ( -- , step over )
\ SM ( many -- , step over many times )
\ SD ( -- , step down )
\ G ( -- , go to end of word )
\ GD ( n -- , go down N levels from current level, stop at end of this level )
\
\ This debugger works by emulating the inner interpreter of pForth.
\ It executes code and maintains a separate return stack for the
\ program under test. Thus all primitives that operate on the return
\ stack, such as DO and R> must be trapped. Local variables must
\ also be handled specially. Several state variables are also
\ saved and restored to establish the context for the program being
\ tested.
\
\ Copyright 1997 Phil Burk
anew task-trace.fth
: SPACE.TO.COLUMN ( col -- )
out @ - spaces
;
: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
['] first_colon <
;
0 value TRACE_IP \ instruction pointer
0 value TRACE_LEVEL \ level of descent for inner interpreter
0 value TRACE_LEVEL_MAX \ maximum level of descent
private{
\ use fake return stack
128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
variable TRACE-RSP
: TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n
: TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++
: TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
: TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
: TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
: TRACE.RDROP ( -- ) cell trace-rsp +! ;
: TRACE.RCHECK ( -- , abort if return stack out of range )
trace-rsp @ trace-return-stack u<
abort" TRACE return stack OVERFLOW!"
trace-rsp @ trace-return-stack trace_return_size + 12 + u>
abort" TRACE return stack UNDERFLOW!"
;
\ save and restore several state variables
10 cells constant TRACE_STATE_SIZE
create TRACE-STATE-1 TRACE_STATE_SIZE allot
create TRACE-STATE-2 TRACE_STATE_SIZE allot
variable TRACE-STATE-PTR
: TRACE.SAVE++ ( addr -- , save next thing )
@ trace-state-ptr @ !
cell trace-state-ptr +!
;
: TRACE.SAVE.STATE ( -- )
state trace.save++
hld trace.save++
base trace.save++
;
: TRACE.SAVE.STATE1 ( -- , save normal state )
trace-state-1 trace-state-ptr !
trace.save.state
;
: TRACE.SAVE.STATE2 ( -- , save state of word being debugged )
trace-state-2 trace-state-ptr !
trace.save.state
;
: TRACE.RESTORE++ ( addr -- , restore next thing )
trace-state-ptr @ @ swap !
cell trace-state-ptr +!
;
: TRACE.RESTORE.STATE ( -- )
state trace.restore++
hld trace.restore++
base trace.restore++
;
: TRACE.RESTORE.STATE1 ( -- )
trace-state-1 trace-state-ptr !
trace.restore.state
;
: TRACE.RESTORE.STATE2 ( -- )
trace-state-2 trace-state-ptr !
trace.restore.state
;
\ The implementation of these pForth primitives is specific to pForth.
variable TRACE-LOCALS-PTR \ point to top of local frame
\ create a return stack frame for NUM local variables
: TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- }
trace-locals-ptr @ trace.>r
trace-rsp @ trace-locals-ptr !
trace-rsp @ num cells - trace-rsp ! \ make room for locals
trace-rsp @ -> lp
num 0
DO
lp !
cell +-> lp \ move data into locals frame on return stack
LOOP
;
: TRACE.(LOCAL.EXIT) ( -- )
trace-locals-ptr @ trace-rsp !
trace.r> trace-locals-ptr !
;
: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
trace-locals-ptr @ swap cells - @
;
: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
: TRACE.(LOCAL!) ( n l# -- , store into local frame )
trace-locals-ptr @ swap cells - !
;
: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
: TRACE.(LOCAL+!) ( n l# -- , store into local frame )
trace-locals-ptr @ swap cells - +!
;
: TRACE.(?DO) { limit start ip -- ip' }
limit start =
IF
ip @ +-> ip \ BRANCH
ELSE
start trace.>r
limit trace.>r
cell +-> ip
THEN
ip
;
: TRACE.(LOOP) { ip | limit indx -- ip' }
trace.r> -> limit
trace.r> 1+ -> indx
limit indx =
IF
cell +-> ip
ELSE
indx trace.>r
limit trace.>r
ip @ +-> ip
THEN
ip
;
: TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' }
trace.r> -> limit
trace.r> -> oldindx
oldindx delta + -> indx
\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
\ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
\ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
oldindx limit - limit 1- indx - AND $ 80000000 AND
indx limit - limit 1- oldindx - AND $ 80000000 AND OR
IF
cell +-> ip
ELSE
indx trace.>r
limit trace.>r
ip @ +-> ip
THEN
ip
;
: TRACE.CHECK.IP { ip -- }
ip ['] first_colon u<
ip here u> OR
IF
." TRACE - IP out of range = " ip .hex cr
abort
THEN
;
: TRACE.SHOW.IP { ip -- , print name and offset }
ip code> >name dup id.
name> >code ip swap - ." +" .
;
: TRACE.SHOW.STACK { | mdepth -- }
base @ >r
." <" base @ decimal 1 .r ." :"
depth 1 .r ." > "
r> base !
depth 5 min -> mdepth
depth mdepth -
IF
." ... " \ if we don't show entire stack
THEN
mdepth 0
?DO
mdepth i 1+ - pick . \ show numbers in current base
LOOP
;
: TRACE.SHOW.NEXT { ip -- }
>newline
ip trace.check.ip
\ show word name and offset
." << "
ip trace.show.ip
30 space.to.column
\ show data stack
trace.show.stack
65 space.to.column ." ||"
trace_level 2* spaces
ip code@
cell +-> ip
\ show primitive about to be executed
dup .xt space
\ trap any primitives that are followed by inline data
CASE
['] (LITERAL) OF ip @ . ENDOF
['] (ALITERAL) OF ip a@ . ENDOF
[ exists? (FLITERAL) [IF] ]
['] (FLITERAL) OF ip f@ f. ENDOF
[ [THEN] ]
['] BRANCH OF ip @ . ENDOF
['] 0BRANCH OF ip @ . ENDOF
['] (.") OF ip count type .' "' ENDOF
['] (C") OF ip count type .' "' ENDOF
['] (S") OF ip count type .' "' ENDOF
ENDCASE
100 space.to.column ." >> "
;
: TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip }
xt
CASE
0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT
['] (CREATE) OF ip cell- body_offset + ENDOF
['] (LITERAL) OF ip @ cell +-> ip ENDOF
['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
[ exists? (FLITERAL) [IF] ]
['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
[ [THEN] ]
['] BRANCH OF ip @ +-> ip ENDOF
['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
['] >R OF trace.>r ENDOF
['] R> OF trace.r> ENDOF
['] R@ OF trace.r@ ENDOF
['] RDROP OF trace.rdrop ENDOF
['] 2>R OF trace.>r trace.>r ENDOF
['] 2R> OF trace.r> trace.r> ENDOF
['] 2R@ OF trace.r@ 1 trace.rpick ENDOF
['] i OF 1 trace.rpick ENDOF
['] j OF 3 trace.rpick ENDOF
['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF
['] (LOOP) OF ip trace.(loop) -> ip ENDOF
['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF
['] (DO) OF trace.>r trace.>r ENDOF
['] (?DO) OF ip trace.(?do) -> ip ENDOF
['] (.") OF ip count type ip count + aligned -> ip ENDOF
['] (C") OF ip ip count + aligned -> ip ENDOF
['] (S") OF ip count ip count + aligned -> ip ENDOF
['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
['] (LOCAL@) OF trace.(local@) ENDOF
['] (1_LOCAL@) OF trace.(1_local@) ENDOF
['] (2_LOCAL@) OF trace.(2_local@) ENDOF
['] (3_LOCAL@) OF trace.(3_local@) ENDOF
['] (4_LOCAL@) OF trace.(4_local@) ENDOF
['] (5_LOCAL@) OF trace.(5_local@) ENDOF
['] (6_LOCAL@) OF trace.(6_local@) ENDOF
['] (7_LOCAL@) OF trace.(7_local@) ENDOF
['] (8_LOCAL@) OF trace.(8_local@) ENDOF
['] (LOCAL!) OF trace.(local!) ENDOF
['] (1_LOCAL!) OF trace.(1_local!) ENDOF
['] (2_LOCAL!) OF trace.(2_local!) ENDOF
['] (3_LOCAL!) OF trace.(3_local!) ENDOF
['] (4_LOCAL!) OF trace.(4_local!) ENDOF
['] (5_LOCAL!) OF trace.(5_local!) ENDOF
['] (6_LOCAL!) OF trace.(6_local!) ENDOF
['] (7_LOCAL!) OF trace.(7_local!) ENDOF
['] (8_LOCAL!) OF trace.(8_local!) ENDOF
['] (LOCAL+!) OF trace.(local+!) ENDOF
>r xt EXECUTE r>
ENDCASE
ip
;
: TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip }
ip trace.check.ip
\ set context for word under test
trace.save.state1
here -> oldhere
trace.restore.state2
oldhere 256 + dp !
\ get execution token
ip code@ -> xt
cell +-> ip
\ execute token
xt is.primitive?
IF \ primitive
ip xt trace.do.primitive -> ip
ELSE \ secondary
trace_level trace_level_max <
IF
ip trace.>r \ threaded execution
1 +-> trace_level
xt codebase + -> ip
ELSE
\ treat it as a primitive
ip xt trace.do.primitive -> ip
THEN
THEN
\ restore original context
trace.rcheck
trace.save.state2
trace.restore.state1
oldhere dp !
ip
;
: TRACE.NEXT { ip | xt -- ip' }
trace_level 0>
IF
ip trace.do.next -> ip
THEN
trace_level 0>
IF
ip trace.show.next
ELSE
." Finished." cr
THEN
ip
;
}private
: TRACE ( i*x <name> -- i*x , setup trace environment )
' dup is.primitive?
IF
drop ." Sorry. You can't trace a primitive." cr
ELSE
1 -> trace_level
trace_level -> trace_level_max
trace.0rp
>code -> trace_ip
trace_ip trace.show.next
trace-stack off
trace.save.state2
THEN
;
: s ( -- , step over )
trace_level -> trace_level_max
trace_ip trace.next -> trace_ip
;
: sd ( -- , step down )
trace_level 1+ -> trace_level_max
trace_ip trace.next -> trace_ip
;
: sm ( many -- , step down )
trace_level -> trace_level_max
0
?DO
trace_ip trace.next -> trace_ip
LOOP
;
: gd { more_levels | stop_level -- }
depth 1 <
IF
." GD requires a MORE_LEVELS parameter." cr
ELSE
trace_level more_levels + -> trace_level_max
trace_level 1- -> stop_level
BEGIN
trace_ip trace.next -> trace_ip
trace_level stop_level > not
UNTIL
THEN
;
: g ( -- , execute until end of word )
0 gd
;
: TRACE.HELP ( -- )
." TRACE ( i*x <name> -- , setup trace for Forth word )" cr
." S ( -- , step over )" cr
." SM ( many -- , step over many times )" cr
." SD ( -- , step down )" cr
." G ( -- , go to end of word )" cr
." GD ( n -- , go down N levels from current level," cr
." stop at end of this level )" cr
;
privatize
0 [IF]
variable var1
100 var1 !
: FOO dup IF 1 + . THEN 77 var1 @ + . ;
: ZOO 29 foo 99 22 + . ;
: ROO 92 >r 1 r@ + . r> . ;
: MOO c" hello" count type
." This is a message." cr
s" another message" type cr
;
: KOO 7 FOO ." DONE" ;
: TR.DO 4 0 DO i . LOOP ;
: TR.?DO 0 ?DO i . LOOP ;
: TR.LOC1 { aa bb } aa bb + . ;
: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;
[THEN]
src/cmd/pforth/fth/wordslik.fth
+44
View File
@@ -0,0 +1,44 @@
\ @(#) wordslik.fth 98/01/26 1.2
\
\ WORDS.LIKE ( <string> -- , search for words that contain string )
\
\ Enter: WORDS.LIKE +
\ Enter: WORDS.LIKE EMIT
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\
\ The pForth software code is dedicated to the public domain,
\ and any third party may reproduce, distribute and modify
\ the pForth software code or any derivative works thereof
\ without any compensation or license. The pForth software
\ code is provided on an "as is" basis without any warranty
\ of any kind, including, without limitation, the implied
\ warranties of merchantability and fitness for a particular
\ purpose and their equivalents under the laws of any jurisdiction.
anew task-wordslik.fth
decimal
: PARTIAL.MATCH.NAME ( $str1 nfa -- flag , is $str1 in nfa ??? )
count $ 1F and
rot count
search
>r 2drop r>
;
: WORDS.LIKE ( <name> -- , print all words containing substring )
BL word latest
>newline
BEGIN
prevname dup 0<> \ get previous name in dictionary
WHILE
2dup partial.match.name
IF
dup id. tab
cr?
THEN
REPEAT 2drop
>newline
;
src/cmd/pforth/pf_all.h
+67
View File
@@ -0,0 +1,67 @@
/* @(#) pf_all.h 98/01/26 1.2 */
#ifndef _pf_all_h
#define _pf_all_h
/***************************************************************
** Include all files needed for PForth
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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.
**
***************************************************************/
#ifdef PF_EMBEDDED
#define PF_NO_INIT
#define PF_NO_STDIO
#define PF_NO_MALLOC
#define PF_NO_CLIB
#define PF_NO_FILEIO
#endif
/* I don't see any way to pass compiler flags to the Mac Code Warrior compiler! */
#ifdef __MWERKS__
#define PF_SUPPORT_FP (1)
#endif
#ifdef WIN32
#define PF_USER_INC2 "pf_win32.h"
#endif
#if defined(PF_USER_INC1)
#include PF_USER_INC1
#else
#include "pf_inc1.h"
#endif
#include "pforth.h"
#include "pf_types.h"
#include "pf_io.h"
#include "pf_guts.h"
#include "pf_text.h"
#include "pfcompil.h"
#include "pf_clib.h"
#include "pf_words.h"
#include "pf_save.h"
#include "pf_mem.h"
#include "pf_cglue.h"
#include "pf_core.h"
#ifdef PF_USER_INC2
/* This could be used to undef and redefine macros. */
#include PF_USER_INC2
#endif
#endif /* _pf_all_h */
src/cmd/pforth/pf_cglue.c
+100
View File
@@ -0,0 +1,100 @@
/* @(#) pf_cglue.c 98/02/11 1.4 */
/***************************************************************
** 'C' Glue support for Forth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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"
extern CFunc0 CustomFunctionTable[];
/***************************************************************/
cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams )
{
cell_t P1, P2, P3, P4, P5;
cell_t Result = 0;
CFunc0 CF;
DBUG(("CallUserFunction: Index = %d, ReturnMode = %d, NumParams = %d\n",
Index, ReturnMode, NumParams ));
CF = CustomFunctionTable[Index];
switch( NumParams )
{
case 0:
Result = ((CFunc0) CF) ( );
break;
case 1:
P1 = POP_DATA_STACK;
Result = ((CFunc1) CF) ( P1 );
break;
case 2:
P2 = POP_DATA_STACK;
P1 = POP_DATA_STACK;
Result = ((CFunc2) CF) ( P1, P2 );
break;
case 3:
P3 = POP_DATA_STACK;
P2 = POP_DATA_STACK;
P1 = POP_DATA_STACK;
Result = ((CFunc3) CF) ( P1, P2, P3 );
break;
case 4:
P4 = POP_DATA_STACK;
P3 = POP_DATA_STACK;
P2 = POP_DATA_STACK;
P1 = POP_DATA_STACK;
Result = ((CFunc4) CF) ( P1, P2, P3, P4 );
break;
case 5:
P5 = POP_DATA_STACK;
P4 = POP_DATA_STACK;
P3 = POP_DATA_STACK;
P2 = POP_DATA_STACK;
P1 = POP_DATA_STACK;
Result = ((CFunc5) CF) ( P1, P2, P3, P4, P5 );
break;
default:
pfReportError("CallUserFunction", PF_ERR_NUM_PARAMS);
EXIT(1);
}
/* Push result on Forth stack if requested. */
if(ReturnMode == C_RETURNS_VALUE) PUSH_DATA_STACK( Result );
return Result;
}
#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
/***************************************************************/
Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams )
{
ucell_t Packed;
char FName[40];
CStringToForth( FName, CName, sizeof(FName) );
Packed = (Index & 0xFFFF) | 0 | (NumParams << 24) |
(ReturnMode << 31);
DBUG(("Packed = 0x%8x\n", Packed));
ffCreateSecondaryHeader( FName );
CODE_COMMA( ID_CALL_C );
CODE_COMMA(Packed);
ffFinishSecondary();
return 0;
}
#endif
src/cmd/pforth/pf_cglue.h
+45
View File
@@ -0,0 +1,45 @@
/* @(#) pf_cglue.h 96/12/18 1.7 */
#ifndef _pf_c_glue_h
#define _pf_c_glue_h
/***************************************************************
** Include file for PForth 'C' Glue support
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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 cell_t (*CFunc0)( void );
typedef cell_t (*CFunc1)( cell_t P1 );
typedef cell_t (*CFunc2)( cell_t P1, cell_t P2 );
typedef cell_t (*CFunc3)( cell_t P1, cell_t P2, cell_t P3 );
typedef cell_t (*CFunc4)( cell_t P1, cell_t P2, cell_t P3, cell_t P4 );
typedef cell_t (*CFunc5)( cell_t P1, cell_t P2, cell_t P3, cell_t P4, cell_t P5 );
#ifdef __cplusplus
extern "C" {
#endif
Err CreateGlueToC( const char *CName, ucell_t Index, cell_t ReturnMode, int32_t NumParams );
Err CompileCustomFunctions( void );
Err LoadCustomFunctionTable( void );
cell_t CallUserFunction( cell_t Index, int32_t ReturnMode, int32_t NumParams );
#ifdef __cplusplus
}
#endif
#define C_RETURNS_VOID (0)
#define C_RETURNS_VALUE (1)
#endif /* _pf_c_glue_h */
src/cmd/pforth/pf_clib.c
+64
View File
@@ -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, David 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_t pfCStringLength( const char *s )
{
cell_t len = 0;
while( *s++ != NUL ) len++;
return len;
}
/* void *memset (void *s, cell_t c, size_t n); */
void *pfSetMemory( void *s, cell_t c, cell_t n )
{
uint8_t *p = s, byt = (uint8_t) c;
while( (n--) > 0) *p++ = byt;
return s;
}
/* void *memccpy (void *s1, const void *s2, cell_t c, size_t n); */
void *pfCopyMemory( void *s1, const void *s2, cell_t n)
{
uint8_t *p1 = s1;
const uint8_t *p2 = s2;
while( (n--) > 0) *p1++ = *p2++;
return s1;
}
#endif /* PF_NO_CLIB */
char pfCharToUpper( char c )
{
return (char) ( ((c>='a') && (c<='z')) ? (c - ('a' - 'A')) : c );
}
char pfCharToLower( char c )
{
return (char) ( ((c>='A') && (c<='Z')) ? (c + ('a' - 'A')) : c );
}
src/cmd/pforth/pf_clib.h
+63
View File
@@ -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, David 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_t pfCStringLength( const char *s );
void *pfSetMemory( void *s, cell_t c, cell_t n );
void *pfCopyMemory( void *s1, const void *s2, cell_t n);
#define EXIT(n) {while(1);}
#ifdef __cplusplus
}
#endif
#else /* PF_NO_CLIB */
#ifdef PF_USER_CLIB
#include PF_USER_CLIB
#else
/* Use stdlib functions if available because they are probably faster. */
#define pfCStringLength strlen
#define pfSetMemory memset
#define pfCopyMemory memcpy
#define EXIT(n) exit(n)
#endif /* PF_USER_CLIB */
#endif /* !PF_NO_CLIB */
#ifdef __cplusplus
extern "C" {
#endif
/* Always use my own functions to avoid macro expansion problems with tolower(*s++) */
char pfCharToUpper( char c );
char pfCharToLower( char c );
#ifdef __cplusplus
}
#endif
#endif /* _pf_clib_h */
src/cmd/pforth/pf_core.c
+584
View File
@@ -0,0 +1,584 @@
/* @(#) pf_core.c 98/01/28 1.5 */
/***************************************************************
** Forth based on 'C'
**
** This file has the main entry points to the pForth library.
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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
***************************************************************/
char gScratch[TIB_SIZE];
pfTaskData_t *gCurrentTask = NULL;
pfDictionary_t *gCurrentDictionary;
cell_t gNumPrimitives;
ExecToken gLocalCompiler_XT; /* custom compiler for local variables */
ExecToken gNumberQ_XT; /* XT of NUMBER? */
ExecToken gQuitP_XT; /* XT of (QUIT) */
ExecToken gAcceptP_XT; /* XT of ACCEPT */
/* Depth of data stack when colon called. */
cell_t gDepthAtColon;
/* Global Forth variables. */
cell_t gVarContext; /* Points to last name field. */
cell_t gVarState; /* 1 if compiling. */
cell_t gVarBase; /* Numeric Base. */
cell_t gVarEcho; /* Echo input. */
cell_t gVarTraceLevel; /* Trace Level for Inner Interpreter. */
cell_t gVarTraceStack; /* Dump Stack each time if true. */
cell_t gVarTraceFlags; /* Enable various internal debug messages. */
cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */
cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
/* data for INCLUDE that allows multiple nested files. */
IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH];
cell_t gIncludeIndex;
static void pfResetForthTask( void );
static void pfInit( void );
static void pfTerm( void );
/* TODO move to pf_config.h header. */
#define DEFAULT_RETURN_DEPTH (512)
#define DEFAULT_USER_DEPTH (512)
#define DEFAULT_HEADER_SIZE (120000)
#define DEFAULT_CODE_SIZE (300000)
/* Initialize globals in a function to simplify loading on
* embedded systems which may not support initialization of data section.
*/
static void pfInit( void )
{
/* all zero */
gCurrentTask = NULL;
gCurrentDictionary = NULL;
gNumPrimitives = 0;
gLocalCompiler_XT = 0;
gVarContext = (cell_t)NULL; /* Points to last name field. */
gVarState = 0; /* 1 if compiling. */
gVarEcho = 0; /* Echo input. */
gVarTraceLevel = 0; /* Trace Level for Inner Interpreter. */
gVarTraceFlags = 0; /* Enable various internal debug messages. */
gVarReturnCode = 0; /* Returned to caller of Forth, eg. UNIX shell. */
gIncludeIndex = 0;
/* non-zero */
gVarBase = 10; /* Numeric Base. */
gDepthAtColon = DEPTH_AT_COLON_INVALID;
gVarTraceStack = 1;
pfInitMemoryAllocator();
ioInit();
}
static void pfTerm( void )
{
ioTerm();
}
/***************************************************************
** Task Management
***************************************************************/
void pfDeleteTask( PForthTask task )
{
pfTaskData_t *cftd = (pfTaskData_t *)task;
FREE_VAR( cftd->td_ReturnLimit );
FREE_VAR( cftd->td_StackLimit );
pfFreeMem( cftd );
}
/* Allocate some extra cells to protect against mild stack underflows. */
#define STACK_SAFETY (8)
PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )
{
pfTaskData_t *cftd;
cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
if( !cftd ) goto nomem;
pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
/* Allocate User Stack */
cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *
(UserStackDepth + STACK_SAFETY)));
if( !cftd->td_StackLimit ) goto nomem;
cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
cftd->td_StackPtr = cftd->td_StackBase;
/* Allocate Return Stack */
cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );
if( !cftd->td_ReturnLimit ) goto nomem;
cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
cftd->td_ReturnPtr = cftd->td_ReturnBase;
/* Allocate Float Stack */
#ifdef PF_SUPPORT_FP
/* Allocate room for as many Floats as we do regular data. */
cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *
(UserStackDepth + STACK_SAFETY)));
if( !cftd->td_FloatStackLimit ) goto nomem;
cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
#endif
cftd->td_InputStream = PF_STDIN;
cftd->td_SourcePtr = &cftd->td_TIB[0];
cftd->td_SourceNum = 0;
return (PForthTask) cftd;
nomem:
ERR("CreateTaskContext: insufficient memory.\n");
if( cftd ) pfDeleteTask( (PForthTask) cftd );
return NULL;
}
/***************************************************************
** Dictionary Management
***************************************************************/
cell_t pfExecIfDefined( const char *CString )
{
int result = 0;
if( NAME_BASE != (cell_t)NULL)
{
ExecToken XT;
if( ffFindC( CString, &XT ) )
{
result = pfCatch( XT );
}
}
return result;
}
/***************************************************************
** Delete a dictionary created by pfCreateDictionary()
*/
void pfDeleteDictionary( PForthDictionary dictionary )
{
pfDictionary_t *dic = (pfDictionary_t *) dictionary;
if( !dic ) return;
if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
{
FREE_VAR( dic->dic_HeaderBaseUnaligned );
FREE_VAR( dic->dic_CodeBaseUnaligned );
}
pfFreeMem( dic );
}
/***************************************************************
** Create a complete dictionary.
** The dictionary consists of two parts, the header with the names,
** and the code portion.
** Delete using pfDeleteDictionary().
** Return pointer to dictionary management structure.
*/
PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )
{
/* Allocate memory for initial dictionary. */
pfDictionary_t *dic;
dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
if( !dic ) goto nomem;
pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
/* Align dictionary segments to preserve alignment of floats across hosts.
* Thank you Helmut Proelss for pointing out that this needs to be cast
* to (ucell_t) on 16 bit systems.
*/
#define DIC_ALIGNMENT_SIZE ((ucell_t)(0x10))
#define DIC_ALIGN(addr) ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))
/* Allocate memory for header. */
if( HeaderSize > 0 )
{
dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );
if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
/* Align header base. */
dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);
dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
dic->dic_HeaderPtr = dic->dic_HeaderBase;
}
else
{
dic->dic_HeaderBase = 0;
}
/* Allocate memory for code. */
dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );
if( !dic->dic_CodeBaseUnaligned ) goto nomem;
dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);
dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES)));
return (PForthDictionary) dic;
nomem:
pfDeleteDictionary( dic );
return NULL;
}
/***************************************************************
** Used by Quit and other routines to restore system.
***************************************************************/
static void pfResetForthTask( void )
{
/* Go back to terminal input. */
gCurrentTask->td_InputStream = PF_STDIN;
/* Reset stacks. */
gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
#ifdef PF_SUPPORT_FP /* Reset Floating Point stack too! */
gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
#endif
/* Advance >IN to end of input. */
gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
gVarState = 0;
}
/***************************************************************
** Set current task context.
***************************************************************/
void pfSetCurrentTask( PForthTask task )
{
gCurrentTask = (pfTaskData_t *) task;
}
/***************************************************************
** Set Quiet Flag.
***************************************************************/
void pfSetQuiet( cell_t IfQuiet )
{
gVarQuiet = (cell_t) IfQuiet;
}
/***************************************************************
** Query message status.
***************************************************************/
cell_t pfQueryQuiet( void )
{
return gVarQuiet;
}
/***************************************************************
** Top level interpreter.
***************************************************************/
ThrowCode pfQuit( void )
{
ThrowCode exception;
int go = 1;
while(go)
{
exception = ffOuterInterpreterLoop();
if( exception == 0 )
{
exception = ffOK();
}
switch( exception )
{
case 0:
break;
case THROW_BYE:
go = 0;
break;
case THROW_ABORT:
default:
ffDotS();
pfReportThrow( exception );
pfHandleIncludeError();
pfResetForthTask();
break;
}
}
return gVarReturnCode;
}
/***************************************************************
** Include file based on 'C' name.
***************************************************************/
cell_t pfIncludeFile( const char *FileName )
{
FileStream *fid;
cell_t Result;
char buffer[32];
cell_t numChars, len;
/* Open file. */
fid = sdOpenFile( FileName, "r" );
if( fid == NULL )
{
ERR("pfIncludeFile could not open ");
ERR(FileName);
EMIT_CR;
return -1;
}
/* Create a dictionary word named ::::FileName for FILE? */
pfCopyMemory( &buffer[0], "::::", 4);
len = (cell_t) pfCStringLength(FileName);
numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
CreateDicEntryC( ID_NOOP, buffer, 0 );
Result = ffIncludeFile( fid ); /* Also close the file. */
/* Create a dictionary word named ;;;; for FILE? */
CreateDicEntryC( ID_NOOP, ";;;;", 0 );
return Result;
}
/***************************************************************
** Output 'C' string message.
** Use sdTerminalOut which works before initializing gCurrentTask.
***************************************************************/
void pfDebugMessage( const char *CString )
{
#if 0
while( *CString )
{
char c = *CString++;
if( c == '\n' )
{
sdTerminalOut( 0x0D );
sdTerminalOut( 0x0A );
pfDebugMessage( "DBG: " );
}
else
{
sdTerminalOut( c );
}
}
#else
(void)CString;
#endif
}
/***************************************************************
** Print a decimal number to debug output.
*/
void pfDebugPrintDecimalNumber( int n )
{
pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
}
/***************************************************************
** Output 'C' string message.
** This is provided to help avoid the use of printf() and other I/O
** which may not be present on a small embedded system.
** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
***************************************************************/
void pfMessage( const char *CString )
{
ioType( CString, (cell_t) pfCStringLength(CString) );
}
/**************************************************************************
** Main entry point for pForth.
*/
cell_t pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )
{
pfTaskData_t *cftd;
pfDictionary_t *dic = NULL;
cell_t Result = 0;
ExecToken EntryPoint = 0;
#ifdef PF_USER_INIT
Result = PF_USER_INIT;
if( Result < 0 ) goto error1;
#endif
pfInit();
/* Allocate Task structure. */
pfDebugMessage("pfDoForth: call pfCreateTask()\n");
cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
if( cftd )
{
pfSetCurrentTask( cftd );
if( !gVarQuiet )
{
MSG( "PForth V"PFORTH_VERSION );
if( IsHostLittleEndian() ) MSG("-LE");
else MSG("-BE");
#if PF_BIG_ENDIAN_DIC
MSG("/BE");
#elif PF_LITTLE_ENDIAN_DIC
MSG("/LE");
#endif
if (sizeof(cell_t) == 8)
{
MSG("/64");
}
else if (sizeof(cell_t) == 4)
{
MSG("/32");
}
MSG( ", built "__DATE__" "__TIME__ );
}
/* Don't use MSG before task set. */
if( SourceName )
{
pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
}
#ifdef PF_NO_GLOBAL_INIT
if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */
#endif
#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
if( IfInit )
{
pfDebugMessage("Build dictionary from scratch.\n");
dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );
}
else
#else
TOUCH(IfInit);
#endif /* !PF_NO_INIT && !PF_NO_SHELL*/
{
if( DicFileName )
{
pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");
EMIT_CR;
dic = pfLoadDictionary( DicFileName, &EntryPoint );
}
else
{
MSG(" (static)");
EMIT_CR;
dic = pfLoadStaticDictionary();
}
}
if( dic == NULL ) goto error2;
if( !gVarQuiet )
{
EMIT_CR;
}
pfDebugMessage("pfDoForth: try AUTO.INIT\n");
Result = pfExecIfDefined("AUTO.INIT");
if( Result != 0 )
{
MSG("Error in AUTO.INIT");
goto error2;
}
if( EntryPoint != 0 )
{
Result = pfCatch( EntryPoint );
}
#ifndef PF_NO_SHELL
else
{
if( SourceName == NULL )
{
pfDebugMessage("pfDoForth: pfQuit\n");
Result = pfQuit();
}
else
{
if( !gVarQuiet )
{
MSG("Including: ");
MSG(SourceName);
MSG("\n");
}
Result = pfIncludeFile( SourceName );
}
}
#endif /* PF_NO_SHELL */
/* Clean up after running Forth. */
pfExecIfDefined("AUTO.TERM");
pfDeleteDictionary( dic );
pfDeleteTask( cftd );
}
pfTerm();
#ifdef PF_USER_TERM
PF_USER_TERM;
#endif
return Result;
error2:
MSG("pfDoForth: Error occured.\n");
pfDeleteTask( cftd );
/* Terminate so we restore normal shell tty mode. */
pfTerm();
#ifdef PF_USER_INIT
error1:
#endif
return -1;
}
#ifdef PF_UNIT_TEST
cell_t pfUnitTest( void )
{
cell_t numErrors = 0;
numErrors += pfUnitTestText();
return numErrors;
}
#endif
src/cmd/pforth/pf_core.h
+38
View File
@@ -0,0 +1,38 @@
/* @(#) pf_core.h 98/01/26 1.3 */
#ifndef _pf_core_h
#define _pf_core_h
/***************************************************************
** Include file for PForth 'C' Glue support
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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 pfInitGlobals( void );
void pfDebugMessage( const char *CString );
void pfDebugPrintDecimalNumber( int n );
cell_t pfUnitTestText( void );
#ifdef __cplusplus
}
#endif
#endif /* _pf_core_h */
src/cmd/pforth/pf_float.h
+43
View File
@@ -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, David 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
src/cmd/pforth/pf_guts.h
+597
View File
@@ -0,0 +1,597 @@
/* @(#) pf_guts.h 98/01/28 1.4 */
#ifndef _pf_guts_h
#define _pf_guts_h
/***************************************************************
** Include file for PForth, a Forth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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 "27"
/*
** PFORTH_FILE_VERSION changes when incompatible changes are made
** in the ".dic" file format.
**
** FV3 - 950225 - Use ABS_TO_CODEREL for CodePtr. See file "pf_save.c".
** FV4 - 950309 - Added NameSize and CodeSize to pfSaveForth().
** FV5 - 950316 - Added Floats and reserved words.
** FV6 - 961213 - Added ID_LOCAL_PLUSSTORE, ID_COLON_P, etc.
** FV7 - 971203 - Added ID_FILL, (1LOCAL@), etc., ran out of reserved, resorted.
** FV8 - 980818 - Added Endian flag.
** FV9 - 20100503 - Added support for 64-bit CELL.
*/
#define PF_FILE_VERSION (9) /* Bump this whenever primitives added. */
#define PF_EARLIEST_FILE_VERSION (9) /* earliest one still compatible */
/***************************************************************
** Sizes and other constants
***************************************************************/
#define TIB_SIZE (256)
#ifndef FALSE
#define FALSE (0)
#endif
#ifndef TRUE
#define TRUE (1)
#endif
#define FFALSE (0)
#define FTRUE (-1)
#define BLANK (' ')
#define FLAG_PRECEDENCE (0x80)
#define FLAG_IMMEDIATE (0x40)
#define FLAG_SMUDGE (0x20)
#define MASK_NAME_SIZE (0x1F)
/* Debug TRACE flags */
#define TRACE_INNER (0x0002)
#define TRACE_COMPILE (0x0004)
#define TRACE_SPECIAL (0x0008)
/* Numeric types returned by NUMBER? */
#define NUM_TYPE_BAD (0)
#define NUM_TYPE_SINGLE (1)
#define NUM_TYPE_DOUBLE (2)
#define NUM_TYPE_FLOAT (3)
#define CREATE_BODY_OFFSET (3*sizeof(cell_t))
/***************************************************************
** Primitive Token IDS
** Do NOT change the order of these IDs or dictionary files will break!
***************************************************************/
enum cforth_primitive_ids
{
ID_EXIT = 0, /* ID_EXIT must always be zero. */
/* Do NOT change the order of these IDs or dictionary files will break! */
ID_1MINUS,
ID_1PLUS,
ID_2DUP,
ID_2LITERAL,
ID_2LITERAL_P,
ID_2MINUS,
ID_2OVER,
ID_2PLUS,
ID_2SWAP,
ID_2_R_FETCH,
ID_2_R_FROM,
ID_2_TO_R,
ID_ACCEPT_P,
ID_ALITERAL,
ID_ALITERAL_P,
ID_ALLOCATE,
ID_AND,
ID_ARSHIFT,
ID_BAIL,
ID_BODY_OFFSET,
ID_BRANCH,
ID_BYE,
ID_CALL_C,
ID_CFETCH,
ID_CMOVE,
ID_CMOVE_UP,
ID_COLON,
ID_COLON_P,
ID_COMPARE,
ID_COMP_EQUAL,
ID_COMP_GREATERTHAN,
ID_COMP_LESSTHAN,
ID_COMP_NOT_EQUAL,
ID_COMP_U_GREATERTHAN,
ID_COMP_U_LESSTHAN,
ID_COMP_ZERO_EQUAL,
ID_COMP_ZERO_GREATERTHAN,
ID_COMP_ZERO_LESSTHAN,
ID_COMP_ZERO_NOT_EQUAL,
ID_CR,
ID_CREATE,
ID_CREATE_P,
ID_CSTORE,
ID_DEFER,
ID_DEFER_P,
ID_DEPTH,
ID_DIVIDE,
ID_DOT,
ID_DOTS,
ID_DO_P,
ID_DROP,
ID_DUMP,
ID_DUP,
ID_D_MINUS,
ID_D_MTIMES,
ID_D_MUSMOD,
ID_D_PLUS,
ID_D_UMSMOD,
ID_D_UMTIMES,
ID_EMIT,
ID_EMIT_P,
ID_EOL,
ID_ERRORQ_P,
ID_EXECUTE,
ID_FETCH,
ID_FILE_CLOSE,
ID_FILE_CREATE,
ID_FILE_OPEN,
ID_FILE_POSITION,
ID_FILE_READ,
ID_FILE_REPOSITION,
ID_FILE_RO,
ID_FILE_RW,
ID_FILE_SIZE,
ID_FILE_WRITE,
ID_FILL,
ID_FIND,
ID_FINDNFA,
ID_FLUSHEMIT,
ID_FREE,
ID_HERE,
ID_NUMBERQ_P,
ID_I,
ID_INCLUDE_FILE,
ID_J,
ID_KEY,
ID_LEAVE_P,
ID_LITERAL,
ID_LITERAL_P,
ID_LOADSYS,
ID_LOCAL_COMPILER,
ID_LOCAL_ENTRY,
ID_LOCAL_EXIT,
ID_LOCAL_FETCH,
ID_LOCAL_FETCH_1,
ID_LOCAL_FETCH_2,
ID_LOCAL_FETCH_3,
ID_LOCAL_FETCH_4,
ID_LOCAL_FETCH_5,
ID_LOCAL_FETCH_6,
ID_LOCAL_FETCH_7,
ID_LOCAL_FETCH_8,
ID_LOCAL_PLUSSTORE,
ID_LOCAL_STORE,
ID_LOCAL_STORE_1,
ID_LOCAL_STORE_2,
ID_LOCAL_STORE_3,
ID_LOCAL_STORE_4,
ID_LOCAL_STORE_5,
ID_LOCAL_STORE_6,
ID_LOCAL_STORE_7,
ID_LOCAL_STORE_8,
ID_LOOP_P,
ID_LSHIFT,
ID_MAX,
ID_MIN,
ID_MINUS,
ID_NAME_TO_PREVIOUS,
ID_NAME_TO_TOKEN,
ID_NOOP,
ID_NUMBERQ,
ID_OR,
ID_OVER,
ID_PICK,
ID_PLUS,
ID_PLUSLOOP_P,
ID_PLUS_STORE,
ID_QDO_P,
ID_QDUP,
ID_QTERMINAL,
ID_QUIT_P,
ID_REFILL,
ID_RESIZE,
ID_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,
ID_CATCH,
ID_THROW,
ID_INTERPRET,
ID_FILE_WO,
ID_FILE_BIN,
/* Added to support 64 bit operation. */
ID_CELL,
ID_CELLS,
/* DELETE-FILE */
ID_FILE_DELETE,
/* 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_FP_D_TO_F,
ID_FP_FSTORE,
ID_FP_FTIMES,
ID_FP_FPLUS,
ID_FP_FMINUS,
ID_FP_FSLASH,
ID_FP_F_ZERO_LESS_THAN,
ID_FP_F_ZERO_EQUALS,
ID_FP_F_LESS_THAN,
ID_FP_F_TO_D,
ID_FP_FFETCH,
ID_FP_FDEPTH,
ID_FP_FDROP,
ID_FP_FDUP,
ID_FP_FLITERAL,
ID_FP_FLITERAL_P,
ID_FP_FLOAT_PLUS,
ID_FP_FLOATS,
ID_FP_FLOOR,
ID_FP_FMAX,
ID_FP_FMIN,
ID_FP_FNEGATE,
ID_FP_FOVER,
ID_FP_FROT,
ID_FP_FROUND,
ID_FP_FSWAP,
ID_FP_FSTAR_STAR,
ID_FP_FABS,
ID_FP_FACOS,
ID_FP_FACOSH,
ID_FP_FALOG,
ID_FP_FASIN,
ID_FP_FASINH,
ID_FP_FATAN,
ID_FP_FATAN2,
ID_FP_FATANH,
ID_FP_FCOS,
ID_FP_FCOSH,
ID_FP_FLN,
ID_FP_FLNP1,
ID_FP_FLOG,
ID_FP_FSIN,
ID_FP_FSINCOS,
ID_FP_FSINH,
ID_FP_FSQRT,
ID_FP_FTAN,
ID_FP_FTANH,
ID_FP_FPICK,
#endif
/* Add new IDs by replacing reserved IDs or extending FP routines. */
/* Do NOT change the order of these IDs or dictionary files will break! */
NUM_PRIMITIVES /* This must always be LAST */
};
/***************************************************************
** THROW Codes
***************************************************************/
/* ANSI standard definitions needed by pForth */
#define THROW_ABORT (-1)
#define THROW_ABORT_QUOTE (-2)
#define THROW_STACK_OVERFLOW (-3)
#define THROW_STACK_UNDERFLOW (-4)
#define THROW_UNDEFINED_WORD (-13)
#define THROW_EXECUTING (-14)
#define THROW_PAIRS (-22)
#define THROW_FLOAT_STACK_UNDERFLOW ( -45)
#define THROW_QUIT (-56)
/* THROW codes unique to pForth */
#define THROW_BYE (-256) /* Exit program. */
#define THROW_SEMICOLON (-257) /* Error detected at ; */
#define THROW_DEFERRED (-258) /* Not a deferred word. Used in system.fth */
/***************************************************************
** Structures
***************************************************************/
typedef struct pfTaskData_s
{
cell_t *td_StackPtr; /* Primary data stack */
cell_t *td_StackBase;
cell_t *td_StackLimit;
cell_t *td_ReturnPtr; /* Return stack */
cell_t *td_ReturnBase;
cell_t *td_ReturnLimit;
#ifdef PF_SUPPORT_FP
PF_FLOAT *td_FloatStackPtr;
PF_FLOAT *td_FloatStackBase;
PF_FLOAT *td_FloatStackLimit;
#endif
cell_t *td_InsPtr; /* Instruction pointer, "PC" */
FileStream *td_InputStream;
/* Terminal. */
char td_TIB[TIB_SIZE]; /* Buffer for terminal input. */
cell_t td_IN; /* Index into Source */
cell_t td_SourceNum; /* #TIB after REFILL */
char *td_SourcePtr; /* Pointer to TIB or other source. */
cell_t td_LineNumber; /* Incremented on every refill. */
cell_t td_OUT; /* Current output column. */
} pfTaskData_t;
typedef struct pfNode
{
struct pfNode *n_Next;
struct pfNode *n_Prev;
} pfNode;
/* Structure of header entry in dictionary. These will be stored in dictionary specific endian format*/
typedef struct cfNameLinks
{
cell_t cfnl_PreviousName; /* name relative address of previous */
ExecToken cfnl_ExecToken; /* Execution token for word. */
/* Followed by variable length name field. */
} cfNameLinks;
#define PF_DICF_ALLOCATED_SEGMENTS ( 0x0001)
typedef struct pfDictionary_s
{
pfNode dic_Node;
ucell_t dic_Flags;
/* Headers contain pointers to names and dictionary. */
ucell_t dic_HeaderBaseUnaligned;
ucell_t dic_HeaderBase;
ucell_t dic_HeaderPtr;
ucell_t dic_HeaderLimit;
/* Code segment contains tokenized code and data. */
ucell_t dic_CodeBaseUnaligned;
ucell_t dic_CodeBase;
union
{
cell_t *Cell;
uint8_t *Byte;
} dic_CodePtr;
ucell_t dic_CodeLimit;
} pfDictionary_t;
/* Save state of include when nesting files. */
typedef struct IncludeFrame
{
FileStream *inf_FileID;
cell_t inf_LineNumber;
cell_t inf_SourceNum;
cell_t inf_IN;
char inf_SaveTIB[TIB_SIZE];
} IncludeFrame;
#define MAX_INCLUDE_DEPTH (16)
/***************************************************************
** Prototypes
***************************************************************/
#ifdef __cplusplus
extern "C" {
#endif
int pfCatch( ExecToken XT );
#ifdef __cplusplus
}
#endif
/***************************************************************
** External Globals
***************************************************************/
extern pfTaskData_t *gCurrentTask;
extern pfDictionary_t *gCurrentDictionary;
extern char gScratch[TIB_SIZE];
extern cell_t gNumPrimitives;
extern ExecToken gLocalCompiler_XT; /* CFA of (LOCAL) compiler. */
extern ExecToken gNumberQ_XT; /* XT of NUMBER? */
extern ExecToken gQuitP_XT; /* XT of (QUIT) */
extern ExecToken gAcceptP_XT; /* XT of ACCEPT */
#define DEPTH_AT_COLON_INVALID (-100)
extern cell_t gDepthAtColon;
/* Global variables. */
extern cell_t gVarContext; /* Points to last name field. */
extern cell_t gVarState; /* 1 if compiling. */
extern cell_t gVarBase; /* Numeric Base. */
extern cell_t gVarEcho; /* Echo input from file. */
extern cell_t gVarEchoAccept; /* Echo input from ACCEPT. */
extern cell_t gVarTraceLevel;
extern cell_t gVarTraceStack;
extern cell_t gVarTraceFlags;
extern cell_t gVarQuiet; /* Suppress unnecessary messages, OK, etc. */
extern cell_t gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
extern IncludeFrame gIncludeStack[MAX_INCLUDE_DEPTH];
extern cell_t gIncludeIndex;
/***************************************************************
** Macros
***************************************************************/
/* Endian specific macros for creating target dictionaries for machines with
** different endian-ness.
*/
#if defined(PF_BIG_ENDIAN_DIC)
#define WRITE_FLOAT_DIC WriteFloatBigEndian
#define WRITE_CELL_DIC(addr,data) WriteCellBigEndian((uint8_t *)(addr),(ucell_t)(data))
#define WRITE_SHORT_DIC(addr,data) Write16BigEndian((uint8_t *)(addr),(uint16_t)(data))
#define READ_FLOAT_DIC ReadFloatBigEndian
#define READ_CELL_DIC(addr) ReadCellBigEndian((const uint8_t *)(addr))
#define READ_SHORT_DIC(addr) Read16BigEndian((const uint8_t *)(addr))
#elif defined(PF_LITTLE_ENDIAN_DIC)
#define WRITE_FLOAT_DIC WriteFloatLittleEndian
#define WRITE_CELL_DIC(addr,data) WriteCellLittleEndian((uint8_t *)(addr),(ucell_t)(data))
#define WRITE_SHORT_DIC(addr,data) Write16LittleEndian((uint8_t *)(addr),(uint16_t)(data))
#define READ_FLOAT_DIC ReadFloatLittleEndian
#define READ_CELL_DIC(addr) ReadCellLittleEndian((const uint8_t *)(addr))
#define READ_SHORT_DIC(addr) Read16LittleEndian((const uint8_t *)(addr))
#else
#define WRITE_FLOAT_DIC(addr,data) { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); }
#define WRITE_CELL_DIC(addr,data) { *((cell_t *)(addr)) = (cell_t)(data); }
#define WRITE_SHORT_DIC(addr,data) { *((int16_t *)(addr)) = (int16_t)(data); }
#define READ_FLOAT_DIC(addr) ( *((PF_FLOAT *)(addr)) )
#define READ_CELL_DIC(addr) ( *((const ucell_t *)(addr)) )
#define READ_SHORT_DIC(addr) ( *((const uint16_t *)(addr)) )
#endif
#define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell)
#define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell)
#define CODE_COMMA( N ) WRITE_CELL_DIC(CODE_HERE++,(N))
#define NAME_BASE (gCurrentDictionary->dic_HeaderBase)
#define CODE_BASE (gCurrentDictionary->dic_CodeBase)
#define NAME_SIZE (gCurrentDictionary->dic_HeaderLimit - gCurrentDictionary->dic_HeaderBase)
#define CODE_SIZE (gCurrentDictionary->dic_CodeLimit - gCurrentDictionary->dic_CodeBase)
#define IN_CODE_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_CodeBase) && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_CodeLimit) )
#define IN_NAME_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_HeaderLimit) )
#define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr))
/* Address conversion */
#define ABS_TO_NAMEREL( a ) ((cell_t) (((ucell_t) a) - NAME_BASE ))
#define ABS_TO_CODEREL( a ) ((cell_t) (((ucell_t) a) - CODE_BASE ))
#define NAMEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + NAME_BASE))
#define CODEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + CODE_BASE))
/* The check for >0 is only needed for CLONE testing. !!! */
#define IsTokenPrimitive(xt) ((xt<gNumPrimitives) && (xt>=0))
#define FREE_VAR(v) { if (v) { pfFreeMem((void *)(v)); v = 0; } }
#define DATA_STACK_DEPTH (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr)
#define DROP_DATA_STACK (gCurrentTask->td_StackPtr++)
#define POP_DATA_STACK (*gCurrentTask->td_StackPtr++)
#define PUSH_DATA_STACK(x) {*(--(gCurrentTask->td_StackPtr)) = (cell_t) x; }
/* Force Quad alignment. */
#define QUADUP(x) (((x)+3)&~3)
#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 MSG(cs) pfMessage(cs)
#define ERR(x) MSG(x)
#define DBUG(x) /* PRT(x) */
#define DBUGX(x) /* DBUG(x) */
#define MSG_NUM_D(msg,num) { MSG(msg); ffDot((cell_t) num); EMIT_CR; }
#define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((cell_t) num); EMIT_CR; }
#define DBUG_NUM_D(msg,num) { pfDebugMessage(msg); pfDebugPrintDecimalNumber((cell_t) num); pfDebugMessage("\n"); }
#endif /* _pf_guts_h */
src/cmd/pforth/pf_host.h
+24
View File
@@ -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, David 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 */
src/cmd/pforth/pf_inc1.h
+48
View File
@@ -0,0 +1,48 @@
/* @(#) pf_unix.h 98/01/28 1.4 */
#ifndef _pf_embedded_h
#define _pf_embedded_h
/***************************************************************
** Embedded System include file for PForth, a Forth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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.
**
***************************************************************/
#ifndef PF_NO_CLIB
#include <string.h> /* Needed for strlen(), memcpy(), and memset(). */
#include <stdlib.h> /* Needed for exit(). */
#endif
#ifdef PF_NO_STDIO
#define NULL ((void *) 0)
#define EOF (-1)
#else
#ifdef CROSS
#include </usr/include/stdio.h>
#else
#include <stdio.h>
#endif
#endif
#ifdef PF_SUPPORT_FP
#include <math.h>
#ifndef PF_USER_FP
#include "pf_float.h"
#else
#include PF_USER_FP
#endif
#endif
#endif /* _pf_embedded_h */
src/cmd/pforth/pf_inner.c
+1803
View File
File diff suppressed because it is too large Load Diff
src/cmd/pforth/pf_io.c
+225
View File
@@ -0,0 +1,225 @@
/* @(#) pf_io.c 96/12/23 1.12 */
/***************************************************************
** I/O subsystem for PForth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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"
/***************************************************************
** Initialize I/O system.
*/
void ioInit( void )
{
/* System dependant terminal initialization. */
sdTerminalInit();
}
void ioTerm( void )
{
sdTerminalTerm();
}
/***************************************************************
** Send single character to output stream.
*/
void ioEmit( char c )
{
cell_t Result;
Result = sdTerminalOut(c);
if( Result < 0 ) EXIT(1);
if( gCurrentTask )
{
if(c == '\n')
{
gCurrentTask->td_OUT = 0;
sdTerminalFlush();
}
else
{
gCurrentTask->td_OUT++;
}
}
}
/***************************************************************
** Send an entire string..
*/
void ioType( const char *s, cell_t n )
{
cell_t i;
for( i=0; i<n; i++)
{
ioEmit ( *s++ );
}
}
/***************************************************************
** Return single character from input device, always keyboard.
*/
cell_t ioKey( void )
{
cell_t c;
sdEnableInput();
c = sdTerminalIn();
sdDisableInput();
return c;
}
/**************************************************************
** Receive line from keyboard.
** Return number of characters enterred.
*/
#define SPACE (0x20)
#define BACKSPACE (0x08)
#define DELETE (0x7F)
cell_t ioAccept( char *buffer, cell_t maxChars )
{
int c;
int len;
char *p;
DBUGX(("ioAccept(0x%x, 0x%x)\n", buffer, len ));
sdEnableInput();
p = buffer;
len = 0;
while(len < maxChars)
{
c = sdTerminalIn();
switch(c)
{
case '\r':
case '\n':
DBUGX(("EOL\n"));
goto gotline;
break;
case BACKSPACE:
case DELETE:
if( len > 0 ) /* Don't go beyond beginning of line. */
{
EMIT(BACKSPACE);
EMIT(' ');
EMIT(BACKSPACE);
p--;
len--;
}
break;
default:
sdTerminalEcho( (char) c );
*p++ = (char) c;
len++;
break;
}
}
gotline:
sdDisableInput();
sdTerminalEcho( SPACE );
/* NUL terminate line to simplify printing when debugging. */
if( len < maxChars ) p[len] = '\0';
return len;
}
#define UNIMPLEMENTED(name) { MSG(name); MSG("is unimplemented!\n"); }
/***********************************************************************************/
/*********** File I/O **************************************************************/
/***********************************************************************************/
#ifdef PF_NO_FILEIO
/* Provide stubs for standard file I/O */
FileStream *PF_STDIN;
FileStream *PF_STDOUT;
cell_t sdInputChar( FileStream *stream )
{
UNIMPLEMENTED("sdInputChar");
TOUCH(stream);
return -1;
}
FileStream *sdOpenFile( const char *FileName, const char *Mode )
{
UNIMPLEMENTED("sdOpenFile");
TOUCH(FileName);
TOUCH(Mode);
return NULL;
}
cell_t sdFlushFile( FileStream * Stream )
{
TOUCH(Stream);
return 0;
}
cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream )
{
UNIMPLEMENTED("sdReadFile");
TOUCH(ptr);
TOUCH(Size);
TOUCH(nItems);
TOUCH(Stream);
return 0;
}
cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream )
{
UNIMPLEMENTED("sdWriteFile");
TOUCH(ptr);
TOUCH(Size);
TOUCH(nItems);
TOUCH(Stream);
return 0;
}
cell_t sdSeekFile( FileStream * Stream, cell_t Position, int32_t Mode )
{
UNIMPLEMENTED("sdSeekFile");
TOUCH(Stream);
TOUCH(Position);
TOUCH(Mode);
return 0;
}
cell_t sdTellFile( FileStream * Stream )
{
UNIMPLEMENTED("sdTellFile");
TOUCH(Stream);
return 0;
}
cell_t sdCloseFile( FileStream * Stream )
{
UNIMPLEMENTED("sdCloseFile");
TOUCH(Stream);
return 0;
}
FileStream *sdDeleteFile( const char *FileName )
{
UNIMPLEMENTED("sdDeleteFile");
TOUCH(FileName);
return NULL;
}
#endif
src/cmd/pforth/pf_io.h
+156
View File
@@ -0,0 +1,156 @@
/* @(#) pf_io.h 98/01/26 1.2 */
#ifndef _pf_io_h
#define _pf_io_h
/***************************************************************
** Include file for PForth IO
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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_CHAR_XON (0x11)
#define PF_CHAR_XOFF (0x13)
int sdTerminalOut( char c );
int sdTerminalEcho( char c );
int sdTerminalFlush( void );
int sdTerminalIn( void );
int sdQueryTerminal( void );
void sdTerminalInit( void );
void sdTerminalTerm( void );
void ioInit( void );
void ioTerm( void );
#ifdef PF_NO_CHARIO
void sdEnableInput( void );
void sdDisableInput( void );
#else /* PF_NO_CHARIO */
#ifdef PF_USER_CHARIO
/* Get user prototypes or macros from include file.
** API must match that defined above for the stubs.
*/
/* If your sdTerminalIn echos, define PF_KEY_ECHOS. */
#include PF_USER_CHARIO
#else
#define sdEnableInput() /* sdTerminalOut( PF_CHAR_XON ) */
#define sdDisableInput() /* sdTerminalOut( PF_CHAR_XOFF ) */
#endif
#endif /* PF_NO_CHARIO */
/* Define file access modes. */
/* User can #undef and re#define using PF_USER_FILEIO if needed. */
#define PF_FAM_READ_ONLY (0)
#define PF_FAM_READ_WRITE (1)
#define PF_FAM_WRITE_ONLY (2)
#define PF_FAM_BINARY_FLAG (8)
#define PF_FAM_CREATE_WO ("w")
#define PF_FAM_CREATE_RW ("w+")
#define PF_FAM_OPEN_RO ("r")
#define PF_FAM_OPEN_RW ("r+")
#define PF_FAM_BIN_CREATE_WO ("wb")
#define PF_FAM_BIN_CREATE_RW ("wb+")
#define PF_FAM_BIN_OPEN_RO ("rb")
#define PF_FAM_BIN_OPEN_RW ("rb+")
#ifdef PF_NO_FILEIO
typedef void FileStream;
extern FileStream *PF_STDIN;
extern FileStream *PF_STDOUT;
#ifdef __cplusplus
extern "C" {
#endif
/* Prototypes for stubs. */
FileStream *sdOpenFile( const char *FileName, const char *Mode );
cell_t sdFlushFile( FileStream * Stream );
cell_t sdReadFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream );
cell_t sdWriteFile( void *ptr, cell_t Size, int32_t nItems, FileStream * Stream );
cell_t sdSeekFile( FileStream * Stream, off_t Position, int32_t Mode );
off_t sdTellFile( FileStream * Stream );
cell_t sdCloseFile( FileStream * Stream );
cell_t sdInputChar( FileStream *stream );
#ifdef __cplusplus
}
#endif
#define PF_SEEK_SET (0)
#define PF_SEEK_CUR (1)
#define PF_SEEK_END (2)
/*
** printf() is only used for debugging purposes.
** It is not required for normal operation.
*/
#define PRT(x) /* No printf(). */
#else
#ifdef PF_USER_FILEIO
/* Get user prototypes or macros from include file.
** API must match that defined above for the stubs.
*/
#include PF_USER_FILEIO
#else
typedef FILE FileStream;
#define sdOpenFile fopen
#define sdDeleteFile remove
#define sdFlushFile fflush
#define sdReadFile fread
#define sdWriteFile fwrite
#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_t ioAccept( char *Target, cell_t n1 );
cell_t ioKey( void);
void ioEmit( char c );
void ioType( const char *s, cell_t n);
#ifdef __cplusplus
}
#endif
#endif /* _pf_io_h */
src/cmd/pforth/pf_io_none.c
+49
View File
@@ -0,0 +1,49 @@
/* $Id$ */
/***************************************************************
** I/O subsystem for PForth when NO CHARACTER I/O is supported.
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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"
#ifdef PF_NO_CHARIO
int sdTerminalOut( char c )
{
TOUCH(c);
return 0;
}
int sdTerminalEcho( char c )
{
TOUCH(c);
return 0;
}
int sdTerminalIn( void )
{
return -1;
}
int sdTerminalFlush( void )
{
return -1;
}
void sdTerminalInit( void )
{
}
void sdTerminalTerm( void )
{
}
#endif
src/cmd/pforth/pf_io_posix.c
+142
View File
@@ -0,0 +1,142 @@
/* $Id$ */
/***************************************************************
** I/O subsystem for PForth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** The pForth software code is dedicated to the public domain,
** and any third party may reproduce, distribute and modify
** the 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
** 090220 PLB Fixed broken sdQueryTerminal on Mac. It always returned true.
***************************************************************/
#include "pf_all.h"
/* Configure console so that characters are not buffered.
* This allows KEY and ?TERMINAL to work and also HISTORY.ON
*/
#include <unistd.h>
#include <strings.h>
#include <sys/time.h>
#ifdef sun
#include <sys/int_types.h> /* Needed on Solaris for uint32_t in termio.h */
#endif
#include <termios.h>
//#include <sys/poll.h>
static struct termios save_termios;
static int stdin_is_tty;
/* poll() is broken in Mac OS X Tiger OS so use select() instead. */
#ifndef PF_USE_SELECT
#define PF_USE_SELECT (1)
#endif
/* Default portable terminal I/O. */
int sdTerminalOut( char c )
{
return putchar(c);
}
int sdTerminalEcho( char c )
{
putchar(c);
return 0;
}
int sdTerminalIn( void )
{
return getchar();
}
int sdTerminalFlush( void )
{
#ifdef PF_NO_FILEIO
return -1;
#else
return fflush(PF_STDOUT);
#endif
}
/****************************************************/
int sdQueryTerminal( void )
{
#if PF_USE_SELECT
int select_retval;
fd_set readfds;
struct timeval tv;
FD_ZERO(&readfds);
FD_SET(STDIN_FILENO, &readfds);
/* Set timeout to zero so that we just poll and return. */
tv.tv_sec = 0;
tv.tv_usec = 0;
select_retval = select(STDIN_FILENO+1, &readfds, NULL, NULL, &tv);
if (select_retval < 0)
{
perror("sdTerminalInit: select");
}
return FD_ISSET(STDIN_FILENO,&readfds) ? FTRUE : FFALSE;
#else
int result;
struct pollfd pfd = { 0 };
sdTerminalFlush();
pfd.fd = STDIN_FILENO;
pfd.events = POLLIN;
result = poll( &pfd, 1, 0 );
/* On a Mac it may set revents to POLLNVAL because poll() is broken on Tiger. */
if( pfd.revents & POLLNVAL )
{
PRT(("sdQueryTerminal: poll got POLLNVAL, stdin not open\n"));
return FFALSE;
}
else
{
return (pfd.revents & POLLIN) ? FTRUE : FFALSE;
}
#endif
}
/****************************************************/
void sdTerminalInit(void)
{
struct termios term;
stdin_is_tty = isatty(STDIN_FILENO);
if (stdin_is_tty)
{
/* Get current terminal attributes and save them so we can restore them. */
tcgetattr(STDIN_FILENO, &term);
save_termios = term;
/* ICANON says to wait upon read until a character is received,
* and then to return it immediately (or soon enough....)
* ECHOCTL says not to echo backspaces and other control chars as ^H */
term.c_lflag &= ~( ECHO | ECHONL | ECHOCTL | ICANON );
term.c_cc[VTIME] = 0;
term.c_cc[VMIN] = 1;
if( tcsetattr(STDIN_FILENO, TCSANOW, &term) < 0 )
{
perror("sdTerminalInit: tcsetattr");
}
}
}
/****************************************************/
void sdTerminalTerm(void)
{
if (stdin_is_tty)
{
tcsetattr(STDIN_FILENO, TCSANOW, &save_termios);
}
}
src/cmd/pforth/pf_io_stdio.c
+56
View File
@@ -0,0 +1,56 @@
/* $Id$ */
/***************************************************************
** I/O subsystem for PForth for common systems.
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** The pForth software code is dedicated to the public domain,
** and any third party may reproduce, distribute and modify
** the 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"
/* Default portable terminal I/O. */
int sdTerminalOut( char c )
{
return putchar(c);
}
/* We don't need to echo because getchar() echos. */
int sdTerminalEcho( char c )
{
return 0;
}
int sdTerminalIn( void )
{
return getchar();
}
int sdQueryTerminal( void )
{
return 0;
}
int sdTerminalFlush( void )
{
#ifdef PF_NO_FILEIO
return -1;
#else
return fflush(PF_STDOUT);
#endif
}
void sdTerminalInit( void )
{
}
void sdTerminalTerm( void )
{
}
src/cmd/pforth/pf_main.c
+150
View File
@@ -0,0 +1,150 @@
/* @(#) pf_main.c 98/01/26 1.2 */
/***************************************************************
** Forth based on 'C'
**
** main() routine that demonstrates how to call PForth as
** a module from 'C' based application.
** Customize this as needed for your application.
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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.
**
***************************************************************/
#if (defined(PF_NO_STDIO) || defined(PF_EMBEDDED))
#define NULL ((void *) 0)
#define ERR(msg) /* { printf msg; } */
#else
#ifdef CROSS
#include </usr/include/stdio.h>
#else
#include <stdio.h>
#endif
#define ERR(msg) { printf msg; }
#endif
#include "pforth.h"
#ifndef PF_DEFAULT_DICTIONARY
#define PF_DEFAULT_DICTIONARY "/lib/pforth.dic"
#endif
#ifdef __MWERKS__
#include <console.h>
#include <sioux.h>
#endif
#ifndef TRUE
#define TRUE (1)
#define FALSE (0)
#endif
#ifdef PF_EMBEDDED
int main( void )
{
char IfInit = 0;
const char *DicName = NULL;
const char *SourceName = NULL;
pfMessage("\npForth Embedded\n");
return pfDoForth( DicName, SourceName, IfInit);
}
#else
int main( int argc, char **argv )
{
#ifdef PF_STATIC_DIC
const char *DicName = NULL;
#else /* PF_STATIC_DIC */
const char *DicName = PF_DEFAULT_DICTIONARY;
#endif /* !PF_STATIC_DIC */
const char *SourceName = NULL;
char IfInit = FALSE;
char *s;
cell_t i;
int Result;
/* For Metroworks on Mac */
#ifdef __MWERKS__
argc = ccommand(&argv);
#endif
pfSetQuiet( FALSE );
/* Parse command line. */
for( i=1; i<argc; i++ )
{
s = argv[i];
if( *s == '-' )
{
char c;
s++; /* past '-' */
c = *s++;
switch(c)
{
case 'i':
IfInit = TRUE;
DicName = NULL;
break;
case 'q':
pfSetQuiet( TRUE );
break;
case 'd':
if( *s != '\0' ) DicName = s;
/* Allow space after -d (Thanks Aleksej Saushev) */
/* Make sure there is another argument. */
else if( (i+1) < argc )
{
DicName = argv[++i];
}
if (DicName == NULL || *DicName == '\0')
{
DicName = PF_DEFAULT_DICTIONARY;
}
break;
default:
ERR(("Unrecognized option!\n"));
ERR(("pforth {-i} {-q} {-dfilename.dic} {sourcefilename}\n"));
Result = 1;
goto on_error;
break;
}
}
else
{
SourceName = s;
}
}
/* Force Init */
#ifdef PF_INIT_MODE
IfInit = TRUE;
DicName = NULL;
#endif
#ifdef PF_UNIT_TEST
if( (Result = pfUnitTest()) != 0 )
{
ERR(("pForth stopping on unit test failure.\n"));
goto on_error;
}
#endif
Result = pfDoForth( DicName, SourceName, IfInit);
on_error:
return Result;
}
#endif /* PF_EMBEDDED */
src/cmd/pforth/pf_mem.c
+366
View File
@@ -0,0 +1,366 @@
/***************************************************************
** Memory allocator for systems that don't have real one.
** This might be useful when bringing up a new computer with no OS.
**
** For PForth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** The pForth software code is dedicated to the public domain,
** and any third party may reproduce, distribute and modify
** the pForth software code or any derivative works thereof
** without any compensation or license. The pForth software
** code is provided on an "as is" basis without any warranty
** of any kind, including, without limitation, the implied
** warranties of merchantability and fitness for a particular
** purpose and their equivalents under the laws of any jurisdiction.
**
****************************************************************
**
***************************************************************/
#include "pf_all.h"
#ifdef PF_NO_MALLOC
static char *gMemPoolPtr;
static ucell_t gMemPoolSize;
/* CUSTOM: Make the memory pool bigger if you want. */
#ifndef PF_MEM_POOL_SIZE
#define PF_MEM_POOL_SIZE (0x100000)
#endif
#define PF_MEM_BLOCK_SIZE (16)
#ifndef PF_MALLOC_ADDRESS
static char MemoryPool[PF_MEM_POOL_SIZE];
#define PF_MALLOC_ADDRESS MemoryPool
#endif
/**********************************************************
** Doubly Linked List Tools
**********************************************************/
typedef struct DoublyLinkedListNode_s
{
struct DoublyLinkedListNode_s *dlln_Next;
struct DoublyLinkedListNode_s *dlln_Previous;
} DoublyLinkedListNode;
typedef struct DoublyLinkedList_s
{
DoublyLinkedListNode *dll_First;
DoublyLinkedListNode *dll_Null;
DoublyLinkedListNode *dll_Last;
} DoublyLinkedList;
#define dllPreviousNode(n) ((n)->dlln_Previous)
#define dllNextNode(n) ((n)->dlln_Next)
void dllSetupList( DoublyLinkedList *dll )
{
dll->dll_First = &(dll->dll_Null);
dll->dll_Null = (DoublyLinkedListNode *) NULL;
dll->dll_Last = &(dll->dll_First);
}
void dllLinkNodes( DoublyLinkedListNode *Node0, DoublyLinkedListNode *Node1 )
{
Node0->dlln_Next = Node1;
Node1->dlln_Previous = Node0;
}
void dllInsertNodeBefore( DoublyLinkedListNode *NewNodePtr,
DoublyLinkedListNode *NodeInListPtr )
{
DoublyLinkedListNode *NodePreviousPtr = dllPreviousNode( NodeInListPtr );
dllLinkNodes( NodePreviousPtr, NewNodePtr );
dllLinkNodes( NewNodePtr, NodeInListPtr );
}
void dllInsertNodeAfter( DoublyLinkedListNode *NewNodePtr,
DoublyLinkedListNode *NodeInListPtr )
{
DoublyLinkedListNode *NodeNextPtr = dllNextNode( NodeInListPtr );
dllLinkNodes( NodeInListPtr, NewNodePtr );
dllLinkNodes( NewNodePtr, NodeNextPtr );
}
void dllDumpNode( DoublyLinkedListNode *NodePtr )
{
TOUCH(NodePtr);
DBUG((" 0x%x -> (0x%x) -> 0x%x\n",
dllPreviousNode( NodePtr ), NodePtr,
dllNextNode( NodePtr ) ));
}
cell_t dllCheckNode( DoublyLinkedListNode *NodePtr )
{
if( (NodePtr->dlln_Next->dlln_Previous != NodePtr) ||
(NodePtr->dlln_Previous->dlln_Next != NodePtr))
{
ERR("dllCheckNode: Bad Node!\n");
dllDumpNode( dllPreviousNode( NodePtr ) );
dllDumpNode( NodePtr );
dllDumpNode( dllNextNode( NodePtr ) );
return -1;
}
else
{
return 0;
}
}
void dllRemoveNode( DoublyLinkedListNode *NodePtr )
{
if( dllCheckNode( NodePtr ) == 0 )
{
dllLinkNodes( dllPreviousNode( NodePtr ), dllNextNode( NodePtr ) );
}
}
void dllAddNodeToHead( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr )
{
dllInsertNodeBefore( NewNodePtr, ListPtr->dll_First );
}
void dllAddNodeToTail( DoublyLinkedList *ListPtr, DoublyLinkedListNode *NewNodePtr )
{
dllInsertNodeAfter( NewNodePtr, ListPtr->dll_Last );
}
#define dllIsNodeInList( n ) (!((n)->dlln_Next == NULL) )
#define dllIsLastNode( n ) ((n)->dlln_Next->dll_nNext == NULL )
#define dllIsListEmpty( l ) ((l)->dll_First == ((DoublyLinkedListNode *) &((l)->dll_Null)) )
#define dllFirstNode( l ) ((l)->dll_First)
static DoublyLinkedList gMemList;
typedef struct MemListNode
{
DoublyLinkedListNode mln_Node;
cell_t mln_Size;
} MemListNode;
#ifdef PF_DEBUG
/***************************************************************
** Dump memory list.
*/
void maDumpList( void )
{
MemListNode *mln;
MSG("PForth MemList\n");
for( mln = (MemListNode *) dllFirstNode( &gMemList );
dllIsNodeInList( (DoublyLinkedListNode *) mln);
mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )
{
MSG(" Node at = 0x"); ffDotHex(mln);
MSG_NUM_H(", size = 0x", mln->mln_Size);
}
}
#endif
/***************************************************************
** Free mem of any size.
*/
static void pfFreeRawMem( char *Mem, cell_t NumBytes )
{
MemListNode *mln, *FreeNode;
MemListNode *AdjacentLower = NULL;
MemListNode *AdjacentHigher = NULL;
MemListNode *NextBiggest = NULL;
/* Allocate in whole blocks of 16 bytes */
DBUG(("\npfFreeRawMem( 0x%x, 0x%x )\n", Mem, NumBytes ));
NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1);
DBUG(("\npfFreeRawMem: Align NumBytes to 0x%x\n", NumBytes ));
/* Check memory alignment. */
if( ( ((cell_t)Mem) & (PF_MEM_BLOCK_SIZE - 1)) != 0)
{
MSG_NUM_H("pfFreeRawMem: misaligned Mem = 0x", (cell_t) Mem );
return;
}
/* Scan list from low to high looking for various nodes. */
for( mln = (MemListNode *) dllFirstNode( &gMemList );
dllIsNodeInList( (DoublyLinkedListNode *) mln);
mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )
{
if( (((char *) mln) + mln->mln_Size) == Mem )
{
AdjacentLower = mln;
}
else if( ((char *) mln) == ( Mem + NumBytes ))
{
AdjacentHigher = mln;
}
/* is this the next biggest node. */
else if( (NextBiggest == NULL) && (mln->mln_Size >= NumBytes) )
{
NextBiggest = mln;
}
}
/* Check to see if we can merge nodes. */
if( AdjacentHigher )
{
DBUG((" Merge (0x%x) -> 0x%x\n", Mem, AdjacentHigher ));
NumBytes += AdjacentHigher->mln_Size;
dllRemoveNode( (DoublyLinkedListNode *) AdjacentHigher );
}
if( AdjacentLower )
{
DBUG((" Merge 0x%x -> (0x%x)\n", AdjacentLower, Mem ));
AdjacentLower->mln_Size += NumBytes;
}
else
{
DBUG((" Link before 0x%x\n", NextBiggest ));
FreeNode = (MemListNode *) Mem;
FreeNode->mln_Size = NumBytes;
if( NextBiggest == NULL )
{
/* Nothing bigger so add to end of list. */
dllAddNodeToTail( &gMemList, (DoublyLinkedListNode *) FreeNode );
}
else
{
/* Add this node before the next biggest one we found. */
dllInsertNodeBefore( (DoublyLinkedListNode *) FreeNode,
(DoublyLinkedListNode *) NextBiggest );
}
}
/* maDumpList(); */
}
/***************************************************************
** Setup memory list. Initialize allocator.
*/
static void pfInitMemBlock( void *addr, ucell_t poolSize )
{
char *AlignedMemory;
cell_t AlignedSize;
pfDebugMessage("pfInitMemBlock()\n");
/* Set globals. */
gMemPoolPtr = addr;
gMemPoolSize = poolSize;
dllSetupList( &gMemList );
/* Adjust to next highest aligned memory location. */
AlignedMemory = (char *) ((((cell_t)gMemPoolPtr) + PF_MEM_BLOCK_SIZE - 1) &
~(PF_MEM_BLOCK_SIZE - 1));
/* Adjust size to reflect aligned memory. */
AlignedSize = gMemPoolSize - (AlignedMemory - gMemPoolPtr);
/* Align size of pool. */
AlignedSize = AlignedSize & ~(PF_MEM_BLOCK_SIZE - 1);
/* Free to pool. */
pfFreeRawMem( AlignedMemory, AlignedSize );
}
/***************************************************************
** Allocate mem from list of free nodes.
*/
static char *pfAllocRawMem( cell_t NumBytes )
{
char *Mem = NULL;
MemListNode *mln;
pfDebugMessage("pfAllocRawMem()\n");
if( NumBytes <= 0 ) return NULL;
/* Allocate in whole blocks of 16 bytes */
NumBytes = (NumBytes + PF_MEM_BLOCK_SIZE - 1) & ~(PF_MEM_BLOCK_SIZE - 1);
DBUG(("\npfAllocRawMem( 0x%x )\n", NumBytes ));
/* Scan list from low to high until we find a node big enough. */
for( mln = (MemListNode *) dllFirstNode( &gMemList );
dllIsNodeInList( (DoublyLinkedListNode *) mln);
mln = (MemListNode *) dllNextNode( (DoublyLinkedListNode *) mln ) )
{
if( mln->mln_Size >= NumBytes )
{
cell_t RemSize;
Mem = (char *) mln;
/* Remove this node from list. */
dllRemoveNode( (DoublyLinkedListNode *) mln );
/* Is there enough left in block to make it worth splitting? */
RemSize = mln->mln_Size - NumBytes;
if( RemSize >= PF_MEM_BLOCK_SIZE )
{
pfFreeRawMem( (Mem + NumBytes), RemSize );
}
break;
}
}
/* maDumpList(); */
DBUG(("Allocate mem at 0x%x.\n", Mem ));
return Mem;
}
/***************************************************************
** Keep mem size at first cell.
*/
char *pfAllocMem( cell_t NumBytes )
{
cell_t *IntMem;
if( NumBytes <= 0 ) return NULL;
/* Allocate an extra cell for size. */
NumBytes += sizeof(cell_t);
IntMem = (cell_t *)pfAllocRawMem( NumBytes );
if( IntMem != NULL ) *IntMem++ = NumBytes;
return (char *) IntMem;
}
/***************************************************************
** Free mem with mem size at first cell.
*/
void pfFreeMem( void *Mem )
{
cell_t *IntMem;
cell_t NumBytes;
if( Mem == NULL ) return;
/* Allocate an extra cell for size. */
IntMem = (cell_t *) Mem;
IntMem--;
NumBytes = *IntMem;
pfFreeRawMem( (char *) IntMem, NumBytes );
}
void pfInitMemoryAllocator( void )
{
pfInitMemBlock( PF_MALLOC_ADDRESS, PF_MEM_POOL_SIZE );
}
#else /* PF_NO_MALLOC */
int not_an_empty_file; /* Stops nasty compiler warnings when PF_NO_MALLOC not defined. */
#endif /* PF_NO_MALLOC */
src/cmd/pforth/pf_mem.h
+47
View File
@@ -0,0 +1,47 @@
/* @(#) pf_mem.h 98/01/26 1.3 */
#ifndef _pf_mem_h
#define _pf_mem_h
/***************************************************************
** Include file for PForth Fake Memory Allocator
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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 pfInitMemoryAllocator( void );
char *pfAllocMem( cell_t NumBytes );
void pfFreeMem( void *Mem );
#ifdef __cplusplus
}
#endif
#else
#ifdef PF_USER_MALLOC
/* Get user prototypes or macros from include file.
** API must match that defined above for the stubs.
*/
#include PF_USER_MALLOC
#else
#define pfInitMemoryAllocator()
#define pfAllocMem malloc
#define pfFreeMem free
#endif
#endif /* PF_NO_MALLOC */
#endif /* _pf_mem_h */
src/cmd/pforth/pf_save.c
+845
View File
@@ -0,0 +1,845 @@
/* @(#) pf_save.c 98/01/26 1.3 */
/***************************************************************
** Save and Load Dictionary
** for PForth based on 'C'
**
** Compile file based version or static data based version
** depending on PF_NO_FILEIO switch.
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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
** 000623 PLB Cast chars as ucell_t before shifting for 16 bit systems.
***************************************************************/
#include <assert.h>
#include "pf_all.h"
/* If no File I/O, then force static dictionary. */
#ifdef PF_NO_FILEIO
#ifndef PF_STATIC_DIC
#define PF_STATIC_DIC
#endif
#endif
#ifdef PF_STATIC_DIC
#include "pfdicdat.h"
#endif
/*
Dictionary File Format based on IFF standard.
The chunk IDs, sizes, and data values are all Big Endian in conformance with the IFF standard.
The dictionaries may be big or little endian.
'FORM'
size
'P4TH' - Form Identifier
Chunks
'P4DI'
size
struct DictionaryInfoChunk
'P4NM'
size
Name and Header portion of dictionary. (Big or Little Endian) (Optional)
'P4CD'
size
Code portion of dictionary. (Big or Little Endian)
*/
/***************************************************************/
/* Endian-ness tools. */
ucell_t ReadCellBigEndian( const uint8_t *addr )
{
ucell_t temp = (ucell_t)addr[0];
temp = (temp << 8) | ((ucell_t)addr[1]);
temp = (temp << 8) | ((ucell_t)addr[2]);
temp = (temp << 8) | ((ucell_t)addr[3]);
if( sizeof(ucell_t) == 8 )
{
temp = (temp << 8) | ((ucell_t)addr[4]);
temp = (temp << 8) | ((ucell_t)addr[5]);
temp = (temp << 8) | ((ucell_t)addr[6]);
temp = (temp << 8) | ((ucell_t)addr[7]);
}
return temp;
}
/***************************************************************/
/* Endian-ness tools. */
uint32_t Read32BigEndian( const uint8_t *addr )
{
uint32_t temp = (uint32_t)addr[0];
temp = (temp << 8) | ((uint32_t)addr[1]);
temp = (temp << 8) | ((uint32_t)addr[2]);
temp = (temp << 8) | ((uint32_t)addr[3]);
return temp;
}
/***************************************************************/
uint16_t Read16BigEndian( const uint8_t *addr )
{
return (uint16_t) ((addr[0]<<8) | addr[1]);
}
/***************************************************************/
ucell_t ReadCellLittleEndian( const uint8_t *addr )
{
ucell_t temp = 0;
if( sizeof(ucell_t) == 8 )
{
temp = (temp << 8) | ((uint32_t)addr[7]);
temp = (temp << 8) | ((uint32_t)addr[6]);
temp = (temp << 8) | ((uint32_t)addr[5]);
temp = (temp << 8) | ((uint32_t)addr[4]);
}
temp = (temp << 8) | ((uint32_t)addr[3]);
temp = (temp << 8) | ((uint32_t)addr[2]);
temp = (temp << 8) | ((uint32_t)addr[1]);
temp = (temp << 8) | ((uint32_t)addr[0]);
return temp;
}
/***************************************************************/
uint32_t Read32LittleEndian( const uint8_t *addr )
{
uint32_t temp = (uint32_t)addr[3];
temp = (temp << 8) | ((uint32_t)addr[2]);
temp = (temp << 8) | ((uint32_t)addr[1]);
temp = (temp << 8) | ((uint32_t)addr[0]);
return temp;
}
/***************************************************************/
uint16_t Read16LittleEndian( const uint8_t *addr )
{
const unsigned char *bp = (const unsigned char *) addr;
return (uint16_t) ((bp[1]<<8) | bp[0]);
}
#ifdef PF_SUPPORT_FP
/***************************************************************/
static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst );
static void ReverseCopyFloat( const PF_FLOAT *src, PF_FLOAT *dst )
{
int i;
unsigned char *d = (unsigned char *) dst;
const unsigned char *s = (const unsigned char *) src;
for( i=0; i<sizeof(PF_FLOAT); i++ )
{
d[i] = s[sizeof(PF_FLOAT) - 1 - i];
}
}
/***************************************************************/
void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data )
{
if( IsHostLittleEndian() )
{
ReverseCopyFloat( &data, addr );
}
else
{
*addr = data;
}
}
/***************************************************************/
PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr )
{
PF_FLOAT data;
if( IsHostLittleEndian() )
{
ReverseCopyFloat( addr, &data );
return data;
}
else
{
return *addr;
}
}
/***************************************************************/
void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data )
{
if( IsHostLittleEndian() )
{
*addr = data;
}
else
{
ReverseCopyFloat( &data, addr );
}
}
/***************************************************************/
PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr )
{
PF_FLOAT data;
if( IsHostLittleEndian() )
{
return *addr;
}
else
{
ReverseCopyFloat( addr, &data );
return data;
}
}
#endif /* PF_SUPPORT_FP */
/***************************************************************/
void WriteCellBigEndian( uint8_t *addr, ucell_t data )
{
/* Write should be in order of increasing address
* to optimize for burst writes to DRAM. */
#if 0
if( sizeof(ucell_t) == 8 )
{
*addr++ = (uint8_t) (data>>56);
*addr++ = (uint8_t) (data>>48);
*addr++ = (uint8_t) (data>>40);
*addr++ = (uint8_t) (data>>32);
}
#endif
*addr++ = (uint8_t) (data>>24);
*addr++ = (uint8_t) (data>>16);
*addr++ = (uint8_t) (data>>8);
*addr = (uint8_t) (data);
}
/***************************************************************/
void Write32BigEndian( uint8_t *addr, uint32_t data )
{
*addr++ = (uint8_t) (data>>24);
*addr++ = (uint8_t) (data>>16);
*addr++ = (uint8_t) (data>>8);
*addr = (uint8_t) (data);
}
/***************************************************************/
void Write16BigEndian( uint8_t *addr, uint16_t data )
{
*addr++ = (uint8_t) (data>>8);
*addr = (uint8_t) (data);
}
/***************************************************************/
void WriteCellLittleEndian( uint8_t *addr, ucell_t data )
{
/* Write should be in order of increasing address
* to optimize for burst writes to DRAM. */
if( sizeof(ucell_t) == 8 )
{
*addr++ = (uint8_t) data; /* LSB at near end */
data = data >> 8;
*addr++ = (uint8_t) data;
data = data >> 8;
*addr++ = (uint8_t) data;
data = data >> 8;
*addr++ = (uint8_t) data;
data = data >> 8;
}
*addr++ = (uint8_t) data;
data = data >> 8;
*addr++ = (uint8_t) data;
data = data >> 8;
*addr++ = (uint8_t) data;
data = data >> 8;
*addr = (uint8_t) data;
}
/***************************************************************/
void Write32LittleEndian( uint8_t *addr, uint32_t data )
{
*addr++ = (uint8_t) data;
data = data >> 8;
*addr++ = (uint8_t) data;
data = data >> 8;
*addr++ = (uint8_t) data;
data = data >> 8;
*addr = (uint8_t) data;
}
/***************************************************************/
void Write16LittleEndian( uint8_t *addr, uint16_t data )
{
*addr++ = (uint8_t) data;
data = data >> 8;
*addr = (uint8_t) data;
}
/***************************************************************/
/* Return 1 if host CPU is Little Endian */
int IsHostLittleEndian( void )
{
static int gEndianCheck = 1;
unsigned char *bp = (unsigned char *) &gEndianCheck;
return (int) (*bp); /* Return byte pointed to by address. If LSB then == 1 */
}
#if defined(PF_NO_FILEIO) || defined(PF_NO_SHELL)
cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize)
{
TOUCH(FileName);
TOUCH(EntryPoint);
TOUCH(NameSize);
TOUCH(CodeSize);
pfReportError("ffSaveForth", PF_ERR_NOT_SUPPORTED);
return -1;
}
#else /* PF_NO_FILEIO or PF_NO_SHELL */
/***************************************************************/
static int Write32ToFile( FileStream *fid, uint32_t Val )
{
int numw;
uint8_t pad[4];
Write32BigEndian(pad,Val);
numw = sdWriteFile( pad, 1, sizeof(pad), fid );
if( numw != sizeof(pad) ) return -1;
return 0;
}
/***************************************************************/
static cell_t WriteChunkToFile( FileStream *fid, cell_t ID, char *Data, int32_t NumBytes )
{
cell_t numw;
cell_t EvenNumW;
EvenNumW = EVENUP(NumBytes);
if( Write32ToFile( fid, ID ) < 0 ) goto error;
if( Write32ToFile( fid, EvenNumW ) < 0 ) goto error;
numw = sdWriteFile( Data, 1, EvenNumW, fid );
if( numw != EvenNumW ) goto error;
return 0;
error:
pfReportError("WriteChunkToFile", PF_ERR_WRITE_FILE);
return -1;
}
/* Convert dictionary info chunk between native and on-disk (big-endian). */
static void
convertDictionaryInfoWrite (DictionaryInfoChunk *sd)
{
/* Convert all fields in DictionaryInfoChunk from Native to BigEndian.
* This assumes they are all 32-bit integers.
*/
int i;
uint32_t *p = (uint32_t *) sd;
for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++)
{
Write32BigEndian( (uint8_t *)&p[i], p[i] );
}
}
static void
convertDictionaryInfoRead (DictionaryInfoChunk *sd)
{
/* Convert all fields in structure from BigEndian to Native. */
int i;
uint32_t *p = (uint32_t *) sd;
for (i=0; i<((int)(sizeof(*sd)/sizeof(uint32_t))); i++)
{
p[i] = Read32BigEndian( (uint8_t *)&p[i] );
}
}
/****************************************************************
** Save Dictionary in File.
** If EntryPoint is NULL, save as development environment.
** If EntryPoint is non-NULL, save as turnKey environment with no names.
*/
cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize)
{
FileStream *fid;
DictionaryInfoChunk SD;
uint32_t FormSize;
uint32_t NameChunkSize = 0;
uint32_t CodeChunkSize;
uint32_t relativeCodePtr;
fid = sdOpenFile( FileName, "wb" );
if( fid == NULL )
{
pfReportError("pfSaveDictionary", PF_ERR_OPEN_FILE);
return -1;
}
/* Save in uninitialized form. */
pfExecIfDefined("AUTO.TERM");
/* Write FORM Header ---------------------------- */
if( Write32ToFile( fid, ID_FORM ) < 0 ) goto error;
if( Write32ToFile( fid, 0 ) < 0 ) goto error;
if( Write32ToFile( fid, ID_P4TH ) < 0 ) goto error;
/* Write P4DI Dictionary Info ------------------ */
SD.sd_Version = PF_FILE_VERSION;
relativeCodePtr = ABS_TO_CODEREL(gCurrentDictionary->dic_CodePtr.Byte); /* 940225 */
SD.sd_RelCodePtr = relativeCodePtr;
SD.sd_UserStackSize = sizeof(cell_t) * (gCurrentTask->td_StackBase - gCurrentTask->td_StackLimit);
SD.sd_ReturnStackSize = sizeof(cell_t) * (gCurrentTask->td_ReturnBase - gCurrentTask->td_ReturnLimit);
SD.sd_NumPrimitives = gNumPrimitives; /* Must match compiled dictionary. */
#ifdef PF_SUPPORT_FP
SD.sd_FloatSize = sizeof(PF_FLOAT); /* Must match compiled dictionary. */
#else
SD.sd_FloatSize = 0;
#endif
SD.sd_CellSize = sizeof(cell_t);
/* Set bit that specifies whether dictionary is BIG or LITTLE Endian. */
{
#if defined(PF_BIG_ENDIAN_DIC)
int eflag = SD_F_BIG_ENDIAN_DIC;
#elif defined(PF_LITTLE_ENDIAN_DIC)
int eflag = 0;
#else
int eflag = IsHostLittleEndian() ? 0 : SD_F_BIG_ENDIAN_DIC;
#endif
SD.sd_Flags = eflag;
}
if( EntryPoint )
{
SD.sd_EntryPoint = EntryPoint; /* Turnkey! */
}
else
{
SD.sd_EntryPoint = 0;
}
/* Do we save names? */
if( NameSize == 0 )
{
SD.sd_RelContext = 0;
SD.sd_RelHeaderPtr = 0;
SD.sd_NameSize = 0;
}
else
{
uint32_t relativeHeaderPtr;
/* Development mode. */
SD.sd_RelContext = ABS_TO_NAMEREL(gVarContext);
relativeHeaderPtr = ABS_TO_NAMEREL(gCurrentDictionary->dic_HeaderPtr);
SD.sd_RelHeaderPtr = relativeHeaderPtr;
/* How much real name space is there? */
NameChunkSize = QUADUP(relativeHeaderPtr); /* Align */
/* NameSize must be 0 or greater than NameChunkSize + 1K */
NameSize = QUADUP(NameSize); /* Align */
if( NameSize > 0 )
{
NameSize = MAX( NameSize, (NameChunkSize + 1024) );
}
SD.sd_NameSize = NameSize;
}
/* How much real code is there? */
CodeChunkSize = QUADUP(relativeCodePtr);
CodeSize = QUADUP(CodeSize); /* Align */
CodeSize = MAX( CodeSize, (CodeChunkSize + 2048) );
SD.sd_CodeSize = CodeSize;
convertDictionaryInfoWrite (&SD);
if( WriteChunkToFile( fid, ID_P4DI, (char *) &SD, sizeof(DictionaryInfoChunk) ) < 0 ) goto error;
/* Write Name Fields if NameSize non-zero ------- */
if( NameSize > 0 )
{
if( WriteChunkToFile( fid, ID_P4NM, (char *) NAME_BASE,
NameChunkSize ) < 0 ) goto error;
}
/* Write Code Fields ---------------------------- */
if( WriteChunkToFile( fid, ID_P4CD, (char *) CODE_BASE,
CodeChunkSize ) < 0 ) goto error;
FormSize = sdTellFile( fid ) - 8;
sdSeekFile( fid, 4, PF_SEEK_SET );
if( Write32ToFile( fid, FormSize ) < 0 ) goto error;
sdCloseFile( fid );
/* Restore initialization. */
pfExecIfDefined("AUTO.INIT");
return 0;
error:
sdSeekFile( fid, 0, PF_SEEK_SET );
Write32ToFile( fid, ID_BADF ); /* Mark file as bad. */
sdCloseFile( fid );
/* Restore initialization. */
pfExecIfDefined("AUTO.INIT");
return -1;
}
#endif /* !PF_NO_FILEIO and !PF_NO_SHELL */
#ifndef PF_NO_FILEIO
/***************************************************************/
static uint32_t Read32FromFile( FileStream *fid, uint32_t *ValPtr )
{
int32_t numr;
uint8_t pad[4];
numr = sdReadFile( pad, 1, sizeof(pad), fid );
if( numr != sizeof(pad) ) return -1;
*ValPtr = Read32BigEndian( pad );
return 0;
}
/***************************************************************/
PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr )
{
pfDictionary_t *dic = NULL;
FileStream *fid;
DictionaryInfoChunk *sd;
uint32_t ChunkID;
uint32_t ChunkSize;
uint32_t FormSize;
uint32_t BytesLeft;
uint32_t numr;
int isDicBigEndian;
DBUG(("pfLoadDictionary( %s )\n", FileName ));
/* Open file. */
fid = sdOpenFile( FileName, "rb" );
if( fid == NULL )
{
pfReportError("pfLoadDictionary", PF_ERR_OPEN_FILE);
goto xt_error;
}
/* Read FORM, Size, ID */
if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;
if( ChunkID != ID_FORM )
{
pfReportError("pfLoadDictionary", PF_ERR_WRONG_FILE);
goto error;
}
if (Read32FromFile( fid, &FormSize ) < 0) goto read_error;
BytesLeft = FormSize;
if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;
BytesLeft -= 4;
if( ChunkID != ID_P4TH )
{
pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE);
goto error;
}
/* Scan and parse all chunks in file. */
while( BytesLeft > 0 )
{
if (Read32FromFile( fid, &ChunkID ) < 0) goto read_error;
if (Read32FromFile( fid, &ChunkSize ) < 0) goto read_error;
BytesLeft -= 8;
DBUG(("ChunkID = %4s, Size = %d\n", (char *)&ChunkID, ChunkSize ));
switch( ChunkID )
{
case ID_P4DI:
sd = (DictionaryInfoChunk *) pfAllocMem( ChunkSize );
if( sd == NULL ) goto nomem_error;
numr = sdReadFile( sd, 1, ChunkSize, fid );
if( numr != ChunkSize ) goto read_error;
BytesLeft -= ChunkSize;
convertDictionaryInfoRead (sd);
isDicBigEndian = sd->sd_Flags & SD_F_BIG_ENDIAN_DIC;
if( !gVarQuiet )
{
MSG("pForth loading dictionary from file "); MSG(FileName);
EMIT_CR;
MSG_NUM_D(" File format version is ", sd->sd_Version );
MSG_NUM_D(" Name space size = ", sd->sd_NameSize );
MSG_NUM_D(" Code space size = ", sd->sd_CodeSize );
MSG_NUM_D(" Entry Point = ", sd->sd_EntryPoint );
MSG_NUM_D(" Cell Size = ", sd->sd_CellSize );
MSG( (isDicBigEndian ? " Big Endian Dictionary" :
" Little Endian Dictionary") );
if( isDicBigEndian == IsHostLittleEndian() ) MSG(" !!!!");
EMIT_CR;
}
if( sd->sd_Version > PF_FILE_VERSION )
{
pfReportError("pfLoadDictionary", PF_ERR_VERSION_FUTURE );
goto error;
}
if( sd->sd_Version < PF_EARLIEST_FILE_VERSION )
{
pfReportError("pfLoadDictionary", PF_ERR_VERSION_PAST );
goto error;
}
if( sd->sd_CellSize != sizeof(cell_t) )
{
pfReportError("pfLoadDictionary", PF_ERR_CELL_SIZE_CONFLICT );
goto error;
}
if( sd->sd_NumPrimitives > NUM_PRIMITIVES )
{
pfReportError("pfLoadDictionary", PF_ERR_NOT_SUPPORTED );
goto error;
}
/* Check to make sure that EndianNess of dictionary matches mode of pForth. */
#if defined(PF_BIG_ENDIAN_DIC)
if(isDicBigEndian == 0)
#elif defined(PF_LITTLE_ENDIAN_DIC)
if(isDicBigEndian == 1)
#else
if( isDicBigEndian == IsHostLittleEndian() )
#endif
{
pfReportError("pfLoadDictionary", PF_ERR_ENDIAN_CONFLICT );
goto error;
}
/* Check for compatible float size. */
#ifdef PF_SUPPORT_FP
if( sd->sd_FloatSize != sizeof(PF_FLOAT) )
#else
if( sd->sd_FloatSize != 0 )
#endif
{
pfReportError("pfLoadDictionary", PF_ERR_FLOAT_CONFLICT );
goto error;
}
dic = pfCreateDictionary( sd->sd_NameSize, sd->sd_CodeSize );
if( dic == NULL ) goto nomem_error;
gCurrentDictionary = dic;
if( sd->sd_NameSize > 0 )
{
gVarContext = NAMEREL_TO_ABS(sd->sd_RelContext); /* Restore context. */
gCurrentDictionary->dic_HeaderPtr = (ucell_t)(uint8_t *)
NAMEREL_TO_ABS(sd->sd_RelHeaderPtr);
}
else
{
gVarContext = 0;
gCurrentDictionary->dic_HeaderPtr = (ucell_t)NULL;
}
gCurrentDictionary->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(sd->sd_RelCodePtr);
gNumPrimitives = sd->sd_NumPrimitives; /* Must match compiled dictionary. */
/* Pass EntryPoint back to caller. */
if( EntryPointPtr != NULL ) *EntryPointPtr = sd->sd_EntryPoint;
pfFreeMem(sd);
break;
case ID_P4NM:
#ifdef PF_NO_SHELL
pfReportError("pfLoadDictionary", PF_ERR_NO_SHELL );
goto error;
#else
if( NAME_BASE == 0 )
{
pfReportError("pfLoadDictionary", PF_ERR_NO_NAMES );
goto error;
}
if( gCurrentDictionary == NULL )
{
pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );
goto error;
}
if( ChunkSize > NAME_SIZE )
{
pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG);
goto error;
}
numr = sdReadFile( (char *) NAME_BASE, 1, ChunkSize, fid );
if( numr != ChunkSize ) goto read_error;
BytesLeft -= ChunkSize;
#endif /* PF_NO_SHELL */
break;
case ID_P4CD:
if( gCurrentDictionary == NULL )
{
pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );
goto error;
}
if( ChunkSize > CODE_SIZE )
{
pfReportError("pfLoadDictionary", PF_ERR_TOO_BIG);
goto error;
}
numr = sdReadFile( (uint8_t *) CODE_BASE, 1, ChunkSize, fid );
if( numr != ChunkSize ) goto read_error;
BytesLeft -= ChunkSize;
break;
default:
pfReportError("pfLoadDictionary", PF_ERR_BAD_FILE );
sdSeekFile( fid, ChunkSize, PF_SEEK_CUR );
break;
}
}
sdCloseFile( fid );
if( NAME_BASE != 0)
{
cell_t Result;
/* Find special words in dictionary for global XTs. */
if( (Result = FindSpecialXTs()) < 0 )
{
pfReportError("pfLoadDictionary: FindSpecialXTs", Result);
goto error;
}
}
DBUG(("pfLoadDictionary: return %p\n", dic));
return (PForthDictionary) dic;
nomem_error:
pfReportError("pfLoadDictionary", PF_ERR_NO_MEM);
sdCloseFile( fid );
return NULL;
read_error:
pfReportError("pfLoadDictionary", PF_ERR_READ_FILE);
error:
sdCloseFile( fid );
xt_error:
return NULL;
}
#else
PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr )
{
(void) FileName;
(void) EntryPointPtr;
return NULL;
}
#endif /* !PF_NO_FILEIO */
/***************************************************************/
PForthDictionary pfLoadStaticDictionary( void )
{
#ifdef PF_STATIC_DIC
cell_t Result;
pfDictionary_t *dic;
cell_t NewNameSize, NewCodeSize;
if( IF_LITTLE_ENDIAN != IsHostLittleEndian() )
{
MSG( (IF_LITTLE_ENDIAN ?
"Little Endian Dictionary on " :
"Big Endian Dictionary on ") );
MSG( (IsHostLittleEndian() ?
"Little Endian CPU" :
"Big Endian CPU") );
EMIT_CR;
}
/* Check to make sure that EndianNess of dictionary matches mode of pForth. */
#if defined(PF_BIG_ENDIAN_DIC)
if(IF_LITTLE_ENDIAN == 1)
#elif defined(PF_LITTLE_ENDIAN_DIC)
if(IF_LITTLE_ENDIAN == 0)
#else /* Code is native endian! */
if( IF_LITTLE_ENDIAN != IsHostLittleEndian() )
#endif
{
pfReportError("pfLoadStaticDictionary", PF_ERR_ENDIAN_CONFLICT );
goto error;
}
#ifndef PF_EXTRA_HEADERS
#define PF_EXTRA_HEADERS (20000)
#endif
#ifndef PF_EXTRA_CODE
#define PF_EXTRA_CODE (40000)
#endif
/* Copy static const data to allocated dictionaries. */
NewNameSize = sizeof(MinDicNames) + PF_EXTRA_HEADERS;
NewCodeSize = sizeof(MinDicCode) + PF_EXTRA_CODE;
DBUG_NUM_D( "static dic name size = ", NewNameSize );
DBUG_NUM_D( "static dic code size = ", NewCodeSize );
gCurrentDictionary = dic = pfCreateDictionary( NewNameSize, NewCodeSize );
if( !dic ) goto nomem_error;
pfCopyMemory( (uint8_t *) dic->dic_HeaderBase, MinDicNames, sizeof(MinDicNames) );
pfCopyMemory( (uint8_t *) dic->dic_CodeBase, MinDicCode, sizeof(MinDicCode) );
DBUG(("Static data copied to newly allocated dictionaries.\n"));
dic->dic_CodePtr.Byte = (uint8_t *) CODEREL_TO_ABS(CODEPTR);
gNumPrimitives = NUM_PRIMITIVES;
if( NAME_BASE != 0)
{
/* Setup name space. */
dic->dic_HeaderPtr = (ucell_t)(uint8_t *) NAMEREL_TO_ABS(HEADERPTR);
gVarContext = NAMEREL_TO_ABS(RELCONTEXT); /* Restore context. */
/* Find special words in dictionary for global XTs. */
if( (Result = FindSpecialXTs()) < 0 )
{
pfReportError("pfLoadStaticDictionary: FindSpecialXTs", Result);
goto error;
}
}
return (PForthDictionary) dic;
error:
return NULL;
nomem_error:
pfReportError("pfLoadStaticDictionary", PF_ERR_NO_MEM);
#endif /* PF_STATIC_DIC */
return NULL;
}
src/cmd/pforth/pf_save.h
+100
View File
@@ -0,0 +1,100 @@
/* @(#) pf_save.h 96/12/18 1.8 */
#ifndef _pforth_save_h
#define _pforth_save_h
/***************************************************************
** Include file for PForth SaveForth
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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 fields must be the same size for easy endian conversion.
* All fields must be 32 bit for file compatibility with older versions.
*/
int32_t sd_Version;
int32_t sd_RelContext; /* relative ptr to Dictionary Context */
int32_t sd_RelHeaderPtr; /* relative ptr to Dictionary Header Ptr */
int32_t sd_RelCodePtr; /* relative ptr to Dictionary Header Ptr */
int32_t sd_EntryPoint; /* relative ptr to entry point or NULL */
int32_t sd_UserStackSize; /* in bytes */
int32_t sd_ReturnStackSize; /* in bytes */
int32_t sd_NameSize; /* in bytes */
int32_t sd_CodeSize; /* in bytes */
int32_t sd_NumPrimitives; /* To distinguish between primitive and secondary. */
uint32_t sd_Flags;
int32_t sd_FloatSize; /* In bytes. Must match code. 0 means no floats. */
int32_t sd_CellSize; /* In bytes. Must match code. */
} DictionaryInfoChunk;
/* Bits in sd_Flags */
#define SD_F_BIG_ENDIAN_DIC (1<<0)
#ifndef MAKE_ID
#define MAKE_ID(a,b,c,d) ((((uint32_t)a)<<24)|(((uint32_t)b)<<16)|(((uint32_t)c)<<8)|((uint32_t)d))
#endif
#define ID_FORM MAKE_ID('F','O','R','M')
#define ID_P4TH MAKE_ID('P','4','T','H')
#define ID_P4DI MAKE_ID('P','4','D','I')
#define ID_P4NM MAKE_ID('P','4','N','M')
#define ID_P4CD MAKE_ID('P','4','C','D')
#define ID_BADF MAKE_ID('B','A','D','F')
#ifndef EVENUP
#define EVENUP(n) ((n+1)&(~1))
#endif
#ifdef __cplusplus
extern "C" {
#endif
cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize, cell_t CodeSize );
/* Endian-ness tools. */
int IsHostLittleEndian( void );
ucell_t ReadCellBigEndian( const uint8_t *addr );
uint32_t Read32BigEndian( const uint8_t *addr );
uint16_t Read16BigEndian( const uint8_t *addr );
ucell_t ReadCellLittleEndian( const uint8_t *addr );
uint32_t Read32LittleEndian( const uint8_t *addr );
uint16_t Read16LittleEndian( const uint8_t *addr );
void WriteCellBigEndian( uint8_t *addr, ucell_t data );
void Write32BigEndian( uint8_t *addr, uint32_t data );
void Write16BigEndian( uint8_t *addr, uint16_t data );
void WriteCellLittleEndian( uint8_t *addr, ucell_t data );
void Write32LittleEndian( uint8_t *addr, uint32_t data );
void Write16LittleEndian( uint8_t *addr, uint16_t data );
#ifdef PF_SUPPORT_FP
void WriteFloatBigEndian( PF_FLOAT *addr, PF_FLOAT data );
PF_FLOAT ReadFloatBigEndian( const PF_FLOAT *addr );
void WriteFloatLittleEndian( PF_FLOAT *addr, PF_FLOAT data );
PF_FLOAT ReadFloatLittleEndian( const PF_FLOAT *addr );
#endif
#ifdef __cplusplus
}
#endif
#endif /* _pforth_save_h */
src/cmd/pforth/pf_text.c
+407
View File
@@ -0,0 +1,407 @@
/* @(#) pf_text.c 98/01/26 1.3 */
/***************************************************************
** Text Strings for Error Messages
** Various Text tools.
**
** For PForth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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_TOO_BIG & 0xFF:
s = "data chunk too large"; break;
case PF_ERR_NUM_PARAMS & 0xFF:
s = "incorrect number of parameters"; break;
case PF_ERR_OPEN_FILE & 0xFF:
s = "could not open file"; break;
case PF_ERR_WRONG_FILE & 0xFF:
s = "wrong type of file format"; break;
case PF_ERR_BAD_FILE & 0xFF:
s = "badly formatted file"; break;
case PF_ERR_READ_FILE & 0xFF:
s = "file read failed"; break;
case PF_ERR_WRITE_FILE & 0xFF:
s = "file write failed"; break;
case PF_ERR_CORRUPT_DIC & 0xFF:
s = "corrupted dictionary"; break;
case PF_ERR_NOT_SUPPORTED & 0xFF:
s = "not supported in this version"; break;
case PF_ERR_VERSION_FUTURE & 0xFF:
s = "version from future"; break;
case PF_ERR_VERSION_PAST & 0xFF:
s = "version is obsolete. Rebuild new one."; break;
case PF_ERR_COLON_STACK & 0xFF:
s = "stack depth changed between : and ; . Probably unbalanced conditional"; break;
case PF_ERR_HEADER_ROOM & 0xFF:
s = "no room left in header space"; break;
case PF_ERR_CODE_ROOM & 0xFF:
s = "no room left in code space"; break;
case PF_ERR_NO_SHELL & 0xFF:
s = "attempt to use names in forth compiled with PF_NO_SHELL"; break;
case PF_ERR_NO_NAMES & 0xFF:
s = "dictionary has no names"; break;
case PF_ERR_OUT_OF_RANGE & 0xFF:
s = "parameter out of range"; break;
case PF_ERR_ENDIAN_CONFLICT & 0xFF:
s = "endian-ness of dictionary does not match code"; break;
case PF_ERR_FLOAT_CONFLICT & 0xFF:
s = "float support mismatch between .dic file and code"; break;
case PF_ERR_CELL_SIZE_CONFLICT & 0xFF:
s = "cell size mismatch between .dic file and code"; break;
default:
s = "unrecognized error code!"; break;
}
MSG(s);
EMIT_CR;
}
void pfReportThrow( ThrowCode code )
{
const char *s = NULL;
switch(code)
{
case THROW_ABORT:
case THROW_ABORT_QUOTE:
s = "ABORT"; break;
case THROW_STACK_OVERFLOW:
s = "Stack overflow!"; break;
case THROW_STACK_UNDERFLOW:
s = "Stack underflow!"; break;
case THROW_EXECUTING:
s = "Executing a compile-only word!"; break;
case THROW_FLOAT_STACK_UNDERFLOW:
s = "Float Stack underflow!"; break;
case THROW_UNDEFINED_WORD:
s = "Undefined word!"; break;
case THROW_PAIRS:
s = "Conditional control structure mismatch!"; break;
case THROW_BYE:
case THROW_QUIT:
break;
case THROW_SEMICOLON:
s = "Stack depth changed between : and ; . Probably unbalanced conditional!"; break;
case THROW_DEFERRED:
s = "Not a DEFERred word!"; break;
default:
s = "Unrecognized throw code!"; break;
}
if( s )
{
MSG_NUM_D("THROW code = ", code );
MSG(s);
EMIT_CR;
}
}
#endif
/**************************************************************
** Copy a Forth String to a 'C' string.
*/
char *ForthStringToC( char *dst, const char *FString, cell_t dstSize )
{
cell_t Len;
Len = (cell_t) *FString;
/* Make sure the text + NUL can fit. */
if( Len >= dstSize )
{
Len = dstSize - 1;
}
pfCopyMemory( dst, FString+1, Len );
dst[Len] = '\0';
return dst;
}
/**************************************************************
** Copy a NUL terminated string to a Forth counted string.
*/
char *CStringToForth( char *dst, const char *CString, cell_t dstSize )
{
cell_t i;
/* Make sure the SIZE+text can fit. */
for( i=1; i<dstSize; i++ )
{
if( *CString == 0 )
{
break;
}
dst[i] = *CString++;
}
*dst = (char ) i-1;
return dst;
}
/**************************************************************
** Compare two test strings, case sensitive.
** Return TRUE if they match.
*/
cell_t ffCompareText( const char *s1, const char *s2, cell_t len )
{
cell_t i, Result;
Result = TRUE;
for( i=0; i<len; i++ )
{
DBUGX(("ffCompareText: *s1 = 0x%x, *s2 = 0x%x\n", *s1, *s2 ));
if( *s1++ != *s2++ )
{
Result = FALSE;
break;
}
}
DBUGX(("ffCompareText: return 0x%x\n", Result ));
return Result;
}
/**************************************************************
** Compare two test strings, case INsensitive.
** Return TRUE if they match.
*/
cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len )
{
cell_t i, Result;
char c1,c2;
Result = TRUE;
for( i=0; i<len; i++ )
{
c1 = pfCharToLower(*s1++);
c2 = pfCharToLower(*s2++);
DBUGX(("ffCompareText: c1 = 0x%x, c2 = 0x%x\n", c1, c2 ));
if( c1 != c2 )
{
Result = FALSE;
break;
}
}
DBUGX(("ffCompareText: return 0x%x\n", Result ));
return Result;
}
/**************************************************************
** Compare two strings, case sensitive.
** Return zero if they match, -1 if s1<s2, +1 is s1>s2;
*/
cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 )
{
cell_t i, result, n, diff;
result = 0;
n = MIN(len1,len2);
for( i=0; i<n; i++ )
{
if( (diff = (*s2++ - *s1++)) != 0 )
{
result = (diff > 0) ? -1 : 1 ;
break;
}
}
if( result == 0 ) /* Match up to MIN(len1,len2) */
{
if( len1 < len2 )
{
result = -1;
}
else if ( len1 > len2 )
{
result = 1;
}
}
return result;
}
/***************************************************************
** Convert number to text.
*/
#define CNTT_PAD_SIZE ((sizeof(cell_t)*8)+2) /* PLB 19980522 - Expand PAD so "-1 binary .s" doesn't crash. */
static char cnttPad[CNTT_PAD_SIZE];
char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars )
{
cell_t IfNegative = 0;
char *p,c;
ucell_t NewNum, Rem, uNum;
cell_t i = 0;
uNum = Num;
if( IfSigned )
{
/* Convert to positive and keep sign. */
if( Num < 0 )
{
IfNegative = TRUE;
uNum = -Num;
}
}
/* Point past end of Pad */
p = cnttPad + CNTT_PAD_SIZE;
*(--p) = (char) 0; /* NUL terminate */
while( (i++<MinChars) || (uNum != 0) )
{
NewNum = uNum / Base;
Rem = uNum - (NewNum * Base);
c = (char) (( Rem < 10 ) ? (Rem + '0') : (Rem - 10 + 'A'));
*(--p) = c;
uNum = NewNum;
}
if( IfSigned )
{
if( IfNegative ) *(--p) = '-';
}
return p;
}
/***************************************************************
** Diagnostic routine that prints memory in table format.
*/
void DumpMemory( void *addr, cell_t cnt)
{
cell_t ln, cn, nlines;
unsigned char *ptr, *cptr, c;
nlines = (cnt + 15) / 16;
ptr = (unsigned char *) addr;
EMIT_CR;
for (ln=0; ln<nlines; ln++)
{
MSG( ConvertNumberToText( (cell_t) ptr, 16, FALSE, 8 ) );
MSG(": ");
cptr = ptr;
for (cn=0; cn<16; cn++)
{
MSG( ConvertNumberToText( (cell_t) *cptr++, 16, FALSE, 2 ) );
EMIT(' ');
}
EMIT(' ');
for (cn=0; cn<16; cn++)
{
c = *ptr++;
if ((c < ' ') || (c > '}')) c = '.';
EMIT(c);
}
EMIT_CR;
}
}
/* Print name, mask off any dictionary bits. */
void TypeName( const char *Name )
{
const char *FirstChar;
cell_t Len;
FirstChar = Name+1;
Len = *Name & 0x1F;
ioType( FirstChar, Len );
}
#ifdef PF_UNIT_TEST
/* Unit test for string conversion routines. */
#define ASSERT_PAD_IS( index, value, msg ) \
if( pad[index] != ((char)(value)) ) \
{ \
ERR(( "ERROR text test failed: " msg "\n")); \
numErrors += 1; \
} \
cell_t pfUnitTestText( void )
{
cell_t numErrors = 0;
char pad[16];
char fpad[8];
/* test CStringToForth */
pfSetMemory(pad,0xA5,sizeof(pad));
CStringToForth( pad, "frog", 6 );
ASSERT_PAD_IS( 0, 4, "CS len 6" );
ASSERT_PAD_IS( 4, 'g', "CS end 6" );
ASSERT_PAD_IS( 5, 0xA5, "CS past 6" );
pfSetMemory(pad,0xA5,sizeof(pad));
CStringToForth( pad, "frog", 5 );
ASSERT_PAD_IS( 0, 4, "CS len 5" );
ASSERT_PAD_IS( 4, 'g', "CS end 5" );
ASSERT_PAD_IS( 5, 0xA5, "CS past 5" );
pfSetMemory(pad,0xA5,sizeof(pad));
CStringToForth( pad, "frog", 4 );
ASSERT_PAD_IS( 0, 3, "CS len 4" );
ASSERT_PAD_IS( 3, 'o', "CS end 4" );
ASSERT_PAD_IS( 4, 0xA5, "CS past 4" );
/* Make a Forth string for testing ForthStringToC. */
CStringToForth( fpad, "frog", sizeof(fpad) );
pfSetMemory(pad,0xA5,sizeof(pad));
ForthStringToC( pad, fpad, 6 );
ASSERT_PAD_IS( 0, 'f', "FS len 6" );
ASSERT_PAD_IS( 3, 'g', "FS end 6" );
ASSERT_PAD_IS( 4, 0, "FS nul 6" );
ASSERT_PAD_IS( 5, 0xA5, "FS past 6" );
pfSetMemory(pad,0xA5,sizeof(pad));
ForthStringToC( pad, fpad, 5 );
ASSERT_PAD_IS( 0, 'f', "FS len 5" );
ASSERT_PAD_IS( 3, 'g', "FS end 5" );
ASSERT_PAD_IS( 4, 0, "FS nul 5" );
ASSERT_PAD_IS( 5, 0xA5, "FS past 5" );
pfSetMemory(pad,0xA5,sizeof(pad));
ForthStringToC( pad, fpad, 4 );
ASSERT_PAD_IS( 0, 'f', "FS len 4" );
ASSERT_PAD_IS( 2, 'o', "FS end 4" );
ASSERT_PAD_IS( 3, 0, "FS nul 4" );
ASSERT_PAD_IS( 4, 0xA5, "FS past 4" );
return numErrors;
}
#endif
src/cmd/pforth/pf_text.h
+71
View File
@@ -0,0 +1,71 @@
/* @(#) pf_text.h 96/12/18 1.10 */
#ifndef _pforth_text_h
#define _pforth_text_h
/***************************************************************
** Include file for PForth Text
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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_TOO_BIG (PF_ERR_BASE | 2)
#define PF_ERR_NUM_PARAMS (PF_ERR_BASE | 3)
#define PF_ERR_OPEN_FILE (PF_ERR_BASE | 4)
#define PF_ERR_WRONG_FILE (PF_ERR_BASE | 5)
#define PF_ERR_BAD_FILE (PF_ERR_BASE | 6)
#define PF_ERR_READ_FILE (PF_ERR_BASE | 7)
#define PF_ERR_WRITE_FILE (PF_ERR_BASE | 8)
#define PF_ERR_CORRUPT_DIC (PF_ERR_BASE | 9)
#define PF_ERR_NOT_SUPPORTED (PF_ERR_BASE | 10)
#define PF_ERR_VERSION_FUTURE (PF_ERR_BASE | 11)
#define PF_ERR_VERSION_PAST (PF_ERR_BASE | 12)
#define PF_ERR_COLON_STACK (PF_ERR_BASE | 13)
#define PF_ERR_HEADER_ROOM (PF_ERR_BASE | 14)
#define PF_ERR_CODE_ROOM (PF_ERR_BASE | 15)
#define PF_ERR_NO_SHELL (PF_ERR_BASE | 16)
#define PF_ERR_NO_NAMES (PF_ERR_BASE | 17)
#define PF_ERR_OUT_OF_RANGE (PF_ERR_BASE | 18)
#define PF_ERR_ENDIAN_CONFLICT (PF_ERR_BASE | 19)
#define PF_ERR_FLOAT_CONFLICT (PF_ERR_BASE | 20)
#define PF_ERR_CELL_SIZE_CONFLICT (PF_ERR_BASE | 21)
/* If you add an error code here, also add a text message in "pf_text.c". */
#ifdef __cplusplus
extern "C" {
#endif
void pfReportError( const char *FunctionName, Err ErrCode );
void pfReportThrow( ThrowCode code );
char *ForthStringToC( char *dst, const char *FString, cell_t dstSize );
char *CStringToForth( char *dst, const char *CString, cell_t dstSize );
cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 );
cell_t ffCompareText( const char *s1, const char *s2, cell_t len );
cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len );
void DumpMemory( void *addr, cell_t cnt);
char *ConvertNumberToText( cell_t Num, cell_t Base, int32_t IfSigned, int32_t MinChars );
void TypeName( const char *Name );
cell_t pfUnitTestText( void );
#ifdef __cplusplus
}
#endif
#endif /* _pforth_text_h */
src/cmd/pforth/pf_types.h
+35
View File
@@ -0,0 +1,35 @@
/* @(#) pf_types.h 96/12/18 1.3 */
#ifndef _pf_types_h
#define _pf_types_h
/***************************************************************
** Type declarations for PForth, a Forth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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 Err
typedef long Err;
#endif
typedef cell_t *dicptr;
typedef char ForthString;
typedef char *ForthStringPtr;
#endif /* _pf_types_h */
src/cmd/pforth/pf_win32.h
+41
View File
@@ -0,0 +1,41 @@
/* @(#) pf_win32.h 98/01/26 1.2 */
#ifndef _pf_win32_h
#define _pf_win32_h
#include <conio.h>
/***************************************************************
** WIN32 dependant include file for PForth, a Forth based on 'C'
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** The pForth software code is dedicated to the public domain,
** and any third party may reproduce, distribute and modify
** the 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+")
#endif /* _pf_win32_h */
src/cmd/pforth/pf_words.c
+223
View File
@@ -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, David 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( cell_t n )
{
MSG( ConvertNumberToText( n, gVarBase, TRUE, 1 ) );
EMIT(' ');
}
/***************************************************************
** Print number in current base to output stream.
** This version does not handle double precision.
*/
void ffDotHex( cell_t n )
{
MSG( ConvertNumberToText( n, 16, FALSE, 1 ) );
EMIT(' ');
}
/* ( ... --- ... , print stack ) */
void ffDotS( void )
{
cell_t *sp;
cell_t i, Depth;
MSG("Stack<");
MSG( ConvertNumberToText( gVarBase, 10, TRUE, 1 ) ); /* Print base in decimal. */
MSG("> ");
Depth = gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr;
sp = gCurrentTask->td_StackBase;
if( Depth < 0 )
{
MSG("UNDERFLOW!");
}
else
{
for( i=0; i<Depth; i++ )
{
/* Print as unsigned if not base 10. */
MSG( ConvertNumberToText( *(--sp), gVarBase, (gVarBase == 10), 1 ) );
EMIT(' ');
}
}
MSG("\n");
}
/* ( addr cnt char -- addr' cnt' , skip leading characters ) */
cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
{
char *s;
s = AddrIn;
if( c == BLANK )
{
while( ( Cnt > 0 ) &&
(( *s == BLANK) || ( *s == '\t')) )
{
DBUGX(("ffSkip BLANK: %c, %d\n", *s, Cnt ));
s++;
Cnt--;
}
}
else
{
while(( Cnt > 0 ) && ( *s == c ))
{
DBUGX(("ffSkip: %c=0x%x, %d\n", *s, Cnt ));
s++;
Cnt--;
}
}
*AddrOut = s;
return Cnt;
}
/* ( addr cnt char -- addr' cnt' , scan for char ) */
cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut )
{
char *s;
s = AddrIn;
if( c == BLANK )
{
while(( Cnt > 0 ) &&
( *s != BLANK) &&
( *s != '\r') &&
( *s != '\n') &&
( *s != '\t'))
{
DBUGX(("ffScan BLANK: %c, %d\n", *s, Cnt ));
s++;
Cnt--;
}
}
else
{
while(( Cnt > 0 ) && ( *s != c ))
{
DBUGX(("ffScan: %c, %d\n", *s, Cnt ));
s++;
Cnt--;
}
}
*AddrOut = s;
return Cnt;
}
/***************************************************************
** Forth equivalent 'C' functions.
***************************************************************/
/* Convert a single digit to the corresponding hex number. */
static cell_t HexDigitToNumber( char c )
{
if( (c >= '0') && (c <= '9') )
{
return( c - '0' );
}
else if ( (c >= 'A') && (c <= 'F') )
{
return( c - 'A' + 0x0A );
}
else
{
return -1;
}
}
/* Convert a string to the corresponding number using BASE. */
cell_t ffNumberQ( const char *FWord, cell_t *Num )
{
cell_t Len, i, Accum=0, n, Sign=1;
const char *s;
/* get count */
Len = *FWord++;
s = FWord;
/* process initial minus sign */
if( *s == '-' )
{
Sign = -1;
s++;
Len--;
}
for( i=0; i<Len; i++)
{
n = HexDigitToNumber( *s++ );
if( (n < 0) || (n >= gVarBase) )
{
return NUM_TYPE_BAD;
}
Accum = (Accum * gVarBase) + n;
}
*Num = Accum * Sign;
return NUM_TYPE_SINGLE;
}
/***************************************************************
** Compiler Support
***************************************************************/
/* ( char -- c-addr , parse word ) */
char * ffWord( char c )
{
char *s1,*s2,*s3;
cell_t n1, n2, n3;
cell_t i, nc;
s1 = gCurrentTask->td_SourcePtr + gCurrentTask->td_IN;
n1 = gCurrentTask->td_SourceNum - gCurrentTask->td_IN;
n2 = ffSkip( s1, n1, c, &s2 );
DBUGX(("ffWord: s2=%c, %d\n", *s2, n2 ));
n3 = ffScan( s2, n2, c, &s3 );
DBUGX(("ffWord: s3=%c, %d\n", *s3, n3 ));
nc = n2-n3;
if (nc > 0)
{
gScratch[0] = (char) nc;
for( i=0; i<nc; i++ )
{
gScratch[i+1] = pfCharToUpper( s2[i] );
}
}
else
{
gScratch[0] = 0;
}
gCurrentTask->td_IN += (n1-n3) + 1;
return &gScratch[0];
}
src/cmd/pforth/pf_words.h
+36
View File
@@ -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, David 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( cell_t n );
void ffDotHex( cell_t n );
void ffDotS( void );
cell_t ffSkip( char *AddrIn, cell_t Cnt, char c, char **AddrOut );
cell_t ffScan( char *AddrIn, cell_t Cnt, char c, char **AddrOut );
#ifdef __cplusplus
}
#endif
#endif /* _pforth_words_h */
src/cmd/pforth/pfcompfp.h
+78
View File
@@ -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, David 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", FLAG_IMMEDIATE );
CreateDicEntryC( ID_FP_FLITERAL_P, "(FLITERAL)", 0 );
CreateDicEntryC( ID_FP_FLOAT_PLUS, "FLOAT+", 0 );
CreateDicEntryC( ID_FP_FLOATS, "FLOATS", 0 );
CreateDicEntryC( ID_FP_FLOOR, "FLOOR", 0 );
CreateDicEntryC( ID_FP_FMAX, "FMAX", 0 );
CreateDicEntryC( ID_FP_FMIN, "FMIN", 0 );
CreateDicEntryC( ID_FP_FNEGATE, "FNEGATE", 0 );
CreateDicEntryC( ID_FP_FOVER, "FOVER", 0 );
CreateDicEntryC( ID_FP_FROT, "FROT", 0 );
CreateDicEntryC( ID_FP_FROUND, "FROUND", 0 );
CreateDicEntryC( ID_FP_FSWAP, "FSWAP", 0 );
/* Extended words */
CreateDicEntryC( ID_FP_FSTAR_STAR, "F**", 0 );
CreateDicEntryC( ID_FP_FABS, "FABS", 0 );
CreateDicEntryC( ID_FP_FACOS, "FACOS", 0 );
CreateDicEntryC( ID_FP_FACOSH, "FACOSH", 0 );
CreateDicEntryC( ID_FP_FALOG, "FALOG", 0 );
CreateDicEntryC( ID_FP_FASIN, "FASIN", 0 );
CreateDicEntryC( ID_FP_FASINH, "FASINH", 0 );
CreateDicEntryC( ID_FP_FATAN, "FATAN", 0 );
CreateDicEntryC( ID_FP_FATAN2, "FATAN2", 0 );
CreateDicEntryC( ID_FP_FATANH, "FATANH", 0 );
CreateDicEntryC( ID_FP_FCOS, "FCOS", 0 );
CreateDicEntryC( ID_FP_FCOSH, "FCOSH", 0 );
CreateDicEntryC( ID_FP_FLN, "FLN", 0 );
CreateDicEntryC( ID_FP_FLNP1, "FLNP1", 0 );
CreateDicEntryC( ID_FP_FLOG, "FLOG", 0 );
CreateDicEntryC( ID_FP_FSIN, "FSIN", 0 );
CreateDicEntryC( ID_FP_FSINCOS, "FSINCOS", 0 );
CreateDicEntryC( ID_FP_FSINH, "FSINH", 0 );
CreateDicEntryC( ID_FP_FSQRT, "FSQRT", 0 );
CreateDicEntryC( ID_FP_FTAN, "FTAN", 0 );
CreateDicEntryC( ID_FP_FTANH, "FTANH", 0 );
CreateDicEntryC( ID_FP_FPICK, "FPICK", 0 );
#endif
src/cmd/pforth/pfcompil.c
+1187
View File
File diff suppressed because it is too large Load Diff
src/cmd/pforth/pfcompil.h
+73
View File
@@ -0,0 +1,73 @@
/* @(#) pfcompil.h 96/12/18 1.11 */
#ifndef _pforth_compile_h
#define _pforth_compile_h
/***************************************************************
** Include file for PForth Compiler
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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_t id );
FileStream *ffPopInputStream( void );
cell_t ffConvertStreamToSourceID( FileStream *Stream );
cell_t ffFind( const ForthString *WordName, ExecToken *pXT );
cell_t ffFindC( const char *WordName, ExecToken *pXT );
cell_t ffFindNFA( const ForthString *WordName, const ForthString **NFAPtr );
cell_t ffNumberQ( const char *FWord, cell_t *Num );
cell_t ffRefill( void );
cell_t ffTokenToName( ExecToken XT, const ForthString **NFAPtr );
cell_t *NameToCode( ForthString *NFA );
PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize );
char *ffWord( char c );
const ForthString *NameToPrevious( const ForthString *NFA );
cell_t FindSpecialCFAs( void );
cell_t FindSpecialXTs( void );
cell_t NotCompiled( const char *FunctionName );
void CreateDicEntry( ExecToken XT, const ForthStringPtr FName, ucell_t Flags );
void CreateDicEntryC( ExecToken XT, const char *CName, ucell_t Flags );
void ff2Literal( cell_t dHi, cell_t dLo );
void ffALiteral( cell_t Num );
void ffColon( void );
void ffCreate( void );
void ffCreateSecondaryHeader( const ForthStringPtr FName);
void ffDefer( void );
void ffFinishSecondary( void );
void ffLiteral( cell_t Num );
void ffStringCreate( ForthStringPtr FName);
void ffStringDefer( const ForthStringPtr FName, ExecToken DefaultXT );
void pfHandleIncludeError( void );
ThrowCode ffSemiColon( void );
ThrowCode ffOK( void );
ThrowCode ffInterpret( void );
ThrowCode ffOuterInterpreterLoop( void );
ThrowCode ffIncludeFile( FileStream *InputFile );
#ifdef PF_SUPPORT_FP
void ffFPLiteral( PF_FLOAT fnum );
#endif
#ifdef __cplusplus
}
#endif
#endif /* _pforth_compile_h */
src/cmd/pforth/pfcustom.c
+121
View File
@@ -0,0 +1,121 @@
/* @(#) pfcustom.c 98/01/26 1.3 */
#ifndef PF_USER_CUSTOM
/***************************************************************
** Call Custom Functions for pForth
**
** Create a file similar to this and compile it into pForth
** by setting -DPF_USER_CUSTOM="mycustom.c"
**
** Using this, you could, for example, call X11 from Forth.
** See "pf_cglue.c" for more information.
**
** Author: Phil Burk
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
**
** 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 cell_t CTest0( cell_t Val );
static void CTest1( cell_t Val1, cell_t Val2 );
/****************************************************************
** Step 1: Put your own special glue routines here
** or link them in from another file or library.
****************************************************************/
static cell_t CTest0( cell_t Val )
{
MSG_NUM_D("CTest0: Val = ", Val);
return Val+1;
}
static void CTest1( cell_t Val1, cell_t Val2 )
{
MSG("CTest1: Val1 = "); ffDot(Val1);
MSG_NUM_D(", Val2 = ", Val2);
}
/****************************************************************
** Step 2: Create CustomFunctionTable.
** Do not change the name of CustomFunctionTable!
** It is used by the pForth kernel.
****************************************************************/
#ifdef PF_NO_GLOBAL_INIT
/******************
** If your loader does not support global initialization, then you
** must define PF_NO_GLOBAL_INIT and provide a function to fill
** the table. Some embedded system loaders require this!
** Do not change the name of LoadCustomFunctionTable()!
** It is called by the pForth kernel.
*/
#define NUM_CUSTOM_FUNCTIONS (2)
CFunc0 CustomFunctionTable[NUM_CUSTOM_FUNCTIONS];
Err LoadCustomFunctionTable( void )
{
CustomFunctionTable[0] = CTest0;
CustomFunctionTable[1] = CTest1;
return 0;
}
#else
/******************
** If your loader supports global initialization (most do.) then just
** create the table like this.
*/
CFunc0 CustomFunctionTable[] =
{
(CFunc0) CTest0,
(CFunc0) CTest1
};
#endif
/****************************************************************
** Step 3: Add custom functions to the dictionary.
** Do not change the name of CompileCustomFunctions!
** It is called by the pForth kernel.
****************************************************************/
#if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
Err CompileCustomFunctions( void )
{
Err err;
int i = 0;
/* Compile Forth words that call your custom functions.
** Make sure order of functions matches that in LoadCustomFunctionTable().
** Parameters are: Name in UPPER CASE, Function, Index, Mode, NumParams
*/
err = CreateGlueToC( "CTEST0", i++, C_RETURNS_VALUE, 1 );
if( err < 0 ) return err;
err = CreateGlueToC( "CTEST1", i++, C_RETURNS_VOID, 2 );
if( err < 0 ) return err;
return 0;
}
#else
Err CompileCustomFunctions( void ) { return 0; }
#endif
/****************************************************************
** Step 4: Recompile using compiler option PF_USER_CUSTOM
** and link with your code.
** Then rebuild the Forth using "pforth -i system.fth"
** Test: 10 Ctest0 ( should print message then '11' )
****************************************************************/
#endif /* PF_USER_CUSTOM */
src/cmd/pforth/pfdicdat.h
+3364
View File
File diff suppressed because it is too large Load Diff
src/cmd/pforth/pfinnrfp.h
+336
View File
@@ -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, David 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) ((ucell_t)Scratch) ); /* Convert TOS and push on FP stack. */
FP_TOS = fpTemp + fpScratch;
}
M_DROP;
/* printf("d2f = %g\n", FP_TOS); */
break;
case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
if( IN_CODE_DIC(TOS) )
{
WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );
}
else
{
*((PF_FLOAT *) TOS) = FP_TOS;
}
#else
*((PF_FLOAT *) TOS) = FP_TOS;
#endif
M_FP_DROP; /* drop FP value */
M_DROP; /* drop addr */
break;
case ID_FP_FTIMES: /* ( F: r1 r2 -- r1*r2 ) */
FP_TOS = M_FP_POP * FP_TOS;
break;
case ID_FP_FPLUS: /* ( F: r1 r2 -- r1+r2 ) */
FP_TOS = M_FP_POP + FP_TOS;
break;
case ID_FP_FMINUS: /* ( F: r1 r2 -- r1-r2 ) */
FP_TOS = M_FP_POP - FP_TOS;
break;
case ID_FP_FSLASH: /* ( F: r1 r2 -- r1/r2 ) */
FP_TOS = M_FP_POP / FP_TOS;
break;
case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag ) ( F: r -- ) */
PUSH_TOS;
TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ;
M_FP_DROP;
break;
case ID_FP_F_ZERO_EQUALS: /* ( -- flag ) ( F: r -- ) */
PUSH_TOS;
TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ;
M_FP_DROP;
break;
case ID_FP_F_LESS_THAN: /* ( -- flag ) ( F: r1 r2 -- ) */
PUSH_TOS;
TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ;
M_FP_DROP;
break;
case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */
/* printf("f2d = %g\n", FP_TOS); */
{
ucell_t dlo;
cell_t dhi;
int ifNeg;
/* Convert absolute value, then negate D if negative. */
PUSH_TOS; /* Save old TOS */
fpTemp = FP_TOS;
M_FP_DROP;
ifNeg = (fpTemp < 0.0);
if( ifNeg )
{
fpTemp = 0.0 - fpTemp;
}
fpScratch = fpTemp / FP_DHI1;
/* printf("f2d - fpScratch = %g\n", fpScratch); */
dhi = (cell_t) fpScratch; /* dhi */
fpScratch = ((PF_FLOAT) dhi) * FP_DHI1;
/* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */
fpTemp = fpTemp - fpScratch; /* Remainder */
dlo = (ucell_t) fpTemp;
/* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */
if( ifNeg )
{
dlo = 0 - dlo;
dhi = 0 - dhi - 1;
}
/* Push onto stack. */
TOS = dlo;
PUSH_TOS;
TOS = dhi;
}
break;
case ID_FP_FFETCH: /* ( addr -- ) ( F: -- r ) */
PUSH_FP_TOS;
#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
if( IN_CODE_DIC(TOS) )
{
FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );
}
else
{
FP_TOS = *((PF_FLOAT *) TOS);
}
#else
FP_TOS = *((PF_FLOAT *) TOS);
#endif
M_DROP;
break;
case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */
PUSH_TOS;
/* Add 1 to account for FP_TOS in cached in register. */
TOS = (( M_FP_SPZERO - FP_STKPTR) + 1);
break;
case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */
M_FP_DROP;
break;
case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */
PUSH_FP_TOS;
break;
case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */
TOS = TOS + sizeof(PF_FLOAT);
break;
case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */
TOS = TOS * sizeof(PF_FLOAT);
break;
case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_floor( FP_TOS );
break;
case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */
fpScratch = M_FP_POP;
FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ;
break;
case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */
fpScratch = M_FP_POP;
FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ;
break;
case ID_FP_FNEGATE:
FP_TOS = -FP_TOS;
break;
case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */
PUSH_FP_TOS;
FP_TOS = M_FP_STACK(1);
break;
case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */
fpScratch = M_FP_POP; /* r2 */
fpTemp = M_FP_POP; /* r1 */
M_FP_PUSH( fpScratch ); /* r2 */
PUSH_FP_TOS; /* r3 */
FP_TOS = fpTemp; /* r1 */
break;
case ID_FP_FROUND:
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_t *) fptr;
}
#endif
endcase;
case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_log(FP_TOS);
break;
case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);
break;
case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );
break;
case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );
break;
case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */
M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS));
FP_TOS = (PF_FLOAT) fp_cos(FP_TOS);
break;
case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );
break;
case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );
break;
case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );
break;
case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */
FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );
break;
case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */
PUSH_FP_TOS; /* push cached floats into RAM */
FP_TOS = FP_STKPTR[TOS]; /* 0 FPICK gets top of FP stack */
M_DROP;
break;
#endif
src/cmd/pforth/pforth.dic
BIN
View File
Binary file not shown.
src/cmd/pforth/pforth.h
+101
View File
@@ -0,0 +1,101 @@
/* @(#) 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, David 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 void *PForthTask;
typedef void *PForthDictionary;
/* Integer types for Forth cells, signed and unsigned: */
typedef int cell_t;
typedef unsigned int ucell_t;
typedef char int8_t;
typedef unsigned char uint8_t;
typedef short int16_t;
typedef unsigned short uint16_t;
typedef int int32_t;
typedef unsigned int uint32_t;
typedef ucell_t ExecToken; /* Execution Token */
typedef cell_t ThrowCode;
#ifdef __cplusplus
extern "C" {
#endif
/* Main entry point to pForth. */
cell_t pfDoForth( const char *DicName, const char *SourceName, cell_t IfInit );
/* Turn off messages. */
void pfSetQuiet( cell_t IfQuiet );
/* Query message status. */
cell_t pfQueryQuiet( void );
/* Send a message using low level I/O of pForth */
void pfMessage( const char *CString );
/* Create a task used to maintain context of execution. */
PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth );
/* Establish this task as the current task. */
void pfSetCurrentTask( PForthTask task );
/* Delete task created by pfCreateTask */
void pfDeleteTask( PForthTask task );
/* Build a dictionary with all the basic kernel words. */
PForthDictionary pfBuildDictionary( cell_t HeaderSize, cell_t CodeSize );
/* Create an empty dictionary. */
PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize );
/* Load dictionary from a file. */
PForthDictionary pfLoadDictionary( const char *FileName, ExecToken *EntryPointPtr );
/* Load dictionary from static array in "pfdicdat.h". */
PForthDictionary pfLoadStaticDictionary( void );
/* Delete dictionary data. */
void pfDeleteDictionary( PForthDictionary dict );
/* Execute the pForth interpreter. Yes, QUIT is an odd name but it has historical meaning. */
ThrowCode pfQuit( void );
/* Execute a single execution token in the current task and return 0 or an error code. */
int pfCatch( ExecToken XT );
/* Include the given pForth source code file. */
ThrowCode pfIncludeFile( const char *FileName );
/* Execute a Forth word by name. */
ThrowCode pfExecIfDefined( const char *CString );
#ifdef __cplusplus
}
#endif
#endif /* _pforth_h */
src/cmd/pforth/readme.txt
+97
View File
@@ -0,0 +1,97 @@
README for pForth - a Portable ANS-like Forth written in ANSI 'C'
by Phil Burk
with Larry Polansky, David Rosenboom and Darren Gibbs.
Support for 64-bit cells by Aleksej Saushev.
Last updated: May 20, 2010 V26
Code for pForth is maintained on Google at:
http://code.google.com/p/pforth/
Documentation for pForth at:
http://www.softsynth.com/pforth/
For technical support please use the pForth forum at:
http://groups.google.com/group/pforthdev
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:
http://www.softsynth.com/contacts.php
-- 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.
-- Contents of SDK --------------------------------------
build - tools for building pForth on various platforms
build/win32/vs2005 - Visual Studio 2005 Project and Solution
build/unix - Makefile for unix
csrc - pForth kernel in ANSI 'C'
csrc/pf_main.c - main() application for a standalone Forth
csrc/stdio - I/O code using basic stdio for generic platforms
csrc/posix - I/O code for Posix platform
csrc/win32 - I/O code for basic WIN32 platform
csrc/win32_console - I/O code for WIN32 console that supports command line history
fth - Forth code
fth/util - utility functions
-- How to build pForth ------------------------------------
See pForth reference manual at:
http://www.softsynth.com/pforth/pf_ref.htm
-- How to run pForth ------------------------------------
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 Test 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.
src/cmd/pforth/releases.txt
+273
View File
@@ -0,0 +1,273 @@
Release History for pForth - a Portable ANS-like Forth written in ANSI 'C'
Documentation for pForth at http://www.softsynth.com/pforth/
V27
- Fixed REPOSITION-FILE FILE-SIZE and FILE-POSITION.
They used to use single precision offset. Now use double as specified.
- Delete object directories in Makefile clean.
- Fixed "Issue 4: Filehandle remains locked upon INCLUDE error".
http://code.google.com/p/pforth/issues/detail?id=4&can=1
- Fixed scrambled HISTORY on 64-bit systems. Was using CELL+ but really needed 4 +.
- Fixed floating point input. Now accepts "1E" as 1.0. Was Issue #2.
- Fixed lots of warning and made code compatible with C89 and ANSI. Uses -pedantic.
- Use fseek and ftell on WIN32 instead of fseeko and ftello.
- Makefile is now more standard. Builds in same dir as Makefile. Uses CFLAGS etc.
- Add support for console IO with _WATCOMC_
- Internal CStringToForth and ForthStringToC now take a destination size for safety.
- Run units tests for CStringToForth and ForthStringToC if PF_UNIT_TESTS is defined.
V26 5/20/2010
- 64-bit support for M* UM/MOD etc by Aleksej Saushev. Thanks Aleksej!
V25 5/19/2010
- Added 64-bit CELL support contributed by Aleksej Saushev. Thanks Aleksej!
- Added "-x c" to Makefile CCOPTS to prevent confusion with C++
- Allow space after -d command line option.
- Restore normal tty mode if pForth dictionary loading fails.
V24 2/20/09
- Fixed Posix IO on Mac. ?TERMINAL was always returning true.
- ACCCEPT now emits a space at end of line before output.
- Fixed RESIZE because it was returning the wrong address.
V23 8/4/2008
- Removed -v option from mkdir in build/unix/Makefile. It was not supported on FreeBSD.
Thank you Alexsej Saushev for reporting this.
V23 7/20/2008
- Reorganized for Google Code project.
V22 (unreleased)
- Added command line history and cursor control words.
- Sped up UM* and M* by a factor of 3. Thanks to Steve Green for suggested algorithm.
- Modified ACCEPT so that a line at the end of a file that does NOT have a line
terminator will now be processed.
- Use _getch(), _putch(), and _kbhit() so that KEY, EMIT and ?TERMINAL will work on PC.
- Fixed : foo { -- } 55 ; - Was entering local frame but not exiting. Now prints error.
- Redefined MAKE_ID to protect it from 16 bit ints
- John Providenza says "If you split local variables onto 2 lines, PForth crashes." Fixed. Also allow \
- Fixed float evaluation in EVALUATE in "quit.fth".
- Flush register cache for ffColon and ffSemiColon to prevent stack warnings from ;
V21 - 9/16/1998
- Fixed some compiler warnings.
V20
- Expand PAD for ConvertNumberToText so "-1 binary .s" doesn't crash.
Thank you Michael Connor of Vancouver for reporting this bug.
- Removed FDROP in REPRESENT to fix stack underflow after "0.0 F.".
Thank you Jim Rosenow of Minnesota for reporting this bug.
- Changed pfCharToLower to function to prevent macro expansion bugs under VXWORKS
Thank you Jim Rosenow of Minnesota for reporting this bug.
- "0.0 F~" now checks actual binary encoding of floats. Before this it used to just
compare value which was incorrect. Now "0.0 -0.0 0.0 F~" returns FALSE.
- Fixed definition of INPUT$ in tutorial.
Thank you Hampton Miller of California for reporting this bug.
- Added support for producing a target dictionary with a different
Endian-ness than the host CPU. See PF_BIG_ENDIAN_DIC and PF_LITTLE_ENDIAN_DIC.
- PForth kernel now comes up in a mode that uses BASE for numeric input when
started with "-i" option. It used to always consider numeric input as HEX.
Initial BASE is decimal.
V19 4/1998
- Warn if local var name matches dictionary, : foo { count -- } ;
- TO -> and +-> now parse input stream. No longer use to-flag.
- TO -> and +-> now give error if used with non-immediate word.
- Added (FLITERAL) support to SEE.
- Aded TRACE facility for single step debugging of Forth words.
- Added stub for ?TERMINAL and KEY? for embedded systems.
- Added PF_NO_GLOBAL_INIT for no reliance on global initialization.
- Added PF_USER_FLOAT for customization of FP support.
- Added floating point to string conversion words (F.) (FS.) (FE.)
For example: : F. (F.) TYPE SPACE ;
- Reversed order that values are placed on return stack in 2>R
so that it matches ANS standard. 2>R is now same as SWAP >R >R
Thank you Leo Wong for reporting this bug.
- Added PF_USER_INIT and PF_USER_TERM for user definable init and term calls.
- FIXED memory leak in pfDoForth()
V18
- Make FILL a 'C' primitive.
- optimized locals with (1_LOCAL@)
- optimized inner interpreter by 15%
- fix tester.fth failures
- Added define for PF_KEY_ECHOS which turns off echo in ACCEPT if defined.
- Fixed MARKER. Was equivalent to ANEW instead of proper ANS definition.
- Fixed saving and restoring of TIB when nesting include files.
V17
- Fixed input of large floats. 0.7071234567 F. used to fail.
V16
* Define PF_USER_CUSTOM if you are defining your own custom
'C' glue routines. This will ifndef the published example.
- Fixed warning in pf_cglue.c.
- Fixed SDAD in savedicd.fth. It used to generate bogus 'C' code
if called when (BASE != 10), as in HEX mode.
- Fixed address comparisons in forget.fth and private.fth for
addresses above 0x80000000. Must be unsigned.
- Call FREEZE at end of system.fth to initialize rfence.
- Fixed 0.0 F. which used to leave 0.0 on FP stack.
- Added FPICK ( n -- ) ( i*f -- i*f f[n] )
- .S now prints hex numbers as unsigned.
- Fixed internal number to text conversion for unsigned nums.
V15 - 2/15/97
* If you use PF_USER_FILEIO, you must now define PF_STDIN and PF_STDOUT
among other additions. See "pf_io.h".
* COMPARE now matches ANS STRING word set!
- Added PF_USER_INC1 and PF_USER_INC2 for optional includes
and host customization. See "pf_all.h".
- Fixed more warnings.
- Fixed >NAME and WORDS for systems with high "negative" addresses.
- Added WORDS.LIKE utility. Enter: WORDS.LIKE EMIT
- Added stack check after every word in high level interpreter.
Enter QUIT to enter high level interpreter which uses this feature.
- THROW will no longer crash if not using high level interpreter.
- Isolated all host dependencies into "pf_unix.h", "pf_win32.h",
"pf_mac.h", etc. See "pf_all.h".
- Added tests for CORE EXT, STRINGS words sets.
- Added SEARCH
- Fixed WHILE and REPEAT for multiple WHILEs.
- Fixed .( ) for empty strings.
- Fixed FATAN2 which could not compile on some systems (Linux gcc).
V14 - 12/23/96
* pforth command now requires -d before dictionary name.
Eg. pforth -dcustom.dic test.fth
* PF_USER_* now need to be defined as include file names.
* PF_USER_CHARIO now requires different functions to be defined.
See "csrc/pf_io.h".
- Moved pfDoForth() from pf_main.c to pf_core.c to simplify
file with main().
- Fix build with PF_NO_INIT
- Makefile now has target for embedded dictionary, "gmake pfemb".
V13 - 12/15/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".
V12 - 12/1/96
- Advance pointers in pfCopyMemory() and pfSetMemory()
to fix PF_NO_CLIB build.
- Increase size of array for PF_NO_MALLOC
- Eliminate many warnings involving type casts and (const char *)
- Fix error recovery in dictionary creation.
- Conditionally eliminate some include files for embedded builds.
- Cleanup some test files.
V11 - 11/14/96
- Added support for AUTO.INIT and AUTO.TERM. These are called
automagically when the Forth starts and quits.
- Change all int to int32.
- Changed DO LOOP to ?DO LOOP in ENDCASE and LV.MATCH
to fix hang when zero local variables.
- Align long word members in :STRUCT to avoid bus errors.
V10 - 3/21/96
- Close nested source files when INCLUDE aborts.
- Add PF_NO_CLIB option to reduce OS dependencies.
- Add CREATE-FILE, fix R/W access mode for OPEN-FILE.
- Use PF_FLOAT instead of FLOAT to avoid DOS problem.
- Add PF_HOST_DOS for compilation control.
- Shorten all long file names to fit in the 8.3 format
required by some primitive operating systems. My
apologies to those with modern computers who suffer
as a result. ;-)
V9 - 10/13/95
- Cleaned up and documented for alpha release.
- Added EXISTS?
- compile floats.fth if F* exists
- got PF_NO_SHELL working
- added TURNKEY to build headerless dictionary apps
- improved release script and rlsMakefile
- added FS@ and FS! for FLPT structure members
V8 - 5/1/95
- Report line number and line dump when INCLUDE aborts
- Abort if stack depth changes in colon definition. Helps
detect unbalanced conditionals (IF without THEN).
- Print bytes added by include. Helps determine current file.
- Added RETURN-CODE which is returned to caller, eg. UNIX shell.
- Changed Header and Code sizes to 60000 and 150000
- Added check for overflowing dictionary when creating secondaries.
V8 - 5/1/95
- Report line number and line dump when INCLUDE aborts
- Abort if stack depth changes in colon definition. Helps
detect unbalanced conditionals (IF without THEN).
- Print bytes added by include. Helps determine current file.
- Added RETURN-CODE which is returned to caller, eg. UNIX shell.
- Changed Header and Code sizes to 60000 and 150000
- Added check for overflowing dictionary when creating secondaries.
V7 - 4/12/95
- Converted to 3DO Teamware environment
- Added conditional compiler [IF] [ELSE] [THEN], use like #if
- Fixed W->S B->S for positive values
- Fixed ALLOCATE FREE validation. Was failing on some 'C' compilers.
- Added FILE-SIZE
- Fixed ERASE, now fills with zero instead of BL
V6 - 3/16/95
- Added floating point
- Changed NUMBER? to return a numeric type
- Support double number entry, eg. 234. -> 234 0
V5 - 3/9/95
- Added pfReportError()
- Fixed problem with NumPrimitives growing and breaking dictionaries
- Reduced size of saved dictionaries, 198K -> 28K in one instance
- Funnel all terminal I/O through ioKey() and ioEmit()
- Removed dependencies on printf() except for debugging
V4 - 3/6/95
- Added smart conditionals to allow IF THEN DO LOOP etc.
outside colon definitions.
- Fixed RSHIFT, made logical.
- Added ARSHIFT for arithmetic shift.
- Added proper M*
- Added <> U> U<
- Added FM/MOD SM/REM /MOD MOD */ */MOD
- Added +LOOP EVALUATE UNLOOP EXIT
- Everything passes "coretest.fth" except UM/MOD FIND and WORD
V3 - 3/1/95
- Added support for embedded systems: PF_NO_FILEIO
and PF_NO_MALLOC.
- Fixed bug in dictionary loader that treated HERE as name relative.
V2 - 8/94
- made improvements necessary for use with M2 Verilog testing
V1 - 5/94
- built pForth from various Forths including HMSL
----------------------------------------------------------
Enjoy,
Phil Burk