Extend mutit tasker for catch and throw, export frame pointer from kernel, utf8 ...

diff --git a/preForth/hi.forth b/preForth/hi.forth
index 9ed80bb..40bfc56 100644 (file)
--- a/preForth/hi.forth
+++ b/preForth/hi.forth
@@ -555,22 +555,27 @@ Variable up  \ user pointer
 : User ( x -- )
     Create , Does> @ up@ + ;
 
+: his ( task addr -- ) up@ - + ;
+
 0
 1 cells over + swap User task-state
 1 cells over + swap User task-link
+1 cells over + swap User error#
 1 cells over + swap User sp-save
 1 cells over + swap User rp-save
+1 cells over + swap User frame-save
 
 Constant task-size
 
 : pause ( -- )
-    rp@  rp-save !  sp@ sp-save !
+    rp@  rp-save !  sp@ sp-save ! frame @ frame-save !
     BEGIN task-link @ up! task-state @ UNTIL
-    sp-save @ sp!  rp-save @ rp! ;   
+    sp-save @ sp!  rp-save @ rp! frame-save @  frame ! ;   
 
 Create operator 
    true ,      \ task-state
    operator ,  \ task-link to itself
+   0 ,         \ error#
    0 ,         \ sp-save
    0 ,         \ rp-save
 
@@ -581,25 +586,26 @@ operator up!
     here >r
     0 , ( task-state ) 
     task-link @ , r@ task-link !
