unquote and unquote-splicing can split multiple expressions

* module/ice-9/psyntax.scm (quasiquote): Import new definition from
  upstream psyntax, to allow unquote and unquote-splicing to take
  multiple arguments.
  (unquote, unquote-splicing): Adapt to not require a particular syntax
  form.

* module/ice-9/psyntax-pp.scm: Regenerated.

module/ice-9/psyntax.scm

@@ -2657,66 +2657,109 @@
                         (begin c ... (doloop step ...)))))))))))
 
 (define-syntax quasiquote
-   (letrec
+  (let ()
-      ((quasicons
+    (define (quasi p lev)
-        (lambda (x y)
+      (syntax-case p (unquote quasiquote)
-          (with-syntax ((x x) (y y))
-            (syntax-case #'y (quote list)
-              ((quote dy)
-               (syntax-case #'x (quote)
-                 ((quote dx) #'(quote (dx . dy)))
-                 (_ (if (null? #'dy)
-                        #'(list x)
-                        #'(cons x y)))))
-              ((list . stuff) #'(list x . stuff))
-              (else #'(cons x y))))))
-       (quasiappend
-        (lambda (x y)
-          (with-syntax ((x x) (y y))
-            (syntax-case #'y (quote)
-              ((quote ()) #'x)
-              (_ #'(append x y))))))
-       (quasivector
-        (lambda (x)
-          (with-syntax ((x x))
-            (syntax-case #'x (quote list)
-              ((quote (x ...)) #'(quote #(x ...)))
-              ((list x ...) #'(vector x ...))
-              (_ #'(list->vector x))))))
-       (quasi
-        (lambda (p lev)
-           (syntax-case p (unquote unquote-splicing quasiquote)
         ((unquote p)
          (if (= lev 0)
-                   #'p
+             #'("value" p)
-                   (quasicons #'(quote unquote)
+             (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
-                              (quasi #'(p) (- lev 1)))))
+        ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
-              ((unquote . args)
-               (= lev 0)
-               (syntax-violation 'unquote
-                                 "unquote takes exactly one argument"
-                                 p #'(unquote . args)))
-              (((unquote-splicing p) . q)
-               (if (= lev 0)
-                   (quasiappend #'p (quasi #'q lev))
-                   (quasicons (quasicons #'(quote unquote-splicing)
-                                         (quasi #'(p) (- lev 1)))
-                              (quasi #'q lev))))
-              (((unquote-splicing . args) . q)
-               (= lev 0)
-               (syntax-violation 'unquote-splicing
-                                 "unquote-splicing takes exactly one argument"
-                                 p #'(unquote-splicing . args)))
-              ((quasiquote p)
-               (quasicons #'(quote quasiquote)
-                          (quasi #'(p) (+ lev 1))))
         ((p . q)
-               (quasicons (quasi #'p lev) (quasi #'q lev)))
+         (syntax-case #'p (unquote unquote-splicing)
-              (#(x ...) (quasivector (quasi #'(x ...) lev)))
+           ((unquote p ...)
-              (p #'(quote p))))))
+            (if (= lev 0)
+                (quasilist* #'(("value" p) ...) (quasi #'q lev))
+                (quasicons
+                 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
+                 (quasi #'q lev))))
+           ((unquote-splicing p ...)
+            (if (= lev 0)
+                (quasiappend #'(("value" p) ...) (quasi #'q lev))
+                (quasicons
+                 (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
+                 (quasi #'q lev))))
+           (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
+        (#(x ...) (quasivector (vquasi #'(x ...) lev)))
+        (p #'("quote" p))))
+    (define (vquasi p lev)
+      (syntax-case p ()
+        ((p . q)
+         (syntax-case #'p (unquote unquote-splicing)
+           ((unquote p ...)
+            (if (= lev 0)
+                (quasilist* #'(("value" p) ...) (vquasi #'q lev))
+                (quasicons
+                 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
+                 (vquasi #'q lev))))
+           ((unquote-splicing p ...)
+            (if (= lev 0)
+                (quasiappend #'(("value" p) ...) (vquasi #'q lev))
+                (quasicons
+                 (quasicons
+                  #'("quote" unquote-splicing)
+                  (quasi #'(p ...) (- lev 1)))
+                 (vquasi #'q lev))))
+           (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
+        (() #'("quote" ()))))
+    (define (quasicons x y)
+      (with-syntax ((x x) (y y))
+        (syntax-case #'y ()
+          (("quote" dy)
+           (syntax-case #'x ()
+             (("quote" dx) #'("quote" (dx . dy)))
+             (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
+          (("list" . stuff) #'("list" x . stuff))
+          (("list*" . stuff) #'("list*" x . stuff))
+          (_ #'("list*" x y)))))
+    (define (quasiappend x y)
+      (syntax-case y ()
+        (("quote" ())
+         (cond
+          ((null? x) #'("quote" ()))
+          ((null? (cdr x)) (car x))
+          (else (with-syntax (((p ...) x)) #'("append" p ...)))))
+        (_
+         (cond
+          ((null? x) y)
+          (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
+    (define (quasilist* x y)
+      (let f ((x x))
+        (if (null? x)
+            y
+            (quasicons (car x) (f (cdr x))))))
+    (define (quasivector x)
+      (syntax-case x ()
+        (("quote" (x ...)) #'("quote" #(x ...)))
+        (_
+         (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
+           (syntax-case y ()
+             (("quote" (y ...)) (k #'(("quote" y) ...)))
+             (("list" y ...) (k #'(y ...)))
+             (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
+             (else #`("list->vector" #,x)))))))
+    (define (emit x)
+      (syntax-case x ()
+        (("quote" x) #''x)
+        (("list" x ...) #`(list #,@(map emit #'(x ...))))
+        ;; could emit list* for 3+ arguments if implementation supports
+        ;; list*
+        (("list*" x ... y)
+         (let f ((x* #'(x ...)))
+           (if (null? x*)
+               (emit #'y)
+               #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
+        (("append" x ...) #`(append #,@(map emit #'(x ...))))
+        (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
+        (("list->vector" x) #`(list->vector #,(emit #'x)))
+        (("value" x) #'x)))
     (lambda (x)
       (syntax-case x ()
-          ((_ e) (quasi #'e 0))))))
+        ;; convert to intermediate language, combining introduced (but
+        ;; not unquoted source) quote expressions where possible and
+        ;; choosing optimal construction code otherwise, then emit
+        ;; Scheme code corresponding to the intermediate language forms.
+        ((_ e) (emit (quasi #'e 0))))))) 
 
 (define-syntax include
   (lambda (x)
@@ -2752,19 +2795,15 @@
 
 (define-syntax unquote
   (lambda (x)
-    (syntax-case x ()
-      ((_ e)
     (syntax-violation 'unquote
                       "expression not valid outside of quasiquote"
-                         x)))))
+                      x)))
 
 (define-syntax unquote-splicing
   (lambda (x)
-    (syntax-case x ()
-      ((_ e)
     (syntax-violation 'unquote-splicing
                       "expression not valid outside of quasiquote"
-                         x)))))
+                      x)))
 
 (define-syntax case
   (lambda (x)