Buggy implementation of analyze-lambda.

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

diff --git a/src/scheme.4th b/src/scheme.4th
index ec97f09..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
@@ -11,6 +12,7 @@ include debugging.4th
 
 defer read
 defer expand
+defer analyze
 defer eval
 defer print
 
@@ -162,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 ---- {{{
@@ -1726,6 +1732,176 @@ hide env
 
 \ }}}
 
+\ ---- Analyze ----
+
+: evaluate-eproc ( env eproc --- res )
+    begin
+        nil? invert
+    while
+        2dup car
+        2swap cdr
+    repeat
+    
+    2drop \ get rid of null
+
+    \ Final element of eproc list is primitive procedure
+    drop \ dump type signifier
+    goto \ jump straight to primitive procedure (executor)
+;
+
+: self-evaluating-executor ( env exp -- exp )
+    2swap 2drop ;
+
+: analyze-self-evaluating ( exp --- eproc )
+    ['] self-evaluating-executor primitive-proc-type
+    nil cons cons
+;
+
+: quote-executor ( env exp -- exp )
+    2swap 2drop ;
+
+: analyze-quoted ( exp -- eproc )
+    quote-body
+
+    ['] quote-executor primitive-proc-type
+    nil cons cons
+;
+
+: variable-executor ( env var -- val )
+    2swap lookup-var ;
+
+: analyze-variable ( exp -- eproc )
+    ['] variable-executor primitive-proc-type
+    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
+;
+
+: analyze-assignment ( exp -- eproc )
+    2dup assignment-var
+    2swap assignment-val analyze ( var val-eproc )
+
+    ['] assignment-executor primitive-proc-type
+    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
+        analyze-self-evaluating
+        exit
+    then
+
+    quote? if
+        analyze-quoted
+        exit
+    then
+    
+    variable? if
+        analyze-variable
+        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
+
+
 \ ---- Macro Expansion ---- {{{
 
 ( Simply evaluates the given procedure with expbody as its argument. )
@@ -2110,7 +2286,7 @@ variable gc-stack-depth
 
     include scheme-primitives.4th
 
-    s" scheme-library.scm" load 2drop
+    \ s" scheme-library.scm" load 2drop
     
 \ }}}
 
@@ -2143,7 +2319,7 @@ variable gc-stack-depth
     enable-gc
 
     \ Display welcome message
-    welcome-symbol nil cons global-env obj@ eval 2drop
+    \ welcome-symbol nil cons global-env obj@ eval 2drop
 
     begin
         ['] repl-body catch