X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=blobdiff_plain;f=scheme.4th;h=f8dd0899d0e02aac9094648a03be84f1f10ee6f6;hp=69154f263b3d4ee12e8def7843faa85b7fa80531;hb=3eaf389aa81bcfbf8dd64c89520925413d5c2390;hpb=dc4ac2b64f29f0fc1154945437b5fe8676be4f27

diff --git a/scheme.4th b/scheme.4th
index 69154f2..f8dd089 100644
--- a/scheme.4th
+++ b/scheme.4th
@@ -139,11 +139,6 @@ variable nextfree
     cdr-cells + !
 ;
 
-: caar car car ;
-: cadr cdr car ;
-: cdar car cdr ;
-: cddr cdr cdr ;
-
 : nil 0 nil-type ;
 : nil? nil-type istype? ;
 
@@ -1058,14 +1053,16 @@ parse-idx-stack parse-idx-sp !
     quote-symbol tagged-list?  ;
 
 : quote-body ( quote-obj -- quote-body-obj )
-    cadr ;
+    cdr car ;
 
 : quasiquote? ( obj -- obj bool )
     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,27 +1079,49 @@ parse-idx-stack parse-idx-sp !
     2drop car 2swap eval
 ;
 
-defer eval-quasiquote-item
-: eval-quasiquote-list ( env obj -- res )
-    nil? if
-        2swap 2drop exit
-    then
+( 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-pair ( env obj -- res )
     2over 2over ( env obj env obj )
 
-    car eval-quasiquote-item ( env obj caritem )
+    cdr eval-quasiquote-item
+
+    -2rot car ( cdritem 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 )
+    nil? if
+        2swap 2drop exit
+    then
+
     unquote? if
         eval-unquote exit
     then
 
     pair-type istype? if
-        eval-quasiquote-list exit
+        eval-quasiquote-pair exit
     then
 
     2swap 2drop
@@ -1224,10 +1243,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 ;
@@ -1384,6 +1403,7 @@ hide env
         endcase
 ;
 
+( Simply evaluates the given procedure with expbody as its argument. )
 : macro-expand ( proc expbody -- result )
     2swap
     2dup procedure-body ( expbody proc procbody )
@@ -1571,6 +1591,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