Provide counted string literals

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index 232153a..70e865c 100644 (file)
--- 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 (file)
--- 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: ( <name> n -- )
-    CREATE dup , 1+ #FUNS ! DOES> @ SUBMIT ;
+    CREATE dup , 1+ FUNCTIONS DOES> @ SUBMIT ;
     
 : FUN: ( <name> -- )
     #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
+  
 : ': ( <name> -- ) 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 (file)
--- 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