From 7888f570d4b32b447622e25c38a4e78197cc7732 Mon Sep 17 00:00:00 2001
From: Tim Vaughan <tgvaughan@gmail.com>
Date: Sat, 5 Nov 2016 21:30:29 +1300
Subject: [PATCH] Implemented unquote-splicing

---
 scheme.4th | 36 +++++++++++++++++++++++++++++++-----
 1 file changed, 31 insertions(+), 5 deletions(-)

diff --git a/scheme.4th b/scheme.4th
index 69154f2..c300365 100644
--- 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,6 +1084,15 @@ parse-idx-stack parse-idx-sp !
     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
@@ -1090,10 +1101,22 @@ defer eval-quasiquote-item
 
     2over 2over ( env obj env obj )
 
-    car eval-quasiquote-item ( env obj caritem )
+    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
 
-    -2rot cdr recurse ( caritem cdritems )
-    cons
 ;
 
 :noname ( env obj )
@@ -1571,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
-- 
2.20.1