1 ;;; "synrul.scm" Rule-based Syntactic Expanders -*-Scheme-*-
2 ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
4 ;;; This material was developed by the Scheme project at the
5 ;;; Massachusetts Institute of Technology, Department of Electrical
6 ;;; Engineering and Computer Science. Permission to copy this
7 ;;; software, to redistribute it, and to use it for any purpose is
8 ;;; granted, subject to the following restrictions and understandings.
10 ;;; 1. Any copy made of this software must include this copyright
13 ;;; 2. Users of this software agree to make their best efforts (a) to
14 ;;; return to the MIT Scheme project any improvements or extensions
15 ;;; that they make, so that these may be included in future releases;
16 ;;; and (b) to inform MIT of noteworthy uses of this software.
18 ;;; 3. All materials developed as a consequence of the use of this
19 ;;; software shall duly acknowledge such use, in accordance with the
20 ;;; usual standards of acknowledging credit in academic research.
22 ;;; 4. MIT has made no warrantee or representation that the operation
23 ;;; of this software will be error-free, and MIT is under no
24 ;;; obligation to provide any services, by way of maintenance, update,
27 ;;; 5. In conjunction with products arising from the use of this
28 ;;; material, there shall be no use of the name of the Massachusetts
29 ;;; Institute of Technology nor of any adaptation thereof in any
30 ;;; advertising, promotional, or sales literature without prior
31 ;;; written consent from MIT in each case.
33 ;;;; Rule-based Syntactic Expanders
35 ;;; See "Syntactic Extensions in the Programming Language Lisp", by
36 ;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986.
37 ;;; See also "Macros That Work", by William Clinger and Jonathan Rees
38 ;;; (reference? POPL?). This implementation is derived from an
39 ;;; implementation by Kent Dybvig, and includes some ideas from
40 ;;; another implementation by Jonathan Rees.
42 ;;; The expansion of SYNTAX-RULES references the following keywords:
43 ;;; ER-TRANSFORMER LAMBDA IF BEGIN SET! QUOTE
44 ;;; and the following procedures:
45 ;;; CAR CDR NULL? PAIR? EQUAL? MAP LIST CONS APPEND
47 ;;; it also uses the anonymous keyword SYNTAX-QUOTE.
50 ;;;(define (run-sr form)
51 ;;; (expand/syntax-rules form (lambda (x) x) eq?))
53 (define (make-syntax-rules-macrology)
54 (make-er-expander-macrology
55 (lambda (define-classifier base-environment)
56 base-environment ;ignore
57 (define-classifier 'SYNTAX-RULES expand/syntax-rules))))
59 (define (expand/syntax-rules form rename compare)
60 (if (syntax-match? '((* IDENTIFIER) + ((IDENTIFIER . DATUM) EXPRESSION))
62 (let ((keywords (cadr form))
63 (clauses (cddr form)))
64 (if (let loop ((keywords keywords))
66 (or (memq (car keywords) (cdr keywords))
67 (loop (cdr keywords)))))
68 (syntax-error "keywords list contains duplicates" keywords)
69 (let ((r-form (rename 'FORM))
70 (r-rename (rename 'RENAME))
71 (r-compare (rename 'COMPARE)))
72 `(,(rename 'ER-TRANSFORMER)
74 (,r-form ,r-rename ,r-compare)
75 ,(let loop ((clauses clauses))
77 `(,(rename 'ILL-FORMED-SYNTAX) ,r-form)
78 (let ((pattern (caar clauses)))
80 (parse-pattern rename compare keywords
83 ,(generate-match rename compare keywords
86 ,(generate-output rename compare r-rename
89 ,(loop (cdr clauses))))))))))))
90 (ill-formed-syntax form)))
92 (define (parse-pattern rename compare keywords pattern expression)
95 (expression expression)
98 (cond ((identifier? pattern)
99 (if (memq pattern keywords)
101 (cons (make-sid pattern expression control) sids)))
102 ((and (or (zero-or-more? pattern rename compare)
103 (at-least-one? pattern rename compare))
104 (null? (cddr pattern)))
105 (let ((variable ((make-name-generator) 'CONTROL)))
109 (make-sid variable expression control))))
112 `(,(rename 'CAR) ,expression)
114 `(,(rename 'CDR) ,expression)
120 (define (generate-match rename compare keywords r-rename r-compare
124 (lambda (pattern expression)
125 (cond ((identifier? pattern)
126 (if (memq pattern keywords)
127 (let ((temp (rename 'TEMP)))
131 (,(rename 'IDENTIFIER?) ,temp)
133 (,r-rename ,(syntax-quote pattern)))
137 ((and (zero-or-more? pattern rename compare)
138 (null? (cddr pattern)))
139 (do-list (car pattern) expression))
140 ((and (at-least-one? pattern rename compare)
141 (null? (cddr pattern)))
142 `(,(rename 'IF) (,(rename 'NULL?) ,expression)
144 ,(do-list (car pattern) expression)))
149 `(,(rename 'PAIR?) ,expression)
152 `(,(rename 'CAR) ,expression))
154 `(,(rename 'CDR) ,expression)))))))
155 (if (identifier? expression)
156 (generate-pair expression)
157 (let ((temp (rename 'TEMP)))
158 `((,(rename 'LAMBDA) (,temp) ,(generate-pair temp))
161 `(,(rename 'NULL?) ,expression))
163 `(,(rename 'EQUAL?) ,expression
164 (,(rename 'QUOTE) ,pattern))))))
166 (lambda (pattern expression)
167 (let ((r-loop (rename 'LOOP))
169 (r-lambda (rename 'LAMBDA)))
178 (,(rename 'NULL?) ,r-l)
181 `(,(rename 'PAIR?) ,r-l)
182 (conjunction (loop pattern `(,(rename 'CAR) ,r-l))
183 `(,r-loop (,(rename 'CDR) ,r-l)))))))
188 (lambda (predicate consequent)
189 (cond ((eq? predicate #T) consequent)
190 ((eq? consequent #T) predicate)
191 (else `(,(rename 'IF) ,predicate ,consequent #F))))))
192 (loop pattern expression)))
194 (define (generate-output rename compare r-rename sids template syntax-error)
195 (let loop ((template template) (ellipses '()))
196 (cond ((identifier? template)
198 (let loop ((sids sids))
199 (and (not (null? sids))
200 (if (eq? (sid-name (car sids)) template)
202 (loop (cdr sids)))))))
205 (add-control! sid ellipses syntax-error)
206 (sid-expression sid))
207 `(,r-rename ,(syntax-quote template)))))
208 ((or (zero-or-more? template rename compare)
209 (at-least-one? template rename compare))
210 (optimized-append rename compare
211 (let ((ellipsis (make-ellipsis '())))
212 (generate-ellipsis rename
217 (loop (cddr template) ellipses)))
219 (optimized-cons rename compare
220 (loop (car template) ellipses)
221 (loop (cdr template) ellipses)))
223 `(,(rename 'QUOTE) ,template)))))
225 (define (add-control! sid ellipses syntax-error)
226 (let loop ((sid sid) (ellipses ellipses))
227 (let ((control (sid-control sid)))
230 (syntax-error "missing ellipsis in expansion" #f)
231 (let ((sids (ellipsis-sids (car ellipses))))
232 (cond ((not (memq control sids))
233 (set-ellipsis-sids! (car ellipses)
234 (cons control sids)))
235 ((not (eq? control (car sids)))
236 (syntax-error "illegal control/ellipsis combination"
238 (loop control (cdr ellipses)))
239 ((not (null? ellipses))
240 (syntax-error "extra ellipsis in expansion" #f))))))
242 (define (generate-ellipsis rename ellipsis body)
243 (let ((sids (ellipsis-sids ellipsis)))
244 (let ((name (sid-name (car sids)))
245 (expression (sid-expression (car sids))))
246 (cond ((and (null? (cdr sids))
249 ((and (null? (cdr sids))
252 (eq? (cadr body) name)
254 `(,(rename 'MAP) ,(car body) ,expression))
256 `(,(rename 'MAP) (,(rename 'LAMBDA) ,(map sid-name sids) ,body)
257 ,@(map sid-expression sids)))))))
259 (define (zero-or-more? pattern rename compare)
261 (pair? (cdr pattern))
262 (identifier? (cadr pattern))
263 (compare (cadr pattern) (rename '...))))
265 (define (at-least-one? pattern rename compare)
266 ;;; (and (pair? pattern)
267 ;;; (pair? (cdr pattern))
268 ;;; (identifier? (cadr pattern))
269 ;;; (compare (cadr pattern) (rename '+)))
270 pattern rename compare ;ignore
273 (define (optimized-cons rename compare a d)
274 (cond ((and (pair? d)
275 (compare (car d) (rename 'QUOTE))
279 `(,(rename 'LIST) ,a))
281 (compare (car d) (rename 'LIST))
283 `(,(car d) ,a ,@(cdr d)))
285 `(,(rename 'CONS) ,a ,d))))
287 (define (optimized-append rename compare x y)
289 (compare (car y) (rename 'QUOTE))
294 `(,(rename 'APPEND) ,x ,y)))
297 (make-record-type "sid" '(NAME EXPRESSION CONTROL OUTPUT-EXPRESSION)))
300 (record-constructor sid-type '(NAME EXPRESSION CONTROL)))
303 (record-accessor sid-type 'NAME))
305 (define sid-expression
306 (record-accessor sid-type 'EXPRESSION))
309 (record-accessor sid-type 'CONTROL))
311 (define sid-output-expression
312 (record-accessor sid-type 'OUTPUT-EXPRESSION))
314 (define set-sid-output-expression!
315 (record-modifier sid-type 'OUTPUT-EXPRESSION))
317 (define ellipsis-type
318 (make-record-type "ellipsis" '(SIDS)))
320 (define make-ellipsis
321 (record-constructor ellipsis-type '(SIDS)))
323 (define ellipsis-sids
324 (record-accessor ellipsis-type 'SIDS))
326 (define set-ellipsis-sids!
327 (record-modifier ellipsis-type 'SIDS))