Fixed if form when no alternative.

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

diff --git a/scheme.4th b/scheme.4th
index bacd8e0..244a33f 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -1060,6 +1060,94 @@ parse-idx-stack parse-idx-sp !
 : quote-body ( quote-obj -- quote-body-obj )
     cadr ;
 
+: quasiquote? ( obj -- obj bool )
+    quasiquote-symbol tagged-list? ;
+
+: unquote? ( obj -- obj bool )
+    unquote-symbol tagged-list? ;
+
+: unquote-splicing? ( obj -- obj bool )
+    unquote-splicing-symbol tagged-list? ;
+
+: eval-unquote ( env obj -- res )
+    cdr ( env args )
+
+    nil? if
+        recoverable-exception throw" no arguments to unquote."
+    then
+
+    2dup cdr
+    nil? false = if
+        recoverable-exception throw" too many arguments to unquote."
+    then
+
+    2drop car 2swap eval
+;
+
+( Create a new list from elements of l1 consed on to l2 )
+: join-lists ( l2 l1 -- l3 )
+    nil? if 2drop exit then
+
+    2dup car
+    -2rot cdr
+    recurse cons
+;
+
+defer eval-quasiquote-item
+: eval-quasiquote-list ( env obj -- res )
+    nil? if
+        2swap 2drop exit
+    then
+
+    2over 2over ( env obj env obj )
+
+    cdr recurse
+    -2rot car ( cdritems env objcar )
+
+    unquote-splicing? if
+        eval-unquote ( cdritems caritem )
+
+        2swap nil? if
+            2drop
+        else
+            2swap join-lists
+        then
+    else
+        eval-quasiquote-item ( cdritems caritem )
+        2swap cons
+    then
+
+;
+
+:noname ( env obj )
+    unquote? if
+        eval-unquote exit
+    then
+
+    pair-type istype? if
+        eval-quasiquote-list exit
+    then
+
+    2swap 2drop
+; is eval-quasiquote-item
+
+: eval-quasiquote ( obj env -- res )
+    2swap cdr ( env args )
+
+    nil? if
+        recoverable-exception throw" no arguments to quasiquote."
+    then
+
+    2dup cdr ( env args args-cdr )
+    nil? false = if
+        recoverable-exception throw" too many arguments to quasiquote."
+    then
+
+    2drop car ( env arg )
+
+    eval-quasiquote-item
+;
+
 : variable? ( obj -- obj bool )
     symbol-type istype? ;
 
@@ -1159,10 +1247,10 @@ hide env
 : if-consequent ( ifobj -- conseq )
     cdr cdr car ;
 
-: if-alternative ( ifobj -- alt|false )
+: if-alternative ( ifobj -- alt|none )
     cdr cdr cdr
     nil? if
-        2drop false
+        2drop none
     else
         car
     then ;
@@ -1346,6 +1434,11 @@ hide env
         exit
     then
 
+    quasiquote? if
+        2swap eval-quasiquote
+        exit
+    then
+
     variable? if
         2swap lookup-var
         exit
@@ -1501,6 +1594,9 @@ hide env
 : printnone ( noneobj -- )
     2drop ." Unspecified return value" ;
 
+: printport ( port -- )
+    2drop ." <port>" ;
+
 :noname ( obj -- )
     fixnum-type istype? if printfixnum exit then
     realnum-type istype? if printrealnum exit then