Add tester to seedForth

diff --git a/preForth/Makefile b/preForth/Makefile
index ea9bc17..360e93d 100644 (file)
--- a/preForth/Makefile
+++ b/preForth/Makefile
@@ -75,7 +75,7 @@ preForth: preForth.$(UNIXFLAVOUR)
           /usr/lib/i386-linux-gnu/crt1.o /usr/lib/i386-linux-gnu/crti.o \
           $@.o \
           -lc /usr/lib/i386-linux-gnu/crtn.o
-       rm $@.o
+       # rm $@.o
 
 # assemble and link executable on MacOS
 %.Darwin: %.asm

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index e2f2fad..49fd358 100644 (file)
--- a/preForth/seedForth-i386.pre
+++ b/preForth/seedForth-i386.pre
@@ -272,6 +272,15 @@ code ?branch ( f -- ) \ threaded code:  ?exit r> @ >r ;
         next
 ;
 
+code depth ( -- n )
+        mov eax, stck
+        sub eax, esp
+        sar eax,2
+        push eax
+        next
+;
+
+
 : negate ( n1 -- n2 )
    0 swap - ;
 
@@ -375,6 +384,7 @@ code ?branch ( f -- ) \ threaded code:  ?exit r> @ >r ;
    lit create      h, \ 35  23
    lit does>       h, \ 36  24
    lit cold        h, \ 37  25
+   lit depth       h, \ 38  26
    tail interpreter ;
 
 pre

diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs
index 4058ec0..f9e0af8 100644 (file)
--- a/preForth/seedForth-tokenizer.fs
+++ b/preForth/seedForth-tokenizer.fs
@@ -32,7 +32,7 @@ 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                                                                               \ 24 25
+FUN: does>     FUN: cold        FUN: depth                             \ 24 25 26
 
 : [ ( -- )  0 SUBMIT ;
 : ] ( -- )  compiler ;

diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource
index e10a414..ab26ffc 100644 (file)
--- a/preForth/seedForthDemo.seedsource
+++ b/preForth/seedForthDemo.seedsource
@@ -239,11 +239,55 @@ cr d1 d1 d1 \ now display dashes
 
 cr 80 # stars
 
+\ Tester 
 
-?ok
-cr
+': empty-stack ( i*x -- )
+    BEGIN depth 0< WHILE    0 #, REPEAT
+    BEGIN depth    WHILE    drop REPEAT ;'
+
+variable actual-depth
+( actual-results )
+20 # cells allot
+
+': nth-result ( n -- addr )
+   cells actual-depth + ;'
+
+': error ( i*x c-addr u -- )
+   cr  type empty-stack ;'
+
+': t{ ( i*x -- )
+   empty-stack ;'
+
+': -> ( -- )
+   depth 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,
+
+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,
+
+
+': }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 ;'
+
+?ok 2drop
+
+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
 
-2drop
 
+cr  'd' # emit 'o' # emit 'n' # emit 'e' # emit cr
 
 end