1;; Quasisyntax in terms of syntax-case.
2;;
3;; Code taken from
4;; <http://www.het.brown.edu/people/andre/macros/index.html>;
5;; Copyright (c) 2006 Andre van Tonder. All Rights Reserved.
6;;
7;; Permission is hereby granted, free of charge, to any person
8;; obtaining a copy of this software and associated documentation
9;; files (the "Software"), to deal in the Software without
10;; restriction, including without limitation the rights to use, copy,
11;; modify, merge, publish, distribute, sublicense, and/or sell copies
12;; of the Software, and to permit persons to whom the Software is
13;; furnished to do so, subject to the following conditions:
14;;
15;; The above copyright notice and this permission notice shall be
16;; included in all copies or substantial portions of the Software.
17;;
18;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
22;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
23;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
24;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
25;; SOFTWARE.
26
27;;=========================================================
28;;
29;; To make nested unquote-splicing behave in a useful way,
30;; the R5RS-compatible extension of quasiquote in appendix B
31;; of the following paper is here ported to quasisyntax:
32;;
33;; Alan Bawden - Quasiquotation in Lisp
34;; http://citeseer.ist.psu.edu/bawden99quasiquotation.html
35;;
36;; The algorithm converts a quasisyntax expression to an
37;; equivalent with-syntax expression.
38;; For example:
39;;
40;; (quasisyntax (set! #,a #,b))
41;;   ==> (with-syntax ((t0 a)
42;;                     (t1 b))
43;;         (syntax (set! t0 t1)))
44;;
45;; (quasisyntax (list #,@args))
46;;   ==> (with-syntax (((t ...) args))
47;;         (syntax (list t ...)))
48;;
49;; Note that quasisyntax is expanded first, before any
50;; ellipses act.  For example:
51;;
52;; (quasisyntax (f ((b #,a) ...))
53;;   ==> (with-syntax ((t a))
54;;         (syntax (f ((b t) ...))))
55;;
56;; so that
57;;
58;; (let-syntax ((test-ellipses-over-unsyntax
59;;               (lambda (e)
60;;                 (let ((a (syntax a)))
61;;                   (with-syntax (((b ...) (syntax (1 2 3))))
62;;                     (quasisyntax
63;;                      (quote ((b #,a) ...))))))))
64;;   (test-ellipses-over-unsyntax))
65;;
66;;     ==> ((1 a) (2 a) (3 a))
67(define-syntax quasisyntax
68  (lambda (e)
69
70    ;; Expand returns a list of the form
71    ;;    [template[t/e, ...] (replacement ...)]
72    ;; Here template[t/e ...] denotes the original template
73    ;; with unquoted expressions e replaced by fresh
74    ;; variables t, followed by the appropriate ellipses
75    ;; if e is also spliced.
76    ;; The second part of the return value is the list of
77    ;; replacements, each of the form (t e) if e is just
78    ;; unquoted, or ((t ...) e) if e is also spliced.
79    ;; This will be the list of bindings of the resulting
80    ;; with-syntax expression.
81
82    (define (expand x level)
83      (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
84        ((quasisyntax e)
85         (with-syntax (((k _)     x) ;; original identifier must be copied
86                       ((e* reps) (expand (syntax e) (+ level 1))))
87           (syntax ((k e*) reps))))
88        ((unsyntax e)
89         (= level 0)
90         (with-syntax (((t) (generate-temporaries '(t))))
91           (syntax (t ((t e))))))
92        (((unsyntax e ...) . r)
93         (= level 0)
94         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
95                       ((t ...)        (generate-temporaries (syntax (e ...)))))
96           (syntax ((t ... . r*)
97                    ((t e) ... rep ...)))))
98        (((unsyntax-splicing e ...) . r)
99         (= level 0)
100         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
101                       ((t ...)        (generate-temporaries (syntax (e ...)))))
102           (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
103             (syntax ((t ... ... . r*)
104                      (((t ...) e) ... rep ...))))))
105        ((k . r)
106         (and (> level 0)
107              (identifier? (syntax k))
108              (or (free-identifier=? (syntax k) (syntax unsyntax))
109                  (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
110         (with-syntax (((r* reps) (expand (syntax r) (- level 1))))
111           (syntax ((k . r*) reps))))
112        ((h . t)
113         (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
114                       ((t* (rep2 ...)) (expand (syntax t) level)))
115           (syntax ((h* . t*)
116                    (rep1 ... rep2 ...)))))
117        (#(e ...)
118         (with-syntax ((((e* ...) reps)
119                        (expand (vector->list (syntax #(e ...))) level)))
120           (syntax (#(e* ...) reps))))
121        (other
122         (syntax (other ())))))
123
124    (syntax-case e ()
125      ((_ template)
126       (with-syntax (((template* replacements) (expand (syntax template) 0)))
127         (syntax
128          (with-syntax replacements (syntax template*))))))))
129
130(define-syntax unsyntax
131  (lambda (e)
132    (syntax-violation 'unsyntax "Invalid expression" e)))
133
134(define-syntax unsyntax-splicing
135  (lambda (e)
136    (syntax-violation 'unsyntax "Invalid expression" e)))
137