source: project/syntactic-closures/syntactic-closures.scm @ 4641

Last change on this file since 4641 was 4641, checked in by Jim Ursetto, 13 years ago

syntactic-closures: hygienify cond-expand, include; export syntax-case, syntax-match?

File size: 57.4 KB
Line 
1;;; "synclo.scm" Syntactic Closures             -*-Hen -*-
2;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
3;;;
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 and modify
7;;; this software, to redistribute either the original software or a
8;;; modified version, and to use this software for any purpose is
9;;; granted, subject to the following restrictions and understandings.
10;;;
11;;; 1. Any copy made of this software must include this copyright
12;;; notice in full.
13;;;
14;;; 2. Users of this software agree to make their best efforts (a) to
15;;; return to the MIT Scheme project any improvements or extensions
16;;; that they make, so that these may be included in future releases;
17;;; and (b) to inform MIT of noteworthy uses of this software.
18;;;
19;;; 3. All materials developed as a consequence of the use of this
20;;; software shall duly acknowledge such use, in accordance with the
21;;; usual standards of acknowledging credit in academic research.
22;;;
23;;; 4. MIT has made no warranty or representation that the operation
24;;; of this software will be error-free, and MIT is under no
25;;; obligation to provide any services, by way of maintenance, update,
26;;; or otherwise.
27;;;
28;;; 5. In conjunction with products arising from the use of this
29;;; material, there shall be no use of the name of the Massachusetts
30;;; Institute of Technology nor of any adaptation thereof in any
31;;; advertising, promotional, or sales literature without prior
32;;; written consent from MIT in each case.
33
34(declare
35  (uses srfi-1)
36  (export ill-formed-syntax synclo:expand
37          make-syntactic-closure capture-syntactic-environment
38          identifier? identifier=?
39          scheme-syntactic-environment macroexpand
40          syntax-match? syntax-check
41          ##sys#compiler-toplevel-macroexpand-hook
42          ##sys#interpreter-toplevel-macroexpand-hook) )
43
44;;;; Syntactic Closures
45;;; written by Alan Bawden
46;;; extensively modified by Chris Hanson
47
48;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
49;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
50;;; Programming, page 86.
51
52;;;; Syntax Checking
53;;; written by Alan Bawden
54;;; modified by Chris Hanson
55
56(define (syntax-check pattern form)
57  (if (not (syntax-match? (cdr pattern) (cdr form)))
58      (syntax-error "ill-formed special form" form)))
59
60(define (ill-formed-syntax form)
61  (syntax-error "ill-formed special form" form))
62
63(define (syntax-match? pattern object)
64  (define (check-llist object)
65    (let loop ((seen '()) (object object))
66      (or (null? object)
67          (if (identifier? object)
68              (not (memq object seen))
69              (and (pair? object)
70                   (identifier? (car object))
71                   (not (memq (car object) seen))
72                   (loop (cons (car object) seen) (cdr object)))))))
73  (let ((match-error
74         (lambda ()
75           (impl-error "ill-formed pattern" pattern))))
76    (cond ((symbol? pattern)
77           (case pattern
78             ((identifier) (identifier? object))
79             ((datum expression form) #t)
80             ((r4rs-bvl) (check-llist object))
81             ((dsssl-bvl) (or (##sys#extended-lambda-list? object) (check-llist object)))
82             ;;((mit-bvl) (lambda-list? object))
83             (else (match-error))))
84          ((pair? pattern)
85           (case (car pattern)
86             ((*)
87              (if (pair? (cdr pattern))
88                  (let ((head (cadr pattern))
89                        (tail (cddr pattern)))
90                    (let loop ((object object))
91                      (or (and (pair? object)
92                               (syntax-match? head (car object))
93                               (loop (cdr object)))
94                          (syntax-match? tail object))))
95                  (match-error)))
96             ((+)
97              (if (pair? (cdr pattern))
98                  (let ((head (cadr pattern))
99                        (tail (cddr pattern)))
100                    (and (pair? object)
101                         (syntax-match? head (car object))
102                         (let loop ((object (cdr object)))
103                           (or (and (pair? object)
104                                    (syntax-match? head (car object))
105                                    (loop (cdr object)))
106                               (syntax-match? tail object)))))
107                  (match-error)))
108             ((?)
109              (if (pair? (cdr pattern))
110                  (or (and (pair? object)
111                           (syntax-match? (cadr pattern) (car object))
112                           (syntax-match? (cddr pattern) (cdr object)))
113                      (syntax-match? (cddr pattern) object))
114                  (match-error)))
115             ((quote)
116              (if (and (pair? (cdr pattern))
117                       (null? (cddr pattern)))
118                  (eqv? (cadr pattern) object)
119                  (match-error)))
120             (else
121              (and (pair? object)
122                   (syntax-match? (car pattern) (car object))
123                   (syntax-match? (cdr pattern) (cdr object))))))
124          (else
125           (eqv? pattern object)))))
126
127;;;; Syntaxer Output Interface
128
129(define impl-error error)
130
131(define *counter* 0)
132
133(define (make-name-generator)
134  (let ((make-suffix
135         (lambda ()
136            (string-append "."
137                           (number->string (begin
138                                             (set! *counter* (+ *counter* 1))
139                                             *counter*))))))
140    (lambda (identifier)
141      (string->symbol
142       (string-append "."
143                      (symbol->string (identifier->symbol identifier))
144                      (make-suffix))))))
145
146(define (rename-top-level-identifier identifier)
147  (if (symbol? identifier)
148      identifier
149      ((make-name-generator) identifier)))
150
151(define (output/variable name)
152  name)
153
154(define (output/literal-unquoted datum)
155  datum)
156
157(define (output/literal-quoted datum);was output/constant (inefficient)
158  `(quote ,datum))
159
160(define (output/assignment name value)
161  `(set! ,name ,value))
162
163(define (output/top-level-definition name value)
164  `(define ,name ,value))
165
166(define (output/conditional predicate consequent alternative)
167  `(if ,predicate ,consequent ,alternative))
168
169(define (output/sequence expressions)
170  (if (null? (cdr expressions))
171      (car expressions)
172      `(begin ,@expressions)))
173
174(define (output/combination operator operands)
175  `(,operator ,@operands))
176
177(define (output/lambda pattern body)
178  `(lambda ,pattern ,body))
179
180(define (output/delay expression)
181  `(##sys#make-promise (lambda () ,expression)))
182
183(define (output/unassigned)
184  `(##core#undefined))
185
186(define (output/unspecific)
187  `(##sys#void))
188
189;;;; Classifier
190;;;  The classifier maps forms into items.  In addition to locating
191;;;  definitions so that they can be properly processed, it also
192;;;  identifies keywords and variables, which allows a powerful form
193;;;  of syntactic binding to be implemented.
194
195(define (classify/form form environment definition-environment)
196  (cond ((identifier? form)
197         (syntactic-environment/lookup environment form))
198        ((syntactic-closure? form)
199         (let ((form (syntactic-closure/form form))
200               (environment
201                (filter-syntactic-environment
202                 (syntactic-closure/free-names form)
203                 environment
204                 (syntactic-closure/environment form))))
205           (classify/form form
206                          environment
207                          definition-environment)))
208        ((pair? form)
209         (let ((item
210                (classify/subexpression (car form) environment)))
211           (cond ((keyword-item? item)
212                  ((keyword-item/classifier item) form
213                                                  environment
214                                                  definition-environment))
215                 ((list? (cdr form))
216                  (let ((items
217                         (classify/subexpressions (cdr form)
218                                                  environment)))
219                    (make-expression-item
220;;                   (lambda ()
221;;                     (output/combination
222;;                      (compile-item/expression item)
223;;                      (map! compile-item/expression items)))
224;;                      (lambda () form)
225                     ;; XXXX preserve line-number info (ashinn 2006/12/11)
226                     (lambda ()
227                       (let ((new
228                              (output/combination
229                               (compile-item/expression item)
230                               (map compile-item/expression items))))
231                         (if (and ##sys#line-number-database
232                                  (symbol? (car new)))
233                           (if (eq? (car form) (car new))
234                             ;; same symbol, just overwrite the old
235                             ;; cell (the old form should never be
236                             ;; used, unless the macro is duplicating
237                             ;; user code in multiple places, which is
238                             ;; bad-style so we don't care if they
239                             ;; lose line-number info in that case)
240                             (let ((bucket
241                                    (##sys#hash-table-ref
242                                     ##sys#line-number-database
243                                     (car form))))
244                               (if bucket
245                                 (let ((cell (assq form bucket)))
246                                   (if cell
247                                     (set-car! cell new)))))
248                             ;; renamed symbol, add a new entry
249                             (let ((line (get-line-number form)))
250                               (if line
251                                 (let* ((name (car new))
252                                        (old (or (##sys#hash-table-ref
253                                                  ##sys#line-number-database name) '())))
254                                   (##sys#hash-table-set! ##sys#line-number-database name (alist-cons new line old)))))))
255                         new))
256                     form)))
257                 (else
258                  (syntax-error "combination must be a proper list"
259                                form)))))
260        (else
261         (make-expression-item ;don't quote literals evaluating to themselves
262           (if (or (boolean? form) (char? form) (number? form) (string? form)
263                   (null? form))
264               (lambda () (output/literal-unquoted form))
265               (lambda () (output/literal-quoted form))) form))))
266
267(define (classify/subform form environment definition-environment)
268  (classify/form form
269                 environment
270                 definition-environment))
271
272(define (classify/subforms forms environment definition-environment)
273  (map (lambda (form)
274         (classify/subform form environment definition-environment))
275       forms))
276
277(define (classify/subexpression expression environment)
278  (classify/subform expression environment environment))
279
280(define (classify/subexpressions expressions environment)
281  (classify/subforms expressions environment environment))
282
283;;;; Compiler
284;;;  The compiler maps items into the output language.
285
286(define (compile-item/expression item)
287  (let ((illegal
288         (lambda (item name)
289           (let ((decompiled (decompile-item item))) (newline)
290           (error (string-append name " may not be used as an expression")
291                  decompiled)))))
292    (cond ((variable-item? item)
293           (output/variable (variable-item/name item)))
294          ((expression-item? item)
295           ((expression-item/compiler item)))
296          ((body-item? item)
297           (let ((items (flatten-body-items (body-item/components item))))
298             (if (null? items)
299                 (illegal item "empty sequence")
300                 (output/sequence (map compile-item/expression items)))))
301          ((definition-item? item)
302           (output/top-level-definition
303            (definition-item/name item)
304            (compile-item/expression (definition-item/value item))))
305          ((keyword-item? item)
306           (illegal item "keyword"))
307          (else
308           (impl-error "unknown item" item)))))
309
310(define (compile/subexpression expression environment)
311  (compile-item/expression
312   (classify/subexpression expression environment)))
313
314(define (compile/top-level forms environment)
315  ;; Top-level syntactic definitions affect all forms that appear
316  ;; after them.
317  (output/top-level-sequence
318   (let forms-loop ((forms forms))
319     (if (null? forms)
320         '()
321         (let items-loop
322             ((items
323               (item->list
324                (classify/subform (car forms)
325                                  environment
326                                  environment))))
327           (cond ((null? items)
328                  (forms-loop (cdr forms)))
329                 ((definition-item? (car items))
330                  (if (not (keyword-item? (definition-item/value (car items))))
331                      (cons (output/top-level-definition
332                             (definition-item/name (car items))
333                             (compile-item/expression
334                              (definition-item/value (car items))))
335                            (items-loop (cdr items)))
336                      (items-loop (cdr items))))
337                 (else
338                  (cons (compile-item/expression (car items))
339                        (items-loop (cdr items))))))))))
340
341;;;; De-Compiler
342;;;  The de-compiler maps partly-compiled things back to the input language,
343;;;  as far as possible.  Used to display more meaningful macro error messages.
344
345(define (decompile-item item)
346    (display " ")
347    (cond ((variable-item? item) (variable-item/name item))
348          ((expression-item? item)
349           (decompile-item (expression-item/annotation item)))
350          ((body-item? item)
351           (let ((items (flatten-body-items (body-item/components item))))
352             (display "sequence")
353             (if (null? items)
354                 "empty sequence"
355                 "non-empty sequence")))
356          ((definition-item? item) "definition")
357          ((keyword-item? item)
358           (decompile-item (keyword-item/name item)));in case expression
359          ((syntactic-closure? item); (display "syntactic-closure;")
360           (decompile-item (syntactic-closure/form item)))
361          ((list? item) (display "(")
362                (map decompile-item item) (display ")") "see list above")
363          ((string? item) item);explicit name-string for keyword-item
364          ((symbol? item) (display item) item) ;symbol for syntactic-closures
365          ((boolean? item) (display item) item) ;symbol for syntactic-closures
366          (else (write item) (impl-error "unknown item" item))))
367
368;;;; Syntactic Closures
369
370(define-record syntactic-closure environment free-names form)
371
372(define-record-printer (syntactic-closure x p)
373  (fprintf p "#<syntactic closure ~s>" (syntactic-closure-form x) ) )
374
375(define syntactic-closure/environment syntactic-closure-environment)
376(define syntactic-closure/free-names syntactic-closure-free-names)
377(define syntactic-closure/form syntactic-closure-form)
378
379(define (make-syntactic-closure-list environment free-names forms)
380  (map (lambda (form) (make-syntactic-closure environment free-names form))
381       forms))
382
383(define (strip-syntactic-closures object)
384  (cond ((syntactic-closure? object)
385         (strip-syntactic-closures (syntactic-closure/form object)))
386        ((pair? object)
387         (cons (strip-syntactic-closures (car object))
388               (strip-syntactic-closures (cdr object))))
389        ((vector? object)
390         (let ((length (vector-length object)))
391           (let ((result (make-vector length)))
392             (do ((i 0 (+ i 1)))
393                 ((= i length))
394               (vector-set! result i
395                            (strip-syntactic-closures (vector-ref object i))))
396             result)))
397        (else
398         object)))
399;@
400(define (identifier? object)
401  (or (symbol? object)
402      (synthetic-identifier? object)))
403
404(define (synthetic-identifier? object)
405  (and (syntactic-closure? object)
406       (identifier? (syntactic-closure/form object))))
407
408(define (identifier->symbol identifier)
409  (cond ((symbol? identifier)
410         identifier)
411        ((synthetic-identifier? identifier)
412         (identifier->symbol (syntactic-closure/form identifier)))
413        (else
414         (impl-error "not an identifier" identifier))))
415;@
416(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
417  (let ((item-1 (syntactic-environment/lookup environment-1 identifier-1))
418        (item-2 (syntactic-environment/lookup environment-2 identifier-2)))
419    (or (eq? item-1 item-2)
420        ;; This is necessary because an identifier that is not
421        ;; explicitly bound by an environment is mapped to a variable
422        ;; item, and the variable items are not cached.  Therefore
423        ;; two references to the same variable result in two
424        ;; different variable items.
425        (and (variable-item? item-1)
426             (variable-item? item-2)
427             (eq? (variable-item/name item-1)
428                  (variable-item/name item-2))))))
429
430;;;; Syntactic Environments
431
432(define-record syntactic-environment
433  parent
434  top-level?
435  lookup-operation
436  rename-operation
437  define-operation
438  bindings-operation
439  )
440
441(define syntactic-environment/parent syntactic-environment-parent)
442(define syntactic-environment/top-level? syntactic-environment-top-level?)
443(define syntactic-environment/lookup-operation syntactic-environment-lookup-operation)
444(define (syntactic-environment/assign! environment name item)
445  (let ((binding
446         ((syntactic-environment/lookup-operation environment) name)))
447    (if binding
448        (set-cdr! binding item)
449        (impl-error "can't assign unbound identifier" name))))
450
451(define syntactic-environment/rename-operation syntactic-environment-rename-operation)
452
453(define (syntactic-environment/rename environment name)
454  ((syntactic-environment/rename-operation environment) name))
455
456(define syntactic-environment/define!
457  (let ((accessor syntactic-environment-define-operation))
458    (lambda (environment name item)
459      ((accessor environment) name item))))
460
461(define syntactic-environment/bindings
462  (let ((accessor syntactic-environment-bindings-operation))
463    (lambda (environment)
464      ((accessor environment)))))
465
466(define (syntactic-environment/lookup environment name)
467  (let ((binding
468         ((syntactic-environment/lookup-operation environment) name)))
469    (cond (binding
470           (let ((item (cdr binding)))
471             (if (reserved-name-item? item)
472                 (syntax-error "premature reference to reserved name"
473                               name)
474                 item)))
475          ((symbol? name)
476           (make-variable-item name))
477          ((synthetic-identifier? name)
478           (syntactic-environment/lookup (syntactic-closure/environment name)
479                                         (syntactic-closure/form name)))
480          (else
481           (impl-error "not an identifier" name)))))
482
483(define root-syntactic-environment
484  (make-syntactic-environment
485   #f                                   ;No parent
486   #t                                   ;Top level
487   (lambda (name)                       ;LOOKUP operation
488     name
489     #f)
490   (lambda (name)                       ;RENAME operation
491     (rename-top-level-identifier name))
492   (lambda (name item)                  ;DEFINE operation
493     (impl-error "can't bind name in root syntactic environment" name item))
494   (lambda ()                           ;BINDINGS operation
495     '())))
496
497(define null-syntactic-environment
498  (make-syntactic-environment
499   #f                                   ;No parent
500   #t                                   ;Top level
501   (lambda (name)                       ;LOOKUP operation
502     (impl-error "can't lookup name in null syntactic environment" name))
503   (lambda (name)                       ;RENAME operation
504     (impl-error "can't rename name in null syntactic environment" name))
505   (lambda (name item)                  ;DEFINE operation
506     (impl-error "can't bind name in null syntactic environment" name item))
507   (lambda ()                           ;BINDINGS operation
508     '())))
509
510(define (top-level-syntactic-environment parent)
511  (let ((bound '()))
512    (make-syntactic-environment
513     parent
514     #t                                 ;Top level
515     (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
516       (lambda (name)                   ;LOOKUP operation
517         (or (assq name bound)
518             (parent-lookup name))))
519     (lambda (name)                     ;RENAME operation
520       (rename-top-level-identifier name))
521     (lambda (name item)                ;DEFINE operation
522       (let ((binding (assq name bound)))
523         (if binding
524             (set-cdr! binding item)
525             (set! bound (cons (cons name item) bound)))))
526     (lambda ()                         ;BINDINGS operation
527       (map (lambda (pair) (cons (car pair) (cdr pair))) bound)))))
528
529(define (internal-syntactic-environment parent)
530  (let ((bound '())
531        (free '()))
532    (make-syntactic-environment
533     parent
534     #f                                 ;Not top level
535     (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
536       (lambda (name)                   ;LOOKUP operation
537         (or (assq name bound)
538             (assq name free)
539             (let ((binding (parent-lookup name)))
540               (if binding (set! free (cons binding free)))
541               binding))))
542     (make-name-generator)              ;RENAME operation
543     (lambda (name item)                ;DEFINE operation
544       (cond ((assq name bound)
545              =>
546              (lambda (association)
547                (if (and (reserved-name-item? (cdr association))
548                         (not (reserved-name-item? item)))
549                    (set-cdr! association item)
550                    (impl-error "can't redefine name; already bound" name))))
551             ((assq name free)
552              (if (reserved-name-item? item)
553                  (syntax-error "premature reference to reserved name"
554                                name)
555                  (impl-error "can't define name; already free" name)))
556             (else
557              (set! bound (cons (cons name item) bound)))))
558     (lambda ()                         ;BINDINGS operation
559       (map (lambda (pair) (cons (car pair) (cdr pair))) bound)))))
560
561(define (filter-syntactic-environment names names-env else-env)
562  (if (or (null? names)
563          (eq? names-env else-env))
564      else-env
565      (let ((make-operation
566             (lambda (get-operation)
567               (let ((names-operation (get-operation names-env))
568                     (else-operation (get-operation else-env)))
569                 (lambda (name)
570                   ((if (memq name names) names-operation else-operation)
571                    name))))))
572        (make-syntactic-environment
573         else-env
574         #f                             ;Not top level
575         (make-operation syntactic-environment/lookup-operation)
576         (make-operation syntactic-environment/rename-operation)
577         (lambda (name item)            ;DEFINE operation
578           (impl-error "can't bind name in filtered syntactic environment"
579                       name item))
580         (lambda ()                     ;BINDINGS operation
581           (map (lambda (name)
582                  (cons name
583                        (syntactic-environment/lookup names-env name)))
584                names))))))
585
586;;;; Items
587
588;;; Reserved name items do not represent any form, but instead are
589;;; used to reserve a particular name in a syntactic environment.  If
590;;; the classifier refers to a reserved name, a syntax error is
591;;; signalled.  This is used in the implementation of LETREC-SYNTAX
592;;; to signal a meaningful error when one of the <init>s refers to
593;;; one of the names being bound.
594
595(define-record reserved-name-item)
596
597;;; Keyword items represent macro keywords.
598
599(define-record keyword-item classifier name)
600
601(define keyword-item/classifier keyword-item-classifier)
602(define keyword-item/name keyword-item-name)
603
604;;; Variable items represent run-time variables.
605
606(define-record variable-item name)
607
608(define variable-item/name variable-item-name)
609
610;;; Expression items represent any kind of expression other than a
611;;; run-time variable or a sequence.  The ANNOTATION field is used to
612;;; make expression items that can appear in non-expression contexts
613;;; (for example, this could be used in the implementation of SETF).
614
615(define-record expression-item compiler annotation)
616
617(define expression-item/compiler expression-item-compiler)
618(define expression-item/annotation expression-item-annotation)
619
620;;; Body items represent sequences (e.g. BEGIN).
621
622(define-record body-item components)
623
624(define body-item/components body-item-components)
625
626;;; Definition items represent definitions, whether top-level or
627;;; internal, keyword or variable.
628
629(define-record definition-item name value)
630
631(define definition-item/name definition-item-name)
632(define definition-item/value definition-item-value)
633
634(define (syntactic-binding-theory environment name item)
635  (if (keyword-item? item)
636      (begin
637        (syntactic-environment/define! environment name item)
638        (make-definition-item (rename-top-level-identifier name) item))
639      (syntax-error "syntactic binding value must be a keyword or a variable"
640                    item)))
641
642(define (variable-binding-theory environment name item)
643  ;; If ITEM isn't a valid expression, an error will be signalled by
644  ;; COMPILE-ITEM/EXPRESSION later.
645  (make-definition-item (bind-variable! environment name) item))
646
647(define (overloaded-binding-theory environment name item)
648  (if (keyword-item? item)
649      (syntactic-binding-theory environment name item)
650      (variable-binding-theory environment name item)))
651
652;;;; Classifiers, Compilers, Expanders
653
654(define (sc-expander->classifier expander keyword-environment)
655  (lambda (form environment definition-environment)
656    (classify/form (expander form environment)
657                   keyword-environment
658                   definition-environment)))
659
660(define (rsc-expander->classifier expander keyword-environment)
661  (sc-expander->classifier (rsc->sc-expander expander) keyword-environment))
662
663(define (rsc->sc-expander expander)
664  (lambda (form environment)
665    (capture-syntactic-environment
666     (lambda (keyword-environment)
667       (make-syntactic-closure
668        environment '()
669        (expander form keyword-environment))))))
670
671(define (er-expander->classifier expander keyword-environment)
672  (sc-expander->classifier (er->sc-expander expander) keyword-environment))
673
674(define (er->sc-expander expander)
675  (lambda (form environment)
676    (capture-syntactic-environment
677     (lambda (keyword-environment)
678       (make-syntactic-closure
679        environment '()
680        (expander form
681                  (let ((renames '()))
682                    (lambda (identifier)
683                      (let ((association (assq identifier renames)))
684                        (if association
685                            (cdr association)
686                            (let ((rename
687                                   (make-syntactic-closure
688                                    keyword-environment
689                                    '()
690                                    identifier)))
691                              (set! renames
692                                    (cons (cons identifier rename)
693                                          renames))
694                              rename)))))
695                  (lambda (x y)
696                    (identifier=? environment x
697                                  environment y))))))))
698
699(define (classifier->keyword classifier)
700  (make-syntactic-closure
701   (let ((environment
702          (internal-syntactic-environment null-syntactic-environment)))
703     (syntactic-environment/define! environment
704                                    'keyword
705                                    (make-keyword-item classifier "c->k"))
706     environment)
707   '()
708   'keyword))
709
710(define (compiler->keyword compiler)
711  (classifier->keyword (compiler->classifier compiler)))
712
713(define (classifier->form classifier)
714  `(,(classifier->keyword classifier)))
715
716(define (compiler->form compiler)
717  (classifier->form (compiler->classifier compiler)))
718
719(define (compiler->classifier compiler)
720  (lambda (form environment definition-environment)
721    definition-environment              ;ignore
722    (make-expression-item
723     (lambda () (compiler form environment)) form)))
724
725;;;; Macrologies
726;;;  A macrology is a procedure that accepts a syntactic environment
727;;;  as an argument, producing a new syntactic environment that is an
728;;;  extension of the argument.
729
730(define (make-primitive-macrology generate-definitions)
731  (lambda (base-environment)
732    (let ((environment (top-level-syntactic-environment base-environment)))
733      (let ((define-classifier
734              (lambda (keyword classifier)
735                (syntactic-environment/define!
736                 environment
737                 keyword
738                 (make-keyword-item classifier keyword)))))
739        (generate-definitions
740         define-classifier
741         (lambda (keyword compiler)
742           (define-classifier keyword (compiler->classifier compiler)))))
743      environment)))
744
745(define (make-expander-macrology object->classifier generate-definitions)
746  (lambda (base-environment)
747    (let ((environment (top-level-syntactic-environment base-environment)))
748      (generate-definitions
749       (lambda (keyword object)
750         (syntactic-environment/define!
751          environment
752          keyword
753          (make-keyword-item (object->classifier object environment) keyword)))
754       base-environment)
755      environment)))
756
757(define (make-sc-expander-macrology generate-definitions)
758  (make-expander-macrology sc-expander->classifier generate-definitions))
759
760(define (make-rsc-expander-macrology generate-definitions)
761  (make-expander-macrology rsc-expander->classifier generate-definitions))
762
763(define (make-er-expander-macrology generate-definitions)
764  (make-expander-macrology er-expander->classifier generate-definitions))
765
766(define (compose-macrologies . macrologies)
767  (lambda (environment)
768    (do ((macrologies macrologies (cdr macrologies))
769         (environment environment ((car macrologies) environment)))
770        ((null? macrologies) environment))))
771
772;;;; Utilities
773
774(define (bind-variable! environment name)
775  (let ((rename (syntactic-environment/rename environment name)))
776    (syntactic-environment/define! environment
777                                   name
778                                   (make-variable-item rename))
779    rename))
780
781(define (reserve-names! names environment)
782  (let ((item (make-reserved-name-item)))
783    (for-each (lambda (name)
784                (syntactic-environment/define! environment name item))
785              names)))
786;@
787(define (capture-syntactic-environment expander)
788  (classifier->form
789   (lambda (form environment definition-environment)
790     form                               ;ignore
791     (classify/form (expander environment)
792                    environment
793                    definition-environment))))
794
795(define (unspecific-expression)
796  (compiler->form
797   (lambda (form environment)
798     form environment                   ;ignore
799     (output/unspecific))))
800
801(define (unassigned-expression)
802  (compiler->form
803   (lambda (form environment)
804     form environment                   ;ignore
805     (output/unassigned))))
806
807(define (syntax-quote expression)
808  `(,(compiler->keyword
809      (lambda (form environment)
810        environment                     ;ignore
811        (syntax-check '(keyword datum) form)
812        (output/literal-quoted (cadr form))))
813    ,expression))
814
815(define (flatten-body-items items)
816  (append-map item->list items))
817
818(define (item->list item)
819  (if (body-item? item)
820      (flatten-body-items (body-item/components item))
821      (list item)))
822
823(define (output/let names values body)
824  (if (null? names)
825      body
826      (output/combination (output/lambda names body) values)))
827
828(define (output/letrec names values body)
829  (if (null? names)
830      body
831      (output/let
832       names
833       (map (lambda (name) name (output/unassigned)) names)
834       (output/sequence
835        (list (if (null? (cdr names))
836                  (output/assignment (car names) (car values))
837                  (let ((temps (map (make-name-generator) names)))
838                    (output/let
839                     temps
840                     values
841                     (output/sequence
842                      (map output/assignment names temps)))))
843              body)))))
844
845(define (output/top-level-sequence expressions)
846  (if (null? expressions)
847      (output/unspecific)
848      (output/sequence expressions)))
849
850;;;; R4RS Syntax
851
852(define scheme-syntactic-environment #f)
853
854(define (initialize-scheme-syntactic-environment!)
855  (set! scheme-syntactic-environment
856        ((compose-macrologies
857          (make-core-primitive-macrology)
858          (make-binding-macrology syntactic-binding-theory #f
859                                  'let-syntax 'letrec-syntax 'define-syntax)
860          (make-binding-macrology variable-binding-theory #t
861                                  'let 'letrec 'define)
862          (make-r4rs-primitive-macrology)
863          (make-core-expander-macrology)
864          (make-syntax-rules-macrology))
865         root-syntactic-environment)))
866
867;;;; core primitives
868
869(define (make-core-primitive-macrology)
870  (make-primitive-macrology
871   (lambda (define-classifier define-compiler)
872
873     (define-classifier 'begin
874       (lambda (form environment definition-environment)
875         (syntax-check '(keyword * form) form)
876         (make-body-item (classify/subforms (cdr form)
877                                            environment
878                                            definition-environment))))
879
880     (define-compiler 'delay
881       (lambda (form environment)
882         (syntax-check '(keyword expression) form)
883         (output/delay
884          (compile/subexpression (cadr form)
885                                 environment))))
886
887     (define-compiler 'if
888       (lambda (form environment)
889         (syntax-check '(keyword expression expression ? expression) form)
890         (output/conditional
891          (compile/subexpression (cadr form) environment)
892          (compile/subexpression (caddr form) environment)
893          (if (null? (cdddr form))
894              (output/unspecific)
895              (compile/subexpression (cadddr form)
896                                     environment)))))
897
898     (define-compiler 'quote
899       (lambda (form environment)
900         environment                    ;ignore
901         (syntax-check '(keyword datum) form)
902         (output/literal-quoted (strip-syntactic-closures (cadr form))))))))
903
904;;;; bindings
905
906(define (make-binding-macrology binding-theory retain-bindings?
907                                let-keyword letrec-keyword define-keyword)
908  (make-primitive-macrology
909   (lambda (define-classifier define-compiler)
910
911     (let ((pattern/let-like
912            '(keyword (* (identifier expression)) + form))
913           (compile/let-like
914            (lambda (form environment body-environment output/let)
915              ;; This must be a LET* so that the applications of
916              ;; BINDING-THEORY, which have side effects, will happen
917              ;; before the classification and compilation of the body.
918              (let* ((definitions
919                      (map (lambda (binding)
920                             (binding-theory body-environment
921                                             (car binding)
922                                             (classify/subexpression
923                                              (cadr binding)
924                                              environment)))
925                           (cadr form)))
926                     (body
927                      (compile-item/expression
928                       (classify/body (cddr form)
929                                      body-environment))))
930                (if retain-bindings?
931                    (output/let (map definition-item/name definitions)
932                                (map (lambda (definition)
933                                       (compile-item/expression
934                                        (definition-item/value definition)))
935                                     definitions)
936                                body)
937                    (output/let '() '() body))))))
938
939       (define-compiler let-keyword
940         (lambda (form environment)
941           (syntax-check pattern/let-like form)
942           (compile/let-like form
943                             environment
944                             (internal-syntactic-environment environment)
945                             output/let)))
946
947       (define-compiler letrec-keyword
948         (lambda (form environment)
949           (syntax-check pattern/let-like form)
950           (let ((environment (internal-syntactic-environment environment)))
951             (reserve-names! (map car (cadr form)) environment)
952             (compile/let-like form
953                               environment
954                               environment
955                               output/letrec)))))
956
957     (define-classifier define-keyword
958       (lambda (form environment definition-environment)
959         (syntax-check '(keyword identifier expression) form)
960         (if (not (syntactic-environment/top-level? definition-environment))
961             (reserve-names! (list (cadr form)) definition-environment))
962         (binding-theory definition-environment
963                         (cadr form)
964                         (classify/subexpression (caddr form)
965                                                 environment)))))))
966
967;;;; bodies
968
969(define (classify/body forms environment)
970  (let ((environment (internal-syntactic-environment environment)))
971    (let forms-loop
972        ((forms forms)
973         (definitions '()))
974      (if (null? forms)
975          (syntax-error "no expressions in body")
976          (let items-loop
977              ((items
978                (item->list
979                 (classify/subform (car forms)
980                                   environment
981                                   environment)))
982               (definitions definitions))
983            (cond ((null? items)
984                   (forms-loop (cdr forms)
985                               definitions))
986                  ((definition-item? (car items))
987                   (items-loop (cdr items)
988                               (cons (car items) definitions)))
989                  (else
990                   (let ((body
991                          (make-body-item
992                           (append items
993                                   (flatten-body-items
994                                    (classify/subforms
995                                     (cdr forms)
996                                     environment
997                                     environment))))))
998                     (make-expression-item
999                      (lambda ()
1000                        (output/letrec
1001                         (map definition-item/name definitions)
1002                         (map (lambda (definition)
1003                                (compile-item/expression
1004                                 (definition-item/value definition)))
1005                              definitions)
1006                         (compile-item/expression body))) forms)))))))))
1007
1008;;;; r4rs primitives
1009
1010(define (make-r4rs-primitive-macrology)
1011  (make-primitive-macrology
1012   (lambda (define-classifier define-compiler)
1013
1014     (define (transformer-keyword expander->classifier)
1015       (lambda (form environment definition-environment)
1016         definition-environment         ;ignore
1017         (syntax-check '(keyword expression) form)
1018         (let ((item
1019                (classify/subexpression (cadr form)
1020                                        scheme-syntactic-environment)))
1021           (let ((transformer (base:eval (compile-item/expression item))))
1022             (if (procedure? transformer)
1023                 (make-keyword-item
1024                  (expander->classifier transformer environment) item)
1025                 (syntax-error "transformer not a procedure"
1026                               transformer))))))
1027
1028     (define-classifier 'sc-macro-transformer
1029       ;; "syntactic closures" transformer
1030       (transformer-keyword sc-expander->classifier))
1031
1032     (define-classifier 'rsc-macro-transformer
1033       ;; reverse "syntactic closures" transformer
1034       (transformer-keyword rsc-expander->classifier))
1035     
1036     (define-classifier 'er-macro-transformer
1037       ;; "explicit renaming" transformer
1038       (transformer-keyword er-expander->classifier))
1039
1040     (define-compiler 'lambda
1041       (lambda (form environment)
1042         (syntax-check '(keyword dsssl-bvl + form) form)
1043         (let ((environment (internal-syntactic-environment environment)))
1044           ;; force order -- bind names before classifying body.
1045           (call-with-values
1046               (lambda ()
1047                 (if (##sys#extended-lambda-list? (cadr form))
1048                     (##sys#expand-extended-lambda-list (cadr form) (cddr form) ##sys#syntax-error-hook) 
1049                     (values (cadr form) (cddr form)) ) )
1050             (lambda (llist body)
1051               (let ((bvl-description
1052                      (let ((rename
1053                             (lambda (identifier)
1054                               (bind-variable! environment identifier))))
1055                        (let loop ((bvl llist))
1056                          (cond ((null? bvl)
1057                                 '())
1058                                ((pair? bvl)
1059                                 (cons (rename (car bvl)) (loop (cdr bvl))))
1060                                (else
1061                                 (rename bvl)))))))
1062                 (output/lambda bvl-description
1063                                (compile-item/expression
1064                                 (classify/body body environment)))))))))
1065
1066     (define-compiler 'set!
1067       (lambda (form0 environment0)
1068         (syntax-check '(keyword form expression) form0)
1069         (let loop
1070             ((form (cadr form0))
1071              (environment environment0))
1072           (cond ((identifier? form)
1073                  (let ((item (syntactic-environment/lookup environment form)))
1074                    (if (variable-item? item)
1075                        (output/assignment
1076                         (variable-item/name item)
1077                         (compile/subexpression (caddr form0)
1078                                                environment0))
1079                        (syntax-error "target of assignment not a variable"
1080                               form))))
1081                 ((syntactic-closure? form)
1082                  (let ((form (syntactic-closure/form form))
1083                        (environment
1084                         (filter-syntactic-environment
1085                          (syntactic-closure/free-names form)
1086                          environment
1087                          (syntactic-closure/environment form))))
1088                    (loop form
1089                          environment)))
1090                 ((pair? form)
1091                  (output/combination
1092                   (output/combination
1093                    '##sys#setter
1094                    (list (compile/subexpression (car form) environment0) ))
1095                   (append
1096                    (map (lambda (x) (compile/subexpression x environment0))
1097                         (cdr form) )
1098                    (list (compile/subexpression (caddr form0) environment0)))))
1099                 (else
1100                  (syntax-error "target of assignment not an identifier"
1101                         form))))))
1102     
1103     ;; end make-r4rs-primitive-macrology
1104     )))
1105
1106;;;; core expanders
1107
1108(define (make-core-expander-macrology)
1109  (make-er-expander-macrology
1110   (lambda (define-expander base-environment)
1111
1112     (let ((keyword (make-syntactic-closure base-environment '() 'define)))
1113       (define-expander 'define
1114         (lambda (form rename compare)
1115           compare                      ;ignore
1116           (cond ((syntax-match? '((identifier . dsssl-bvl) + form) (cdr form))
1117                  `(,keyword ,(caadr form)
1118                             (,(rename 'lambda) ,(cdadr form) ,@(cddr form))) )
1119                 ((syntax-match? '((form . dsssl-bvl) + form) (cdr form))
1120                  `(,(rename 'define) ,(caadr form)      ; curried define
1121                                      (,(rename 'lambda) ,(cdadr form) ,@(cddr form))) )
1122                 ((syntax-match? '(identifier) (cdr form))
1123                  `(,keyword ,(cadr form) (##sys#void)) )
1124                 (else `(,keyword ,@(cdr form)))))) )
1125
1126     (let ((keyword (make-syntactic-closure base-environment '() 'let)))
1127       (define-expander 'let
1128         (lambda (form rename compare)
1129           compare                      ;ignore
1130           (if (syntax-match? '(identifier (* (identifier expression)) + form)
1131                              (cdr form))
1132               (let ((name (cadr form))
1133                     (bindings (caddr form)))
1134                 `((,(rename 'letrec)
1135                    ((,name (,(rename 'lambda) ,(map car bindings) ,@(cdddr form))))
1136                    ,name)
1137                   ,@(map cadr bindings)))
1138               `(,keyword ,@(cdr form))))))
1139
1140     (define-expander 'let*
1141       (lambda (form rename compare)
1142         compare                        ;ignore
1143         (if (syntax-match? '((* (identifier expression)) + form) (cdr form))
1144             (let ((bindings (cadr form))
1145                   (body (cddr form))
1146                   (keyword (rename 'let)))
1147               (if (null? bindings)
1148                   `(,keyword ,bindings ,@body)
1149                   (let loop ((bindings bindings))
1150                     (if (null? (cdr bindings))
1151                         `(,keyword ,bindings ,@body)
1152                         `(,keyword (,(car bindings))
1153                                    ,(loop (cdr bindings)))))))
1154             (ill-formed-syntax form))))
1155
1156     (define-expander 'and
1157       (lambda (form rename compare)
1158         compare                        ;ignore
1159         (if (syntax-match? '(* expression) (cdr form))
1160             (let ((operands (cdr form)))
1161               (if (null? operands)
1162                   `#t
1163                   (let ((if-keyword (rename 'if)))
1164                     (let loop ((operands operands))
1165                       (if (null? (cdr operands))
1166                           (car operands)
1167                           `(,if-keyword ,(car operands)
1168                                         ,(loop (cdr operands))
1169                                         #f))))))
1170             (ill-formed-syntax form))))
1171
1172     (define-expander 'or
1173       (lambda (form rename compare)
1174         compare                        ;ignore
1175         (if (syntax-match? '(* expression) (cdr form))
1176             (let ((operands (cdr form)))
1177               (if (null? operands)
1178                   `#f
1179                   (let ((let-keyword (rename 'let))
1180                         (if-keyword (rename 'if))
1181                         (temp (rename 'temp)))
1182                     (let loop ((operands operands))
1183                       (if (null? (cdr operands))
1184                           (car operands)
1185                           `(,let-keyword ((,temp ,(car operands)))
1186                                          (,if-keyword ,temp
1187                                                       ,temp
1188                                                       ,(loop (cdr operands)))))))))
1189             (ill-formed-syntax form))))
1190
1191     (define-expander 'case
1192       (lambda (form rename compare)
1193         (if (syntax-match? '(expression + (datum + expression)) (cdr form))
1194             (letrec
1195                 ((process-clause
1196                   (lambda (clause rest)
1197                     (cond ((null? (car clause))
1198                            (process-rest rest))
1199                           ((and (identifier? (car clause))
1200                                 (compare (rename 'else) (car clause))
1201                                 (null? rest))
1202                            `(,(rename 'begin) ,@(cdr clause)))
1203                           ((list? (car clause))
1204                            `(,(rename 'if) (,(rename 'memv) ,(rename 'temp)
1205                                                             ',(car clause))
1206                                            (,(rename 'begin) ,@(cdr clause))
1207                                            ,(process-rest rest)))
1208                           (else
1209                            (syntax-error "ill-formed clause" clause)))))
1210                  (process-rest
1211                   (lambda (rest)
1212                     (if (null? rest)
1213                         (unspecific-expression)
1214                         (process-clause (car rest) (cdr rest))))))
1215               `(,(rename 'let) ((,(rename 'temp) ,(cadr form)))
1216                                ,(process-clause (caddr form) (cdddr form))))
1217             (ill-formed-syntax form))))
1218
1219     (define-expander 'cond
1220       (lambda (form rename compare)
1221         (letrec
1222             ((process-clause
1223               (lambda (clause rest)
1224                 (cond
1225                  ((or (not (list? clause))
1226                       (null? clause))
1227                   (syntax-error "ill-formed clause" clause))
1228                  ((and (identifier? (car clause))
1229                        (compare (rename 'else) (car clause)))
1230                   (cond
1231                    ((or (null? (cdr clause))
1232                         (and (identifier? (cadr clause))
1233                              (compare (rename '=>) (cadr clause))))
1234                     (syntax-error "ill-formed else clause" clause))
1235                    ((not (null? rest))
1236                     (syntax-error "misplaced else clause" clause))
1237                    (else
1238                     `(,(rename 'begin) ,@(cdr clause)))))
1239                  ((null? (cdr clause))
1240                   `(,(rename 'or) ,(car clause) ,(process-rest rest)))
1241                  ((and (identifier? (cadr clause))
1242                        (compare (rename '=>) (cadr clause)))
1243                   (if (and (pair? (cddr clause))
1244                            (null? (cdddr clause)))
1245                       `(,(rename 'let)
1246                         ((,(rename 'temp) ,(car clause)))
1247                         (,(rename 'if) ,(rename 'temp)
1248                                        (,(caddr clause) ,(rename 'temp))
1249                                        ,(process-rest rest)))
1250                       (syntax-error "ill-formed => clause" clause)))
1251                  (else
1252                   `(,(rename 'if) ,(car clause)
1253                                   (,(rename 'begin) ,@(cdr clause))
1254                                   ,(process-rest rest))))))
1255              (process-rest
1256               (lambda (rest)
1257                 (if (null? rest)
1258                     (unspecific-expression)
1259                     (process-clause (car rest) (cdr rest))))))
1260           (let ((clauses (cdr form)))
1261             (if (null? clauses)
1262                 (syntax-error "no clauses" form)
1263                 (process-clause (car clauses) (cdr clauses)))))))
1264
1265     (define-expander 'do
1266       (lambda (form rename compare)
1267         compare                        ;ignore
1268         (if (syntax-match? '((* (identifier expression ? expression))
1269                              (+ expression)
1270                              * form)
1271                            (cdr form))
1272             (let ((bindings (cadr form)))
1273               `(,(rename 'letrec)
1274                 ((,(rename 'do-loop)
1275                   (,(rename 'lambda)
1276                    ,(map car bindings)
1277                    (,(rename 'if) ,(caaddr form)
1278                                   ,(if (null? (cdaddr form))
1279                                        (unspecific-expression)
1280                                        `(,(rename 'begin) ,@(cdaddr form)))
1281                                   (,(rename 'begin)
1282                                    ,@(cdddr form)
1283                                    (,(rename 'do-loop)
1284                                     ,@(map (lambda (binding)
1285                                              (if (null? (cddr binding))
1286                                                  (car binding)
1287                                                  (caddr binding)))
1288                                            bindings)))))))
1289                 (,(rename 'do-loop) ,@(map cadr bindings))))
1290             (ill-formed-syntax form))))
1291
1292     (define-expander 'quasiquote
1293       (lambda (form rename compare)
1294         (define (descend-quasiquote x level return)
1295           (cond ((pair? x) (descend-quasiquote-pair x level return))
1296                 ((vector? x) (descend-quasiquote-vector x level return))
1297                 (else (return 'quote x))))
1298         (define (descend-quasiquote-pair x level return)
1299           (cond ((not (and (pair? x)
1300                            (identifier? (car x))
1301                            (pair? (cdr x))
1302                            (null? (cddr x))))
1303                  (descend-quasiquote-pair* x level return))
1304                 ((compare (rename 'quasiquote) (car x))
1305                  (descend-quasiquote-pair* x (+ level 1) return))
1306                 ((compare (rename 'unquote) (car x))
1307                  (if (zero? level)
1308                      (return 'unquote (cadr x))
1309                      (descend-quasiquote-pair* x (- level 1) return)))
1310                 ((compare (rename 'unquote-splicing) (car x))
1311                  (if (zero? level)
1312                      (return 'unquote-splicing (cadr x))
1313                      (descend-quasiquote-pair* x (- level 1) return)))
1314                 (else
1315                  (descend-quasiquote-pair* x level return))))
1316         (define (descend-quasiquote-pair* x level return)
1317           (descend-quasiquote
1318            (car x) level
1319            (lambda (car-mode car-arg)
1320              (descend-quasiquote
1321               (cdr x) level
1322               (lambda (cdr-mode cdr-arg)
1323                 (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
1324                        (return 'quote x))
1325                       ((eq? car-mode 'unquote-splicing)
1326                        (if (and (eq? cdr-mode 'quote) (null? cdr-arg))
1327                            (return 'unquote car-arg)
1328                            (return 'append
1329                                    (list car-arg
1330                                          (finalize-quasiquote cdr-mode
1331                                                               cdr-arg)))))
1332                       ((and (eq? cdr-mode 'quote) (list? cdr-arg))
1333                        (return 'list
1334                                (cons (finalize-quasiquote car-mode car-arg)
1335                                      (map (lambda (element)
1336                                             (finalize-quasiquote 'quote
1337                                                                  element))
1338                                           cdr-arg))))
1339                       ((eq? cdr-mode 'list)
1340                        (return 'list
1341                                (cons (finalize-quasiquote car-mode car-arg)
1342                                      cdr-arg)))
1343                       (else
1344                        (return
1345                         'cons
1346                         (list (finalize-quasiquote car-mode car-arg)
1347                               (finalize-quasiquote cdr-mode cdr-arg))))))))))
1348         (define (descend-quasiquote-vector x level return)
1349           (descend-quasiquote
1350            (vector->list x) level
1351            (lambda (mode arg)
1352              (case mode
1353                ((quote) (return 'quote x))
1354                ((list) (return 'vector arg))
1355                (else
1356                 (return 'list->vector
1357                         (list (finalize-quasiquote mode arg))))))))
1358         (define (finalize-quasiquote mode arg)
1359           (case mode
1360             ((quote) `(,(rename 'quote) ,arg))
1361             ((unquote) arg)
1362             ((unquote-splicing) (syntax-error ",@ in illegal context" arg))
1363             (else `(,(rename mode) ,@arg))))
1364         (if (syntax-match? '(expression) (cdr form))
1365             (descend-quasiquote (cadr form) 0 finalize-quasiquote)
1366             (ill-formed-syntax form))))
1367
1368;;; end make-core-expander-macrology
1369     )))
1370
1371;;;; Rule-based Syntactic Expanders
1372
1373;;; See "Syntactic Extensions in the Programming Language Lisp", by
1374;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986.
1375;;; See also "Macros That Work", by William Clinger and Jonathan Rees
1376;;; (reference? POPL?).  This implementation is derived from an
1377;;; implementation by Kent Dybvig, and includes some ideas from
1378;;; another implementation by Jonathan Rees.
1379
1380;;; The expansion of SYNTAX-RULES references the following keywords:
1381;;;   ER-TRANSFORMER LAMBDA IF BEGIN SET! QUOTE
1382;;; and the following procedures:
1383;;;   CAR CDR NULL? PAIR? EQUAL? MAP LIST CONS APPEND
1384;;;   ILL-FORMED-SYNTAX
1385;;; it also uses the anonymous keyword SYNTAX-QUOTE.
1386
1387;;; For testing.
1388;;;(define (run-sr form)
1389;;;  (expand/syntax-rules form (lambda (x) x) eq?))
1390
1391(define (make-syntax-rules-macrology)
1392  (make-er-expander-macrology
1393   (lambda (define-classifier base-environment)
1394     base-environment                   ;ignore
1395     (define-classifier 'syntax-rules expand/syntax-rules))))
1396
1397(define (expand/syntax-rules form rename compare)
1398  (if (syntax-match? '((* identifier) + ((identifier . datum) expression))
1399                     (cdr form))
1400      (let ((keywords (cadr form))
1401            (clauses (cddr form)))
1402        (if (let loop ((keywords keywords))
1403              (and (pair? keywords)
1404                   (or (memq (car keywords) (cdr keywords))
1405                       (loop (cdr keywords)))))
1406            (syntax-error "keywords list contains duplicates" keywords)
1407            (let ((r-form (rename 'form))
1408                  (r-rename (rename 'rename))
1409                  (r-compare (rename 'compare)))
1410              `(,(rename 'er-macro-transformer)
1411                (,(rename 'lambda)
1412                 (,r-form ,r-rename ,r-compare)
1413                 ,(let loop ((clauses clauses))
1414                    (if (null? clauses)
1415                        `(,(rename 'ill-formed-syntax) ,r-form)
1416                        (let ((pattern (caar clauses)))
1417                          (let ((sids
1418                                 (parse-pattern rename compare keywords
1419                                                pattern r-form)))
1420                            `(,(rename 'if)
1421                              ,(generate-match rename compare keywords
1422                                               r-rename r-compare
1423                                               pattern r-form)
1424                              ,(generate-output rename compare r-rename
1425                                                sids (cadar clauses)
1426                                                syntax-error)
1427                              ,(loop (cdr clauses))))))))))))
1428      (ill-formed-syntax form)))
1429
1430(define (parse-pattern rename compare keywords pattern expression)
1431  (let loop
1432      ((pattern pattern)
1433       (expression expression)
1434       (sids '())
1435       (control #f))
1436    (cond ((identifier? pattern)
1437           (if (memq pattern keywords)
1438               sids
1439               (cons (make-sid pattern expression control) sids)))
1440          ((and (or (zero-or-more? pattern rename compare)
1441                    (at-least-one? pattern rename compare))
1442                (null? (cddr pattern)))
1443           (let ((variable ((make-name-generator) 'control)))
1444             (loop (car pattern)
1445                   variable
1446                   sids
1447                   (make-sid variable expression control))))
1448          ((pair? pattern)
1449           (loop (car pattern)
1450                 `(,(rename 'car) ,expression)
1451                 (loop (cdr pattern)
1452                       `(,(rename 'cdr) ,expression)
1453                       sids
1454                       control)
1455                 control))
1456          ((vector? pattern)
1457           (loop (vector->list pattern)
1458                 `(,(rename 'vector->list) ,expression)
1459                 sids
1460                 control))
1461          (else sids))))
1462
1463(define (generate-match rename compare keywords r-rename r-compare
1464                        pattern expression)
1465  (letrec
1466      ((loop
1467        (lambda (pattern expression)
1468          (cond ((identifier? pattern)
1469                 (if (memq pattern keywords)
1470                     (let ((temp (rename 'temp)))
1471                       `((,(rename 'lambda)
1472                          (,temp)
1473                          (,(rename 'if)
1474                           (,(rename 'identifier?) ,temp)
1475                           (,r-compare ,temp
1476                                       (,r-rename ,(syntax-quote pattern)))
1477                           #f))
1478                         ,expression))
1479                     `#t))
1480                ((and (zero-or-more? pattern rename compare)
1481                      (null? (cddr pattern)))
1482                 (do-list (car pattern) expression))
1483                ((and (at-least-one? pattern rename compare)
1484                      (null? (cddr pattern)))
1485                 `(,(rename 'if) (,(rename 'null?) ,expression)
1486                                 #f
1487                                 ,(do-list (car pattern) expression)))
1488                ((pair? pattern)
1489                 (let ((generate-pair
1490                        (lambda (expression)
1491                          (conjunction
1492                           `(,(rename 'pair?) ,expression)
1493                           (conjunction
1494                            (loop (car pattern)
1495                                  `(,(rename 'car) ,expression))
1496                            (loop (cdr pattern)
1497                                  `(,(rename 'cdr) ,expression)))))))
1498                   (if (identifier? expression)
1499                       (generate-pair expression)
1500                       (let ((temp (rename 'temp)))
1501                         `((,(rename 'lambda) (,temp) ,(generate-pair temp))
1502                           ,expression)))))
1503                ((null? pattern)
1504                 `(,(rename 'null?) ,expression))
1505                ((vector? pattern)
1506                 (letrec
1507                     ((len (vector-length pattern))
1508                      (generate-vector
1509                       (lambda (len res)
1510                         (if (negative? len)
1511                           res
1512                           (generate-vector
1513                            (- len 1)
1514                            (conjunction (loop (vector-ref pattern len)
1515                                               `(,(rename 'vector-ref)
1516                                                 ,expression
1517                                                 ,len))
1518                                         res))))))
1519                   (if (zero? len)
1520                     `(,(rename 'equal?) ,expression '#())
1521                     (conjunction
1522                      `(,(rename 'vector?) ,expression)
1523                      (if (compare (vector-ref pattern (- len 1)) (rename '...))
1524                        (conjunction
1525                         `(,(rename '>=)
1526                           (,(rename 'vector-length) ,expression)
1527                           ,(- len 2))
1528                         (conjunction
1529                          (generate-vector (- len 2) #t)
1530                          (do-vec (vector-ref pattern (- len 1))
1531                                  expression
1532                                  (- len 1))))
1533                        (conjunction
1534                         `(,(rename '>=)
1535                           (,(rename 'vector-length) ,expression)
1536                           ,(- len 2))
1537                         (generate-vector (- len 1) #t)))))))
1538                (else
1539                 `(,(rename 'equal?) ,expression
1540                                     (,(rename 'quote) ,pattern))))))
1541       (do-list
1542        (lambda (pattern expression)
1543          (let ((r-loop (rename 'loop))
1544                (r-l (rename 'l))
1545                (r-lambda (rename 'lambda)))
1546            `(((,r-lambda
1547                (,r-loop)
1548                (,(rename 'begin)
1549                 (,(rename 'set!)
1550                  ,r-loop
1551                  (,r-lambda
1552                   (,r-l)
1553                   (,(rename 'if)
1554                    (,(rename 'null?) ,r-l)
1555                    #t
1556                    ,(conjunction
1557                      `(,(rename 'pair?) ,r-l)
1558                      (conjunction (loop pattern `(,(rename 'car) ,r-l))
1559                                   `(,r-loop (,(rename 'cdr) ,r-l)))))))
1560                 ,r-loop))
1561               #f)
1562              ,expression))))
1563       (do-vec
1564        (lambda (pattern expression start)
1565          (let ((r-loop (rename 'loop))
1566                (r-vec (rename 'vec))
1567                (r-len (rename 'len))
1568                (r-i (rename 'i))
1569                (r-lambda (rename 'lambda)))
1570            `((,r-lambda
1571               (,r-vec)
1572               ((,r-lambda
1573                 (,r-len)
1574                 ((,r-lambda
1575                   (,r-loop)
1576                   (,(rename 'begin)
1577                    (,(rename 'set!)
1578                     ,r-loop
1579                     (,r-lambda
1580                      (,r-i)
1581                      (,(rename 'if)
1582                       (,(rename '>=) ,r-i ,r-len)
1583                       #t
1584                       ,(conjunction
1585                         (loop pattern `(,(rename 'vector-ref) ,r-vec))
1586                         `(,r-loop (,(rename '+) ,r-i 1))))))
1587                    (,r-loop ,start)))
1588                  #f))
1589                (,(rename 'vector-length) ,r-vec)))
1590              ,expression))))
1591       (conjunction
1592        (lambda (predicate consequent)
1593          (cond ((eq? predicate #t) consequent)
1594                ((eq? consequent #t) predicate)
1595                (else `(,(rename 'if) ,predicate ,consequent #f))))))
1596    (loop pattern expression)))
1597
1598(define (generate-output rename compare r-rename sids template syntax-error)
1599  (let loop ((template template) (ellipses '()))
1600    (cond ((identifier? template)
1601           (let ((sid
1602                  (let loop ((sids sids))
1603                    (and (not (null? sids))
1604                         (if (eq? (sid-name (car sids)) template)
1605                             (car sids)
1606                             (loop (cdr sids)))))))
1607             (if sid
1608                 (begin
1609                   (add-control! sid ellipses syntax-error)
1610                   (sid-expression sid))
1611                 `(,r-rename ,(syntax-quote template)))))
1612          ((or (zero-or-more? template rename compare)
1613               (at-least-one? template rename compare))
1614           (optimized-append rename compare
1615                             (let ((ellipsis (make-ellipsis '())))
1616                               (generate-ellipsis rename
1617                                                  ellipsis
1618                                                  (loop (car template)
1619                                                        (cons ellipsis
1620                                                              ellipses))))
1621                             (loop (cddr template) ellipses)))
1622          ((pair? template)
1623           (optimized-cons rename compare
1624                           (loop (car template) ellipses)
1625                           (loop (cdr template) ellipses)))
1626          (else
1627           `(,(rename 'quote) ,template)))))
1628
1629(define (add-control! sid ellipses syntax-error)
1630  (let loop ((sid sid) (ellipses ellipses))
1631    (let ((control (sid-control sid)))
1632      (cond (control
1633             (if (null? ellipses)
1634                 (syntax-error "missing ellipsis in expansion")
1635                 (let ((sids (ellipsis-sids (car ellipses))))
1636                   (cond ((not (memq control sids))
1637                          (set-ellipsis-sids! (car ellipses)
1638                                              (cons control sids)))
1639                         ((not (eq? control (car sids)))
1640                          (syntax-error "illegal control/ellipsis combination"
1641                                        control sids)))))
1642             (loop control (cdr ellipses)))
1643         ;; This check catches useful errors but prohibits useful
1644         ;; idioms of unambiguous mixed segment depth.
1645         ;; ((not (null? ellipses))
1646         ;;  (syntax-error "extra ellipsis in expansion"))
1647            ))))
1648
1649(define (generate-ellipsis rename ellipsis body)
1650  (let ((sids (ellipsis-sids ellipsis)))
1651    (let ((name (sid-name (car sids)))
1652          (expression (sid-expression (car sids))))
1653      (cond ((and (null? (cdr sids))
1654                  (eq? body name))
1655             expression)
1656            ((and (null? (cdr sids))
1657                  (pair? body)
1658                  (pair? (cdr body))
1659                  (eq? (cadr body) name)
1660                  (null? (cddr body)))
1661             `(,(rename 'map) ,(car body) ,expression))
1662            (else
1663             `(,(rename 'map) (,(rename 'lambda) ,(map sid-name sids) ,body)
1664                              ,@(map sid-expression sids)))))))
1665
1666(define (zero-or-more? pattern rename compare)
1667  (and (pair? pattern)
1668       (pair? (cdr pattern))
1669       (identifier? (cadr pattern))
1670       (compare (cadr pattern) (rename '...))))
1671
1672(define (at-least-one? pattern rename compare)
1673;;;  (and (pair? pattern)
1674;;;       (pair? (cdr pattern))
1675;;;       (identifier? (cadr pattern))
1676;;;       (compare (cadr pattern) (rename '+)))
1677  pattern rename compare                ;ignore
1678  #f)
1679
1680(define (optimized-cons rename compare a d)
1681  (cond ((and (pair? d)
1682              (compare (car d) (rename 'quote))
1683              (pair? (cdr d))
1684              (null? (cadr d))
1685              (null? (cddr d)))
1686         `(,(rename 'list) ,a))
1687        ((and (pair? d)
1688              (compare (car d) (rename 'list))
1689              (list? (cdr d)))
1690         `(,(car d) ,a ,@(cdr d)))
1691        (else
1692         `(,(rename 'cons) ,a ,d))))
1693
1694(define (optimized-append rename compare x y)
1695  (if (and (pair? y)
1696           (compare (car y) (rename 'quote))
1697           (pair? (cdr y))
1698           (null? (cadr y))
1699           (null? (cddr y)))
1700      x
1701      `(,(rename 'append) ,x ,y)))
1702
1703(define-record sid name expression control output-expression)
1704
1705(define make-sid
1706  (let ((make-sid make-sid))
1707    (lambda (name expression control)
1708      (make-sid name expression control (void)) ) ) )
1709
1710(define set-sid-output-expression! sid-output-expression-set!)
1711
1712(define-record ellipsis sids)
1713
1714(define set-ellipsis-sids! ellipsis-sids-set!)
1715
1716;;; OK, time to build the databases.
1717(initialize-scheme-syntactic-environment!)
1718
1719;;@ MACRO:EXPAND is for you to use.  It takes an R4RS expression, macro-expands
1720;;; it, and returns the result of the macro expansion.
1721(define (synclo:expand expression)
1722  (set! *counter* 0)
1723  (compile/top-level (list expression) scheme-syntactic-environment))
1724
1725(set! ##sys#compiler-toplevel-macroexpand-hook synclo:expand)
1726(set! ##sys#interpreter-toplevel-macroexpand-hook synclo:expand)
1727(set! macroexpand (lambda (exp . me) (synclo:expand exp)))
1728;(set! ##sys#macroexpand-1-local (lambda (x me) x))
1729
1730(register-feature! 'syntax-rules 'hygienic-macros 'syntactic-closures)
1731
1732(define (base:eval x) ((##sys#eval-handler) x))
1733
1734(unless (memq #:standard-syntax ##sys#features)
1735  (load (##sys#resolve-include-filename "syntactic-closures-chicken-macros.scm" #t #t)) )
Note: See TracBrowser for help on using the repository browser.