* [PATCH] Quasisyntax support, update #2
@ 2009-10-29 20:20 Andreas Rottmann
0 siblings, 0 replies; only message in thread
From: Andreas Rottmann @ 2009-10-29 20:20 UTC (permalink / raw)
To: Guile Developers
[-- Attachment #1: Type: text/plain, Size: 162 bytes --]
Hi!
Here is another update for the quasisyntax patch. It adds two small
testcases, and fixes the SRFI-10 test to revert its changes to the
global reader table.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Quasisyntax support --]
[-- Type: text/x-diff, Size: 7546 bytes --]
From: Andreas Rottmann <a.rottmann@gmx.at>
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
+;; <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)))
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)
[-- Attachment #3: Type: text/plain, Size: 63 bytes --]
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2009-10-29 20:20 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2009-10-29 20:20 [PATCH] Quasisyntax support, update #2 Andreas Rottmann
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).