From: Tim Vaughan <tgvaughan@gmail.com>
Date: Tue, 20 Jun 2017 23:48:07 +0000 (+1200)
Subject: IF analysis working.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=commitdiff_plain;h=84e8f70df686212cbf4c4d38b282651a3735f840

IF analysis working.
---

diff --git a/src/defer-is.4th b/src/defer-is.4th
index 89f07de..468a353 100644
--- a/src/defer-is.4th
+++ b/src/defer-is.4th
@@ -33,9 +33,3 @@ hide abort-defer
     0 ,
     here docol ,
     [compile] ] ;
-
-
-\ Need this for tail call optimization
-
-: goto-deferred ( cfa -- )
-    R> drop >body @ >body >R ;
diff --git a/src/scheme.4th b/src/scheme.4th
index 1a90ae3..7d9e2c4 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,25 @@ 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
+;
+
 :noname ( exp --- eproc )
 
     self-evaluating? if
@@ -1801,11 +1841,21 @@ hide env
         exit
     then
 
+    definition? if
+        analyze-definition
+        exit
+    then
+
     assignment? if
         analyze-assignment
         exit
     then
 
+    if? if
+        analyze-if
+        exit
+    then
+
 ; is analyze