From: Ulrich Hoffmann Date: Sat, 14 Dec 2019 11:27:54 +0000 (+0100) Subject: Simplify kernel: Remove CATCH and THROW, leave INTERPRETER loop now by executing... X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=ced1c837cfa0860efac7716e9a36f897266392c7;p=preForth.git Simplify kernel: Remove CATCH and THROW, leave INTERPRETER loop now by executing EXIT, Extend Kernel: also use double byte tokens --- diff --git a/preForth/hi.forth b/preForth/hi.forth index 40bfc56..fb80623 100644 --- a/preForth/hi.forth +++ b/preForth/hi.forth @@ -181,6 +181,7 @@ 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 @@ -292,7 +293,6 @@ t{ 65535 dup * sqrt -> 65535 }t : visible-word ( -- ) hidden-word hidden-word ; - : save-mem ( c-addr1 u1 -- c-addr2 u2 ) dup >r allocate throw swap over r@ cmove r> ; @@ -479,6 +479,9 @@ Variable hld : scroll-up ( -- ) esc ." [S" ; +: white ( -- ) esc ." [37m" ; +: blue-bg ( -- ) esc ." [44m" ; + : save-cursor-position ( -- ) 27 emit '7' emit ; : restore-cursor-position ( -- ) 27 emit '8' emit ; @@ -487,7 +490,7 @@ Variable hld : show-status ( -- ) status-line IF scroll-up THEN - save-cursor-position blue reverse + save-cursor-position blue-bg white base @ >r decimal 0 status-line 1 max at-xy ( clreol ) terminal-width spaces 0 status-line 1 max at-xy @@ -604,7 +607,7 @@ operator up! rp-save his dup >r @ 1 cells - dup r> ! ! ; -: (activate) ( xt -- ) +| : (activate) ( xt -- ) catch error# ! stop ; : activate ( xt tid -- ) @@ -692,6 +695,6 @@ 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 ++status +echo on cr cr .( Welcome! ) input-echo on diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index 7d1ddb0..801a0e2 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -29,8 +29,6 @@ stck: DD 16 dup(0) DD 10000 dup(0) rstck: DD 16 dup(0) -_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 @@ -296,8 +294,10 @@ code c! ( c c-addr -- ) next ; -code invoke ( addr -- ) \ native code: >r ; - pop eax +\ code invoke ( addr -- ) \ native code: >r ; +code execute ( addr -- ) \ this version uses token numbers as execution tokens and finds their code address via the headers table + pop edx + mov dword eax, [_head+edx*4] jmp dword [eax] ; @@ -374,8 +374,11 @@ code um/mod ( ud u1 -- u2 u3 ) : ?dup ( x -- x x | 0 ) dup 0= ?exit dup ; +: 2* ( x1 -- x2 ) + dup + ; + : cells ( x1 -- x2 ) - dup + dup + ; + 2* 2* ; : +! ( x addr -- ) swap >r dup @ r> + swap ! ; @@ -404,23 +407,28 @@ code um/mod ( ud u1 -- u2 u3 ) : compile, ( x -- ) h@ , ; -: execute ( x -- ) - h@ invoke ; +\ token are in the range 0 .. 767: +\ 0, 3 .. 255 are single byte tokens +\ 256 .. 511 are double byte tokens of the form 01 xx +\ 511 .. 767 are double byte tokens of the form 02 xx +: token ( -- x ) + key dup 0= ?exit \ 0 -> single byte token + dup 3 - 0< 0= ?exit \ not 1 2 -> single byte token + key couple ; \ double byte token : interpreter ( -- ) - key ?dup 0= ?exit execute tail interpreter ; + token execute tail interpreter ; \ executing exit will leave this loop : num ( -- x ) tail interpreter ; -: ?lit ( xt -- xt ) - h@ lit num - ?exit drop \ not num token: exit i.e. normal compile action +: ?lit ( xt -- xt | ) + dup h@ lit num - ?exit drop \ not num token: exit i.e. normal compile action lit lit , num , \ generate lit x num call puts x on stack r> drop tail compiler ; : compiler ( -- ) - key ?dup 0= ?exit - dup ?lit + token ?dup 0= ?exit ?lit compile, tail compiler ; : new ( -- xt ) @@ -429,9 +437,6 @@ code um/mod ( ud u1 -- u2 u3 ) : fun ( -- ) new drop compiler ; -: 2* ( x1 -- x2 ) - dup + ; - : couple ( hi lo -- hilo ) >r 2* 2* 2* 2* 2* 2* 2* 2* r> + ; @@ -446,67 +451,57 @@ 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 ) - 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 frame @ rp! r> swap >r sp! drop r> r> frame ! ; - - : unused ( -- u ) lit memtop here - ; : cold ( -- ) 's' emit 'e' dup emit emit 'd' emit 10 emit lit bye h, \ 0 00 - lit emit h, \ 1 01 - lit key h, \ 2 02 - lit dup h, \ 3 03 - lit swap h, \ 4 04 - lit drop h, \ 5 05 - lit 0< h, \ 6 06 - lit ?exit h, \ 7 07 - lit >r h, \ 8 08 - lit r> h, \ 9 09 - lit - h, \ 10 0A - lit exit h, \ 11 0B - lit lit h, \ 12 0C - lit @ h, \ 13 0D - lit c@ h, \ 14 0E - lit ! h, \ 15 0F - lit c! h, \ 16 10 - lit execute h, \ 17 11 - lit branch h, \ 18 12 - lit ?branch h, \ 19 13 - lit negate h, \ 20 14 - lit + h, \ 21 15 - lit 0= h, \ 22 16 - lit ?dup h, \ 23 17 - lit cells h, \ 24 18 - lit +! h, \ 25 19 - lit h@ h, \ 26 1A - lit h, h, \ 27 1B - lit here h, \ 28 1C - lit allot h, \ 29 1D - lit , h, \ 30 1E - lit c, h, \ 31 1F - lit fun h, \ 32 20 - lit interpreter h, \ 33 21 - lit compiler h, \ 34 22 - lit create h, \ 35 23 - lit does> h, \ 36 24 - lit cold h, \ 37 25 - lit depth h, \ 38 26 - lit compile, h, \ 39 27 - lit new h, \ 40 28 - lit couple h, \ 41 29 - lit and h, \ 42 2A - lit or h, \ 43 2B - lit catch h, \ 44 2C - lit throw h, \ 45 2D + 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 + lit negate h, \ 22 16 + lit + h, \ 23 17 + lit 0= h, \ 24 18 + lit ?dup h, \ 25 19 + lit cells h, \ 26 1A + lit +! h, \ 27 1B + lit h@ h, \ 28 1C + lit h, h, \ 29 1D + lit here h, \ 30 1E + lit allot h, \ 31 1F + lit , h, \ 32 20 + lit c, h, \ 33 21 + lit fun h, \ 34 22 + lit interpreter h, \ 35 23 + lit compiler h, \ 36 24 + lit create h, \ 37 25 + lit does> h, \ 38 26 + lit cold h, \ 39 27 + lit depth h, \ 40 28 + 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 @@ -517,7 +512,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 + lit token h, \ 56 38 interpreter bye ; pre diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index 2d3df53..85f2ec2 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -35,15 +35,18 @@ Create tokens #hashsize cells allot tokens #hashsize cells 0 fill VARIABLE OUTFILE -: SUBMIT ( c -- ) +: submit ( c -- ) PAD C! PAD 1 OUTFILE @ WRITE-FILE THROW ; +: submit-token ( x -- ) + dup 255 > IF dup 8 rshift SUBMIT THEN SUBMIT ; + : ( -- c-addr u ) bl word count ; Variable #tokens 0 #tokens ! : Token ( -- ) :noname - #tokens @ postpone LITERAL postpone SUBMIT postpone ; + #tokens @ postpone LITERAL postpone SUBMIT-TOKEN postpone ; cr #tokens @ 3 .r space 2dup type \ tell user about used tokens ?token ! 1 #tokens +! ; @@ -59,21 +62,21 @@ Variable #tokens 0 #tokens ! token@ dup 0= Abort" is undefined" postpone LITERAL postpone EXECUTE ; immediate -( 0 $00 ) Token bye Token emit Token key Token dup -( 4 $04 ) Token swap Token drop Token 0< Token ?exit -( 8 $08 ) Token >r Token r> Token - Token exit -( 12 $0C ) Token lit Token @ Token c@ Token ! -( 16 $10 ) Token c! Token execute Token branch Token ?branch -( 20 $14 ) Token negate Token + Token 0= Token ?dup -( 24 $18 ) Token cells Token +! Token h@ Token h, -( 28 $1C ) Token here Token allot Token , Token c, -( 32 $20 ) Token fun Token interpreter Token compiler Token create -( 36 $24 ) Token does> Token cold Token depth Token compile, -( 40 $28 ) Token new Token couple Token and Token or -( 44 $2C ) Token catch Token throw Token sp@ Token sp! +( 0 $00 ) Token bye Token prefix1 Token prefix2 Token emit +( 4 $04 ) Token key Token dup Token swap Token drop +( 8 $08 ) Token 0< Token ?exit Token >r Token r> +( 12 $0C ) Token - Token exit Token lit Token @ +( 16 $10 ) Token c@ Token ! Token c! Token execute +( 20 $14 ) Token branch Token ?branch Token negate Token + +( 24 $18 ) Token 0= Token ?dup Token cells Token +! +( 28 $1C ) Token h@ Token h, Token here Token allot +( 32 $20 ) Token , Token c, Token fun Token interpreter +( 36 $24 ) Token compiler Token create Token does> Token cold +( 40 $28 ) Token depth Token compile, Token new Token couple +( 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? -( 53 $35 ) Token frame +( 52 $34 ) Token um* Token um/mod Token unused Token key? +( 56 $38 ) Token token \ generate token sequences for numbers @@ -105,8 +108,8 @@ Variable #tokens 0 #tokens ! : seed-name ( c-addr u -- ) 2dup token@ dup IF nip nip execute EXIT THEN drop - 2dup char-lit? IF nip nip seed num seed-number seed bye EXIT THEN drop - 2dup number? IF nip nip seed num seed-number seed bye EXIT THEN drop + 2dup char-lit? IF nip nip seed num seed-number seed exit EXIT THEN drop + 2dup number? IF nip nip seed num seed-number seed exit EXIT THEN drop cr type ." not found" abort ; : seed-line ( -- ) @@ -248,7 +251,7 @@ Macro Definer ( -- ) postpone Token #tokens @ 1 #tokens +! postpone Literal - postpone SUBMIT + postpone SUBMIT-TOKEN seed fun postpone end-macro end-macro diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource index 0d9205f..4e09668 100644 --- a/preForth/seedForthDemo.seedsource +++ b/preForth/seedForthDemo.seedsource @@ -184,12 +184,12 @@ 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 +\ 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 089b15e..7127820 100644 --- a/preForth/seedForthInteractive.seedsource +++ b/preForth/seedForthInteractive.seedsource @@ -84,7 +84,7 @@ end-macro : 0<> ( x -- f ) 0= 0= ; -: 2* ( x1 -- x2 ) +: 2* ( x1 -- x2 ) \ already in kernel dup + ; : cell+ ( addr1 -- addr2 ) @@ -153,10 +153,23 @@ end-macro : move cmove ; - : place ( c-addr1 u c-addr2 -- ) 2dup >r >r 1+ swap cmove r> r> c! ; + +\ Exception handling + +Variable frame ( -- addr ) + +: catch ( i*x xt -- j*x 0 | i*x err ) + 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 frame @ rp! r> swap >r sp! drop + r> r> frame ! ; + + \ Tester : empty-stack ( i*x -- ) BEGIN depth 0< WHILE 0 REPEAT @@ -242,15 +255,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 1- Constant maxint +: minint ( -- n ) + 1 BEGIN dup 2* dup WHILE nip REPEAT drop ; -\ t{ minint negate -> minint }t -\ t{ minint maxint < -> -1 }t -\ t{ maxint minint < -> 0 }t +minint 1- Constant maxint +t{ minint negate -> minint }t +t{ minint maxint < -> -1 }t +t{ maxint minint < -> 0 }t t{ 0 1 u< -> -1 }t t{ 1 0 u< -> 0 }t @@ -318,7 +330,7 @@ t{ 0 -1 u< -> -1 }t \ Deferred words -: ' ( -- x ) key ; +: ' ( -- x ) token ; : uninitialized ( -- ) cr s" uninitialized execution vector" type -1 throw ; @@ -679,8 +691,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 @@ -920,6 +932,10 @@ Variable heads -1 heads ! ' find-name has-header find-name +: Alias ( xt -- ) + parse-name "header dup link-header _xt ! ; + +' Alias has-header Alias : (postpone) ( -- ) parse-name find-name dup 0= -13 and throw @@ -1069,7 +1085,9 @@ Variable echo -1 echo ! : green ( -- ) esc ." [32m" ; \ : yellow ( -- ) esc ." [33m" ; : blue ( -- ) esc ." [34m" ; +\ : bright-blue ( -- ) esc ." [94m" ; : reset-colors ( -- ) esc ." [39;49m" ; +: cyan ( -- ) esc ." [96m" ; : page ( -- ) esc ." [2J" esc ." [H" ; ' blue has-header blue @@ -1088,7 +1106,7 @@ Defer .status : noop ; ' noop is .status : prompt ( -- ) echo @ IF - cr blue bold .s normal reset-colors compiling? IF ']' ELSE '>' THEN emit space + cr cyan bold .s normal reset-colors compiling? IF ']' ELSE '>' THEN emit space THEN ; : .ok ( -- ) @@ -1110,7 +1128,7 @@ Defer .status : noop ; ' noop is .status 2 Constant major ( -- x ) -1 Constant minor ( -- x ) +2 Constant minor ( -- x ) 0 Constant patch ( -- x ) : .version ( -- ) @@ -1144,17 +1162,20 @@ 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 \ -------- +' token has-header token + cr t{ -> }t + 0 echo ! reveal boot