-\ seedForth tokenizer (byte-tokenized source code)
+\ Another seedForth tokenizer 2019-10-18
-\ load on on top of gforth uho 2018-04-13
+: fnv1a ( c-addr u -- x )
+ 2166136261 >r
+ BEGIN dup WHILE over c@ r> xor 16777619 um* drop $FFFFFFFF and >r 1 /string REPEAT 2drop r> ;
-\ -----------------------------
+19 Constant #hashbits \ 0 < #hashbits < 16
-WARNINGS OFF
+1 #hashbits lshift Constant #hashsize
+\ #hashsize 1 - Constant tinymask
+#hashsize 1 - Constant mask cr .( mask=) mask hex u. decimal
-VARIABLE OUT
-: PROGRAM ( <name> -- )
- BL WORD COUNT R/W CREATE-FILE THROW OUT ! ;
-
-: SUBMIT ( c -- )
- PAD C! PAD 1 OUT @ WRITE-FILE THROW ;
-
-: END ( -- )
- .S CR 0 SUBMIT OUT @ CLOSE-FILE THROW BYE ;
-
-Variable #FUNS
-
-: FUNCTIONS ( u -- ) #FUNS ! ;
+\ : fold ( x1 -- x2 ) dup #hashbits rshift xor tinymask and ;
+: fold ( x1 -- x2 ) dup #hashbits rshift swap mask and xor ;
-: #FUN: ( <name> n -- )
- CREATE dup , 1+ FUNCTIONS DOES> @ SUBMIT ;
-
-: FUN: ( <name> -- )
- #FUNS @ #FUN: ;
-$02 #FUN: key
-$0A #FUN: -
-$29 #FUN: couple
+Create tokens #hashsize cells allot tokens #hashsize cells 0 fill
-: byte# ( c -- )
- ( seedForth ) key
- SUBMIT ;
+: 'token ( c-addr u -- addr )
+ fnv1a fold cells tokens + ;
-: # ( 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 ) couple EXIT THEN
- byte# ;
+: token@ ( c-addr u -- x ) 'token @ ;
-$22 #FUN: compiler
+: ?token ( c-addr u -- x ) 2dup 'token dup @ IF >r cr type ." collides with token " r> @ name-see abort THEN nip nip ;
-: [ ( -- ) 0 SUBMIT ;
-: ] ( -- ) compiler ;
-\ Literal numbers
-$0C #FUN: lit
-$1E #FUN: ,
-$1F #FUN: c,
+VARIABLE OUTFILE
-: #, ( x -- ) lit [ # , ] ; \ x is placed in memory as a cell-sized quantity (32/64 bit), as defined by comma
-
-\ Strings
+: SUBMIT ( c -- )
+ PAD C! PAD 1 OUTFILE @ WRITE-FILE THROW ;
+
+: <name> ( -- c-addr u ) bl word count ;
+
+Variable #tokens 0 #tokens !
+: Token ( <name> -- )
+ :noname
+ #tokens @ postpone LITERAL postpone SUBMIT postpone ;
+ <name>
+ cr #tokens @ 3 .r space 2dup type
+ ?token ! 1 #tokens +! ;
+
+: Macro ( <name> -- )
+ <name> ?token :noname $FEED ;
+
+: end-macro ( 'hash colon-sys -- )
+ $FEED - Abort" end-macro without corresponding Macro"
+ postpone ; ( 'hash xt ) swap ! ; immediate
+
+: seed ( i*x <name> -- j*x )
+ <name> token@ dup 0= Abort" is undefined" postpone LITERAL postpone EXECUTE ; immediate
+
+
+Token bye Token emit Token key Token dup
+Token swap Token drop Token 0< Token ?exit
+Token >r Token r> Token - Token unnest
+Token lit Token @ Token c@ Token !
+Token c! Token execute Token branch Token ?branch
+Token negate Token + Token 0= Token ?dup
+Token cells Token +! Token h@ Token h,
+Token here Token allot Token , Token c,
+Token fun Token interpreter Token compiler Token create
+Token does> Token cold Token depth Token compile,
+Token new Token couple Token and Token or
+Token catch Token throw Token sp@ Token sp!
+Token rp@ Token rp! Token $lit Token num
+
+
+\ generate token sequences for numbers
+
+: seed-byte ( c -- )
+ seed key SUBMIT ;
+
+: seed-number ( x -- ) \ x is placed in the token file. Handle also negative and large numbers
+ dup 0< IF 0 seed-byte negate recurse seed - EXIT THEN
+ dup $FF > IF dup 8 rshift recurse $FF and seed-byte seed couple EXIT THEN
+ seed-byte ;
+
+: char-lit? ( c-addr u -- x flag )
+ 3 - IF drop 0 false EXIT THEN
+ dup c@ [char] ' - IF drop 0 false EXIT THEN
+ dup 2 chars + c@ [char] ' - IF drop 0 false EXIT THEN
+ char+ c@ true ;
+
+: process-digit? ( x c -- x' flag )
+ '0' - dup 10 u< IF swap 10 * + true EXIT THEN drop false ;
+
+: number? ( c-addr u -- x flag )
+ dup 0= IF 2drop 0 false EXIT THEN
+ over c@ '-' = dup >r IF 1 /string THEN
+ >r >r 0 r> r> bounds
+ ?DO ( x )
+ I c@ process-digit? 0= IF unloop r> drop false EXIT THEN ( x d )
+ LOOP
+ r> IF negate THEN true ;
+
+: seed-name ( c-addr u )
+ 2dup token@ dup IF nip nip execute EXIT THEN drop
+ 2dup char-lit? IF nip nip seed num seed-number seed bye EXIT THEN drop
+ 2dup number? IF nip nip seed num seed-number seed bye EXIT THEN drop
+ cr type ." not found" abort ;
+
+: seed-line ( -- )
+ BEGIN <name> dup WHILE seed-name REPEAT 2drop ;
+
+: seed-file ( -- )
+ BEGIN refill WHILE seed-line REPEAT ;
-$32 #FUN: $lit
+: PROGRAM ( <name> -- )
+ <name> R/W CREATE-FILE THROW OUTFILE !
+ seed-file ;
-: ", ( c-addr u -- )
- dup # ( seedForth) c, BEGIN dup WHILE >r dup char+ swap c@ # ( seedForth) c, r> 1- REPEAT 2drop ;
+Macro END ( -- )
+ .S CR 0 SUBMIT OUTFILE @ CLOSE-FILE THROW BYE end-macro
-: ," ( ccc" -- ) [char] " parse ", ;
+Macro [ ( -- ) 0 SUBMIT end-macro \ bye
+Macro ] ( -- ) seed compiler end-macro \ compiler
-: $, ( c-addr u -- ) $lit [ ", ] ;
+Macro : ( <name> -- ) seed fun Token end-macro
+Macro ; ( -- ) seed unnest seed [ end-macro
-: s" ( ccc" -- ) [char] " parse $, ; \ only in compile mode
+\ generate token sequences for strings
+: seed-string ( c-addr u -- )
+ dup seed-number seed c,
+ BEGIN dup WHILE
+ >r dup char+ swap c@ seed-number seed c,
+ r> 1-
+ REPEAT 2drop
+;
- $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: couple ) $2A #FUN: and $2B #FUN: or
- $2C #FUN: catch $2D #FUN: throw $2E #FUN: sp@ $2F #FUN: sp!
- $30 #FUN: rp@ $31 #FUN: rp! ( $32 #FUN: $lit )
+Macro ," ( ccc" -- ) [char] " parse seed-string end-macro
-$33 FUNCTIONS
+: $, ( c-addr u -- )
+ seed $lit
+ seed [
+ seed-string
+ seed ]
+;
-\ Definitions
-
-: ': ( <name> -- ) FUN: fun ;
-: ;' ( -- ) unnest [ ;
+Macro s" ( ccc" -- ) \ only in compile mode
+ [char] " parse $,
+end-macro
\ Control structure macros
-
-: AHEAD ( -- addr ) branch [ here 0 # , ] ;
-: IF ( -- addr ) ?branch [ here 0 # , ] ;
-: THEN ( addr -- ) [ here swap ! ] ;
-: ELSE ( addr1 -- addr2 ) branch [ here 0 # , swap ] THEN ;
-
-: BEGIN ( -- addr ) [ here ] ;
-: AGAIN ( addr -- ) branch [ , ] ;
-: UNTIL ( addr -- ) ?branch [ , ] ;
-: WHILE ( addr1 -- addr2 addr1 ) IF [ swap ] ;
-: REPEAT ( addr -- ) AGAIN THEN ;
-
+: forward ( -- )
+ seed [
+ seed here
+ 0 seed-number seed ,
+ seed ]
+;
+
+: back ( -- )
+ seed [
+ seed ,
+ seed ]
+;
+
+
+Macro AHEAD ( -- addr )
+ seed branch forward
+end-macro
+
+Macro IF ( -- addr )
+ seed ?branch forward
+end-macro
+
+
+Macro THEN ( addr -- )
+ seed [
+ seed here
+ seed swap
+ seed !
+ seed ]
+end-macro
+
+Macro ELSE ( addr1 -- addr2 )
+ seed branch forward
+ seed [
+ seed swap
+ seed ]
+ seed THEN
+end-macro
+
+Macro BEGIN ( -- addr )
+ seed [
+ seed here
+ seed ]
+end-macro
+
+Macro AGAIN ( addr -- )
+ seed branch back
+end-macro
+
+Macro UNTIL ( addr -- )
+ seed ?branch back
+end-macro
+
+Macro WHILE ( addr1 -- addr2 addr1 )
+ seed IF
+ seed [
+ seed swap
+ seed ]
+end-macro
+
+Macro REPEAT ( addr -- )
+ seed AGAIN
+ seed THEN
+end-macro
+
+Macro ( ( -- )
+ postpone (
+end-macro
+
+Macro \ ( -- )
+ postpone \
+end-macro
+
+0 [if]
+
+Macro Token ( <name> -- )
+ postpone Token
+end-macro
+
+Macro Macro ( <name> -- )
+ Macro
+end-macro
+
+Macro end-macro ( -- )
+ postpone end-macro
+end-macro
+
+Macro seed ( <name> -- )
+ postpone seed
+end-macro
+
+[then]
+
+\ Macro Definer ( <name> <runtime> -- )
+\ Macro
+\ postpone Token
+\ postpone seed
+\ postpone end-macro
+\ end-macro
+
+Macro Definer ( <name> -- )
+ Macro
+ postpone Token
+ #tokens @ 1 #tokens +!
+ postpone Literal
+ postpone SUBMIT
+ seed fun
+ postpone end-macro
+end-macro
+
+Macro see ( <name> -- )
+ <name> token@ ?dup 0= Abort" see cannot find name" name-see end-macro
\
-program seedForthDemo.seed
+PROGRAM seedForthDemo.seed
-\ : compiler ( -- )
-\ key ?dup 0= ?exit compile, tail compiler ;
-'o' # 'k' # \ push stack marker. Used eventually below.
+'o' 'k' \ push stack marker. Used eventually below.
-': ?ok ( o k -- o k ) 10 #, emit >r dup emit r> dup emit ;'
+: ?ok ( o k -- o k ) 10 emit >r dup emit r> dup emit ;
?ok
-10 # emit '*' # dup emit emit \ interpret numbers and words
+10 emit '*' dup emit emit \ interpret numbers and words
-': 3* dup dup + + ;' \ defintions
-': 1- 1 #, - ;' \ compile number and words
+: 3* dup dup + + ; \ definitions
+: 1- 1 - ; \ compile number and words
\ output utilities
-': cr ( -- ) 10 #, emit ;'
-': space ( -- ) 32 #, emit ;'
-': .digit ( n -- ) '0' #, + emit ;'
+: cr ( -- ) 10 emit ;
+: space ( -- ) 32 emit ;
+: .digit ( n -- ) '0' + emit ;
-': star ( -- ) '*' #, emit ;'
+: star ( -- ) '*' emit ;
-': stars ( n -- )
- ?dup IF BEGIN star 1- ?dup 0= UNTIL THEN ;' \ standard Forth control structures
+: stars ( n -- )
+ ?dup IF BEGIN star 1- ?dup 0= UNTIL THEN ; \ standard Forth control structures
-': dash ( -- ) '-' #, emit ;'
+: dash ( -- ) '-' emit ;
-': dashes ( n -- ) BEGIN ?dup WHILE dash 1- REPEAT ;'
+: dashes ( n -- ) BEGIN ?dup WHILE dash 1- REPEAT ;
-': --- ( -- ) cr 80 #, dashes ;'
+: --- ( -- ) cr 80 dashes ;
-': space ( -- ) 32 #, emit ;'
-
-': spaces ( n -- )
- BEGIN ?dup 0= ?exit space 1- AGAIN ;' \ another loop variation
+: spaces ( n -- )
+ BEGIN ?dup 0= ?exit space 1- AGAIN ; \ another loop variation
---
-': countdown ( n -- )
- ?dup 0= ?exit dup cr .digit 1- countdown ;' \ recursion
+: countdown ( n -- )
+ ?dup 0= ?exit dup cr .digit 1- countdown ; \ recursion
-cr '2' # emit '*' # emit '3' # emit '=' # emit 2 # 3* .digit \ interpret new definitions
+cr '2' emit '*' emit '3' emit '=' emit 2 3* .digit \ interpret new definitions
-9 # countdown
+9 countdown
---
-': another-count-down ( n -- )
- BEGIN dup WHILE dup cr .digit 1- REPEAT drop ;' \ standard Forth control structures
+: another-count-down ( n -- )
+ BEGIN dup WHILE dup cr .digit 1- REPEAT drop ; \ standard Forth control structures
-5 # another-count-down
+5 another-count-down
---
-': yes? ( f -- )
- IF 'Y' #, ELSE 'N' #, THEN emit ;' \ standard Forth conditionals
+: yes? ( f -- )
+ IF 'Y' ELSE 'N' THEN emit ; \ standard Forth conditionals
-cr 0 # yes? -1 # yes? 1 # yes?
+cr 0 yes? -1 yes? 1 yes?
?ok \ display ok again (for error analysis)
\ utility words
-': 1+ ( x1 -- x2 ) 1 #, + ;'
+: 1+ ( x1 -- x2 ) 1 + ;
-': over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ;'
+: over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ;
-': 2drop ( x1 x2 -- ) drop drop ;'
+: 2drop ( x1 x2 -- ) drop drop ;
-': nip ( x1 x2 -- x2 ) swap drop ;'
+: nip ( x1 x2 -- x2 ) swap drop ;
-\ ': c, ( c -- ) here 1 #, allot c! ;'
+\ : c, ( c -- ) here 1 allot c! ;
-': /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ;'
+: /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ;
-': count ( addr -- c-addr u ) dup 1+ swap c@ ;'
+: count ( addr -- c-addr u ) dup 1+ swap c@ ;
-': type ( c-addr u -- )
- BEGIN dup WHILE over c@ emit 1 #, /string REPEAT 2drop ;'
+: type ( c-addr u -- )
+ BEGIN dup WHILE over c@ emit 1 /string REPEAT 2drop ;
-here 5 # c, 'H' # c, 'e' # c, 'l' # dup c, c, 'o' # c,
+here 5 c, 'H' c, 'e' c, 'l' dup c, c, 'o' c,
cr count type
\ more utility words
-': < ( n1 n2 -- f ) - 0< ;'
-': > ( n1 n2 -- f ) swap < ;'
-': = ( x1 x2 -- f ) - 0= ;'
+: < ( n1 n2 -- f ) - 0< ;
+: > ( n1 n2 -- f ) swap < ;
+: = ( x1 x2 -- f ) - 0= ;
\ hex number output
-': .hexdigit ( n -- ) dup 9 #, > IF lit [ 'A' # 10 # - , ] ELSE '0' #, THEN + emit ;'
+: .hexdigit ( n -- ) dup 9 > IF lit [ 'A' 10 - , ] ELSE '0' THEN + emit ;
-': 2* ( x1 -- x2 ) dup + ;'
+: 2* ( x1 -- x2 ) dup + ;
\ 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 ;'
+: 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= ;'
+: odd? ( x1 -- f ) dup u2/ 2* = 0= ;
-': 2/mod ( x1 -- x2 r ) \ swapped results
- dup u2/ swap odd? negate ;'
+: 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> + ;'
+: 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 -- )
+: #### ( 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 ;'
+ r> .hexdigit r> .hexdigit r> .hexdigit space ;
+
+: (.) ( x -- )
+ ?dup IF 16/mod >r (.) r> .hexdigit THEN ;
-': (.) ( x -- )
- ?dup IF 16/mod >r (.) r> .hexdigit THEN ;'
+: u. ( x -- )
+ ?dup IF (.) ELSE '0' emit THEN space ;
-': u. ( x -- )
- ?dup IF (.) ELSE '0' #, emit THEN space ;'
+: . ( n -- ) dup 0< IF '-' emit negate THEN u. ;
-': . ( n -- ) dup 0< IF '-' #, emit negate THEN u. ;'
+cr 42 .
+43 . 44 . 45 . 46 . 47 . 48 . 49 . 50 . 51 . 52 . 53 . 54 . 55 . 56 . 57 . 58 .
+cr 100 .
+: hundred 100 ;
-cr 100 # negate . \ display negative number
+cr 100 negate . \ display negative number
cr here u. \ display larger number
cr
\ create and defining words
-fun: V create 4 # , \ new token for tokenizer and new variable like definition
+\ Token V create 4 , \ new token for tokenizer and new variable like definition
-cr V @ u. \ get value: 4
+\ cr V @ u. \ get value: 4
-?ok
+\ ?ok
---
+
\ We must split defining words into two parts.
\ 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)
-: Value ( <name> x -- ) fun: _value ; \ macro 2)
+\ : _value ( x -- ) create , does> @ ; \ a seedForth defining word 1)
+\ Definer Value _value ( x <name> -- )
+
+Definer Value ( x <name> -- ) create , does> @ ;
+
+10 Value ten cr ten .
-': _variable ( -- ) create 0 #, , does> ;' \ a seedForth defining word
-: Variable ( <name> -- ) fun: _variable ; \ macro
+?ok
+
+
+( <name> -- )
+\ : _variable create 0 , does> ; \ a seedForth defining word
+\ Definer Variable _variable ( x <name> -- )
-fun: V1 5 # _value
-cr V1 u. \ use value: 5
-6 # Value v4 v4 u. \ values are initialized from stack: 6
+Definer Variable ( <name> -- ) create 0 , does> ;
+\ : _const create , does> @ ;
+\ Definer Constant _const ( <name> x -- )
-fun: V2 _variable
-7 # V2 +! V2 @ u. 8 # V2 ! V2 @ u. \ fetch and store value: 7 8
+Definer Constant ( x <name> -- ) create , does> @ ;
+0 Constant zero
-': doconst ( -- ) does> @ ;' \ a does> w/o creat path sets behavour
-: Constant ( <name> x -- ) fun: create , doconst ; \ macro
+cr zero . \ constants are similar to values here: 0
-fun: nine create
- 9 # , \ parameter field
- doconst \ set behaviour of last word
-nine . \ display constant: 9
+Variable v 5 v ! v @ .
+
+20 Constant twenty twenty .
-0 # Constant zero zero . \ constants are similar to values here: 0
?ok
---
-
\ structured data
-': _field ( addr -- addr' ) create over , + does> @ + ;'
-: Field ( <name> offset size -- offset' ) fun: _field ;
+\ : _field ( addr -- addr' ) create over , + does> @ + ;
+\ Definer Field _field ( <name> offset size -- offset' )
+
+Definer Field ( offset size <name> -- offset' ) create over , + does> @ + ;
+
\ define structure
-0 #
+0
+
+1 cells Field >name
+2 cells Field >date
-1 # cells Field >name
-2 # cells Field >date
+Value person
-Value #person
+Definer Create ( <name> -- ) create ;
-fun: p1 create #person allot
+Create p1 person allot
p1 >date u. \ address calculation
-cr #person u. \ size of structure
+cr person u. \ size of structure
?ok
---
+
\ Defered words
-': ' ( -- x ) key ;'
+: ' ( -- x ) key ;
+
+' star Constant 'star cr 'star .
+
+\ : _defer create 'star , does> @ execute ;
+\ Definer Defer _defer ( <name> -- )
+
+\ see Defer
-' star constant 'star cr 'star .
+\ Macro defr Token seed _defer end-macro
+\ see defr
-': dodefer ( -- ) does> @ execute ;'
-: Defer ( <name> -- ) fun: create 'star , dodefer ; \ macro, star is default behaviour
-': >body ( xt -- body ) h@ 1 #, cells + ;'
+Definer Defer ( <name> -- ) create 'star , does> @ execute ;
+see Defer
-': is ( xt -- ) ' >body ! ;'
+
+: >body ( xt -- body ) h@ 1 cells + ;
+
+: is ( xt -- ) ' >body ! ;
cr ' dash dup . execute \ get execution token of definition
cr
?ok
-cr 80 # stars
+---
+
+cr 80 stars
\ Tester
-': empty-stack ( i*x -- )
- BEGIN depth 0< WHILE 0 #, REPEAT
- BEGIN depth WHILE drop REPEAT ;'
+: empty-stack ( i*x -- )
+ BEGIN depth 0< WHILE 0 REPEAT
+ BEGIN depth WHILE drop REPEAT ;
-variable actual-depth
+Variable actual-depth
( actual-results )
-20 # cells allot
+20 cells allot
-': nth-result ( n -- addr )
- cells actual-depth + ;'
+: nth-result ( n -- addr )
+ cells actual-depth + ;
-': error ( i*x c-addr u -- )
- cr type empty-stack ;'
+: error ( i*x c-addr u -- )
+ cr type empty-stack ;
-': t{ ( i*x -- )
- '.' #, emit empty-stack ;'
+: t{ ( i*x -- )
+ '.' emit empty-stack ;
-': -> ( -- )
+: -> ( -- )
depth actual-depth !
- BEGIN depth WHILE depth nth-result ! REPEAT ;'
+ BEGIN depth WHILE depth nth-result ! REPEAT ;
-fun: wrong create ( -- addr )
+Create wrong ( -- addr )
," wrong number of results"
-fun: incorrect create ( -- addr )
+Create incorrect ( -- addr )
," incorrect result"
-': }t ( i*x -- )
+: }t ( i*x -- )
depth actual-depth @ - IF wrong count error unnest THEN
- BEGIN depth WHILE depth nth-result @ - IF incorrect count error unnest THEN REPEAT ;'
+ BEGIN depth WHILE depth nth-result @ - IF incorrect count error unnest THEN REPEAT ;
?ok 2drop
-fun: testing create ( -- addr )
+Create testing ( -- addr )
," testing"
cr testing count type cr
-\ cr 't' # emit 'e' # emit 's' # emit 't' # emit 'i' # emit 'n' # emit 'g' # emit cr
+\ cr 't' emit 'e' emit 's' emit 't' emit 'i' emit 'n' emit 'g' emit cr
+
+\ 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,
-fun: twice
-new key dup compile, key + compile, key unnest compile,
+: twice ( x -- 2x )
+ dup + ;
-t{ 2 # twice -> 4 # }t
+t{ 2 twice -> 4 }t
-\ cr 2 # twice .
+\ cr 2 twice .
-fun: area create 1 # ,
+Create area 1 ,
-t{ area @ -> 1 # }t
-t{ area 2 # cells - @ -> 0 # }t \ extract the dummy Does> field.
+t{ area @ -> 1 }t
+t{ area 2 cells - @ -> 0 }t \ extract the dummy Does> field.
-t{ 1 # 2 # couple -> 129 # dup + }t
-t{ 258 # -> 129 # dup + }t
-t{ -1 # 2 # + -> 1 # }t
+t{ 1 2 couple -> 129 dup + }t
+t{ 258 -> 129 dup + }t
+t{ -1 2 + -> 1 }t
-': large 12345 #, ;'
-t{ large -> 12340 # 5 # + }t
+: large 12345 ;
+t{ large -> 12340 5 + }t
-': negative -12345 #, ;'
-t{ negative -> -12340 # 5 # - }t
+: negative -12345 ;
+t{ negative -> -12340 5 - }t
-t{ 10 # ' dup catch -> 10 # 10 # 0 # }t
+t{ 10 ' dup catch -> 10 10 0 }t
-': err99 ( x -- ) dup 9 #, = IF 99 #, throw THEN 1 #, + ;'
+: err99 ( x -- ) dup 9 = IF 99 throw THEN 1 + ;
-t{ 1 # ' err99 catch -> 2 # 0 # }t
-t{ 5 # 9 # ' err99 catch nip -> 5 # 99 # }t
+t{ 1 ' err99 catch -> 2 0 }t
+t{ 5 9 ' err99 catch nip -> 5 99 }t
-': rot ( a b c -- b c a ) >r swap r> swap ;'
-t{ 10 # sp@ 20 # 30 # rot sp! -> 10 # }t
+: rot ( a b c -- b c a ) >r swap r> swap ;
+t{ 10 sp@ 20 30 rot sp! -> 10 }t
-': rp!-test ( -- ) rp@ 10 #, >r 20 #, >r 30 #, >r rp! ;'
+: rp!-test ( -- ) rp@ 10 >r 20 >r 30 >r rp! ;
-t{ 99 # rp!-test -> 99 # }t
+t{ 99 rp!-test -> 99 }t
-t{ 0 # 0< -> 0 # }t
-t{ 1 # 0< -> 0 # }t
-t{ 2 # 0< -> 0 # }t
-t{ 1 # negate 0< -> -1 # }t
-t{ 2 # negate 0< -> -1 # }t
+t{ 0 0< -> 0 }t
+t{ 1 0< -> 0 }t
+t{ 2 0< -> 0 }t
+t{ 1 negate 0< -> -1 }t
+t{ 2 negate 0< -> -1 }t
-': greeting ( -- ) s" a string literal" ;'
+: greeting ( -- ) s" a string literal" ;
-t{ greeting nip -> 16 # }t
+t{ greeting nip -> 16 }t
-': compare ( c-addr1 u1 c-addr2 u2 -- n )
+: 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
+ >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 #,
+ -1
ELSE
- dup 0= IF 0 #, ELSE 1 #, THEN
- THEN >r 2drop 2drop r> ;'
+ dup 0= IF 0 ELSE 1 THEN
+ THEN >r 2drop 2drop r> ;
-t{ wrong count wrong count compare -> 0 # }t
-t{ wrong count incorrect count compare -> 1 # }t
+t{ wrong count wrong count compare -> 0 }t
+t{ wrong count incorrect count compare -> 1 }t
-': .s ( i*x -- i*x )
- depth 0= ?exit >r .s r> dup . ;'
+: .s ( i*x -- i*x )
+ depth 0= ?exit >r .s r> dup . ;
-': alloc ( u -- addr )
- here swap allot ;'
+: alloc ( u -- addr )
+ here swap allot ;
-': dispose ( addr -- )
- drop ;'
+: dispose ( addr -- )
+ drop ;
\ -----------------------------------------------
-': done ( -- ) cr s" done" type cr ;' done
-\ cr 'd' # emit 'o' # emit 'n' # emit 'e' # emit cr
+: done ( -- ) cr s" done" type cr ; done
+\ cr 'd' emit 'o' emit 'n' emit 'e' emit cr
-end
+END
public / preForth.git / commitdiff