# ------------------------------------------------------------------------
.PHONY=all
-all: preForth simpleForth forth runforth
+all: preForth runseedforthdemo
-.PHONY=runforth
-runforth: ./forth hi.forth
- cat hi.forth - | ./forth
-
-.PHONY=runseedforth
-runseedforth: seedForth seedForthDemo.seed
+.PHONY=runseedforthdemo
+runseedforthdemo: seedForth seedForthDemo.seed
cat seedForthDemo.seed | ./seedForth
-
-.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
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
+ $@_m.o /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib/crt1.o /usr/lib/libc.dylib
# rm $@.o $@_m.o
# run preForth on its own source code to perform a bootstrap
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 >$@
-
# ------------------------------------------------------------------------
# seedForth
# ------------------------------------------------------------------------
.PHONY=clean
clean:
- rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo simpleForthDemo simpleForth preForth forth seedForth seedForthDemo.seed
+ rm -f *.asm *.o *.fas *.s *.c *.Darwin *.Linux preForthdemo preForth forth seedForth seedForthDemo.seed
+++ /dev/null
-\ Klaus Schleisiek's dynamic memory allocation (FORML'88) seedForth-version uh 2018-06-20
-
-program dynamic.seed
-
-\ extend seedForth core with words required by dynamic memory
-\ -------------------------------------
-
-': _variable ( -- ) create 0 #, , does> ;' \ a seedForth defining word
-: Variable ( <name> -- ) fun: _variable ; \ macro
-
-': doconst ( -- ) does> @ ;' \ a does> w/o create path sets behaviour
-: Constant ( <name> x -- ) fun: create , doconst ; \ macro
-
-': over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ;'
-
-': 2dup ( x1 x2 -- x1 x2 x1 x2 ) over over ;'
-': 2drop ( x1 x2 -- ) drop drop ;'
-
-
-': < ( u1 u2 -- f ) - 0< ;'
-': > ( u1 u2 -- f ) swap < ;'
-': u< < ;'
-': = ( x1 x2 -- f ) - 0= ;'
-': max ( x1 x2 -- x3 ) 2dup < IF swap THEN drop ;'
-': rot ( x1 x2 x3 -- x2 x3 x1 ) >r swap r> swap ;'
-
-': move ( c-addr1 c-addr2 u -- )
- BEGIN dup WHILE >r over c@ over c! 1 #, + swap 1 #, + swap r> 1 #, - REPEAT drop 2drop ;'
-
-: r@ ( -- x ) r> dup >r ;
-
-': cell+ ( addr1 -- addr2 ) 1 #, cells + ;'
-
-': 2* ( x1 -- x2 ) dup + ;'
-': 256* ( x1 -- x2 ) 2* 2* 2* 2* 2* 2* 2* 2* ;'
-
-
-\ dynamic memory
-\ -------------------------------------
-
-Variable anchor
-
-50 # Constant waste
-
-128 # 256* 256* 256* ( 32bit ) Constant #free \ sign bit
-#free 1 # - ( 31bit ) Constant #max
-
-
-': size ( mem -- size ) 1 #, cells - @ #max and ;'
-
-': addr&size ( mem -- mem size ) dup size ;'
-
-': above ( mem -- >mem ) addr&size + 2 #, cells + ;'
-
-': use ( mem size -- )
- dup >r swap 2dup 1 #, cells - ! r> #max and + ! ;'
-
-': release ( mem size -- ) #free or use ;'
-
-': fits? ( size -- mem | false ) >r anchor @
- BEGIN addr&size r@ u< 0=
- IF r> drop unnest THEN
- @ dup anchor @ =
- UNTIL 0= r> drop ;'
-
-': link ( mem >mem <mem -- )
- >r 2dup cell+ ! over ! r> 2dup ! swap cell+ ! ;'
-
-': @links ( mem -- <mem mem> ) dup @ swap cell+ @ ;'
-
-': setanchor ( mem -- mem )
- dup anchor @ = IF dup @ anchor ! THEN ;'
-
-': unlink ( mem -- ) setanchor @links 2dup ! swap cell+ ! ;'
-
-
-': allocate ( size -- mem ior )
- 3 #, cells max dup >r fits? ?dup 0= IF r> -8 #, unnest THEN ( "dictionary overflow" )
- addr&size r@ - dup waste u<
- IF drop dup @ over unlink over addr&size use
- ELSE 2 #, cells - over r@ use
- over above dup rot release
- 2dup swap @links link THEN
- r> drop anchor ! 0 #, ;'
-
-': free ( mem -- ior )
- addr&size over 2 #, cells - @ dup 0<
- IF #max and 2 #, cells + rot over - rot rot +
- ELSE drop over anchor @ dup cell+ @ link THEN
- 2dup + cell+ dup @ dup 0<
- IF #max and swap cell+ unlink + 2 #, cells + release 0 #, unnest THEN
- 2drop release 0 #, ;'
-
-': resize ( mem newsize -- mem' ior )
- over swap over size 2dup >
- IF ( mem mem size newsize ) swap allocate ?dup IF >r drop 2drop r> unnest THEN
- dup >r swap move free r> swap unnest THEN
- 2drop drop ;'
-
-': empty-memory ( addr size -- )
- >r cell+ dup anchor ! dup 2 #, cells use dup 2dup link
- dup above swap over dup link
- dup r> 7 #, cells - release above 1 #, cells - 0 #, swap ! ;'
-
-\ : ?memory ( -- ) anchor @
-\ cr ." ->: " BEGIN cr dup u. ." : " addr&size u. @ dup anchor @ = UNTIL
-\ cr ." <-: " BEGIN cr dup u. ." : " addr&size u. cell+ @ dup anchor @ = UNTIL
-\ drop ;
-
-': init ( -- )
- here 1000 #, ( chars ) dup allot empty-memory ;'
-
-': alloc ( u -- addr )
- allocate throw ;'
-
-': dispose ( addr -- )
- free throw ;'
-
-
-\ Utility words for debugging
-\ ----------------------------
-\ hex number output
-
-': 1- 1 #, - ;'
-': 1+ 1 #, + ;'
-': nip swap drop ;'
-
-': .hexdigit ( n -- ) dup 9 #, > IF lit [ 'A' # 10 # - , ] ELSE '0' #, THEN + emit ;'
-
-\ ': 2* ( x1 -- x2 ) dup + ;'
-
-': space 32 #, emit ;'
-
-': cr 10 #, emit 13 #, emit ;'
-
-
-\ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
-': u2/ ( x1 -- x2 )
- 0 #, 8 #, CELLS 1- BEGIN ?dup WHILE >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- REPEAT nip ;'
-
-': odd? ( x1 -- f ) dup u2/ 2* = 0= ;'
-
-': 2/mod ( x1 -- x2 r ) \ swapped results
- dup u2/ swap odd? negate ;'
-
-': 16/mod ( x -- x r ) \ swapped results
- 2/mod >r 2/mod >r 2/mod >r 2/mod 2* r> + 2* r> + 2* r> + ;'
-
-': #### ( x -- )
- 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r
- .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit
- r> .hexdigit r> .hexdigit r> .hexdigit space ;'
-
-': (.) ( x -- )
- ?dup IF 16/mod >r (.) r> .hexdigit THEN ;'
-
-': u. ( x -- )
- ?dup IF (.) ELSE '0' #, emit THEN space ;'
-
-': . ( n -- ) dup 0< IF '-' #, emit negate THEN u. ;'
-
-
-\ Dynamic Memory smoke test
-\ -------------------------------------
-
-#max u. \ 7FFFFFFF
-#free u. \ 80000000
-
-cr here . \ base address
-
-init
-
-cr here . \ end address roughly 1000 abover
-
-cr 100 # allocate . dup . free . \ ior 0, allocate at address1, ior 0
-cr 100 # allocate . dup . \ ior 0, allocated at same address1
-cr 100 # allocate . dup . free . \ ior 0, allocated at new address2 roughly 100 above, ior 0
-cr 100 # allocate . dup . \ ior 0, allocated at again at address2
-cr free . \ free address2 -> ior 0
-cr free . \ free address1 -> ior 0
-cr 100 # allocate . dup . free . \ ior 0, allocated at address1, ior 0
-
-end
+++ /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 - ;
-
-: 2@ ( addr -- x1 x2 )
- dup cell+ @ swap @ ;
-
-: 2! ( x1 x2 addr -- )
- swap over ! cell+ ! ;
-
-\ 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 ;
-
-: u. ( u -- )
- (u. space ;
-
-|: (. ( 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 x1 x2 )
- over over ;
-
-: 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
- >r rot rot r> rot rot ;
-
-: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
- >r >r 2dup r> r> 2swap ;
-
-: 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 . ;
-
-\ 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 ;
-
-: ' ( <name> -- xt )
- parse-name last @ find-name dup 0= ?exit l>interp ;
-
-immediate: ['] ( <name> -- )
- ' dup 0= IF '?' emit tail restart exit THEN ['] lit , , ;
-
-
-: 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 @ + ;
-
-: >body ( xt -- body )
- cell+ ;
-
-: .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 ;
-
-: max ( 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 2dup swap - 1+ min >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 ;
-
-: empty-stack ( i*x -- )
- BEGIN depth 0< WHILE 0 REPEAT
- BEGIN depth WHILE drop REPEAT ;
-
-: +! ( n addr -- )
- dup >r @ + r> ! ;
-
-variable dp
-
-: here ( -- addr )
- dp @ ;
-
-: allot ( n -- )
- dp +! ;
-
-: c, ( c -- )
- here 1 allot c! ;
-
-: , ( 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 ;
-
-: place ( c-addr1 u c-addr2 -- )
- 2dup >r >r 1+ swap cmove r> r> c! ;
-
-: header ( c-addr u -- )
- here last @ , last !
- 0 , \ flags
- dup , \ len
- here swap dup allot
- cmove ;
-
-: create ( <name> -- )
- parse-name header ['] dp @ , ;
-
-: 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 ( -- )
- [ empty-stack restart ;
-
-create banner ( -- addr )
- 5 c, 'F' c, 'o' c, 'r' c, 't' c, 'h' c,
-
-1 constant major ( -- x )
-3 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
-;
-
-: spaces ( n -- )
- BEGIN ?dup WHILE space 1- REPEAT ;
-
-code * ( n1 n2 -- n3 )
- pop eax
- pop edx
- mul edx
- push eax
- next
-;
-
-: fac ( n -- n! )
- cr dup spaces dup .
- dup 1 = ?exit dup >r dup 1- fac *
- cr r> spaces dup . ;
-
-: ", ( c-addr len -- )
- dup c, BEGIN dup WHILE >r count c, r> 1- REPEAT 2drop ;
-
-|: (." ( -- )
- r> count 2dup + >r type ;
-
-immediate: ." ( -- )
- ['] (." ,
- '"' parse ", ;
-
-immediate: 0=exit ( -- )
- ['] 0= compile, ['] ?exit compile, ;
-
-immediate: FOR ( n -- )
- ['] BEGIN execute
- ['] >r compile, ;
-
-immediate: NEXT ( -- )
- ['] r> compile,
- ['] 1- compile,
- ['] dup compile,
- ['] 0< compile,
- ['] UNTIL execute
- ['] drop compile, ;
-
-
-\ immediate: r@ ( -- )
-\ ['] r> compile,
-\ ['] dup compile,
-\ ['] >r compile, ;
-
-: r@ ( -- x )
- r> r> dup >r swap >r ;
-
-|: "lit ( -- c-addr len )
- r> count 2dup + >r ;
-
-immediate: s" ( -- )
- ['] "lit compile, '"' parse ", ;
-
-: ," ( ccc" -- )
- '"' parse here over 1+ allot place ;
-
-code / ( n1 n2 -- n3 )
- pop ecx
- pop eax
- xor edx,edx
- and eax,eax
- jns div1
- dec edx
-div1: idiv ecx
- push eax
- next
-;
-
-code 2/ ( n1 -- n2 )
- pop eax
- sar eax,1
- push eax
- next
-;
-
-
-\ Some arithmetic
-
-: sqrt ( x² -- x )
- 1 BEGIN 2dup / over - 2 /
- dup
- WHILE
- +
- REPEAT drop nip ;
-
-: sqr ( x -- x² )
- dup * ;
-
-: pyt ( a b -- c )
- sqr swap sqr + sqrt ;
-
-
-\ Dump utility
-
-|: .hexdigit ( x -- )
- dup 10 < IF '0' + ELSE 10 - 'A' + THEN emit ;
-
-|: .hex ( x -- )
- dup 240 and 2/ 2/ 2/ 2/ .hexdigit 15 and .hexdigit ;
-
-|: .addr ( x -- )
- ?dup 0= ?exit dup 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ .addr .hex ;
-
-|: b/line ( -- x )
- 16 ;
-
-|: .h ( addr len -- )
- b/line min dup >r
- BEGIN \ ( addr len )
- dup
- WHILE \ ( addr len )
- over c@ .hex space 1 /string
- REPEAT 2drop
- b/line r> - 3 * spaces ;
-
-|: .a ( addr1 len1 -- )
- b/line min
- BEGIN \ ( addr len )
- dup
- WHILE
- over c@ dup 32 < IF drop '.' THEN emit
- 1 /string
- REPEAT 2drop ;
-
-: d ( addr len1 -- addr len2 )
- over .addr ':' emit space 2dup .h space space 2dup .a dup b/line min /string
-;
-
-
-: dump ( addr len -- )
- BEGIN
- dup
- WHILE \ ( addr len )
- cr d
- REPEAT 2drop ;
-
-: :smile: ( -- )
- 226 emit 152 emit 186 emit ;
-
-\ Tester
-
-\ : t{ ;
-\ : --> ;
-\ : t} ;
-
-variable actual-depth
-( actual-results )
- 80 allot \ 20 cells allot
-
-: nth-result ( n -- addr )
- cells actual-depth + ;
-
-: error ( i*x c-addr u -- )
- cr source type space type empty-stack ;
-
-: t{ ( i*x -- )
- empty-stack ;
-
-: -> ( -- )
- depth actual-depth !
- BEGIN depth WHILE depth nth-result ! REPEAT ;
-
-create wrong ( -- addr )
- 23 c,
- 'w' c, 'r' c, 'o' c, 'n' c, 'g' c, 32 c,
- 'n' c, 'u' c, 'm' c, 'b' c, 'e' c, 'r' c, 32 c,
- 'o' c, 'f' c, 32 c,
- 'r' c, 'e' c, 's' c, 'u' c, 'l' c, 't' c, 's' c,
-
-create incorrect ( -- addr )
- 16 c,
- 'i' c, 'n' c, 'c' c, 'o' c, 'r' c, 'r' c, 'e' c, 'c' c, 't' c, 32 c,
- 'r' c, 'e' c, 's' c, 'u' c, 'l' c, 't' c,
-
-
-: }t ( i*x -- )
- depth actual-depth @ - IF wrong count error exit THEN
- BEGIN depth WHILE depth nth-result @ - IF incorrect count error exit THEN REPEAT ;
-
-
-
+++ /dev/null
-cr .( hi - doing some test )
-t{ 3 4 + -> 7 }t
-t{ 3 -> }t
-t{ 3 4 + -> 8 }t
-cr .( ready )
+++ /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 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 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
-\ simpleForth i386 backend
-
-\ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels).
-: replace ( c1 -- c2 c3 2 | c2 1 )
- >r
- 'A' 1 r> ''' case? ?exit >r 2drop
- 'B' 1 r> '\' case? ?exit >r 2drop
- 'C' 1 r> ':' case? ?exit >r 2drop
- 'D' 1 r> '.' case? ?exit >r 2drop
- 'E' 1 r> '=' case? ?exit >r 2drop
- 'F' 1 r> '[' case? ?exit >r 2drop
- 'G' 1 r> '>' case? ?exit >r 2drop
- 'H' 1 r> ']' case? ?exit >r 2drop
- 'I' 1 r> '1' case? ?exit >r 2drop
- 'J' 1 r> '2' case? ?exit >r 2drop
- 'K' 1 r> '/' case? ?exit >r 2drop
- 'L' 1 r> '<' case? ?exit >r 2drop
- 'M' 1 r> '-' case? ?exit >r 2drop
- 'N' 1 r> '#' case? ?exit >r 2drop
- 'O' 1 r> '0' case? ?exit >r 2drop
- 'P' 1 r> '+' case? ?exit >r 2drop
- 'Q' 1 r> '?' case? ?exit >r 2drop
- 'R' 1 r> '"' case? ?exit >r 2drop
- 'S' 1 r> '!' case? ?exit >r 2drop
- 'T' 1 r> '*' case? ?exit >r 2drop
- 'U' 1 r> '(' case? ?exit >r 2drop
- 'V' 1 r> '|' case? ?exit >r 2drop
- 'W' 1 r> ',' case? ?exit >r 2drop
- \ also 'X' for machine code
- 'Y' 1 r> ')' case? ?exit >r 2drop
- 'Z' 1 r> ';' case? ?exit >r 2drop
- 'U' 'T' 2 r> '{' case? ?exit >r drop 2drop
- 'T' 'Y' 2 r> '}' case? ?exit >r drop 2drop
- r> 1
-;
-
-\ 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> swap >r replace r> + ;
-
-\ ------------
-\ 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> -- )
- :' ;
-
+++ /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 ;
-
-: nip ( x1 x2 -- x2 )
- swap drop ;
-
-: 1- ( n1 -- n2 )
- 1 - ;
-
-: > ( n1 n2 -- flag )
- swap < ;
-
-: negate ( n1 -- n2 )
- 0 swap - ;
-
-: 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 ! ;
-
-: countdown ( n -- )
- BEGIN ?dup WHILE 1 - cr dup '0' + emit REPEAT ;
-
-: dashes ( n -- )
- BEGIN ?dup WHILE '-' emit 1 - REPEAT ;
-
-: ."yes" ( -- )
- 'y' emit 'e' emit 's' emit ;
-
-: ."no" ( -- )
- 'n' emit 'o' emit ;
-
-: yes? ( f -- )
- IF ."yes" ELSE ."no" THEN ;
-
-: ."Hello,_world!" ( -- )
- 'H' emit 'e' emit 'l' emit 'l' emit 'o' emit ',' emit space
- 'w' emit 'o' emit 'r' emit 'l' emit 'd' emit '!' emit ;
-
-create squares ( -- addr )
- 0 , 1 , 4 , 9 , 16 , 25 , 36 , 49 , 64 , 81 , 100 ,
-
-create text ( -- addr )
- 2 c, 'a' c, 'b' c, 10 allot
-
-variable v1
-
-: v1? ( -- )
- v1 @ IF ."yes" ELSE ."no" THEN ;
-
-: 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 ;
-
-: ======= ( -- )
- cr 10 dashes ;
-
-: cold ( -- )
- =======
- cr ."Hello,_world!"
- 10 countdown
- =======
- cr 1 yes?
- cr 0 yes?
- =======
- cr v1?
- v1 on cr v1?
- v1 off cr v1?
- =======
- cr 5 cells squares + @ 25 - 0= yes?
- 3 text c!
- 'c' text 3 + c!
- cr text count type
- ======= cr ;
\ No newline at end of file
public / preForth.git / commitdiff