Commit | Line | Data |
---|---|---|
cb65f76c AR |
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))) |