Buggy implementation of analyze-lambda.

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

diff --git a/src/scheme.4th b/src/scheme.4th
index 1a90ae3..425b378 100644 (file)
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -3,6 +3,7 @@ scheme definitions
 
 include term-colours.4th
 include defer-is.4th
+include goto.4th
 include catch-throw.4th
 include integer.4th
 include float.4th
@@ -163,6 +164,10 @@ variable nextfree
     R> R>
 ;
 
+: 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn )
+    2* 1+ dup
+    >R pick R> pick ;
+
 \ }}}
 
 \ ---- Pre-defined symbols ---- {{{
@@ -1740,8 +1745,8 @@ hide env
     2drop \ get rid of null
 
     \ Final element of eproc list is primitive procedure
-    drop        \ dump type signifier
-    R> drop >body >R  \ GOTO primitive procedure (executor)
+    drop \ dump type signifier
+    goto \ jump straight to primitive procedure (executor)
 ;
 
 : self-evaluating-executor ( env exp -- exp )
@@ -1770,11 +1775,27 @@ hide env
     nil cons cons
 ;
 
+: definition-executor ( env var val-eproc -- ok )
+     2rot 2dup 2rot ( var env env val-eproc )
+    evaluate-eproc 2swap ( var val env )
+    define-var
+    ok-symbol
+;
+
+: analyze-definition ( exp -- eproc )
+    2dup definition-var
+    2swap definition-val analyze
+
+    ['] definition-executor primitive-proc-type
+    nil cons cons cons
+;
+
 : assignment-executor ( env var val-eproc -- ok )
     2rot 2dup 2rot ( var env env val-eproc )
     evaluate-eproc 2swap ( var val env )
     set-var
-    ok-symbol ;
+    ok-symbol
+;
 
 : analyze-assignment ( exp -- eproc )
     2dup assignment-var
@@ -1784,6 +1805,63 @@ hide env
     nil cons cons cons
 ;
 
+: if-executor ( env pproc cproc aproc -- res )
+    2rot 3 2pick 2swap ( env cproc aproc env pproc )
+    evaluate-eproc
+    true? if
+        2drop evaluate-eproc
+    else
+        2swap 2drop evaluate-eproc
+    then
+;
+
+: analyze-if ( exp -- eproc )
+    2dup if-predicate analyze
+    2swap 2dup if-consequent analyze
+    2swap if-alternative analyze
+
+    ['] if-executor primitive-proc-type
+    nil cons cons cons cons
+;
+
+: sequential-executor ( env eproc1 eproc2 -- res )
+    2swap 2 2pick 2swap ( env eproc2 env eproc1 )
+    evaluate-eproc 2drop
+    evaluate-eproc
+;
+
+: analyze-sequence ( explist -- eproc )
+    nil? if
+        except-message: ." Tried to analyze empty expression sequence." recoverable-exception throw
+    then
+
+    2dup car analyze
+    2swap cdr
+    nil? if
+        2drop
+    else
+        recurse
+        ['] sequential-executor
+        nil cons cons
+    then
+;
+
+: lambda-executor ( env params bproc -- res )
+    2rot make-procedure
+    ( Although this is packaged up as a regular compound procedure,
+      the "body" element contains an _eproc_ to be evaluated in an
+      environment resulting from extending env with the parameter
+      bindings. )
+;
+
+: analyze-lambda ( exp -- eproc )
+    2dup lambda-parameters
+    2swap lambda-body analyze-sequence
+
+    ['] lambda-executor primitive-proc-type
+    nil cons cons cons
+;
+
 :noname ( exp --- eproc )
 
     self-evaluating? if
@@ -1801,11 +1879,26 @@ hide env
         exit
     then
 
+    definition? if
+        analyze-definition
+        exit
+    then
+
     assignment? if
         analyze-assignment
         exit
     then
 
+    if? if
+        analyze-if
+        exit
+    then
+
+    lambda? if
+        analyze-lambda
+        exit
+    then
+
 ; is analyze