Fixed TCO bug.

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

diff --git a/scheme.4th b/scheme.4th
index 9a2a3ca..8bc44d3 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -3,6 +3,11 @@ scheme definitions
 
 include term-colours.4th
 include defer-is.4th
+include catch-throw.4th
+
+defer read
+defer eval
+defer print
 
 \ ------ Types ------
 
@@ -20,7 +25,7 @@ include defer-is.4th
 
 \ ------ Cons cell memory ------ {{{
 
-1000 constant N
+10000 constant N
 create car-cells N allot
 create car-type-cells N allot
 create cdr-cells N allot
@@ -376,8 +381,6 @@ include scheme-primitives.4th
 
 \ ---- Read ---- {{{
 
-defer read
-
 variable parse-idx
 variable stored-parse-idx
 create parse-str 161 allot
@@ -785,8 +788,6 @@ parse-idx-stack parse-idx-sp !
 
 \ ---- Eval ---- {{{
 
-defer eval
-
 : self-evaluating? ( obj -- obj bool )
     boolean-type istype? if true exit then
     fixnum-type istype? if true exit then
@@ -817,11 +818,23 @@ defer eval
 : definition? ( obj -- obj bool )
     define-symbol tagged-list? ;
 
+: make-lambda ( params body -- lambda-exp )
+    lambda-symbol -2rot cons cons ;
+
 : definition-var ( obj -- var )
-    cdr car ;
+    cdr car
+    symbol-type istype? false = if car then
+;
 
 : definition-val ( obj -- val )
-    cdr cdr car ;
+    2dup cdr car symbol-type istype? if
+        2drop
+        cdr cdr car
+    else
+        cdr 2swap cdr cdr
+        make-lambda
+    then
+;
 
 : assignment? ( obj -- obj bool )
     set!-symbol tagged-list? ;
@@ -933,6 +946,15 @@ defer eval
     then
 ;
 
+: procedure-params ( proc -- params )
+    drop pair-type car ;
+
+: procedure-body ( proc -- body )
+    drop pair-type cdr car ;
+
+: procedure-env ( proc -- body )
+    drop pair-type cdr cdr car ;
+
 : apply ( proc args )
         2swap dup case
             primitive-proc-type of
@@ -940,7 +962,27 @@ defer eval
             endof
 
             compound-proc-type of
-                ." Compound procedures not yet implemented."
+                2dup procedure-body ( args proc body )
+                -2rot 2dup procedure-params ( body args proc params )
+                -2rot procedure-env ( body params args procenv )
+
+                extend-env ( body env )
+
+                2swap ( env body )
+
+                begin
+                    2dup cdr 2dup nil objeq? false =
+                while
+                    -2rot car 2over ( nextbody env exp env )
+                    eval
+                    2drop \ discard result
+                    2swap ( env nextbody )
+                repeat
+
+                2drop ( env body )
+                car 2swap ( exp env )
+
+                R> drop ['] eval goto-deferred  \ Tail call optimization
             endof
 
             bold fg red ." Object not applicable. Aboring." reset-term cr
@@ -988,12 +1030,13 @@ defer eval
             if-alternative
         then
 
-        2swap ['] eval goto
+        2swap
+        ['] eval goto-deferred
     then
 
     lambda? if
-        2dup lambda-body
-        2swap lambda-parameters
+        2dup lambda-parameters
+        2swap lambda-body
         2rot make-procedure
         exit
     then
@@ -1016,8 +1059,6 @@ defer eval
 
 \ ---- Print ---- {{{
 
-defer print
-
 : printnum ( numobj -- ) drop 0 .R ;
 
 : printbool ( numobj -- )