Draft implementation of application analysis.

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

diff --git a/src/scheme.4th b/src/scheme.4th
index 1a90ae3..7a1a1dc 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 ---- {{{
@@ -1729,7 +1734,10 @@ hide env
 
 \ ---- Analyze ----
 
-: evaluate-eproc ( env eproc --- res )
+: evaluate-eproc ( eproc env --- res )
+
+    >R >R
+    
     begin
         nil? invert
     while
@@ -1739,21 +1747,23 @@ hide env
     
     2drop \ get rid of null
 
+    R> R>
+
     \ 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 )
-    2swap 2drop ;
+: self-evaluating-executor ( exp env -- exp )
+    2drop ;
 
 : analyze-self-evaluating ( exp --- eproc )
     ['] self-evaluating-executor primitive-proc-type
     nil cons cons
 ;
 
-: quote-executor ( env exp -- exp )
-    2swap 2drop ;
+: quote-executor ( exp env -- exp )
+    2drop ;
 
 : analyze-quoted ( exp -- eproc )
     quote-body
@@ -1762,19 +1772,35 @@ hide env
     nil cons cons
 ;
 
-: variable-executor ( env var -- val )
-    2swap lookup-var ;
+: variable-executor ( var env -- val )
+    lookup-var ;
 
 : analyze-variable ( exp -- eproc )
     ['] variable-executor primitive-proc-type
     nil cons cons
 ;
 
-: assignment-executor ( env var val-eproc -- ok )
-    2rot 2dup 2rot ( var env env val-eproc )
+: definition-executor ( var val-eproc env -- ok )
+    2swap 2over ( var env val-eproc env )
+    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 ( var val-eproc env -- ok )
+    2swap 2over ( var env val-eproc env )
     evaluate-eproc 2swap ( var val env )
     set-var
-    ok-symbol ;
+    ok-symbol
+;
 
 : analyze-assignment ( exp -- eproc )
     2dup assignment-var
@@ -1784,6 +1810,136 @@ hide env
     nil cons cons cons
 ;
 
+: if-executor ( cproc aproc pproc env -- res )
+    2swap 2over ( cproc aproc env pproc env -- res )
+    evaluate-eproc
+
+    true? if
+        2swap 2drop
+    else
+        2rot 2drop
+    then
+
+    evaluate-eproc
+;
+
+: 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
+;
+
+: sequence-executor ( eproc-list env -- res )
+    2swap
+
+    begin
+        2dup cdr ( env elist elist-rest)
+        nil? invert
+    while
+
+        -2rot car 2over ( elist-rest env elist-head env )
+        evaluate-eproc  ( elist-rest env head-res )
+        2drop 2swap     ( env elist-rest )
+    repeat
+
+    2drop car 2swap
+    ['] evaluate-eproc goto
+;
+
+
+: (analyze-sequence) ( explist -- eproc-list )
+    nil? if exit then
+
+    2dup car analyze
+    2swap cdr recurse
+
+    cons
+;
+
+: analyze-sequence ( explist -- eproc )
+    (analyze-sequence)
+    ['] sequence-executor primitive-proc-type
+    nil cons cons
+;
+
+: lambda-executor ( params bproc env -- res )
+    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
+
+    nil? if
+        except-message: ." encountered lambda with an empty body." recoverable-exception throw
+    then
+
+    analyze-sequence
+
+    ['] lambda-executor primitive-proc-type
+    nil cons cons cons
+;
+
+: operand-eproc-list ( operands -- eprocs )
+    nil? invert if
+        2dup car analyze
+        2swap cdr recurse
+        cons
+    then
+;
+
+: evaluate-operand-eprocs ( env aprocs -- vals )
+    nil? invert if
+        2over 2over car evaluate-eproc ( env aprocs thisres )
+        -rot cdr recurse
+;
+
+: application-executor ( operator-proc arg-procs env -- res )
+    2rot 2over ( aprocs env fproc env )
+    evaluate-eproc ( aprocs env proc )
+    2swap -2rot 2over 2swap ( proc env env aprocs )
+    evaluate-operand-eprocs ( proc env vals )
+    
+    2rot ( env vals proc )
+    
+    dup case
+        primitive-proc-type of
+            2rot 2drop execute
+        endof
+
+        compound-proc-type of
+                2dup procedure-body ( argvals proc body )
+                -2rot 2dup procedure-params ( bproc argvals proc argnames )
+                -2rot procedure-env ( bproc argnames argvals procenv )
+
+                -2rot 2swap
+                flatten-proc-args
+                2swap 2rot
+
+                extend-env ( bproc env )
+
+               ['] evaluate-eproc goto
+        endof
+
+        except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
+    endcase
+;
+
+: analyze-application ( exp -- eproc )
+    2dup operator analyze
+    2swap operands operand-eproc-list
+
+    ['] application-executor
+    nil cons cons cons
+;
+
 :noname ( exp --- eproc )
 
     self-evaluating? if
@@ -1801,11 +1957,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