Add usleep, timeout in multitasker, interactive decompiler, dump

diff --git a/preForth/hi.forth b/preForth/hi.forth
index 4136a99..d360a33 100644 (file)
--- a/preForth/hi.forth
+++ b/preForth/hi.forth
@@ -597,6 +597,8 @@ operator up!
     r> wake
 ;
 
+: ms ( u -- )  1000 * usleep ;
+
 100 cells 100 cells  task Constant t1
 
 Variable counter  0 counter !
@@ -607,7 +609,7 @@ Variable counter  0 counter !
 
 100 cells 100 cells task Constant counter-display
 
-: ctr ( -- x ) counter @ 13 rshift ;
+: ctr ( -- x ) counter @ 8 rshift ;
 
 : .emoji ( n -- )
     0 OF ." 😀" exit THEN
@@ -632,7 +634,9 @@ Variable counter  0 counter !
     AGAIN ;
 ' .counter counter-display activate
 
-: multikey ( -- c)  BEGIN pause key? UNTIL key ;
+1000 Value cycle-time
+
+: multikey ( -- c) BEGIN pause key? 0= WHILE  cycle-time usleep  REPEAT key ;
 
 : multi ( -- ) [ ' multikey ] Literal [ ' getkey >body ] Literal ! ;
 : single ( -- ) [ ' key ] Literal [ ' getkey >body ] Literal ! ;
@@ -673,4 +677,77 @@ t{ 916 pad u8!+   pad -   pad c@  pad 1+ c@ -> 2 206 148 }t
 
 +status
 
+| : ?:     dup 4 u.r ." :" ;                                    
+| : @?     dup @ 6 u.r ;                                        
+| : c?     dup c@ 6 u.r ;
+| : ?:@?   ?: 4 spaces @? ;
+| : >#     spaces u. ;                                      
+                                                                
+: s ( adr - adr+1 ) \ string                                           
+    ?: 4 spaces c? 2 spaces  dup 1+ over c@ type  dup c@ + 1+ ; 
+                                                          
+: .name ( name -- ) ?dup IF count type exit THEN ." ???" ;
+
+: n ( adr - adr' )  \ name
+     ?:@? 2 spaces  dup @ addr>name .name cell+ ;
+
+: d ( adr n - adr+n )  \ dump                                        
+     2dup swap ?:  swap  FOR c? 1+ NEXT  2 spaces  -rot type ;     
+                                                                
+: l ( adr - adr' )  ?:   dup @ 12 ># cell+ ;  \ cell     
+: c ( adr - adr+1)  1 d ;                     \ character       
+: b ( adr - adr')   ?:@? dup @  2 ># cell+ ;  \ branch, could be relative
+                                                                
+cr .( Interactive decompiler: User single letter commands n d l c b s ) cr
+
+\ Dump utility
+
+| : .hexdigit ( x -- )
+     dup 10 < IF '0' + ELSE  10 - 'A' + THEN emit ;  
+
+| : .hex ( x -- )
+     dup 240 and  4 rshift .hexdigit   15 and .hexdigit ; 
+
+| : .addr ( x -- )
+     ?dup 0= ?exit dup 8 rshift  recurse  .hex ;
+
+| : b/line ( -- x )
+     16 ;
+
+| : .h ( addr len -- )
+   b/line min dup >r
+   BEGIN \ ( addr len )
+     dup
+   WHILE \ ( addr len )
+     over c@ .hex space  1 /string
+   REPEAT 2drop
+   b/line r> - 3 * spaces ; 
+
+| : .a ( addr1 len1 -- )
+     b/line min
+     BEGIN \ ( addr len )
+       dup
+     WHILE 
+       over c@ dup 32 < IF drop '.' THEN emit
+       1 /string
+     REPEAT 2drop ;
+
+| : dump-line ( addr len1 -- addr len2 )
+     over .addr ':' emit space   2dup .h space space  2dup .a 
+     dup  b/line  min /string 
+;
+
+
+: dump ( addr len -- )
+   BEGIN
+     dup
+   WHILE \ ( addr len )
+     cr dump-line 
+   REPEAT 2drop ;  
+                                  
+
+
+
+
+
 echo on cr cr .( Welcome! ) input-echo on

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index 801a0e2..1ceda81 100644 (file)
--- a/preForth/seedForth-i386.pre
+++ b/preForth/seedForth-i386.pre
@@ -44,6 +44,7 @@ extrn fflush
 extrn exit
 extrn mprotect
 extrn ioctl
+extrn usleep
   
 macro next  {
        lodsd
@@ -362,6 +363,23 @@ code um/mod ( ud u1 -- u2 u3 )
         next
 ;
 
+code usleep ( c -- )
+    pop eax
+
+    push ebp  
+    mov  ebp, esp
+    push eax 
+    and  esp, 0xfffffff0
+
+    mov dword [esp], eax
+    call usleep
+
+    mov esp, ebp  
+    pop ebp  
+    next
+;
+
+
 : negate ( n1 -- n2 )
    0 swap - ;
 
@@ -513,6 +531,7 @@ code um/mod ( ud u1 -- u2 u3 )
    lit unused      h, \ 54  36
    lit key?        h, \ 55  37
    lit token       h, \ 56  38
+   lit usleep      h, \ 57  39
    interpreter bye ;
 
 pre

diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs
index 85f2ec2..cc9d000 100644 (file)
--- a/preForth/seedForth-tokenizer.fs
+++ b/preForth/seedForth-tokenizer.fs
@@ -76,7 +76,7 @@ Variable #tokens  0 #tokens !
 ( 44 $2C ) Token and       Token or            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?          
-( 56 $38 ) Token token
+( 56 $38 ) Token token     Token usleep
 
 \ generate token sequences for numbers
 

diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource
index 670350d..981b9e9 100644 (file)
--- a/preForth/seedForthInteractive.seedsource
+++ b/preForth/seedForthInteractive.seedsource
@@ -755,6 +755,10 @@ end-macro
 ' link-header has-header link-header
 ' _xt         has-header _xt
 
+
+' usleep has-header usleep
+
+
 Macro :noname
    seed new
    seed compiler
@@ -863,6 +867,36 @@ Variable heads -1 heads !
 
 ' find-name has-header find-name
 
+: find-xt-in ( xt wid -- header | 0 )
+    BEGIN
+       dup
+    WHILE ( xt wid )
+       2dup _xt @ = IF nip exit THEN
+       _link @
+    REPEAT ( xt wid )
+    2drop 0 ;
+
+: >name ( xt -- name | 0 )
+    get-order over >r set-order r> find-xt-in dup IF _name THEN ;
+
+' >name has-header >name
+
+: find-addr-in ( xt wid -- header | 0 )
+    BEGIN
+       dup
+    WHILE ( xt wid )
+       2dup _xt @ h@ = IF nip exit THEN
+       _link @
+    REPEAT ( xt wid )
+    2drop 0 ;
+
+: addr>name ( xt -- name | 0 )
+    get-order over >r set-order r> find-addr-in dup IF _name THEN ;
+
+' addr>name has-header addr>name
+
+
+
 : Alias ( xt <name> -- )
    parse-name "header dup link-header _xt ! ;
 
@@ -981,7 +1015,7 @@ Variable handlers        interpreters @ handlers !
 ' heads has-header heads
 
 : interpret ( -- )
-   BEGIN ( )
+   BEGIN ( ) 
       parse-name dup
    WHILE ( c-addr u )
       handlers @ execute 2drop