3 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;;; Portable implementation of syntax-case
22 ;;; Originally extracted from Chez Scheme Version 5.9f
23 ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
25 ;;; Copyright (c) 1992-1997 Cadence Research Systems
26 ;;; Permission to copy this software, in whole or in part, to use this
27 ;;; software for any lawful purpose, and to redistribute this software
28 ;;; is granted subject to the restriction that all copies made of this
29 ;;; software must include this copyright notice in full. This software
30 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
31 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
32 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
33 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
34 ;;; NATURE WHATSOEVER.
36 ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
37 ;;; to the ChangeLog distributed in the same directory as this file:
38 ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
39 ;;; 2000-09-12, 2001-03-08
41 ;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
42 ;;; revision control logs corresponding to this file: 2009, 2010.
45 ;;; This file defines the syntax-case expander, macroexpand, and a set
46 ;;; of associated syntactic forms and procedures. Of these, the
47 ;;; following are documented in The Scheme Programming Language,
48 ;;; Fourth Edition (R. Kent Dybvig, MIT Press, 2009), and in the
51 ;;; bound-identifier=?
54 ;;; syntax-parameterize
56 ;;; generate-temporaries
67 ;;; Additionally, the expander provides definitions for a number of core
68 ;;; Scheme syntactic bindings, such as `let', `lambda', and the like.
70 ;;; The remaining exports are listed below:
72 ;;; (macroexpand datum)
73 ;;; if datum represents a valid expression, macroexpand returns an
74 ;;; expanded version of datum in a core language that includes no
75 ;;; syntactic abstractions. The core language includes begin,
76 ;;; define, if, lambda, letrec, quote, and set!.
77 ;;; (eval-when situations expr ...)
78 ;;; conditionally evaluates expr ... at compile-time or run-time
79 ;;; depending upon situations (see the Chez Scheme System Manual,
80 ;;; Revision 3, for a complete description)
81 ;;; (syntax-violation who message form [subform])
82 ;;; used to report errors found during expansion
83 ;;; ($sc-dispatch e p)
84 ;;; used by expanded code to handle syntax-case matching
86 ;;; This file is shipped along with an expanded version of itself,
87 ;;; psyntax-pp.scm, which is loaded when psyntax.scm has not yet been
88 ;;; compiled. In this way, psyntax bootstraps off of an expanded
89 ;;; version of itself.
91 ;;; This implementation of the expander sometimes uses syntactic
92 ;;; abstractions when procedural abstractions would suffice. For
93 ;;; example, we define top-wrap and top-marked? as
95 ;;; (define-syntax top-wrap (identifier-syntax '((top))))
96 ;;; (define-syntax top-marked?
98 ;;; ((_ w) (memq 'top (wrap-marks w)))))
102 ;;; (define top-wrap '((top)))
103 ;;; (define top-marked?
104 ;;; (lambda (w) (memq 'top (wrap-marks w))))
106 ;;; On the other hand, we don't do this consistently; we define
107 ;;; make-wrap, wrap-marks, and wrap-subst simply as
109 ;;; (define make-wrap cons)
110 ;;; (define wrap-marks car)
111 ;;; (define wrap-subst cdr)
113 ;;; In Chez Scheme, the syntactic and procedural forms of these
114 ;;; abstractions are equivalent, since the optimizer consistently
115 ;;; integrates constants and small procedures. This will be true of
116 ;;; Guile as well, once we implement a proper inliner.
119 ;;; Implementation notes:
121 ;;; Objects with no standard print syntax, including objects containing
122 ;;; cycles and syntax object, are allowed in quoted data as long as they
123 ;;; are contained within a syntax form or produced by datum->syntax.
124 ;;; Such objects are never copied.
126 ;;; All identifiers that don't have macro definitions and are not bound
127 ;;; lexically are assumed to be global variables.
129 ;;; Top-level definitions of macro-introduced identifiers are allowed.
130 ;;; This may not be appropriate for implementations in which the
131 ;;; model is that bindings are created by definitions, as opposed to
132 ;;; one in which initial values are assigned by definitions.
134 ;;; Identifiers and syntax objects are implemented as vectors for
135 ;;; portability. As a result, it is possible to "forge" syntax objects.
137 ;;; The implementation of generate-temporaries assumes that it is
138 ;;; possible to generate globally unique symbols (gensyms).
140 ;;; The source location associated with incoming expressions is tracked
141 ;;; via the source-properties mechanism, a weak map from expression to
142 ;;; source information. At times the source is separated from the
143 ;;; expression; see the note below about "efficiency and confusion".
148 ;;; When changing syntax-object representations, it is necessary to support
149 ;;; both old and new syntax-object representations in id-var-name. It
150 ;;; should be sufficient to recognize old representations and treat
151 ;;; them as not lexically bound.
156 (set-current-module (resolve-module '(guile))))
159 (define-syntax define-expansion-constructors
163 (let lp ((n 0) (out '()))
164 (if (< n (vector-length %expanded-vtables))
166 (let* ((vtable (vector-ref %expanded-vtables n))
167 (stem (struct-ref vtable (+ vtable-offset-user 0)))
168 (fields (struct-ref vtable (+ vtable-offset-user 2)))
169 (sfields (map (lambda (f) (datum->syntax x f)) fields))
170 (ctor (datum->syntax x (symbol-append 'make- stem))))
171 (cons #`(define (#,ctor #,@sfields)
172 (make-struct (vector-ref %expanded-vtables #,n) 0
175 #`(begin #,@(reverse out))))))))
177 (define-syntax define-expansion-accessors
182 (let ((vtable (vector-ref %expanded-vtables n))
183 (stem (syntax->datum #'stem)))
184 (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
186 (define (#,(datum->syntax x (symbol-append stem '?)) x)
188 (eq? (struct-vtable x)
189 (vector-ref %expanded-vtables #,n))))
192 (let ((get (datum->syntax x (symbol-append stem '- f)))
193 (set (datum->syntax x (symbol-append 'set- stem '- f '!)))
194 (idx (list-index (struct-ref vtable
195 (+ vtable-offset-user 2))
199 (struct-ref x #,idx))
201 (struct-set! x #,idx v)))))
202 (syntax->datum #'(field ...))))
205 (define-syntax define-structure
207 (define construct-name
208 (lambda (template-identifier . args)
216 (symbol->string (syntax->datum x))))
220 (and-map identifier? #'(name id1 ...))
222 ((constructor (construct-name #'name "make-" #'name))
223 (predicate (construct-name #'name #'name "?"))
225 (map (lambda (x) (construct-name x #'name "-" x))
229 (construct-name x "set-" #'name "-" x "!"))
232 (+ (length #'(id1 ...)) 1))
234 (let f ((i 1) (ids #'(id1 ...)))
237 (cons i (f (+ i 1) (cdr ids)))))))
241 (vector 'name id1 ... )))
245 (= (vector-length x) structure-length)
246 (eq? (vector-ref x 0) 'name))))
249 (vector-ref x index)))
253 (vector-set! x index update)))
257 (define-expansion-constructors)
258 (define-expansion-accessors lambda meta)
260 ;; hooks to nonportable run-time helpers
262 (define-syntax fx+ (identifier-syntax +))
263 (define-syntax fx- (identifier-syntax -))
264 (define-syntax fx= (identifier-syntax =))
265 (define-syntax fx< (identifier-syntax <))
267 (define top-level-eval-hook
271 (define local-eval-hook
275 (define-syntax-rule (gensym-hook)
278 (define put-global-definition-hook
279 (lambda (symbol type val)
280 (module-define! (current-module)
282 (make-syntax-transformer symbol type val))))
284 (define get-global-definition-hook
285 (lambda (symbol module)
286 (if (and (not module) (current-module))
287 (warn "module system is booted, we should have a module" symbol))
288 (let ((v (module-variable (if module
289 (resolve-module (cdr module))
292 (and v (variable-bound? v)
293 (let ((val (variable-ref v)))
294 (and (macro? val) (macro-type val)
295 (cons (macro-type val)
296 (macro-binding val)))))))))
299 (define (decorate-source e s)
300 (if (and (pair? e) s)
301 (set-source-properties! e s))
304 (define (maybe-name-value! name val)
306 (let ((meta (lambda-meta val)))
307 (if (not (assq 'name meta))
308 (set-lambda-meta! val (acons 'name name meta))))))
310 ;; output constructors
316 (lambda (source fun-exp arg-exps)
317 (make-call source fun-exp arg-exps)))
319 (define build-conditional
320 (lambda (source test-exp then-exp else-exp)
321 (make-conditional source test-exp then-exp else-exp)))
324 (lambda (source fluids vals body)
325 (make-dynlet source fluids vals body)))
327 (define build-lexical-reference
328 (lambda (type source name var)
329 (make-lexical-ref source name var)))
331 (define build-lexical-assignment
332 (lambda (source name var exp)
333 (maybe-name-value! name exp)
334 (make-lexical-set source name var exp)))
336 (define (analyze-variable mod var modref-cont bare-cont)
339 (let ((kind (car mod))
342 ((public) (modref-cont mod var #t))
343 ((private) (if (not (equal? mod (module-name (current-module))))
344 (modref-cont mod var #f)
346 ((bare) (bare-cont var))
347 ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
348 (module-variable (resolve-module mod) var))
349 (modref-cont mod var #f)
351 (else (syntax-violation #f "bad module kind" var mod))))))
353 (define build-global-reference
354 (lambda (source var mod)
357 (lambda (mod var public?)
358 (make-module-ref source mod var public?))
360 (make-toplevel-ref source var)))))
362 (define build-global-assignment
363 (lambda (source var exp mod)
364 (maybe-name-value! var exp)
367 (lambda (mod var public?)
368 (make-module-set source mod var public? exp))
370 (make-toplevel-set source var exp)))))
372 (define build-global-definition
373 (lambda (source var exp)
374 (maybe-name-value! var exp)
375 (make-toplevel-define source var exp)))
377 (define build-simple-lambda
378 (lambda (src req rest vars meta exp)
381 ;; hah, a case in which kwargs would be nice.
383 ;; src req opt rest kw inits vars body else
384 src req #f rest #f '() vars exp #f))))
386 (define build-case-lambda
387 (lambda (src meta body)
388 (make-lambda src meta body)))
390 (define build-lambda-case
392 ;; opt := (name ...) | #f
394 ;; kw := (allow-other-keys? (keyword name var) ...) | #f
397 ;; vars map to named arguments in the following order:
398 ;; required, optional (positional), rest, keyword.
399 ;; the body of a lambda: anything, already expanded
400 ;; else: lambda-case | #f
401 (lambda (src req opt rest kw inits vars body else-case)
402 (make-lambda-case src req opt rest kw inits vars body else-case)))
404 (define build-primcall
405 (lambda (src name args)
406 (make-primcall src name args)))
408 (define build-primref
410 (make-primitive-ref src name)))
412 (define (build-data src exp)
413 (make-const src exp))
415 (define build-sequence
417 (if (null? (cdr exps))
419 (make-seq src (car exps) (build-sequence #f (cdr exps))))))
422 (lambda (src ids vars val-exps body-exp)
423 (for-each maybe-name-value! ids val-exps)
426 (make-let src ids vars val-exps body-exp))))
428 (define build-named-let
429 (lambda (src ids vars val-exps body-exp)
434 (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
435 (maybe-name-value! f-name proc)
436 (for-each maybe-name-value! ids val-exps)
439 (list f-name) (list f) (list proc)
440 (build-call src (build-lexical-reference 'fun src f-name f)
444 (lambda (src in-order? ids vars val-exps body-exp)
448 (for-each maybe-name-value! ids val-exps)
449 (make-letrec src in-order? ids vars val-exps body-exp)))))
452 ;; FIXME: use a faster gensym
453 (define-syntax-rule (build-lexical-var src id)
454 (gensym (string-append (symbol->string id) " ")))
456 (define-structure (syntax-object expression wrap module))
458 (define-syntax no-source (identifier-syntax #f))
460 (define source-annotation
464 (source-annotation (syntax-object-expression x)))
465 ((pair? x) (let ((props (source-properties x)))
471 (define-syntax-rule (arg-check pred? e who)
473 (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
475 ;; compile-time environments
477 ;; wrap and environment comprise two level mapping.
478 ;; wrap : id --> label
479 ;; env : label --> <element>
481 ;; environments are represented in two parts: a lexical part and a global
482 ;; part. The lexical part is a simple list of associations from labels
483 ;; to bindings. The global part is implemented by
484 ;; {put,get}-global-definition-hook and associates symbols with
487 ;; global (assumed global variable) and displaced-lexical (see below)
488 ;; do not show up in any environment; instead, they are fabricated by
489 ;; resolve-identifier when it finds no other bindings.
491 ;; <environment> ::= ((<label> . <binding>)*)
493 ;; identifier bindings include a type and a value
495 ;; <binding> ::= (macro . <procedure>) macros
496 ;; (syntax-parameter . (<procedure>)) syntax parameters
497 ;; (core . <procedure>) core forms
498 ;; (module-ref . <procedure>) @ or @@
501 ;; (define-syntax) define-syntax
502 ;; (define-syntax-parameter) define-syntax-parameter
503 ;; (local-syntax . rec?) let-syntax/letrec-syntax
504 ;; (eval-when) eval-when
505 ;; (syntax . (<var> . <level>)) pattern variables
506 ;; (global) assumed global variable
507 ;; (lexical . <var>) lexical variables
508 ;; (displaced-lexical) displaced lexicals
509 ;; <level> ::= <nonnegative integer>
510 ;; <var> ::= variable returned by build-lexical-var
512 ;; a macro is a user-defined syntactic-form. a core is a
513 ;; system-defined syntactic form. begin, define, define-syntax,
514 ;; define-syntax-parameter, and eval-when are treated specially
515 ;; since they are sensitive to whether the form is at top-level and
516 ;; (except for eval-when) can denote valid internal definitions.
518 ;; a pattern variable is a variable introduced by syntax-case and can
519 ;; be referenced only within a syntax form.
521 ;; any identifier for which no top-level syntax definition or local
522 ;; binding of any kind has been seen is assumed to be a global
525 ;; a lexical variable is a lambda- or letrec-bound variable.
527 ;; a displaced-lexical identifier is a lexical identifier removed from
528 ;; it's scope by the return of a syntax object containing the identifier.
529 ;; a displaced lexical can also appear when a letrec-syntax-bound
530 ;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
531 ;; a displaced lexical should never occur with properly written macros.
533 (define-syntax make-binding
534 (syntax-rules (quote)
535 ((_ type value) (cons type value))
537 ((_ type) (cons type '()))))
538 (define-syntax-rule (binding-type x)
540 (define-syntax-rule (binding-value x)
543 (define-syntax null-env (identifier-syntax '()))
546 (lambda (labels bindings r)
549 (extend-env (cdr labels) (cdr bindings)
550 (cons (cons (car labels) (car bindings)) r)))))
552 (define extend-var-env
553 ;; variant of extend-env that forms "lexical" binding
554 (lambda (labels vars r)
557 (extend-var-env (cdr labels) (cdr vars)
558 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
560 ;; we use a "macros only" environment in expansion of local macro
561 ;; definitions so that their definitions can use local macros without
562 ;; attempting to use other lexical identifiers.
563 (define macros-only-env
568 (if (memq (cadr a) '(macro syntax-parameter))
569 (cons a (macros-only-env (cdr r)))
570 (macros-only-env (cdr r)))))))
572 (define global-extend
573 (lambda (type sym val)
574 (put-global-definition-hook sym type val)))
577 ;; Conceptually, identifiers are always syntax objects. Internally,
578 ;; however, the wrap is sometimes maintained separately (a source of
579 ;; efficiency and confusion), so that symbols are also considered
580 ;; identifiers by id?. Externally, they are always wrapped.
582 (define nonsymbol-id?
584 (and (syntax-object? x)
585 (symbol? (syntax-object-expression x)))))
591 ((syntax-object? x) (symbol? (syntax-object-expression x)))
594 (define-syntax-rule (id-sym-name e)
596 (if (syntax-object? x)
597 (syntax-object-expression x)
600 (define id-sym-name&marks
602 (if (syntax-object? x)
604 (syntax-object-expression x)
605 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
606 (values x (wrap-marks w)))))
608 ;; syntax object wraps
610 ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
611 ;; <subst> ::= <shift> | <subs>
612 ;; <subs> ::= #(<old name> <label> (<mark> ...))
613 ;; <shift> ::= positive fixnum
615 (define-syntax make-wrap (identifier-syntax cons))
616 (define-syntax wrap-marks (identifier-syntax car))
617 (define-syntax wrap-subst (identifier-syntax cdr))
619 (define-syntax subst-rename? (identifier-syntax vector?))
620 (define-syntax-rule (rename-old x) (vector-ref x 0))
621 (define-syntax-rule (rename-new x) (vector-ref x 1))
622 (define-syntax-rule (rename-marks x) (vector-ref x 2))
623 (define-syntax-rule (make-rename old new marks)
624 (vector old new marks))
626 ;; labels must be comparable with "eq?", have read-write invariance,
627 ;; and distinct from symbols.
629 (lambda () (symbol->string (gensym "i"))))
635 (cons (gen-label) (gen-labels (cdr ls))))))
637 (define-structure (ribcage symnames marks labels))
639 (define-syntax empty-wrap (identifier-syntax '(())))
641 (define-syntax top-wrap (identifier-syntax '((top))))
643 (define-syntax-rule (top-marked? w)
644 (memq 'top (wrap-marks w)))
646 ;; Marks must be comparable with "eq?" and distinct from pairs and
647 ;; the symbol top. We do not use integers so that marks will remain
648 ;; unique even across file compiles.
650 (define-syntax the-anti-mark (identifier-syntax #f))
654 (make-wrap (cons the-anti-mark (wrap-marks w))
655 (cons 'shift (wrap-subst w)))))
657 (define-syntax-rule (new-mark)
660 ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
661 ;; internal definitions, in which the ribcages are built incrementally
662 (define-syntax-rule (make-empty-ribcage)
663 (make-ribcage '() '() '()))
665 (define extend-ribcage!
666 ;; must receive ids with complete wraps
667 (lambda (ribcage id label)
668 (set-ribcage-symnames! ribcage
669 (cons (syntax-object-expression id)
670 (ribcage-symnames ribcage)))
671 (set-ribcage-marks! ribcage
672 (cons (wrap-marks (syntax-object-wrap id))
673 (ribcage-marks ribcage)))
674 (set-ribcage-labels! ribcage
675 (cons label (ribcage-labels ribcage)))))
677 ;; make-binding-wrap creates vector-based ribcages
678 (define make-binding-wrap
679 (lambda (ids labels w)
685 (let ((labelvec (list->vector labels)))
686 (let ((n (vector-length labelvec)))
687 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
688 (let f ((ids ids) (i 0))
689 (if (not (null? ids))
691 (lambda () (id-sym-name&marks (car ids) w))
692 (lambda (symname marks)
693 (vector-set! symnamevec i symname)
694 (vector-set! marksvec i marks)
695 (f (cdr ids) (fx+ i 1))))))
696 (make-ribcage symnamevec marksvec labelvec))))
707 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
713 (smart-append s1 (wrap-subst w2))))
715 (smart-append m1 (wrap-marks w2))
716 (smart-append s1 (wrap-subst w2)))))))
720 (smart-append m1 m2)))
727 (eq? (car x) (car y))
728 (same-marks? (cdr x) (cdr y))))))
731 ;; Syntax objects use wraps to associate names with marked
732 ;; identifiers. This function returns the name corresponding to
733 ;; the given identifier and wrap, or the original identifier if no
734 ;; corresponding name was found.
736 ;; The name may be a string created by gen-label, indicating a
737 ;; lexical binding, or another syntax object, indicating a
738 ;; reference to a top-level definition created during a previous
741 ;; For lexical variables, finding a label simply amounts to
742 ;; looking for an entry with the same symbolic name and the same
743 ;; marks. Finding a toplevel definition is the same, except we
744 ;; also have to compare modules, hence the `mod' parameter.
745 ;; Instead of adding a separate entry in the ribcage for modules,
746 ;; which wouldn't be used for lexicals, we arrange for the entry
747 ;; for the name entry to be a pair with the module in its car, and
748 ;; the name itself in the cdr. So if the name that we find is a
749 ;; pair, we have to check modules.
751 ;; The identifer may be passed in wrapped or unwrapped. In any
752 ;; case, this routine returns either a symbol, a syntax object, or
756 (define-syntax-rule (first e)
757 ;; Rely on Guile's multiple-values truncation.
760 (lambda (sym subst marks mod)
763 (let ((fst (car subst)))
765 (search sym (cdr subst) (cdr marks) mod)
766 (let ((symnames (ribcage-symnames fst)))
767 (if (vector? symnames)
768 (search-vector-rib sym subst marks symnames fst mod)
769 (search-list-rib sym subst marks symnames fst mod))))))))
770 (define search-list-rib
771 (lambda (sym subst marks symnames ribcage mod)
772 (let f ((symnames symnames) (i 0))
774 ((null? symnames) (search sym (cdr subst) marks mod))
775 ((and (eq? (car symnames) sym)
776 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
777 (let ((n (list-ref (ribcage-labels ribcage) i)))
779 (if (equal? mod (car n))
780 (values (cdr n) marks)
781 (f (cdr symnames) (fx+ i 1)))
783 (else (f (cdr symnames) (fx+ i 1)))))))
784 (define search-vector-rib
785 (lambda (sym subst marks symnames ribcage mod)
786 (let ((n (vector-length symnames)))
789 ((fx= i n) (search sym (cdr subst) marks mod))
790 ((and (eq? (vector-ref symnames i) sym)
791 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
792 (let ((n (vector-ref (ribcage-labels ribcage) i)))
794 (if (equal? mod (car n))
795 (values (cdr n) marks)
798 (else (f (fx+ i 1))))))))
801 (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
803 (let ((id (syntax-object-expression id))
804 (w1 (syntax-object-wrap id))
805 (mod (syntax-object-module id)))
806 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
807 (call-with-values (lambda () (search id (wrap-subst w) marks mod))
808 (lambda (new-id marks)
810 (first (search id (wrap-subst w1) marks mod))
812 (else (syntax-violation 'id-var-name "invalid id" id)))))
814 ;; Returns three values: binding type, binding value, the module (for
815 ;; resolving toplevel vars).
816 (define (resolve-identifier id w r mod resolve-syntax-parameters?)
817 (define (resolve-syntax-parameters b)
818 (if (and resolve-syntax-parameters?
819 (eq? (binding-type b) 'syntax-parameter))
820 (or (assq-ref r (binding-value b))
821 (make-binding 'macro (car (binding-value b))))
823 (define (resolve-global var mod)
824 (let ((b (resolve-syntax-parameters
825 (or (get-global-definition-hook var mod)
826 (make-binding 'global)))))
827 (if (eq? (binding-type b) 'global)
828 (values 'global var mod)
829 (values (binding-type b) (binding-value b) mod))))
830 (define (resolve-lexical label mod)
831 (let ((b (resolve-syntax-parameters
832 (or (assq-ref r label)
833 (make-binding 'displaced-lexical)))))
834 (values (binding-type b) (binding-value b) mod)))
835 (let ((n (id-var-name id w mod)))
838 ;; Recursing allows syntax-parameterize to override
839 ;; macro-introduced syntax parameters.
840 (resolve-identifier n w r mod resolve-syntax-parameters?))
842 (resolve-global n (if (syntax-object? id)
843 (syntax-object-module id)
846 (resolve-lexical n (if (syntax-object? id)
847 (syntax-object-module id)
850 (error "unexpected id-var-name" id w n)))))
852 ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
853 ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
857 (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
858 (mj (and (syntax-object? j) (syntax-object-module j)))
859 (ni (id-var-name i empty-wrap mi))
860 (nj (id-var-name j empty-wrap mj)))
861 (define (id-module-binding id mod)
865 (resolve-module (cdr mod))
866 ;; Either modules have not been booted, or we have a
867 ;; raw symbol coming in, which is possible.
871 ((syntax-object? ni) (free-id=? ni j))
872 ((syntax-object? nj) (free-id=? i nj))
874 ;; `i' is not lexically bound. Assert that `j' is free,
875 ;; and if so, compare their bindings, that they are either
876 ;; bound to the same variable, or both unbound and have
878 (and (eq? nj (id-sym-name j))
879 (let ((bi (id-module-binding i mi)))
881 (eq? bi (id-module-binding j mj))
882 (and (not (id-module-binding j mj))
884 (eq? (id-module-binding i mi) (id-module-binding j mj))))
886 ;; Otherwise `i' is bound, so check that `j' is bound, and
887 ;; bound to the same thing.
890 ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
891 ;; long as the missing portion of the wrap is common to both of the ids
892 ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
896 (if (and (syntax-object? i) (syntax-object? j))
897 (and (eq? (syntax-object-expression i)
898 (syntax-object-expression j))
899 (same-marks? (wrap-marks (syntax-object-wrap i))
900 (wrap-marks (syntax-object-wrap j))))
903 ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
904 ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
905 ;; as long as the missing portion of the wrap is common to all of the
908 (define valid-bound-ids?
910 (and (let all-ids? ((ids ids))
913 (all-ids? (cdr ids)))))
914 (distinct-bound-ids? ids))))
916 ;; distinct-bound-ids? expects a list of ids and returns #t if there are
917 ;; no duplicates. It is quadratic on the length of the id list; long
918 ;; lists could be sorted to make it more efficient. distinct-bound-ids?
919 ;; may be passed unwrapped (or partially wrapped) ids as long as the
920 ;; missing portion of the wrap is common to all of the ids.
922 (define distinct-bound-ids?
924 (let distinct? ((ids ids))
926 (and (not (bound-id-member? (car ids) (cdr ids)))
927 (distinct? (cdr ids)))))))
929 (define bound-id-member?
931 (and (not (null? list))
932 (or (bound-id=? x (car list))
933 (bound-id-member? x (cdr list))))))
935 ;; wrapping expressions and identifiers
940 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
943 (syntax-object-expression x)
944 (join-wraps w (syntax-object-wrap x))
945 (syntax-object-module x)))
947 (else (make-syntax-object x w defmod)))))
950 (lambda (x w s defmod)
951 (wrap (decorate-source x s) w defmod)))
955 (define expand-sequence
956 (lambda (body r w s mod)
958 (let dobody ((body body) (r r) (w w) (mod mod))
961 (let ((first (expand (car body) r w mod)))
962 (cons first (dobody (cdr body) r w mod))))))))
964 ;; At top-level, we allow mixed definitions and expressions. Like
965 ;; expand-body we expand in two passes.
967 ;; First, from left to right, we expand just enough to know what
968 ;; expressions are definitions, syntax definitions, and splicing
969 ;; statements (`begin'). If we anything needs evaluating at
970 ;; expansion-time, it is expanded directly.
972 ;; Otherwise we collect expressions to expand, in thunks, and then
973 ;; expand them all at the end. This allows all syntax expanders
974 ;; visible in a toplevel sequence to be visible during the
975 ;; expansions of all normal definitions and expressions in the
978 (define expand-top-sequence
979 (lambda (body r w s m esew mod)
980 (let* ((r (cons '("placeholder" . (placeholder)) r))
981 (ribcage (make-empty-ribcage))
982 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
983 (define (record-definition! id var)
984 (let ((mod (cons 'hygiene (module-name (current-module)))))
985 ;; Ribcages map symbol+marks to names, mostly for
986 ;; resolving lexicals. Here to add a mapping for toplevel
987 ;; definitions we also need to match the module. So, we
988 ;; put it in the name instead, and make id-var-name handle
989 ;; the special case of names that are pairs. See the
990 ;; comments in id-var-name for more.
991 (extend-ribcage! ribcage id
992 (cons (syntax-object-module id)
993 (wrap var top-wrap mod)))))
994 (define (macro-introduced-identifier? id)
995 (not (equal? (wrap-marks (syntax-object-wrap id)) '(top))))
996 (define (fresh-derived-name id orig-form)
998 (syntax-object-expression id)
1001 ;; FIXME: `hash' currently stops descending into nested
1002 ;; data at some point, so it's less unique than we would
1003 ;; like. Also this encodes hash values into the ABI of
1004 ;; compiled modules; a problem?
1006 (hash (syntax->datum orig-form) most-positive-fixnum)
1008 (define (parse body r w s m esew mod)
1009 (let lp ((body body) (exps '()))
1013 (append (parse1 (car body) r w s m esew mod)
1015 (define (parse1 x r w s m esew mod)
1018 (syntax-type x r w (source-annotation x) ribcage mod #f))
1019 (lambda (type value e w s mod)
1022 (let* ((id (wrap value w mod))
1024 (var (if (macro-introduced-identifier? id)
1025 (fresh-derived-name id x)
1026 (syntax-object-expression id))))
1027 (record-definition! id var)
1030 (let ((x (build-global-definition s var (expand e r w mod))))
1031 (top-level-eval-hook x mod)
1034 (build-global-definition s var (expand e r w mod)))))))
1035 ((define-syntax-form define-syntax-parameter-form)
1036 (let* ((id (wrap value w mod))
1038 (var (if (macro-introduced-identifier? id)
1039 (fresh-derived-name id x)
1040 (syntax-object-expression id))))
1041 (record-definition! id var)
1045 ((memq 'compile esew)
1046 (let ((e (expand-install-global var type (expand e r w mod))))
1047 (top-level-eval-hook e mod)
1048 (if (memq 'load esew)
1049 (list (lambda () e))
1053 (expand-install-global var type (expand e r w mod)))))
1056 (let ((e (expand-install-global var type (expand e r w mod))))
1057 (top-level-eval-hook e mod)
1058 (list (lambda () e))))
1060 (if (memq 'eval esew)
1061 (top-level-eval-hook
1062 (expand-install-global var type (expand e r w mod))
1068 (parse #'(e1 ...) r w s m esew mod))))
1069 ((local-syntax-form)
1070 (expand-local-syntax value e r w s mod
1071 (lambda (forms r w s mod)
1072 (parse forms r w s m esew mod))))
1075 ((_ (x ...) e1 e2 ...)
1076 (let ((when-list (parse-when-list e #'(x ...)))
1077 (body #'(e1 e2 ...)))
1078 (define (recurse m esew)
1079 (parse body r w s m esew mod))
1082 (if (memq 'eval when-list)
1083 (recurse (if (memq 'expand when-list) 'c&e 'e)
1086 (if (memq 'expand when-list)
1087 (top-level-eval-hook
1088 (expand-top-sequence body r w s 'e '(eval) mod)
1091 ((memq 'load when-list)
1092 (if (or (memq 'compile when-list)
1093 (memq 'expand when-list)
1094 (and (eq? m 'c&e) (memq 'eval when-list)))
1095 (recurse 'c&e '(compile load))
1096 (if (memq m '(c c&e))
1097 (recurse 'c '(load))
1099 ((or (memq 'compile when-list)
1100 (memq 'expand when-list)
1101 (and (eq? m 'c&e) (memq 'eval when-list)))
1102 (top-level-eval-hook
1103 (expand-top-sequence body r w s 'e '(eval) mod)
1111 (let ((x (expand-expr type value e r w s mod)))
1112 (top-level-eval-hook x mod)
1115 (expand-expr type value e r w s mod)))))))))
1116 (let ((exps (map (lambda (x) (x))
1117 (reverse (parse body r w s m esew mod)))))
1120 (build-sequence s exps))))))
1122 (define expand-install-global
1123 (lambda (name type e)
1124 (build-global-definition
1129 'make-syntax-transformer
1130 (if (eq? type 'define-syntax-parameter-form)
1131 (list (build-data no-source name)
1132 (build-data no-source 'syntax-parameter)
1133 (build-primcall no-source 'list (list e)))
1134 (list (build-data no-source name)
1135 (build-data no-source 'macro)
1138 (define parse-when-list
1139 (lambda (e when-list)
1140 ;; `when-list' is syntax'd version of list of situations. We
1141 ;; could match these keywords lexically, via free-id=?, but then
1142 ;; we twingle the definition of eval-when to the bindings of
1143 ;; eval, load, expand, and compile, which is totally unintended.
1144 ;; So do a symbolic match instead.
1145 (let ((result (strip when-list empty-wrap)))
1146 (let lp ((l result))
1149 (if (memq (car l) '(compile load eval expand))
1151 (syntax-violation 'eval-when "invalid situation" e
1154 ;; syntax-type returns six values: type, value, e, w, s, and mod. The
1155 ;; first two are described in the table below.
1157 ;; type value explanation
1158 ;; -------------------------------------------------------------------
1159 ;; core procedure core singleton
1160 ;; core-form procedure core form
1161 ;; module-ref procedure @ or @@ singleton
1162 ;; lexical name lexical variable reference
1163 ;; global name global variable reference
1164 ;; begin none begin keyword
1165 ;; define none define keyword
1166 ;; define-syntax none define-syntax keyword
1167 ;; define-syntax-parameter none define-syntax-parameter keyword
1168 ;; local-syntax rec? letrec-syntax/let-syntax keyword
1169 ;; eval-when none eval-when keyword
1170 ;; syntax level pattern variable
1171 ;; displaced-lexical none displaced lexical identifier
1172 ;; lexical-call name call to lexical variable
1173 ;; global-call name call to global variable
1174 ;; call none any other call
1175 ;; begin-form none begin expression
1176 ;; define-form id variable definition
1177 ;; define-syntax-form id syntax definition
1178 ;; define-syntax-parameter-form id syntax parameter definition
1179 ;; local-syntax-form rec? syntax definition
1180 ;; eval-when-form none eval-when form
1181 ;; constant none self-evaluating datum
1182 ;; other none anything else
1184 ;; For definition forms (define-form, define-syntax-parameter-form,
1185 ;; and define-syntax-form), e is the rhs expression. For all
1186 ;; others, e is the entire form. w is the wrap for e. s is the
1187 ;; source for the entire form. mod is the module for e.
1189 ;; syntax-type expands macros and unwraps as necessary to get to one
1190 ;; of the forms above. It also parses definition forms, although
1191 ;; perhaps this should be done by the consumer.
1194 (lambda (e r w s rib mod for-car?)
1197 (call-with-values (lambda () (resolve-identifier e w r mod #t))
1198 (lambda (type value mod*)
1202 (values type value e w s mod)
1203 (syntax-type (expand-macro value e r w s rib mod)
1204 r empty-wrap s rib mod #f)))
1206 ;; Toplevel definitions may resolve to bindings with
1207 ;; different names or in different modules.
1208 (values type value value w s mod*))
1209 (else (values type value e w s mod))))))
1211 (let ((first (car e)))
1213 (lambda () (syntax-type first r w s rib mod #t))
1214 (lambda (ftype fval fe fw fs fmod)
1217 (values 'lexical-call fval e w s mod))
1219 ;; If we got here via an (@@ ...) expansion, we need to
1220 ;; make sure the fmod information is propagated back
1221 ;; correctly -- hence this consing.
1222 (values 'global-call (make-syntax-object fval w fmod)
1225 (syntax-type (expand-macro fval e r w s rib mod)
1226 r empty-wrap s rib mod for-car?))
1228 (call-with-values (lambda () (fval e r w))
1229 (lambda (e r w s mod)
1230 (syntax-type e r w s rib mod for-car?))))
1232 (values 'core-form fval e w s mod))
1234 (values 'local-syntax-form fval e w s mod))
1236 (values 'begin-form #f e w s mod))
1238 (values 'eval-when-form #f e w s mod))
1243 (values 'define-form #'name #'val w s mod))
1244 ((_ (name . args) e1 e2 ...)
1246 (valid-bound-ids? (lambda-var-list #'args)))
1247 ;; need lambda here...
1248 (values 'define-form (wrap #'name w mod)
1250 (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
1255 (values 'define-form (wrap #'name w mod)
1257 empty-wrap s mod))))
1262 (values 'define-syntax-form #'name #'val w s mod))))
1263 ((define-syntax-parameter)
1267 (values 'define-syntax-parameter-form #'name #'val w s mod))))
1269 (values 'call #f e w s mod)))))))
1271 (syntax-type (syntax-object-expression e)
1273 (join-wraps w (syntax-object-wrap e))
1274 (or (source-annotation e) s) rib
1275 (or (syntax-object-module e) mod) for-car?))
1276 ((self-evaluating? e) (values 'constant #f e w s mod))
1277 (else (values 'other #f e w s mod)))))
1282 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
1283 (lambda (type value e w s mod)
1284 (expand-expr type value e r w s mod)))))
1287 (lambda (type value e r w s mod)
1290 (build-lexical-reference 'value s e value))
1292 ;; apply transformer
1293 (value e r w s mod))
1295 (call-with-values (lambda () (value e r w))
1296 (lambda (e r w s mod)
1297 (expand e r w mod))))
1301 (build-lexical-reference 'fun (source-annotation id)
1302 (if (syntax-object? id)
1309 (build-global-reference (source-annotation (car e))
1310 (if (syntax-object? value)
1311 (syntax-object-expression value)
1313 (if (syntax-object? value)
1314 (syntax-object-module value)
1317 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1318 ((global) (build-global-reference s value mod))
1319 ((call) (expand-call (expand (car e) r w mod) e r w s mod))
1322 ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))))
1323 ((local-syntax-form)
1324 (expand-local-syntax value e r w s mod expand-sequence))
1327 ((_ (x ...) e1 e2 ...)
1328 (let ((when-list (parse-when-list e #'(x ...))))
1329 (if (memq 'eval when-list)
1330 (expand-sequence #'(e1 e2 ...) r w s mod)
1332 ((define-form define-syntax-form define-syntax-parameter-form)
1333 (syntax-violation #f "definition in expression context"
1334 e (wrap value w mod)))
1336 (syntax-violation #f "reference to pattern variable outside syntax form"
1337 (source-wrap e w s mod)))
1338 ((displaced-lexical)
1339 (syntax-violation #f "reference to identifier outside its scope"
1340 (source-wrap e w s mod)))
1341 (else (syntax-violation #f "unexpected syntax"
1342 (source-wrap e w s mod))))))
1345 (lambda (x e r w s mod)
1349 (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
1351 ;; (What follows is my interpretation of what's going on here -- Andy)
1353 ;; A macro takes an expression, a tree, the leaves of which are identifiers
1354 ;; and datums. Identifiers are symbols along with a wrap and a module. For
1355 ;; efficiency, subtrees that share wraps and modules may be grouped as one
1358 ;; Going into the expansion, the expression is given an anti-mark, which
1359 ;; logically propagates to all leaves. Then, in the new expression returned
1360 ;; from the transfomer, if we see an expression with an anti-mark, we know it
1361 ;; pertains to the original expression; conversely, expressions without the
1362 ;; anti-mark are known to be introduced by the transformer.
1364 ;; OK, good until now. We know this algorithm does lexical scoping
1365 ;; appropriately because it's widely known in the literature, and psyntax is
1366 ;; widely used. But what about modules? Here we're on our own. What we do is
1367 ;; to mark the module of expressions produced by a macro as pertaining to the
1368 ;; module that was current when the macro was defined -- that is, free
1369 ;; identifiers introduced by a macro are scoped in the macro's module, not in
1370 ;; the expansion's module. Seems to work well.
1372 ;; The only wrinkle is when we want a macro to expand to code in another
1373 ;; module, as is the case for the r6rs `library' form -- the body expressions
1374 ;; should be scoped relative the the new module, the one defined by the macro.
1375 ;; For that, use `(@@ mod-name body)'.
1377 ;; Part of the macro output will be from the site of the macro use and part
1378 ;; from the macro definition. We allow source information from the macro use
1379 ;; to pass through, but we annotate the parts coming from the macro with the
1380 ;; source location information corresponding to the macro use. It would be
1381 ;; really nice if we could also annotate introduced expressions with the
1382 ;; locations corresponding to the macro definition, but that is not yet
1384 (define expand-macro
1385 (lambda (p e r w s rib mod)
1386 (define rebuild-macro-output
1390 (cons (rebuild-macro-output (car x) m)
1391 (rebuild-macro-output (cdr x) m))
1394 (let ((w (syntax-object-wrap x)))
1395 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1396 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1397 ;; output is from original text
1399 (syntax-object-expression x)
1400 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1401 (syntax-object-module x))
1402 ;; output introduced by macro
1404 (decorate-source (syntax-object-expression x) s)
1405 (make-wrap (cons m ms)
1407 (cons rib (cons 'shift s))
1409 (syntax-object-module x))))))
1412 (let* ((n (vector-length x))
1413 (v (decorate-source (make-vector n) x)))
1414 (do ((i 0 (fx+ i 1)))
1417 (rebuild-macro-output (vector-ref x i) m)))))
1419 (syntax-violation #f "encountered raw symbol in macro output"
1420 (source-wrap e w (wrap-subst w) mod) x))
1421 (else (decorate-source x s)))))
1422 (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
1426 ;; In processing the forms of the body, we create a new, empty wrap.
1427 ;; This wrap is augmented (destructively) each time we discover that
1428 ;; the next form is a definition. This is done:
1430 ;; (1) to allow the first nondefinition form to be a call to
1431 ;; one of the defined ids even if the id previously denoted a
1432 ;; definition keyword or keyword for a macro expanding into a
1434 ;; (2) to prevent subsequent definition forms (but unfortunately
1435 ;; not earlier ones) and the first nondefinition form from
1436 ;; confusing one of the bound identifiers for an auxiliary
1438 ;; (3) so that we do not need to restart the expansion of the
1439 ;; first nondefinition form, which is problematic anyway
1440 ;; since it might be the first element of a begin that we
1441 ;; have just spliced into the body (meaning if we restarted,
1442 ;; we'd really need to restart with the begin or the macro
1443 ;; call that expanded into the begin, and we'd have to give
1444 ;; up allowing (begin <defn>+ <expr>+), which is itself
1445 ;; problematic since we don't know if a begin contains only
1446 ;; definitions until we've expanded it).
1448 ;; Before processing the body, we also create a new environment
1449 ;; containing a placeholder for the bindings we will add later and
1450 ;; associate this environment with each form. In processing a
1451 ;; let-syntax or letrec-syntax, the associated environment may be
1452 ;; augmented with local keyword bindings, so the environment may
1453 ;; be different for different forms in the body. Once we have
1454 ;; gathered up all of the definitions, we evaluate the transformer
1455 ;; expressions and splice into r at the placeholder the new variable
1456 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1457 ;; forms local to a portion or all of the body to shadow the
1458 ;; definition bindings.
1460 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1463 ;; outer-form is fully wrapped w/source
1464 (lambda (body outer-form r w mod)
1465 (let* ((r (cons '("placeholder" . (placeholder)) r))
1466 (ribcage (make-empty-ribcage))
1467 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1468 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1469 (ids '()) (labels '())
1470 (var-ids '()) (vars '()) (vals '()) (bindings '()))
1472 (syntax-violation #f "no expressions in body" outer-form)
1473 (let ((e (cdar body)) (er (caar body)))
1475 (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
1476 (lambda (type value e w s mod)
1479 (let ((id (wrap value w mod)) (label (gen-label)))
1480 (let ((var (gen-var id)))
1481 (extend-ribcage! ribcage id label)
1483 (cons id ids) (cons label labels)
1485 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1486 (cons (make-binding 'lexical var) bindings)))))
1487 ((define-syntax-form define-syntax-parameter-form)
1488 (let ((id (wrap value w mod)) (label (gen-label)))
1489 (extend-ribcage! ribcage id label)
1491 (cons id ids) (cons label labels)
1494 (if (eq? type 'define-syntax-parameter-form)
1497 (cons er (wrap e w mod)))
1502 (parse (let f ((forms #'(e1 ...)))
1505 (cons (cons er (wrap (car forms) w mod))
1507 ids labels var-ids vars vals bindings))))
1508 ((local-syntax-form)
1509 (expand-local-syntax value e er w s mod
1510 (lambda (forms er w s mod)
1511 (parse (let f ((forms forms))
1514 (cons (cons er (wrap (car forms) w mod))
1516 ids labels var-ids vars vals bindings))))
1517 (else ; found a non-definition
1519 (build-sequence no-source
1521 (expand (cdr x) (car x) empty-wrap mod))
1522 (cons (cons er (source-wrap e w s mod))
1525 (if (not (valid-bound-ids? ids))
1527 #f "invalid or duplicate identifier in definition"
1529 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1530 (if (not (null? bs))
1531 (let* ((b (car bs)))
1532 (if (memq (car b) '(macro syntax-parameter))
1533 (let* ((er (cadr b))
1535 (if (eq? er er-cache)
1537 (macros-only-env er))))
1539 (eval-local-transformer
1540 (expand (cddr b) r-cache empty-wrap mod)
1542 (if (eq? (car b) 'syntax-parameter)
1543 (set-cdr! b (list (cdr b))))
1544 (loop (cdr bs) er r-cache))
1545 (loop (cdr bs) er-cache r-cache)))))
1546 (set-cdr! r (extend-env labels bindings (cdr r)))
1547 (build-letrec no-source #t
1548 (reverse (map syntax->datum var-ids))
1551 (expand (cdr x) (car x) empty-wrap mod))
1553 (build-sequence no-source
1555 (expand (cdr x) (car x) empty-wrap mod))
1556 (cons (cons er (source-wrap e w s mod))
1557 (cdr body)))))))))))))))))
1559 (define expand-local-syntax
1560 (lambda (rec? e r w s mod k)
1562 ((_ ((id val) ...) e1 e2 ...)
1563 (let ((ids #'(id ...)))
1564 (if (not (valid-bound-ids? ids))
1565 (syntax-violation #f "duplicate bound keyword" e)
1566 (let ((labels (gen-labels ids)))
1567 (let ((new-w (make-binding-wrap ids labels w)))
1571 (let ((w (if rec? new-w w))
1572 (trans-r (macros-only-env r)))
1574 (make-binding 'macro
1575 (eval-local-transformer
1576 (expand x trans-r w mod)
1583 (_ (syntax-violation #f "bad local syntax definition"
1584 (source-wrap e w s mod))))))
1586 (define eval-local-transformer
1587 (lambda (expanded mod)
1588 (let ((p (local-eval-hook expanded mod)))
1591 (syntax-violation #f "nonprocedure transformer" p)))))
1595 (build-void no-source)))
1599 (and (nonsymbol-id? x)
1600 (free-id=? x #'(... ...)))))
1602 (define lambda-formals
1604 (define (req args rreq)
1605 (syntax-case args ()
1607 (check (reverse rreq) #f))
1609 (req #'b (cons #'a rreq)))
1611 (check (reverse rreq) #'r))
1613 (syntax-violation 'lambda "invalid argument list" orig-args args))))
1614 (define (check req rest)
1616 ((distinct-bound-ids? (if rest (cons rest req) req))
1617 (values req #f rest #f))
1619 (syntax-violation 'lambda "duplicate identifier in argument list"
1621 (req orig-args '())))
1623 (define expand-simple-lambda
1624 (lambda (e r w s mod req rest meta body)
1625 (let* ((ids (if rest (append req (list rest)) req))
1626 (vars (map gen-var ids))
1627 (labels (gen-labels ids)))
1628 (build-simple-lambda
1630 (map syntax->datum req) (and rest (syntax->datum rest)) vars
1632 (expand-body body (source-wrap e w s mod)
1633 (extend-var-env labels vars r)
1634 (make-binding-wrap ids labels w)
1637 (define lambda*-formals
1639 (define (req args rreq)
1640 (syntax-case args ()
1642 (check (reverse rreq) '() #f '()))
1644 (req #'b (cons #'a rreq)))
1645 ((a . b) (eq? (syntax->datum #'a) #:optional)
1646 (opt #'b (reverse rreq) '()))
1647 ((a . b) (eq? (syntax->datum #'a) #:key)
1648 (key #'b (reverse rreq) '() '()))
1649 ((a b) (eq? (syntax->datum #'a) #:rest)
1650 (rest #'b (reverse rreq) '() '()))
1652 (rest #'r (reverse rreq) '() '()))
1654 (syntax-violation 'lambda* "invalid argument list" orig-args args))))
1655 (define (opt args req ropt)
1656 (syntax-case args ()
1658 (check req (reverse ropt) #f '()))
1660 (opt #'b req (cons #'(a #f) ropt)))
1661 (((a init) . b) (id? #'a)
1662 (opt #'b req (cons #'(a init) ropt)))
1663 ((a . b) (eq? (syntax->datum #'a) #:key)
1664 (key #'b req (reverse ropt) '()))
1665 ((a b) (eq? (syntax->datum #'a) #:rest)
1666 (rest #'b req (reverse ropt) '()))
1668 (rest #'r req (reverse ropt) '()))
1670 (syntax-violation 'lambda* "invalid optional argument list"
1672 (define (key args req opt rkey)
1673 (syntax-case args ()
1675 (check req opt #f (cons #f (reverse rkey))))
1677 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1678 (key #'b req opt (cons #'(k a #f) rkey))))
1679 (((a init) . b) (id? #'a)
1680 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1681 (key #'b req opt (cons #'(k a init) rkey))))
1682 (((a init k) . b) (and (id? #'a)
1683 (keyword? (syntax->datum #'k)))
1684 (key #'b req opt (cons #'(k a init) rkey)))
1685 ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
1686 (check req opt #f (cons #t (reverse rkey))))
1687 ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1688 (eq? (syntax->datum #'a) #:rest))
1689 (rest #'b req opt (cons #t (reverse rkey))))
1690 ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1692 (rest #'r req opt (cons #t (reverse rkey))))
1693 ((a b) (eq? (syntax->datum #'a) #:rest)
1694 (rest #'b req opt (cons #f (reverse rkey))))
1696 (rest #'r req opt (cons #f (reverse rkey))))
1698 (syntax-violation 'lambda* "invalid keyword argument list"
1700 (define (rest args req opt kw)
1701 (syntax-case args ()
1703 (check req opt #'r kw))
1705 (syntax-violation 'lambda* "invalid rest argument"
1707 (define (check req opt rest kw)
1709 ((distinct-bound-ids?
1710 (append req (map car opt) (if rest (list rest) '())
1711 (if (pair? kw) (map cadr (cdr kw)) '())))
1712 (values req opt rest kw))
1714 (syntax-violation 'lambda* "duplicate identifier in argument list"
1716 (req orig-args '())))
1718 (define expand-lambda-case
1719 (lambda (e r w s mod get-formals clauses)
1720 (define (parse-req req opt rest kw body)
1721 (let ((vars (map gen-var req))
1722 (labels (gen-labels req)))
1723 (let ((r* (extend-var-env labels vars r))
1724 (w* (make-binding-wrap req labels w)))
1725 (parse-opt (map syntax->datum req)
1726 opt rest kw body (reverse vars) r* w* '() '()))))
1727 (define (parse-opt req opt rest kw body vars r* w* out inits)
1730 (syntax-case (car opt) ()
1732 (let* ((v (gen-var #'id))
1733 (l (gen-labels (list v)))
1734 (r** (extend-var-env l (list v) r*))
1735 (w** (make-binding-wrap (list #'id) l w*)))
1736 (parse-opt req (cdr opt) rest kw body (cons v vars)
1737 r** w** (cons (syntax->datum #'id) out)
1738 (cons (expand #'i r* w* mod) inits))))))
1740 (let* ((v (gen-var rest))
1741 (l (gen-labels (list v)))
1742 (r* (extend-var-env l (list v) r*))
1743 (w* (make-binding-wrap (list rest) l w*)))
1744 (parse-kw req (if (pair? out) (reverse out) #f)
1745 (syntax->datum rest)
1746 (if (pair? kw) (cdr kw) kw)
1747 body (cons v vars) r* w*
1748 (if (pair? kw) (car kw) #f)
1751 (parse-kw req (if (pair? out) (reverse out) #f) #f
1752 (if (pair? kw) (cdr kw) kw)
1754 (if (pair? kw) (car kw) #f)
1756 (define (parse-kw req opt rest kw body vars r* w* aok out inits)
1759 (syntax-case (car kw) ()
1761 (let* ((v (gen-var #'id))
1762 (l (gen-labels (list v)))
1763 (r** (extend-var-env l (list v) r*))
1764 (w** (make-binding-wrap (list #'id) l w*)))
1765 (parse-kw req opt rest (cdr kw) body (cons v vars)
1767 (cons (list (syntax->datum #'k)
1768 (syntax->datum #'id)
1771 (cons (expand #'i r* w* mod) inits))))))
1773 (parse-body req opt rest
1774 (if (or aok (pair? out)) (cons aok (reverse out)) #f)
1775 body (reverse vars) r* w* (reverse inits) '()))))
1776 (define (parse-body req opt rest kw body vars r* w* inits meta)
1777 (syntax-case body ()
1778 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1779 (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1782 . ,(syntax->datum #'docstring))))))
1783 ((#((k . v) ...) e1 e2 ...)
1784 (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1785 (append meta (syntax->datum #'((k . v) ...)))))
1787 (values meta req opt rest kw inits vars
1788 (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
1791 (syntax-case clauses ()
1792 (() (values '() #f))
1793 (((args e1 e2 ...) (args* e1* e2* ...) ...)
1794 (call-with-values (lambda () (get-formals #'args))
1795 (lambda (req opt rest kw)
1796 (call-with-values (lambda ()
1797 (parse-req req opt rest kw #'(e1 e2 ...)))
1798 (lambda (meta req opt rest kw inits vars body)
1801 (expand-lambda-case e r w s mod get-formals
1802 #'((args* e1* e2* ...) ...)))
1803 (lambda (meta* else*)
1806 (build-lambda-case s req opt rest kw inits vars
1807 body else*))))))))))))
1811 ;; strips syntax-objects down to top-wrap
1813 ;; since only the head of a list is annotated by the reader, not each pair
1814 ;; in the spine, we also check for pairs whose cars are annotated in case
1815 ;; we've been passed the cdr of an annotated list
1824 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1826 (let ((a (f (car x))) (d (f (cdr x))))
1827 (if (and (eq? a (car x)) (eq? d (cdr x)))
1831 (let ((old (vector->list x)))
1832 (let ((new (map f old)))
1833 ;; inlined and-map with two args
1834 (let lp ((l1 old) (l2 new))
1837 (if (eq? (car l1) (car l2))
1838 (lp (cdr l1) (cdr l2))
1839 (list->vector new)))))))
1842 ;; lexical variables
1846 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1847 (build-lexical-var no-source id))))
1849 ;; appears to return a reversed list
1850 (define lambda-var-list
1852 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1854 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1855 ((id? vars) (cons (wrap vars w #f) ls))
1857 ((syntax-object? vars)
1858 (lvl (syntax-object-expression vars)
1860 (join-wraps w (syntax-object-wrap vars))))
1861 ;; include anything else to be caught by subsequent error
1863 (else (cons vars ls))))))
1865 ;; core transformers
1867 (global-extend 'local-syntax 'letrec-syntax #t)
1868 (global-extend 'local-syntax 'let-syntax #f)
1871 'core 'syntax-parameterize
1872 (lambda (e r w s mod)
1874 ((_ ((var val) ...) e1 e2 ...)
1875 (valid-bound-ids? #'(var ...))
1879 (lambda () (resolve-identifier x w r mod #f))
1880 (lambda (type value mod)
1882 ((displaced-lexical)
1883 (syntax-violation 'syntax-parameterize
1884 "identifier out of context"
1886 (source-wrap x w s mod)))
1890 (syntax-violation 'syntax-parameterize
1891 "invalid syntax parameter"
1893 (source-wrap x w s mod)))))))
1896 (let ((trans-r (macros-only-env r)))
1900 (eval-local-transformer (expand x trans-r w mod) mod)))
1902 (expand-body #'(e1 e2 ...)
1903 (source-wrap e w s mod)
1904 (extend-env names bindings r)
1907 (_ (syntax-violation 'syntax-parameterize "bad syntax"
1908 (source-wrap e w s mod))))))
1910 (global-extend 'core 'quote
1911 (lambda (e r w s mod)
1913 ((_ e) (build-data s (strip #'e w)))
1914 (_ (syntax-violation 'quote "bad syntax"
1915 (source-wrap e w s mod))))))
1921 (lambda (src e r maps ellipsis? mod)
1923 (call-with-values (lambda ()
1924 (resolve-identifier e empty-wrap r mod #f))
1925 (lambda (type value mod)
1929 (lambda () (gen-ref src (car value) (cdr value) maps))
1931 (values `(ref ,var) maps))))
1934 (syntax-violation 'syntax "misplaced ellipsis" src)
1935 (values `(quote ,e) maps))))))
1939 (gen-syntax src #'e r maps (lambda (x) #f) mod))
1941 ;; this could be about a dozen lines of code, except that we
1942 ;; choose to handle #'(x ... ...) forms
1948 (gen-syntax src #'x r
1949 (cons '() maps) ellipsis? mod))
1951 (if (null? (car maps))
1952 (syntax-violation 'syntax "extra ellipsis"
1954 (values (gen-map x (car maps))
1962 (lambda () (k (cons '() maps)))
1964 (if (null? (car maps))
1965 (syntax-violation 'syntax "extra ellipsis" src)
1966 (values (gen-mappend x (car maps))
1968 (_ (call-with-values
1969 (lambda () (gen-syntax src y r maps ellipsis? mod))
1972 (lambda () (k maps))
1974 (values (gen-append x y) maps)))))))))
1977 (lambda () (gen-syntax src #'x r maps ellipsis? mod))
1980 (lambda () (gen-syntax src #'y r maps ellipsis? mod))
1981 (lambda (y maps) (values (gen-cons x y) maps))))))
1985 (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
1986 (lambda (e maps) (values (gen-vector e) maps))))
1987 (_ (values `(quote ,e) maps))))))
1990 (lambda (src var level maps)
1994 (syntax-violation 'syntax "missing ellipsis" src)
1996 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1997 (lambda (outer-var outer-maps)
1998 (let ((b (assq outer-var (car maps))))
2000 (values (cdr b) maps)
2001 (let ((inner-var (gen-var 'tmp)))
2003 (cons (cons (cons outer-var inner-var)
2005 outer-maps)))))))))))
2009 `(apply (primitive append) ,(gen-map e map-env))))
2013 (let ((formals (map cdr map-env))
2014 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
2017 ;; identity map equivalence:
2018 ;; (map (lambda (x) x) y) == y
2021 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
2023 ;; eta map equivalence:
2024 ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
2025 `(map (primitive ,(car e))
2026 ,@(map (let ((r (map cons formals actuals)))
2027 (lambda (x) (cdr (assq (cadr x) r))))
2029 (else `(map (lambda ,formals ,e) ,@actuals))))))
2035 (if (eq? (car x) 'quote)
2036 `(quote (,(cadr x) . ,(cadr y)))
2037 (if (eq? (cadr y) '())
2040 ((list) `(list ,x ,@(cdr y)))
2041 (else `(cons ,x ,y)))))
2045 (if (equal? y '(quote ()))
2052 ((eq? (car x) 'list) `(vector ,@(cdr x)))
2053 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
2054 (else `(list->vector ,x)))))
2060 ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
2061 ((primitive) (build-primref no-source (cadr x)))
2062 ((quote) (build-data no-source (cadr x)))
2064 (if (list? (cadr x))
2065 (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
2066 (error "how did we get here" x)))
2067 (else (build-primcall no-source (car x) (map regen (cdr x)))))))
2069 (lambda (e r w s mod)
2070 (let ((e (source-wrap e w s mod)))
2074 (lambda () (gen-syntax e #'x r '() ellipsis? mod))
2075 (lambda (e maps) (regen e))))
2076 (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
2078 (global-extend 'core 'lambda
2079 (lambda (e r w s mod)
2082 (call-with-values (lambda () (lambda-formals #'args))
2083 (lambda (req opt rest kw)
2084 (let lp ((body #'(e1 e2 ...)) (meta '()))
2085 (syntax-case body ()
2086 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
2090 . ,(syntax->datum #'docstring))))))
2091 ((#((k . v) ...) e1 e2 ...)
2093 (append meta (syntax->datum #'((k . v) ...)))))
2094 (_ (expand-simple-lambda e r w s mod req rest meta body)))))))
2095 (_ (syntax-violation 'lambda "bad lambda" e)))))
2097 (global-extend 'core 'lambda*
2098 (lambda (e r w s mod)
2103 (expand-lambda-case e r w s mod
2104 lambda*-formals #'((args e1 e2 ...))))
2105 (lambda (meta lcase)
2106 (build-case-lambda s meta lcase))))
2107 (_ (syntax-violation 'lambda "bad lambda*" e)))))
2109 (global-extend 'core 'case-lambda
2110 (lambda (e r w s mod)
2112 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
2115 (expand-lambda-case e r w s mod
2117 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2118 (lambda (meta lcase)
2119 (build-case-lambda s meta lcase))))
2120 (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
2122 (global-extend 'core 'case-lambda*
2123 (lambda (e r w s mod)
2125 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
2128 (expand-lambda-case e r w s mod
2130 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2131 (lambda (meta lcase)
2132 (build-case-lambda s meta lcase))))
2133 (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
2135 (global-extend 'core 'let
2137 (define (expand-let e r w s mod constructor ids vals exps)
2138 (if (not (valid-bound-ids? ids))
2139 (syntax-violation 'let "duplicate bound variable" e)
2140 (let ((labels (gen-labels ids))
2141 (new-vars (map gen-var ids)))
2142 (let ((nw (make-binding-wrap ids labels w))
2143 (nr (extend-var-env labels new-vars r)))
2145 (map syntax->datum ids)
2147 (map (lambda (x) (expand x r w mod)) vals)
2148 (expand-body exps (source-wrap e nw s mod)
2150 (lambda (e r w s mod)
2152 ((_ ((id val) ...) e1 e2 ...)
2153 (and-map id? #'(id ...))
2154 (expand-let e r w s mod
2159 ((_ f ((id val) ...) e1 e2 ...)
2160 (and (id? #'f) (and-map id? #'(id ...)))
2161 (expand-let e r w s mod
2166 (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
2169 (global-extend 'core 'letrec
2170 (lambda (e r w s mod)
2172 ((_ ((id val) ...) e1 e2 ...)
2173 (and-map id? #'(id ...))
2174 (let ((ids #'(id ...)))
2175 (if (not (valid-bound-ids? ids))
2176 (syntax-violation 'letrec "duplicate bound variable" e)
2177 (let ((labels (gen-labels ids))
2178 (new-vars (map gen-var ids)))
2179 (let ((w (make-binding-wrap ids labels w))
2180 (r (extend-var-env labels new-vars r)))
2182 (map syntax->datum ids)
2184 (map (lambda (x) (expand x r w mod)) #'(val ...))
2185 (expand-body #'(e1 e2 ...)
2186 (source-wrap e w s mod) r w mod)))))))
2187 (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
2190 (global-extend 'core 'letrec*
2191 (lambda (e r w s mod)
2193 ((_ ((id val) ...) e1 e2 ...)
2194 (and-map id? #'(id ...))
2195 (let ((ids #'(id ...)))
2196 (if (not (valid-bound-ids? ids))
2197 (syntax-violation 'letrec* "duplicate bound variable" e)
2198 (let ((labels (gen-labels ids))
2199 (new-vars (map gen-var ids)))
2200 (let ((w (make-binding-wrap ids labels w))
2201 (r (extend-var-env labels new-vars r)))
2203 (map syntax->datum ids)
2205 (map (lambda (x) (expand x r w mod)) #'(val ...))
2206 (expand-body #'(e1 e2 ...)
2207 (source-wrap e w s mod) r w mod)))))))
2208 (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
2213 (lambda (e r w s mod)
2218 (lambda () (resolve-identifier #'id w r mod #t))
2219 (lambda (type value id-mod)
2222 (build-lexical-assignment s (syntax->datum #'id) value
2223 (expand #'val r w mod)))
2225 (build-global-assignment s value (expand #'val r w mod) id-mod))
2227 (if (procedure-property value 'variable-transformer)
2228 ;; As syntax-type does, call expand-macro with
2229 ;; the mod of the expression. Hmm.
2230 (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
2231 (syntax-violation 'set! "not a variable transformer"
2233 (wrap #'id w id-mod))))
2234 ((displaced-lexical)
2235 (syntax-violation 'set! "identifier out of context"
2238 (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
2239 ((_ (head tail ...) val)
2241 (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
2242 (lambda (type value ee ww ss modmod)
2245 (let ((val (expand #'val r w mod)))
2246 (call-with-values (lambda () (value #'(head tail ...) r w))
2247 (lambda (e r w s* mod)
2250 (build-global-assignment s (syntax->datum #'e)
2254 (expand #'(setter head) r w mod)
2255 (map (lambda (e) (expand e r w mod))
2256 #'(tail ... val))))))))
2257 (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
2259 (global-extend 'module-ref '@
2263 (and (and-map id? #'(mod ...)) (id? #'id))
2264 (values (syntax->datum #'id) r w #f
2266 #'(public mod ...)))))))
2268 (global-extend 'module-ref '@@
2273 (cons (remodulate (car x) mod)
2274 (remodulate (cdr x) mod)))
2277 (remodulate (syntax-object-expression x) mod)
2278 (syntax-object-wrap x)
2279 ;; hither the remodulation
2282 (let* ((n (vector-length x)) (v (make-vector n)))
2283 (do ((i 0 (fx+ i 1)))
2285 (vector-set! v i (remodulate (vector-ref x i) mod)))))
2289 (and-map id? #'(mod ...))
2290 (let ((mod (syntax->datum #'(private mod ...))))
2291 (values (remodulate #'exp mod)
2292 r w (source-annotation #'exp)
2295 (global-extend 'core 'if
2296 (lambda (e r w s mod)
2301 (expand #'test r w mod)
2302 (expand #'then r w mod)
2303 (build-void no-source)))
2307 (expand #'test r w mod)
2308 (expand #'then r w mod)
2309 (expand #'else r w mod))))))
2311 (global-extend 'core 'with-fluids
2312 (lambda (e r w s mod)
2314 ((_ ((fluid val) ...) b b* ...)
2317 (map (lambda (x) (expand x r w mod)) #'(fluid ...))
2318 (map (lambda (x) (expand x r w mod)) #'(val ...))
2319 (expand-body #'(b b* ...)
2320 (source-wrap e w s mod) r w mod))))))
2322 (global-extend 'begin 'begin '())
2324 (global-extend 'define 'define '())
2326 (global-extend 'define-syntax 'define-syntax '())
2327 (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
2329 (global-extend 'eval-when 'eval-when '())
2331 (global-extend 'core 'syntax-case
2333 (define convert-pattern
2334 ;; accepts pattern & keys
2335 ;; returns $sc-dispatch pattern & ids
2336 (lambda (pattern keys)
2339 (if (not (pair? p*))
2342 (lambda () (cvt* (cdr p*) n ids))
2345 (lambda () (cvt (car p*) n ids))
2347 (values (cons x y) ids))))))))
2349 (define (v-reverse x)
2350 (let loop ((r '()) (x x))
2353 (loop (cons (car x) r) (cdr x)))))
2359 ((bound-id-member? p keys)
2360 (values (vector 'free-id p) ids))
2364 (values 'any (cons (cons p n) ids))))
2367 (ellipsis? (syntax dots))
2369 (lambda () (cvt (syntax x) (fx+ n 1) ids))
2371 (values (if (eq? p 'any) 'each-any (vector 'each p))
2374 (ellipsis? (syntax dots))
2376 (lambda () (cvt* (syntax ys) n ids))
2379 (lambda () (cvt (syntax x) (+ n 1) ids))
2382 (lambda () (v-reverse ys))
2384 (values `#(each+ ,x ,ys ,e)
2388 (lambda () (cvt (syntax y) n ids))
2391 (lambda () (cvt (syntax x) n ids))
2393 (values (cons x y) ids))))))
2394 (() (values '() ids))
2397 (lambda () (cvt (syntax (x ...)) n ids))
2398 (lambda (p ids) (values (vector 'vector p) ids))))
2399 (x (values (vector 'atom (strip p empty-wrap)) ids))))))
2400 (cvt pattern 0 '())))
2402 (define build-dispatch-call
2403 (lambda (pvars exp y r mod)
2404 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2405 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2409 (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
2413 (map (lambda (var level)
2414 (make-binding 'syntax `(,var . ,level)))
2418 (make-binding-wrap ids labels empty-wrap)
2423 (lambda (x keys clauses r pat fender exp mod)
2425 (lambda () (convert-pattern pat keys))
2428 ((not (distinct-bound-ids? (map car pvars)))
2429 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2430 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2431 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2433 (let ((y (gen-var 'tmp)))
2434 ;; fat finger binding and references to temp variable y
2435 (build-call no-source
2436 (build-simple-lambda no-source (list 'tmp) #f (list y) '()
2437 (let ((y (build-lexical-reference 'value no-source
2439 (build-conditional no-source
2440 (syntax-case fender ()
2442 (_ (build-conditional no-source
2444 (build-dispatch-call pvars fender y r mod)
2445 (build-data no-source #f))))
2446 (build-dispatch-call pvars exp y r mod)
2447 (gen-syntax-case x keys clauses r mod))))
2448 (list (if (eq? p 'any)
2449 (build-primcall no-source 'list (list x))
2450 (build-primcall no-source '$sc-dispatch
2451 (list x (build-data no-source p)))))))))))))
2453 (define gen-syntax-case
2454 (lambda (x keys clauses r mod)
2456 (build-primcall no-source 'syntax-violation
2457 (list (build-data no-source #f)
2458 (build-data no-source
2459 "source expression failed to match any pattern")
2461 (syntax-case (car clauses) ()
2463 (if (and (id? #'pat)
2464 (and-map (lambda (x) (not (free-id=? #'pat x)))
2465 (cons #'(... ...) keys)))
2466 (if (free-id=? #'pad #'_)
2467 (expand #'exp r empty-wrap mod)
2468 (let ((labels (list (gen-label)))
2469 (var (gen-var #'pat)))
2470 (build-call no-source
2471 (build-simple-lambda
2472 no-source (list (syntax->datum #'pat)) #f (list var)
2476 (list (make-binding 'syntax `(,var . 0)))
2478 (make-binding-wrap #'(pat)
2482 (gen-clause x keys (cdr clauses) r
2483 #'pat #t #'exp mod)))
2485 (gen-clause x keys (cdr clauses) r
2486 #'pat #'fender #'exp mod))
2487 (_ (syntax-violation 'syntax-case "invalid clause"
2490 (lambda (e r w s mod)
2491 (let ((e (source-wrap e w s mod)))
2493 ((_ val (key ...) m ...)
2494 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
2496 (let ((x (gen-var 'tmp)))
2497 ;; fat finger binding and references to temp variable x
2499 (build-simple-lambda no-source (list 'tmp) #f (list x) '()
2500 (gen-syntax-case (build-lexical-reference 'value no-source
2502 #'(key ...) #'(m ...)
2505 (list (expand #'val r empty-wrap mod))))
2506 (syntax-violation 'syntax-case "invalid literals list" e))))))))
2508 ;; The portable macroexpand seeds expand-top's mode m with 'e (for
2509 ;; evaluating) and esew (which stands for "eval syntax expanders
2510 ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
2511 ;; if we are compiling a file, and esew is set to
2512 ;; (eval-syntactic-expanders-when), which defaults to the list
2513 ;; '(compile load eval). This means that, by default, top-level
2514 ;; syntactic definitions are evaluated immediately after they are
2515 ;; expanded, and the expanded definitions are also residualized into
2516 ;; the object file if we are compiling a file.
2518 (lambda* (x #:optional (m 'e) (esew '(eval)))
2519 (expand-top-sequence (list x) null-env top-wrap #f m esew
2520 (cons 'hygiene (module-name (current-module))))))
2528 (make-syntax-object datum (syntax-object-wrap id)
2529 (syntax-object-module id))))
2532 ;; accepts any object, since syntax objects may consist partially
2533 ;; or entirely of unwrapped, nonsymbolic data
2535 (strip x empty-wrap)))
2538 (lambda (x) (source-annotation x)))
2540 (set! generate-temporaries
2542 (arg-check list? ls 'generate-temporaries)
2543 (let ((mod (cons 'hygiene (module-name (current-module)))))
2544 (map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
2546 (set! free-identifier=?
2548 (arg-check nonsymbol-id? x 'free-identifier=?)
2549 (arg-check nonsymbol-id? y 'free-identifier=?)
2552 (set! bound-identifier=?
2554 (arg-check nonsymbol-id? x 'bound-identifier=?)
2555 (arg-check nonsymbol-id? y 'bound-identifier=?)
2558 (set! syntax-violation
2559 (lambda* (who message form #:optional subform)
2560 (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2561 who 'syntax-violation)
2562 (arg-check string? message 'syntax-violation)
2563 (throw 'syntax-error who message
2564 (source-annotation (or form subform))
2565 (strip form empty-wrap)
2566 (and subform (strip subform empty-wrap)))))
2568 ;; $sc-dispatch expects an expression and a pattern. If the expression
2569 ;; matches the pattern a list of the matching expressions for each
2570 ;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2571 ;; not work on r4rs implementations that violate the ieee requirement
2572 ;; that #f and () be distinct.)
2574 ;; The expression is matched with the pattern as follows:
2576 ;; pattern: matches:
2579 ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2581 ;; #(free-id <key>) <key> with free-identifier=?
2582 ;; #(each <pattern>) (<pattern>*)
2583 ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
2584 ;; #(vector <pattern>) (list->vector <pattern>)
2585 ;; #(atom <object>) <object> with "equal?"
2587 ;; Vector cops out to pair under assumption that vectors are rare. If
2588 ;; not, should convert to:
2589 ;; #(vector <pattern>*) #(<pattern>*)
2597 (let ((first (match (car e) p w '() mod)))
2599 (let ((rest (match-each (cdr e) p w mod)))
2600 (and rest (cons first rest))))))
2603 (match-each (syntax-object-expression e)
2605 (join-wraps w (syntax-object-wrap e))
2606 (syntax-object-module e)))
2610 (lambda (e x-pat y-pat z-pat w r mod)
2611 (let f ((e e) (w w))
2614 (call-with-values (lambda () (f (cdr e) w))
2615 (lambda (xr* y-pat r)
2618 (let ((xr (match (car e) x-pat w '() mod)))
2620 (values (cons xr xr*) y-pat r)
2625 (match (car e) (car y-pat) w r mod)))
2626 (values #f #f #f)))))
2628 (f (syntax-object-expression e) (join-wraps w e)))
2630 (values '() y-pat (match e z-pat w r mod)))))))
2632 (define match-each-any
2636 (let ((l (match-each-any (cdr e) w mod)))
2637 (and l (cons (wrap (car e) w mod) l))))
2640 (match-each-any (syntax-object-expression e)
2641 (join-wraps w (syntax-object-wrap e))
2650 ((eq? p 'any) (cons '() r))
2651 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2652 ((eq? p 'each-any) (cons '() r))
2654 (case (vector-ref p 0)
2655 ((each) (match-empty (vector-ref p 1) r))
2656 ((each+) (match-empty (vector-ref p 1)
2658 (reverse (vector-ref p 2))
2659 (match-empty (vector-ref p 3) r))))
2661 ((vector) (match-empty (vector-ref p 1) r)))))))
2665 (if (null? (car r*))
2667 (cons (map car r*) (combine (map cdr r*) r)))))
2670 (lambda (e p w r mod)
2672 ((null? p) (and (null? e) r))
2674 (and (pair? e) (match (car e) (car p) w
2675 (match (cdr e) (cdr p) w r mod)
2678 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2680 (case (vector-ref p 0)
2683 (match-empty (vector-ref p 1) r)
2684 (let ((l (match-each e (vector-ref p 1) w mod)))
2686 (let collect ((l l))
2689 (cons (map car l) (collect (map cdr l)))))))))
2693 (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
2694 (lambda (xr* y-pat r)
2698 (match-empty (vector-ref p 1) r)
2699 (combine xr* r))))))
2700 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2701 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2704 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2707 (lambda (e p w r mod)
2711 ((eq? p 'any) (cons (wrap e w mod) r))
2714 (syntax-object-expression e)
2716 (join-wraps w (syntax-object-wrap e))
2718 (syntax-object-module e)))
2719 (else (match* e p w r mod)))))
2724 ((eq? p 'any) (list e))
2727 (match* (syntax-object-expression e)
2728 p (syntax-object-wrap e) '() (syntax-object-module e)))
2729 (else (match* e p empty-wrap '() #f))))))))
2732 (define-syntax with-syntax
2736 #'(let () e1 e2 ...))
2737 ((_ ((out in)) e1 e2 ...)
2738 #'(syntax-case in ()
2739 (out (let () e1 e2 ...))))
2740 ((_ ((out in) ...) e1 e2 ...)
2741 #'(syntax-case (list in ...) ()
2742 ((out ...) (let () e1 e2 ...)))))))
2744 (define-syntax syntax-rules
2747 ((_ (k ...) ((keyword . pattern) template) ...)
2749 ;; embed patterns as procedure metadata
2750 #((macro-type . syntax-rules)
2751 (patterns pattern ...))
2752 (syntax-case x (k ...)
2753 ((_ . pattern) #'template)
2755 ((_ (k ...) docstring ((keyword . pattern) template) ...)
2756 (string? (syntax->datum #'docstring))
2758 ;; the same, but allow a docstring
2760 #((macro-type . syntax-rules)
2761 (patterns pattern ...))
2762 (syntax-case x (k ...)
2763 ((_ . pattern) #'template)
2766 (define-syntax define-syntax-rule
2769 ((_ (name . pattern) template)
2770 #'(define-syntax name
2772 ((_ . pattern) template))))
2773 ((_ (name . pattern) docstring template)
2774 (string? (syntax->datum #'docstring))
2775 #'(define-syntax name
2778 ((_ . pattern) template)))))))
2783 ((let* ((x v) ...) e1 e2 ...)
2784 (and-map identifier? #'(x ...))
2785 (let f ((bindings #'((x v) ...)))
2786 (if (null? bindings)
2787 #'(let () e1 e2 ...)
2788 (with-syntax ((body (f (cdr bindings)))
2789 (binding (car bindings)))
2790 #'(let (binding) body))))))))
2794 (syntax-case orig-x ()
2795 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2796 (with-syntax (((step ...)
2801 (_ (syntax-violation
2802 'do "bad step expression"
2806 (syntax-case #'(e1 ...) ()
2807 (() #'(let doloop ((var init) ...)
2809 (begin c ... (doloop step ...)))))
2811 #'(let doloop ((var init) ...)
2814 (begin c ... (doloop step ...)))))))))))
2816 (define-syntax quasiquote
2818 (define (quasi p lev)
2819 (syntax-case p (unquote quasiquote)
2823 (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
2824 ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
2826 (syntax-case #'p (unquote unquote-splicing)
2829 (quasilist* #'(("value" p) ...) (quasi #'q lev))
2831 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2833 ((unquote-splicing p ...)
2835 (quasiappend #'(("value" p) ...) (quasi #'q lev))
2837 (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
2839 (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
2840 (#(x ...) (quasivector (vquasi #'(x ...) lev)))
2842 (define (vquasi p lev)
2845 (syntax-case #'p (unquote unquote-splicing)
2848 (quasilist* #'(("value" p) ...) (vquasi #'q lev))
2850 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2852 ((unquote-splicing p ...)
2854 (quasiappend #'(("value" p) ...) (vquasi #'q lev))
2857 #'("quote" unquote-splicing)
2858 (quasi #'(p ...) (- lev 1)))
2860 (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
2861 (() #'("quote" ()))))
2862 (define (quasicons x y)
2863 (with-syntax ((x x) (y y))
2867 (("quote" dx) #'("quote" (dx . dy)))
2868 (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
2869 (("list" . stuff) #'("list" x . stuff))
2870 (("list*" . stuff) #'("list*" x . stuff))
2871 (_ #'("list*" x y)))))
2872 (define (quasiappend x y)
2876 ((null? x) #'("quote" ()))
2877 ((null? (cdr x)) (car x))
2878 (else (with-syntax (((p ...) x)) #'("append" p ...)))))
2882 (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
2883 (define (quasilist* x y)
2887 (quasicons (car x) (f (cdr x))))))
2888 (define (quasivector x)
2890 (("quote" (x ...)) #'("quote" #(x ...)))
2892 (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
2894 (("quote" (y ...)) (k #'(("quote" y) ...)))
2895 (("list" y ...) (k #'(y ...)))
2896 (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
2897 (else #`("list->vector" #,x)))))))
2901 (("list" x ...) #`(list #,@(map emit #'(x ...))))
2902 ;; could emit list* for 3+ arguments if implementation supports
2905 (let f ((x* #'(x ...)))
2908 #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
2909 (("append" x ...) #`(append #,@(map emit #'(x ...))))
2910 (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
2911 (("list->vector" x) #`(list->vector #,(emit #'x)))
2915 ;; convert to intermediate language, combining introduced (but
2916 ;; not unquoted source) quote expressions where possible and
2917 ;; choosing optimal construction code otherwise, then emit
2918 ;; Scheme code corresponding to the intermediate language forms.
2919 ((_ e) (emit (quasi #'e 0)))))))
2921 (define-syntax include
2925 (let ((p (open-input-file fn)))
2926 (let f ((x (read p))
2930 (close-input-port p)
2933 (cons (datum->syntax k x) result)))))))
2936 (let ((fn (syntax->datum #'filename)))
2937 (with-syntax (((exp ...) (read-file fn #'filename)))
2938 #'(begin exp ...)))))))
2940 (define-syntax include-from-path
2944 (let ((fn (syntax->datum #'filename)))
2945 (with-syntax ((fn (datum->syntax
2947 (or (%search-load-path fn)
2948 (syntax-violation 'include-from-path
2949 "file not found in path"
2951 #'(include fn)))))))
2953 (define-syntax unquote
2955 (syntax-violation 'unquote
2956 "expression not valid outside of quasiquote"
2959 (define-syntax unquote-splicing
2961 (syntax-violation 'unquote-splicing
2962 "expression not valid outside of quasiquote"
2970 ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
2972 (syntax-case clause (else)
2973 ((else e1 e2 ...) #'(begin e1 e2 ...))
2974 (((k ...) e1 e2 ...)
2975 #'(if (memv t '(k ...)) (begin e1 e2 ...)))
2976 (_ (syntax-violation 'case "bad clause" x clause)))
2977 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2978 (syntax-case clause (else)
2979 (((k ...) e1 e2 ...)
2980 #'(if (memv t '(k ...))
2983 (_ (syntax-violation 'case "bad clause" x
2985 #'(let ((t e)) body))))))
2987 (define (make-variable-transformer proc)
2988 (if (procedure? proc)
2989 (let ((trans (lambda (x)
2990 #((macro-type . variable-transformer))
2992 (set-procedure-property! trans 'variable-transformer #t)
2994 (error "variable transformer not a procedure" proc)))
2996 (define-syntax identifier-syntax
2998 (syntax-case x (set!)
3001 #((macro-type . identifier-syntax))
3007 #'(e x (... ...))))))
3008 ((_ (id exp1) ((set! var val) exp2))
3009 (and (identifier? #'id) (identifier? #'var))
3010 #'(make-variable-transformer
3012 #((macro-type . variable-transformer))
3013 (syntax-case x (set!)
3014 ((set! var val) #'exp2)
3015 ((id x (... ...)) #'(exp1 x (... ...)))
3016 (id (identifier? #'id) #'exp1))))))))
3018 (define-syntax define*
3021 ((_ (id . args) b0 b1 ...)
3022 #'(define id (lambda* args b0 b1 ...)))
3023 ((_ id val) (identifier? #'x)
3024 #'(define id val)))))