From 592728bd6d57659b2978162b0d6dda60d34e28dc Mon Sep 17 00:00:00 2001 From: uho Date: Sun, 3 Nov 2019 20:37:40 +0100 Subject: [PATCH] Extend interactive seedForth --- preForth/hi.forth | 72 +++++++++++ preForth/seedForth-i386.pre | 10 +- preForth/seedForthDemo.seedsource | 20 +-- preForth/seedForthInteractive.seedsource | 149 +++++++++++++++-------- 4 files changed, 188 insertions(+), 63 deletions(-) diff --git a/preForth/hi.forth b/preForth/hi.forth index 7106600..68ce7b1 100644 --- a/preForth/hi.forth +++ b/preForth/hi.forth @@ -1,5 +1,77 @@ +0 echo ! +: 2drop drop drop ; +: ( + ')' parse 2drop ; immediate + +: \ + source nip >in ! ; + + cr .( hi - doing some test ) t{ 3 4 + -> 7 }t t{ 3 -> }t t{ 3 4 + -> 8 }t + + + +: on ( addr -- ) -1 swap ! ; +: off ( addr -- ) 0 swap ! ; + + +: AHEAD ( -- c:orig ) + postpone branch here 0 , ; immediate + +: IF ( -- c:orig ) + postpone ?branch here 0 , ; immediate + +: THEN ( c:orig -- ) + here swap ! ; immediate + +: ELSE ( c:orig1 -- c:orig2 ) + postpone AHEAD swap postpone THEN ; immediate + +: BEGIN ( -- c:dest ) + here ; immediate + +: WHILE ( c: orig -- c:dest c:orig ) + postpone IF swap ; immediate + +: AGAIN ( c:orig -- ) + postpone branch , ; immediate + +: UNTIL ( c:orig -- ) + postpone ?branch , ; immediate + +: REPEAT ( c:orig c:dest -- ) + postpone AGAIN postpone THEN ; immediate + +: s" + postpone $lit '"' parse here over 1+ allot place ; immediate + +: :noname ( -- xt ) + new ] ; + +: Variable ( ) + Create 0 , ; + +: Constant ( x -- ) + Create , Does> @ ; + + +Variable up + +: User ( x -- ) + Create cells , Does> @ up @ + ; + + +0 User u1 +1 User u2 +2 User u3 + +: n' parse-name last @ find-name ; + + +cr cr words cr cr .( ready ) + +echo on diff --git a/preForth/seedForth-i386.pre b/preForth/seedForth-i386.pre index f8434ae..38ae993 100644 --- a/preForth/seedForth-i386.pre +++ b/preForth/seedForth-i386.pre @@ -381,7 +381,7 @@ code rp! ( x -- ) dup ?lit compile, tail compiler ; -: new ( -- x ) +: new ( -- xt ) lit hp @ here h, lit enter , ; : fun ( -- ) @@ -396,12 +396,12 @@ code rp! ( x -- ) : $lit ( -- addr u ) r> dup 1 + dup >r swap c@ dup r> + >r ; -: create ( -- ) +: create ( -- xt ) 0 , \ dummy does> field - here h, lit dovar , ; + lit hp @ here h, lit dovar , ; -: does> ( -- ) \ set code field of last defined word - r> lit hp @ 1 - h@ dup >r 1 cells - ! lit dodoes r> ! +: does> ( xt -- ) \ set code field of last defined word + r> swap h@ dup >r 1 cells - ! lit dodoes r> ! ; : catch ( i*x xt -- j*x 0 | i*x err ) diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource index b8bb746..0d9205f 100644 --- a/preForth/seedForthDemo.seedsource +++ b/preForth/seedForthDemo.seedsource @@ -11,7 +11,7 @@ PROGRAM seedForthDemo.seed -Definer Variable create 0 , ; +Definer Variable create ( x ) drop 0 , ; \ Missing primitives : over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ; @@ -121,19 +121,19 @@ t{ here 5 c, count -> here 5 }t depth 0= ?exit >r .s r> dup . ; \ Defining words -Definer Create ( -- ) create ; +Definer Create ( -- ) create ( x ) drop ; Create dada 17 , t{ dada @ -> 17 }t -Definer Value ( x -- ) create , does> @ ; +Definer Value ( x -- ) create >r , r> does> @ ; 10 Value ten t{ ten -> 10 }t -Definer Constant ( x -- ) create , does> @ ; +Definer Constant ( x -- ) create >r , r> does> @ ; 5 Constant five t{ five -> 5 }t @@ -145,7 +145,7 @@ t{ five -> 5 }t \ structured data Definer Field ( offset size -- offset' ) - create over , + does> @ + ; + create >r over , + r> does> @ + ; \ define structure @@ -168,7 +168,7 @@ t{ person -> 3 cells }t \ size of structure : uninitialized ( -- ) cr s" uninitialized execution vector" type ; ' uninitialized Constant 'uninitialized -Definer Defer ( -- ) create 'uninitialized , does> @ execute ; +Definer Defer ( -- ) create >r 'uninitialized , r> does> @ execute ; : >body ( xt -- body ) h@ 1 cells + ; @@ -302,7 +302,7 @@ Variable #tib \ Adder -Definer Adder ( n -- ) create , does> @ + ; +Definer Adder ( n -- ) create >r , r> does> @ + ; 5 Adder 5+ @@ -313,7 +313,7 @@ t{ 1 5+ -> 6 }t \ Inlining Constant -Definer iConstant ( x -- ) create , ( immediate ) does> @ lit lit , , ; +Definer iConstant ( x -- ) create >r , ( immediate ) r> does> @ lit lit , , ; \ improve: needs to define macro @@ -371,10 +371,10 @@ t{ m 2@ m 2! m @ m cell+ @ -> 1 2 }t r> r> ; Definer Array ( n -- ) - create dup , + create >r dup , here >r 0 , cells alloc r> ! \ { size | addr } - does> ( n -- addr ) + r> does> ( n -- addr ) BEGIN ( n body ) 2dup @ < 0= WHILE ( n body ) diff --git a/preForth/seedForthInteractive.seedsource b/preForth/seedForthInteractive.seedsource index e506f39..d18ab5c 100644 --- a/preForth/seedForthInteractive.seedsource +++ b/preForth/seedForthInteractive.seedsource @@ -12,9 +12,9 @@ PROGRAM seedForthInteractive.seed \ Defining words -Definer Create ( -- ) create ; -Definer Variable ( -- ) create 0 , ; -Definer Constant ( x -- ) create , does> @ ; +Definer Create ( -- ) create ( x ) drop ; +Definer Variable ( -- ) create ( x ) drop 0 , ; +Definer Constant ( x -- ) create ( x ) >r , r> does> @ ; \ Missing primitives : over ( x1 x2 -- x1 x2 x1 ) @@ -69,7 +69,7 @@ Definer Constant ( x -- ) create , does> @ ; swap over ! cell+ ! ; Definer Field ( offset size -- offset' ) - create over , + does> @ + ; + create >r over , + r> does> @ + ; \ output 32 Constant bl @@ -263,7 +263,7 @@ t{ -1 4 min -> -1 }t cr s" uninitialized execution vector" type -1 throw ; Definer Defer ( -- ) - create [ ' uninitialized ] Literal , does> @ execute ; + create >r [ ' uninitialized ] Literal , r> does> @ execute ; : >body ( xt -- body ) h@ 1 cells + ; @@ -481,6 +481,11 @@ end-macro +\ ' "header has-header "header +\ ' link has-header link +\ ' _xt has-header _xt + + Macro :noname seed new seed compiler @@ -489,47 +494,51 @@ end-macro \ :noname 10 ; -: (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) - (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 +\ : (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 ) +' >in has-header >in + : source ( -- c-addr u ) tib #tib @ ; +' source has-header source + : parse ( c -- c-addr u ) >r source >in @ /string 2dup r> dup >r scan @@ -543,23 +552,45 @@ Variable >in ( -- addr ) ' parse has-header parse ' parse-name has-header parse-name +: (Create) ( -- ) + parse-name "header dup link create swap _xt ! reveal ; + +' (Create) has-header Create + +: last-xt ( -- xt ) + last @ _xt @ ; + +: (Does>) ( -- ) + [ ' last-xt ] Literal compile, + [ ' does> ] Literal compile, ; + +' (Does>) has-header Does> immediate +' last has-header last +' _xt has-header _xt +' _name has-header _name : (Literal) ( x -- ) lit [ ' lit , ] compile, , ; ' (Literal) has-header Literal immediate -: (.") ( ccc" -- ) +: (s") ( ccc" -- ) [ ' $lit ] Literal compile, - '"' parse here over 1+ allot place + '"' parse here over 1+ allot place ; + +\ ' (s") has-header s" immediate + +: (.") ( ccc" -- ) + (s") [ ' type ] Literal compile, ; ' (.") has-header ." immediate +: dot-paren + ')' parse type ; + +' dot-paren has-header .( immediate -\ : (Create) ( -- ) -\ Header create hp@ swap _xt ! 0 , ; -\ ' (Create) has-header Create : find-name ( c-addr u link -- header|0 ) \ >r 2dup lowercase r> @@ -572,6 +603,20 @@ Variable >in ( -- addr ) REPEAT nip nip ; +' find-name has-header find-name + +: (postpone) ( -- ) + parse-name last @ find-name dup 0= -13 and throw + dup immediate? IF + _xt @ compile, + ELSE + [ ' lit ] Literal compile, _xt @ , [ ' compile, ] Literal compile, + THEN +; + +' (postpone) has-header postpone immediate +' immediate? has-header immediate? + : tick ( -- xt ) parse-name last @ find-name dup IF _xt @ exit THEN -13 throw ; @@ -675,10 +720,16 @@ Variable handlers interpreters @ handlers ! REPEAT 2drop ; +Variable echo -1 echo ! + +' echo has-header echo + : prompt ( -- ) - cr .s handlers @ compilers @ = IF ']' ELSE '>' THEN emit space ; + echo @ IF + cr .s handlers @ compilers @ = IF ']' ELSE '>' THEN emit space + THEN ; -: .ok ( -- ) ." ok" ; +: .ok ( -- ) echo @ IF ." ok" THEN ; : restart ( -- ) ([) @@ -694,7 +745,7 @@ Variable handlers interpreters @ handlers ! 2 Constant major ( -- x ) 0 Constant minor ( -- x ) -1 Constant patch ( -- x ) +2 Constant patch ( -- x ) : .version ( -- ) major .digit '.' emit @@ -708,11 +759,13 @@ Variable handlers interpreters @ handlers ! : boot ( -- ) key drop \ skip 0 of boot program .banner - words cr BEGIN [ ' warm ] Literal catch ?dup IF ." error " . cr THEN AGAIN ; +' boot has-header boot + +0 echo ! reveal boot END -- 2.34.1