--- /dev/null
+# Bootstrapping Forth
+
+## preForth
+
+preForth is a minimal non-interactive Forth kernel that can bootstrap itself and can be used as an easy-to-port basis for a full Forth implementation.
+
+preForth feels like Forth - it's mainly a sublanguage of ANS-Forth - but is significantly reduced in its capabilities.
+
+### Features: minimal control structures, no immediate words, strings on stack, few primitives
+
+just
+
+- Stack
+- Returnstack
+- Only ?exit and recursion as control structures
+- :-definitions
+- optional tail call optimization
+- IO via KEY/EMIT
+- signed single cell decimal numbers (0-9)+
+- character constants via 'c'-notation
+- output single cell decimal numbers
+
+and
+
+- no immediate words, i.e.
+- no control structures IF ELSE THEN BEGIN WHILE REPEAT UNTIL
+- no defining words
+- no DOES>
+- no memory @ ! CMOVE ALLOT ,
+- no pictured numeric output
+- no input stream
+- no state
+- no base
+- no dictionary, no EXECUTE, not EVALUATE
+- no CATCH and THROW
+- no error handling
+
+### Prerequisites:
+
+ Just 13 primitives: emit key dup swap drop 0< ?exit >r r> - nest unnest lit
+
+## simpleForth
+
+simpleForth is an extension to preForth built using preForth. It is still non-interactive but adds
+
+- control structures IF ELSE THEN BEGIN WHILE REPEAT UNTIL
+- definitions with and without headers in generated code
+- memory: @ ! c@ c! allot c, ,
+- variable, constants
+- ['] execute
+- immediate definitions
+
+## Forth
+
+Forth is a simple interactive Forth system built using simpleForth.
+Forth is open ended and has a yet incomplete set of features. Work in progress.
+
+
+# How to use:
+
+An i386-Backend (32Bit) indirect threaded code implementation based on [FASM](https://flatassembler.net/) is pre-configured.
+PreForth initially bootstraps on with [gforth](https://www.gnu.org/software/gforth/) or [swiftForth](https://www.forth.com/swiftforth/).
+You'll need one of these for the first bootstrap.
+
+ cd preForth
+ make
+
+This will successively compile preForth, simpleForth, then Forth.
+
+If successful issue
+
+ $ ./Forth
+
+ Forth 1.2.0
+
+ last * warm cold empty patch minor major banner quit restart REPEAT WHILE AGAIN UNTIL BEGIN THEN ELSE IF ; : constant variable header cmove compile, , allot here dp +! clearstack interpret parse-name \ .( ( parse (interpreters ?word (compilers ,word immediate !flags @flags or and #immediate ] [ interpreters compilers handlers ,'x' ?'x' ,# ?# scan skip source /string >in query #tib tib accept min words .name l>interp l>name l>flags type count cell+ cells find-name .s prefix? compare 2dup 2drop rot off on ?dup + space bl cr . u. negate > 1- nip = 0= pick 1+ < over depth execute c! ! c@ @ ?branch branch lit exit unnest - r> >r ?exit 0< drop swap dup key emit bye
+
+Inspect sources and generated files.
+
+*Have fun. May the Forth be with you.*
+
--- /dev/null
+from debian
+
+run dpkg --add-architecture i386
+
+run apt-get -y update && apt-get -y upgrade
+run apt-get -y install fasm gforth make gcc:i386
+
+run mkdir preForth
+workdir preForth
+
+copy Makefile /preForth/Makefile
+copy preForth.pre /preForth/preForth.pre
+copy preForth-i386-backend.pre /preForth/preForth-i386-backend.pre
+copy preForth-i386-rts.pre /preForth/preForth-i386-rts.pre
+copy preForth-rts.pre /preForth/preForth-rts.pre
+
+copy borrow.fs /preForth/borrow.fs
+copy load-preForth.fs /preForth/load-preForth.fs
+copy load-i386-preForth.fs /preForth/load-i386-preForth.fs
+
+copy simpleForth.pre /preForth/simpleForth.pre
+copy simpleForth-i386-backend.pre /preForth/simpleForth-i386-backend.pre
+copy simpleForth-i386-rts.simple /preForth/simpleForth-i386-rts.simple
+copy simpleForth-rts.simple /preForth/simpleForth-rts.simple
+
+copy simpleForthDemo.simple /preForth/simpleForthDemo.simple
+
+run make bootstrap
+run make simpleForthDemo
+run ./simpleForthDemo
+
--- /dev/null
+# Makefile for preForth
+#
+# make bootstrap should produce two identical files: preForth1.asm and preForth.asm
+# or preForth1.c and preForth.c
+
+
+# Set PLATFORM to the intended preForth platform
+# ------------------------------------------------------------------------
+# PLATFORM=symbolic
+PLATFORM=i386
+# PLATFORM=C
+# ------------------------------------------------------------------------
+
+
+# Set HOSTFORTH to the Forth system that generates the initial preForth
+# ------------------------------------------------------------------------
+HOSTFORTH=gforth
+# HOSTFORTH=sf # SwiftForth >3.7
+# ------------------------------------------------------------------------
+
+.PHONY=all
+all: preForth simpleForth forth
+
+.PHONY=test
+test: preForth.pre preForth-$(PLATFORM)-backend.pre load-$(PLATFORM)-preForth.fs
+ cat preForth-$(PLATFORM)-backend.pre simpleForth.pre | $(HOSTFORTH) load-$(PLATFORM)-preForth.fs
+
+# preForth connected to stdin - output to stdout
+.PHONY=visible-bootstrap
+visible-bootstrap: preForth preForth-$(PLATFORM)-backend.pre preForth.pre
+ cat preForth-$(PLATFORM)-backend.pre preForth.pre | ./preForth
+
+# ------------------------------------------------------------------------
+# i386 version MacOS and Linux
+# ------------------------------------------------------------------------
+ifeq ($(PLATFORM),C)
+ UNIXFLAVOUR=stdC
+ EXT=c
+else
+ UNIXFLAVOUR=$(shell uname -s)
+ EXT=asm
+endif
+
+# preForth connected to stdin - output to preForth.asm
+preForth.asm: preForth.pre preForth-$(PLATFORM)-backend.pre load-$(PLATFORM)-preForth.fs
+ cat preForth-$(PLATFORM)-rts.pre preForth-rts.pre preForth-$(PLATFORM)-backend.pre preForth.pre \
+ | $(HOSTFORTH) load-$(PLATFORM)-preForth.fs >preForth.asm
+
+preForth: preForth.$(UNIXFLAVOUR)
+ cp preForth.$(UNIXFLAVOUR) preForth
+
+%.asm: %.pre preForth preForth-$(PLATFORM)-rts.pre preForth-rts.pre
+ cat preForth-$(PLATFORM)-rts.pre preForth-rts.pre $< | ./preForth >$@
+
+%: %.$(UNIXFLAVOUR)
+ cp $< $@
+
+# assemble and link executable on linux
+%.Linux: %.asm
+ fasm $< $@.o
+ ld -arch i386 -o $@ \
+ -dynamic-linker /lib32/ld-linux.so.2 \
+ /usr/lib/i386-linux-gnu/crt1.o /usr/lib/i386-linux-gnu/crti.o \
+ $@.o \
+ -lc /usr/lib/i386-linux-gnu/crtn.o
+ rm $@.o
+
+# assemble and link executable on MacOS
+%.Darwin: %.asm
+ fasm $< $@.o
+ objconv -fmacho32 -nu $@.o $@_m.o
+ ld -arch i386 -macosx_version_min 10.6 -o $@ \
+ $@_m.o /usr/lib/crt1.o /usr/lib/libc.dylib
+ # rm $@.o $@_m.o
+
+# run preForth on its own source code to perform a bootstrap
+# should produce identical results
+bootstrap: preForth preForth-$(PLATFORM)-backend.pre preForth.pre preForth.$(EXT)
+ cat preForth-$(PLATFORM)-rts.pre preForth-rts.pre preForth-$(PLATFORM)-backend.pre preForth.pre\
+ | ./preForth >preForth1.$(EXT)
+ cmp preForth.$(EXT) preForth1.$(EXT)
+
+# ------------------------------------------------------------------------
+# C version
+# ------------------------------------------------------------------------
+# preForth connected to stdin - output to preForth.c
+preForth.c: preForth.pre preForth-C-backend.pre load-C-preForth.fs
+ cat preForth-C-rts.pre preForth-rts.pre preForth-C-backend.pre preForth.pre \
+ | $(HOSTFORTH) load-C-preForth.fs >preForth.c
+
+%.c: %.pre preForth preForth-C-rts.pre preForth-rts.pre
+ cat preForth-C-rts.pre preForth-rts.pre $< | ./preForth >$@
+
+%.stdC: %.c
+ gcc -O3 -Wno-implicit-function-declaration -o $@ $<
+
+# get C version assembly listing
+preForth.s: preForth.c
+ gcc -S -O3 -Wno-implicit-function-declaration -o preForth.s preForth.c
+
+
+# ------------------------------------------------------------------------
+# Docker support (for Linux version)
+# ------------------------------------------------------------------------
+# create a linux image based on Dockerfile
+.PHONY=docker-image
+docker-image: Dockerfile
+ docker build -t preforth .
+
+# run the docker image
+.PHONY=run
+run: docker-image
+ docker run -i -t --rm preforth
+# ------------------------------------------------------------------------
+
+# ------------------------------------------------------------------------
+# simpleForth
+# ------------------------------------------------------------------------
+simpleForth.$(EXT): simpleForth.pre simpleForth-$(PLATFORM)-backend.pre preForth-$(PLATFORM)-rts.pre preForth-rts.pre preForth
+ cat preForth-$(PLATFORM)-rts.pre preForth-rts.pre simpleForth-$(PLATFORM)-backend.pre simpleForth.pre \
+ | ./preForth >simpleForth.$(EXT)
+
+simpleForth: simpleForth.$(UNIXFLAVOUR)
+ cp simpleForth.$(UNIXFLAVOUR) simpleForth
+
+%.asm: %.simple simpleForth simpleForth-$(PLATFORM)-rts.simple simpleForth-rts.simple
+ cat simpleForth-$(PLATFORM)-rts.simple simpleForth-rts.simple $< | ./simpleForth >$@
+
+
+.PHONY=clean
+clean:
+ rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo simpleForthDemo simpleForth preForth forth
--- /dev/null
+\ Minimal Forth Workbench: main file uh 2015-10-05
+
+: tick ( <spaces>name<spaces> -- comp-xt exec-xt flag )
+ STATE @ >R
+ ] >IN @ >R BL WORD FIND
+ IF R> >IN !
+ POSTPONE [ BL WORD FIND
+ ELSE R> DROP
+ DROP 0 0 false
+ THEN
+ R> IF ] ELSE POSTPONE [ THEN ;
+
+: immediate-alias ( comp-xt exec-xt <spaces>name<spaces> -- )
+ CREATE , , IMMEDIATE DOES> STATE @ IF CELL+ THEN @ EXECUTE ;
+
+: non-immediate-alias ( comp-xt exec-xt <spaces>name<spaces> -- )
+ CREATE , , IMMEDIATE DOES> STATE @ IF CELL+ @ COMPILE, ELSE @ EXECUTE THEN ;
+
+VARIABLE #primitives 0 #primitives !
+VARIABLE #words 0 #words !
+
+: another-primitive ( -- ) 1 #primitives +! 1 #words +! ;
+
+: borrow ( <space>ccc<space> -- )
+ get-order
+ >IN @ >R tick R> >IN ! NIP NIP
+ 0= IF
+ forth-wordlist 1 set-order
+ another-primitive
+ >IN @ >R tick R> >IN ! DUP 0= Abort" ?"
+ 0< IF non-immediate-alias ELSE immediate-alias THEN
+ ELSE
+ CR BL WORD COUNT TYPE ." is already defined."
+ THEN
+ set-order ;
+
+: primitive ( <space>ccc<space> -- ) borrow ;
+
+\ : later ( <space>ccc<space> -- ) \ word ccc uses late binding
+\ \ has danger of infinite recursion if no defintion exists
+\ >IN @ >R CREATE R> >IN !
+\ HERE BL WORD COUNT >R
+\ HERE CHAR+ R@ MOVE R@ CHAR+ ALLOT R> SWAP C!
+\ DOES> COUNT EVALUATE ;
+
+: later ( <space>ccc<space> -- ) \ word ccc uses late binding
+ >IN @ >R CREATE R> >IN !
+ HERE BL WORD COUNT >R
+ HERE CHAR+ R@ MOVE R@ CHAR+ ALLOT R> SWAP C!
+ DOES> DUP >R
+ FIND 0= ABORT" ?"
+ DUP >BODY R@ = IF R> COUNT TYPE ." is not yet defined." ABORT THEN
+ R> DROP EXECUTE ;
+
+
+
--- /dev/null
+\ simpleForth test program
+
+\ The simpleForth runtimesystem has only the words
+\
+\ bye emit key dup swap drop 0< ?exit >r r> - unnest lit
+\ branch ?branch @ c@ ! c!
+
+: over ( x1 x2 -- x1 x2 x1 )
+ >r dup r> swap ;
+
+: < ( n1 n2 -- flag )
+ - 0< ;
+
+: 1+ ( n1 -- n2 )
+ 1 + ;
+
+: pick ( xn-1 ... x0 i -- xn-1 ... x0 xi )
+ over swap ?dup 0= ?exit nip swap >r 1- pick r> swap ;
+
+: 0= ( x -- flag )
+ 0 swap ?exit drop -1 ;
+
+: = ( x1 x2 -- f )
+ - 0= ;
+
+: nip ( x1 x2 -- x2 )
+ swap drop ;
+
+: 1- ( n1 -- n2 )
+ 1 - ;
+
+: > ( n1 n2 -- flag )
+ swap < ;
+
+: negate ( n1 -- n2 )
+ 0 swap - ;
+
+
+
+
+\ number output
+\ -------------
+
+|: (/mod ( n d q0 -- r d q )
+ >r 2dup < r> swap ?exit
+ >r swap over - swap r> 1+ (/mod ;
+
+|: 10* ( x1 -- x2 )
+ dup + dup dup + dup + + ;
+
+|: (10u/mod ( n q d -- r q d )
+ 2 pick over > 0= ?exit \ ( n q d )
+ dup >r 10* \ ( n q 10*d ) ( R: d )
+ (10u/mod \ ( r q d )
+ swap >r 0 (/mod nip r> 10* + r> ;
+
+|: 10u/mod ( n -- r q )
+ 0 1 (10u/mod drop ;
+
+|: (u. ( u1 -- )
+ ?dup 0= ?exit 10u/mod (u. '0' + emit ;
+
+\ display unsigned number
+: u. ( u -- )
+ dup (u. ?exit '0' emit ;
+
+
+|: (. ( n -- n' )
+ dup 0< 0= ?exit '-' emit negate ;
+
+\ display signed number
+: . ( n -- )
+ (. u. ;
+
+
+
+: cr ( -- )
+ 10 emit ;
+
+32 constant bl
+
+: space ( -- )
+ bl emit ;
+
+: + ( n1 n2 -- n3 )
+ 0 swap - - ;
+
+: ?dup ( x -- x x | 0 )
+ dup IF dup THEN ;
+
+: on ( addr -- )
+ -1 swap ! ;
+
+: off ( addr -- )
+ 0 swap ! ;
+
+: rot ( x y z -- y z x )
+ >r swap r> swap ;
+
+: 2drop ( x1 x2 -- )
+ drop drop ;
+
+: 2dup ( x1 x2 -- x1 x2 )
+ over over ;
+
+: compare ( c-addr1 u1 c-addr2 u2 -- n )
+ rot
+ BEGIN \ ( c-addr1 c-addr2 u1 u2 )
+ over
+ WHILE
+ dup
+ WHILE
+ >r >r over c@ over c@ - ?dup IF 0< dup + 1 + nip nip r> drop r> drop unnest THEN
+ 1+ swap 1+ swap
+ r> 1- r> 1-
+ REPEAT
+ -1
+ ELSE
+ dup 0= IF 0 ELSE 1 THEN
+ THEN >r 2drop 2drop r> ;
+
+\ prefix? tests if c-addr1 u1 is a prefix of c-addr2 u2
+: prefix? ( c-addr1 u1 c-addr2 u2 -- f )
+ rot
+ 2dup < IF 2drop 2drop 0 exit THEN
+ nip
+ BEGIN \ ( c-addr1 c-addr2 u2 )
+ ?dup
+ WHILE
+ >r over c@ over c@ - IF 2drop r> drop 0 exit THEN
+ 1+ swap 1+ swap
+ r> 1-
+ REPEAT
+ 2drop -1 ;
+
+: .s ( i*x -- i*x )
+ depth 0= ?exit >r .s r> dup . space ;
+
+\ TODO prefix handling
+
+: find-name ( c-addr u link -- header )
+ BEGIN
+ dup
+ WHILE
+ >r 2dup r> dup >r
+ l>name dup cell+ swap @ compare 0= IF 2drop r> exit THEN
+ r> @
+ REPEAT
+ nip nip ;
+
+: cells ( n -- m )
+ dup + dup + ;
+
+: cell+ ( addr1 -- addr2 )
+ 1 cells + ;
+
+: count ( addr1 -- addr2 u )
+ dup 1+ swap c@ ;
+
+: type ( c-addr u -- )
+ BEGIN ?dup WHILE >r count emit r> 1- REPEAT drop ;
+
+: l>flags ( link -- flags )
+ cell+ ;
+
+: l>name ( link -- name )
+ 2 cells + ;
+
+: l>interp ( link -- xt )
+ l>name dup cell+ swap @ + ;
+
+: .name ( addr -- )
+ dup cell+ swap @ type ;
+
+: words ( -- )
+ last @
+ BEGIN
+ ?dup
+ WHILE
+ dup l>name .name space
+ @
+ REPEAT ;
+
+: min ( n1 n2 -- n3 )
+ 2dup > IF swap THEN drop ;
+
+: accept ( c-addr +n1 -- +n2 )
+ dup 0= IF nip exit THEN
+ swap >r 0
+ BEGIN \ ( +n1 +n3 ) ( R: c-addr )
+ key dup 10 -
+ WHILE
+ over r> dup >r + c!
+ 1+ over 1- min
+ REPEAT
+ drop nip r> drop ;
+
+create tib ( -- addr )
+ 80 allot
+
+variable #tib
+
+: query ( -- )
+ tib 80 accept #tib ! ;
+
+variable >in ( -- addr )
+
+: /string ( c-addr1 u1 n -- c-addr2 u2 )
+ swap over - >r + r> ;
+
+: source ( -- c-addr u )
+ tib #tib @ ;
+
+: skip ( c-addr1 u1 c -- c-addr2 u2 )
+ BEGIN
+ over
+ WHILE
+ >r over c@ r> swap over =
+ WHILE
+ >r 1 /string r>
+ REPEAT THEN drop ;
+
+: scan ( c-addr u1 c -- c-addr2 u2 )
+ BEGIN
+ over
+ WHILE
+ >r over c@ r> swap over -
+ WHILE
+ >r 1 /string r>
+ REPEAT THEN drop ;
+
+|: digit? ( c -- f )
+ dup '0' < IF drop 0 exit THEN '9' > 0= ;
+
+: ?# ( c-addr u -- x 0 0 | c-addr u )
+ dup 0= ?exit
+ 2dup 0 >r
+ BEGIN
+ dup
+ WHILE
+ over c@ dup digit? 0= IF drop r> drop 2drop exit THEN
+ '0' - r> 10* + >r
+ 1 /string
+ REPEAT
+ 2drop 2drop r> 0 0 ;
+
+: ,# ( c-addr u -- 0 0 | c-addr u )
+ dup 0= ?exit
+ ?# dup ?exit
+ ['] lit compile, rot , ;
+
+: ?'x' ( c-addr u -- x 0 0 | c-addr u )
+ dup 0= ?exit
+ dup 3 =
+ IF over c@ ''' - ?exit
+ over 2 + c@ ''' - ?exit
+ drop 1+ c@ 0 0 THEN ;
+
+: ,'x' ( c-addr u -- 0 0 | c-addr u )
+ dup 0= ?exit
+ ?'x' dup ?exit
+ ['] lit compile, rot , ;
+
+
+
+variable handlers
+
+variable compilers
+
+variable interpreters
+
+
+: [ ( -- )
+ interpreters @ handlers ! ;
+
+: ] ( -- )
+ compilers @ handlers ! ;
+
+1 constant #immediate
+
+code and ( x1 x2 -- x3 )
+ pop eax
+ pop edx
+ and eax, edx
+ push eax
+ next
+;
+
+code or ( x1 x2 -- x3 )
+ pop eax
+ pop edx
+ or eax, edx
+ push eax
+ next
+;
+
+: @flags ( -- x )
+ last @ l>flags @ ;
+
+: !flags ( x -- )
+ last @ l>flags ! ;
+
+: immediate ( x -- )
+ @flags #immediate or !flags ;
+
+: ,word ( c-addr1 u1 | i*x c-addr2 u2 )
+ dup 0= ?exit
+ 2dup last @ find-name ?dup
+ IF nip nip dup l>flags @ #immediate and
+ IF l>interp execute ELSE l>interp compile, THEN 0 0 THEN
+;
+
+
+
+: (compilers ( c-addr u1 | i*x c-addr2 u2 )
+ ,word
+ ,#
+ ,'x'
+ over IF space type '?' emit tail restart THEN
+;
+
+: ?word ( c-addr1 u1 | i*x c-addr2 u2 )
+ dup 0= ?exit
+ 2dup last @ find-name ?dup IF nip nip l>interp execute 0 0 THEN
+;
+
+: (interpreters ( c-addr1 u1 | i*x c-addr2 u2 )
+ ?word
+ ?#
+ ?'x'
+ over IF space type '?' emit tail restart THEN
+;
+
+: parse ( c -- c-addr u )
+ >r source >in @ /string
+ 2dup r> dup >r scan
+ 2dup r> skip nip source nip swap - >in !
+ nip - ;
+
+immediate: ( ( -- )
+ ')' parse 2drop ;
+
+immediate: .( ( -- )
+ ')' parse type ;
+
+immediate: \ ( -- )
+ source >in ! drop ;
+
+: parse-name ( -- c-addr u )
+ source >in @ /string
+ bl skip 2dup bl scan source nip over - >in ! nip - ;
+
+: interpret ( -- )
+ 0 0 BEGIN handlers @ execute 2drop parse-name dup 0= UNTIL 2drop ;
+
+|: prompt ( -- )
+ cr .s
+ handlers @ compilers @ = IF ']' ELSE '>' THEN emit space ;
+
+|: .ok ( -- )
+ space 'o' emit 'k' emit ;
+
+: clearstack ( -- )
+ BEGIN depth 0< WHILE 0 REPEAT
+ BEGIN depth WHILE drop REPEAT ;
+
+\ : t{ ;
+\ : --> ;
+\ : t} ;
+
+: +! ( n addr -- )
+ dup >r @ + r> ! ;
+
+variable dp
+
+: here ( -- addr )
+ dp @ ;
+
+: allot ( n -- )
+ dp +! ;
+
+: , ( x -- )
+ here 1 cells allot ! ;
+
+: compile, ( xt -- )
+ , ;
+
+: cmove ( c-addr1 c-addr2 u -- )
+ BEGIN
+ ?dup
+ WHILE
+ >r
+ over c@ over c!
+ 1+ swap 1+ swap
+ r> 1-
+ REPEAT
+ 2drop ;
+
+: header ( c-addr u -- )
+ here last @ , last !
+ 0 , \ flags
+ dup , \ len
+ here swap dup allot
+ cmove ;
+
+: variable ( <name> -- )
+ parse-name header ['] dp @ , 0 , ;
+
+: constant ( <name> -- )
+ parse-name header ['] bl @ , , ;
+
+: : ( <name> -- )
+ parse-name header ['] ; @ , ] ;
+
+immediate: ; ( -- )
+ ['] unnest compile, [ ;
+
+immediate: IF ( -- addr )
+ ['] ?branch compile, here 0 , ;
+
+immediate: ELSE ( addr1 -- addr2 )
+ ['] branch compile, here 0 , here rot ! ;
+
+immediate: THEN ( addr -- )
+ here swap ! ;
+
+immediate: BEGIN ( -- addr )
+ here ;
+
+immediate: UNTIL ( addr -- )
+ ['] ?branch compile, , ;
+
+immediate: AGAIN ( addr -- )
+ ['] branch compile, , ;
+
+immediate: WHILE ( addr1 -- addr2 addr1 )
+ ['] ?branch compile, here 0 , swap ;
+
+immediate: REPEAT ( addr1 addr2 -- )
+ ['] branch compile, , here swap ! ;
+
+: restart ( -- )
+ BEGIN
+ prompt query 0 >in ! interpret .ok
+ 0 UNTIL ;
+
+: quit ( -- )
+ [ clearstack restart ;
+
+create banner ( -- addr )
+ 5 c, 'F' c, 'o' c, 'r' c, 't' c, 'h' c,
+
+1 constant major ( -- x )
+2 constant minor ( -- x )
+0 constant patch ( -- x )
+
+|: .version ( -- )
+ major '0' + emit '.' emit
+ minor '0' + emit '.' emit
+ patch '0' + emit ;
+
+|: .banner ( -- )
+ cr banner count type space .version cr ;
+
+: empty ( -- )
+ last cell+ dp ! last 20 - last ! ; \ reset dictionary
+
+: cold ( -- )
+ empty warm ;
+
+: warm ( -- )
+ .banner
+ ['] (interpreters interpreters !
+ ['] (compilers compilers !
+ cr words cr
+ quit
+;
+
+
+code * ( n1 n2 -- n3 )
+ pop eax
+ pop edx
+ mul edx
+ push eax
+ next
+;
+
--- /dev/null
+\ load C preForth on top of a host Forth system
+
+include load-preForth.fs
+include preForth-C-rts.pre
+include preForth-rts.pre
+include preForth-C-backend.pre
+include preForth.pre
+
+cold
+
+bye
--- /dev/null
+\ load i386 preForth on top of a host Forth system
+
+include load-preForth.fs
+include preForth-i386-rts.pre
+include preForth-rts.pre
+include preForth-i386-backend.pre
+include preForth.pre
+
+cold
+
+bye
--- /dev/null
+\ Load preForth on GForth or SwiftForth connected to stdin and stdout.
+
+
+defined warnings [IF] \ e.g. gforth
+ warnings off
+[THEN]
+
+defined warning [IF] \ e.g. SwiftForth
+ warning off
+[THEN]
+
+Variable ch
+
+\ key reads from stdin so it can be used with pipes and input redirection.
+: key ( -- c )
+ ch 1 stdin read-file throw
+ 1 < IF 4 ( eof ) ELSE ch c@ THEN
+ ; \ dup emit ;
+
+\ This : allows for recursion by using a word's name.
+defined -smudge [IF] \ SwiftForth
+: : : -smudge ;
+[THEN]
+
+defined reveal [IF] \ gforth
+: : : reveal ;
+[THEN]
+
+
+\ Define pre and code so they skip their body
+
+: pre ( -- )
+ BEGIN refill WHILE
+ source s" ;" compare 0= IF POSTPONE \ EXIT THEN
+ REPEAT ;
+
+: prefix pre ;
+: prelude pre ;
+: preamble pre ;
+: code pre ;
+
+: tail ;
+
+include borrow.fs
+
+wordlist Constant preForth
+
+preForth set-current
+
+: borrow borrow ;
+: primitive borrow ;
+: tail tail ;
+
+preForth 1 set-order
+
+borrow include
+borrow :
+borrow ;
+borrow \
+borrow (
+borrow .s
+
+borrow pre
+borrow prefix
+borrow prelude
+borrow preamble
+borrow code
+
+borrow later
+later ?dup
+later 0=
+later negate
+later +
+later 1+
+later 1-
+later =
+later <
+later >
+later case?
+
+later over
+later rot
+later nip
+later 2drop
+later pick
+later roll
+
+later bl
+later space
+later tab
+later cr
+later u.
+later .
+
+later show
+later _dup
+later _drop
+later _swap
+
+primitive emit
+primitive key
+primitive dup
+primitive swap
+primitive 0<
+primitive ?exit
+primitive drop
+primitive recurse
+primitive >r
+primitive r>
+primitive -
+\ nest
+\ unnest
+\ lit
+
+borrow bye
--- /dev/null
+\ load symbolic preForth on top of a host Forth system
+
+include load-preForth.fs
+include preForth-symbolic-rts.pre
+include preForth-rts.pre
+include preForth-symbolic-backend.pre
+include preForth.pre
+
+cold
+
+bye
--- /dev/null
+\ preForth C backend
+
+\ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels).
+: replace ( c -- c d )
+ 'A' swap ''' case? ?exit nip
+ 'B' swap '\' case? ?exit nip
+ 'C' swap ':' case? ?exit nip
+ 'D' swap '.' case? ?exit nip
+ 'E' swap '=' case? ?exit nip
+\ 'F' swap '@' case? ?exit nip
+ 'G' swap '>' case? ?exit nip
+ 'H' swap ']' case? ?exit nip
+ 'I' swap '1' case? ?exit nip
+ 'J' swap '2' case? ?exit nip
+ 'K' swap '/' case? ?exit nip
+ 'L' swap '<' case? ?exit nip
+ 'M' swap '-' case? ?exit nip
+ 'N' swap '#' case? ?exit nip
+ 'O' swap '0' case? ?exit nip
+ 'P' swap '+' case? ?exit nip
+ 'Q' swap '?' case? ?exit nip
+ 'R' swap '"' case? ?exit nip
+ 'S' swap ';' case? ?exit nip
+ 'T' swap '*' case? ?exit nip
+ 'U' swap '(' case? ?exit nip
+ 'V' swap '|' case? ?exit nip
+ \ also 'X' for machine code
+ 'W' swap ',' case? ?exit nip
+ 'Y' swap ')' case? ?exit nip
+ 'Z' swap '!' case? ?exit nip
+;
+
+\ alter substitutes all non-letter characters by upper case letters.
+: alter ( c1 ... cn n -- d1 ... dn n )
+ dup 0= ?exit
+ swap >r 1- alter r> replace swap 1+ ;
+
+\ ------------
+\ output words
+\ ------------
+\ Output is done by emit.
+\ We define convenience words of the form ."xxx" to output xxx and >"xxx" to output xxx on a new line indented by a tab.
+
+: ."int" ( -- )
+ 'i' emit 'n' emit 't' emit ;
+
+: ."return" ( -- )
+ 'r' emit 'e' emit 't' emit 'u' emit 'r' emit 'n' emit ;
+
+: ."#define" ( -- )
+ '#' emit 'd' emit 'e' emit 'f' emit 'i' emit 'n' emit 'e' emit ;
+
+: ."lit" ( -- )
+ 'l' emit 'i' emit 't' emit ;
+
+: >\word ( c1 ... c2 n -- )
+ cr '/' emit '*' emit space show space '*' emit '/' emit ;
+
+\ ------------
+\ Compiling words
+\ ------------
+
+\ reproduce a verbatim line
+: ,line ( x1 ...cn n -- )
+ show ;
+
+\ indent a verbatim line
+: ,>line ( c1 ... cn b -- )
+ cr tab ,line ;
+
+\ compile a reference to an invoked word
+: ,word ( c1 ... cn n -- )
+ tab alter show '(' emit ')' emit ';' emit ;
+
+\ compile a reference to an invoked word on a new line
+: ,>word ( c1 ... cn n -- )
+ cr ,word ;
+
+\ compile reference to nest primitive
+: ,nest ( -- )
+ space '{' emit ;
+
+\ compile reference to unnest primitive
+: ,unnest ( -- )
+ cr tab ."return" space 0 . ';' emit
+ cr '}' emit cr cr ;
+
+\ compile signed number
+: ,n ( n -- )
+ . ;
+
+\ compile unsigned number
+: ,u ( u -- )
+ u. ;
+
+\ compile literal
+: ,_lit ( c1 ... cn n -- )
+ cr tab ."lit" space ,word ';' emit ;
+
+: ,lit ( x -- )
+ cr tab ."lit" '(' emit ')' emit space ,n ';' emit ;
+
+\ output string as comment
+: ,comment ( c1 ... cn n -- )
+ cr '/' emit '*' emit space show space '*' emit '/' emit ;
+
+\ create a new symbolic label
+: label ( c1 ... cn n -- )
+ cr ."int" space alter show '(' emit ')' emit ;
+
+\ body calculates the name of the body from a token
+: body ( c1 ... cn n -- c1 ... cm m )
+ 'X' swap 1+ ;
+
+: ,code ( c1 ... nn n -- )
+ cr ."#define" space alter show '(' emit ')' emit ;
+
+: ,end-code ( -- )
+ cr ;
+
+\ -----------------------------------------
+
+\ tail calls
+\ C compilei is assumed to optimize tail calls
+\ so no optimization is done here.
+
+: bodylabel ( c1 ... cn n -- )
+ _drop ;
+
+\ ,tail compiles an unoptimized call
+: ,tail ( c1 ... cn n -- )
+ ,>word ;
+
+\ --------------
+\ Create headers
+\ --------------
+\ preForth can optionally also create word headers with a very simple layout.
+\
+\ Word creation is split into parts
+\ - header creates a dictionary header from a string on the stack.
+\ - label creates the assembler label (with symbol substitution)
+\ - body defined later by code (assembly code) or : (threaded code)
+\
+\ Headers are linked in a single linked list ending in 0.
+\ The link-label name of the latest definition is always as a string on top of stack.
+\ Creating a new header puts this in the link field of the new definition and
+\ replaces the link-label with the current one.
+
+
+\ link to previous header c. d is new header.
+: ,link ( c1 ... cn n d1 ... dm m -- d1 ... dm _ m+1 d1 ... dm m )
+ '_' swap 1+ _dup label \ d_:
+ _swap ,word _dup
+ 1- nip ;
+
+\ create a new header with given name c and flags
+\ : header ( d1 ... dm m c1 ... c2 n flags -- d1 ... dm m c1 ... cn n )
+\ >r
+\ ,link \ link
+\ r> ,u \ flags
+\ dup ,u \ len
+\ _dup ,string \ name
+\ ;
+
+\ dummy definition to not create a new header with given name c and flags
+: header ( d1 ... dm m c1 ... c2 n flags -- d1 ... dm m c1 ... cn n )
+ drop ;
+
+: ."done" ( -- )
+ 'd' emit 'o' emit 'n' emit 'e' emit ;
+
+: ."last:" ( -- )
+ 'l' emit 'a' emit 's' emit 't' emit ':' emit ;
+
+: ,end ( c1 ... cn n -- )
+ cr '/' emit '*' emit space ."last:" space alter show space '*' emit '/' emit
+ cr '/' emit '*' emit space ."done" space '*' emit '/' emit
+ cr ;
+
+
+\ ==== End of platform dependent part - all below should be platform independent ===
--- /dev/null
+\ preForth runtime system - C dependent part
+
+preamble
+/* This is a preForth generated file using preForth-C-backend. */
+/* Only modify it, if you know what you are doing. */
+
+ #include <stdio.h>
+
+ int s[10000]; /* stack */
+ int *sp=s; /* stack pointer */
+ int r[10000]; /* return stack */
+ int *rp=r; /* return stack pointer */
+
+#define cold main
+
+;
+
+code emit ( c -- )
+ do { putchar(*sp--); fflush(stdout); } while(0)
+;
+
+code key ( -- c )
+ do { *++sp=getchar(); if (*sp==EOF) *sp=4; } while(0)
+;
+
+code dup ( x -- x x )
+ do { int tos=*sp; *++sp=tos; } while (0)
+;
+
+code swap ( x y -- y x )
+ do { int tos=*sp; *sp=sp[-1]; sp[-1]=tos; } while(0)
+;
+
+code drop ( x -- )
+ sp--
+;
+
+code 0< ( x -- flag )
+ *sp=*sp<0?-1:0
+;
+
+code ?exit ( f -- )
+ if (*sp--) return 0
+;
+
+code >r ( x -- ) ( R -- x )
+ *++rp=*sp--
+;
+
+code r> ( R x -- ) ( -- x )
+ *++sp=*rp--
+;
+
+code - ( x1 x2 -- x3 )
+ do { int tos=*sp--; *sp-=tos; } while(0)
+;
+
+code lit ( -- )
+ *++sp=
+;
+
--- /dev/null
+\ --------------------------
+\ preForth backend for i386 (32 bit) FASM
+\ --------------------------
+
+\ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels).
+: replace ( c -- c d )
+ 'A' swap 39 case? ?exit nip
+ 'B' swap '\' case? ?exit nip
+ 'C' swap ':' case? ?exit nip
+ 'D' swap '.' case? ?exit nip
+ 'E' swap '=' case? ?exit nip
+ 'F' swap '[' case? ?exit nip
+ 'G' swap '>' case? ?exit nip
+ 'H' swap ']' case? ?exit nip
+ 'I' swap '1' case? ?exit nip
+ 'J' swap '2' case? ?exit nip
+ 'K' swap '/' case? ?exit nip
+ 'L' swap '<' case? ?exit nip
+ 'M' swap '-' case? ?exit nip
+ 'N' swap '#' case? ?exit nip
+ 'O' swap '0' case? ?exit nip
+ 'P' swap '+' case? ?exit nip
+ 'Q' swap '?' case? ?exit nip
+ 'R' swap '"' case? ?exit nip
+\ 'S' swap '!' case? ?exit nip
+ 'T' swap '*' case? ?exit nip
+ 'U' swap '(' case? ?exit nip
+ 'V' swap '|' case? ?exit nip
+ 'W' swap ',' case? ?exit nip
+ \ also 'X' for machine code
+ 'Y' swap ')' case? ?exit nip
+ 'Z' swap ';' case? ?exit nip
+;
+
+\ alter substitutes all non-letter characters by upper case letters.
+: alter ( S1 -- S2 )
+ '_' 1 rot ?dup 0= ?exit nip nip
+ \ dup 0= ?exit
+ swap >r 1- alter r> replace swap 1+ ;
+
+\ ------------
+\ output words
+\ ------------
+\ Output is done by emit.
+\ We define convenience words of the form ."xxx" to output xxx and >"xxx" to output xxx on a new line indented by a tab.
+
+: ."dd" ( -- )
+ 'D' emit 'D' emit space ;
+
+: >"dd" ( -- )
+ cr tab ."dd" ;
+
+: ."db" ( -- )
+ 'D' emit 'B' emit space ;
+
+: >"db" ( -- )
+ cr tab ."db" ;
+
+: >"ds" ( -- )
+ cr tab 'D' emit 'S' emit space ;
+
+: ."nest" ( -- )
+ 'n' 'e' 's' 't' 4 alter show ;
+
+: ."unnest" ( -- )
+ 'u' 'n' 'n' 'e' 's' 't' 6 alter show ;
+
+: ."lit" ( -- )
+ 'l' 'i' 't' 3 alter show ;
+
+\ ------------
+\ Compiling words
+\ ------------
+
+\ ,string compiles the topmost string as a sequence of numeric DB values.
+: ,string ( S -- )
+ \ ."ds" show ;
+ ?dup 0= ?exit
+ dup roll >"db" u. \ 1st char
+ 1- ,string ;
+
+\ reproduce a verbatim line
+: ,line ( x1 ...cn n -- )
+ show ;
+
+\ compile a reference to an invoked word
+: ,word ( S -- )
+ ."dd" alter show ;
+
+\ compile a reference to an invoked word on a new line
+: ,>word ( S -- )
+ >"dd" alter show ;
+
+\ compile reference to nest primitive
+: ,nest ( -- )
+ ."dd" ."nest" ;
+
+\ compile reference to unnest primitive
+: ,unnest ( -- )
+ >"dd" ."unnest"
+ cr ;
+
+\ compile signed number
+: ,n ( n -- )
+ >"dd" . ;
+
+\ compile unsigned number
+: ,u ( u -- )
+ >"dd" u. ;
+
+\ compile literal
+: ,_lit ( S -- )
+ >"dd" ."lit" ,>word ;
+
+\ compile literal
+: ,lit ( x -- )
+ >"dd" ."lit" ,n ;
+
+\ output string as comment
+: ,comment ( S -- )
+ cr tab ';' emit space show ;
+
+\ create a new symbolic label
+: label ( S -- )
+ cr alter show ':' emit tab ;
+
+\ body calculates the name of the body from a token
+: body ( S1 -- S2 )
+ 'X' swap 1+ ;
+
+\ ,codefield compiles the code field of primitive
+: ,codefield ( S -- )
+ body _dup ,word label ;
+
+: ,code ( S -- )
+ _dup label
+ ,codefield ;
+
+: ,end-code ( -- )
+ cr ;
+
+\ -----------------------------------
+\ tail call optimization tail word ; -> [ ' word >body ] literal >r ;
+
+: bodylabel ( S -- )
+ body label ;
+
+\ ,tail compiles a tail call
+: ,tail ( S -- )
+ body ,_lit
+ '>' 'r' 2 ,>word ;
+
+: ."done" ( -- )
+ ';' emit space 'd' emit 'o' emit 'n' emit 'e' emit ;
+
+: ."last:" ( -- )
+ ';' emit space 'l' emit 'a' emit 's' emit 't' emit ':' emit space ;
+
+: ,end ( S -- )
+ cr ."last:" alter show
+ cr ."done" cr ;
+
+\ create a new header with given name S2 and flags - do nothing
+: header ( S1 S2 flags -- S3 S2 )
+ drop ;
+
--- /dev/null
+\ preForth runtime system - i386 (32 bit) dependent part
+\ --------------------------
+\
+\ - registers:
+\ EAX, EDX general purpose
+\ ESI instruction pointer
+\ EBP return stack pointer
+\ ESP data stack pointer
+
+prelude
+;;; This is a preForth generated file using preForth-i386-backend.
+;;; Only modify it, if you know what you are doing.
+
+;
+
+prefix
+format ELF
+
+section '.bss' writeable executable
+
+ DD 10000 dup (0)
+stck: DD 16 dup(0)
+
+ DD 10000 dup(0)
+rstck: DD 16 dup(0)
+
+
+section '.text' executable writeable
+public main
+extrn putchar
+extrn getchar
+extrn fflush
+extrn exit
+
+macro next {
+ lodsd
+ jmp dword [eax]
+}
+
+
+main: cld
+ mov esp, dword stck
+ mov ebp, dword rstck
+ mov esi, main1
+ next
+
+main1: DD _cold
+ DD _bye
+
+
+_nest: lea ebp, [ebp-4]
+ mov [ebp], esi
+ lea esi, [eax+4]
+ next
+
+_O = 0
+
+;
+
+code bye ( -- )
+ push ebp
+ mov ebp, esp
+ and esp, 0xfffffff0
+ mov eax, 0
+ mov [esp], eax
+ call exit
+;
+
+code emit ( c -- )
+ pop eax
+
+ push ebp
+ mov ebp, esp
+ push eax
+ and esp, 0xfffffff0
+
+ mov dword [esp], eax
+ call putchar
+
+ mov eax, 0
+ mov [esp], eax
+ call fflush ; flush all output streams
+
+ mov esp, ebp
+ pop ebp
+ next
+;
+
+code key ( -- c )
+ push ebp
+ mov ebp, esp
+ and esp, 0xfffffff0
+
+ call getchar
+ mov esp, ebp
+ pop ebp
+ cmp eax,-1
+ jnz key1
+ mov eax,4
+key1: push eax
+ next
+;
+
+code dup ( x -- x x )
+ pop eax
+ push eax
+ push eax
+ next
+;
+
+code swap ( x y -- y x )
+ pop edx
+ pop eax
+ push edx
+ push eax
+ next
+;
+
+code drop ( x -- )
+ pop eax
+ next
+;
+
+code 0< ( x -- flag )
+ pop eax
+ or eax, eax
+ mov eax, 0
+ jns zless1
+ dec eax
+zless1: push eax
+ next
+;
+
+code ?exit ( f -- )
+ pop eax
+ or eax, eax
+ jz qexit1
+ mov esi, [ebp]
+ lea ebp,[ebp+4]
+qexit1: next
+;
+
+code >r ( x -- ) ( R -- x )
+ pop ebx
+ lea ebp,[ebp-4]
+ mov [ebp], ebx
+ next
+;
+
+code r> ( R x -- ) ( -- x )
+ mov eax,[ebp]
+ lea ebp, [ebp+4]
+ push eax
+ next
+;
+
+code - ( x1 x2 -- x3 )
+ pop edx
+ pop eax
+ sub eax, edx
+ push eax
+ next
+;
+
+code unnest ( -- )
+ mov esi,[ebp]
+ lea ebp,[ebp+4]
+ next
+;
+
+code lit ( -- )
+ lodsd
+ push eax
+ next
+;
--- /dev/null
+\ preForth runtime system - machine independent part
+
+\ ------------------------------------
+\ define lots of useful standard words
+\ ------------------------------------
+
+: ?dup ( x -- x x | 0 )
+ dup dup ?exit drop ;
+
+: 0= ( x -- flag )
+ 0 swap ?exit drop -1 ;
+
+: negate ( n1 -- n2 )
+ 0 swap - ;
+
+: + ( x1 x2 -- x3 )
+ negate - ;
+
+: 1+ ( n1 -- n2 )
+ 1 + ;
+
+: 1- ( n1 -- n2 )
+ 1 - ;
+
+: = ( x1 x2 -- flag )
+ - 0= ;
+
+: < ( n1 n2 -- flag )
+ - 0< ;
+
+: > ( n1 n2 -- flag )
+ swap < ;
+
+\ case? compares the value x to y. If they match, return true. If not keep x and return false.
+: case? ( x y -- tf | x ff )
+ over = dup 0= ?exit 2drop -1 ;
+
+
+\ additional stack operators
+\ --------------------------
+
+: over ( x1 x2 -- x1 x2 x1 )
+ >r dup r> swap ;
+
+: rot ( x1 x2 x3 -- x2 x3 x1 )
+ >r swap r> swap ;
+
+: nip ( x1 x2 -- x2 )
+ swap drop ;
+
+: 2drop ( x1 x2 -- )
+ drop drop ;
+
+: pick ( xn-1 ... x0 i -- xn-1 ... x0 xi )
+ over swap ?dup 0= ?exit nip swap >r 1- pick r> swap ;
+
+: roll ( xn-1 ... x0 i -- xn-1 ... xi-1 xi+1 ... x0 xi )
+ ?dup 0= ?exit swap >r 1- roll r> swap ;
+
+
+\ text output words
+\ -----------------
+
+: bl ( -- bl )
+ 32 ;
+
+: space ( -- )
+ bl emit ;
+
+: tab ( -- )
+ 9 emit ;
+
+: cr ( -- )
+ 10 emit ;
+
+
+\ number output
+\ -------------
+
+: (/mod ( n d q0 -- r d q )
+ >r over over < r> swap ?exit
+ >r swap over - swap r> 1+ (/mod ;
+
+: 10* ( x1 -- x2 )
+ dup + dup dup + dup + + ;
+
+: (10u/mod ( n q d -- r q d )
+ 2 pick over > 0= ?exit \ ( n q d )
+ dup >r 10* \ ( n q 10*d ) ( R: d )
+ (10u/mod \ ( r q d )
+ swap >r 0 (/mod nip r> 10* + r> ;
+
+: 10u/mod ( n -- r q )
+ 0 1 (10u/mod drop ;
+
+: (u. ( u1 -- )
+ ?dup 0= ?exit 10u/mod (u. '0' + emit ;
+
+\ display unsigned number
+: u. ( u -- )
+ dup (u. ?exit '0' emit ;
+
+
+: (. ( n -- n' )
+ dup 0< 0= ?exit '-' emit negate ;
+
+\ display signed number
+: . ( n -- )
+ (. u. ;
+
+
+\ -----------
+\ strings
+\ -----------
+\ Strings are represented as character stack elements with a count on top
+\ They convieniently be processed using recursion.
+\ Idioms: dup pick gets 1st character
+\ dup gets length
+\ x swap 1+ adds x to end of string
+\ nip 1- removes last character
+\
+\ Useful words
+\ show displays trings
+\ _dup duplicates topmost string
+\ _drop removes topmost string
+\ _swap exchanges two topmost strings
+
+\ show displays topmost string
+: show ( S -- )
+ ?dup 0= ?exit swap >r 1- show r> emit ;
+
+
+: (_dup ( S m n -- S S )
+ ?dup 0= ?exit over 2 + pick rot rot 1- tail (_dup ;
+
+\ _dup duplicated topmost string
+: _dup ( S -- S S )
+ dup dup (_dup ;
+
+\ _drop removes topmost string
+: _drop ( S -- )
+ ?dup 0= ?exit nip 1- _drop ;
+
+
+: (_swap ( S1 S2 x1 x2 -- S2 S1 x1 0 )
+ dup 0= ?exit over 3 + roll rot rot 1- (_swap ;
+
+\ _swap exchanges two topmost strings
+: _swap ( S1 S2 -- S2 S1 )
+ dup >r pick r> dup >r over >r + r> r> rot rot 1+ (_swap 2drop ;
+
--- /dev/null
+\ preForth Symbolic Backend
+
+\ ------------
+\ output words
+\ ------------
+\ Output is done by emit.
+\ We define convenience words of the form ."xxx" to output xxx and >"xxx" to output xxx on a new line indented by a tab.
+
+: ."dw" ( -- )
+ 'D' emit 'W' emit space ;
+
+: >"dw" ( -- )
+ cr tab ."dw" ;
+
+: ."db" ( -- )
+ 'D' emit 'B' emit space ;
+
+: >"db" ( -- )
+ cr tab ."db" ;
+
+: >"ds" ( -- )
+ cr tab 'D' emit 'S' emit space ;
+
+: ."nest" ( -- )
+ 'n' emit 'e' emit 's' emit 't' emit ;
+
+: ."unnest" ( -- )
+ 'u' emit 'n' emit ."nest" ;
+
+: ."lit" ( -- )
+ 'l' emit 'i' emit 't' emit ;
+
+
+\ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels).
+: replace ( c -- c d )
+ 'A' swap 39 case? ?exit nip
+ 'B' swap '\' case? ?exit nip
+ 'C' swap ':' case? ?exit nip
+ 'D' swap '.' case? ?exit nip
+ 'E' swap '=' case? ?exit nip
+\ 'F' swap '@' case? ?exit nip
+ 'G' swap '>' case? ?exit nip
+ 'H' swap ']' case? ?exit nip
+ 'I' swap '1' case? ?exit nip
+ 'J' swap '2' case? ?exit nip
+ 'K' swap '/' case? ?exit nip
+ 'L' swap '<' case? ?exit nip
+ 'M' swap '-' case? ?exit nip
+ 'N' swap '#' case? ?exit nip
+ 'O' swap '0' case? ?exit nip
+ 'P' swap '+' case? ?exit nip
+ 'Q' swap '?' case? ?exit nip
+ 'R' swap '"' case? ?exit nip
+\ 'S' swap '!' case? ?exit nip
+ 'T' swap '*' case? ?exit nip
+ 'U' swap '(' case? ?exit nip
+ 'V' swap '|' case? ?exit nip
+ 'W' swap ',' case? ?exit nip
+ \ also 'X' for machine code
+ 'Y' swap ')' case? ?exit nip
+ 'Z' swap ';' case? ?exit nip
+;
+
+\ alter substitutes all non-letter characters by upper case letters.
+: alter ( c1 ... cn n -- d1 ... dn n )
+ dup 0= ?exit
+ swap >r 1- alter r> replace swap 1+ ;
+
+\ ------------
+\ Compiling words
+\ ------------
+
+\ ,string compiles the topmost string as a sequence of numeric DB values.
+: ,string ( c1 ... cn n -- )
+ \ ."ds" show ;
+ ?dup 0= ?exit
+ dup roll >"db" u. \ 1st char
+ 1- ,string ;
+
+\ reproduce a verbatim line
+: ,line ( x1 ...cn n -- )
+ show ;
+
+\ indent a verbatim line
+: ,>line ( c1 ... cn b -- )
+ cr tab ,line ;
+
+\ compile a reference to an invoked word
+: ,word ( c1 ... cn n -- )
+ ."dw" alter show ;
+
+\ compile a reference to an invoked word on a new line
+: ,>word ( c1 ... cn n -- )
+ >"dw" alter show ;
+
+\ compile reference to nest primitive
+: ,nest ( -- )
+ ."dw" ."nest" ;
+
+\ compile reference to unnest primitive
+: ,unnest ( -- )
+ >"dw" ."unnest" cr ;
+
+\ compile signed number
+: ,n ( n -- )
+ >"dw" . ;
+
+\ compile unsigned number
+: ,u ( u -- )
+ >"dw" u. ;
+
+\ compile literal
+: ,_lit ( c1 ... cn n -- )
+ >"dw" ."lit" ,>word ;
+
+: ,lit ( x -- )
+ >"dw" ."lit" ,n ;
+
+\ output string as comment
+: ,comment ( c1 ... cn n -- )
+ cr tab '\' emit space show ;
+
+\ create a new symbolic label
+: label ( c1 ... cn n -- )
+ cr alter show ':' emit tab ;
+
+\ body calculates the name of the body from a token
+: body ( c1 ... cn n -- c1 ... cm m )
+ 'X' swap 1+ ;
+
+\ ,codefield compiles the code field of primitive
+: ,codefield ( c1 ... cn n -- )
+ body _dup ,word label ;
+
+: ,code ( c1 ... cn n -- )
+ _dup label
+ ,codefield ;
+
+: ,end-code ( -- )
+ cr ;
+
+\ -------------------------------------------------
+\ Tail call optimization tail word ; -> [ ' word >body ] literal >r ;
+: bodylabel ( c1 ... cn n -- )
+ body label ;
+
+\ ,tail compiles a tail call
+: ,tail ( c1 ... cn n -- )
+ body ,_lit
+ '>' 'r' 2 ,>word ;
+
+\ --------------
+\ Create headers
+\ --------------
+\ preForth can optionally also create word headers with a very simple layout.
+\
+\ Word creation is split into parts
+\ - header creates a dictionary header from a string on the stack.
+\ - label creates the assembler label (with symbol substitution)
+\ - body defined later by code (assembly code) or : (threaded code)
+\
+\ Headers are linked in a single linked list ending in 0.
+\ The link-label name of the latest definition is always as a string on top of stack.
+\ Creating a new header puts this in the link field of the new definition and
+\ replaces the link-label with the current one.
+
+
+\ link to previous header c. d is new header.
+: ,link ( c1 ... cn n d1 ... dm m -- d1 ... dm _ m+1 d1 ... dm m )
+ '_' swap 1+ _dup label \ d_:
+ _swap ,word _dup
+ 1- nip ;
+
+\ create a new header with given name c and flags
+\ : header ( d1 ... dm m c1 ... c2 n flags -- d1 ... dm m c1 ... cn n )
+\ >r
+\ ,link \ link
+\ r> ,u \ flags
+\ dup ,u \ len
+\ _dup ,string \ name
+\ ;
+
+\ dummy definition to not create a new header with given name c and flags
+: header ( d1 ... dm m c1 ... c2 n flags -- d1 ... dm m c1 ... cn n )
+ drop ;
+
+: ."done" ( -- )
+ '\' emit space 'd' emit 'o' emit 'n' emit 'e' emit ;
+
+: ."last:" ( -- )
+ '\' emit space 'l' emit 'a' emit 's' emit 't' emit ':' emit space ;
+
+: ,end ( c1 ... cn n -- )
+ cr ."last:" alter show
+ cr ."done" cr ;
+
+
+
+
+\ ==== End of platform dependent part - all below should be platform independent ===
+
--- /dev/null
+\ preForth runtime system - symbolic dependent part
+
+\ --------------------------
+\ define preForth primitives
+\ --------------------------
+\ These are just pseudo assembler definitions to show the overall setup.
+\ Pseudo assember assumptions:
+\ - registers:
+\ X Y general purpose
+\ IP instruction pointer
+\ W pointer to body
+\
+\ - stacks:
+\ data stack accessible by push pop
+\ return stack accessible by rpush rpop
+
+pre
+\ This is a preForth generated file using the preForth-symbolic-backend.
+\ Only modify it if you know what you are doing.
+;
+
+code emit ( c -- )
+ pop X
+ swi 0 -- software interrupt 0 to output character in X
+ next
+;
+
+code key ( -- c )
+ swi 1 -- software interrupt 1 to input a character to X
+ push X
+ next
+;
+
+code dup ( x -- x x )
+ pop X
+ push X
+ push X
+ next
+;
+
+code swap ( x y -- y x )
+ pop X
+ pop Y
+ push X
+ push Y
+ next
+;
+
+code drop ( x -- )
+ pop X
+ next
+;
+
+code 0< ( x -- flag )
+ pop X
+ and X,X
+ js less1
+ mov X,#-1
+ jmp less2
+less1: xor X,X
+less2: push X
+ next
+;
+
+code ?exit
+ pop X
+ and X,X
+ jz qexit1
+ rpop IP
+qexit1: next
+;
+
+code >r ( x -- ) ( R -- x )
+ pop X
+ rpush X
+ next
+;
+
+code r> ( R x -- ) ( -- x )
+ rpop X
+ push X
+ next
+;
+
+code - ( x1 x2 -- x3 )
+ pop X
+ pop Y
+ sub X,Y
+ push X
+ next
+;
+
+code unnest ( -- )
+ rpop IP
+ next
+;
+
+code nest ( -- )
+ rpush IP
+ mov IP, W
+ next
+;
+
+code lit ( -- )
+ mov X,(IP)
+ push X
+ next
+;
+
+\ NEXT might look like this:
+\
+\ code next ( -- )
+\ mov W, (IP+)
+\ jmp (W+)
+\ ;
--- /dev/null
+\ preForth compiler
+\
+\ features: minimal control structures, no immediate words, strings on stack, few primitives
+\
+\ just
+\ - Stack
+\ - Returnstack
+\ - Only ?exit and recursion as control structures
+\ - :-definitions
+\ - IO via KEY/EMIT
+\ - signed single cell decimal numbers (0-9)+
+\ - character constants via 'c'-notation
+\ - output signed single cell decimal numbers
+\
+\ and
+\ - no immediate words, i.e.
+\ - no control structures IF ELSE THEN BEGIN WHILE REPEAT UNTIL
+\ - no defining words
+\ - no DOES>
+\ - no memory @ ! CMOVE ALLOT ,
+\ - no pictured numeric output
+\ - no input stream
+\ - no state
+\ - no base
+\ - no dictionary, no EXECUTE, not EVALUATE
+\ - no CATCH and THROW
+\ - no error handling
+
+\ Prerequisites:
+\ Just 13 primitives: emit key dup swap drop 0< ?exit >r r> - nest unnest lit
+
+
+\ ---------------------------------------------------
+\ Words required from backend:
+\
+\ primitives:
+\ emit key dup swap drop 0< ?exit >r r> - nest unnest lit
+\
+\ compiler words:
+\ ,line ,comment ,codefield ,end
+\ ,lit ,>word ,nest ,unnest ,tail
+\
+\ header creation:
+\ header label bodylabel
+\
+\ Words defined in runtime system
+\ ?dup 0= negate + 1+ 1- = < > case? over rot nip 2drop pick roll
+\ bl space tab cr u. .
+\ show _dup _drop _swap
+
+\ -----------
+\ parse input
+\ -----------
+\ Input has only key. Ascii End of Transmission, 4, Ctrl-D signals end of input.
+\ We scan input on a character by character basis skiping whitespace (control characters) and collecting non control characters
+\ essentially extracting tokens a word boundaries.
+
+\ This all leads to the word token that gets the next word from the input.
+\ As preForth word names can contain symbol characters and the assembler can most likely not handle symbols in labels,
+\ a simple subsitution is defined that replaces symbols to upper case letters. Because of this all preForth definitions themselves
+\ are assumed to have lower case letters only to avoid name clashes.
+
+\ skip reads and ignores control character and returns the next non-control character (or EOF when the input is exhausted).
+: skip ( -- c )
+ key dup bl > ?exit
+ dup 4 = ?exit \ eof
+ drop tail skip ;
+
+\ scan reads and appends non-control characters to the given string. Returns resulting string and the delimiting character.
+: scan ( S1 -- S2 bl )
+ key dup bl > 0= ?exit swap 1+ scan ;
+
+: (line ( S1 -- S2 )
+ key swap 1+ over 10 = ?exit tail (line ;
+
+\ line reads the rest of the current line and returns it as a string.
+: line ( -- S )
+ 0 (line ;
+
+\ token gets the next whitespace separated token from the input and returns it as topmost string on the stack.
+: token ( -- S )
+ skip 1 scan drop ;
+
+
+\ -----------------
+\ Code definitions
+\ -----------------
+\ preForth uses code definitions in the form
+\
+\ code <name> ( stack comment )
+\ assembly instruction
+\ ...
+\ assembly instruction
+\ ;
+\
+\ To define primitives.
+\ The assembly instructions are copied verbatim to the output. No processing takes place.
+\ Note, that the assembly instructions start at the line after code. All characters
+\ following <name> on the same line are ignored.
+\ As preForth has no immediate words, comments must be handled by code directly.
+\ ; has to be placed on a line of its own to be recognized.
+
+\ Code definitions and also the :-compiler and interpreter use a scheme of handlers trying to process
+\ the current line (or token) as topmost string. The first handler that can process the string, performs
+\ its action (possibly leaving items beneath the string) and turns the string into an empty string.
+\
+\ Code works on lines of source code.
+
+\ handle ;
+
+\ ?: detects a single ; character
+: ?; ( S -- 0 | S )
+ dup 0= ?exit
+ dup 1 - ?exit
+ over ';' - ?exit
+ _drop 0 ;
+
+\ detect if there is a ; as single character in a line
+: ?;< ( S -- tf | S ff )
+ dup 2 - ?exit
+ 2 pick ';' - ?exit
+ over 10 - ?exit
+ _drop 0 ;
+
+\ pre just copies the following line verbatim to output until a single ; on a line of its own is detected.
+: pre ( -- )
+ line ?;< ?dup 0= ?exit ,line tail pre ;
+
+\ code starts a code definition. Lines are replicated to output until a single ; on a line of its own is detected.
+: code ( <name> -- )
+ token
+ _dup ,comment
+ 0 header
+ ,code line _drop pre ,end-code ;
+
+\ Colon definitions - the preForth compiler
+\ -----------------------------------------
+\ preForth uses :-definitions in the form
+\
+\ : <name> ( stack comment )
+\ word 99 'x' \ comment
+\ ...
+\ word word word ;
+\
+\ To define secondary (threaded code) words. The body of the :-definition is compiled by the appropriate
+\ compiler handlers.
+\ Note, that as for code definitions, the body starts at the line after : <name> and comment. All characters
+\ following <name> on the same line are ignored.
+\
+\ In preForth : does not switch to compiler mode but contains a loop on its own, traditionally called ] .
+\ It uses the same handler scheme as code definitions and the interpreter.
+\
+\ The :-compiler works on tokens.
+
+
+\ compiler handlers
+\ =================
+
+\ handle character literals
+\ -------------------------
+
+\ ?'x' detects and compiles a character literal.
+: ?'x' ( S -- 0 | S )
+ dup 0= ?exit
+ dup 3 - ?exit
+ over ''' - ?exit
+ 3 pick ''' - ?exit
+ 2 pick >r _drop r>
+ ,lit 0 ;
+
+\ handle numbers
+\ --------------
+\ preForth can compile signed and unsigned decimal numbers.
+\ Digit sequences are detected by ?# and compiled by ?lit as a lit primtive followed by the number.
+\ Note, that the compiler could in principle just copy the number token to the output.
+\ The interpreter however needs to put the numbers on the stack, so the conversion is
+\ still necessary there.
+\ preForth has no base and processed decimal numbers only.
+
+\ digit checks whether a given character is a decimal digit.
+: ?digit ( c -- x 0 | c )
+ dup '0' < ?exit '9' over < ?exit '0' - 0 ;
+
+\ ?'-' checks if the first character of the topmost string is a '-' sign.
+: ?'-' ( S -- flag )
+ dup pick >r dup >r _drop r> 1 > r> '-' = ?exit drop 0 ;
+
+: ((?# ( S x1 -- 0 x2 ff | ci ... cn n-i x2 tf )
+ over dup 0= ?exit drop
+ >r dup pick r> swap ?digit ?dup ?exit
+ swap 10* + >r dup roll drop 1- r> tail ((?# ;
+
+: (?# ( S x1 -- tf | x ff )
+ ((?# >r >r _drop r> r> dup 0= ?exit nip ;
+
+ : ?-# ( S -- ci ... cn n-i tf | x ff )
+ _dup ?'-' 0= dup ?exit drop \ check for leading '-'
+ dup roll drop 1- \ remove leading '-'
+ 0 (?# ?dup ?exit
+ negate 0 ;
+
+: ?+-# ( S -- tf | x ff )
+ ?-# dup 0= ?exit drop \ try to convert negative
+ 0 (?# ; \ try to convert positive
+
+\ ?# detects and handles a signed or unsigned decimal number and puts its value on the stack.
+: ?# ( S -- x ff | S )
+ dup 0= ?exit
+ _dup ?+-# ?exit >r _drop r> 0 ;
+
+\ ?lit detects and handles a signed or unsigned decimal number and compiles it.
+: ?lit ( S -- ff | S )
+ dup 0= ?exit
+ _dup ?+-# ?exit >r _drop r> ,lit 0 ;
+
+\ Handle comments
+\ ---------------
+
+\ ?\ detects and handles \ comments by ignoring the rest of the current input line.
+: ?\ ( S -- 0 | S )
+ dup 1 - ?exit \ length
+ over '\' - ?exit \ sole character
+ _drop line _drop 0 ; \ skip rest of line
+
+
+\ Handle tail calls
+
+: ?tail ( S -- 0 | S )
+ dup 4 - ?exit
+ 4 pick 't' - ?exit
+ 3 pick 'a' - ?exit
+ 2 pick 'i' - ?exit
+ over 'l' - ?exit
+ _drop token ,tail 0 ;
+
+\ Handle words
+\ ------------
+
+\ ?word detects and handles words by compiling them as reference.
+: ?word ( S -- 0 | S )
+ dup 0= ?exit ,>word 0 ;
+
+\ Compiler loop
+\ -------------
+
+: ] ( -- )
+ token \ get next token
+ \ run compilers
+ ?; ?dup 0= ?exit \ ; leave compiler loop
+ ?\ \ comment
+ ?tail
+ ?'x' \ character literal
+ ?lit \ number
+ ?word \ word
+ _drop tail ] ; \ ignore unhandled token and cycle
+
+\ (: creates label for word and compiles body.
+: (: ( S -- )
+ _dup label line _drop ,nest bodylabel ] ,unnest ;
+
+\ :' is the pre: that already has the intended :-functionality. However : has to be defined as last word. See below.
+: :' ( <name> -- )
+ token
+ _dup ,comment
+ 0 header
+ (: ;
+
+\ -----------
+\ Interpreter
+\ -----------
+\ As preForth has no dictionary the interpreter must detect the words to execute on its own.
+\ The preForth interpreter handles
+\ - Code definitions
+\ - :-definitions
+\ - signed and unsigned decimal numbers.
+\ - \-comments
+
+\ interpreter handlers
+\ ---------------------
+
+\ ?: detects a single : token and executes the :-compiler.
+: ?: ( S c -- 0 | S )
+ dup 0= ?exit
+ dup 1 - ?exit
+ over ':' - ?exit
+ _drop :' 0 ;
+
+\ ?code detects the code token and executes the inline assembler.
+: ?code ( S -- 0 | S )
+ dup 4 - ?exit
+ 4 pick 'c' - ?exit
+ 3 pick 'o' - ?exit
+ 2 pick 'd' - ?exit
+ over 'e' - ?exit
+ _drop code 0 ;
+
+\ ?pre detects token starting with pre and copies lines verbatim.
+: ?pre ( S -- 0 | S )
+ dup 3 < ?exit
+ dup pick 'p' - ?exit
+ dup 1 - pick 'r' - ?exit
+ dup 2 - pick 'e' - ?exit
+ _drop pre 0 ;
+
+\ quit is the top level preForth interpreter loop. It reads tokens and handles them until
+\ an error occurs or the input is exhausted.
+: quit ( -- )
+ token \ get next token
+ \ run interpreters
+ ?: \ :-definition
+ ?code \ code definitions
+ ?pre \ pre*
+ ?\ \ comment
+ dup ?exit drop \ unhandled or EOF
+ tail quit ; \ cycle
+
+\ cold initializes the dictionary link and starts the interpreter. Acknowledge end on exit.
+: cold ( -- )
+ '0' 1 \ dictionary anchor
+ quit _drop \ eof
+ \ top of dictionary as string on stack
+ ,end ;
+
+\ : is eventually defined as preForth is now complete (assuming the primitives existed).
+\ In order to bootstrap. They have to be defined.
+: : ( <name> -- )
+ :' ;
+
--- /dev/null
+\ simpleForth i386 backend
+
+\ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels).
+: replace ( c -- c d )
+ 'A' swap ''' case? ?exit nip
+ 'B' swap '\' case? ?exit nip
+ 'C' swap ':' case? ?exit nip
+ 'D' swap '.' case? ?exit nip
+ 'E' swap '=' case? ?exit nip
+ 'F' swap '[' case? ?exit nip
+ 'G' swap '>' case? ?exit nip
+ 'H' swap ']' case? ?exit nip
+ 'I' swap '1' case? ?exit nip
+ 'J' swap '2' case? ?exit nip
+ 'K' swap '/' case? ?exit nip
+ 'L' swap '<' case? ?exit nip
+ 'M' swap '-' case? ?exit nip
+ 'N' swap '#' case? ?exit nip
+ 'O' swap '0' case? ?exit nip
+ 'P' swap '+' case? ?exit nip
+ 'Q' swap '?' case? ?exit nip
+ 'R' swap '"' case? ?exit nip
+ 'S' swap '!' case? ?exit nip
+ 'T' swap '*' case? ?exit nip
+ 'U' swap '(' case? ?exit nip
+ 'V' swap '|' case? ?exit nip
+ 'W' swap ',' case? ?exit nip
+ \ also 'X' for machine code
+ 'Y' swap ')' case? ?exit nip
+ 'Z' swap ';' case? ?exit nip
+;
+
+\ alter substitutes all non-letter characters by upper case letters.
+: alter ( S1 -- S2 )
+ '_' 1 rot ?dup 0= ?exit nip nip
+ \ dup 0= ?exit
+ swap >r 1- alter r> replace swap 1+ ;
+
+\ ------------
+\ output words
+\ ------------
+\ Output is done by emit.
+\ We define convenience words of the form ."xxx" to output xxx and >"xxx" to output xxx on a new line indented by a tab.
+
+: ."dd" ( -- )
+ 'D' emit 'D' emit space ;
+
+: >"dd" ( -- )
+ cr tab ."dd" ;
+
+: ."db" ( -- )
+ 'D' emit 'B' emit space ;
+
+: >"db" ( -- )
+ cr tab ."db" ;
+
+: ."dup" ( -- )
+ 'd' emit 'u' emit 'p' emit ;
+
+: ."nest" ( -- )
+ 'n' 'e' 's' 't' 4 alter show ;
+
+: ."unnest" ( -- )
+ 'u' 'n' 'n' 'e' 's' 't' 6 alter show ;
+
+: ."lit" ( -- )
+ 'l' 'i' 't' 3 alter show ;
+
+\ ------------
+\ Compiling words
+\ ------------
+
+: escaped ( S1 -- S2 )
+ dup 0= ?exit
+ swap >r 1- escaped r> swap 1+ over '"' - ?exit '"' swap 1+ ;
+
+\ ,string compiles the topmost string as a sequence of numeric DB values.
+: ,string ( S -- )
+ >"db" '"' emit escaped show '"' emit ;
+ \ ?dup 0= ?exit
+ \ dup roll >"db" u. \ 1st char
+ \ 1- ,string ;
+
+\ reproduce a verbatim line
+: ,line ( S -- )
+ show ;
+
+\ compile a reference to an invoked word
+: ,word ( S -- )
+ ."dd" alter show ;
+
+\ compile a reference to an invoked word on a new line
+: ,>word ( S -- )
+ >"dd" alter show ;
+
+\ compile reference to nest primitive
+: ,nest ( -- )
+ ."dd" ."nest" ;
+
+
+\ compile reference to unnest primitive
+: ,unnest ( -- )
+ >"dd" ."unnest"
+ cr ;
+
+\ reserve space
+: ,allot ( u -- )
+ >"db" u. space ."dup" '(' emit '0' emit ')' emit ;
+
+\ compile byte
+: ,byte ( u -- )
+ >"db" space u. ;
+
+\ compile signed number
+: ,n ( n -- )
+ >"dd" . ;
+
+\ compile unsigned number
+: ,u ( u -- )
+ >"dd" u. ;
+
+\ compile literal
+: ,_lit ( S -- )
+ >"dd" ."lit" ,>word ;
+
+\ compile literal
+: ,lit ( x -- )
+ >"dd" ."lit" ,n ;
+
+\ output string as comment
+: ,comment ( S -- )
+ cr tab ';' emit space show ;
+
+: ,label ( L -- )
+ cr show ':' emit tab ;
+
+\ create a new symbolic label
+: label ( S -- )
+ alter ,label ;
+
+\ body calculates the name of the body from a token
+: body ( S1 -- S2 )
+ 'X' swap 1+ ;
+
+\ ,codefield compiles the code field of primitive
+: ,codefield ( S -- )
+ body _dup ,word label ;
+
+: ,code ( S -- )
+ _dup label
+ ,codefield ;
+
+: ,end-code ( -- )
+ cr ;
+
+\ -----------------------------------
+\ tail call optimization tail word ; -> [ ' word >body ] literal >r ;
+
+: bodylabel ( S -- )
+ body label ;
+
+\ ,tail compiles a tail call
+: ,tail ( S -- )
+ body ,_lit
+ '>' 'r' 2 ,>word ;
+
+\ Handle conditionals
+
+\ initialize local labels
+: (label ( S1 -- S1 S2 0 )
+ alter '_' swap 1+ '_' swap 1+ 0 ;
+
+\ deinitialize local labels
+: label) ( S m -- )
+ drop _drop ;
+
+: +label ( L1 i -- L1 L2 i+1 )
+ >r _dup nip r> dup >r '0' + swap r> 1+ ;
+
+: ."branch" ( -- )
+ 'b' 'r' 'a' 'n' 'c' 'h' 6 alter show ;
+
+: ."?branch" ( -- )
+ '?' 'b' 'r' 'a' 'n' 'c' 'h' 7 alter show ;
+
+: ,branch ( L -- )
+ >"dd" ."branch" >"dd" show ;
+
+: ,?branch ( L -- )
+ >"dd" ."?branch" >"dd" show ;
+
+\ codefields
+
+: ."dovar" ( -- )
+ 'd' 'o' 'v' 'a' 'r' 5 alter show ;
+
+: ."doconst" ( -- )
+ 'd' 'o' 'c' 'o' 'n' 's' 't' 7 alter show ;
+
+: ,dovar ( -- )
+ ."dd" ."dovar" ;
+
+: ,doconst ( -- )
+ ."dd" ."doconst" ;
+
+
+\ prologue and epilogue
+
+: ,opening ( -- )
+;
+
+: ."done" ( -- )
+ ';' emit space 'd' emit 'o' emit 'n' emit 'e' emit ;
+
+: ."last:" ( -- )
+ ';' emit space 'l' emit 'a' emit 's' emit 't' emit ':' emit space ;
+
+: ,ending ( S -- )
+ 'l' 'a' 's' 't' 4 0 header cr tab _dup label ,dovar bodylabel _dup ."dd" alter show
+ 100000 ,allot
+ 'm' 'e' 'm' 't' 'o' 'p' 6 ,label 0 ,u
+ cr ."last:" alter show
+ cr ."done" cr ;
+
+\ --------------
+\ Create headers
+\ --------------
+\ preForth can optionally also create word headers with a very simple layout.
+\
+\ Word creation is split into parts
+\ - header creates a dictionary header from a string on the stack.
+\ - label creates the assembler label (with symbol substitution)
+\ - body defined later by code (assembly code) or : (threaded code)
+\
+\ Headers are linked in a single linked list ending in 0.
+\ The link-label name of the latest definition is always as a string on top of stack.
+\ Creating a new header puts this in the link field of the new definition and
+\ replaces the link-label with the current one.
+
+
+\ link to previous header c. d is new header.
+: ,link ( S1 S2 -- S3 S2 )
+ '_' swap 1+ _dup label \ d_:
+ _swap ,word _dup
+ 1- nip ;
+
+\ create a new header with given name S2 and flags, S1 is the last link label
+: header ( S1 S2 flags -- S3 S2 )
+ >r
+ ,link \ link
+ r> ,u \ flags
+ dup ,u \ len
+ _dup ,string \ name
+;
+
--- /dev/null
+\ simpleForth runtimesystem - i386 (32 bit) dependent part
+\ --------------------------------------------------------
+
+\ - registers:
+\ EAX, EDX general purpose
+\ ESI instruction pointer
+\ EBP return stack pointer
+\ ESP data stack pointer
+
+prelude
+;;; This is a simpleForth generated file using simpleForth-i386-backend.
+;;; Only modify it, if you know what you are doing.
+
+;
+
+\ --------------------------
+\ simpleForth primitives for i386 (32 bit)
+\ --------------------------
+
+prefix
+format ELF
+
+section '.bss' executable writable
+
+ DD 10000 dup(0)
+stck: DD 16 dup(0)
+
+ DD 10000 dup(0)
+rstck: DD 16 dup(0)
+
+
+section '.text' executable writable align 4096
+
+public main
+extrn putchar
+extrn getchar
+extrn fflush
+extrn exit
+extrn mprotect
+; extrn __error ; Mac OS
+; extrn __errno_location ; Linux
+
+macro next {
+ lodsd
+ jmp dword [eax]
+}
+
+origin:
+
+main: cld
+ mov esp, dword stck
+ mov ebp, dword rstck
+
+ ; make section writable
+ push ebp
+ mov ebp, esp
+ sub esp, 16
+ and esp, 0xfffffff0
+ mov dword [esp+8], 7 ; rwx
+ mov eax, memtop
+ sub eax, origin
+ mov dword [esp+4], eax
+ mov dword [esp], origin
+ call mprotect
+ mov esp, ebp
+ pop ebp
+ or eax, eax ; error?
+ jz main0
+ push ebp
+ mov ebp, esp
+ push eax
+ and esp, 0xfffffff0
+ ; call __error ; get error code on Mac OS
+ ; mov eax, [eax]
+ ; call __errno_location ; get error on Linux
+ ; mov eax, [eax]
+ mov [esp], eax
+ call exit
+
+main0: mov esi, main1
+ next
+
+main1: DD _cold
+ DD _bye
+
+
+_nest: lea ebp, [ebp-4]
+ mov [ebp], esi
+ lea esi, [eax+4]
+ next
+
+_dovar: lea eax,[eax+4]
+ push eax
+ next
+
+_doconst:
+ push dword [eax+4]
+ next
+
+_dodefer:
+ mov eax, [eax+4]
+ jmp dword [eax]
+
+_O = 0
+
+;
+
+code bye ( -- )
+ push ebp
+ mov ebp, esp
+ and esp, 0xfffffff0
+ mov eax, 0
+ mov [esp], eax
+ call exit
+;
+
+code emit ( c -- )
+ pop eax
+
+ push ebp
+ mov ebp, esp
+ push eax
+ and esp, 0xfffffff0
+
+ mov dword [esp], eax
+ call putchar
+
+ mov eax, 0
+ mov [esp], eax
+ call fflush ; flush all output streams
+
+ mov esp, ebp
+ pop ebp
+ next
+;
+
+code key ( -- c )
+ push ebp
+ mov ebp, esp
+ and esp, 0xfffffff0
+
+ call getchar
+ mov esp, ebp
+ pop ebp
+ cmp eax,-1
+ jnz key1
+ mov eax,4
+key1: push eax
+ next
+;
+
+code dup ( x -- x x )
+ pop eax
+ push eax
+ push eax
+ next
+;
+
+code swap ( x y -- y x )
+ pop edx
+ pop eax
+ push edx
+ push eax
+ next
+;
+
+code drop ( x -- )
+ pop eax
+ next
+;
+
+code 0< ( x -- flag )
+ pop eax
+ or eax, eax
+ mov eax, 0
+ jns zless1
+ dec eax
+zless1: push eax
+ next
+;
+
+code ?exit ( f -- )
+ pop eax
+ or eax, eax
+ jz qexit1
+ mov esi, [ebp]
+ lea ebp,[ebp+4]
+qexit1: next
+;
+
+code >r ( x -- ) ( R -- x )
+ pop ebx
+ lea ebp,[ebp-4]
+ mov [ebp], ebx
+ next
+;
+
+code r> ( R x -- ) ( -- x )
+ mov eax,[ebp]
+ lea ebp, [ebp+4]
+ push eax
+ next
+;
+
+code - ( x1 x2 -- x3 )
+ pop edx
+ pop eax
+ sub eax, edx
+ push eax
+ next
+;
+
+code unnest ( -- )
+ mov esi,[ebp]
+ lea ebp,[ebp+4]
+ next
+;
+
+code exit ( -- )
+ mov esi,[ebp]
+ lea ebp,[ebp+4]
+ next
+;
+
+
+code lit ( -- )
+ lodsd
+ push eax
+ next
+;
+
+code branch ( -- )
+ lodsd
+ mov esi,eax
+ next
+;
+
+code ?branch ( f -- )
+ pop eax
+ or eax,eax
+ jz _branchX
+ lea esi,[esi+4]
+ next
+;
+
+code @ ( addr -- x )
+ pop eax
+ mov eax,[eax]
+ push eax
+ next
+;
+
+code c@ ( c-addr -- c )
+ pop edx
+ xor eax, eax
+ mov al,byte [edx]
+ push eax
+ next
+;
+
+code ! ( x addr -- )
+ pop edx
+ pop eax
+ mov dword [edx],eax
+ next
+;
+
+code c! ( c c-addr -- )
+ pop edx
+ pop eax
+ mov byte [edx], al
+ next
+;
+
+code execute ( xt -- )
+ pop eax
+ jmp dword [eax]
+;
+
+code depth ( -- n )
+ mov eax, stck
+ sub eax, esp
+ sar eax,2
+ push eax
+ next
+;
+
+\ pre
+\ section '.data' writable executable
+\ ;
--- /dev/null
+\ preForth runtime system - machine independent part
+
+\ empty up to now
+
--- /dev/null
+\ simpleForth
+
+\ ---------------------------------------------------
+\ Words required from backend:
+\
+\ primitives:
+\ emit key dup swap drop 0< ?exit >r r> - nest unnest lit
+\ branch ?branch
+\
+\ compiler words:
+\ ,line ,comment ,codefield ,opening ,ending
+\ ,lit ,>word ,nest ,unnest ,tail
+\
+\ control structures
+\ ,branch ,?branch +label ,label (label label)
+\
+\ header creation:
+\ header label bodylabel
+\
+\ Words defined in runtime system
+\ ?dup 0= negate + 1+ 1- = < > case? over rot nip 2drop pick roll
+\ bl space tab cr u. .
+\ show _dup _drop _swap
+
+\ -----------
+\ parse input
+\ -----------
+\ Input has only key. Ascii End of Transmission, 4, Ctrl-D signals end of input.
+\ We scan input on a character by character basis skiping whitespace (control characters) and collecting non control characters
+\ essentially extracting tokens a word boundaries.
+
+\ This all leads to the word token that gets the next word from the input.
+\ As preForth word names can contain symbol characters and the assembler can most likely not handle symbols in labels,
+\ a simple subsitution is defined that replaces symbols to upper case letters. Because of this all preForth definitions themselves
+\ are assumed to have lower case letters only to avoid name clashes.
+
+\ skip reads and ignores control character and returns the next non-control character (or EOF when the input is exhausted).
+: skip ( -- c )
+ key dup bl > ?exit
+ dup 4 = ?exit \ eof
+ drop tail skip ;
+
+\ scan reads and appends non-control characters to the given string. Returns resulting string and the delimiting character.
+: scan ( S1 -- S2 bl )
+ key dup bl > 0= ?exit swap 1+ scan ;
+
+: (line ( S1 -- S2 )
+ key swap 1+ over 10 = ?exit tail (line ;
+
+\ line reads the rest of the current line and returns it as a string.
+: line ( -- S )
+ 0 (line ;
+
+\ token gets the next whitespace separated token from the input and returns it as topmost string on the stack.
+: token ( -- S )
+ skip 1 scan drop ;
+
+
+\ -----------------
+\ Code definitions
+\ -----------------
+\ preForth uses code definitions in the form
+\
+\ code <name> ( stack comment )
+\ assembly instruction
+\ ...
+\ assembly instruction
+\ ;
+\
+\ To define primitives.
+\ The assembly instructions are copied verbatim to the output. No processing takes place.
+\ Note, that the assembly instructions start at the line after code. All characters
+\ following <name> on the same line are ignored.
+\ As preForth has no immediate words, comments must be handled by code directly.
+\ ; has to be placed on a line of its own to be recognized.
+
+\ Code definitions and also the :-compiler and interpreter use a scheme of handlers trying to process
+\ the current line (or token) as topmost string. The first handler that can process the string, performs
+\ its action (possibly leaving items beneath the string) and turns the string into an empty string.
+\
+\ Code works on lines of source code.
+
+\ handle ;
+
+\ ?: detects a single ; character
+: ?; ( S -- 0 | S )
+ dup 0= ?exit
+ dup 1 - ?exit
+ over ';' - ?exit
+ _drop 0 ;
+
+\ detect if there is a ; as single character in a line
+: ?;< ( S -- tf | S ff )
+ dup 2 - ?exit
+ 2 pick ';' - ?exit
+ over 10 - ?exit
+ _drop 0 ;
+
+\ pre just copies the following line verbatim to output until a single ; on a line of its own is detected.
+: pre ( -- )
+ line ?;< ?dup 0= ?exit ,line tail pre ;
+
+\ code starts a code definition. Lines are replicated to output until a single ; on a line of its own is detected.
+: code ( <name> -- )
+ token
+ _dup ,comment
+ 0 header
+ ,code line _drop pre ,end-code ;
+
+\ Colon definitions - the preForth compiler
+\ -----------------------------------------
+\ preForth uses :-definitions in the form
+\
+\ : <name> ( stack comment )
+\ word 99 'x' \ comment
+\ ...
+\ word word word ;
+\
+\ To define secondary (threaded code) words. The body of the :-definition is compiled by the appropriate
+\ compiler handlers.
+\ Note, that as for code definitions, the body starts at the line after : <name> and comment. All characters
+\ following <name> on the same line are ignored.
+\
+\ In preForth : does not switch to compiler mode but contains a loop on its own, traditionally called ] .
+\ It uses the same handler scheme as code definitions and the interpreter.
+\
+\ The :-compiler works on tokens.
+
+
+\ compiler handlers
+\ =================
+
+\ handle character literals
+\ -------------------------
+
+\ ?'x' detects and pushes it on the stack
+: ?'x' ( S -- x 0 | S )
+ dup 0= ?exit
+ dup 3 - ?exit
+ over ''' - ?exit
+ 3 pick ''' - ?exit
+ 2 pick >r _drop r>
+ 0 ;
+
+\ ?'x'lit detects and compiles a character literal.
+: ?'x'lit ( S -- 0 | S )
+ dup 0= ?exit
+ dup 3 - ?exit
+ over ''' - ?exit
+ 3 pick ''' - ?exit
+ 2 pick >r _drop r>
+ ,lit 0 ;
+
+\ handle numbers
+\ --------------
+\ preForth can compile signed and unsigned decimal numbers.
+\ Digit sequences are detected by ?# and compiled by ?lit as a lit primtive followed by the number.
+\ Note, that the compiler could in principle just copy the number token to the output.
+\ The interpreter however needs to put the numbers on the stack, so the conversion is
+\ still necessary there.
+\ preForth has no base and processed decimal numbers only.
+
+\ digit checks whether a given character is a decimal digit.
+: ?digit ( c -- x 0 | c )
+ dup '0' < ?exit '9' over < ?exit '0' - 0 ;
+
+\ ?'-' checks if the first character of the topmost string is a '-' sign.
+: ?'-' ( S -- flag )
+ dup pick >r dup >r _drop r> 1 > r> '-' = ?exit drop 0 ;
+
+: ((?# ( S x1 -- 0 x2 ff | S2 x2 tf )
+ over dup 0= ?exit drop
+ >r dup pick r> swap ?digit ?dup ?exit
+ swap 10* + >r dup roll drop 1- r> tail ((?# ;
+
+: (?# ( S x1 -- tf | x ff )
+ ((?# >r >r _drop r> r> dup 0= ?exit nip ;
+
+ : ?-# ( S -- ci ... cn n-i tf | x ff )
+ _dup ?'-' 0= dup ?exit drop \ check for leading '-'
+ dup roll drop 1- \ remove leading '-'
+ 0 (?# ?dup ?exit
+ negate 0 ;
+
+: ?+-# ( S -- tf | x ff )
+ ?-# dup 0= ?exit drop \ try to convert negative
+ 0 (?# ; \ try to convert positive
+
+\ ?# detects and handles a signed or unsigned decimal number and puts its value on the stack.
+: ?# ( S -- x ff | S )
+ dup 0= ?exit
+ _dup ?+-# ?exit >r _drop r> 0 ;
+
+\ ?lit detects and handles a signed or unsigned decimal number and compiles it.
+: ?lit ( S -- ff | S )
+ dup 0= ?exit
+ _dup ?+-# ?exit >r _drop r> ,lit 0 ;
+
+\ Handle comments
+\ ---------------
+
+\ ?\ detects and handles \ comments by ignoring the rest of the current input line.
+: ?\ ( S -- 0 | S )
+ dup 1 - ?exit \ length
+ over '\' - ?exit \ sole character
+ _drop line _drop 0 ; \ skip rest of line
+
+
+\ Handle tail calls
+
+: ?tail ( S -- 0 | S )
+ dup 0= ?exit
+ dup 4 - ?exit
+ 4 pick 't' - ?exit
+ 3 pick 'a' - ?exit
+ 2 pick 'i' - ?exit
+ over 'l' - ?exit
+ _drop token ,tail 0 ;
+
+
+\ Handle control structures
+
+: ?if ( L1 n1 S -- L1 L2 n2 0 | L1 n1 S )
+ dup 0= ?exit
+ dup 2 - ?exit
+ 2 pick 'I' - ?exit
+ over 'F' - ?exit
+ _drop
+ +label >r _dup ,?branch r> 0 ;
+
+: ?else ( L1 L2 n1 S -- L1 L3 L2 n2 0 | L1 L2 n1 S )
+ dup 0= ?exit
+ dup 4 - ?exit
+ 4 pick 'E' - ?exit
+ 3 pick 'L' - ?exit
+ 2 pick 'S' - ?exit
+ over 'E' - ?exit
+ _drop
+ +label >r _dup ,branch _swap ,label r> 0 ;
+
+: ?then ( L1 L2 n1 S -- L1 n2 0 | L1 L2 n1 S )
+ dup 0= ?exit
+ dup 4 - ?exit
+ 4 pick 'T' - ?exit
+ 3 pick 'H' - ?exit
+ 2 pick 'E' - ?exit
+ over 'N' - ?exit
+ _drop
+ >r ,label r> 0 ;
+
+: ?begin ( L1 n1 S -- L1 L2 n2 0 | L1 n1 S )
+ dup 0= ?exit
+ dup 5 - ?exit
+ 5 pick 'B' - ?exit
+ 4 pick 'E' - ?exit
+ 3 pick 'G' - ?exit
+ 2 pick 'I' - ?exit
+ over 'N' - ?exit
+ _drop
+ +label >r _dup ,label r> 0 ;
+
+: ?while ( S -- 0 | S )
+ dup 0= ?exit
+ dup 5 - ?exit
+ 5 pick 'W' - ?exit
+ 4 pick 'H' - ?exit
+ 3 pick 'I' - ?exit
+ 2 pick 'L' - ?exit
+ over 'E' - ?exit
+ _drop
+ +label >r _dup ,?branch _swap r> 0 ;
+
+: ?repeat ( S -- 0 | S )
+ dup 0= ?exit
+ dup 6 - ?exit
+ 6 pick 'R' - ?exit
+ 5 pick 'E' - ?exit
+ 4 pick 'P' - ?exit
+ 3 pick 'E' - ?exit
+ 2 pick 'A' - ?exit
+ over 'T' - ?exit
+ _drop
+ >r ,branch ,label r> 0 ;
+
+: ?until ( S -- 0 | S )
+ dup 0= ?exit
+ dup 5 - ?exit
+ 5 pick 'U' - ?exit
+ 4 pick 'N' - ?exit
+ 3 pick 'T' - ?exit
+ 2 pick 'I' - ?exit
+ over 'L' - ?exit
+ _drop
+ >r ,?branch r> 0 ;
+
+\ ?'x' detects and pushes it on the stack
+: ?['] ( S -- x 0 | S )
+ dup 0= ?exit
+ dup 3 - ?exit
+ 3 pick '[' - ?exit
+ 2 pick ''' - ?exit
+ over ']' - ?exit
+ _drop
+ token ,_lit
+ 0 ;
+
+
+
+\ Handle words
+\ ------------
+
+\ ?word detects and handles words by compiling them as reference.
+: ?word ( S -- 0 | S )
+ dup 0= ?exit ,>word 0 ;
+
+\ Compiler loop
+\ -------------
+
+: ] ( -- )
+ token \ get next token
+ \ _dup cr tab ';' emit space show
+ \ run compilers
+ ?; ?dup 0= ?exit \ ; leave compiler loop
+ ?\ \ comment
+ ?tail
+ ?if
+ ?else
+ ?then
+ ?begin
+ ?while
+ ?repeat
+ ?until
+ ?[']
+ ?'x'lit \ character literal
+ ?lit \ number
+ ?word \ word
+ _drop tail ] ; \ ignore unhandled token and cycle
+
+\ (: creates label for word and compiles body.
+: (: ( S -- )
+ _dup label line _drop ,nest _dup bodylabel (label ] label) ,unnest ;
+
+: |: ( <name> -- )
+ token (: ;
+
+: immediate: ( <name> -- )
+ \ cr ';' emit 'i' emit
+ token _dup ,comment 1 header (: ;
+
+
+\ :' is the pre: that already has the intended :-functionality. However : has to be defined as last word. See below.
+: :' ( <name> -- )
+ token
+ _dup ,comment
+ 0 header
+ (: ;
+
+: , ( x -- )
+ ,u ;
+
+: c, ( x -- )
+ ,byte ;
+
+: allot ( u -- )
+ ,allot ;
+
+: create ( <name> -- )
+ token _dup ,comment
+ 0 header _dup label line _drop ,dovar bodylabel ;
+
+: variable ( <name> -- )
+ create 0 ,u ;
+
+: constant ( <name> L x -- )
+ >r
+ token _dup ,comment
+ 0 header _dup label line _drop ,doconst bodylabel r> ,u ;
+
+
+\ -----------
+\ Interpreter
+\ -----------
+\ As preForth has no dictionary the interpreter must detect the words to execute on its own.
+\ The preForth interpreter handles
+\ - Code definitions
+\ - :-definitions
+\ - signed and unsigned decimal numbers.
+\ - \-comments
+
+\ interpreter handlers
+\ ---------------------
+
+\ ?|: handle headerless :-definitions
+: ?|: ( S -- 0 | S )
+ dup 0= ?exit
+ dup 2 - ?exit
+ 2 pick '|' - ?exit
+ over ':' - ?exit
+ _drop
+ |: 0 ;
+
+: ?immediate: ( S -- 0 | S )
+ dup 0= ?exit
+ dup 10 - ?exit
+ 10 pick 'i' - ?exit
+ 9 pick 'm' - ?exit
+ 8 pick 'm' - ?exit
+ 7 pick 'e' - ?exit
+ 6 pick 'd' - ?exit
+ 5 pick 'i' - ?exit
+ 4 pick 'a' - ?exit
+ 3 pick 't' - ?exit
+ 2 pick 'e' - ?exit
+ over ':' - ?exit
+ _drop
+ immediate: 0 ;
+
+\ ?: detects a single : token and executes the :-compiler.
+: ?: ( S -- 0 | S )
+ dup 0= ?exit
+ dup 1 - ?exit
+ over ':' - ?exit
+ _drop :' 0 ;
+
+
+: ?, ( S -- 0 | S )
+ dup 0= ?exit
+ dup 1 - ?exit
+ over ',' - ?exit
+ _drop , 0 ;
+
+: ?c, ( S -- 0 | S )
+ dup 0= ?exit
+ dup 2 - ?exit
+ 2 pick 'c' - ?exit
+ over ',' - ?exit
+ _drop c, 0 ;
+
+\ ?allot detects the variablecreate token and creates a word w/o parameter field
+: ?allot ( S -- 0 | S )
+ dup 0= ?exit
+ dup 5 - ?exit
+ 5 pick 'a' - ?exit
+ 4 pick 'l' - ?exit
+ 3 pick 'l' - ?exit
+ 2 pick 'o' - ?exit
+ over 't' - ?exit
+ _drop
+ allot 0 ;
+
+\ ?create detects the variablecreate token and creates a word w/o parameter field
+: ?create ( S -- 0 | S )
+ dup 0= ?exit
+ dup 6 - ?exit
+ 6 pick 'c' - ?exit
+ 5 pick 'r' - ?exit
+ 4 pick 'e' - ?exit
+ 3 pick 'a' - ?exit
+ 2 pick 't' - ?exit
+ over 'e' - ?exit
+ _drop
+ create 0 ;
+
+\ ?variable detects the variable token and creates a variable
+: ?variable ( S -- 0 | S )
+ dup 0= ?exit
+ dup 8 - ?exit
+ 8 pick 'v' - ?exit
+ 7 pick 'a' - ?exit
+ 6 pick 'r' - ?exit
+ 5 pick 'i' - ?exit
+ 4 pick 'a' - ?exit
+ 3 pick 'b' - ?exit
+ 2 pick 'l' - ?exit
+ over 'e' - ?exit
+ _drop
+ variable 0 ;
+
+\ ?constant detects the constant token and creates a constant
+: ?constant ( i*x <name> -- )
+ dup 0= ?exit
+ dup 8 - ?exit
+ 8 pick 'c' - ?exit
+ 7 pick 'o' - ?exit
+ 6 pick 'n' - ?exit
+ 5 pick 's' - ?exit
+ 4 pick 't' - ?exit
+ 3 pick 'a' - ?exit
+ 2 pick 'n' - ?exit
+ over 't' - ?exit
+ _drop
+ constant 0 ;
+
+
+\ ?code detects the code token and executes the inline assembler.
+: ?code ( S -- 0 | S )
+ dup 4 - ?exit
+ 4 pick 'c' - ?exit
+ 3 pick 'o' - ?exit
+ 2 pick 'd' - ?exit
+ over 'e' - ?exit
+ _drop code 0 ;
+
+\ ?pre detects token starting with pre and copies lines verbatim.
+: ?pre ( S -- 0 | S )
+ dup 3 < ?exit
+ dup pick 'p' - ?exit
+ dup 1 - pick 'r' - ?exit
+ dup 2 - pick 'e' - ?exit
+ _drop pre 0 ;
+
+\ quit is the top level preForth interpreter loop. It reads tokens and handles them until
+\ an error occurs or the input is exhausted.
+: quit ( -- )
+ token \ get next token
+ \ cr ';' emit space _dup show cr
+ \ run interpreters
+ ?: \ :-definition
+ ?|: \ headerless definitions
+ ?immediate: \ immediate definitions
+ ?code \ code definitions
+ ?pre \ pre*
+ ?create \ create definitions
+ ?variable \ variable definition
+ ?constant \ constant definition
+ ?, \ comma
+ ?c, \ byte comma
+ ?allot \ allot
+ ?# \ signed decimal number
+ ?'x' \ character literal
+ ?\ \ comment
+ dup ?exit drop \ unhandled or EOF
+ tail quit ; \ cycle
+
+\ cold initializes the dictionary link and starts the interpreter. Acknowledge end on exit.
+: cold ( -- )
+ ,opening
+ '0' 1 \ dictionary anchor
+ quit _drop \ eof
+ \ top of dictionary as string on stack
+ ,ending ;
+
+\ : is eventually defined as preForth is now complete (assuming the primitives existed).
+\ In order to bootstrap. They have to be defined.
+: : ( <name> -- )
+ :' ;
+
public / preForth.git / commitdiff