+    0 , ( error# )
     over  here + 2 cells + , ( sp-save )
     + dup here +   cell+ ,   ( rp-save )
     allot              \ allocate stack and return stack
     r> ;
 
-: wake ( tid -- )  ( _task-state ) on ;
-: sleep ( tid -- )  ( _task-state ) off ;
+: wake ( tid -- )   task-state his on ;
+: sleep ( tid -- )  task-state his off ;
 : stop ( -- ) up@ sleep pause ;
 
 : task-push ( x tid -- ) \ push x on tids stack
-    2 cells + ( sp_save )  dup >r @  1 cells -  dup r> !  !
+   sp-save his  dup >r @  1 cells -  dup r> !  !
 ;
 
 : task-rpush ( x tid -- ) \ push x on tids return-stack
-    3 cells + ( rp_save )  dup >r @  1 cells -  dup r> !  !
+    rp-save his  dup >r @  1 cells -  dup r> !  !
 ;
 
 : (activate) ( xt -- )
-    pause execute stop ;
+    catch  error# !  stop ;
 
 : activate ( xt tid -- )
     \ put xt on stack of tid
@@ -613,7 +619,7 @@ operator up!
 
 Variable counter  0 counter !
 : do-counter ( -- )  
-   BEGIN  1 counter +!  pause AGAIN ;
+   BEGIN  1 counter +!  pause  AGAIN ;
 
 ' do-counter  t1 activate
 
@@ -647,14 +653,44 @@ Variable counter  0 counter !
     AGAIN ;
 ' .counter counter-display activate
 
-: multikey ( -- c)  BEGIN key? 0= WHILE pause REPEAT key ;
+: multikey ( -- c)  BEGIN key? 0= WHILE  pause  REPEAT key ;
 
 : multi ( -- ) [ ' multikey ] Literal [ ' getkey >body ] Literal ! ;
 : single ( -- ) [ ' key ] Literal [ ' getkey >body ] Literal ! ;
 
 : stars ( n -- )  ?dup IF  1- FOR '*' emit NEXT  THEN ;
 
-26 to status-line
+0 to status-line 
+cr .( Adjust your terminal to have ) status-line 1+ . .( lines.)
+
+-77 Constant UTF-8-err
+
+128 Constant max-single-byte
+ 
+: u8@+ ( u8addr -- u8addr' u )
+    count  dup max-single-byte u< ?exit  \ special case ASCII
+    dup 194 u< IF  UTF-8-err throw  THEN  \ malformed character
+    127 and  64 >r
+    BEGIN  dup r@ and  WHILE  r@ xor
+      6 lshift r> 5 lshift >r >r count
+      dup 192 and 128 <> IF   UTF-8-err throw  THEN
+      63 and r> or
+    REPEAT  r> drop ;
+ 
+: u8!+ ( u u8addr -- u8addr' )
+    over max-single-byte u< IF  swap over c! 1+  exit  THEN \ special case ASCII
+    >r 0 swap  63
+    BEGIN  2dup swap u<  WHILE
+      u2/ >r  dup 63 and 128 or swap 6 rshift r>
+    REPEAT  127 xor 2* or  r>
+    BEGIN   over 128 u< 0= WHILE  swap over c! 1+  REPEAT  nip ;
+ 
+cr s( Δ) 2dup type .(  has codepoint ) drop  u8@+ . drop
+
+cr 916 pad u8!+ pad swap over - type
+
+t{ s( Δ) drop u8@+ nip -> 916 }t
+t{ 916 pad u8!+   pad -   pad c@  pad 1+ c@ -> 2 206 148 }t
 
 echo on
 input-echo on

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index 6c49bf0..7d1ddb0 100644 (file)
--- a/preForth/seedForth-i386.pre
+++ b/preForth/seedForth-i386.pre
@@ -29,7 +29,7 @@ stck:  DD 16 dup(0)
        DD 10000 dup(0)
 rstck: DD 16 dup(0)
   
-_frame: DD 0 ; frame pointer for catch/throw
+_fp:   DD 0 ; frame pointer for catch/throw
 
 _dp:    DD _start  ; dictionary pointer: points to next free location in memory
         ; free memory starts at _start
@@ -446,11 +446,15 @@ code um/mod ( ud u1 -- u2 u3 )
     r>   swap h@  dup >r 1 cells - !   lit dodoes r> !
 ;
 
+: frame ( -- addr ) 
+    lit fp ;
+
 : 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 ;
+    frame @ >r  sp@ >r  rp@  frame !  execute    r> drop r> 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 ! ;
+    ?dup 0= ?exit  frame @ rp!  r> swap >r  sp! drop  r> r> frame ! ;
+
 
 : unused ( -- u )  
     lit memtop  here - ;
@@ -513,6 +517,7 @@ code um/mod ( ud u1 -- u2 u3 )
    lit um/mod      h, \ 53  35
    lit unused      h, \ 54  36
    lit key?        h, \ 55  37
+   lit frame       h, \ 56  38
    interpreter bye ;
 
 pre

diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs
index 01bf681..2d3df53 100644 (file)
--- a/preForth/seedForth-tokenizer.fs
+++ b/preForth/seedForth-tokenizer.fs
@@ -73,6 +73,7 @@ Variable #tokens  0 #tokens !
 ( 44 $2C ) Token catch     Token throw         Token sp@        Token sp!
 ( 48 $30 ) Token rp@       Token rp!           Token $lit       Token num
 ( 52 $34 ) Token um*       Token um/mod        Token unused     Token key?
+( 53 $35 ) Token frame
 
 \ generate token sequences for numbers
 

diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource
index 74161f1..089b15e 100644 (file)
--- a/preForth/seedForthInteractive.seedsource
+++ b/preForth/seedForthInteractive.seedsource
@@ -242,14 +242,14 @@ t{ 10 -10 < -> 0 }t
 t{ 10 -1000 < -> 0 }t
 t{ 1000 -10 < ->  0 }t
 
-: minint ( -- n )
-   1 BEGIN dup 2* dup WHILE nip REPEAT drop ;
+\ : minint ( -- n )
+\   1 BEGIN dup 2* dup WHILE nip REPEAT drop ;
 
-minint 1- Constant maxint
+\ minint 1- Constant maxint
 
-t{ minint negate -> minint }t
-t{ minint maxint < -> -1 }t
-t{ maxint minint < -> 0  }t
+\ t{ minint negate -> minint }t
+\ t{ minint maxint < -> -1 }t
+\ t{ maxint minint < -> 0  }t
 
 
 t{ 0 1 u< -> -1 }t
@@ -679,8 +679,8 @@ end-macro
 ' xor         has-header xor
 ' max         has-header max
 ' min         has-header min
-' minint      has-header minint
-' maxint      has-header maxint
+\ ' minint      has-header minint
+\ ' maxint      has-header maxint
 ' dispose     has-header dispose
 ' alloc       has-header alloc
 
@@ -757,6 +757,7 @@ end-macro
 ' .wordlist   has-header .wordlist
 ' key?        has-header key?
 ' getkey      has-header getkey
+' frame       has-header frame
 
 \ ' "header     has-header "header
 \ ' link        has-header link