add quasisyntax

* module/Makefile.am:
* module/ice-9/boot-9.scm:
* module/ice-9/quasisyntax.scm: Add quasisyntax. Implementation by Andre
  van Tonder, patch by Andreas Rottmann.
* test-suite/tests/srfi-10.test: Hack to remove srfi-10's clobbering of
  #,.
* test-suite/tests/syncase.test: Add a quasisyntax test.

module/Makefile.am

@@ -55,7 +55,11 @@ SOURCES =								\
   $(BRAINFUCK_LANG_SOURCES)
 
 ## test.scm is not currently installed.
-EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
+EXTRA_DIST +=					\
+  ice-9/test.scm				\
+  ice-9/compile-psyntax.scm			\
+  ice-9/quasisyntax.scm				\
+  ice-9/ChangeLog-2008
 
 # We expect this to never be invoked when there is not already
 # ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends

module/ice-9/boot-9.scm

@@ -308,6 +308,8 @@
   (syntax-rules ()
     ((_ exp) (make-promise (lambda () exp)))))
 
+(include-from-path "ice-9/quasisyntax")
+
 ;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
 ;;; Please let the Guile developers know if you are using this macro.
 ;;;

module/ice-9/quasisyntax.scm

@@ -0,0 +1,136 @@
+;; Quasisyntax in terms of syntax-case.
+;;
+;; Code taken from
+;; <http://www.het.brown.edu/people/andre/macros/index.html>;
+;; Copyright (c) 2006 Andre van Tonder. All Rights Reserved.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;=========================================================
+;;
+;; To make nested unquote-splicing behave in a useful way,
+;; the R5RS-compatible extension of quasiquote in appendix B
+;; of the following paper is here ported to quasisyntax:
+;;
+;; Alan Bawden - Quasiquotation in Lisp
+;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
+;;
+;; The algorithm converts a quasisyntax expression to an
+;; equivalent with-syntax expression.
+;; For example:
+;;
+;; (quasisyntax (set! #,a #,b))
+;;   ==> (with-syntax ((t0 a)
+;;                     (t1 b))
+;;         (syntax (set! t0 t1)))
+;;
+;; (quasisyntax (list #,@args))
+;;   ==> (with-syntax (((t ...) args))
+;;         (syntax (list t ...)))
+;;
+;; Note that quasisyntax is expanded first, before any
+;; ellipses act.  For example:
+;;
+;; (quasisyntax (f ((b #,a) ...))
+;;   ==> (with-syntax ((t a))
+;;         (syntax (f ((b t) ...))))
+;;
+;; so that
+;;
+;; (let-syntax ((test-ellipses-over-unsyntax
+;;               (lambda (e)
+;;                 (let ((a (syntax a)))
+;;                   (with-syntax (((b ...) (syntax (1 2 3))))
+;;                     (quasisyntax
+;;                      (quote ((b #,a) ...))))))))
+;;   (test-ellipses-over-unsyntax))
+;;
+;;     ==> ((1 a) (2 a) (3 a))
+(define-syntax quasisyntax
+  (lambda (e)
+
+    ;; Expand returns a list of the form
+    ;;    [template[t/e, ...] (replacement ...)]
+    ;; Here template[t/e ...] denotes the original template
+    ;; with unquoted expressions e replaced by fresh
+    ;; variables t, followed by the appropriate ellipses
+    ;; if e is also spliced.
+    ;; The second part of the return value is the list of
+    ;; replacements, each of the form (t e) if e is just
+    ;; unquoted, or ((t ...) e) if e is also spliced.
+    ;; This will be the list of bindings of the resulting
+    ;; with-syntax expression.
+
+    (define (expand x level)
+      (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
+        ((quasisyntax e)
+         (with-syntax (((k _)     x) ;; original identifier must be copied
+                       ((e* reps) (expand (syntax e) (+ level 1))))
+           (syntax ((k e*) reps))))
+        ((unsyntax e)
+         (= level 0)
+         (with-syntax (((t) (generate-temporaries '(t))))
+           (syntax (t ((t e))))))
+        (((unsyntax e ...) . r)
+         (= level 0)
+         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+                       ((t ...)        (generate-temporaries (syntax (e ...)))))
+           (syntax ((t ... . r*)
+                    ((t e) ... rep ...)))))
+        (((unsyntax-splicing e ...) . r)
+         (= level 0)
+         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+                       ((t ...)        (generate-temporaries (syntax (e ...)))))
+           (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
+             (syntax ((t ... ... . r*)
+                      (((t ...) e) ... rep ...))))))
+        ((k . r)
+         (and (> level 0)
+              (identifier? (syntax k))
+              (or (free-identifier=? (syntax k) (syntax unsyntax))
+                  (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
+         (with-syntax (((r* reps) (expand (syntax r) (- level 1))))
+           (syntax ((k . r*) reps))))
+        ((h . t)
+         (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
+                       ((t* (rep2 ...)) (expand (syntax t) level)))
+           (syntax ((h* . t*)
+                    (rep1 ... rep2 ...)))))
+        (#(e ...)
+         (with-syntax ((((e* ...) reps)
+                        (expand (vector->list (syntax #(e ...))) level)))
+           (syntax (#(e* ...) reps))))
+        (other
+         (syntax (other ())))))
+
+    (syntax-case e ()
+      ((_ template)
+       (with-syntax (((template* replacements) (expand (syntax template) 0)))
+         (syntax
+          (with-syntax replacements (syntax template*))))))))
+
+(define-syntax unsyntax
+  (lambda (e)
+    (syntax-violation 'unsyntax "Invalid expression" e)))
+
+(define-syntax unsyntax-splicing
+  (lambda (e)
+    (syntax-violation 'unsyntax "Invalid expression" e)))

test-suite/tests/srfi-10.test

@@ -1,7 +1,7 @@
 ;;;; srfi-10.test --- Test suite for Guile's SRFI-10 functions. -*- scheme -*-
 ;;;; Martin Grabmueller, 2001-05-10
 ;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -27,3 +27,7 @@
      (let* ((rx #,(rx "^foo$")))
        (and (->bool (regexp-exec rx "foo"))
 	    (not (regexp-exec rx "bar foo frob"))))))
+
+;; Disable SRFI-10 reader syntax again, to avoid messing up
+;; syntax-case's unsyntax
+(read-hash-extend #\, #f)

test-suite/tests/syncase.test

@@ -1,6 +1,6 @@
 ;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
 ;;;;
-;;;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,3 +31,15 @@
 
 (pass-if "@ works with syncase"
   (eq? run-test (@ (test-suite lib) run-test)))
+
+(define-syntax string-let
+  (lambda (stx)
+    (syntax-case stx ()
+      ((_ id body ...)
+       #`(let ((id #,(symbol->string
+                      (syntax->datum #'id))))
+           body ...)))))
+
+(pass-if "macro using quasisyntax"
+  (equal? (string-let foo (list foo foo))
+          '("foo" "foo")))