Extend interactive seedForth

diff --git a/preForth/hi.forth b/preForth/hi.forth
index 7106600..68ce7b1 100644 (file)
--- 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 ( <name> )
+    Create 0 , ;
+
+: Constant ( x <name> -- )
+    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 (file)
--- 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 (file)
--- 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 ( <name> -- ) create ;
+Definer Create ( <name> -- ) create ( x ) drop ;
 
 Create dada 17 ,
 t{ dada @ -> 17 }t
 
 
-Definer Value ( x <name> -- )  create , does> @ ;
+Definer Value ( x <name> -- )  create >r , r> does> @ ;
 
 10 Value ten
 t{ ten -> 10 }t
 
 
-Definer Constant ( x <name> -- )  create , does> @ ;
+Definer Constant ( x <name> -- )  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 <name> -- 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 ( <name> -- ) create 'uninitialized , does> @ execute ;
+Definer Defer ( <name> -- ) create >r 'uninitialized , r> does> @ execute ;
 
 : >body ( xt -- body )  h@  1 cells + ;
 
@@ -302,7 +302,7 @@ Variable #tib
 
 \ Adder
 
-Definer Adder ( n <name> -- )  create , does>  @ + ;
+Definer Adder ( n <name> -- )  create >r , r> does>  @ + ;
 
 5 Adder 5+
 
@@ -313,7 +313,7 @@ t{ 1 5+ -> 6 }t
 
 \ Inlining Constant
 
-Definer iConstant ( x <name> -- )  create , ( immediate )  does> @  lit lit , , ;
+Definer iConstant ( x <name> -- )  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 (file)
--- a/preForth/seedForthInteractive.seedsource
+++ b/preForth/seedForthInteractive.seedsource
@@ -12,9 +12,9 @@
 PROGRAM seedForthInteractive.seed
 
 \ Defining words
-Definer Create ( <name> -- )      create ;
-Definer Variable ( <name> -- )    create 0 , ;
-Definer Constant ( x <name> -- )  create , does> @ ;
+Definer Create ( <name> -- )      create ( x ) drop ;
+Definer Variable ( <name> -- )    create ( x ) drop 0 , ;
+Definer Constant ( x <name> -- )  create ( x ) >r , r> does> @ ;
 
 \ Missing primitives
 : over ( x1 x2 -- x1 x2 x1 )  
@@ -69,7 +69,7 @@ Definer Constant ( x <name> -- )  create , does> @ ;
     swap over ! cell+ ! ;
 
 Definer Field ( offset size <name> -- 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 ( <name> -- ) 
-   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) ( <name> -- )
+    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) ( <name> -- )
-\      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) ( <name> -- )
+    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 ( <name> -- 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