From: Tim Vaughan <tgvaughan@gmail.com>
Date: Tue, 19 Jul 2016 08:35:11 +0000 (+1200)
Subject: Added conditionals.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=commitdiff_plain;h=613a9d60145361cec8ed96e49193f730e113a53a

Added conditionals.
---

diff --git a/defer-is.4th b/defer-is.4th
index 07f1342..1b171b6 100644
--- a/defer-is.4th
+++ b/defer-is.4th
@@ -1,4 +1,4 @@
-\ Add words supporting deferred execution
+\ Words supporting deferred execution
 
 : abort-defer
     ." Tried to execute undefined deferred word." cr abort ;
@@ -33,3 +33,10 @@ hide abort-defer
     0 ,
     here docol ,
     [compile] ] ;
+
+
+\ Need this for tail call optimization
+
+: goto ( cfa -- )
+    R> drop execute ;
+
diff --git a/scheme.4th b/scheme.4th
index 8581893..e2162be 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -121,6 +121,7 @@ create-symbol quote     quote-symbol
 create-symbol define    define-symbol
 create-symbol set!      set!-symbol
 create-symbol ok        ok-symbol
+create-symbol if        if-symbol
 
 \ }}}
 
@@ -669,6 +670,8 @@ defer read
 
 \ ---- Eval ---- {{{
 
+defer eval
+
 : self-evaluating? ( obj -- obj bool )
     boolean-type istype? if true exit then
     number-type istype? if true exit then
@@ -714,8 +717,6 @@ defer read
 : assignment-val ( obj -- val )
     cdr cdr car ;
 
-defer eval
-
 : eval-definition ( obj env -- res )
     2swap 
     2over 2over ( env obj env obj )
@@ -744,6 +745,34 @@ defer eval
     ok-symbol
 ;
 
+: if? ( obj -- obj bool )
+    if-symbol tagged-list? ;
+
+: if-predicate ( ifobj -- pred )
+    cdr car ;
+
+: if-consequent ( ifobj -- conseq )
+    cdr cdr car ;
+
+: if-alternative ( ifobj -- alt|false )
+    cdr cdr cdr
+    2dup nil objeq? if
+        2drop false
+    else
+        car
+    then ;
+
+: false? ( boolobj -- boolean )
+    boolean-type istype? if
+        false boolean-type objeq?
+    else
+        2drop false
+    then
+;
+
+: true? ( boolobj -- boolean )
+    false? invert ;
+
 :noname ( obj env -- result )
     2swap
 
@@ -773,6 +802,20 @@ defer eval
         exit
     then
 
+    if? if
+        2over 2over
+        if-predicate
+        2swap eval 
+
+        true? if
+            if-consequent
+        else
+            if-alternative
+        then
+
+        2swap ['] eval goto
+    then
+
     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
     abort
 ; is eval