Add high level multitasker and key?

diff --git a/preForth/TODO.md b/preForth/TODO.md
index 6ab809a..f8d3f07 100644 (file)
--- a/preForth/TODO.md
+++ b/preForth/TODO.md
@@ -8,14 +8,16 @@
 
 + | based on allocated headers
 
-+ packages � la swiftForth (currently based on headerless definitions)
++ packages � la swiftForth (currently based on headerless definitions) with vocabularies
 
 - dual xt headers
 
-- high level multi tasker definitions
++ high level multi tasker definitions
 
 - more Standard words (at least CORE words w/ exceptions such as BASE STATE)
 
+- Divison SM/REM FM/MOD ...
+
 - umbilical Block-Interface
 
 - file interface open-file read read-line write close-file
@@ -92,5 +94,6 @@
 
 - generalize linked list handling (map/filter)
 
++ key? and raw-terminal
 
 

diff --git a/preForth/hi.forth b/preForth/hi.forth
index d8c54db..9ed80bb 100644 (file)
--- a/preForth/hi.forth
+++ b/preForth/hi.forth
@@ -1,4 +1,5 @@
 0 echo !
+0 input-echo !
 
 cr .( ⓪ )
 
@@ -221,14 +222,6 @@ t{ 4 3 5 within -> true }t
 t{ 5 3 5 within -> false }t
 t{ 6 3 5 within -> false }t
 
-Variable up
-
-: User ( x -- )
-    Create cells , Does> @ up @ + ;
-
-0 User u1
-1 User u2
-2 User u3
 
 : n' parse-name find-name ;
 
@@ -419,6 +412,20 @@ Variable voc-link  0 voc-link !
 
 : cntd ( n -- ) ?dup 0= ?exit dup . 1- recurse '.' emit ;
 
+\ division / /mod  fm/mod sm/rem mod
+
+: s>d ( n -- d )  dup 0< ;
+
+: dnegate ( d1 -- d2 )  ;   \ define w/o carry
+
+: sm/rem ( d1 n1 -- n2 n3 ) ;
+    
+
+t{  10 s>d  3  sm/rem ->   1  3 }t
+t{ -10 s>d  3  sm/rem ->  -1 -3 }t
+t{  10 s>d -3  sm/rem ->   1 -3 }t
+t{ -10 s>d -3  sm/rem ->  -1  3 }t
+
 
 \ number output:  <# # #s #> sign hold holds base . u. .r u.r
 
@@ -460,28 +467,45 @@ Variable hld
 : u.r ( u l -- )  >r (u.) r> over - 0 max spaces type ;
 
 : at-xy ( u1 u2 -- ) \ col row
-    esc ." [" 1+  0 u.r ." ;" 1+ 0 u.r ." H" ;
+    base @ >r decimal
+    esc ." [" 1+  0 u.r ." ;" 1+ 0 u.r ." H" 
+    r> base ! ;
 
 \ : at? CSI 6n 
 
 : clreol ( -- )
     esc ." [K" ;
 
+: scroll-up ( -- )
+    esc ." [S" ;
+
 : save-cursor-position ( -- ) 27 emit '7' emit ;
 : restore-cursor-position  ( -- ) 27 emit '8' emit ;
 
+0 Value status-line
+132 Value terminal-width
+
 : show-status ( -- )
-   save-cursor-position reverse
-   base @ >r decimal 
-   0 1 at-xy  clreol  80 spaces  0 1 at-xy  
-     ."  seedForth 😉 "
+   status-line IF scroll-up THEN
+   save-cursor-position blue reverse
+   base @ >r decimal
+   0 status-line 1 max at-xy  ( clreol ) terminal-width spaces  
+   0 status-line 1 max at-xy  
+     ."  seedForth 😉     "
+     ." | free: " unused u.
      ." | order: " order  
      ." | base: "  r@ . 
-     ." | stack: " .s  
+     ." | " depth 0= IF ." ∅" ELSE .s THEN  
    r> base !
