From: Ulrich Hoffmann Date: Sat, 14 Dec 2019 15:44:29 +0000 (+0100) Subject: Clean up X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=58e0c9a7eeb293e340ce2d10b56676d440113c16;p=preForth.git Clean up --- diff --git a/preForth/hi.forth b/preForth/hi.forth index fb80623..4136a99 100644 --- a/preForth/hi.forth +++ b/preForth/hi.forth @@ -3,7 +3,6 @@ cr .( ⓪ ) -: 2drop drop drop ; : ( ')' parse 2drop ; immediate @@ -50,12 +49,6 @@ cr .( ⓪ ) : OF ( n1 n2 -- n1 | ) postpone case? postpone IF ; immediate -: s" ( ccc" -- c-addr u ) \ compile only - postpone $lit - '"' parse - dup 0= -39 and throw - here over 1+ allot place ; immediate - cr .( ① ) cr @@ -89,13 +82,6 @@ false invert Constant true : erase ( c-addr u -- ) 0 fill ; : blank ( c-addr u -- ) bl fill ; -\ : xor ( x1 x2 -- x3 ) -\ 2dup or >r invert swap invert or r> and ; -\ -\ t{ 15 10 xor -> 5 }t -\ t{ 21845 dup xor -> 0 }t \ $5555 -\ t{ 21845 dup 2* xor -> 65535 }t - : 0> ( n -- f ) 0 > ; t{ 10 0> -> -1 }t @@ -181,7 +167,6 @@ t{ 3 3 <> -> 0 }t t{ 'x' 'u' <> -> -1 }t - : pick ( xn ... xi ... x0 i -- xn ... xi ... x0 xi ) 1+ cells sp@ + @ ; t{ 10 20 30 1 pick -> 10 20 30 20 }t @@ -206,14 +191,6 @@ t{ 10 20 30 1 roll -> 10 30 20 }t t{ val 42 to val val -> 5 42 }t -\ : u< ( u1 u2 -- f ) -\ over 0< IF dup 0< IF < exit THEN \ both large -\ 2drop false exit THEN \ u1 is larger -\ dup 0< IF 2drop true exit THEN \ u2 is larger -\ < \ both small -\ ; - - : within ( test low high -- flag ) over - >r - r> u< ; @@ -289,6 +266,8 @@ t{ 65535 dup * sqrt -> 65535 }t REPEAT 2drop ; +: clear ( -- ) remove-headers ; + | : hidden-word ." still there - " ; : visible-word ( -- ) hidden-word hidden-word ; @@ -626,9 +605,6 @@ Variable counter 0 counter ! ' 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 ; @@ -656,7 +632,7 @@ Variable counter 0 counter ! AGAIN ; ' .counter counter-display activate -: multikey ( -- c) BEGIN key? 0= WHILE pause REPEAT key ; +: multikey ( -- c) BEGIN pause key? UNTIL key ; : multi ( -- ) [ ' multikey ] Literal [ ' getkey >body ] Literal ! ; : single ( -- ) [ ' key ] Literal [ ' getkey >body ] Literal ! ; diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource index 4e09668..1363b87 100644 --- a/preForth/seedForthDemo.seedsource +++ b/preForth/seedForthDemo.seedsource @@ -182,15 +182,6 @@ t{ d1 d1 d1 -> five five five }t t{ 3 4 + -> 7 }t -\ catch and throw tests - -\ 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 - \ Test for sp! diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource index 7127820..670350d 100644 --- a/preForth/seedForthInteractive.seedsource +++ b/preForth/seedForthInteractive.seedsource @@ -33,6 +33,12 @@ end-macro : -rot ( a b c -- c a b ) swap >r swap r> ; +: under+ ( x1 x2 x3 -- x1+x3 x2 ) + rot + swap ; + +: tuck ( x1 x2 -- x2 x1 x2 ) + swap over ; + : /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ; @@ -156,7 +162,6 @@ end-macro : place ( c-addr1 u c-addr2 -- ) 2dup >r >r 1+ swap cmove r> r> c! ; - \ Exception handling Variable frame ( -- addr ) @@ -169,6 +174,7 @@ Variable frame ( -- addr ) ?dup 0= ?exit frame @ rp! r> swap >r sp! drop r> r> frame ! ; +\ tests: see later when ' is defined \ Tester : empty-stack ( i*x -- ) @@ -287,33 +293,6 @@ t{ 0 -1 u< -> -1 }t >r 1 /string r> REPEAT THEN drop ; -\ decimal output -\ -------------- - -\ : (u/mod ( u d q0 -- r d q ) -\ >r -\ BEGIN ( u d r:q0 ) -\ 2dup u< 0= -\ WHILE ( u d ) -\ swap over - swap ( u' d r:q0 ) -\ r> 1+ >r -\ REPEAT ( u' d r:q0 ) -\ r> ; -\ -: 10* ( x1 -- x2 ) - dup + dup dup + dup + + ; - -\ : 10* ( x1 -- x2 ) 10 um* drop ; - -\ : (10u/mod ( u q d -- r q d ) -\ third over swap u< 0= ?exit \ ( u q d ) -\ dup >r 10* \ ( u q 10*d ) ( R: d ) -\ (10u/mod \ ( r q d ) -\ swap >r 0 (u/mod nip r> 10* + r> ; - -\ : 10u/mod ( u -- r q ) -\ 0 1 (10u/mod drop ; - : (u. ( u1 -- ) ?dup IF 0 10 um/mod (u. .digit THEN ; @@ -344,6 +323,16 @@ Definer Defer ( -- ) : is ( xt -- ) \ only interactive ' >body ! ; +\ catch and throw tests + +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 + + \ String comparison : compare ( c-addr1 u1 c-addr2 u2 -- n ) rot @@ -364,15 +353,12 @@ Definer Defer ( -- ) \ dynamic memory \ ------------------------------------- -: 256* ( x1 -- x2 ) 2* 2* 2* 2* 2* 2* 2* 2* ; - Variable anchor 50 Constant waste -128 256* 256* 256* ( 32bit ) Constant #free \ sign bit -#free 1 - ( 31bit ) Constant #max - +minint Constant #free \ sign bit +maxint Constant #max : size ( mem -- size ) 1 cells - @ #max and ; @@ -401,7 +387,6 @@ Variable anchor : unlink ( mem -- ) setanchor @links 2dup ! swap cell+ ! ; - : allocate ( size -- mem ior ) 3 cells max dup >r fits? ?dup 0= IF r> -8 exit THEN ( "dictionary overflow" ) addr&size r@ - dup waste u< @@ -464,8 +449,6 @@ Constant #tib Defer getkey ' key is getkey -\ : getkey key ; - Variable input-echo -1 input-echo ! : accept ( c-addr u1 -- u2 ) @@ -536,9 +519,6 @@ Definer Header-flag? ( x -- ) : wordlist ( -- wid ) here 0 , ; -\ : under+ ( x1 x2 x3 -- x1+x3 x2 ) rot + swap ; -\ : tuck ( x1 x2 -- x2 x1 x2 ) swap over ; - Create search-order 0 , 10 cells allot : get-order ( -- wid0 wid1 wid2 ... widn n ) @@ -771,67 +751,18 @@ end-macro ' getkey has-header getkey ' frame has-header frame -\ ' "header has-header "header -\ ' link has-header link -\ ' _xt has-header _xt +' "header has-header "header +' link-header has-header link-header +' _xt has-header _xt Macro :noname seed new seed compiler end-macro -\ :noname 10 ; - - : compile ( -- ) r> dup cell+ >r @ , ; -\ Macro compile -\ seed [ -\ seed ' -\ -\ seed ] -\ seed compile, -\ end-macro - -\ lit [ ' ?branch , ] compile, - - -\ : (IF) ( -- c:orig ) -\ [ ' ?branch ] Literal compile, here 0 , ; -\ -\ : (AHEAD) ( -- c:orig ) -\ [ ' branch ] Literal compile, here 0 , ; -\ -\ : (THEN) ( c:orig -- ) -\ here swap ! ; -\ -\ : (ELSE) ( c:orig1 -- c:orig2 ) -\ [ ' branch ] Literal compile, here 0 , swap (THEN) ; -\ -\ : (WHILE) ( c: orig -- c:dest c:orig ) -\ (IF) swap ; -\ -\ : (AGAIN) ( c:orig -- ) -\ [ ' branch ] Literal compile, , ; -\ -\ : (UNTIL) -\ [ ' ?branch ] Literal compile, , ; - -\ : (REPEAT) ( c:orig c:dest -- ) -\ (AGAIN) (THEN) ; - -\ ' (IF) has-header IF immediate -\ ' (ELSE) has-header ELSE immediate -\ ' (THEN) has-header THEN immediate -\ ' (AHEAD) has-header AHEAD immediate - -\ ' here has-header BEGIN immediate -\ ' (WHILE) has-header WHILE immediate -\ ' (AGAIN) has-header AGAIN immediate -\ ' (UNTIL) has-header UNTIL immediate -\ ' (REPEAT) has-header REPEAT immediate - Variable >in ( -- addr ) @@ -890,7 +821,7 @@ Variable heads -1 heads ! [ ' $lit ] Literal compile, '"' parse here over 1+ allot place ; -\ ' (s") has-header s" immediate +' (s") has-header s" immediate : (.") ( ccc" -- ) (s") @@ -917,7 +848,7 @@ Variable heads -1 heads ! REPEAT nip nip ; -\ ' find-name-in has-header find-name-in +' find-name-in has-header find-name-in : find-name ( c-addr u -- header|0 ) search-order dup cell+ swap @ @@ -971,7 +902,7 @@ Variable heads -1 heads ! dup WHILE over c@ dup digit? 0= IF drop r> drop r> drop 2drop exit THEN - '0' - r> 10* + >r + '0' - r> 10 um* drop + >r 1 /string REPEAT 2drop 2drop r> r> IF negate THEN 0 0 ; @@ -1170,7 +1101,7 @@ here swap - swap c! colored-header count "header dup link-header \ -------- -' token has-header token +\ ' token has-header token cr t{ -> }t