def/set/lookup are working!

[scheme.forth.jl.git] / scheme.4th

diff --git a/scheme.4th b/scheme.4th
index ee180fc..8581893 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -117,16 +117,15 @@ objvar symbol-table
     does> dup @ swap 1+ @
 ;
 
-create-symbol quote quote-symbol
-create-symbol define define-symbol
-create-symbol set! set!-symbol
+create-symbol quote     quote-symbol
+create-symbol define    define-symbol
+create-symbol set!      set!-symbol
+create-symbol ok        ok-symbol
 
 \ }}}
 
 \ ---- Environments ---- {{{
 
-objvar global-env
-
 : enclosing-env ( env -- env )
     cdr ;
 
@@ -144,9 +143,9 @@ objvar global-env
 
 : add-binding ( var val frame -- )
     2swap 2over frame-vals cons
-    2over set-car!
+    2over set-cdr!
     2swap 2over frame-vars cons
-    swap set-cdr!
+    2swap set-car!
 ;
 
 : extend-env ( vars vals env -- env )
@@ -184,7 +183,7 @@ objvar vals
         2dup nil objeq? false =
     while
         2over 2over first-frame
-        lookup-var-frame if
+        get-vars-vals-frame if
             2drop 2drop
             vars fetchobj vals fetchobj true
             exit
@@ -204,7 +203,7 @@ hide vals
     get-vars-vals if
         2swap 2drop car
     else
-        bold fg red ." Tried to read unbound variable." reset-term abort
+        bold fg red ." Tried to read unbound variable." reset-term cr abort
     then
 ;
 
@@ -214,22 +213,22 @@ hide vals
         2swap 2drop ( val vals )
         set-car!
     else
-        bold fg red ." Tried to set unbound variable." reset-term abort
+        bold fg red ." Tried to set unbound variable." reset-term cr abort
     then
 ;
 
 objvar env
 
 : define-var ( var val env -- )
-    env objset 
+    env setobj 
 
-    2over env objfetch ( var val var env )
+    2over env fetchobj ( var val var env )
     get-vars-vals if
         2swap 2drop ( var val vals )
         set-car!
         2drop
     else
-        env objfetch
+        env fetchobj
         first-frame ( var val frame )
         add-binding
     then
@@ -237,6 +236,10 @@ objvar env
 
 hide env
 
+objvar global-env
+nil nil nil extend-env
+global-env setobj
+
 \ }}}
 
 \ ---- Read ---- {{{
@@ -696,10 +699,52 @@ defer read
 : definition? ( obj -- obj bool )
     define-symbol tagged-list? ;
 
+: definition-var ( obj -- var )
+    cdr car ;
+
+: definition-val ( obj -- val )
+    cdr cdr car ;
+
 : assignment? ( obj -- obj bool )
-    set-symbol tagged-list? ;
+    set!-symbol tagged-list? ;
+
+: assignment-var ( obj -- var )
+    cdr car ;
+    
+: assignment-val ( obj -- val )
+    cdr cdr car ;
+
+defer eval
+
+: eval-definition ( obj env -- res )
+    2swap 
+    2over 2over ( env obj env obj )
+    definition-val 2swap ( env obj valexp env )
+    eval  ( env obj val )
+    
+    2swap definition-var 2swap ( env var val )
+
+    >R >R 2swap R> R> 2swap ( var val env )
+    define-var
+
+    ok-symbol
+;
     
-: eval ( obj env -- result )
+: eval-assignment ( obj env -- res )
+    2swap 
+    2over 2over ( env obj env obj )
+    assignment-val 2swap ( env obj valexp env )
+    eval  ( env obj val )
+    
+    2swap assignment-var 2swap ( env var val )
+
+    >R >R 2swap R> R> 2swap ( var val env )
+    set-var
+
+    ok-symbol
+;
+
+:noname ( obj env -- result )
     2swap
 
     self-evaluating? if
@@ -718,9 +763,19 @@ defer read
         exit
     then
 
+    definition? if
+        2swap eval-definition
+        exit
+    then
+
+    assignment? if
+        2swap eval-assignment
+        exit
+    then
+
     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
     abort
-;
+; is eval
 
 \ }}}
 
@@ -817,3 +872,5 @@ defer print
 ;
 
 forth definitions
+
+\ vim:fdm=marker