Add abort, abort" and too probably too simple DO LOOP I unloop,

diff --git a/preForth/hi.forth b/preForth/hi.forth
index 624ffa0..92afbc9 100644 (file)
--- a/preForth/hi.forth
+++ b/preForth/hi.forth
@@ -626,8 +626,8 @@ Variable counter  0 counter !
 
 : .counter ( -- )  
     BEGIN 
-       ctr
-       BEGIN pause ctr  over - UNTIL drop
+       ctr BEGIN pause ctr  over - UNTIL drop
+       \ 100 FOR  pause  NEXT 
        save-cursor-position blue reverse   
        11 status-line dup 1 = IF 1- THEN at-xy
        ctr 3 rshift 7 and .emoji  
@@ -678,7 +678,7 @@ 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
 
-+status
+\ +status
 
 | : ?:     dup 4 u.r ." :" ;                                    
 | : @?     dup @ 6 u.r ;                                        
@@ -787,6 +787,49 @@ cr .( ok: afterwords )
 cr .( How would conditional compilation work in tokenized form? )
 
 
+: abort ( -- )  -1 throw ;
+
+| : (abort") ( f c-addr u -- )  rot IF  errormsg 2! -2 throw THEN 2drop ;
+
+: abort" ( f -- ) 
+    postpone s" 
+    postpone (abort") ; immediate
+
+: abort"test ( -- )   dup abort" abort" ;
+
+: chars ; immediate
+
+: char+ 1+ ;
+
+' exit Alias EXIT
+
+: bounds ( addr count -- limit addr)  over + swap ;
+
+: DO ( to from -- )
+     postpone swap
+     postpone BEGIN
+     postpone >r postpone >r ; immediate
+
+: LOOP ( -- )
+     postpone r> 
+     postpone 1+ 
+     postpone r> 
+     postpone 2dup postpone = postpone UNTIL 
+     postpone 2drop ; immediate
+
+: I ( -- )
+     postpone r@ ; immediate
+
+\ : ?DO ( to from -- )
+\     postpone 2dup
+\     postpone -
+\     postpone IF  postpone DO ; immediate
+
+t{ : dotest   10 0 DO I LOOP ;  dotest -> 0 1 2 3 4 5 6 7 8 9 }t
+
+: unloop ( -- )  
+   postpone r>  postpone drop 
+   postpone r>  postpone drop ; immediate
 
 
 echo on cr cr .( Welcome! ) input-echo on

diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre
index 1ceda81..96d8a25 100644 (file)
--- a/preForth/seedForth-i386.pre
+++ b/preForth/seedForth-i386.pre
@@ -473,29 +473,29 @@ code usleep ( c -- )
     lit memtop  here - ;
 
 : cold ( -- )
-   's' emit 'e' dup emit emit  'd' emit 10 emit
-   lit bye         h, \ 0   00
-   0               h, \ 1   01 prefix
-   0               h, \ 2   02 prefix
-   lit emit        h, \ 3   03
-   lit key         h, \ 4   04
-   lit dup         h, \ 5   05
-   lit swap        h, \ 6   06
-   lit drop        h, \ 7   07
-   lit 0<          h, \ 8   08
-   lit ?exit       h, \ 9   09
-   lit >r          h, \ 10  0A
-   lit r>          h, \ 11  0B
-   lit -           h, \ 12  0C
-   lit exit        h, \ 13  0D
-   lit lit         h, \ 14  0E
-   lit @           h, \ 15  0F
-   lit c@          h, \ 16  10
-   lit !           h, \ 17  11
-   lit c!          h, \ 18  12
-   lit execute     h, \ 19  13
-   lit branch      h, \ 20  14
-   lit ?branch     h, \ 21  15
+   \ 's' emit 'e' dup emit emit  'd' emit 10 emit
+   lit bye         h, \ 0   00  code
+   0               h, \ 1   01  prefix
+   0               h, \ 2   02  prefix
+   lit emit        h, \ 3   03  code
+   lit key         h, \ 4   04  code
+   lit dup         h, \ 5   05  code
+   lit swap        h, \ 6   06  code
+   lit drop        h, \ 7   07  code
+   lit 0<          h, \ 8   08  code
+   lit ?exit       h, \ 9   09  code
+   lit >r          h, \ 10  0A  code
+   lit r>          h, \ 11  0B  code
+   lit -           h, \ 12  0C  code
+   lit exit        h, \ 13  0D  code
+   lit lit         h, \ 14  0E  code
+   lit @           h, \ 15  0F  code
+   lit c@          h, \ 16  10  code
+   lit !           h, \ 17  11  code
+   lit c!          h, \ 18  12  code
+   lit execute     h, \ 19  13  code
+   lit branch      h, \ 20  14  code
+   lit ?branch     h, \ 21  15  code
    lit negate      h, \ 22  16
    lit +           h, \ 23  17
    lit 0=          h, \ 24  18
@@ -514,24 +514,24 @@ code usleep ( c -- )
    lit create      h, \ 37  25
    lit does>       h, \ 38  26
    lit cold        h, \ 39  27
-   lit depth       h, \ 40  28
+   lit depth       h, \ 40  28  code
    lit compile,    h, \ 41  29
    lit new         h, \ 42  2A
    lit couple      h, \ 43  2B
-   lit and         h, \ 44  2C
-   lit or          h, \ 45  2D
-   lit sp@         h, \ 46  2E
-   lit sp!         h, \ 47  2F
-   lit rp@         h, \ 48  30
-   lit rp!         h, \ 49  31
+   lit and         h, \ 44  2C  code
+   lit or          h, \ 45  2D  code
+   lit sp@         h, \ 46  2E  code
+   lit sp!         h, \ 47  2F  code
+   lit rp@         h, \ 48  30  code
+   lit rp!         h, \ 49  31  code
    lit $lit        h, \ 50  32
    lit num         h, \ 51  33
-   lit um*         h, \ 52  34
-   lit um/mod      h, \ 53  35
+   lit um*         h, \ 52  34  code
+   lit um/mod      h, \ 53  35  code
    lit unused      h, \ 54  36
    lit key?        h, \ 55  37
    lit token       h, \ 56  38
-   lit usleep      h, \ 57  39
+   lit usleep      h, \ 57  39  code
    interpreter bye ;
 
 pre

diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource
index 1363b87..4e2ddad 100644 (file)
--- a/preForth/seedForthDemo.seedsource
+++ b/preForth/seedForthDemo.seedsource
@@ -45,7 +45,11 @@ Variable actual-depth  ( actual-results )  20 cells allot
 
 : }t ( i*x -- )
    depth actual-depth @ - IF  s" wrong number of results" error  exit THEN
-   BEGIN depth WHILE  depth nth-result @ - IF  s" incorrect result" error  exit THEN  REPEAT ;
+   BEGIN 
+     depth 
+   WHILE  
+      depth nth-result @ - IF  s" incorrect result" error  exit THEN
+   REPEAT ;
 
 \ Test basics
 t{ 10 '*' + ->  52 }t
@@ -94,7 +98,8 @@ t{ here 5 c, count -> here 5 }t
 
 \ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
 : u2/ ( x1 -- x2 )
-   0 8 cells 1-  BEGIN ?dup WHILE  >r 2*  over 0< IF 1+ THEN  >r 2* r> r> 1- REPEAT nip ;
+   0 8 cells 1-  
+   BEGIN ?dup WHILE  >r 2*  over 0< IF 1+ THEN  >r 2* r> r> 1- REPEAT nip ;
 
 : odd? ( x1 -- f )  dup u2/ 2* = 0= ;
 
@@ -183,6 +188,7 @@ t{ d1 d1 d1 -> five five five }t
 t{ 3 4 + -> 7 }t
 
 
+
 \ Test for sp!
 
 : rot ( a b c -- b c a )  >r swap r> swap ;
@@ -226,7 +232,8 @@ t{ greeting nip -> 16 }t
     WHILE
       dup
     WHILE
-      >r >r  over c@ over c@ - ?dup IF 0< dup + 1  + nip nip r> drop r> drop exit THEN
+      >r >r  over c@ over c@ - 
+      ?dup IF 0< dup + 1  + nip nip r> drop r> drop exit THEN
       1+ swap 1+ swap
       r> 1- r> 1-
     REPEAT
@@ -304,7 +311,8 @@ t{ 1 5+ -> 6 }t
 
 \ Inlining Constant
 
-Definer iConstant ( x <name> -- )  create >r , ( immediate )  r> does> @  lit lit , , ;
+Definer iConstant ( x <name> -- )  
+  create >r , ( immediate )  r> does> @  lit lit , , ;
 
 \ improve: needs to define macro
 
@@ -393,4 +401,6 @@ t{ 60 5 a !  0 a @  1 a @  2 a @  3 a @  4 a @   5 a @  -> 10 20 30 40 50 60 }t
 \ cr  'd'  emit 'o'  emit 'n'  emit 'e'  emit cr
 
 \ hi
-END
\ No newline at end of file
+END
+
+

diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource
index 25c14a1..8a10de6 100644 (file)
--- a/preForth/seedForthInteractive.seedsource
+++ b/preForth/seedForthInteractive.seedsource
@@ -1116,7 +1116,14 @@ Defer .status   : noop ;  ' noop is .status
     cr ." ---------------------------" 
     cr unused . ." bytes free" cr ;
 
+Create errormsg  0 , 0 ,
+
+' errormsg has-header errormsg
+
 : .error# ( n -- )
+    dup  -1 = IF drop ." abort" exit THEN
+    dup  -2 = IF drop ." error: " 
+                 errormsg 2@ type 0 0 errormsg 2! exit THEN
     dup  -4 = IF drop ." stack underflow" exit THEN
     dup -13 = IF drop ." not found" exit THEN
     dup -16 = IF drop ." attempt to use zero-length string as a name" exit THEN
@@ -1152,6 +1159,7 @@ t{ -> }t
 
 
 0 echo !
+\ 0 input-echo !
 reveal
 boot
 END