From: Andreas Rottmann Subject: [PATCH] Add support for `quasisyntax' --- module/ice-9/boot-9.scm | 2 + module/ice-9/quasisyntax.scm | 136 +++++++++++++++++++++++++++++++++++++++++ test-suite/tests/srfi-10.test | 4 + test-suite/tests/syncase.test | 12 ++++ 4 files changed, 154 insertions(+), 0 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5852477..2120c1d 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -308,6 +308,8 @@ (syntax-rules () ((_ exp) (make-promise (lambda () exp))))) +(primitive-load-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. ;;; diff --git a/module/ice-9/quasisyntax.scm b/module/ice-9/quasisyntax.scm new file mode 100644 index 0000000..ec3cace --- /dev/null +++ b/module/ice-9/quasisyntax.scm @@ -0,0 +1,136 @@ +;; Quasisyntax in terms of syntax-case. +;; +;; Code taken from +;; ; +;; 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))) diff --git a/test-suite/tests/srfi-10.test b/test-suite/tests/srfi-10.test index ab3cb88..53b18e9 100644 --- a/test-suite/tests/srfi-10.test +++ b/test-suite/tests/srfi-10.test @@ -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) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index 72acdec..cb916cf 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -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"))) -- tg: (b158c2c..) t/quasisyntax (depends on: master)