From: Ulrich Hoffmann Date: Wed, 15 Aug 2018 15:11:27 +0000 (+0200) Subject: Provide counted string literals X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?p=preForth.git;a=commitdiff_plain;h=64ebfddc6c08c9b4ce8677184dd2c61294210826 Provide counted string literals --- diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 232153a..70e865c 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -374,9 +374,14 @@ code rp! ( x -- ) : fun ( -- ) new compiler ; -: +lit ( hi lo -- hilo ) - >r dup + dup + dup + dup + - dup + dup + dup + dup + r> + ; +: 2* ( x1 -- x2 ) + dup + ; + +: couple ( hi lo -- hilo ) + >r 2* 2* 2* 2* 2* 2* 2* 2* r> + ; + +: $lit ( -- addr u ) + r> dup 1 + dup >r swap c@ dup r> + >r ; : create ( -- ) 0 , \ dummy does> field @@ -436,7 +441,7 @@ code rp! ( x -- ) lit depth h, \ 38 26 lit compile, h, \ 39 27 lit new h, \ 40 28 - lit +lit h, \ 41 29 + lit couple h, \ 41 29 lit and h, \ 42 2A lit or h, \ 43 2B lit catch h, \ 44 2C @@ -445,6 +450,7 @@ code rp! ( x -- ) lit sp! h, \ 47 2F lit rp@ h, \ 48 30 lit rp! h, \ 49 31 + lit $lit h, \ 50 32 tail interpreter ; pre diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index 20ebab5..7c1ccc7 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -17,48 +17,78 @@ VARIABLE OUT : END ( -- ) .S CR 0 SUBMIT OUT @ CLOSE-FILE THROW BYE ; -Variable #FUNS 29 #FUNS ! +Variable #FUNS + +: FUNCTIONS ( u -- ) #FUNS ! ; + : #FUN: ( n -- ) - CREATE dup , 1+ #FUNS ! DOES> @ SUBMIT ; + CREATE dup , 1+ FUNCTIONS DOES> @ SUBMIT ; : FUN: ( -- ) #FUNS @ #FUN: ; $02 #FUN: key $0A #FUN: - -$29 #FUN: +lit +$29 #FUN: couple : byte# ( c -- ) - ( seedForth) key + ( 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 + 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# ; -$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 -$2C #FUN: catch $2D #FUN: throw $2E #FUN: sp@ $2F #FUN: sp! -$30 #FUN: rp@ $31 #FUN: rp! +$22 #FUN: compiler : [ ( -- ) 0 SUBMIT ; : ] ( -- ) compiler ; +\ Literal numbers + +$0C #FUN: lit +$1E #FUN: , +$1F #FUN: c, + +: #, ( x -- ) lit [ # , ] ; \ x is placed in memory as a cell-sized quantity (32/64 bit), as defined by comma + +\ Strings + +$32 #FUN: $lit + +: ", ( c-addr u -- ) + dup # ( seedForth) c, BEGIN dup WHILE >r dup char+ swap c@ # ( seedForth) c, r> 1- REPEAT 2drop ; + +: ," ( ccc" -- ) [char] " parse ", ; + +: $, ( c-addr u -- ) $lit [ ", ] ; + +: s" ( ccc" -- ) [char] " parse $, ; \ only in compile mode + + + $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 ) + +$33 FUNCTIONS + +\ Definitions + : ': ( -- ) FUN: fun ; : ;' ( -- ) unnest [ ; -: #, ( x -- ) lit [ # , ] ; \ x is placed in memory as a cell-sized quantity (32/64 bit), as defined by comma \ Control structure macros @@ -72,3 +102,4 @@ $30 #FUN: rp@ $31 #FUN: rp! : UNTIL ( addr -- ) ?branch [ , ] ; : WHILE ( addr1 -- addr2 addr1 ) IF [ swap ] ; : REPEAT ( addr -- ) AGAIN THEN ; + diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource index 29bef6d..5918f4b 100644 --- a/preForth/seedForthDemo.seedsource +++ b/preForth/seedForthDemo.seedsource @@ -272,17 +272,10 @@ variable actual-depth BEGIN depth WHILE depth nth-result ! REPEAT ;' fun: wrong create ( -- 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, + ," wrong number of results" fun: incorrect create ( -- 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, - + ," incorrect result" ': }t ( i*x -- ) depth actual-depth @ - IF wrong count error unnest THEN @@ -290,7 +283,12 @@ fun: incorrect create ( -- addr ) ?ok 2drop -cr 't' # emit 'e' # emit 's' # emit 't' # emit 'i' # emit 'n' # emit 'g' # emit cr +fun: testing create ( -- addr ) + ," testing" + +cr testing count type 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 @@ -308,7 +306,7 @@ 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{ 1 # 2 # couple -> 129 # dup + }t t{ 258 # -> 129 # dup + }t t{ -1 # 2 # + -> 1 # }t @@ -339,6 +337,13 @@ t{ 2 # 0< -> 0 # }t t{ 1 # negate 0< -> -1 # }t t{ 2 # negate 0< -> -1 # }t + +': greet ( -- ) + cr s" a string literal" ;' + +t{ greet nip -> 16 # }t + + cr 'd' # emit 'o' # emit 'n' # emit 'e' # emit cr end