X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=425b3782633ace22eb693fbc4f70945dbeea6c7c;hb=70a8db797c242289782d563b0d8a0368d137e7ab;hp=1a90ae3f6e7a5c528a4a784e7a3264d7a17bdfc0;hpb=ed191ba289bdcd6c0aa2e1079e63e8069ca6965c;p=scheme.forth.jl.git

diff --git a/src/scheme.4th b/src/scheme.4th
index 1a90ae3..425b378 100644
--- 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