3 ;;;; Copyright (C) 2001, 2003, 2006 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 2.1 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 ;;; Extracted from Chez Scheme Version 5.9f
23 ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
25 ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
26 ;;; to the ChangeLog distributed in the same directory as this file:
27 ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
28 ;;; 2000-09-12, 2001-03-08
30 ;;; Copyright (c) 1992-1997 Cadence Research Systems
31 ;;; Permission to copy this software, in whole or in part, to use this
32 ;;; software for any lawful purpose, and to redistribute this software
33 ;;; is granted subject to the restriction that all copies made of this
34 ;;; software must include this copyright notice in full. This software
35 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
36 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
37 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
38 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
39 ;;; NATURE WHATSOEVER.
41 ;;; Before attempting to port this code to a new implementation of
42 ;;; Scheme, please read the notes below carefully.
45 ;;; This file defines the syntax-case expander, sc-expand, and a set
46 ;;; of associated syntactic forms and procedures. Of these, the
47 ;;; following are documented in The Scheme Programming Language,
48 ;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). Most are
49 ;;; also documented in the R4RS and draft R5RS.
51 ;;; bound-identifier=?
52 ;;; datum->syntax-object
56 ;;; generate-temporaries
63 ;;; syntax-object->datum
67 ;;; All standard Scheme syntactic forms are supported by the expander
68 ;;; or syntactic abstractions defined in this file. Only the R4RS
69 ;;; delay is omitted, since its expansion is implementation-dependent.
71 ;;; The remaining exports are listed below:
74 ;;; if datum represents a valid expression, sc-expand returns an
75 ;;; expanded version of datum in a core language that includes no
76 ;;; syntactic abstractions. The core language includes begin,
77 ;;; define, if, lambda, letrec, quote, and set!.
78 ;;; (eval-when situations expr ...)
79 ;;; conditionally evaluates expr ... at compile-time or run-time
80 ;;; depending upon situations (see the Chez Scheme System Manual,
81 ;;; Revision 3, for a complete description)
82 ;;; (syntax-error object message)
83 ;;; used to report errors found during expansion
84 ;;; (install-global-transformer symbol value)
85 ;;; used by expanded code to install top-level syntactic abstractions
86 ;;; (syntax-dispatch e p)
87 ;;; used by expanded code to handle syntax-case matching
89 ;;; The following nonstandard procedures must be provided by the
90 ;;; implementation for this code to run.
93 ;;; returns the implementation's cannonical "unspecified value". This
94 ;;; usually works: (define void (lambda () (if #f #f))).
96 ;;; (andmap proc list1 list2 ...)
97 ;;; returns true if proc returns true when applied to each element of list1
98 ;;; along with the corresponding elements of list2 ....
99 ;;; The following definition works but does no error checking:
102 ;;; (lambda (f first . rest)
103 ;;; (or (null? first)
105 ;;; (let andmap ((first first))
106 ;;; (let ((x (car first)) (first (cdr first)))
107 ;;; (if (null? first)
109 ;;; (and (f x) (andmap first)))))
110 ;;; (let andmap ((first first) (rest rest))
111 ;;; (let ((x (car first))
112 ;;; (xr (map car rest))
113 ;;; (first (cdr first))
114 ;;; (rest (map cdr rest)))
115 ;;; (if (null? first)
116 ;;; (apply f (cons x xr))
117 ;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
119 ;;; The following nonstandard procedures must also be provided by the
120 ;;; implementation for this code to run using the standard portable
121 ;;; hooks and output constructors. They are not used by expanded code,
122 ;;; and so need be present only at expansion time.
125 ;;; where x is always in the form ("noexpand" expr).
126 ;;; returns the value of expr. the "noexpand" flag is used to tell the
127 ;;; evaluator/expander that no expansion is necessary, since expr has
128 ;;; already been fully expanded to core forms.
130 ;;; eval will not be invoked during the loading of psyntax.pp. After
131 ;;; psyntax.pp has been loaded, the expansion of any macro definition,
132 ;;; whether local or global, will result in a call to eval. If, however,
133 ;;; sc-expand has already been registered as the expander to be used
134 ;;; by eval, and eval accepts one argument, nothing special must be done
135 ;;; to support the "noexpand" flag, since it is handled by sc-expand.
137 ;;; (error who format-string why what)
138 ;;; where who is either a symbol or #f, format-string is always "~a ~s",
139 ;;; why is always a string, and what may be any object. error should
140 ;;; signal an error with a message something like
142 ;;; "error in <who>: <why> <what>"
145 ;;; returns a unique symbol each time it's called
147 ;;; (putprop symbol key value)
148 ;;; (getprop symbol key)
149 ;;; key is always the symbol *sc-expander*; value may be any object.
150 ;;; putprop should associate the given value with the given symbol in
151 ;;; some way that it can be retrieved later with getprop.
153 ;;; When porting to a new Scheme implementation, you should define the
154 ;;; procedures listed above, load the expanded version of psyntax.ss
155 ;;; (psyntax.pp, which should be available whereever you found
156 ;;; psyntax.ss), and register sc-expand as the current expander (how
157 ;;; you do this depends upon your implementation of Scheme). You may
158 ;;; change the hooks and constructors defined toward the beginning of
159 ;;; the code below, but to avoid bootstrapping problems, do so only
160 ;;; after you have a working version of the expander.
162 ;;; Chez Scheme allows the syntactic form (syntax <template>) to be
163 ;;; abbreviated to #'<template>, just as (quote <datum>) may be
164 ;;; abbreviated to '<datum>. The #' syntax makes programs written
165 ;;; using syntax-case shorter and more readable and draws out the
166 ;;; intuitive connection between syntax and quote.
168 ;;; If you find that this code loads or runs slowly, consider
169 ;;; switching to faster hardware or a faster implementation of
170 ;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
171 ;;; compiling (with full optimization), and loading this file takes
172 ;;; between one and two seconds.
174 ;;; In the expander implementation, we sometimes use syntactic abstractions
175 ;;; when procedural abstractions would suffice. For example, we define
176 ;;; top-wrap and top-marked? as
177 ;;; (define-syntax top-wrap (identifier-syntax '((top))))
178 ;;; (define-syntax top-marked?
180 ;;; ((_ w) (memq 'top (wrap-marks w)))))
182 ;;; (define top-wrap '((top)))
183 ;;; (define top-marked?
184 ;;; (lambda (w) (memq 'top (wrap-marks w))))
185 ;;; On ther other hand, we don't do this consistently; we define make-wrap,
186 ;;; wrap-marks, and wrap-subst simply as
187 ;;; (define make-wrap cons)
188 ;;; (define wrap-marks car)
189 ;;; (define wrap-subst cdr)
190 ;;; In Chez Scheme, the syntactic and procedural forms of these
191 ;;; abstractions are equivalent, since the optimizer consistently
192 ;;; integrates constants and small procedures. Some Scheme
193 ;;; implementations, however, may benefit from more consistent use
194 ;;; of one form or the other.
197 ;;; implementation information:
199 ;;; "begin" is treated as a splicing construct at top level and at
200 ;;; the beginning of bodies. Any sequence of expressions that would
201 ;;; be allowed where the "begin" occurs is allowed.
203 ;;; "let-syntax" and "letrec-syntax" are also treated as splicing
204 ;;; constructs, in violation of the R4RS appendix and probably the R5RS
205 ;;; when it comes out. A consequence, let-syntax and letrec-syntax do
206 ;;; not create local contours, as do let and letrec. Although the
207 ;;; functionality is greater as it is presently implemented, we will
208 ;;; probably change it to conform to the R4RS/expected R5RS.
210 ;;; Objects with no standard print syntax, including objects containing
211 ;;; cycles and syntax object, are allowed in quoted data as long as they
212 ;;; are contained within a syntax form or produced by datum->syntax-object.
213 ;;; Such objects are never copied.
215 ;;; All identifiers that don't have macro definitions and are not bound
216 ;;; lexically are assumed to be global variables
218 ;;; Top-level definitions of macro-introduced identifiers are allowed.
219 ;;; This may not be appropriate for implementations in which the
220 ;;; model is that bindings are created by definitions, as opposed to
221 ;;; one in which initial values are assigned by definitions.
223 ;;; Top-level variable definitions of syntax keywords is not permitted.
224 ;;; Any solution allowing this would be kludgey and would yield
225 ;;; surprising results in some cases. We can provide an undefine-syntax
226 ;;; form. The questions is, should define be an implicit undefine-syntax?
227 ;;; We've decided no for now.
229 ;;; Identifiers and syntax objects are implemented as vectors for
230 ;;; portability. As a result, it is possible to "forge" syntax
233 ;;; The implementation of generate-temporaries assumes that it is possible
234 ;;; to generate globally unique symbols (gensyms).
236 ;;; The input to sc-expand may contain "annotations" describing, e.g., the
237 ;;; source file and character position from where each object was read if
238 ;;; it was read from a file. These annotations are handled properly by
239 ;;; sc-expand only if the annotation? hook (see hooks below) is implemented
240 ;;; properly and the operators make-annotation, annotation-expression,
241 ;;; annotation-source, annotation-stripped, and set-annotation-stripped!
242 ;;; are supplied. If annotations are supplied, the proper annotation
243 ;;; source is passed to the various output constructors, allowing
244 ;;; implementations to accurately correlate source and expanded code.
245 ;;; Contact one of the authors for details if you wish to make use of
252 ;;; When changing syntax-object representations, it is necessary to support
253 ;;; both old and new syntax-object representations in id-var-name. It
254 ;;; should be sufficient to recognize old representations and treat
255 ;;; them as not lexically bound.
260 (define-syntax define-structure
262 (define construct-name
263 (lambda (template-identifier . args)
264 (datum->syntax-object
271 (symbol->string (syntax-object->datum x))))
275 (andmap identifier? (syntax (name id1 ...)))
277 ((constructor (construct-name (syntax name) "make-" (syntax name)))
278 (predicate (construct-name (syntax name) (syntax name) "?"))
280 (map (lambda (x) (construct-name x (syntax name) "-" x))
284 (construct-name x "set-" (syntax name) "-" x "!"))
287 (+ (length (syntax (id1 ...))) 1))
289 (let f ((i 1) (ids (syntax (id1 ...))))
292 (cons i (f (+ i 1) (cdr ids)))))))
296 (vector 'name id1 ... )))
300 (= (vector-length x) structure-length)
301 (eq? (vector-ref x 0) 'name))))
304 (vector-ref x index)))
308 (vector-set! x index update)))
312 (define noexpand "noexpand")
314 ;;; hooks to nonportable run-time helpers
321 (define top-level-eval-hook
323 (eval `(,noexpand ,x) (if mod (resolve-module mod)
324 (interaction-environment)))))
326 (define local-eval-hook
328 (eval `(,noexpand ,x) (if mod (resolve-module mod)
329 (interaction-environment)))))
332 (lambda (who why what)
333 (error who "~a ~s" why what)))
335 (define-syntax gensym-hook
339 (define put-global-definition-hook
340 (lambda (symbol binding modname)
341 (let* ((module (if modname
342 (resolve-module modname)
344 (v (or (module-variable module symbol)
345 (let ((v (make-variable 'sc-macro)))
346 (module-add! module symbol v)
348 (if (not (variable-bound? v))
349 (variable-set! v (gensym)))
350 ;; Properties are tied to variable objects
351 (set-object-property! v '*sc-expander* binding))))
353 (define remove-global-definition-hook
354 (lambda (symbol modname)
355 (let* ((module (if modname
356 (resolve-module modname)
358 (v (module-local-variable module symbol)))
360 (let ((p (assq '*sc-expander* (object-properties v))))
361 (set-object-properties! v (delq p (object-properties v))))))))
363 (define get-global-definition-hook
364 (lambda (symbol module)
365 (let* ((module (if module
366 (resolve-module module)
367 (warn "wha" symbol (current-module))))
368 (v (module-variable module symbol)))
370 (or (object-property v '*sc-expander*)
371 (and (variable-bound? v)
372 (macro? (variable-ref v))
373 (macro-transformer (variable-ref v)) ;non-primitive
378 ;;; output constructors
379 (define (build-annotated src exp)
380 (if (and src (not (annotation? exp)))
381 (make-annotation exp src #t)
384 (define-syntax build-application
386 ((_ source fun-exp arg-exps)
387 (build-annotated source `(,fun-exp . ,arg-exps)))))
389 (define-syntax build-conditional
391 ((_ source test-exp then-exp else-exp)
392 (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
394 (define-syntax build-lexical-reference
397 (build-annotated source var))))
399 (define-syntax build-lexical-assignment
402 (build-annotated source `(set! ,var ,exp)))))
404 (define-syntax build-global-reference
407 (build-annotated source
408 (make-module-ref mod var #f)))))
410 (define-syntax build-global-assignment
412 ((_ source var exp mod)
413 (build-annotated source
414 `(set! ,(make-module-ref mod var #f) ,exp)))))
416 (define-syntax build-global-definition
418 ((_ source var exp mod)
419 (build-annotated source `(define ,var ,exp)))))
421 (define-syntax build-lambda
424 (build-annotated src `(lambda ,vars ,exp)))))
426 ;; FIXME: wingo: add modules here somehow?
427 (define-syntax build-primref
429 ((_ src name) (build-annotated src name))
430 ((_ src level name) (build-annotated src name))))
432 (define (build-data src exp)
433 (if (and (self-evaluating? exp)
435 (build-annotated src exp)
436 (build-annotated src (list 'quote exp))))
438 (define build-sequence
440 (if (null? (cdr exps))
441 (build-annotated src (car exps))
442 (build-annotated src `(begin ,@exps)))))
445 (lambda (src vars val-exps body-exp)
447 (build-annotated src body-exp)
448 (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
450 (define build-named-let
451 (lambda (src vars val-exps body-exp)
453 (build-annotated src body-exp)
456 ,(map list (cdr vars) val-exps) ,body-exp)))))
459 (lambda (src vars val-exps body-exp)
461 (build-annotated src body-exp)
463 `(letrec ,(map list vars val-exps) ,body-exp)))))
465 ;; FIXME: wingo: use make-lexical
466 (define-syntax build-lexical-var
468 ((_ src id) (build-annotated src (gensym (symbol->string id))))))
470 (define-structure (syntax-object expression wrap module))
472 (define-syntax unannotate
477 (annotation-expression e)
480 (define-syntax no-source (identifier-syntax #f))
482 (define source-annotation
485 ((annotation? x) (annotation-source x))
486 ((syntax-object? x) (source-annotation (syntax-object-expression x)))
489 (define-syntax arg-check
493 (if (not (pred? x)) (error-hook who "invalid argument" x))))))
495 ;;; compile-time environments
497 ;;; wrap and environment comprise two level mapping.
498 ;;; wrap : id --> label
499 ;;; env : label --> <element>
501 ;;; environments are represented in two parts: a lexical part and a global
502 ;;; part. The lexical part is a simple list of associations from labels
503 ;;; to bindings. The global part is implemented by
504 ;;; {put,get}-global-definition-hook and associates symbols with
507 ;;; global (assumed global variable) and displaced-lexical (see below)
508 ;;; do not show up in any environment; instead, they are fabricated by
509 ;;; lookup when it finds no other bindings.
511 ;;; <environment> ::= ((<label> . <binding>)*)
513 ;;; identifier bindings include a type and a value
515 ;;; <binding> ::= (macro . <procedure>) macros
516 ;;; (core . <procedure>) core forms
517 ;;; (external-macro . <procedure>) external-macro
518 ;;; (module-ref . <procedure>) @ or @@
521 ;;; (define-syntax) define-syntax
522 ;;; (local-syntax . rec?) let-syntax/letrec-syntax
523 ;;; (eval-when) eval-when
524 ;;; (syntax . (<var> . <level>)) pattern variables
525 ;;; (global) assumed global variable
526 ;;; (lexical . <var>) lexical variables
527 ;;; (displaced-lexical) displaced lexicals
528 ;;; <level> ::= <nonnegative integer>
529 ;;; <var> ::= variable returned by build-lexical-var
531 ;;; a macro is a user-defined syntactic-form. a core is a system-defined
532 ;;; syntactic form. begin, define, define-syntax, and eval-when are
533 ;;; treated specially since they are sensitive to whether the form is
534 ;;; at top-level and (except for eval-when) can denote valid internal
537 ;;; a pattern variable is a variable introduced by syntax-case and can
538 ;;; be referenced only within a syntax form.
540 ;;; any identifier for which no top-level syntax definition or local
541 ;;; binding of any kind has been seen is assumed to be a global
544 ;;; a lexical variable is a lambda- or letrec-bound variable.
546 ;;; a displaced-lexical identifier is a lexical identifier removed from
547 ;;; it's scope by the return of a syntax object containing the identifier.
548 ;;; a displaced lexical can also appear when a letrec-syntax-bound
549 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
550 ;;; a displaced lexical should never occur with properly written macros.
552 (define-syntax make-binding
553 (syntax-rules (quote)
554 ((_ type value) (cons type value))
556 ((_ type) (cons type '()))))
557 (define binding-type car)
558 (define binding-value cdr)
560 (define-syntax null-env (identifier-syntax '()))
563 (lambda (labels bindings r)
566 (extend-env (cdr labels) (cdr bindings)
567 (cons (cons (car labels) (car bindings)) r)))))
569 (define extend-var-env
570 ; variant of extend-env that forms "lexical" binding
571 (lambda (labels vars r)
574 (extend-var-env (cdr labels) (cdr vars)
575 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
577 ;;; we use a "macros only" environment in expansion of local macro
578 ;;; definitions so that their definitions can use local macros without
579 ;;; attempting to use other lexical identifiers.
580 (define macros-only-env
585 (if (eq? (cadr a) 'macro)
586 (cons a (macros-only-env (cdr r)))
587 (macros-only-env (cdr r)))))))
590 ; x may be a label or a symbol
591 ; although symbols are usually global, we check the environment first
592 ; anyway because a temporary binding may have been established by
598 (or (get-global-definition-hook x mod) (make-binding 'global)))
599 (else (make-binding 'displaced-lexical)))))
601 (define global-extend
602 (lambda (type sym val)
603 (put-global-definition-hook sym (make-binding type val)
604 (module-name (current-module)))))
607 ;;; Conceptually, identifiers are always syntax objects. Internally,
608 ;;; however, the wrap is sometimes maintained separately (a source of
609 ;;; efficiency and confusion), so that symbols are also considered
610 ;;; identifiers by id?. Externally, they are always wrapped.
612 (define nonsymbol-id?
614 (and (syntax-object? x)
615 (symbol? (unannotate (syntax-object-expression x))))))
621 ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
622 ((annotation? x) (symbol? (annotation-expression x)))
625 (define-syntax id-sym-name
629 (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
631 (define id-sym-name&marks
633 (if (syntax-object? x)
635 (unannotate (syntax-object-expression x))
636 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
637 (values (unannotate x) (wrap-marks w)))))
639 ;;; syntax object wraps
641 ;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
642 ;;; <subst> ::= <shift> | <subs>
643 ;;; <subs> ::= #(<old name> <label> (<mark> ...))
644 ;;; <shift> ::= positive fixnum
646 (define make-wrap cons)
647 (define wrap-marks car)
648 (define wrap-subst cdr)
650 (define-syntax subst-rename? (identifier-syntax vector?))
651 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
652 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
653 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
654 (define-syntax make-rename
656 ((_ old new marks) (vector old new marks))))
658 ;;; labels must be comparable with "eq?" and distinct from symbols.
660 (lambda () (string #\i)))
666 (cons (gen-label) (gen-labels (cdr ls))))))
668 (define-structure (ribcage symnames marks labels))
670 (define-syntax empty-wrap (identifier-syntax '(())))
672 (define-syntax top-wrap (identifier-syntax '((top))))
674 (define-syntax top-marked?
676 ((_ w) (memq 'top (wrap-marks w)))))
678 ;;; Marks must be comparable with "eq?" and distinct from pairs and
679 ;;; the symbol top. We do not use integers so that marks will remain
680 ;;; unique even across file compiles.
682 (define-syntax the-anti-mark (identifier-syntax #f))
686 (make-wrap (cons the-anti-mark (wrap-marks w))
687 (cons 'shift (wrap-subst w)))))
689 (define-syntax new-mark
693 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
694 ;;; internal definitions, in which the ribcages are built incrementally
695 (define-syntax make-empty-ribcage
697 ((_) (make-ribcage '() '() '()))))
699 (define extend-ribcage!
700 ; must receive ids with complete wraps
701 (lambda (ribcage id label)
702 (set-ribcage-symnames! ribcage
703 (cons (unannotate (syntax-object-expression id))
704 (ribcage-symnames ribcage)))
705 (set-ribcage-marks! ribcage
706 (cons (wrap-marks (syntax-object-wrap id))
707 (ribcage-marks ribcage)))
708 (set-ribcage-labels! ribcage
709 (cons label (ribcage-labels ribcage)))))
711 ;;; make-binding-wrap creates vector-based ribcages
712 (define make-binding-wrap
713 (lambda (ids labels w)
719 (let ((labelvec (list->vector labels)))
720 (let ((n (vector-length labelvec)))
721 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
722 (let f ((ids ids) (i 0))
723 (if (not (null? ids))
725 (lambda () (id-sym-name&marks (car ids) w))
726 (lambda (symname marks)
727 (vector-set! symnamevec i symname)
728 (vector-set! marksvec i marks)
729 (f (cdr ids) (fx+ i 1))))))
730 (make-ribcage symnamevec marksvec labelvec))))
741 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
747 (smart-append s1 (wrap-subst w2))))
749 (smart-append m1 (wrap-marks w2))
750 (smart-append s1 (wrap-subst w2)))))))
754 (smart-append m1 m2)))
761 (eq? (car x) (car y))
762 (same-marks? (cdr x) (cdr y))))))
768 ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
770 (lambda (sym subst marks)
773 (let ((fst (car subst)))
775 (search sym (cdr subst) (cdr marks))
776 (let ((symnames (ribcage-symnames fst)))
777 (if (vector? symnames)
778 (search-vector-rib sym subst marks symnames fst)
779 (search-list-rib sym subst marks symnames fst))))))))
780 (define search-list-rib
781 (lambda (sym subst marks symnames ribcage)
782 (let f ((symnames symnames) (i 0))
784 ((null? symnames) (search sym (cdr subst) marks))
785 ((and (eq? (car symnames) sym)
786 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
787 (values (list-ref (ribcage-labels ribcage) i) marks))
788 (else (f (cdr symnames) (fx+ i 1)))))))
789 (define search-vector-rib
790 (lambda (sym subst marks symnames ribcage)
791 (let ((n (vector-length symnames)))
794 ((fx= i n) (search sym (cdr subst) marks))
795 ((and (eq? (vector-ref symnames i) sym)
796 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
797 (values (vector-ref (ribcage-labels ribcage) i) marks))
798 (else (f (fx+ i 1))))))))
801 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
803 (let ((id (unannotate (syntax-object-expression id)))
804 (w1 (syntax-object-wrap id)))
805 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
806 (call-with-values (lambda () (search id (wrap-subst w) marks))
807 (lambda (new-id marks)
809 (first (search id (wrap-subst w1) marks))
812 (let ((id (unannotate id)))
813 (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
814 (else (error-hook 'id-var-name "invalid id" id)))))
816 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
817 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
821 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
822 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
824 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
825 ;;; long as the missing portion of the wrap is common to both of the ids
826 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
830 (if (and (syntax-object? i) (syntax-object? j))
831 (and (eq? (unannotate (syntax-object-expression i))
832 (unannotate (syntax-object-expression j)))
833 (same-marks? (wrap-marks (syntax-object-wrap i))
834 (wrap-marks (syntax-object-wrap j))))
835 (eq? (unannotate i) (unannotate j)))))
837 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
838 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
839 ;;; as long as the missing portion of the wrap is common to all of the
842 (define valid-bound-ids?
844 (and (let all-ids? ((ids ids))
847 (all-ids? (cdr ids)))))
848 (distinct-bound-ids? ids))))
850 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
851 ;;; no duplicates. It is quadratic on the length of the id list; long
852 ;;; lists could be sorted to make it more efficient. distinct-bound-ids?
853 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
854 ;;; missing portion of the wrap is common to all of the ids.
856 (define distinct-bound-ids?
858 (let distinct? ((ids ids))
860 (and (not (bound-id-member? (car ids) (cdr ids)))
861 (distinct? (cdr ids)))))))
863 (define bound-id-member?
865 (and (not (null? list))
866 (or (bound-id=? x (car list))
867 (bound-id-member? x (cdr list))))))
869 ;;; wrapping expressions and identifiers
874 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
877 (syntax-object-expression x)
878 (join-wraps w (syntax-object-wrap x))
879 (syntax-object-module x)))
881 (else (make-syntax-object x w defmod)))))
884 (lambda (x w s defmod)
885 (wrap (if s (make-annotation x s #f) x) w defmod)))
890 (lambda (body r w s mod)
892 (let dobody ((body body) (r r) (w w) (mod mod))
895 (let ((first (chi (car body) r w mod)))
896 (cons first (dobody (cdr body) r w mod))))))))
898 (define chi-top-sequence
899 (lambda (body r w s m esew mod)
901 (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
904 (let ((first (chi-top (car body) r w m esew mod)))
905 (cons first (dobody (cdr body) r w m esew mod))))))))
908 (define chi-install-global
910 (build-application no-source
911 (build-primref no-source 'install-global-transformer)
912 (list (build-data no-source name) e))))
914 (define chi-when-list
915 (lambda (e when-list w)
916 ; when-list is syntax'd version of list of situations
917 (let f ((when-list when-list) (situations '()))
918 (if (null? when-list)
921 (cons (let ((x (car when-list)))
923 ((free-id=? x (syntax compile)) 'compile)
924 ((free-id=? x (syntax load)) 'load)
925 ((free-id=? x (syntax eval)) 'eval)
926 (else (syntax-error (wrap x w #f)
927 "invalid eval-when situation"))))
930 ;;; syntax-type returns six values: type, value, e, w, s, and mod. The
931 ;;; first two are described in the table below.
933 ;;; type value explanation
934 ;;; -------------------------------------------------------------------
935 ;;; core procedure core form (including singleton)
936 ;;; external-macro procedure external macro
937 ;;; module-ref procedure @ or @@ form
938 ;;; lexical name lexical variable reference
939 ;;; global name global variable reference
940 ;;; begin none begin keyword
941 ;;; define none define keyword
942 ;;; define-syntax none define-syntax keyword
943 ;;; local-syntax rec? letrec-syntax/let-syntax keyword
944 ;;; eval-when none eval-when keyword
945 ;;; syntax level pattern variable
946 ;;; displaced-lexical none displaced lexical identifier
947 ;;; lexical-call name call to lexical variable
948 ;;; global-call name call to global variable
949 ;;; call none any other call
950 ;;; begin-form none begin expression
951 ;;; define-form id variable definition
952 ;;; define-syntax-form id syntax definition
953 ;;; local-syntax-form rec? syntax definition
954 ;;; eval-when-form none eval-when form
955 ;;; constant none self-evaluating datum
956 ;;; other none anything else
958 ;;; For define-form and define-syntax-form, e is the rhs expression.
959 ;;; For all others, e is the entire form. w is the wrap for e.
960 ;;; s is the source for the entire form. mod is the module for e.
962 ;;; syntax-type expands macros and unwraps as necessary to get to
963 ;;; one of the forms above. It also parses define and define-syntax
964 ;;; forms, although perhaps this should be done by the consumer.
967 (lambda (e r w s rib mod)
970 (let* ((n (id-var-name e w))
972 (type (binding-type b)))
974 ((lexical) (values type (binding-value b) e w s mod))
975 ((global) (values type n e w s mod))
977 (syntax-type (chi-macro (binding-value b) e r w rib mod)
978 r empty-wrap s rib mod))
979 (else (values type (binding-value b) e w s mod)))))
981 (let ((first (car e)))
983 (let* ((n (id-var-name first w))
984 (b (lookup n r (or (and (syntax-object? first)
985 (syntax-object-module first))
987 (type (binding-type b)))
990 (values 'lexical-call (binding-value b) e w s mod))
992 (values 'global-call n e w s mod))
994 (syntax-type (chi-macro (binding-value b) e r w rib mod)
995 r empty-wrap s rib mod))
996 ((core external-macro module-ref)
997 (values type (binding-value b) e w s mod))
999 (values 'local-syntax-form (binding-value b) e w s mod))
1001 (values 'begin-form #f e w s mod))
1003 (values 'eval-when-form #f e w s mod))
1008 (values 'define-form (syntax name) (syntax val) w s mod))
1009 ((_ (name . args) e1 e2 ...)
1010 (and (id? (syntax name))
1011 (valid-bound-ids? (lambda-var-list (syntax args))))
1012 ; need lambda here...
1013 (values 'define-form (wrap (syntax name) w mod)
1014 (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
1018 (values 'define-form (wrap (syntax name) w mod)
1020 empty-wrap s mod))))
1025 (values 'define-syntax-form (syntax name)
1026 (syntax val) w s mod))))
1028 (values 'call #f e w s mod))))
1029 (values 'call #f e w s mod))))
1031 ;; s can't be valid source if we've unwrapped
1032 (syntax-type (syntax-object-expression e)
1034 (join-wraps w (syntax-object-wrap e))
1035 no-source rib (or (syntax-object-module e) mod)))
1037 (syntax-type (annotation-expression e) r w (annotation-source e) rib mod))
1038 ((self-evaluating? e) (values 'constant #f e w s mod))
1039 (else (values 'other #f e w s mod)))))
1042 (lambda (e r w m esew mod)
1043 (define-syntax eval-if-c&e
1047 (if (eq? m 'c&e) (top-level-eval-hook x mod))
1050 (lambda () (syntax-type e r w no-source #f mod))
1051 (lambda (type value e w s mod)
1057 (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
1058 ((local-syntax-form)
1059 (chi-local-syntax value e r w s mod
1060 (lambda (body r w s mod)
1061 (chi-top-sequence body r w s m esew mod))))
1064 ((_ (x ...) e1 e2 ...)
1065 (let ((when-list (chi-when-list e (syntax (x ...)) w))
1066 (body (syntax (e1 e2 ...))))
1069 (if (memq 'eval when-list)
1070 (chi-top-sequence body r w s 'e '(eval) mod)
1072 ((memq 'load when-list)
1073 (if (or (memq 'compile when-list)
1074 (and (eq? m 'c&e) (memq 'eval when-list)))
1075 (chi-top-sequence body r w s 'c&e '(compile load) mod)
1076 (if (memq m '(c c&e))
1077 (chi-top-sequence body r w s 'c '(load) mod)
1079 ((or (memq 'compile when-list)
1080 (and (eq? m 'c&e) (memq 'eval when-list)))
1081 (top-level-eval-hook
1082 (chi-top-sequence body r w s 'e '(eval) mod)
1085 (else (chi-void)))))))
1086 ((define-syntax-form)
1087 (let ((n (id-var-name value w)) (r (macros-only-env r)))
1090 (if (memq 'compile esew)
1091 (let ((e (chi-install-global n (chi e r w mod))))
1092 (top-level-eval-hook e mod)
1093 (if (memq 'load esew) e (chi-void)))
1094 (if (memq 'load esew)
1095 (chi-install-global n (chi e r w mod))
1098 (let ((e (chi-install-global n (chi e r w mod))))
1099 (top-level-eval-hook e mod)
1102 (if (memq 'eval esew)
1103 (top-level-eval-hook
1104 (chi-install-global n (chi e r w mod))
1108 (let* ((n (id-var-name value w))
1109 (type (binding-type (lookup n r mod))))
1113 (build-global-definition s n (chi e r w mod) mod)
1115 ((displaced-lexical)
1116 (syntax-error (wrap value w mod) "identifier out of context"))
1117 ((core macro module-ref)
1118 (remove-global-definition-hook n mod)
1120 (build-global-definition s n (chi e r w mod) mod)
1123 (syntax-error (wrap value w mod)
1124 "cannot define keyword at top level")))))
1125 (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
1130 (lambda () (syntax-type e r w no-source #f mod))
1131 (lambda (type value e w s mod)
1132 (chi-expr type value e r w s mod)))))
1135 (lambda (type value e r w s mod)
1138 (build-lexical-reference 'value s value))
1139 ((core external-macro)
1140 ;; apply transformer
1141 (value e r w s mod))
1143 (call-with-values (lambda () (value e))
1144 ;; we could add a public? arg here
1145 (lambda (id mod) (build-global-reference s id mod))))
1148 (build-lexical-reference 'fun (source-annotation (car e)) value)
1152 (build-global-reference (source-annotation (car e)) value
1153 (if (syntax-object? (car e))
1154 (syntax-object-module (car e))
1157 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1158 ((global) (build-global-reference s value mod))
1159 ((call) (chi-application (chi (car e) r w mod) e r w s mod))
1162 ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
1163 ((local-syntax-form)
1164 (chi-local-syntax value e r w s mod chi-sequence))
1167 ((_ (x ...) e1 e2 ...)
1168 (let ((when-list (chi-when-list e (syntax (x ...)) w)))
1169 (if (memq 'eval when-list)
1170 (chi-sequence (syntax (e1 e2 ...)) r w s mod)
1172 ((define-form define-syntax-form)
1173 (syntax-error (wrap value w mod) "invalid context for definition of"))
1175 (syntax-error (source-wrap e w s mod)
1176 "reference to pattern variable outside syntax form"))
1177 ((displaced-lexical)
1178 (syntax-error (source-wrap e w s mod)
1179 "reference to identifier outside its scope"))
1180 (else (syntax-error (source-wrap e w s mod))))))
1182 (define chi-application
1183 (lambda (x e r w s mod)
1186 (build-application s x
1187 (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
1190 (lambda (p e r w rib mod)
1191 (define rebuild-macro-output
1194 (cons (rebuild-macro-output (car x) m)
1195 (rebuild-macro-output (cdr x) m)))
1197 (let ((w (syntax-object-wrap x)))
1198 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1199 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1200 ;; output is from original text
1202 (syntax-object-expression x)
1203 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1204 (syntax-object-module x))
1205 ;; output introduced by macro
1207 (syntax-object-expression x)
1208 (make-wrap (cons m ms)
1210 (cons rib (cons 'shift s))
1212 (module-name (procedure-module p))))))) ;; hither the hygiene
1214 (let* ((n (vector-length x)) (v (make-vector n)))
1215 (do ((i 0 (fx+ i 1)))
1218 (rebuild-macro-output (vector-ref x i) m)))))
1220 (syntax-error x "encountered raw symbol in macro output"))
1222 (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
1225 ;; In processing the forms of the body, we create a new, empty wrap.
1226 ;; This wrap is augmented (destructively) each time we discover that
1227 ;; the next form is a definition. This is done:
1229 ;; (1) to allow the first nondefinition form to be a call to
1230 ;; one of the defined ids even if the id previously denoted a
1231 ;; definition keyword or keyword for a macro expanding into a
1233 ;; (2) to prevent subsequent definition forms (but unfortunately
1234 ;; not earlier ones) and the first nondefinition form from
1235 ;; confusing one of the bound identifiers for an auxiliary
1237 ;; (3) so that we do not need to restart the expansion of the
1238 ;; first nondefinition form, which is problematic anyway
1239 ;; since it might be the first element of a begin that we
1240 ;; have just spliced into the body (meaning if we restarted,
1241 ;; we'd really need to restart with the begin or the macro
1242 ;; call that expanded into the begin, and we'd have to give
1243 ;; up allowing (begin <defn>+ <expr>+), which is itself
1244 ;; problematic since we don't know if a begin contains only
1245 ;; definitions until we've expanded it).
1247 ;; Before processing the body, we also create a new environment
1248 ;; containing a placeholder for the bindings we will add later and
1249 ;; associate this environment with each form. In processing a
1250 ;; let-syntax or letrec-syntax, the associated environment may be
1251 ;; augmented with local keyword bindings, so the environment may
1252 ;; be different for different forms in the body. Once we have
1253 ;; gathered up all of the definitions, we evaluate the transformer
1254 ;; expressions and splice into r at the placeholder the new variable
1255 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1256 ;; forms local to a portion or all of the body to shadow the
1257 ;; definition bindings.
1259 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1262 ;; outer-form is fully wrapped w/source
1263 (lambda (body outer-form r w mod)
1264 (let* ((r (cons '("placeholder" . (placeholder)) r))
1265 (ribcage (make-empty-ribcage))
1266 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1267 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1268 (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
1270 (syntax-error outer-form "no expressions in body")
1271 (let ((e (cdar body)) (er (caar body)))
1273 (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
1274 (lambda (type value e w s mod)
1277 (let ((id (wrap value w mod)) (label (gen-label)))
1278 (let ((var (gen-var id)))
1279 (extend-ribcage! ribcage id label)
1281 (cons id ids) (cons label labels)
1282 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1283 (cons (make-binding 'lexical var) bindings)))))
1284 ((define-syntax-form)
1285 (let ((id (wrap value w mod)) (label (gen-label)))
1286 (extend-ribcage! ribcage id label)
1288 (cons id ids) (cons label labels)
1290 (cons (make-binding 'macro (cons er (wrap e w mod)))
1295 (parse (let f ((forms (syntax (e1 ...))))
1298 (cons (cons er (wrap (car forms) w mod))
1300 ids labels vars vals bindings))))
1301 ((local-syntax-form)
1302 (chi-local-syntax value e er w s mod
1303 (lambda (forms er w s mod)
1304 (parse (let f ((forms forms))
1307 (cons (cons er (wrap (car forms) w mod))
1309 ids labels vars vals bindings))))
1310 (else ; found a non-definition
1312 (build-sequence no-source
1314 (chi (cdr x) (car x) empty-wrap mod))
1315 (cons (cons er (source-wrap e w s mod))
1318 (if (not (valid-bound-ids? ids))
1319 (syntax-error outer-form
1320 "invalid or duplicate identifier in definition"))
1321 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1322 (if (not (null? bs))
1323 (let* ((b (car bs)))
1324 (if (eq? (car b) 'macro)
1325 (let* ((er (cadr b))
1327 (if (eq? er er-cache)
1329 (macros-only-env er))))
1331 (eval-local-transformer
1332 (chi (cddr b) r-cache empty-wrap mod)
1334 (loop (cdr bs) er r-cache))
1335 (loop (cdr bs) er-cache r-cache)))))
1336 (set-cdr! r (extend-env labels bindings (cdr r)))
1337 (build-letrec no-source
1340 (chi (cdr x) (car x) empty-wrap mod))
1342 (build-sequence no-source
1344 (chi (cdr x) (car x) empty-wrap mod))
1345 (cons (cons er (source-wrap e w s mod))
1346 (cdr body)))))))))))))))))
1348 (define chi-lambda-clause
1349 (lambda (e c r w mod k)
1351 (((id ...) e1 e2 ...)
1352 (let ((ids (syntax (id ...))))
1353 (if (not (valid-bound-ids? ids))
1354 (syntax-error e "invalid parameter list in")
1355 (let ((labels (gen-labels ids))
1356 (new-vars (map gen-var ids)))
1358 (chi-body (syntax (e1 e2 ...))
1360 (extend-var-env labels new-vars r)
1361 (make-binding-wrap ids labels w)
1364 (let ((old-ids (lambda-var-list (syntax ids))))
1365 (if (not (valid-bound-ids? old-ids))
1366 (syntax-error e "invalid parameter list in")
1367 (let ((labels (gen-labels old-ids))
1368 (new-vars (map gen-var old-ids)))
1369 (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
1372 (f (cdr ls1) (cons (car ls1) ls2))))
1373 (chi-body (syntax (e1 e2 ...))
1375 (extend-var-env labels new-vars r)
1376 (make-binding-wrap old-ids labels w)
1378 (_ (syntax-error e)))))
1380 (define chi-local-syntax
1381 (lambda (rec? e r w s mod k)
1383 ((_ ((id val) ...) e1 e2 ...)
1384 (let ((ids (syntax (id ...))))
1385 (if (not (valid-bound-ids? ids))
1386 (syntax-error e "duplicate bound keyword in")
1387 (let ((labels (gen-labels ids)))
1388 (let ((new-w (make-binding-wrap ids labels w)))
1389 (k (syntax (e1 e2 ...))
1392 (let ((w (if rec? new-w w))
1393 (trans-r (macros-only-env r)))
1395 (make-binding 'macro
1396 (eval-local-transformer
1397 (chi x trans-r w mod)
1399 (syntax (val ...))))
1404 (_ (syntax-error (source-wrap e w s mod))))))
1406 (define eval-local-transformer
1407 (lambda (expanded mod)
1408 (let ((p (local-eval-hook expanded mod)))
1411 (syntax-error p "nonprocedure transformer")))))
1415 (build-application no-source (build-primref no-source 'void) '())))
1419 (and (nonsymbol-id? x)
1420 (free-id=? x (syntax (... ...))))))
1424 ;;; strips all annotations from potentially circular reader output
1426 (define strip-annotation
1430 (let ((new (cons #f #f)))
1431 (if parent (set-annotation-stripped! parent new))
1432 (set-car! new (strip-annotation (car x) #f))
1433 (set-cdr! new (strip-annotation (cdr x) #f))
1436 (or (annotation-stripped x)
1437 (strip-annotation (annotation-expression x) x)))
1439 (let ((new (make-vector (vector-length x))))
1440 (if parent (set-annotation-stripped! parent new))
1441 (let loop ((i (- (vector-length x) 1)))
1443 (vector-set! new i (strip-annotation (vector-ref x i) #f))
1448 ;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
1449 ;;; on an annotation, strips the annotation as well.
1450 ;;; since only the head of a list is annotated by the reader, not each pair
1451 ;;; in the spine, we also check for pairs whose cars are annotated in case
1452 ;;; we've been passed the cdr of an annotated list
1457 (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
1458 (strip-annotation x #f)
1463 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1465 (let ((a (f (car x))) (d (f (cdr x))))
1466 (if (and (eq? a (car x)) (eq? d (cdr x)))
1470 (let ((old (vector->list x)))
1471 (let ((new (map f old)))
1472 (if (andmap eq? old new) x (list->vector new)))))
1475 ;;; lexical variables
1479 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1480 (if (annotation? id)
1481 (build-lexical-var (annotation-source id) (annotation-expression id))
1482 (build-lexical-var no-source id)))))
1484 (define lambda-var-list
1486 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1488 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1489 ((id? vars) (cons (wrap vars w #f) ls))
1491 ((syntax-object? vars)
1492 (lvl (syntax-object-expression vars)
1494 (join-wraps w (syntax-object-wrap vars))))
1496 (lvl (annotation-expression vars) ls w))
1497 ; include anything else to be caught by subsequent error
1499 (else (cons vars ls))))))
1501 ;;; core transformers
1503 (global-extend 'local-syntax 'letrec-syntax #t)
1504 (global-extend 'local-syntax 'let-syntax #f)
1506 (global-extend 'core 'fluid-let-syntax
1507 (lambda (e r w s mod)
1509 ((_ ((var val) ...) e1 e2 ...)
1510 (valid-bound-ids? (syntax (var ...)))
1511 (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
1514 (case (binding-type (lookup n r mod))
1515 ((displaced-lexical)
1516 (syntax-error (source-wrap id w s mod)
1517 "identifier out of context"))))
1521 (syntax (e1 e2 ...))
1522 (source-wrap e w s mod)
1525 (let ((trans-r (macros-only-env r)))
1527 (make-binding 'macro
1528 (eval-local-transformer (chi x trans-r w mod)
1530 (syntax (val ...))))
1534 (_ (syntax-error (source-wrap e w s mod))))))
1536 (global-extend 'core 'quote
1537 (lambda (e r w s mod)
1539 ((_ e) (build-data s (strip (syntax e) w)))
1540 (_ (syntax-error (source-wrap e w s mod))))))
1542 (global-extend 'core 'syntax
1545 (lambda (src e r maps ellipsis? mod)
1547 (let ((label (id-var-name e empty-wrap)))
1548 (let ((b (lookup label r mod)))
1549 (if (eq? (binding-type b) 'syntax)
1552 (let ((var.lev (binding-value b)))
1553 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1554 (lambda (var maps) (values `(ref ,var) maps)))
1556 (syntax-error src "misplaced ellipsis in syntax form")
1557 (values `(quote ,e) maps)))))
1560 (ellipsis? (syntax dots))
1561 (gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
1563 ; this could be about a dozen lines of code, except that we
1564 ; choose to handle (syntax (x ... ...)) forms
1565 (ellipsis? (syntax dots))
1566 (let f ((y (syntax y))
1570 (gen-syntax src (syntax x) r
1571 (cons '() maps) ellipsis? mod))
1573 (if (null? (car maps))
1575 "extra ellipsis in syntax form")
1576 (values (gen-map x (car maps))
1580 (ellipsis? (syntax dots))
1584 (lambda () (k (cons '() maps)))
1586 (if (null? (car maps))
1588 "extra ellipsis in syntax form")
1589 (values (gen-mappend x (car maps))
1591 (_ (call-with-values
1592 (lambda () (gen-syntax src y r maps ellipsis? mod))
1595 (lambda () (k maps))
1597 (values (gen-append x y) maps)))))))))
1600 (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
1603 (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod))
1604 (lambda (y maps) (values (gen-cons x y) maps))))))
1608 (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod))
1609 (lambda (e maps) (values (gen-vector e) maps))))
1610 (_ (values `(quote ,e) maps))))))
1613 (lambda (src var level maps)
1617 (syntax-error src "missing ellipsis in syntax form")
1619 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1620 (lambda (outer-var outer-maps)
1621 (let ((b (assq outer-var (car maps))))
1623 (values (cdr b) maps)
1624 (let ((inner-var (gen-var 'tmp)))
1626 (cons (cons (cons outer-var inner-var)
1628 outer-maps)))))))))))
1632 `(apply (primitive append) ,(gen-map e map-env))))
1636 (let ((formals (map cdr map-env))
1637 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1640 ; identity map equivalence:
1641 ; (map (lambda (x) x) y) == y
1644 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1646 ; eta map equivalence:
1647 ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1648 `(map (primitive ,(car e))
1649 ,@(map (let ((r (map cons formals actuals)))
1650 (lambda (x) (cdr (assq (cadr x) r))))
1652 (else `(map (lambda ,formals ,e) ,@actuals))))))
1658 (if (eq? (car x) 'quote)
1659 `(quote (,(cadr x) . ,(cadr y)))
1660 (if (eq? (cadr y) '())
1663 ((list) `(list ,x ,@(cdr y)))
1664 (else `(cons ,x ,y)))))
1668 (if (equal? y '(quote ()))
1675 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1676 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1677 (else `(list->vector ,x)))))
1683 ((ref) (build-lexical-reference 'value no-source (cadr x)))
1684 ((primitive) (build-primref no-source (cadr x)))
1685 ((quote) (build-data no-source (cadr x)))
1686 ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
1687 ((map) (let ((ls (map regen (cdr x))))
1688 (build-application no-source
1689 (if (fx= (length ls) 2)
1690 (build-primref no-source 'map)
1691 ; really need to do our own checking here
1692 (build-primref no-source 2 'map)) ; require error check
1694 (else (build-application no-source
1695 (build-primref no-source (car x))
1696 (map regen (cdr x)))))))
1698 (lambda (e r w s mod)
1699 (let ((e (source-wrap e w s mod)))
1703 (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
1704 (lambda (e maps) (regen e))))
1705 (_ (syntax-error e)))))))
1708 (global-extend 'core 'lambda
1709 (lambda (e r w s mod)
1712 (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod
1713 (lambda (vars body) (build-lambda s vars body)))))))
1716 (global-extend 'core 'let
1718 (define (chi-let e r w s mod constructor ids vals exps)
1719 (if (not (valid-bound-ids? ids))
1720 (syntax-error e "duplicate bound variable in")
1721 (let ((labels (gen-labels ids))
1722 (new-vars (map gen-var ids)))
1723 (let ((nw (make-binding-wrap ids labels w))
1724 (nr (extend-var-env labels new-vars r)))
1727 (map (lambda (x) (chi x r w mod)) vals)
1728 (chi-body exps (source-wrap e nw s mod)
1730 (lambda (e r w s mod)
1732 ((_ ((id val) ...) e1 e2 ...)
1733 (chi-let e r w s mod
1737 (syntax (e1 e2 ...))))
1738 ((_ f ((id val) ...) e1 e2 ...)
1740 (chi-let e r w s mod
1744 (syntax (e1 e2 ...))))
1745 (_ (syntax-error (source-wrap e w s mod)))))))
1748 (global-extend 'core 'letrec
1749 (lambda (e r w s mod)
1751 ((_ ((id val) ...) e1 e2 ...)
1752 (let ((ids (syntax (id ...))))
1753 (if (not (valid-bound-ids? ids))
1754 (syntax-error e "duplicate bound variable in")
1755 (let ((labels (gen-labels ids))
1756 (new-vars (map gen-var ids)))
1757 (let ((w (make-binding-wrap ids labels w))
1758 (r (extend-var-env labels new-vars r)))
1761 (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
1762 (chi-body (syntax (e1 e2 ...))
1763 (source-wrap e w s mod) r w mod)))))))
1764 (_ (syntax-error (source-wrap e w s mod))))))
1767 (global-extend 'core 'set!
1768 (lambda (e r w s mod)
1772 (let ((val (chi (syntax val) r w mod))
1773 (n (id-var-name (syntax id) w)))
1774 (let ((b (lookup n r mod)))
1775 (case (binding-type b)
1777 (build-lexical-assignment s (binding-value b) val))
1778 ((global) (build-global-assignment s n val mod))
1779 ((displaced-lexical)
1780 (syntax-error (wrap (syntax id) w mod)
1781 "identifier out of context"))
1782 (else (syntax-error (source-wrap e w s mod)))))))
1783 ((_ (head tail ...) val)
1785 (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod))
1786 (lambda (type value ee ww ss modmod)
1789 (call-with-values (lambda () (value (syntax (head tail ...))))
1791 (build-global-assignment s id (syntax val) mod))))
1793 (build-application s
1794 (chi (syntax (setter head)) r w mod)
1795 (map (lambda (e) (chi e r w mod))
1796 (syntax (tail ... val)))))))))
1797 (_ (syntax-error (source-wrap e w s mod))))))
1799 (global-extend 'module-ref '@
1801 (syntax-case e (%module-public-interface)
1803 (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
1804 (values (syntax-object->datum (syntax id))
1805 (syntax-object->datum
1806 (syntax (mod ... %module-public-interface))))))))
1808 (global-extend 'module-ref '@@
1812 (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
1813 (values (syntax-object->datum (syntax id))
1814 (syntax-object->datum
1815 (syntax (mod ...))))))))
1817 (global-extend 'begin 'begin '())
1819 (global-extend 'define 'define '())
1821 (global-extend 'define-syntax 'define-syntax '())
1823 (global-extend 'eval-when 'eval-when '())
1825 (global-extend 'core 'syntax-case
1827 (define convert-pattern
1828 ; accepts pattern & keys
1829 ; returns syntax-dispatch pattern & ids
1830 (lambda (pattern keys)
1831 (let cvt ((p pattern) (n 0) (ids '()))
1833 (if (bound-id-member? p keys)
1834 (values (vector 'free-id p) ids)
1835 (values 'any (cons (cons p n) ids)))
1838 (ellipsis? (syntax dots))
1840 (lambda () (cvt (syntax x) (fx+ n 1) ids))
1842 (values (if (eq? p 'any) 'each-any (vector 'each p))
1846 (lambda () (cvt (syntax y) n ids))
1849 (lambda () (cvt (syntax x) n ids))
1851 (values (cons x y) ids))))))
1852 (() (values '() ids))
1855 (lambda () (cvt (syntax (x ...)) n ids))
1856 (lambda (p ids) (values (vector 'vector p) ids))))
1857 (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
1859 (define build-dispatch-call
1860 (lambda (pvars exp y r mod)
1861 (let ((ids (map car pvars)) (levels (map cdr pvars)))
1862 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1863 (build-application no-source
1864 (build-primref no-source 'apply)
1865 (list (build-lambda no-source new-vars
1869 (map (lambda (var level)
1870 (make-binding 'syntax `(,var . ,level)))
1874 (make-binding-wrap ids labels empty-wrap)
1879 (lambda (x keys clauses r pat fender exp mod)
1881 (lambda () (convert-pattern pat keys))
1884 ((not (distinct-bound-ids? (map car pvars)))
1886 "duplicate pattern variable in syntax-case pattern"))
1887 ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
1889 "misplaced ellipsis in syntax-case pattern"))
1891 (let ((y (gen-var 'tmp)))
1892 ; fat finger binding and references to temp variable y
1893 (build-application no-source
1894 (build-lambda no-source (list y)
1895 (let ((y (build-lexical-reference 'value no-source y)))
1896 (build-conditional no-source
1897 (syntax-case fender ()
1899 (_ (build-conditional no-source
1901 (build-dispatch-call pvars fender y r mod)
1902 (build-data no-source #f))))
1903 (build-dispatch-call pvars exp y r mod)
1904 (gen-syntax-case x keys clauses r mod))))
1905 (list (if (eq? p 'any)
1906 (build-application no-source
1907 (build-primref no-source 'list)
1909 (build-application no-source
1910 (build-primref no-source 'syntax-dispatch)
1911 (list x (build-data no-source p)))))))))))))
1913 (define gen-syntax-case
1914 (lambda (x keys clauses r mod)
1916 (build-application no-source
1917 (build-primref no-source 'syntax-error)
1919 (syntax-case (car clauses) ()
1921 (if (and (id? (syntax pat))
1922 (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
1923 (cons (syntax (... ...)) keys)))
1924 (let ((labels (list (gen-label)))
1925 (var (gen-var (syntax pat))))
1926 (build-application no-source
1927 (build-lambda no-source (list var)
1930 (list (make-binding 'syntax `(,var . 0)))
1932 (make-binding-wrap (syntax (pat))
1936 (gen-clause x keys (cdr clauses) r
1937 (syntax pat) #t (syntax exp) mod)))
1939 (gen-clause x keys (cdr clauses) r
1940 (syntax pat) (syntax fender) (syntax exp) mod))
1941 (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
1943 (lambda (e r w s mod)
1944 (let ((e (source-wrap e w s mod)))
1946 ((_ val (key ...) m ...)
1947 (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
1949 (let ((x (gen-var 'tmp)))
1950 ; fat finger binding and references to temp variable x
1951 (build-application s
1952 (build-lambda no-source (list x)
1953 (gen-syntax-case (build-lexical-reference 'value no-source x)
1954 (syntax (key ...)) (syntax (m ...))
1957 (list (chi (syntax val) r empty-wrap mod))))
1958 (syntax-error e "invalid literals list in"))))))))
1960 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
1961 ;;; evaluating) and esew (which stands for "eval syntax expanders
1962 ;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
1963 ;;; if we are compiling a file, and esew is set to
1964 ;;; (eval-syntactic-expanders-when), which defaults to the list
1965 ;;; '(compile load eval). This means that, by default, top-level
1966 ;;; syntactic definitions are evaluated immediately after they are
1967 ;;; expanded, and the expanded definitions are also residualized into
1968 ;;; the object file if we are compiling a file.
1970 (let ((m 'e) (esew '(eval)))
1972 (if (and (pair? x) (equal? (car x) noexpand))
1974 (chi-top x null-env top-wrap m esew
1975 (module-name (current-module)))))))
1978 (let ((m 'e) (esew '(eval)))
1980 (if (and (pair? x) (equal? (car x) noexpand))
1985 (if (null? rest) m (car rest))
1986 (if (or (null? rest) (null? (cdr rest)))
1989 (module-name (current-module)))))))
1995 (set! datum->syntax-object
1997 (make-syntax-object datum (syntax-object-wrap id) #f)))
1999 (set! syntax-object->datum
2000 ; accepts any object, since syntax objects may consist partially
2001 ; or entirely of unwrapped, nonsymbolic data
2003 (strip x empty-wrap)))
2005 (set! generate-temporaries
2007 (arg-check list? ls 'generate-temporaries)
2008 (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
2010 (set! free-identifier=?
2012 (arg-check nonsymbol-id? x 'free-identifier=?)
2013 (arg-check nonsymbol-id? y 'free-identifier=?)
2016 (set! bound-identifier=?
2018 (arg-check nonsymbol-id? x 'bound-identifier=?)
2019 (arg-check nonsymbol-id? y 'bound-identifier=?)
2023 (lambda (object . messages)
2024 (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
2025 (let ((message (if (null? messages)
2027 (apply string-append messages))))
2028 (error-hook #f message (strip object empty-wrap)))))
2030 (set! install-global-transformer
2032 (arg-check symbol? sym 'define-syntax)
2033 (arg-check procedure? v 'define-syntax)
2034 (global-extend 'macro sym v)))
2036 ;;; syntax-dispatch expects an expression and a pattern. If the expression
2037 ;;; matches the pattern a list of the matching expressions for each
2038 ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2039 ;;; not work on r4rs implementations that violate the ieee requirement
2040 ;;; that #f and () be distinct.)
2042 ;;; The expression is matched with the pattern as follows:
2044 ;;; pattern: matches:
2047 ;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2049 ;;; #(free-id <key>) <key> with free-identifier=?
2050 ;;; #(each <pattern>) (<pattern>*)
2051 ;;; #(vector <pattern>) (list->vector <pattern>)
2052 ;;; #(atom <object>) <object> with "equal?"
2054 ;;; Vector cops out to pair under assumption that vectors are rare. If
2055 ;;; not, should convert to:
2056 ;;; #(vector <pattern>*) #(<pattern>*)
2064 (match-each (annotation-expression e) p w mod))
2066 (let ((first (match (car e) p w '() mod)))
2068 (let ((rest (match-each (cdr e) p w mod)))
2069 (and rest (cons first rest))))))
2072 (match-each (syntax-object-expression e)
2074 (join-wraps w (syntax-object-wrap e))
2075 (syntax-object-module e)))
2078 (define match-each-any
2082 (match-each-any (annotation-expression e) w mod))
2084 (let ((l (match-each-any (cdr e) w mod)))
2085 (and l (cons (wrap (car e) w mod) l))))
2088 (match-each-any (syntax-object-expression e)
2089 (join-wraps w (syntax-object-wrap e))
2097 ((eq? p 'any) (cons '() r))
2098 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2099 ((eq? p 'each-any) (cons '() r))
2101 (case (vector-ref p 0)
2102 ((each) (match-empty (vector-ref p 1) r))
2104 ((vector) (match-empty (vector-ref p 1) r)))))))
2107 (lambda (e p w r mod)
2109 ((null? p) (and (null? e) r))
2111 (and (pair? e) (match (car e) (car p) w
2112 (match (cdr e) (cdr p) w r mod)
2115 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2117 (case (vector-ref p 0)
2120 (match-empty (vector-ref p 1) r)
2121 (let ((l (match-each e (vector-ref p 1) w mod)))
2123 (let collect ((l l))
2126 (cons (map car l) (collect (map cdr l)))))))))
2127 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2128 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2131 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2134 (lambda (e p w r mod)
2137 ((eq? p 'any) (cons (wrap e w mod) r))
2140 (unannotate (syntax-object-expression e))
2142 (join-wraps w (syntax-object-wrap e))
2144 (syntax-object-module e)))
2145 (else (match* (unannotate e) p w r mod)))))
2147 (set! syntax-dispatch
2150 ((eq? p 'any) (list e))
2152 (match* (unannotate (syntax-object-expression e))
2153 p (syntax-object-wrap e) '() (syntax-object-module e)))
2154 (else (match* (unannotate e) p empty-wrap '() #f)))))
2160 (define-syntax with-syntax
2164 (syntax (begin e1 e2 ...)))
2165 ((_ ((out in)) e1 e2 ...)
2166 (syntax (syntax-case in () (out (begin e1 e2 ...)))))
2167 ((_ ((out in) ...) e1 e2 ...)
2168 (syntax (syntax-case (list in ...) ()
2169 ((out ...) (begin e1 e2 ...))))))))
2171 (define-syntax syntax-rules
2174 ((_ (k ...) ((keyword . pattern) template) ...)
2176 (syntax-case x (k ...)
2177 ((dummy . pattern) (syntax template))
2183 ((let* ((x v) ...) e1 e2 ...)
2184 (andmap identifier? (syntax (x ...)))
2185 (let f ((bindings (syntax ((x v) ...))))
2186 (if (null? bindings)
2187 (syntax (let () e1 e2 ...))
2188 (with-syntax ((body (f (cdr bindings)))
2189 (binding (car bindings)))
2190 (syntax (let (binding) body)))))))))
2194 (syntax-case orig-x ()
2195 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2196 (with-syntax (((step ...)
2201 (_ (syntax-error orig-x))))
2203 (syntax (step ...)))))
2204 (syntax-case (syntax (e1 ...)) ()
2205 (() (syntax (let doloop ((var init) ...)
2207 (begin c ... (doloop step ...))))))
2209 (syntax (let doloop ((var init) ...)
2212 (begin c ... (doloop step ...))))))))))))
2214 (define-syntax quasiquote
2218 (with-syntax ((x x) (y y))
2219 (syntax-case (syntax y) (quote list)
2221 (syntax-case (syntax x) (quote)
2222 ((quote dx) (syntax (quote (dx . dy))))
2223 (_ (if (null? (syntax dy))
2225 (syntax (cons x y))))))
2226 ((list . stuff) (syntax (list x . stuff)))
2227 (else (syntax (cons x y)))))))
2230 (with-syntax ((x x) (y y))
2231 (syntax-case (syntax y) (quote)
2232 ((quote ()) (syntax x))
2233 (_ (syntax (append x y)))))))
2236 (with-syntax ((x x))
2237 (syntax-case (syntax x) (quote list)
2238 ((quote (x ...)) (syntax (quote #(x ...))))
2239 ((list x ...) (syntax (vector x ...)))
2240 (_ (syntax (list->vector x)))))))
2243 (syntax-case p (unquote unquote-splicing quasiquote)
2247 (quasicons (syntax (quote unquote))
2248 (quasi (syntax (p)) (- lev 1)))))
2249 (((unquote-splicing p) . q)
2251 (quasiappend (syntax p) (quasi (syntax q) lev))
2252 (quasicons (quasicons (syntax (quote unquote-splicing))
2253 (quasi (syntax (p)) (- lev 1)))
2254 (quasi (syntax q) lev))))
2256 (quasicons (syntax (quote quasiquote))
2257 (quasi (syntax (p)) (+ lev 1))))
2259 (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
2260 (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
2261 (p (syntax (quote p)))))))
2264 ((_ e) (quasi (syntax e) 0))))))
2266 (define-syntax include
2270 (let ((p (open-input-file fn)))
2271 (let f ((x (read p)))
2273 (begin (close-input-port p) '())
2274 (cons (datum->syntax-object k x)
2278 (let ((fn (syntax-object->datum (syntax filename))))
2279 (with-syntax (((exp ...) (read-file fn (syntax k))))
2280 (syntax (begin exp ...))))))))
2282 (define-syntax unquote
2287 "expression ,~s not valid outside of quasiquote"
2288 (syntax-object->datum (syntax e)))))))
2290 (define-syntax unquote-splicing
2294 (error 'unquote-splicing
2295 "expression ,@~s not valid outside of quasiquote"
2296 (syntax-object->datum (syntax e)))))))
2303 ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
2305 (syntax-case clause (else)
2306 ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
2307 (((k ...) e1 e2 ...)
2308 (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
2309 (_ (syntax-error x)))
2310 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2311 (syntax-case clause (else)
2312 (((k ...) e1 e2 ...)
2313 (syntax (if (memv t '(k ...))
2316 (_ (syntax-error x))))))))
2317 (syntax (let ((t e)) body)))))))
2319 (define-syntax identifier-syntax
2327 (identifier? (syntax id))
2330 (syntax (e x (... ...)))))))))))