1 ;;; "synclo.scm" Syntactic Closures -*-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 ;;;; Syntactic Closures
34 ;;; written by Alan Bawden
35 ;;; extensively modified by Chris Hanson
37 ;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
38 ;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
39 ;;; Programming, page 86.
42 ;;; The classifier maps forms into items. In addition to locating
43 ;;; definitions so that they can be properly processed, it also
44 ;;; identifies keywords and variables, which allows a powerful form
45 ;;; of syntactic binding to be implemented.
47 (define (classify/form form environment definition-environment)
48 (cond ((identifier? form)
49 (syntactic-environment/lookup environment form))
50 ((syntactic-closure? form)
51 (let ((form (syntactic-closure/form form))
53 (filter-syntactic-environment
54 (syntactic-closure/free-names form)
56 (syntactic-closure/environment form))))
59 definition-environment)))
62 (classify/subexpression (car form) environment)))
63 (cond ((keyword-item? item)
64 ((keyword-item/classifier item) form
66 definition-environment))
69 (classify/subexpressions (cdr form)
74 (compile-item/expression item)
75 (map compile-item/expression items)))
78 (syntax-error "combination must be a proper list"
81 (make-expression-item ;don't quote literals evaluating to themselves
82 (if (or (boolean? form) (char? form) (number? form) (string? form))
83 (lambda () (output/literal-unquoted form))
84 (lambda () (output/literal-quoted form))) form))))
86 (define (classify/subform form environment definition-environment)
89 definition-environment))
91 (define (classify/subforms forms environment definition-environment)
93 (classify/subform form environment definition-environment))
96 (define (classify/subexpression expression environment)
97 (classify/subform expression environment environment))
99 (define (classify/subexpressions expressions environment)
100 (classify/subforms expressions environment environment))
103 ;;; The compiler maps items into the output language.
105 (define (compile-item/expression item)
108 (let ((decompiled (decompile-item item))) (newline)
109 (slib:error (string-append name
110 " may not be used as an expression")
112 (cond ((variable-item? item)
113 (output/variable (variable-item/name item)))
114 ((expression-item? item)
115 ((expression-item/compiler item)))
117 (let ((items (flatten-body-items (body-item/components item))))
119 (illegal item "empty sequence")
120 (output/sequence (map compile-item/expression items)))))
121 ((definition-item? item)
122 (let ((binding ;allows later scheme errors, but allows top-level
123 (bind-definition-item! ;(if (not (defined? x)) define it)
124 scheme-syntactic-environment item))) ;as in Init.scm
125 (output/top-level-definition
127 (compile-item/expression (cdr binding)))))
128 ((keyword-item? item)
129 (illegal item "keyword"))
131 (impl-error "unknown item" item)))))
133 (define (compile/subexpression expression environment)
134 (compile-item/expression
135 (classify/subexpression expression environment)))
137 (define (compile/top-level forms environment)
138 ;; Top-level syntactic definitions affect all forms that appear
140 (output/top-level-sequence
141 (let forms-loop ((forms forms))
147 (classify/subform (car forms)
151 (forms-loop (cdr forms)))
152 ((definition-item? (car items))
154 (bind-definition-item! environment (car items))))
156 (cons (output/top-level-definition
158 (compile-item/expression (cdr binding)))
159 (items-loop (cdr items)))
160 (items-loop (cdr items)))))
162 (cons (compile-item/expression (car items))
163 (items-loop (cdr items))))))))))
166 ;;; The de-compiler maps partly-compiled things back to the input language,
167 ;;; as far as possible. Used to display more meaningful macro error messages.
169 (define (decompile-item item)
171 (cond ((variable-item? item) (variable-item/name item))
172 ((expression-item? item)
173 (decompile-item (expression-item/annotation item)))
175 (let ((items (flatten-body-items (body-item/components item))))
179 "non-empty sequence")))
180 ((definition-item? item) "definition")
181 ((keyword-item? item)
182 (decompile-item (keyword-item/name item)));in case expression
183 ((syntactic-closure? item); (display "syntactic-closure;")
184 (decompile-item (syntactic-closure/form item)))
185 ((list? item) (display "(")
186 (map decompile-item item) (display ")") "see list above")
187 ((string? item) item);explicit name-string for keyword-item
188 ((symbol? item) (display item) item) ;symbol for syntactic-closures
189 ((boolean? item) (display item) item) ;symbol for syntactic-closures
190 (else (write item) (impl-error "unknown item" item))))
192 ;;;; Syntactic Closures
194 (define syntactic-closure-type
195 (make-record-type "syntactic-closure" '(ENVIRONMENT FREE-NAMES FORM)))
197 (define make-syntactic-closure
198 (record-constructor syntactic-closure-type '(ENVIRONMENT FREE-NAMES FORM)))
200 (define syntactic-closure?
201 (record-predicate syntactic-closure-type))
203 (define syntactic-closure/environment
204 (record-accessor syntactic-closure-type 'ENVIRONMENT))
206 (define syntactic-closure/free-names
207 (record-accessor syntactic-closure-type 'FREE-NAMES))
209 (define syntactic-closure/form
210 (record-accessor syntactic-closure-type 'FORM))
212 (define (make-syntactic-closure-list environment free-names forms)
213 (map (lambda (form) (make-syntactic-closure environment free-names form))
216 (define (strip-syntactic-closures object)
217 (cond ((syntactic-closure? object)
218 (strip-syntactic-closures (syntactic-closure/form object)))
220 (cons (strip-syntactic-closures (car object))
221 (strip-syntactic-closures (cdr object))))
223 (let ((length (vector-length object)))
224 (let ((result (make-vector length)))
227 (vector-set! result i
228 (strip-syntactic-closures (vector-ref object i))))
233 (define (identifier? object)
235 (synthetic-identifier? object)))
237 (define (synthetic-identifier? object)
238 (and (syntactic-closure? object)
239 (identifier? (syntactic-closure/form object))))
241 (define (identifier->symbol identifier)
242 (cond ((symbol? identifier)
244 ((synthetic-identifier? identifier)
245 (identifier->symbol (syntactic-closure/form identifier)))
247 (impl-error "not an identifier" identifier))))
249 (define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
250 (let ((item-1 (syntactic-environment/lookup environment-1 identifier-1))
251 (item-2 (syntactic-environment/lookup environment-2 identifier-2)))
252 (or (eq? item-1 item-2)
253 ;; This is necessary because an identifier that is not
254 ;; explicitly bound by an environment is mapped to a variable
255 ;; item, and the variable items are not cached. Therefore
256 ;; two references to the same variable result in two
257 ;; different variable items.
258 (and (variable-item? item-1)
259 (variable-item? item-2)
260 (eq? (variable-item/name item-1)
261 (variable-item/name item-2))))))
263 ;;;; Syntactic Environments
265 (define syntactic-environment-type
267 "syntactic-environment"
272 BINDINGS-OPERATION)))
274 (define make-syntactic-environment
275 (record-constructor syntactic-environment-type
280 BINDINGS-OPERATION)))
282 (define syntactic-environment?
283 (record-predicate syntactic-environment-type))
285 (define syntactic-environment/parent
286 (record-accessor syntactic-environment-type 'PARENT))
288 (define syntactic-environment/lookup-operation
289 (record-accessor syntactic-environment-type 'LOOKUP-OPERATION))
291 (define (syntactic-environment/assign! environment name item)
293 ((syntactic-environment/lookup-operation environment) name)))
295 (set-cdr! binding item)
296 (impl-error "can't assign unbound identifier" name))))
298 (define syntactic-environment/rename-operation
299 (record-accessor syntactic-environment-type 'RENAME-OPERATION))
301 (define (syntactic-environment/rename environment name)
302 ((syntactic-environment/rename-operation environment) name))
304 (define syntactic-environment/define!
306 (record-accessor syntactic-environment-type 'DEFINE-OPERATION)))
307 (lambda (environment name item)
308 ((accessor environment) name item))))
310 (define syntactic-environment/bindings
312 (record-accessor syntactic-environment-type 'BINDINGS-OPERATION)))
313 (lambda (environment)
314 ((accessor environment)))))
316 (define (syntactic-environment/lookup environment name)
318 ((syntactic-environment/lookup-operation environment) name)))
320 (let ((item (cdr binding)))
321 (if (reserved-name-item? item)
322 (syntax-error "premature reference to reserved name"
326 (make-variable-item name))
327 ((synthetic-identifier? name)
328 (syntactic-environment/lookup (syntactic-closure/environment name)
329 (syntactic-closure/form name)))
331 (impl-error "not an identifier" name)))))
333 (define root-syntactic-environment
334 (make-syntactic-environment
342 (impl-error "can't bind name in root syntactic environment" name item))
346 (define null-syntactic-environment
347 (make-syntactic-environment
350 (impl-error "can't lookup name in null syntactic environment" name))
352 (impl-error "can't rename name in null syntactic environment" name))
354 (impl-error "can't bind name in null syntactic environment" name item))
358 (define (top-level-syntactic-environment parent)
360 (make-syntactic-environment
362 (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
364 (or (assq name bound)
365 (parent-lookup name))))
369 (let ((binding (assq name bound)))
371 (set-cdr! binding item)
372 (set! bound (cons (cons name item) bound)))))
374 (map (lambda (pair) (cons (car pair) (cdr pair))) bound)))))
376 (define (internal-syntactic-environment parent)
379 (make-syntactic-environment
381 (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
383 (or (assq name bound)
385 (let ((binding (parent-lookup name)))
386 (if binding (set! free (cons binding free)))
388 (make-name-generator)
390 (cond ((assq name bound)
392 (lambda (association)
393 (if (and (reserved-name-item? (cdr association))
394 (not (reserved-name-item? item)))
395 (set-cdr! association item)
396 (impl-error "can't redefine name; already bound" name))))
398 (if (reserved-name-item? item)
399 (syntax-error "premature reference to reserved name"
401 (impl-error "can't define name; already free" name)))
403 (set! bound (cons (cons name item) bound)))))
405 (map (lambda (pair) (cons (car pair) (cdr pair))) bound)))))
407 (define (filter-syntactic-environment names names-env else-env)
408 (if (or (null? names)
409 (eq? names-env else-env))
411 (let ((make-operation
412 (lambda (get-operation)
413 (let ((names-operation (get-operation names-env))
414 (else-operation (get-operation else-env)))
416 ((if (memq name names) names-operation else-operation)
418 (make-syntactic-environment
420 (make-operation syntactic-environment/lookup-operation)
421 (make-operation syntactic-environment/rename-operation)
423 (impl-error "can't bind name in filtered syntactic environment"
428 (syntactic-environment/lookup names-env name)))
433 ;;; Reserved name items do not represent any form, but instead are
434 ;;; used to reserve a particular name in a syntactic environment. If
435 ;;; the classifier refers to a reserved name, a syntax error is
436 ;;; signalled. This is used in the implementation of LETREC-SYNTAX
437 ;;; to signal a meaningful error when one of the <init>s refers to
438 ;;; one of the names being bound.
440 (define reserved-name-item-type
441 (make-record-type "reserved-name-item" '()))
443 (define make-reserved-name-item
444 (record-constructor reserved-name-item-type)) ; '()
446 (define reserved-name-item?
447 (record-predicate reserved-name-item-type))
449 ;;; Keyword items represent macro keywords.
451 (define keyword-item-type
452 (make-record-type "keyword-item" '(CLASSIFIER NAME)))
453 ; (make-record-type "keyword-item" '(CLASSIFIER)))
455 (define make-keyword-item
456 ; (lambda (cl) (display "make-keyword-item:") (write cl) (newline)
457 ; ((record-constructor keyword-item-type '(CLASSIFIER)) cl)))
458 (record-constructor keyword-item-type '(CLASSIFIER NAME)))
459 ; (record-constructor keyword-item-type '(CLASSIFIER)))
461 (define keyword-item?
462 (record-predicate keyword-item-type))
464 (define keyword-item/classifier
465 (record-accessor keyword-item-type 'CLASSIFIER))
467 (define keyword-item/name
468 (record-accessor keyword-item-type 'NAME))
470 ;;; Variable items represent run-time variables.
472 (define variable-item-type
473 (make-record-type "variable-item" '(NAME)))
475 (define make-variable-item
476 (record-constructor variable-item-type '(NAME)))
478 (define variable-item?
479 (record-predicate variable-item-type))
481 (define variable-item/name
482 (record-accessor variable-item-type 'NAME))
484 ;;; Expression items represent any kind of expression other than a
485 ;;; run-time variable or a sequence. The ANNOTATION field is used to
486 ;;; make expression items that can appear in non-expression contexts
487 ;;; (for example, this could be used in the implementation of SETF).
489 (define expression-item-type
490 (make-record-type "expression-item" '(COMPILER ANNOTATION)))
492 (define make-expression-item
493 (record-constructor expression-item-type '(COMPILER ANNOTATION)))
495 (define expression-item?
496 (record-predicate expression-item-type))
498 (define expression-item/compiler
499 (record-accessor expression-item-type 'COMPILER))
501 (define expression-item/annotation
502 (record-accessor expression-item-type 'ANNOTATION))
504 ;;; Body items represent sequences (e.g. BEGIN).
506 (define body-item-type
507 (make-record-type "body-item" '(COMPONENTS)))
509 (define make-body-item
510 (record-constructor body-item-type '(COMPONENTS)))
513 (record-predicate body-item-type))
515 (define body-item/components
516 (record-accessor body-item-type 'COMPONENTS))
518 ;;; Definition items represent definitions, whether top-level or
519 ;;; internal, keyword or variable.
521 (define definition-item-type
522 (make-record-type "definition-item" '(BINDING-THEORY NAME VALUE)))
524 (define make-definition-item
525 (record-constructor definition-item-type '(BINDING-THEORY NAME VALUE)))
527 (define definition-item?
528 (record-predicate definition-item-type))
530 (define definition-item/binding-theory
531 (record-accessor definition-item-type 'BINDING-THEORY))
533 (define definition-item/name
534 (record-accessor definition-item-type 'NAME))
536 (define definition-item/value
537 (record-accessor definition-item-type 'VALUE))
539 (define (bind-definition-item! environment item)
540 ((definition-item/binding-theory item)
542 (definition-item/name item)
543 (promise:force (definition-item/value item))))
545 (define (syntactic-binding-theory environment name item)
546 (if (or (keyword-item? item)
547 (variable-item? item))
549 (syntactic-environment/define! environment name item)
551 (syntax-error "syntactic binding value must be a keyword or a variable"
554 (define (variable-binding-theory environment name item)
555 ;; If ITEM isn't a valid expression, an error will be signalled by
556 ;; COMPILE-ITEM/EXPRESSION later.
557 (cons (bind-variable! environment name) item))
559 (define (overloaded-binding-theory environment name item)
560 (if (keyword-item? item)
562 (syntactic-environment/define! environment name item)
564 (cons (bind-variable! environment name) item)))
566 ;;;; Classifiers, Compilers, Expanders
568 (define (sc-expander->classifier expander keyword-environment)
569 (lambda (form environment definition-environment)
570 (classify/form (expander form environment)
572 definition-environment)))
574 (define (er-expander->classifier expander keyword-environment)
575 (sc-expander->classifier (er->sc-expander expander) keyword-environment))
577 (define (er->sc-expander expander)
578 (lambda (form environment)
579 (capture-syntactic-environment
580 (lambda (keyword-environment)
581 (make-syntactic-closure
586 (let ((association (assq identifier renames)))
590 (make-syntactic-closure
595 (cons (cons identifier rename)
599 (identifier=? environment x
600 environment y))))))))
602 (define (classifier->keyword classifier)
603 (make-syntactic-closure
605 (internal-syntactic-environment null-syntactic-environment)))
606 (syntactic-environment/define! environment
608 (make-keyword-item classifier "c->k"))
613 (define (compiler->keyword compiler)
614 (classifier->keyword (compiler->classifier compiler)))
616 (define (classifier->form classifier)
617 `(,(classifier->keyword classifier)))
619 (define (compiler->form compiler)
620 (classifier->form (compiler->classifier compiler)))
622 (define (compiler->classifier compiler)
623 (lambda (form environment definition-environment)
624 definition-environment ;ignore
625 (make-expression-item
626 (lambda () (compiler form environment)) form)))
629 ;;; A macrology is a procedure that accepts a syntactic environment
630 ;;; as an argument, producing a new syntactic environment that is an
631 ;;; extension of the argument.
633 (define (make-primitive-macrology generate-definitions)
634 (lambda (base-environment)
635 (let ((environment (top-level-syntactic-environment base-environment)))
636 (let ((define-classifier
637 (lambda (keyword classifier)
638 (syntactic-environment/define!
641 (make-keyword-item classifier keyword)))))
642 (generate-definitions
644 (lambda (keyword compiler)
645 (define-classifier keyword (compiler->classifier compiler)))))
648 (define (make-expander-macrology object->classifier generate-definitions)
649 (lambda (base-environment)
650 (let ((environment (top-level-syntactic-environment base-environment)))
651 (generate-definitions
652 (lambda (keyword object)
653 (syntactic-environment/define!
656 (make-keyword-item (object->classifier object environment) keyword)))
660 (define (make-sc-expander-macrology generate-definitions)
661 (make-expander-macrology sc-expander->classifier generate-definitions))
663 (define (make-er-expander-macrology generate-definitions)
664 (make-expander-macrology er-expander->classifier generate-definitions))
666 (define (compose-macrologies . macrologies)
667 (lambda (environment)
668 (do ((macrologies macrologies (cdr macrologies))
669 (environment environment ((car macrologies) environment)))
670 ((null? macrologies) environment))))
674 (define (bind-variable! environment name)
675 (let ((rename (syntactic-environment/rename environment name)))
676 (syntactic-environment/define! environment
678 (make-variable-item rename))
681 (define (reserve-names! names environment)
682 (let ((item (make-reserved-name-item)))
683 (for-each (lambda (name)
684 (syntactic-environment/define! environment name item))
687 (define (capture-syntactic-environment expander)
689 (lambda (form environment definition-environment)
691 (classify/form (expander environment)
693 definition-environment))))
695 (define (unspecific-expression)
697 (lambda (form environment)
698 form environment ;ignore
699 (output/unspecific))))
701 (define (unassigned-expression)
703 (lambda (form environment)
704 form environment ;ignore
705 (output/unassigned))))
707 (define (syntax-quote expression)
708 `(,(compiler->keyword
709 (lambda (form environment)
711 (syntax-check '(KEYWORD DATUM) form)
712 (output/literal-quoted (cadr form))))
715 (define (flatten-body-items items)
716 (append-map item->list items))
718 (define (item->list item)
719 (if (body-item? item)
720 (flatten-body-items (body-item/components item))
723 (define (output/let names values body)
726 (output/combination (output/lambda names body) values)))
728 (define (output/letrec names values body)
733 (map (lambda (name) name (output/unassigned)) names)
735 (list (if (null? (cdr names))
736 (output/assignment (car names) (car values))
737 (let ((temps (map (make-name-generator) names)))
742 (map output/assignment names temps)))))
745 (define (output/top-level-sequence expressions)
746 (if (null? expressions)
748 (output/sequence expressions)))