-   normal restore-cursor-position ;
+   normal restore-cursor-position
+   status-line 0= ?exit
+   0 status-line 1 - at-xy clreol
+   0 status-line 2 - at-xy 
+;
+
+: +status ( -- ) [ ' show-status ] Literal  [ ' .status >body ] Literal ! ;
+: -status ( -- ) [ ' noop ] Literal  [ ' .status >body ] Literal ! ;
 
-' show-status ' .status >body !
 
 only Forth also definitions
 Vocabulary root
@@ -498,7 +522,7 @@ root definitions
 : also also ;
 : bye bye ;
 
-only Forth also definitions order
+only Forth also definitions
 
 : mod ( u1 u2 -- u3 ) 0 swap um/mod drop ;
 
@@ -519,5 +543,119 @@ only Forth also definitions order
 
 cr cr cr .( The ) 10001 dup . .( st prime is ) th.prime . 
 
+
+\ cooperative multi tasker
+\ -------------------------
+
+Variable up  \ user pointer
+
+: up@ ( -- x ) up @ ;
+: up! ( x -- ) up ! ;
+
+: User ( x -- )
+    Create , Does> @ up@ + ;
+
+0
+1 cells over + swap User task-state
+1 cells over + swap User task-link
+1 cells over + swap User sp-save
+1 cells over + swap User rp-save
+
+Constant task-size
+
+: pause ( -- )
+    rp@  rp-save !  sp@ sp-save !
+    BEGIN task-link @ up! task-state @ UNTIL
+    sp-save @ sp!  rp-save @ rp! ;   
+
+Create operator 
+   true ,      \ task-state
+   operator ,  \ task-link to itself
+   0 ,         \ sp-save
+   0 ,         \ rp-save
+
+operator up!
+
+
+: task ( stacksize rstacksize -- tid )
+    here >r
+    0 , ( task-state ) 
+    task-link @ , r@ task-link !
+    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 ;
+: stop ( -- ) up@ sleep pause ;
+
+: task-push ( x tid -- ) \ push x on tids stack
+    2 cells + ( sp_save )  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> !  !
+;
+
+: (activate) ( xt -- )
+    pause execute stop ;
+
+: activate ( xt tid -- )
+    \ put xt on stack of tid
+    dup >r  task-push
+    \ put (activate)'s body on return stack
+    [ ' (activate) >body ] Literal  r@ task-rpush
+    r> wake
+;
+
+100 cells 100 cells  task Constant t1
+
+Variable counter  0 counter !
+: do-counter ( -- )  
+   BEGIN  1 counter +!  pause AGAIN ;
+
+' do-counter  t1 activate
+
+\ : multi-key ( -- c )
+\    BEGIN pause key? UNTIL key ;
+
+100 cells 100 cells task Constant counter-display
+
+: ctr ( -- x ) counter @ 13 rshift ;
+
+: .emoji ( n -- )
+    0 OF ." 😀" exit THEN
+    1 OF ." 😃" exit THEN
+    2 OF ." 😄" exit THEN
+    3 OF ." 😆" exit THEN
+    4 OF ." ☺️" exit THEN
+    5 OF ." 😊" exit THEN
+    6 OF ." 🙂" exit THEN
+    7 OF ." 😉" exit THEN ;
+
+: .counter ( -- )  
+    BEGIN 
+       ctr
+       BEGIN pause ctr  over - UNTIL drop
+       save-cursor-position blue reverse   
+       11 status-line dup 1 = IF 1- THEN at-xy
+       ctr 3 rshift 7 and .emoji  
+       14 status-line dup 1 = IF 1- THEN at-xy 
+       ctr 0 999 um/mod drop 3 u.r
+       normal restore-cursor-position
+    AGAIN ;
+' .counter counter-display activate
+
+: 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
+
 echo on
+input-echo on
 

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index f488b13..6c49bf0 100644 (file)
--- a/preForth/seedForth-i386.pre
+++ b/preForth/seedForth-i386.pre
@@ -25,10 +25,10 @@ section '.bss' executable writable
 
        DD 10000 dup(0)
 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
@@ -37,8 +37,6 @@ _dp:    DD _start  ; dictionary pointer: points to next free location in memory
 _hp:    DD 0       ; head pointer: index of first unused head
 _head:  DD 10000 dup (0)
 
-
-
 section '.text' executable writable align 4096
 
 public main 
@@ -47,6 +45,7 @@ extrn getchar
 extrn fflush
 extrn exit
 extrn mprotect
+extrn ioctl
   
 macro next  {
        lodsd
@@ -150,11 +149,35 @@ code key ( -- c )
         pop ebp
         cmp eax,-1
         jnz key1
-        mov eax,4
+        mov eax,4   ; eof: return Ctrl-D 
 key1:   push eax
         next
 ;
 
+code key? ( -- f )
+       push ebp  
+       mov  ebp, esp
+       and  esp, 0xfffffff0
+       sub  esp, 32
+
+       mov dword [esp], 0
+       mov dword [esp+4], 1074030207 ; FIONREAD
+       lea dword eax, [esp+24]
+       mov dword [esp+8], eax
+
+       call ioctl
+       mov dword eax, [esp+24]
+
+       mov esp, ebp
+       pop ebp
+
+       cmp eax, 0
+       jz keyq1
+       mov eax, -1
+keyq1: push eax
+       next
+;
+
 code dup ( x -- x x )
         pop eax
         push eax
@@ -288,7 +311,7 @@ code ?branch ( f -- ) \ threaded code:  ?exit r> @ >r ;
         pop eax
         or eax,eax
         jz _branchX
-       lea esi,[esi+4]
+             lea esi,[esi+4]
         next
 ;
 
@@ -489,10 +512,11 @@ code um/mod ( ud u1 -- u2 u3 )
    lit um*         h, \ 52  34
    lit um/mod      h, \ 53  35
    lit unused      h, \ 54  36
+   lit key?        h, \ 55  37
    interpreter bye ;
 
 pre
  _start: DB 43
-        DD 10000 dup (0)
+        DD 100000 dup (0)
  _memtop: DD 0
 ;

diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs
index bc65150..01bf681 100644 (file)
--- a/preForth/seedForth-tokenizer.fs
+++ b/preForth/seedForth-tokenizer.fs
@@ -72,7 +72,7 @@ Variable #tokens  0 #tokens !
 ( 40 $28 ) Token new       Token couple        Token and        Token or
 ( 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
+( 52 $34 ) Token um*       Token um/mod        Token unused     Token key?
 
 \ generate token sequences for numbers
 

diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource
index f8f1bf6..74161f1 100644 (file)
--- a/preForth/seedForthInteractive.seedsource
+++ b/preForth/seedForthInteractive.seedsource
@@ -106,7 +106,7 @@ Definer Field ( offset size <name> -- offset' )
 32 Constant bl
 
 : cr ( -- ) 
-    10 emit ;
+    10 emit 13 emit ;
 
 : type ( c-addr u -- )
     BEGIN dup WHILE  over c@ emit  1  /string  REPEAT  2drop ;
@@ -450,15 +450,26 @@ Create tib 80 allot
 Create 'source here 0 , tib ,  \ ' source is normally  ^tib #tib is set to c-addr u for evaluate
 Constant #tib
 
+Defer getkey   ' key is getkey
+
+\ : getkey key ;
+
+Variable input-echo -1 input-echo !
+
 : accept ( c-addr u1 -- u2 )
     >r
     0 BEGIN ( c-addr u2 ) ( R: u1 )
-        key dup 10 = over 13 = or 0=
+        getkey dup 10 = over 13 = or 0=
     WHILE ( c-addr u2 key )
-        dup  8 = over 127 = or IF  drop 1- 0 max  8 emit bl emit 8 emit ELSE
-        ( dup emit ) >r 2dup + r> swap c!  1+ r@ min THEN
+        dup  8 = over 127 = or 
+           IF  drop dup 0 > 
+               IF 1-  8 emit bl emit 8 emit ELSE 7 emit THEN ELSE
+        input-echo @ IF dup emit THEN >r 2dup + r> swap c!  1+ r@ min THEN
     REPEAT ( c-addr u2 key r:u1 )
-    drop  r> drop   nip ;
+    drop  r> drop   nip  
+    \ input-echo @ IF cr THEN
+    input-echo @ IF space THEN 
+;
 
 : query ( -- )
     tib 80 accept #tib ! ;
@@ -513,8 +524,8 @@ Definer Header-flag? ( x <name> -- )
 
 : wordlist ( -- wid )  here 0 , ;
 
-: under+ ( x1 x2 x3 -- x1+x3 x2 )  rot + swap ;
-: tuck ( x1 x2 -- x2 x1 x2 )  swap over ;
+\ : under+ ( x1 x2 x3 -- x1+x3 x2 )  rot + swap ;
+\ : tuck ( x1 x2 -- x2 x1 x2 )  swap over ;
 
 Create search-order  0 , 10 cells allot
 
@@ -744,6 +755,8 @@ end-macro
 ' only        has-header only
 \ ' OnlyForth   has-header OnlyForth
 ' .wordlist   has-header .wordlist
+' key?        has-header key?
+' getkey      has-header getkey
 
 \ ' "header     has-header "header
 \ ' link        has-header link
@@ -1040,9 +1053,10 @@ Variable handlers        interpreters @ handlers !
 ' evaluate has-header evaluate
 
 Variable echo  -1 echo !
-
 ' echo has-header echo
 
+' input-echo has-header input-echo
+
 \ ANSI terminal colors
 
 : esc ( -- ) 27 emit ;               ' esc has-header esc
@@ -1067,6 +1081,8 @@ Variable echo  -1 echo !
 
 Defer .status   : noop ;  ' noop is .status
 
+' noop has-header noop
+
 ' .status has-header .status
 
 : prompt ( -- )
@@ -1084,7 +1100,7 @@ Defer .status   : noop ;  ' noop is .status
    tib 0 'source 2!
    ([)
    BEGIN
-     .status prompt query  0 >in !  interpret  ?stack .ok
+     .status  prompt query  0 >in !  interpret  ?stack .ok
    0 UNTIL ;
 
 : warm ( -- )
@@ -1092,7 +1108,6 @@ Defer .status   : noop ;  ' noop is .status
    empty-stack restart ;
 
 
-
 2 Constant major ( -- x )
 1 Constant minor ( -- x )
 0 Constant patch ( -- x )
@@ -1128,26 +1143,14 @@ Defer .status   : noop ;  ' noop is .status
 ' boot has-header boot
 
 \ ---- try colored words with embedded ESC sequences
-Create colored-header here 0 c, here 
-   27 c,  '[' c,  '3' c, '1' c, 'm' c,  'r' c, 'e' c, 'd' c, 'w' c, 'o' c, 'r' c, 'd' c,
-   27 c,  '[' c,  '3' c, '9' c, ';' c,  '4' c, '9' c, 'm' c,
-here swap - swap c!
+\ Create colored-header here 0 c, here 
+\    27 c,  '[' c,  '3' c, '1' c, 'm' c,  'r' c, 'e' c, 'd' c, 'w' c, 'o' c, 'r' c, 'd' c,
+\    27 c,  '[' c,  '3' c, '9' c, ';' c,  '4' c, '9' c, 'm' c,
+\ here swap - swap c!
 
-colored-header count "header dup link-header
+\ colored-header count "header dup link-header
 \ --------
 
-Macro ninelit
-  seed lit
-  seed [
-  9
-  seed ,
-  seed ]
-end-macro
-
-: nine  ninelit ;
-
-' nine has-header nine
-
 cr
 t{ -> }t