Add catch/throw

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index a56d228..232153a 100644 (file)
--- a/preForth/seedForth-i386.pre
+++ b/preForth/seedForth-i386.pre
@@ -29,13 +29,16 @@ stck:  DD 16 dup(0)
        DD 10000 dup(0)
 rstck: DD 16 dup(0)
 
+_frame: DD 0 ; frame pointer for catch/throw
+
 _dp:    DD _start  ; dictionary pointer: points to next free location in memory
-       ; free memory starts at _start
+        ; free memory starts at _start
 
 _hp:    DD 0       ; head pointer: points to first unused head
 _head:  DD 10000 dup (0)
 
 
+
 section '.text' executable writable align 4096
 
 public main 
@@ -174,11 +177,8 @@ code drop ( x -- )
 
 code 0< ( x -- flag )
         pop eax
-        or eax, eax
-        mov eax, 0
-        jns zless1
-        dec eax
-zless1: push eax
+        sar eax,31
+        push eax
         next
 ;
 
@@ -250,9 +250,9 @@ code @ ( addr -- x )
 
 code c@ ( c-addr -- c )
         pop edx
-       xor eax, eax
+        xor eax, eax
         mov al,byte [edx]
-       push eax
+        push eax
         next
 ;
 
@@ -297,6 +297,25 @@ code depth ( -- n )
         next
 ;
 
+code sp@ ( -- x )
+        push esp
+        next
+;
+
+code sp! ( x -- )
+        pop esp
+        next
+;
+
+code rp@ ( -- x )
+        push ebp
+        next
+;
+
+code rp! ( x -- )
+        pop ebp
+        next
+;
 
 : negate ( n1 -- n2 )
    0 swap - ;
@@ -365,7 +384,14 @@ code depth ( -- n )
 
 : does> ( -- ) \ set code field of last defined word
     r>   lit hp @ 1 - h@  dup >r 1 cells - !   lit dodoes r> !
-; 
+;
+
+: catch ( i*x xt -- j*x 0 | i*x err )
+    lit frame @ >r  sp@ >r  rp@  lit frame !  execute    r> drop r> lit frame ! 0 ;
+
+: throw ( i*x 0 | i*x err -- j*x err )
+    ?dup 0= ?exit  lit frame @ rp!  r> swap >r  sp! drop  r> r> lit frame ! ;
+
 
 : cold ( -- )
    's' emit 'e' dup emit emit  'd' emit 10 emit
@@ -413,6 +439,12 @@ code depth ( -- n )
    lit +lit        h, \ 41  29
    lit and         h, \ 42  2A
    lit or          h, \ 43  2B
+   lit catch       h, \ 44  2C
+   lit throw       h, \ 45  2D
+   lit sp@         h, \ 46  2E
+   lit sp!         h, \ 47  2F
+   lit rp@         h, \ 48  30
+   lit rp!         h, \ 49  31
    tail interpreter ;
 
 pre

diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs
index 4d8075b..20ebab5 100644 (file)
--- a/preForth/seedForth-tokenizer.fs
+++ b/preForth/seedForth-tokenizer.fs
@@ -48,7 +48,9 @@ $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      
+$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!
 
 : [ ( -- )  0 SUBMIT ;
 : ] ( -- )  compiler ;

diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource
index 711a788..29bef6d 100644 (file)
--- a/preForth/seedForthDemo.seedsource
+++ b/preForth/seedForthDemo.seedsource
@@ -265,7 +265,7 @@ variable actual-depth
    cr  type empty-stack ;'
 
 ': t{ ( i*x -- )
-   empty-stack ;'
+   '.' #, emit empty-stack ;'
 
 ': -> ( -- )
    depth actual-depth !
@@ -290,7 +290,7 @@ fun: incorrect create ( -- addr )
 
 ?ok 2drop
 
-cr 't' # emit 'e' # emit 's' # emit 't' # emit  'i' # emit  'n' # emit 'g' # emit 
+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
@@ -318,6 +318,27 @@ t{ large -> 12340 # 5 # + }t
 ': negative -12345 #, ;'
 t{ negative -> -12340 # 5 # - }t
 
+t{ 10 #  ' dup catch  -> 10 # 10 # 0 # }t
+
+': 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
+
+': 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!  ;'
+
+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
+
 cr  'd' # emit 'o' # emit 'n' # emit 'e' # emit cr
 
 end