1 ;"mwexpand.scm" macro expander
2 ; Copyright 1992 William Clinger
4 ; Permission to copy this software, in whole or in part, to use this
5 ; software for any lawful purpose, and to redistribute this software
6 ; is granted subject to the restriction that all copies made of this
7 ; software must include this copyright notice in full.
9 ; I also request that you send me a copy of any improvements that you
10 ; make to this software so that they may be incorporated within it to
11 ; the benefit of the Scheme community.
13 ; The external entry points and kernel of the macro expander.
15 ; Part of this code is snarfed from the Twobit macro expander.
17 (define mw:define-syntax-scope
20 (cond ((null? args) flag)
21 ((not (null? (cdr args)))
23 "Too many arguments passed to define-syntax-scope"
25 ((memq (car args) '(letrec letrec* let*))
26 (set! flag (car args)))
27 (else (mw:warn "Unrecognized argument to define-syntax-scope"
30 (define mw:quit ; assigned by macwork:expand
33 (define (macwork:expand def-or-exp)
34 (call-with-current-continuation
37 (set! mw:renaming-counter 0)
38 (mw:desugar-definitions def-or-exp mw:global-syntax-environment))))
40 (define (mw:desugar-definitions exp env)
43 (lambda (exp rest first)
44 (cond ((and (pair? exp)
45 (eq? (mw:syntax-lookup env (car exp))
48 (define-loop (cadr exp) (append (cddr exp) rest) first))
50 (eq? (mw:syntax-lookup env (car exp))
52 (let ((exp (desugar-define exp env)))
53 (cond ((and (null? first) (null? rest))
56 (cons mw:begin1 (reverse (cons exp first))))
57 (else (define-loop (car rest)
61 (eq? (mw:syntax-lookup env (car exp))
62 mw:denote-of-define-syntax)
64 (define-syntax-loop exp rest))
65 ((and (null? first) (null? rest))
68 (cons mw:begin1 (reverse (cons (mw:expand exp env) first))))
70 (append (reverse first)
71 (map (lambda (exp) (mw:expand exp env))
72 (cons exp rest))))))))
77 ((null? (cdr exp)) (mw:error "Malformed definition" exp))
78 ; (define foo) syntax is transformed into (define foo (undefined)).
80 (let ((id (cadr exp)))
82 (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
83 (list mw:define1 id mw:undefined)))
85 ; mw:lambda0 is an unforgeable lambda, needed here because the
86 ; lambda expression will undergo further expansion.
87 (desugar-define `(,mw:define1 ,(car (cadr exp))
88 (,mw:lambda0 ,(cdr (cadr exp))
91 ((> (length exp) 3) (mw:error "Malformed definition" exp))
92 (else (let ((id (cadr exp)))
94 (mw:syntax-bind-globally! id (mw:make-identifier-denotation id))
95 `(,mw:define1 ,id ,(mw:expand (caddr exp) env)))))))
99 (cond ((and (pair? exp)
100 (eq? (mw:syntax-lookup env (car exp))
103 (define-syntax-loop (cadr exp) (append (cddr exp) rest)))
105 (eq? (mw:syntax-lookup env (car exp))
106 mw:denote-of-define-syntax))
107 (if (pair? (cdr exp))
108 (redefinition (cadr exp)))
110 (mw:define-syntax exp env)
111 (begin (mw:define-syntax exp env)
112 (define-syntax-loop (car rest) (cdr rest)))))
115 (else (cons mw:begin1
116 (map (lambda (exp) (mw:expand exp env))
117 (cons exp rest)))))))
122 (if (not (mw:identifier?
123 (mw:syntax-lookup mw:global-syntax-environment id)))
124 (mw:warn "Redefining keyword" id))
125 (mw:error "Malformed variable or keyword" id)))))
129 (define-loop exp '() '())))
131 ; Given an expression and a syntactic environment,
132 ; returns an expression in core Scheme.
134 (define (mw:expand exp env)
135 (if (not (pair? exp))
137 (let ((keyword (mw:syntax-lookup env (car exp))))
138 (case (mw:denote-class keyword)
141 ((eq? keyword mw:denote-of-quote) (mw:quote exp))
142 ((eq? keyword mw:denote-of-lambda) (mw:lambda exp env))
143 ((eq? keyword mw:denote-of-if) (mw:if exp env))
144 ((eq? keyword mw:denote-of-set!) (mw:set exp env))
145 ((eq? keyword mw:denote-of-begin) (mw:begin exp env))
146 ((eq? keyword mw:denote-of-let-syntax) (mw:let-syntax exp env))
147 ((eq? keyword mw:denote-of-letrec-syntax)
148 (mw:letrec-syntax exp env))
149 ; @@ case has a nontrivial syntax also -- wdc
150 ((eq? keyword mw:denote-of-case) (mw:case exp env))
151 ; @@ let, let*, letrec, paint within quasiquotation -- kend
152 ((eq? keyword mw:denote-of-let) (mw:let exp env))
153 ((eq? keyword mw:denote-of-let*) (mw:let* exp env))
154 ((eq? keyword mw:denote-of-letrec) (mw:letrec exp env))
155 ((eq? keyword mw:denote-of-quasiquote) (mw:quasiquote exp env))
156 ((eq? keyword mw:denote-of-do) (mw:do exp env))
157 ((or (eq? keyword mw:denote-of-define)
158 (eq? keyword mw:denote-of-define-syntax))
159 ;; slight hack to allow expansion into defines -KenD
161 (mw:error "Definition out of context" exp)
163 (set! mw:in-define? #t)
164 (let ( (result (mw:desugar-definitions exp env)) )
165 (set! mw:in-define? #f)
168 (else (mw:bug "Bug detected in mw:expand" exp env))))
169 ((macro) (mw:macro exp env))
170 ((identifier) (mw:application exp env))
171 (else (mw:bug "Bug detected in mw:expand" exp env))
175 (define mw:in-define? #f) ; should be fluid
177 (define (mw:atom exp env)
178 (cond ((not (symbol? exp))
179 ; Here exp ought to be a boolean, number, character, or string,
180 ; but I'll allow for non-standard extensions by passing exp
181 ; to the underlying Scheme system without further checking.
183 (else (let ((denotation (mw:syntax-lookup env exp)))
184 (case (mw:denote-class denotation)
186 (mw:error "Syntactic keyword used as a variable" exp env))
187 ((identifier) (mw:identifier-name denotation))
188 (else (mw:bug "Bug detected by mw:atom" exp env)))))))
190 (define (mw:quote exp)
191 (if (= (mw:safe-length exp) 2)
192 (list mw:quote1 (mw:strip (cadr exp)))
193 (mw:error "Malformed quoted constant" exp)))
195 (define (mw:lambda exp env)
196 (if (> (mw:safe-length exp) 2)
197 (let* ((formals (cadr exp))
198 (alist (mw:rename-vars (mw:make-null-terminated formals)))
199 (env (mw:syntax-rename env alist))
202 (mw:rename-formals formals alist)
204 (mw:error "Malformed lambda expression" exp)))
206 (define (mw:body body env)
207 (define (loop body env defs)
209 (mw:error "Empty body"))
210 (let ((exp (car body)))
213 (let ((denotation (mw:syntax-lookup env (car exp))))
214 (case (mw:denote-class denotation)
216 (cond ((eq? denotation mw:denote-of-begin)
217 (loop (append (cdr exp) (cdr body)) env defs))
218 ((eq? denotation mw:denote-of-define)
219 (loop (cdr body) env (cons exp defs)))
220 (else (mw:finalize-body body env defs))))
225 (loop (cons exp (cdr body))
229 (mw:finalize-body body env defs))
230 (else (mw:bug "Bug detected in mw:body" body env))))
231 (mw:finalize-body body env defs))))
234 (define (mw:finalize-body body env defs)
236 (let ((body (map (lambda (exp) (mw:expand exp env))
238 (if (null? (cdr body))
240 (cons mw:begin1 body)))
241 (let* ((alist (mw:rename-vars '(quote lambda set!)))
242 (env (mw:syntax-alias env alist mw:standard-syntax-environment))
243 (new-quote (cdr (assq 'quote alist)))
244 (new-lambda (cdr (assq 'lambda alist)))
245 (new-set! (cdr (assq 'set! alist))))
246 (define (desugar-definition def)
247 (if (> (mw:safe-length def) 2)
248 (cond ((pair? (cadr def))
257 (else (mw:error "Malformed definition" def env)))
258 (mw:error "Malformed definition" def env)))
260 `(letrec ,(map desugar-definition (reverse defs)) ,@body)
264 (define (mw:if exp env)
265 (let ((n (mw:safe-length exp)))
266 (if (or (= n 3) (= n 4))
267 (cons mw:if1 (map (lambda (exp) (mw:expand exp env)) (cdr exp)))
268 (mw:error "Malformed if expression" exp env))))
270 (define (mw:set exp env)
271 (if (= (mw:safe-length exp) 3)
272 `(,mw:set!1 ,(mw:expand (cadr exp) env) ,(mw:expand (caddr exp) env))
273 (mw:error "Malformed assignment" exp env)))
275 (define (mw:begin exp env)
276 (if (positive? (mw:safe-length exp))
277 `(,mw:begin1 ,@(map (lambda (exp) (mw:expand exp env)) (cdr exp)))
278 (mw:error "Malformed begin expression" exp env)))
280 (define (mw:application exp env)
281 (if (> (mw:safe-length exp) 0)
282 (map (lambda (exp) (mw:expand exp env))
284 (mw:error "Malformed application")))
286 ; I think the environment argument should always be global here.
288 (define (mw:define-syntax exp env)
289 (cond ((and (= (mw:safe-length exp) 3)
290 (symbol? (cadr exp)))
291 (mw:define-syntax1 (cadr exp)
294 (mw:define-syntax-scope)))
295 ((and (= (mw:safe-length exp) 4)
297 (memq (caddr exp) '(letrec letrec* let*)))
298 (mw:define-syntax1 (cadr exp)
302 (else (mw:error "Malformed define-syntax" exp env))))
304 (define (mw:define-syntax1 keyword spec env scope)
306 ((letrec) (mw:define-syntax-letrec keyword spec env))
307 ((letrec*) (mw:define-syntax-letrec* keyword spec env))
308 ((let*) (mw:define-syntax-let* keyword spec env))
309 (else (mw:bug "Weird scope" scope)))
310 (list mw:quote1 keyword))
312 (define (mw:define-syntax-letrec keyword spec env)
313 (mw:syntax-bind-globally!
315 (mw:compile-transformer-spec spec env)))
317 (define (mw:define-syntax-letrec* keyword spec env)
318 (let* ((env (mw:syntax-extend (mw:syntax-copy env)
320 '((fake denotation))))
321 (transformer (mw:compile-transformer-spec spec env)))
322 (mw:syntax-assign! env keyword transformer)
323 (mw:syntax-bind-globally! keyword transformer)))
325 (define (mw:define-syntax-let* keyword spec env)
326 (mw:syntax-bind-globally!
328 (mw:compile-transformer-spec spec (mw:syntax-copy env))))
330 (define (mw:let-syntax exp env)
331 (if (and (> (mw:safe-length exp) 2)
332 (comlist:every (lambda (binding)
334 (symbol? (car binding))
335 (pair? (cdr binding))
336 (null? (cddr binding))))
339 (mw:syntax-extend env
342 (mw:compile-transformer-spec
345 (map cadr (cadr exp)))))
346 (mw:error "Malformed let-syntax" exp env)))
348 (define (mw:letrec-syntax exp env)
349 (if (and (> (mw:safe-length exp) 2)
350 (comlist:every (lambda (binding)
352 (symbol? (car binding))
353 (pair? (cdr binding))
354 (null? (cddr binding))))
356 (let ((env (mw:syntax-extend env
361 (for-each (lambda (id spec)
365 (mw:compile-transformer-spec spec env)))
367 (map cadr (cadr exp)))
368 (mw:body (cddr exp) env))
369 (mw:error "Malformed let-syntax" exp env)))
371 (define (mw:macro exp env)
375 (mw:expand exp env))))
378 ; Clean up alist hacking et cetera.
380 ;;-----------------------------------------------------------------
381 ;; The following was added to allow expansion without flattening
382 ;; LETs to LAMBDAs so that the origianl structure of the program
383 ;; is preserved by macro expansion. I.e. so that usual.scm is not
384 ;; required. -- added KenD
386 (define (mw:process-let-bindings alist binding-list env) ;; helper proc
388 (list (cdr (assq (car bind) alist)) ; renamed name
389 (mw:body (cdr bind) env))) ; alpha renamed value expression
393 (define (mw:strip-begin exp) ;; helper proc: mw:body sometimes puts one in
394 (if (and (pair? exp) (eq? (car exp) 'begin))
399 ; CASE -- added by wdc
400 (define (mw:case exp env)
401 (let ((expand (lambda (exp)
402 (mw:expand exp env))))
403 (if (< (mw:safe-length exp) 3)
404 (mw:error "Malformed case expression" exp env)
405 `(case ,(expand (cadr exp))
406 ,@(map (lambda (clause)
407 (if (< (mw:safe-length exp) 2)
408 (mw:error "Malformed case clause" exp env)
409 (cons (mw:strip (car clause))
410 (map expand (cdr clause)))))
415 (define (mw:let exp env)
416 (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp)))
418 (cadr exp))) ; named let?
419 (binds (if name (caddr exp) (cadr exp)))
420 (body (if name (cdddr exp) (cddr exp)))
421 (vars (if (null? binds) #f (map car binds)))
422 (alist (if vars (mw:rename-vars vars) #f))
423 (newenv (if alist (mw:syntax-rename env alist) env))
425 (if name ;; extend env with new name
426 (let ( (rename (mw:rename-vars (list name))) )
427 (set! alist (append rename alist))
428 (set! newenv (mw:syntax-rename newenv rename))
431 ,@(if name (list (cdr (assq name alist))) '())
432 ,(mw:process-let-bindings alist binds env)
433 ,(mw:body body newenv))
437 ; LETREC differs from LET in that the binding values are processed in the
438 ; new rather than the original environment.
440 (define (mw:letrec exp env)
441 (let* ( (binds (cadr exp))
443 (vars (if (null? binds) #f (map car binds)))
444 (alist (if vars (mw:rename-vars vars) #f))
445 (newenv (if alist (mw:syntax-rename env alist) env))
448 ,(mw:process-let-bindings alist binds newenv)
449 ,(mw:body body newenv))
453 ; LET* adds to ENV for each new binding.
455 (define (mw:let* exp env)
456 (let ( (binds (cadr exp))
459 (let bind-loop ( (bindings binds) (newbinds '()) (newenv env) )
461 `(let* ,(reverse newbinds) ,(mw:body body newenv))
462 (let* ( (bind (car bindings))
465 (rename (mw:rename-vars (list var)))
466 (next-newenv (mw:syntax-rename newenv rename))
468 (bind-loop (cdr bindings)
469 (cons (list (cdr (assq var rename))
470 (mw:body valexp newenv))
478 (define (mw:process-do-bindings var-init-steps alist oldenv newenv) ;; helper proc
482 (s (if (null? (cddr vis)) (car vis) (caddr vis))))
483 `( ,(cdr (assq v alist)) ; renamed name
484 ,(mw:body (list i) oldenv) ; init in outer/old env
485 ,(mw:body (list s) newenv) ))) ; step in letrec/inner/new env
489 (define (mw:do exp env)
490 (let* ( (vis (cadr exp)) ; (Var Init Step ...)
491 (ts (caddr exp)) ; (Test Sequence ...)
492 (com (cdddr exp)) ; (COMmand ...)
493 (vars (if (null? vis) #f (map car vis)))
494 (rename (if vars (mw:rename-vars vars) #f))
495 (newenv (if vars (mw:syntax-rename env rename) env))
497 `(do ,(if vars (mw:process-do-bindings vis rename env newenv) '())
498 ,(if (null? ts) '() (mw:strip-begin (mw:body (list ts) newenv)))
499 ,@(if (null? com) '() (list (mw:body com newenv))))
503 ; Quasiquotation (backquote)
505 ; At level 0, unquoted forms are left painted (not mw:strip'ed).
506 ; At higher levels, forms which are unquoted to level 0 are painted.
507 ; This includes forms within quotes. E.g.:
510 ; (a (unquote a) b (quasiquote (a (unquote (unquote a)) b)))))
512 ; (lambda (a) `(a ,a b `(a ,,a b)))
514 ; (lambda (a|1) `(a ,a|1 b `(a ,,a|1 b)))
516 (define (mw:quasiquote exp env)
518 (define (mw:atom exp env)
519 (if (not (symbol? exp))
521 (let ((denotation (mw:syntax-lookup env exp)))
522 (case (mw:denote-class denotation)
523 ((special macro identifier) (mw:identifier-name denotation))
524 (else (mw:bug "Bug detected by mw:atom" exp env))))
527 (define (quasi subexp level)
529 ((null? subexp) subexp)
530 ((not (or (pair? subexp) (vector? subexp)))
531 (if (zero? level) (mw:atom subexp env) subexp) ; the work is here
534 (let* ((l (vector-length subexp))
538 (vector-set! v i (quasi (vector-ref subexp i) level))
543 (let ( (keyword (mw:syntax-lookup env (car subexp))) )
545 ((eq? keyword mw:denote-of-unquote)
546 (cons 'unquote (quasi (cdr subexp) (- level 1)))
548 ((eq? keyword mw:denote-of-unquote-splicing)
549 (cons 'unquote-splicing (quasi (cdr subexp) (- level 1)))
551 ((eq? keyword mw:denote-of-quasiquote)
552 (cons 'quasiquote (quasi (cdr subexp) (+ level 1)))
555 (cons (quasi (car subexp) level) (quasi (cdr subexp) level))
562 (quasi exp 0) ; need to unquote to level 0 to paint