Implemented unquote-splicing

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

diff --git a/scheme.4th b/scheme.4th
index 5d3b778..c300365 100644 (file)
--- a/scheme.4th
+++ b/scheme.4th
@@ -1064,8 +1064,10 @@ parse-idx-stack parse-idx-sp !
     quasiquote-symbol tagged-list? ;
 
 : unquote? ( obj -- obj bool )
-    unquote-symbol tagged-list?
-;
+    unquote-symbol tagged-list? ;
+
+: unquote-splicing? ( obj -- obj bool )
+    unquote-splicing-symbol tagged-list? ;
 
 : eval-unquote ( env obj -- res )
     cdr ( env args )
@@ -1082,24 +1084,53 @@ parse-idx-stack parse-idx-sp !
     2drop car 2swap eval
 ;
 
-: (eval-quasiquote) ( env obj -- res )
+( 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 car ( env obj env obj-car )
+    2over 2over ( env obj env obj )
 
-    unquote? if
-        eval-unquote
+    cdr recurse
+    -2rot car ( cdritems env objcar )
+
+    unquote-splicing? if
+        eval-unquote ( cdritems caritem )
+
+        2swap nil? if
+            2drop
+        else
+            2swap join-lists
+        then
     else
-        2swap 2drop
+        eval-quasiquote-item ( cdritems caritem )
+        2swap cons
     then
 
-    -2rot cdr ( caritem env cdr )
-    recurse ( caritem cdritems )
-    cons
 ;
 
+: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 )
 
@@ -1114,15 +1145,8 @@ parse-idx-stack parse-idx-sp !
 
     2drop car ( env arg )
 
-    unquote? if
-        eval-unquote exit
-    then
-
-    pair-type istype? if
-        (eval-quasiquote) exit
-    then
-
-    2swap 2drop ;
+    eval-quasiquote-item
+;
 
 : variable? ( obj -- obj bool )
     symbol-type istype? ;
@@ -1570,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