lea esi, [eax+4]
next
-_dodoes: ; ( -- addr ) \ call me
+_dodoes: ; ( -- addr )
lea ebp, [ebp-4] ; push IP
mov [ebp], esi
- pop esi ; set IP to caller
+ mov esi,[eax-4] ; set IP
_dovar: ; ( -- addr )
lea eax,[eax+4] ; to parameter field
- push eax
+ push eax
next
_O = 0
: fun ( -- )
new compiler ;
+: +lit ( hi lo -- hilo )
+ >r dup + dup + dup + dup +
+ dup + dup + dup + dup + r> + ;
: create ( -- )
+ 0 , \ dummy does> field
here h, lit dovar , ;
-: ,call ( x -- )
- 232 c, here >r 0 , here - r> ! ; \ call near 32bit
-
-: does ( -- )
- r> lit hp @ 1 - h@ ! ; \ set code field of last defined word
-
-: does> ( -- )
- lit does ,
- lit dodoes ,call ;
-
+: does> ( -- ) \ set code field of last defined word
+ r> lit hp @ 1 - h@ dup >r 1 cells - ! lit dodoes r> !
+;
: cold ( -- )
's' emit 'e' dup emit emit 'd' emit 10 emit
lit depth h, \ 38 26
lit compile, h, \ 39 27
lit new h, \ 40 28
- lit and h, \ 41 29
- lit or h, \ 42 2A
+ lit +lit h, \ 41 29
+ lit and h, \ 42 2A
+ lit or h, \ 43 2B
tail interpreter ;
pre
: END ( -- )
.S CR 0 SUBMIT OUT @ CLOSE-FILE THROW BYE ;
+Variable #FUNS 29 #FUNS !
-Variable #FUNS 0 #FUNS !
+: #FUN: ( <name> n -- )
+ CREATE dup , 1+ #FUNS ! DOES> @ SUBMIT ;
+
: FUN: ( <name> -- )
- CREATE #FUNS @ , 1 #FUNS +!
- DOES> @ SUBMIT ;
-
-FUN: bye FUN: emit FUN: key FUN: dup \ 00 01 02 03
-FUN: swap FUN: drop FUN: 0< FUN: ?exit \ 04 05 06 07
-FUN: >r FUN: r> FUN: - FUN: unnest \ 08 09 0A 0B
-FUN: lit FUN: @ FUN: c@ FUN: ! \ 0C 0D 0E 0F
-FUN: c! FUN: execute FUN: branch FUN: ?branch \ 10 11 12 13
-FUN: negate FUN: + FUN: 0= FUN: ?dup \ 14 15 16 17
-FUN: cells FUN: +! FUN: h@ FUN: h, \ 18 19 1A 1B
-FUN: here FUN: allot FUN: , FUN: c, \ 1C 1D 1E 1F
-FUN: fun FUN: interpreter FUN: compiler FUN: create \ 20 21 22 23
-FUN: does> FUN: cold FUN: depth FUN: compile, \ 24 25 26 27
-FUN: new FUN: and FUN: or
+ #FUNS @ #FUN: ;
+
+$02 #FUN: key
+$0A #FUN: -
+$29 #FUN: +lit
+
+: byte# ( c -- )
+ ( seedForth) key
+ SUBMIT ;
+
+: # ( x -- ) \ x is placed in the token file. Handle also negative and large numbers
+ dup 0< IF 0 byte# negate recurse ( seedForth) - EXIT THEN
+ dup $FF > IF dup 8 rshift recurse $FF and byte# ( seedForth ) +lit EXIT THEN
+ byte# ;
+
+$00 #FUN: bye $01 #FUN: emit ( $02 #FUN: key ) $03 #FUN: dup
+$04 #FUN: swap $05 #FUN: drop $06 #FUN: 0< $07 #FUN: ?exit
+$08 #FUN: >r $09 #FUN: r> ( $0A #FUN: - ) $0B #FUN: unnest
+$0C #FUN: lit $0D #FUN: @ $0E #FUN: c@ $0F #FUN: !
+$10 #FUN: c! $11 #FUN: execute $12 #FUN: branch $13 #FUN: ?branch
+$14 #FUN: negate $15 #FUN: + $16 #FUN: 0= $17 #FUN: ?dup
+$18 #FUN: cells $19 #FUN: +! $1A #FUN: h@ $1B #FUN: h,
+$1C #FUN: here $1D #FUN: allot $1E #FUN: , $1F #FUN: c,
+$20 #FUN: fun $21 #FUN: interpreter $22 #FUN: compiler $23 #FUN: create
+$24 #FUN: does> $25 #FUN: cold $26 #FUN: depth $27 #FUN: compile,
+$28 #FUN: new ( $29 #FUN: +lit ) $2A #FUN: and $2B #FUN: or
: [ ( -- ) 0 SUBMIT ;
: ] ( -- ) compiler ;
: ': ( <name> -- ) FUN: fun ;
: ;' ( -- ) unnest [ ;
-: # ( x -- ) key SUBMIT ; \ x is placed in the token file as a single byte, as defined by key/SUBMIT
: #, ( x -- ) lit [ # , ] ; \ x is placed in memory as a cell-sized quantity (32/64 bit), as defined by comma
\ Control structure macros
program seedForthDemo.seed
-
-
\ : compiler ( -- )
\ key ?dup 0= ?exit compile, tail compiler ;
-
-
'o' # 'k' # \ push stack marker. Used eventually below.
': ?ok ( o k -- o k ) 10 #, emit >r dup emit r> dup emit ;'
\ 1) Build up the new word with function index in seedForth
\ 2) Let the tokenizer create its symbol table entry (then invoke 1)
-': _value ( x -- ) create , [ does> ] @ ;' \ a seedForth defining word 1) \ execute does> as it is a compiling word
+': _value ( x -- ) create , does> @ ;' \ a seedForth defining word 1)
: Value ( <name> x -- ) fun: _value ; \ macro 2)
-': _variable ( x -- ) create 0 #, , [ does> ] ;' \ a seedForth defining word
+': _variable ( x -- ) create 0 #, , does> ;' \ a seedForth defining word
: Variable ( <name> -- ) fun: _variable ; \ macro
fun: V1 5 # _value
7 # V2 +! V2 @ u. 8 # V2 ! V2 @ u. \ fetch and store value: 7 8
-': doconst ( x -- ) [ does> ] @ ;' \ a does> w/o creat path sets behavour
+': doconst ( x -- ) does> @ ;' \ a does> w/o creat path sets behavour
: Constant ( <name> x -- ) fun: create , doconst ; \ macro
fun: nine create
\ structured data
-': _field ( addr -- addr' ) create over , + [ does> ] @ + ;'
+': _field ( addr -- addr' ) create over , + does> @ + ;'
: Field ( <name> offset size -- offset' ) fun: _field ;
\ define structure
' star constant 'star cr 'star .
-': dodefer ( -- ) [ does> ] @ execute ;'
+': dodefer ( -- ) does> @ execute ;'
: Defer ( <name> -- ) fun: create 'star , dodefer ; \ macro, star is default behaviour
': >body ( xt -- body ) h@ 1 #, cells + ;'
cr 't' # emit 'e' # emit 's' # emit 't' # emit 'i' # emit 'n' # emit 'g' # emit
-t{ 3 # 4 # + -> 7 # }t
-t{ 3 # 4 # + -> 8 # }t
-t{ 3 # 4 # + -> 1 # 2 # }t
+\ t{ 3 # 4 # + -> 7 # }t
+\ t{ 3 # 4 # + -> 8 # }t
+\ t{ 3 # 4 # + -> 1 # 2 # }t
fun: twice
new key dup compile, key + compile, key unnest compile,
t{ 2 # twice -> 4 # }t
-cr 2 # twice .
+\ cr 2 # twice .
+
+fun: area create 1 # ,
+
+t{ area @ -> 1 # }t
+t{ area 2 # cells - @ -> 0 # }t \ extract the dummy Does> field.
+
+t{ 1 # 2 # +lit -> 129 # dup + }t
+t{ 258 # -> 129 # dup + }t
+t{ -1 # 2 # + -> 1 # }t
+
+': large 12345 #, ;'
+t{ large -> 12340 # 5 # + }t
+': negative -12345 #, ;'
+t{ negative -> -12340 # 5 # - }t
cr 'd' # emit 'o' # emit 'n' # emit 'e' # emit cr
public / preForth.git / commitdiff