Add save and empty to tokenized seedForth (and Tokenizer). Surround Test-Code by...

diff --git a/preForth/hi.forth b/preForth/hi.forth
index 33c7f9f..4095117 100644 (file)
--- a/preForth/hi.forth
+++ b/preForth/hi.forth
@@ -9,6 +9,23 @@ cr .( ⓪ )
 : \ 
    source nip >in ! ; immediate
 
+
+\ save and empty (need HP)  single wordlist only no string header reclaim
+\ HEAD, the start of seedForth header table is not required. 
+\ DP is not required as it can be read via HERE and set via ALLOT (see DP!) 
+
+: !+ ( x addr -- addr' )  swap over ! cell+ ;
+: @+ ( addr -- x addr' )  dup @ swap cell+ ;
+: dp! ( addr -- )  here - allot ;
+
+| Create savearea  0 , 0 , 0 , \ { hp | dp | forth-wordlist }
+
+: save ( -- )  forth-wordlist @  here  hp @  savearea !+ !+ ! ;
+: empty ( -- )  savearea @+ @+ @ forth-wordlist ! dp! hp ! ;
+
+' save Alias begin-tests 
+' empty Alias end-tests
+
 \ cr .( hi - doing some test )
 \ t{ 3 4 + -> 7 }t   \ pass
 \ t{ 3 -> }t         \ wrong number of results
@@ -84,10 +101,14 @@ false invert Constant true
 
 : 0> ( n -- f )  0 > ;
 
+begin-tests
+
 t{  10 0> -> -1 }t
 t{   0 0> ->  0 }t
 t{ -10 0> ->  0 }t
 
+end-tests
+
 : 2>r ( x1 x2 -- r:x1 r:x2 ) 
    swap r> swap >r swap >r >r ;
 
@@ -97,6 +118,8 @@ t{ -10 0> ->  0 }t
 : 2r@ ( r:x1 r:x2 -- r:x1 r:x2 x1 x2 )
    r>   r> r> 2dup >r >r swap  rot >r ;
 
+begin-tests 
+
 : 2>r-test ( x1 x2 -- x1 x2 )  2>r r> r> swap ;
 t{ 3 4 2>r-test -> 3 4 }t
 
@@ -106,6 +129,8 @@ t{ 3 4 2r>-test -> 3 4 }t
 : 2r@-test ( x1 x2 -- x1 x2 )  2>r  2r@  2r> 2drop ;
 t{ 3 4 2r@-test -> 3 4 }t
 
+end-tests
+
 
 : n>r ( x1 ... xn -- r: xn ... x1 n )
    dup                        \  --
@@ -127,6 +152,8 @@ t{ 3 4 2r@-test -> 3 4 }t
       1-
    REPEAT ;
 
+begin-tests
+
 : n>r-test ( x1 x2 -- n x1 x2 )  2 n>r r> r> r> ;
 t{ 3 4 n>r-test -> 2 3 4 }t
 
@@ -137,6 +164,7 @@ t{ 3 4 nr>-test -> 3 4 2 }t
     2>r 2swap 2r> 2swap ;
 
 t{ 1 2 3 4 5 6 2rot -> 3 4 5 6 1 2 }t
+end-tests
 
 
 : lshift ( x u -- ) BEGIN ?dup WHILE swap 2* swap 1-  REPEAT ;
@@ -151,9 +179,12 @@ t{ 1 2 3 4 5 6 2rot -> 3 4 5 6 1 2 }t
    REPEAT ( x q n )
    nip ;
 
+begin-tests
+
 t{ -1 u2/  dup 1+ u< -> -1 }t
 t{ -1 u2/  10 +  dup 10 + u< -> -1 }t
 
+end-tests
 
 : rshift ( x u -- ) BEGIN ?dup WHILE swap u2/ swap 1-  REPEAT ;
 
@@ -163,20 +194,27 @@ t{ 1 3 lshift -> 8 }t
 \ t{ 48 3 rshift -> 6 }t
 
 : <> ( x1 x2 -- f ) = 0= ;
+
+begin-tests
 t{ 3 3 <> -> 0 }t
 t{ 'x' 'u' <> -> -1 }t
-
+end-tests
 
 : pick ( xn ... xi ... x0 i -- xn ... xi ... x0 xi )
     1+ cells sp@ + @ ;
+
+begin-tests
 t{ 10 20 30 1 pick ->  10 20 30 20 }t
+end-tests
 
 : recursive ( -- )  reveal ; immediate
 
 : roll ( xn-1 ... x0 i -- xn-1 ... xi-1 xi+1 ... x0 xi )
     recursive ?dup IF swap >r 1- roll r> swap THEN ;
 
+begin-tests
 t{ 10 20 30 1 roll ->  10 30 20 }t
+end-tests
 
 | Variable (to) (to) off
 
@@ -187,19 +225,25 @@ t{ 10 20 30 1 roll ->  10 30 20 }t
 
 : to ( x <name> -- )  (to) on ;
 
+begin-tests
+
 5 Value val
 t{ val  42 to val  val -> 5 42 }t
 
+end-tests
 
 :  within ( test low high -- flag ) 
      over - >r - r>  u<  ;
 
+begin-tests
+
 t{ 2 3 5 within -> false }t
 t{ 3 3 5 within -> true }t
 t{ 4 3 5 within -> true }t
 t{ 5 3 5 within -> false }t
 t{ 6 3 5 within -> false }t
 
+end-tests
 
 : n' parse-name find-name ;
 
@@ -217,15 +261,23 @@ cr .( ② )
     dup 0= IF drop 1 exit THEN
     dup 1- fac * ;
 
+begin-tests
+
 t{ 6 fac -> 720 }t
 
+end-tests
+
 : fib ( n1 -- n2 ) recursive
     dup 0=  IF exit THEN
     dup 1 = IF exit THEN
     dup 1- fib  swap 2 - fib + ;
 
+begin-tests
+
 t{ 10 fib -> 55 }t
 
+end-tests
+
 : sqr ( u -- u^2 )  dup * ;
 
 : u/ ( u1 u2 -- u3 )  >r 0 r> um/mod nip ;
@@ -241,15 +293,22 @@ t{ 10 fib -> 55 }t
     UNTIL ( xi xi+1 )
     drop r> drop ;
 
+begin-tests
+
 t{ 15 sqrt -> 3 }t
 t{ 16 sqrt -> 4 }t
 
+end-tests
+
 : pyth ( a b -- c )
     swap sqr  swap sqr  + sqrt ;
 
+begin-tests
+
 t{ 3 4 pyth -> 5 }t
 t{ 65535 dup * sqrt -> 65535 }t
 
+end-tests
 
 
 \ remove headers from dictionary
@@ -294,6 +353,7 @@ cr .( ③ )
 : public ( -- ) heads on ;
 : end-package ( -- ) remove-headers ;
 
+begin-tests
 
 package test
   : a ." a" ;
@@ -309,6 +369,8 @@ t{ s( ab)  s( abc) compare -> -1 }t
 t{ s( abc) s( def)  compare -> -1 }t
 t{ s( def) s( abc)  compare -> 1 }t
 
+end-tests
+
 : Defer ( <name> -- )
     Create 0 , Does> @ execute ;
 
@@ -321,11 +383,11 @@ Defer %defer  ' %defer >body 2 cells -  @  Constant dodefer
     >body 1 cells -  r@ !
     [ ' exit ] Literal >body 1 cells - r> cell+ ! ;
 
-: dp! ( addr -- )  here - allot ;
-
 : backpatch ( xt1 xt2 -- ) 
     here >r  >body dp!  compile,  postpone exit  r> dp! ;
 
+begin-tests
+
 : hallo ." original" ;
 : moin hallo hallo ;
 
@@ -333,7 +395,7 @@ Defer %defer  ' %defer >body 2 cells -  @  Constant dodefer
 
 ' abc ' hallo backpatch
 
-
+end-tests
 
 
 : FOR ( n -- )
@@ -825,28 +887,21 @@ cr .( How would conditional compilation work in tokenized form? )
 \     postpone -
 \     postpone IF  postpone DO ; immediate
 
+begin-tests
+
 t{ : dotest   10 0 DO I LOOP ;  dotest -> 0 1 2 3 4 5 6 7 8 9 }t
 
+end-tests
+
 : unloop ( -- )  
    postpone r>  postpone drop 
    postpone r>  postpone drop ; immediate
 
-\ save and empty (need HP)  single wordlist only no string header reclaim
-\ not really valid in seedForth as the tokenizer would not know how to reset 
-\ token indices. Make SAVE and EMPTY special in the tokenizer?
-\ HEAD the start of seedForth header table is not required. 
-\ DP is not required as it can be read via HERE and set via ALLOT (see DP!) 
-
-: !+ ( x addr -- addr' )  swap over ! cell+ ;
-: @+ ( addr -- x addr' )  dup @ swap cell+ ;
-
-| Create savearea  0 , 0 , 0 ,
-
-: save ( -- )  here  hp @   forth-wordlist @   savearea !+ !+ ! ;
-: empty ( -- )  savearea @+ @+ @ dp! hp ! forth-wordlist ! ;
-
 save
 
 : remove-with-empty ; \ remove with empty
 
+cr 
+empty clear
+
 echo on cr cr .( Welcome! ) input-echo on

diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs
index 8f8650a..3cbd559 100644 (file)
--- a/preForth/seedForth-tokenizer.fs
+++ b/preForth/seedForth-tokenizer.fs
@@ -268,3 +268,13 @@ end-macro
 Macro seed ( <name> -- )
    postpone seed
 end-macro
+
+Macro save-#tokens
+   postpone #tokens
+   postpone @
+end-macro
+
+Macro restore-#tokens
+   postpone #tokens
+   postpone !
+end-macro
\ No newline at end of file

diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource
index 1b4735b..089137f 100644 (file)
--- a/preForth/seedForthInteractive.seedsource
+++ b/preForth/seedForthInteractive.seedsource
@@ -176,6 +176,33 @@ Variable frame ( -- addr )
 
 \ tests: see later when ' is defined
 
+\ save and empty
+
+Create savearea 0 , 0 ,  \ { hp | dp }
+
+: (save) ( -- )
+    here  hp @  savearea 2! ;
+
+Macro save ( -- )
+  seed (save)
+  save-#tokens
+end-macro
+
+: (empty) ( -- )
+    savearea 2@  hp !  here - allot ( aka dp! ) ; 
+
+Macro empty ( -- )
+  seed (empty)
+  restore-#tokens
+end-macro
+
+save
+
+: three 3 ;
+
+empty
+
+
 \ Tester 
 : empty-stack ( i*x -- )
     BEGIN depth 0< WHILE  0    REPEAT
@@ -200,6 +227,16 @@ Variable actual-depth  ( actual-results )  20 cells allot
    depth actual-depth @ - IF  s" wrong number of results" error  exit THEN
    BEGIN depth WHILE  depth nth-result @ - IF  s" incorrect result" error  exit THEN  REPEAT ;
 
+Macro begin-tests 
+   seed save
+end-macro
+
+Macro end-tests
+   seed empty
+end-macro
+
+
+begin-tests
 \ Test basics
 t{ 10 '*' + ->  52 }t
 t{ 0 0< -> 0 }t
@@ -261,11 +298,15 @@ t{ 10 -10 < -> 0 }t
 t{ 10 -1000 < -> 0 }t
 t{ 1000 -10 < ->  0 }t
 
+end-tests
+
 : minint ( -- n )
    1 BEGIN dup 2* dup WHILE nip REPEAT drop ;
 
 minint 1- Constant maxint
 
+begin-tests
+
 t{ minint negate -> minint }t
 t{ minint maxint < -> -1 }t
 t{ maxint minint < -> 0  }t
@@ -275,6 +316,8 @@ t{ 1 0 u< -> 0 }t
 t{ -1 0 u< -> 0 }t
 t{ 0 -1 u< -> -1 }t
 
+end-tests
+
 : skip ( c-addr1 u1 c -- c-addr2 u2 )
    BEGIN
      over
@@ -307,6 +350,7 @@ t{ 0 -1 u< -> -1 }t
 : .s ( i*x -- i*x )  
     depth 0= ?exit  >r .s r> dup . ;
 
+
 \ Deferred words
 
 : ' ( --  x )  token ;
@@ -324,6 +368,7 @@ Definer Defer ( <name> -- )
     ' >body ! ;
 
 \ catch and throw tests
+begin-tests
 
 t{ 10 ' dup catch  -> 10 10 0 }t
  
@@ -332,6 +377,7 @@ t{ 10 ' dup catch  -> 10 10 0 }t
 t{ 1 ' err99 catch -> 2 0 }t
 t{ 5 9 ' err99 catch nip ->  5 99 }t
 
+end-tests
 
 \ String comparison
 : compare ( c-addr1 u1 c-addr2 u2 -- n )
@@ -761,9 +807,6 @@ end-macro
 ' _xt         has-header _xt
 
 
-
-
-
 Macro :noname
    seed new
    seed compiler