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

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

syntactic-closures: add curried define

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