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) (interaction-environment))))
325 (define local-eval-hook
327 (eval `(,noexpand ,x) (interaction-environment))))
330 (lambda (who why what)
331 (error who "~a ~s" why what)))
333 (define-syntax gensym-hook
337 (define put-global-definition-hook
338 (lambda (symbol binding)
339 (putprop symbol '*sc-expander* binding)))
341 (define get-global-definition-hook
343 (getprop symbol '*sc-expander*)))
347 ;;; output constructors
348 (define (build-annotated src exp)
349 (if (and src (not (annotation? exp)))
350 (make-annotation exp src #t)
353 (define-syntax build-application
355 ((_ source fun-exp arg-exps)
356 (build-annotated source `(,fun-exp . ,arg-exps)))))
358 (define-syntax build-conditional
360 ((_ source test-exp then-exp else-exp)
361 (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
363 (define-syntax build-lexical-reference
366 (build-annotated source var))))
368 (define-syntax build-lexical-assignment
371 (build-annotated source `(set! ,var ,exp)))))
373 (define-syntax build-global-reference
376 (build-annotated source var))))
378 (define-syntax build-global-assignment
381 (build-annotated source `(set! ,var ,exp)))))
383 (define-syntax build-global-definition
386 (build-annotated source `(define ,var ,exp)))))
388 (define-syntax build-lambda
391 (build-annotated src `(lambda ,vars ,exp)))))
393 (define-syntax build-primref
395 ((_ src name) (build-annotated src name))
396 ((_ src level name) (build-annotated src name))))
398 (define (build-data src exp)
399 (if (and (self-evaluating? exp)
401 (build-annotated src exp)
402 (build-annotated src (list 'quote exp))))
404 (define build-sequence
406 (if (null? (cdr exps))
407 (build-annotated src (car exps))
408 (build-annotated src `(begin ,@exps)))))
411 (lambda (src vars val-exps body-exp)
413 (build-annotated src body-exp)
414 (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
416 (define build-named-let
417 (lambda (src vars val-exps body-exp)
419 (build-annotated src body-exp)
422 ,(map list (cdr vars) val-exps) ,body-exp)))))
425 (lambda (src vars val-exps body-exp)
427 (build-annotated src body-exp)
429 `(letrec ,(map list vars val-exps) ,body-exp)))))
431 (define-syntax build-lexical-var
433 ((_ src id) (build-annotated src (gensym (symbol->string id))))))
435 (define-structure (syntax-object expression wrap))
437 (define-syntax unannotate
442 (annotation-expression e)
445 (define-syntax no-source (identifier-syntax #f))
447 (define source-annotation
450 ((annotation? x) (annotation-source x))
451 ((syntax-object? x) (source-annotation (syntax-object-expression x)))
454 (define-syntax arg-check
458 (if (not (pred? x)) (error-hook who "invalid argument" x))))))
460 ;;; compile-time environments
462 ;;; wrap and environment comprise two level mapping.
463 ;;; wrap : id --> label
464 ;;; env : label --> <element>
466 ;;; environments are represented in two parts: a lexical part and a global
467 ;;; part. The lexical part is a simple list of associations from labels
468 ;;; to bindings. The global part is implemented by
469 ;;; {put,get}-global-definition-hook and associates symbols with
472 ;;; global (assumed global variable) and displaced-lexical (see below)
473 ;;; do not show up in any environment; instead, they are fabricated by
474 ;;; lookup when it finds no other bindings.
476 ;;; <environment> ::= ((<label> . <binding>)*)
478 ;;; identifier bindings include a type and a value
480 ;;; <binding> ::= (macro . <procedure>) macros
481 ;;; (core . <procedure>) core forms
482 ;;; (external-macro . <procedure>) external-macro
485 ;;; (define-syntax) define-syntax
486 ;;; (local-syntax . rec?) let-syntax/letrec-syntax
487 ;;; (eval-when) eval-when
488 ;;; (syntax . (<var> . <level>)) pattern variables
489 ;;; (global) assumed global variable
490 ;;; (lexical . <var>) lexical variables
491 ;;; (displaced-lexical) displaced lexicals
492 ;;; <level> ::= <nonnegative integer>
493 ;;; <var> ::= variable returned by build-lexical-var
495 ;;; a macro is a user-defined syntactic-form. a core is a system-defined
496 ;;; syntactic form. begin, define, define-syntax, and eval-when are
497 ;;; treated specially since they are sensitive to whether the form is
498 ;;; at top-level and (except for eval-when) can denote valid internal
501 ;;; a pattern variable is a variable introduced by syntax-case and can
502 ;;; be referenced only within a syntax form.
504 ;;; any identifier for which no top-level syntax definition or local
505 ;;; binding of any kind has been seen is assumed to be a global
508 ;;; a lexical variable is a lambda- or letrec-bound variable.
510 ;;; a displaced-lexical identifier is a lexical identifier removed from
511 ;;; it's scope by the return of a syntax object containing the identifier.
512 ;;; a displaced lexical can also appear when a letrec-syntax-bound
513 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
514 ;;; a displaced lexical should never occur with properly written macros.
516 (define-syntax make-binding
517 (syntax-rules (quote)
518 ((_ type value) (cons type value))
520 ((_ type) (cons type '()))))
521 (define binding-type car)
522 (define binding-value cdr)
524 (define-syntax null-env (identifier-syntax '()))
527 (lambda (labels bindings r)
530 (extend-env (cdr labels) (cdr bindings)
531 (cons (cons (car labels) (car bindings)) r)))))
533 (define extend-var-env
534 ; variant of extend-env that forms "lexical" binding
535 (lambda (labels vars r)
538 (extend-var-env (cdr labels) (cdr vars)
539 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
541 ;;; we use a "macros only" environment in expansion of local macro
542 ;;; definitions so that their definitions can use local macros without
543 ;;; attempting to use other lexical identifiers.
544 (define macros-only-env
549 (if (eq? (cadr a) 'macro)
550 (cons a (macros-only-env (cdr r)))
551 (macros-only-env (cdr r)))))))
554 ; x may be a label or a symbol
555 ; although symbols are usually global, we check the environment first
556 ; anyway because a temporary binding may have been established by
562 (or (get-global-definition-hook x) (make-binding 'global)))
563 (else (make-binding 'displaced-lexical)))))
565 (define global-extend
566 (lambda (type sym val)
567 (put-global-definition-hook sym (make-binding type val))))
570 ;;; Conceptually, identifiers are always syntax objects. Internally,
571 ;;; however, the wrap is sometimes maintained separately (a source of
572 ;;; efficiency and confusion), so that symbols are also considered
573 ;;; identifiers by id?. Externally, they are always wrapped.
575 (define nonsymbol-id?
577 (and (syntax-object? x)
578 (symbol? (unannotate (syntax-object-expression x))))))
584 ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
585 ((annotation? x) (symbol? (annotation-expression x)))
588 (define-syntax id-sym-name
592 (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
594 (define id-sym-name&marks
596 (if (syntax-object? x)
598 (unannotate (syntax-object-expression x))
599 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
600 (values (unannotate x) (wrap-marks w)))))
602 ;;; syntax object wraps
604 ;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
605 ;;; <subst> ::= <shift> | <subs>
606 ;;; <subs> ::= #(<old name> <label> (<mark> ...))
607 ;;; <shift> ::= positive fixnum
609 (define make-wrap cons)
610 (define wrap-marks car)
611 (define wrap-subst cdr)
613 (define-syntax subst-rename? (identifier-syntax vector?))
614 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
615 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
616 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
617 (define-syntax make-rename
619 ((_ old new marks) (vector old new marks))))
621 ;;; labels must be comparable with "eq?" and distinct from symbols.
623 (lambda () (string #\i)))
629 (cons (gen-label) (gen-labels (cdr ls))))))
631 (define-structure (ribcage symnames marks labels))
633 (define-syntax empty-wrap (identifier-syntax '(())))
635 (define-syntax top-wrap (identifier-syntax '((top))))
637 (define-syntax top-marked?
639 ((_ w) (memq 'top (wrap-marks w)))))
641 ;;; Marks must be comparable with "eq?" and distinct from pairs and
642 ;;; the symbol top. We do not use integers so that marks will remain
643 ;;; unique even across file compiles.
645 (define-syntax the-anti-mark (identifier-syntax #f))
649 (make-wrap (cons the-anti-mark (wrap-marks w))
650 (cons 'shift (wrap-subst w)))))
652 (define-syntax new-mark
656 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
657 ;;; internal definitions, in which the ribcages are built incrementally
658 (define-syntax make-empty-ribcage
660 ((_) (make-ribcage '() '() '()))))
662 (define extend-ribcage!
663 ; must receive ids with complete wraps
664 (lambda (ribcage id label)
665 (set-ribcage-symnames! ribcage
666 (cons (unannotate (syntax-object-expression id))
667 (ribcage-symnames ribcage)))
668 (set-ribcage-marks! ribcage
669 (cons (wrap-marks (syntax-object-wrap id))
670 (ribcage-marks ribcage)))
671 (set-ribcage-labels! ribcage
672 (cons label (ribcage-labels ribcage)))))
674 ;;; make-binding-wrap creates vector-based ribcages
675 (define make-binding-wrap
676 (lambda (ids labels w)
682 (let ((labelvec (list->vector labels)))
683 (let ((n (vector-length labelvec)))
684 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
685 (let f ((ids ids) (i 0))
686 (if (not (null? ids))
688 (lambda () (id-sym-name&marks (car ids) w))
689 (lambda (symname marks)
690 (vector-set! symnamevec i symname)
691 (vector-set! marksvec i marks)
692 (f (cdr ids) (fx+ i 1))))))
693 (make-ribcage symnamevec marksvec labelvec))))
704 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
710 (smart-append s1 (wrap-subst w2))))
712 (smart-append m1 (wrap-marks w2))
713 (smart-append s1 (wrap-subst w2)))))))
717 (smart-append m1 m2)))
724 (eq? (car x) (car y))
725 (same-marks? (cdr x) (cdr y))))))
731 ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
733 (lambda (sym subst marks)
736 (let ((fst (car subst)))
738 (search sym (cdr subst) (cdr marks))
739 (let ((symnames (ribcage-symnames fst)))
740 (if (vector? symnames)
741 (search-vector-rib sym subst marks symnames fst)
742 (search-list-rib sym subst marks symnames fst))))))))
743 (define search-list-rib
744 (lambda (sym subst marks symnames ribcage)
745 (let f ((symnames symnames) (i 0))
747 ((null? symnames) (search sym (cdr subst) marks))
748 ((and (eq? (car symnames) sym)
749 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
750 (values (list-ref (ribcage-labels ribcage) i) marks))
751 (else (f (cdr symnames) (fx+ i 1)))))))
752 (define search-vector-rib
753 (lambda (sym subst marks symnames ribcage)
754 (let ((n (vector-length symnames)))
757 ((fx= i n) (search sym (cdr subst) marks))
758 ((and (eq? (vector-ref symnames i) sym)
759 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
760 (values (vector-ref (ribcage-labels ribcage) i) marks))
761 (else (f (fx+ i 1))))))))
764 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
766 (let ((id (unannotate (syntax-object-expression id)))
767 (w1 (syntax-object-wrap id)))
768 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
769 (call-with-values (lambda () (search id (wrap-subst w) marks))
770 (lambda (new-id marks)
772 (first (search id (wrap-subst w1) marks))
775 (let ((id (unannotate id)))
776 (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
777 (else (error-hook 'id-var-name "invalid id" id)))))
779 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
780 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
784 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
785 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
787 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
788 ;;; long as the missing portion of the wrap is common to both of the ids
789 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
793 (if (and (syntax-object? i) (syntax-object? j))
794 (and (eq? (unannotate (syntax-object-expression i))
795 (unannotate (syntax-object-expression j)))
796 (same-marks? (wrap-marks (syntax-object-wrap i))
797 (wrap-marks (syntax-object-wrap j))))
798 (eq? (unannotate i) (unannotate j)))))
800 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
801 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
802 ;;; as long as the missing portion of the wrap is common to all of the
805 (define valid-bound-ids?
807 (and (let all-ids? ((ids ids))
810 (all-ids? (cdr ids)))))
811 (distinct-bound-ids? ids))))
813 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
814 ;;; no duplicates. It is quadratic on the length of the id list; long
815 ;;; lists could be sorted to make it more efficient. distinct-bound-ids?
816 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
817 ;;; missing portion of the wrap is common to all of the ids.
819 (define distinct-bound-ids?
821 (let distinct? ((ids ids))
823 (and (not (bound-id-member? (car ids) (cdr ids)))
824 (distinct? (cdr ids)))))))
826 (define bound-id-member?
828 (and (not (null? list))
829 (or (bound-id=? x (car list))
830 (bound-id-member? x (cdr list))))))
832 ;;; wrapping expressions and identifiers
837 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
840 (syntax-object-expression x)
841 (join-wraps w (syntax-object-wrap x))))
843 (else (make-syntax-object x w)))))
847 (wrap (if s (make-annotation x s #f) x) w)))
854 (let dobody ((body body) (r r) (w w))
857 (let ((first (chi (car body) r w)))
858 (cons first (dobody (cdr body) r w))))))))
860 (define chi-top-sequence
861 (lambda (body r w s m esew)
863 (let dobody ((body body) (r r) (w w) (m m) (esew esew))
866 (let ((first (chi-top (car body) r w m esew)))
867 (cons first (dobody (cdr body) r w m esew))))))))
869 (define chi-install-global
871 (build-application no-source
872 (build-primref no-source 'install-global-transformer)
873 (list (build-data no-source name) e))))
875 (define chi-when-list
876 (lambda (e when-list w)
877 ; when-list is syntax'd version of list of situations
878 (let f ((when-list when-list) (situations '()))
879 (if (null? when-list)
882 (cons (let ((x (car when-list)))
884 ((free-id=? x (syntax compile)) 'compile)
885 ((free-id=? x (syntax load)) 'load)
886 ((free-id=? x (syntax eval)) 'eval)
887 (else (syntax-error (wrap x w)
888 "invalid eval-when situation"))))
891 ;;; syntax-type returns five values: type, value, e, w, and s. The first
892 ;;; two are described in the table below.
894 ;;; type value explanation
895 ;;; -------------------------------------------------------------------
896 ;;; core procedure core form (including singleton)
897 ;;; external-macro procedure external macro
898 ;;; lexical name lexical variable reference
899 ;;; global name global variable reference
900 ;;; begin none begin keyword
901 ;;; define none define keyword
902 ;;; define-syntax none define-syntax keyword
903 ;;; local-syntax rec? letrec-syntax/let-syntax keyword
904 ;;; eval-when none eval-when keyword
905 ;;; syntax level pattern variable
906 ;;; displaced-lexical none displaced lexical identifier
907 ;;; lexical-call name call to lexical variable
908 ;;; global-call name call to global variable
909 ;;; call none any other call
910 ;;; begin-form none begin expression
911 ;;; define-form id variable definition
912 ;;; define-syntax-form id syntax definition
913 ;;; local-syntax-form rec? syntax definition
914 ;;; eval-when-form none eval-when form
915 ;;; constant none self-evaluating datum
916 ;;; other none anything else
918 ;;; For define-form and define-syntax-form, e is the rhs expression.
919 ;;; For all others, e is the entire form. w is the wrap for e.
920 ;;; s is the source for the entire form.
922 ;;; syntax-type expands macros and unwraps as necessary to get to
923 ;;; one of the forms above. It also parses define and define-syntax
924 ;;; forms, although perhaps this should be done by the consumer.
927 (lambda (e r w s rib)
930 (let* ((n (id-var-name e w))
932 (type (binding-type b)))
934 ((lexical) (values type (binding-value b) e w s))
935 ((global) (values type n e w s))
937 (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
938 (else (values type (binding-value b) e w s)))))
940 (let ((first (car e)))
942 (let* ((n (id-var-name first w))
944 (type (binding-type b)))
946 ((lexical) (values 'lexical-call (binding-value b) e w s))
947 ((global) (values 'global-call n e w s))
949 (syntax-type (chi-macro (binding-value b) e r w rib)
951 ((core external-macro) (values type (binding-value b) e w s))
953 (values 'local-syntax-form (binding-value b) e w s))
954 ((begin) (values 'begin-form #f e w s))
955 ((eval-when) (values 'eval-when-form #f e w s))
960 (values 'define-form (syntax name) (syntax val) w s))
961 ((_ (name . args) e1 e2 ...)
962 (and (id? (syntax name))
963 (valid-bound-ids? (lambda-var-list (syntax args))))
964 ; need lambda here...
965 (values 'define-form (wrap (syntax name) w)
966 (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
970 (values 'define-form (wrap (syntax name) w)
977 (values 'define-syntax-form (syntax name)
979 (else (values 'call #f e w s))))
980 (values 'call #f e w s))))
982 ;; s can't be valid source if we've unwrapped
983 (syntax-type (syntax-object-expression e)
985 (join-wraps w (syntax-object-wrap e))
988 (syntax-type (annotation-expression e) r w (annotation-source e) rib))
989 ((self-evaluating? e) (values 'constant #f e w s))
990 (else (values 'other #f e w s)))))
993 (lambda (e r w m esew)
994 (define-syntax eval-if-c&e
998 (if (eq? m 'c&e) (top-level-eval-hook x))
1001 (lambda () (syntax-type e r w no-source #f))
1002 (lambda (type value e w s)
1008 (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
1009 ((local-syntax-form)
1010 (chi-local-syntax value e r w s
1011 (lambda (body r w s)
1012 (chi-top-sequence body r w s m esew))))
1015 ((_ (x ...) e1 e2 ...)
1016 (let ((when-list (chi-when-list e (syntax (x ...)) w))
1017 (body (syntax (e1 e2 ...))))
1020 (if (memq 'eval when-list)
1021 (chi-top-sequence body r w s 'e '(eval))
1023 ((memq 'load when-list)
1024 (if (or (memq 'compile when-list)
1025 (and (eq? m 'c&e) (memq 'eval when-list)))
1026 (chi-top-sequence body r w s 'c&e '(compile load))
1027 (if (memq m '(c c&e))
1028 (chi-top-sequence body r w s 'c '(load))
1030 ((or (memq 'compile when-list)
1031 (and (eq? m 'c&e) (memq 'eval when-list)))
1032 (top-level-eval-hook
1033 (chi-top-sequence body r w s 'e '(eval)))
1035 (else (chi-void)))))))
1036 ((define-syntax-form)
1037 (let ((n (id-var-name value w)) (r (macros-only-env r)))
1040 (if (memq 'compile esew)
1041 (let ((e (chi-install-global n (chi e r w))))
1042 (top-level-eval-hook e)
1043 (if (memq 'load esew) e (chi-void)))
1044 (if (memq 'load esew)
1045 (chi-install-global n (chi e r w))
1048 (let ((e (chi-install-global n (chi e r w))))
1049 (top-level-eval-hook e)
1052 (if (memq 'eval esew)
1053 (top-level-eval-hook
1054 (chi-install-global n (chi e r w))))
1057 (let* ((n (id-var-name value w))
1058 (type (binding-type (lookup n r))))
1062 (build-global-definition s n (chi e r w))))
1063 ((displaced-lexical)
1064 (syntax-error (wrap value w) "identifier out of context"))
1066 (if (eq? type 'external-macro)
1068 (build-global-definition s n (chi e r w)))
1069 (syntax-error (wrap value w)
1070 "cannot define keyword at top level"))))))
1071 (else (eval-if-c&e m (chi-expr type value e r w s))))))))
1076 (lambda () (syntax-type e r w no-source #f))
1077 (lambda (type value e w s)
1078 (chi-expr type value e r w s)))))
1081 (lambda (type value e r w s)
1084 (build-lexical-reference 'value s value))
1085 ((core external-macro) (value e r w s))
1088 (build-lexical-reference 'fun (source-annotation (car e)) value)
1092 (build-global-reference (source-annotation (car e)) value)
1094 ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
1095 ((global) (build-global-reference s value))
1096 ((call) (chi-application (chi (car e) r w) e r w s))
1099 ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
1100 ((local-syntax-form)
1101 (chi-local-syntax value e r w s chi-sequence))
1104 ((_ (x ...) e1 e2 ...)
1105 (let ((when-list (chi-when-list e (syntax (x ...)) w)))
1106 (if (memq 'eval when-list)
1107 (chi-sequence (syntax (e1 e2 ...)) r w s)
1109 ((define-form define-syntax-form)
1110 (syntax-error (wrap value w) "invalid context for definition of"))
1112 (syntax-error (source-wrap e w s)
1113 "reference to pattern variable outside syntax form"))
1114 ((displaced-lexical)
1115 (syntax-error (source-wrap e w s)
1116 "reference to identifier outside its scope"))
1117 (else (syntax-error (source-wrap e w s))))))
1119 (define chi-application
1123 (build-application s x
1124 (map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))
1127 (lambda (p e r w rib)
1128 (define rebuild-macro-output
1131 (cons (rebuild-macro-output (car x) m)
1132 (rebuild-macro-output (cdr x) m)))
1134 (let ((w (syntax-object-wrap x)))
1135 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1136 (make-syntax-object (syntax-object-expression x)
1137 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1139 (if rib (cons rib (cdr s)) (cdr s)))
1140 (make-wrap (cons m ms)
1142 (cons rib (cons 'shift s))
1143 (cons 'shift s))))))))
1145 (let* ((n (vector-length x)) (v (make-vector n)))
1146 (do ((i 0 (fx+ i 1)))
1149 (rebuild-macro-output (vector-ref x i) m)))))
1151 (syntax-error x "encountered raw symbol in macro output"))
1153 (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))
1156 ;; In processing the forms of the body, we create a new, empty wrap.
1157 ;; This wrap is augmented (destructively) each time we discover that
1158 ;; the next form is a definition. This is done:
1160 ;; (1) to allow the first nondefinition form to be a call to
1161 ;; one of the defined ids even if the id previously denoted a
1162 ;; definition keyword or keyword for a macro expanding into a
1164 ;; (2) to prevent subsequent definition forms (but unfortunately
1165 ;; not earlier ones) and the first nondefinition form from
1166 ;; confusing one of the bound identifiers for an auxiliary
1168 ;; (3) so that we do not need to restart the expansion of the
1169 ;; first nondefinition form, which is problematic anyway
1170 ;; since it might be the first element of a begin that we
1171 ;; have just spliced into the body (meaning if we restarted,
1172 ;; we'd really need to restart with the begin or the macro
1173 ;; call that expanded into the begin, and we'd have to give
1174 ;; up allowing (begin <defn>+ <expr>+), which is itself
1175 ;; problematic since we don't know if a begin contains only
1176 ;; definitions until we've expanded it).
1178 ;; Before processing the body, we also create a new environment
1179 ;; containing a placeholder for the bindings we will add later and
1180 ;; associate this environment with each form. In processing a
1181 ;; let-syntax or letrec-syntax, the associated environment may be
1182 ;; augmented with local keyword bindings, so the environment may
1183 ;; be different for different forms in the body. Once we have
1184 ;; gathered up all of the definitions, we evaluate the transformer
1185 ;; expressions and splice into r at the placeholder the new variable
1186 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1187 ;; forms local to a portion or all of the body to shadow the
1188 ;; definition bindings.
1190 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1193 ;; outer-form is fully wrapped w/source
1194 (lambda (body outer-form r w)
1195 (let* ((r (cons '("placeholder" . (placeholder)) r))
1196 (ribcage (make-empty-ribcage))
1197 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1198 (let parse ((body (map (lambda (x) (cons r (wrap x w))) body))
1199 (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
1201 (syntax-error outer-form "no expressions in body")
1202 (let ((e (cdar body)) (er (caar body)))
1204 (lambda () (syntax-type e er empty-wrap no-source ribcage))
1205 (lambda (type value e w s)
1208 (let ((id (wrap value w)) (label (gen-label)))
1209 (let ((var (gen-var id)))
1210 (extend-ribcage! ribcage id label)
1212 (cons id ids) (cons label labels)
1213 (cons var vars) (cons (cons er (wrap e w)) vals)
1214 (cons (make-binding 'lexical var) bindings)))))
1215 ((define-syntax-form)
1216 (let ((id (wrap value w)) (label (gen-label)))
1217 (extend-ribcage! ribcage id label)
1219 (cons id ids) (cons label labels)
1221 (cons (make-binding 'macro (cons er (wrap e w)))
1226 (parse (let f ((forms (syntax (e1 ...))))
1229 (cons (cons er (wrap (car forms) w))
1231 ids labels vars vals bindings))))
1232 ((local-syntax-form)
1233 (chi-local-syntax value e er w s
1234 (lambda (forms er w s)
1235 (parse (let f ((forms forms))
1238 (cons (cons er (wrap (car forms) w))
1240 ids labels vars vals bindings))))
1241 (else ; found a non-definition
1243 (build-sequence no-source
1245 (chi (cdr x) (car x) empty-wrap))
1246 (cons (cons er (source-wrap e w s))
1249 (if (not (valid-bound-ids? ids))
1250 (syntax-error outer-form
1251 "invalid or duplicate identifier in definition"))
1252 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1253 (if (not (null? bs))
1254 (let* ((b (car bs)))
1255 (if (eq? (car b) 'macro)
1256 (let* ((er (cadr b))
1258 (if (eq? er er-cache)
1260 (macros-only-env er))))
1262 (eval-local-transformer
1263 (chi (cddr b) r-cache empty-wrap)))
1264 (loop (cdr bs) er r-cache))
1265 (loop (cdr bs) er-cache r-cache)))))
1266 (set-cdr! r (extend-env labels bindings (cdr r)))
1267 (build-letrec no-source
1270 (chi (cdr x) (car x) empty-wrap))
1272 (build-sequence no-source
1274 (chi (cdr x) (car x) empty-wrap))
1275 (cons (cons er (source-wrap e w s))
1276 (cdr body)))))))))))))))))
1278 (define chi-lambda-clause
1281 (((id ...) e1 e2 ...)
1282 (let ((ids (syntax (id ...))))
1283 (if (not (valid-bound-ids? ids))
1284 (syntax-error e "invalid parameter list in")
1285 (let ((labels (gen-labels ids))
1286 (new-vars (map gen-var ids)))
1288 (chi-body (syntax (e1 e2 ...))
1290 (extend-var-env labels new-vars r)
1291 (make-binding-wrap ids labels w)))))))
1293 (let ((old-ids (lambda-var-list (syntax ids))))
1294 (if (not (valid-bound-ids? old-ids))
1295 (syntax-error e "invalid parameter list in")
1296 (let ((labels (gen-labels old-ids))
1297 (new-vars (map gen-var old-ids)))
1298 (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
1301 (f (cdr ls1) (cons (car ls1) ls2))))
1302 (chi-body (syntax (e1 e2 ...))
1304 (extend-var-env labels new-vars r)
1305 (make-binding-wrap old-ids labels w)))))))
1306 (_ (syntax-error e)))))
1308 (define chi-local-syntax
1309 (lambda (rec? e r w s k)
1311 ((_ ((id val) ...) e1 e2 ...)
1312 (let ((ids (syntax (id ...))))
1313 (if (not (valid-bound-ids? ids))
1314 (syntax-error e "duplicate bound keyword in")
1315 (let ((labels (gen-labels ids)))
1316 (let ((new-w (make-binding-wrap ids labels w)))
1317 (k (syntax (e1 e2 ...))
1320 (let ((w (if rec? new-w w))
1321 (trans-r (macros-only-env r)))
1323 (make-binding 'macro
1324 (eval-local-transformer (chi x trans-r w))))
1325 (syntax (val ...))))
1329 (_ (syntax-error (source-wrap e w s))))))
1331 (define eval-local-transformer
1333 (let ((p (local-eval-hook expanded)))
1336 (syntax-error p "nonprocedure transformer")))))
1340 (build-application no-source (build-primref no-source 'void) '())))
1344 (and (nonsymbol-id? x)
1345 (free-id=? x (syntax (... ...))))))
1349 ;;; strips all annotations from potentially circular reader output
1351 (define strip-annotation
1355 (let ((new (cons #f #f)))
1356 (if parent (set-annotation-stripped! parent new))
1357 (set-car! new (strip-annotation (car x) #f))
1358 (set-cdr! new (strip-annotation (cdr x) #f))
1361 (or (annotation-stripped x)
1362 (strip-annotation (annotation-expression x) x)))
1364 (let ((new (make-vector (vector-length x))))
1365 (if parent (set-annotation-stripped! parent new))
1366 (let loop ((i (- (vector-length x) 1)))
1368 (vector-set! new i (strip-annotation (vector-ref x i) #f))
1373 ;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
1374 ;;; on an annotation, strips the annotation as well.
1375 ;;; since only the head of a list is annotated by the reader, not each pair
1376 ;;; in the spine, we also check for pairs whose cars are annotated in case
1377 ;;; we've been passed the cdr of an annotated list
1382 (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
1383 (strip-annotation x #f)
1388 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1390 (let ((a (f (car x))) (d (f (cdr x))))
1391 (if (and (eq? a (car x)) (eq? d (cdr x)))
1395 (let ((old (vector->list x)))
1396 (let ((new (map f old)))
1397 (if (andmap eq? old new) x (list->vector new)))))
1400 ;;; lexical variables
1404 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1405 (if (annotation? id)
1406 (build-lexical-var (annotation-source id) (annotation-expression id))
1407 (build-lexical-var no-source id)))))
1409 (define lambda-var-list
1411 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1413 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
1414 ((id? vars) (cons (wrap vars w) ls))
1416 ((syntax-object? vars)
1417 (lvl (syntax-object-expression vars)
1419 (join-wraps w (syntax-object-wrap vars))))
1421 (lvl (annotation-expression vars) ls w))
1422 ; include anything else to be caught by subsequent error
1424 (else (cons vars ls))))))
1426 ;;; core transformers
1428 (global-extend 'local-syntax 'letrec-syntax #t)
1429 (global-extend 'local-syntax 'let-syntax #f)
1431 (global-extend 'core 'fluid-let-syntax
1434 ((_ ((var val) ...) e1 e2 ...)
1435 (valid-bound-ids? (syntax (var ...)))
1436 (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
1439 (case (binding-type (lookup n r))
1440 ((displaced-lexical)
1441 (syntax-error (source-wrap id w s)
1442 "identifier out of context"))))
1446 (syntax (e1 e2 ...))
1450 (let ((trans-r (macros-only-env r)))
1452 (make-binding 'macro
1453 (eval-local-transformer (chi x trans-r w))))
1454 (syntax (val ...))))
1457 (_ (syntax-error (source-wrap e w s))))))
1459 (global-extend 'core 'quote
1462 ((_ e) (build-data s (strip (syntax e) w)))
1463 (_ (syntax-error (source-wrap e w s))))))
1465 (global-extend 'core 'syntax
1468 (lambda (src e r maps ellipsis?)
1470 (let ((label (id-var-name e empty-wrap)))
1471 (let ((b (lookup label r)))
1472 (if (eq? (binding-type b) 'syntax)
1475 (let ((var.lev (binding-value b)))
1476 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1477 (lambda (var maps) (values `(ref ,var) maps)))
1479 (syntax-error src "misplaced ellipsis in syntax form")
1480 (values `(quote ,e) maps)))))
1483 (ellipsis? (syntax dots))
1484 (gen-syntax src (syntax e) r maps (lambda (x) #f)))
1486 ; this could be about a dozen lines of code, except that we
1487 ; choose to handle (syntax (x ... ...)) forms
1488 (ellipsis? (syntax dots))
1489 (let f ((y (syntax y))
1493 (gen-syntax src (syntax x) r
1494 (cons '() maps) ellipsis?))
1496 (if (null? (car maps))
1498 "extra ellipsis in syntax form")
1499 (values (gen-map x (car maps))
1503 (ellipsis? (syntax dots))
1507 (lambda () (k (cons '() maps)))
1509 (if (null? (car maps))
1511 "extra ellipsis in syntax form")
1512 (values (gen-mappend x (car maps))
1514 (_ (call-with-values
1515 (lambda () (gen-syntax src y r maps ellipsis?))
1518 (lambda () (k maps))
1520 (values (gen-append x y) maps)))))))))
1523 (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
1526 (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
1527 (lambda (y maps) (values (gen-cons x y) maps))))))
1531 (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
1532 (lambda (e maps) (values (gen-vector e) maps))))
1533 (_ (values `(quote ,e) maps))))))
1536 (lambda (src var level maps)
1540 (syntax-error src "missing ellipsis in syntax form")
1542 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1543 (lambda (outer-var outer-maps)
1544 (let ((b (assq outer-var (car maps))))
1546 (values (cdr b) maps)
1547 (let ((inner-var (gen-var 'tmp)))
1549 (cons (cons (cons outer-var inner-var)
1551 outer-maps)))))))))))
1555 `(apply (primitive append) ,(gen-map e map-env))))
1559 (let ((formals (map cdr map-env))
1560 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1563 ; identity map equivalence:
1564 ; (map (lambda (x) x) y) == y
1567 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1569 ; eta map equivalence:
1570 ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1571 `(map (primitive ,(car e))
1572 ,@(map (let ((r (map cons formals actuals)))
1573 (lambda (x) (cdr (assq (cadr x) r))))
1575 (else `(map (lambda ,formals ,e) ,@actuals))))))
1581 (if (eq? (car x) 'quote)
1582 `(quote (,(cadr x) . ,(cadr y)))
1583 (if (eq? (cadr y) '())
1586 ((list) `(list ,x ,@(cdr y)))
1587 (else `(cons ,x ,y)))))
1591 (if (equal? y '(quote ()))
1598 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1599 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1600 (else `(list->vector ,x)))))
1606 ((ref) (build-lexical-reference 'value no-source (cadr x)))
1607 ((primitive) (build-primref no-source (cadr x)))
1608 ((quote) (build-data no-source (cadr x)))
1609 ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
1610 ((map) (let ((ls (map regen (cdr x))))
1611 (build-application no-source
1612 (if (fx= (length ls) 2)
1613 (build-primref no-source 'map)
1614 ; really need to do our own checking here
1615 (build-primref no-source 2 'map)) ; require error check
1617 (else (build-application no-source
1618 (build-primref no-source (car x))
1619 (map regen (cdr x)))))))
1622 (let ((e (source-wrap e w s)))
1626 (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
1627 (lambda (e maps) (regen e))))
1628 (_ (syntax-error e)))))))
1631 (global-extend 'core 'lambda
1635 (chi-lambda-clause (source-wrap e w s) (syntax c) r w
1636 (lambda (vars body) (build-lambda s vars body)))))))
1639 (global-extend 'core 'let
1641 (define (chi-let e r w s constructor ids vals exps)
1642 (if (not (valid-bound-ids? ids))
1643 (syntax-error e "duplicate bound variable in")
1644 (let ((labels (gen-labels ids))
1645 (new-vars (map gen-var ids)))
1646 (let ((nw (make-binding-wrap ids labels w))
1647 (nr (extend-var-env labels new-vars r)))
1650 (map (lambda (x) (chi x r w)) vals)
1651 (chi-body exps (source-wrap e nw s) nr nw))))))
1654 ((_ ((id val) ...) e1 e2 ...)
1659 (syntax (e1 e2 ...))))
1660 ((_ f ((id val) ...) e1 e2 ...)
1666 (syntax (e1 e2 ...))))
1667 (_ (syntax-error (source-wrap e w s)))))))
1670 (global-extend 'core 'letrec
1673 ((_ ((id val) ...) e1 e2 ...)
1674 (let ((ids (syntax (id ...))))
1675 (if (not (valid-bound-ids? ids))
1676 (syntax-error e "duplicate bound variable in")
1677 (let ((labels (gen-labels ids))
1678 (new-vars (map gen-var ids)))
1679 (let ((w (make-binding-wrap ids labels w))
1680 (r (extend-var-env labels new-vars r)))
1683 (map (lambda (x) (chi x r w)) (syntax (val ...)))
1684 (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
1685 (_ (syntax-error (source-wrap e w s))))))
1688 (global-extend 'core 'set!
1693 (let ((val (chi (syntax val) r w))
1694 (n (id-var-name (syntax id) w)))
1695 (let ((b (lookup n r)))
1696 (case (binding-type b)
1698 (build-lexical-assignment s (binding-value b) val))
1699 ((global) (build-global-assignment s n val))
1700 ((displaced-lexical)
1701 (syntax-error (wrap (syntax id) w)
1702 "identifier out of context"))
1703 (else (syntax-error (source-wrap e w s)))))))
1704 ((_ (getter arg ...) val)
1705 (build-application s
1706 (chi (syntax (setter getter)) r w)
1707 (map (lambda (e) (chi e r w))
1708 (syntax (arg ... val)))))
1709 (_ (syntax-error (source-wrap e w s))))))
1711 (global-extend 'begin 'begin '())
1713 (global-extend 'define 'define '())
1715 (global-extend 'define-syntax 'define-syntax '())
1717 (global-extend 'eval-when 'eval-when '())
1719 (global-extend 'core 'syntax-case
1721 (define convert-pattern
1722 ; accepts pattern & keys
1723 ; returns syntax-dispatch pattern & ids
1724 (lambda (pattern keys)
1725 (let cvt ((p pattern) (n 0) (ids '()))
1727 (if (bound-id-member? p keys)
1728 (values (vector 'free-id p) ids)
1729 (values 'any (cons (cons p n) ids)))
1732 (ellipsis? (syntax dots))
1734 (lambda () (cvt (syntax x) (fx+ n 1) ids))
1736 (values (if (eq? p 'any) 'each-any (vector 'each p))
1740 (lambda () (cvt (syntax y) n ids))
1743 (lambda () (cvt (syntax x) n ids))
1745 (values (cons x y) ids))))))
1746 (() (values '() ids))
1749 (lambda () (cvt (syntax (x ...)) n ids))
1750 (lambda (p ids) (values (vector 'vector p) ids))))
1751 (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
1753 (define build-dispatch-call
1754 (lambda (pvars exp y r)
1755 (let ((ids (map car pvars)) (levels (map cdr pvars)))
1756 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1757 (build-application no-source
1758 (build-primref no-source 'apply)
1759 (list (build-lambda no-source new-vars
1763 (map (lambda (var level)
1764 (make-binding 'syntax `(,var . ,level)))
1768 (make-binding-wrap ids labels empty-wrap)))
1772 (lambda (x keys clauses r pat fender exp)
1774 (lambda () (convert-pattern pat keys))
1777 ((not (distinct-bound-ids? (map car pvars)))
1779 "duplicate pattern variable in syntax-case pattern"))
1780 ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
1782 "misplaced ellipsis in syntax-case pattern"))
1784 (let ((y (gen-var 'tmp)))
1785 ; fat finger binding and references to temp variable y
1786 (build-application no-source
1787 (build-lambda no-source (list y)
1788 (let ((y (build-lexical-reference 'value no-source y)))
1789 (build-conditional no-source
1790 (syntax-case fender ()
1792 (_ (build-conditional no-source
1794 (build-dispatch-call pvars fender y r)
1795 (build-data no-source #f))))
1796 (build-dispatch-call pvars exp y r)
1797 (gen-syntax-case x keys clauses r))))
1798 (list (if (eq? p 'any)
1799 (build-application no-source
1800 (build-primref no-source 'list)
1802 (build-application no-source
1803 (build-primref no-source 'syntax-dispatch)
1804 (list x (build-data no-source p)))))))))))))
1806 (define gen-syntax-case
1807 (lambda (x keys clauses r)
1809 (build-application no-source
1810 (build-primref no-source 'syntax-error)
1812 (syntax-case (car clauses) ()
1814 (if (and (id? (syntax pat))
1815 (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
1816 (cons (syntax (... ...)) keys)))
1817 (let ((labels (list (gen-label)))
1818 (var (gen-var (syntax pat))))
1819 (build-application no-source
1820 (build-lambda no-source (list var)
1823 (list (make-binding 'syntax `(,var . 0)))
1825 (make-binding-wrap (syntax (pat))
1826 labels empty-wrap)))
1828 (gen-clause x keys (cdr clauses) r
1829 (syntax pat) #t (syntax exp))))
1831 (gen-clause x keys (cdr clauses) r
1832 (syntax pat) (syntax fender) (syntax exp)))
1833 (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
1836 (let ((e (source-wrap e w s)))
1838 ((_ val (key ...) m ...)
1839 (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
1841 (let ((x (gen-var 'tmp)))
1842 ; fat finger binding and references to temp variable x
1843 (build-application s
1844 (build-lambda no-source (list x)
1845 (gen-syntax-case (build-lexical-reference 'value no-source x)
1846 (syntax (key ...)) (syntax (m ...))
1848 (list (chi (syntax val) r empty-wrap))))
1849 (syntax-error e "invalid literals list in"))))))))
1851 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
1852 ;;; evaluating) and esew (which stands for "eval syntax expanders
1853 ;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
1854 ;;; if we are compiling a file, and esew is set to
1855 ;;; (eval-syntactic-expanders-when), which defaults to the list
1856 ;;; '(compile load eval). This means that, by default, top-level
1857 ;;; syntactic definitions are evaluated immediately after they are
1858 ;;; expanded, and the expanded definitions are also residualized into
1859 ;;; the object file if we are compiling a file.
1861 (let ((m 'e) (esew '(eval)))
1863 (if (and (pair? x) (equal? (car x) noexpand))
1865 (chi-top x null-env top-wrap m esew)))))
1868 (let ((m 'e) (esew '(eval)))
1870 (if (and (pair? x) (equal? (car x) noexpand))
1875 (if (null? rest) m (car rest))
1876 (if (or (null? rest) (null? (cdr rest)))
1884 (set! datum->syntax-object
1886 (make-syntax-object datum (syntax-object-wrap id))))
1888 (set! syntax-object->datum
1889 ; accepts any object, since syntax objects may consist partially
1890 ; or entirely of unwrapped, nonsymbolic data
1892 (strip x empty-wrap)))
1894 (set! generate-temporaries
1896 (arg-check list? ls 'generate-temporaries)
1897 (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
1899 (set! free-identifier=?
1901 (arg-check nonsymbol-id? x 'free-identifier=?)
1902 (arg-check nonsymbol-id? y 'free-identifier=?)
1905 (set! bound-identifier=?
1907 (arg-check nonsymbol-id? x 'bound-identifier=?)
1908 (arg-check nonsymbol-id? y 'bound-identifier=?)
1912 (lambda (object . messages)
1913 (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
1914 (let ((message (if (null? messages)
1916 (apply string-append messages))))
1917 (error-hook #f message (strip object empty-wrap)))))
1919 (set! install-global-transformer
1921 (arg-check symbol? sym 'define-syntax)
1922 (arg-check procedure? v 'define-syntax)
1923 (global-extend 'macro sym v)))
1925 ;;; syntax-dispatch expects an expression and a pattern. If the expression
1926 ;;; matches the pattern a list of the matching expressions for each
1927 ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
1928 ;;; not work on r4rs implementations that violate the ieee requirement
1929 ;;; that #f and () be distinct.)
1931 ;;; The expression is matched with the pattern as follows:
1933 ;;; pattern: matches:
1936 ;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
1938 ;;; #(free-id <key>) <key> with free-identifier=?
1939 ;;; #(each <pattern>) (<pattern>*)
1940 ;;; #(vector <pattern>) (list->vector <pattern>)
1941 ;;; #(atom <object>) <object> with "equal?"
1943 ;;; Vector cops out to pair under assumption that vectors are rare. If
1944 ;;; not, should convert to:
1945 ;;; #(vector <pattern>*) #(<pattern>*)
1953 (match-each (annotation-expression e) p w))
1955 (let ((first (match (car e) p w '())))
1957 (let ((rest (match-each (cdr e) p w)))
1958 (and rest (cons first rest))))))
1961 (match-each (syntax-object-expression e)
1963 (join-wraps w (syntax-object-wrap e))))
1966 (define match-each-any
1970 (match-each-any (annotation-expression e) w))
1972 (let ((l (match-each-any (cdr e) w)))
1973 (and l (cons (wrap (car e) w) l))))
1976 (match-each-any (syntax-object-expression e)
1977 (join-wraps w (syntax-object-wrap e))))
1984 ((eq? p 'any) (cons '() r))
1985 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
1986 ((eq? p 'each-any) (cons '() r))
1988 (case (vector-ref p 0)
1989 ((each) (match-empty (vector-ref p 1) r))
1991 ((vector) (match-empty (vector-ref p 1) r)))))))
1996 ((null? p) (and (null? e) r))
1998 (and (pair? e) (match (car e) (car p) w
1999 (match (cdr e) (cdr p) w r))))
2001 (let ((l (match-each-any e w))) (and l (cons l r))))
2003 (case (vector-ref p 0)
2006 (match-empty (vector-ref p 1) r)
2007 (let ((l (match-each e (vector-ref p 1) w)))
2009 (let collect ((l l))
2012 (cons (map car l) (collect (map cdr l)))))))))
2013 ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r))
2014 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2017 (match (vector->list e) (vector-ref p 1) w r))))))))
2023 ((eq? p 'any) (cons (wrap e w) r))
2026 (unannotate (syntax-object-expression e))
2028 (join-wraps w (syntax-object-wrap e))
2030 (else (match* (unannotate e) p w r)))))
2032 (set! syntax-dispatch
2035 ((eq? p 'any) (list e))
2037 (match* (unannotate (syntax-object-expression e))
2038 p (syntax-object-wrap e) '()))
2039 (else (match* (unannotate e) p empty-wrap '())))))
2045 (define-syntax with-syntax
2049 (syntax (begin e1 e2 ...)))
2050 ((_ ((out in)) e1 e2 ...)
2051 (syntax (syntax-case in () (out (begin e1 e2 ...)))))
2052 ((_ ((out in) ...) e1 e2 ...)
2053 (syntax (syntax-case (list in ...) ()
2054 ((out ...) (begin e1 e2 ...))))))))
2056 (define-syntax syntax-rules
2059 ((_ (k ...) ((keyword . pattern) template) ...)
2061 (syntax-case x (k ...)
2062 ((dummy . pattern) (syntax template))
2068 ((let* ((x v) ...) e1 e2 ...)
2069 (andmap identifier? (syntax (x ...)))
2070 (let f ((bindings (syntax ((x v) ...))))
2071 (if (null? bindings)
2072 (syntax (let () e1 e2 ...))
2073 (with-syntax ((body (f (cdr bindings)))
2074 (binding (car bindings)))
2075 (syntax (let (binding) body)))))))))
2079 (syntax-case orig-x ()
2080 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2081 (with-syntax (((step ...)
2086 (_ (syntax-error orig-x))))
2088 (syntax (step ...)))))
2089 (syntax-case (syntax (e1 ...)) ()
2090 (() (syntax (let doloop ((var init) ...)
2092 (begin c ... (doloop step ...))))))
2094 (syntax (let doloop ((var init) ...)
2097 (begin c ... (doloop step ...))))))))))))
2099 (define-syntax quasiquote
2103 (with-syntax ((x x) (y y))
2104 (syntax-case (syntax y) (quote list)
2106 (syntax-case (syntax x) (quote)
2107 ((quote dx) (syntax (quote (dx . dy))))
2108 (_ (if (null? (syntax dy))
2110 (syntax (cons x y))))))
2111 ((list . stuff) (syntax (list x . stuff)))
2112 (else (syntax (cons x y)))))))
2115 (with-syntax ((x x) (y y))
2116 (syntax-case (syntax y) (quote)
2117 ((quote ()) (syntax x))
2118 (_ (syntax (append x y)))))))
2121 (with-syntax ((x x))
2122 (syntax-case (syntax x) (quote list)
2123 ((quote (x ...)) (syntax (quote #(x ...))))
2124 ((list x ...) (syntax (vector x ...)))
2125 (_ (syntax (list->vector x)))))))
2128 (syntax-case p (unquote unquote-splicing quasiquote)
2132 (quasicons (syntax (quote unquote))
2133 (quasi (syntax (p)) (- lev 1)))))
2134 (((unquote-splicing p) . q)
2136 (quasiappend (syntax p) (quasi (syntax q) lev))
2137 (quasicons (quasicons (syntax (quote unquote-splicing))
2138 (quasi (syntax (p)) (- lev 1)))
2139 (quasi (syntax q) lev))))
2141 (quasicons (syntax (quote quasiquote))
2142 (quasi (syntax (p)) (+ lev 1))))
2144 (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
2145 (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
2146 (p (syntax (quote p)))))))
2149 ((_ e) (quasi (syntax e) 0))))))
2151 (define-syntax include
2155 (let ((p (open-input-file fn)))
2156 (let f ((x (read p)))
2158 (begin (close-input-port p) '())
2159 (cons (datum->syntax-object k x)
2163 (let ((fn (syntax-object->datum (syntax filename))))
2164 (with-syntax (((exp ...) (read-file fn (syntax k))))
2165 (syntax (begin exp ...))))))))
2167 (define-syntax unquote
2172 "expression ,~s not valid outside of quasiquote"
2173 (syntax-object->datum (syntax e)))))))
2175 (define-syntax unquote-splicing
2179 (error 'unquote-splicing
2180 "expression ,@~s not valid outside of quasiquote"
2181 (syntax-object->datum (syntax e)))))))
2188 ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
2190 (syntax-case clause (else)
2191 ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
2192 (((k ...) e1 e2 ...)
2193 (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
2194 (_ (syntax-error x)))
2195 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2196 (syntax-case clause (else)
2197 (((k ...) e1 e2 ...)
2198 (syntax (if (memv t '(k ...))
2201 (_ (syntax-error x))))))))
2202 (syntax (let ((t e)) body)))))))
2204 (define-syntax identifier-syntax
2212 (identifier? (syntax id))
2215 (syntax (e x (... ...)))))))))))