3 ;;;; Copyright (C) 2001, 2003 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 annotation? (lambda (x) #f))
323 (define top-level-eval-hook
325 (eval `(,noexpand ,x) (interaction-environment))))
327 (define local-eval-hook
329 (eval `(,noexpand ,x) (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)
341 (putprop symbol '*sc-expander* binding)))
343 (define get-global-definition-hook
345 (getprop symbol '*sc-expander*)))
349 ;;; output constructors
351 (define-syntax build-application
353 ((_ source fun-exp arg-exps)
354 `(,fun-exp . ,arg-exps))))
356 (define-syntax build-conditional
358 ((_ source test-exp then-exp else-exp)
359 `(if ,test-exp ,then-exp ,else-exp))))
361 (define-syntax build-lexical-reference
366 (define-syntax build-lexical-assignment
371 (define-syntax build-global-reference
376 (define-syntax build-global-assignment
381 (define-syntax build-global-definition
384 `(define ,var ,exp))))
386 (define-syntax build-lambda
389 `(lambda ,vars ,exp))))
391 (define-syntax build-primref
394 ((_ src level name) name)))
396 (define (build-data src exp)
397 (if (and (self-evaluating? exp)
402 (define build-sequence
404 (if (null? (cdr exps))
409 (lambda (src vars val-exps body-exp)
412 `(let ,(map list vars val-exps) ,body-exp))))
414 (define build-named-let
415 (lambda (src vars val-exps body-exp)
418 `(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp))))
421 (lambda (src vars val-exps body-exp)
424 `(letrec ,(map list vars val-exps) ,body-exp))))
426 (define-syntax build-lexical-var
428 ((_ src id) (gensym (symbol->string id)))))
431 (define-structure (syntax-object expression wrap))
433 (define-syntax unannotate
438 (annotation-expression e)
441 (define-syntax no-source (identifier-syntax #f))
443 (define source-annotation
446 ((annotation? x) (annotation-source x))
447 ((syntax-object? x) (source-annotation (syntax-object-expression x)))
450 (define-syntax arg-check
454 (if (not (pred? x)) (error-hook who "invalid argument" x))))))
456 ;;; compile-time environments
458 ;;; wrap and environment comprise two level mapping.
459 ;;; wrap : id --> label
460 ;;; env : label --> <element>
462 ;;; environments are represented in two parts: a lexical part and a global
463 ;;; part. The lexical part is a simple list of associations from labels
464 ;;; to bindings. The global part is implemented by
465 ;;; {put,get}-global-definition-hook and associates symbols with
468 ;;; global (assumed global variable) and displaced-lexical (see below)
469 ;;; do not show up in any environment; instead, they are fabricated by
470 ;;; lookup when it finds no other bindings.
472 ;;; <environment> ::= ((<label> . <binding>)*)
474 ;;; identifier bindings include a type and a value
476 ;;; <binding> ::= (macro . <procedure>) macros
477 ;;; (core . <procedure>) core forms
478 ;;; (external-macro . <procedure>) external-macro
481 ;;; (define-syntax) define-syntax
482 ;;; (local-syntax . rec?) let-syntax/letrec-syntax
483 ;;; (eval-when) eval-when
484 ;;; (syntax . (<var> . <level>)) pattern variables
485 ;;; (global) assumed global variable
486 ;;; (lexical . <var>) lexical variables
487 ;;; (displaced-lexical) displaced lexicals
488 ;;; <level> ::= <nonnegative integer>
489 ;;; <var> ::= variable returned by build-lexical-var
491 ;;; a macro is a user-defined syntactic-form. a core is a system-defined
492 ;;; syntactic form. begin, define, define-syntax, and eval-when are
493 ;;; treated specially since they are sensitive to whether the form is
494 ;;; at top-level and (except for eval-when) can denote valid internal
497 ;;; a pattern variable is a variable introduced by syntax-case and can
498 ;;; be referenced only within a syntax form.
500 ;;; any identifier for which no top-level syntax definition or local
501 ;;; binding of any kind has been seen is assumed to be a global
504 ;;; a lexical variable is a lambda- or letrec-bound variable.
506 ;;; a displaced-lexical identifier is a lexical identifier removed from
507 ;;; it's scope by the return of a syntax object containing the identifier.
508 ;;; a displaced lexical can also appear when a letrec-syntax-bound
509 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
510 ;;; a displaced lexical should never occur with properly written macros.
512 (define-syntax make-binding
513 (syntax-rules (quote)
514 ((_ type value) (cons type value))
516 ((_ type) (cons type '()))))
517 (define binding-type car)
518 (define binding-value cdr)
520 (define-syntax null-env (identifier-syntax '()))
523 (lambda (labels bindings r)
526 (extend-env (cdr labels) (cdr bindings)
527 (cons (cons (car labels) (car bindings)) r)))))
529 (define extend-var-env
530 ; variant of extend-env that forms "lexical" binding
531 (lambda (labels vars r)
534 (extend-var-env (cdr labels) (cdr vars)
535 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
537 ;;; we use a "macros only" environment in expansion of local macro
538 ;;; definitions so that their definitions can use local macros without
539 ;;; attempting to use other lexical identifiers.
540 (define macros-only-env
545 (if (eq? (cadr a) 'macro)
546 (cons a (macros-only-env (cdr r)))
547 (macros-only-env (cdr r)))))))
550 ; x may be a label or a symbol
551 ; although symbols are usually global, we check the environment first
552 ; anyway because a temporary binding may have been established by
558 (or (get-global-definition-hook x) (make-binding 'global)))
559 (else (make-binding 'displaced-lexical)))))
561 (define global-extend
562 (lambda (type sym val)
563 (put-global-definition-hook sym (make-binding type val))))
566 ;;; Conceptually, identifiers are always syntax objects. Internally,
567 ;;; however, the wrap is sometimes maintained separately (a source of
568 ;;; efficiency and confusion), so that symbols are also considered
569 ;;; identifiers by id?. Externally, they are always wrapped.
571 (define nonsymbol-id?
573 (and (syntax-object? x)
574 (symbol? (unannotate (syntax-object-expression x))))))
580 ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
581 ((annotation? x) (symbol? (annotation-expression x)))
584 (define-syntax id-sym-name
588 (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
590 (define id-sym-name&marks
592 (if (syntax-object? x)
594 (unannotate (syntax-object-expression x))
595 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
596 (values (unannotate x) (wrap-marks w)))))
598 ;;; syntax object wraps
600 ;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
601 ;;; <subst> ::= <shift> | <subs>
602 ;;; <subs> ::= #(<old name> <label> (<mark> ...))
603 ;;; <shift> ::= positive fixnum
605 (define make-wrap cons)
606 (define wrap-marks car)
607 (define wrap-subst cdr)
609 (define-syntax subst-rename? (identifier-syntax vector?))
610 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
611 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
612 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
613 (define-syntax make-rename
615 ((_ old new marks) (vector old new marks))))
617 ;;; labels must be comparable with "eq?" and distinct from symbols.
619 (lambda () (string #\i)))
625 (cons (gen-label) (gen-labels (cdr ls))))))
627 (define-structure (ribcage symnames marks labels))
629 (define-syntax empty-wrap (identifier-syntax '(())))
631 (define-syntax top-wrap (identifier-syntax '((top))))
633 (define-syntax top-marked?
635 ((_ w) (memq 'top (wrap-marks w)))))
637 ;;; Marks must be comparable with "eq?" and distinct from pairs and
638 ;;; the symbol top. We do not use integers so that marks will remain
639 ;;; unique even across file compiles.
641 (define-syntax the-anti-mark (identifier-syntax #f))
645 (make-wrap (cons the-anti-mark (wrap-marks w))
646 (cons 'shift (wrap-subst w)))))
648 (define-syntax new-mark
652 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
653 ;;; internal definitions, in which the ribcages are built incrementally
654 (define-syntax make-empty-ribcage
656 ((_) (make-ribcage '() '() '()))))
658 (define extend-ribcage!
659 ; must receive ids with complete wraps
660 (lambda (ribcage id label)
661 (set-ribcage-symnames! ribcage
662 (cons (unannotate (syntax-object-expression id))
663 (ribcage-symnames ribcage)))
664 (set-ribcage-marks! ribcage
665 (cons (wrap-marks (syntax-object-wrap id))
666 (ribcage-marks ribcage)))
667 (set-ribcage-labels! ribcage
668 (cons label (ribcage-labels ribcage)))))
670 ;;; make-binding-wrap creates vector-based ribcages
671 (define make-binding-wrap
672 (lambda (ids labels w)
678 (let ((labelvec (list->vector labels)))
679 (let ((n (vector-length labelvec)))
680 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
681 (let f ((ids ids) (i 0))
682 (if (not (null? ids))
684 (lambda () (id-sym-name&marks (car ids) w))
685 (lambda (symname marks)
686 (vector-set! symnamevec i symname)
687 (vector-set! marksvec i marks)
688 (f (cdr ids) (fx+ i 1))))))
689 (make-ribcage symnamevec marksvec labelvec))))
700 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
706 (smart-append s1 (wrap-subst w2))))
708 (smart-append m1 (wrap-marks w2))
709 (smart-append s1 (wrap-subst w2)))))))
713 (smart-append m1 m2)))
720 (eq? (car x) (car y))
721 (same-marks? (cdr x) (cdr y))))))
727 ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
729 (lambda (sym subst marks)
732 (let ((fst (car subst)))
734 (search sym (cdr subst) (cdr marks))
735 (let ((symnames (ribcage-symnames fst)))
736 (if (vector? symnames)
737 (search-vector-rib sym subst marks symnames fst)
738 (search-list-rib sym subst marks symnames fst))))))))
739 (define search-list-rib
740 (lambda (sym subst marks symnames ribcage)
741 (let f ((symnames symnames) (i 0))
743 ((null? symnames) (search sym (cdr subst) marks))
744 ((and (eq? (car symnames) sym)
745 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
746 (values (list-ref (ribcage-labels ribcage) i) marks))
747 (else (f (cdr symnames) (fx+ i 1)))))))
748 (define search-vector-rib
749 (lambda (sym subst marks symnames ribcage)
750 (let ((n (vector-length symnames)))
753 ((fx= i n) (search sym (cdr subst) marks))
754 ((and (eq? (vector-ref symnames i) sym)
755 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
756 (values (vector-ref (ribcage-labels ribcage) i) marks))
757 (else (f (fx+ i 1))))))))
760 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
762 (let ((id (unannotate (syntax-object-expression id)))
763 (w1 (syntax-object-wrap id)))
764 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
765 (call-with-values (lambda () (search id (wrap-subst w) marks))
766 (lambda (new-id marks)
768 (first (search id (wrap-subst w1) marks))
771 (let ((id (unannotate id)))
772 (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
773 (else (error-hook 'id-var-name "invalid id" id)))))
775 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
776 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
780 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
781 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
783 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
784 ;;; long as the missing portion of the wrap is common to both of the ids
785 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
789 (if (and (syntax-object? i) (syntax-object? j))
790 (and (eq? (unannotate (syntax-object-expression i))
791 (unannotate (syntax-object-expression j)))
792 (same-marks? (wrap-marks (syntax-object-wrap i))
793 (wrap-marks (syntax-object-wrap j))))
794 (eq? (unannotate i) (unannotate j)))))
796 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
797 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
798 ;;; as long as the missing portion of the wrap is common to all of the
801 (define valid-bound-ids?
803 (and (let all-ids? ((ids ids))
806 (all-ids? (cdr ids)))))
807 (distinct-bound-ids? ids))))
809 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
810 ;;; no duplicates. It is quadratic on the length of the id list; long
811 ;;; lists could be sorted to make it more efficient. distinct-bound-ids?
812 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
813 ;;; missing portion of the wrap is common to all of the ids.
815 (define distinct-bound-ids?
817 (let distinct? ((ids ids))
819 (and (not (bound-id-member? (car ids) (cdr ids)))
820 (distinct? (cdr ids)))))))
822 (define bound-id-member?
824 (and (not (null? list))
825 (or (bound-id=? x (car list))
826 (bound-id-member? x (cdr list))))))
828 ;;; wrapping expressions and identifiers
833 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
836 (syntax-object-expression x)
837 (join-wraps w (syntax-object-wrap x))))
839 (else (make-syntax-object x w)))))
843 (wrap (if s (make-annotation x s #f) x) w)))
850 (let dobody ((body body) (r r) (w w))
853 (let ((first (chi (car body) r w)))
854 (cons first (dobody (cdr body) r w))))))))
856 (define chi-top-sequence
857 (lambda (body r w s m esew)
859 (let dobody ((body body) (r r) (w w) (m m) (esew esew))
862 (let ((first (chi-top (car body) r w m esew)))
863 (cons first (dobody (cdr body) r w m esew))))))))
865 (define chi-install-global
867 (build-application no-source
868 (build-primref no-source 'install-global-transformer)
869 (list (build-data no-source name) e))))
871 (define chi-when-list
872 (lambda (e when-list w)
873 ; when-list is syntax'd version of list of situations
874 (let f ((when-list when-list) (situations '()))
875 (if (null? when-list)
878 (cons (let ((x (car when-list)))
880 ((free-id=? x (syntax compile)) 'compile)
881 ((free-id=? x (syntax load)) 'load)
882 ((free-id=? x (syntax eval)) 'eval)
883 (else (syntax-error (wrap x w)
884 "invalid eval-when situation"))))
887 ;;; syntax-type returns five values: type, value, e, w, and s. The first
888 ;;; two are described in the table below.
890 ;;; type value explanation
891 ;;; -------------------------------------------------------------------
892 ;;; core procedure core form (including singleton)
893 ;;; external-macro procedure external macro
894 ;;; lexical name lexical variable reference
895 ;;; global name global variable reference
896 ;;; begin none begin keyword
897 ;;; define none define keyword
898 ;;; define-syntax none define-syntax keyword
899 ;;; local-syntax rec? letrec-syntax/let-syntax keyword
900 ;;; eval-when none eval-when keyword
901 ;;; syntax level pattern variable
902 ;;; displaced-lexical none displaced lexical identifier
903 ;;; lexical-call name call to lexical variable
904 ;;; global-call name call to global variable
905 ;;; call none any other call
906 ;;; begin-form none begin expression
907 ;;; define-form id variable definition
908 ;;; define-syntax-form id syntax definition
909 ;;; local-syntax-form rec? syntax definition
910 ;;; eval-when-form none eval-when form
911 ;;; constant none self-evaluating datum
912 ;;; other none anything else
914 ;;; For define-form and define-syntax-form, e is the rhs expression.
915 ;;; For all others, e is the entire form. w is the wrap for e.
916 ;;; s is the source for the entire form.
918 ;;; syntax-type expands macros and unwraps as necessary to get to
919 ;;; one of the forms above. It also parses define and define-syntax
920 ;;; forms, although perhaps this should be done by the consumer.
923 (lambda (e r w s rib)
926 (let* ((n (id-var-name e w))
928 (type (binding-type b)))
930 ((lexical) (values type (binding-value b) e w s))
931 ((global) (values type n e w s))
933 (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
934 (else (values type (binding-value b) e w s)))))
936 (let ((first (car e)))
938 (let* ((n (id-var-name first w))
940 (type (binding-type b)))
942 ((lexical) (values 'lexical-call (binding-value b) e w s))
943 ((global) (values 'global-call n e w s))
945 (syntax-type (chi-macro (binding-value b) e r w rib)
947 ((core external-macro) (values type (binding-value b) e w s))
949 (values 'local-syntax-form (binding-value b) e w s))
950 ((begin) (values 'begin-form #f e w s))
951 ((eval-when) (values 'eval-when-form #f e w s))
956 (values 'define-form (syntax name) (syntax val) w s))
957 ((_ (name . args) e1 e2 ...)
958 (and (id? (syntax name))
959 (valid-bound-ids? (lambda-var-list (syntax args))))
960 ; need lambda here...
961 (values 'define-form (wrap (syntax name) w)
962 (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
966 (values 'define-form (wrap (syntax name) w)
973 (values 'define-syntax-form (syntax name)
975 (else (values 'call #f e w s))))
976 (values 'call #f e w s))))
978 ;; s can't be valid source if we've unwrapped
979 (syntax-type (syntax-object-expression e)
981 (join-wraps w (syntax-object-wrap e))
984 (syntax-type (annotation-expression e) r w (annotation-source e) rib))
985 ((self-evaluating? e) (values 'constant #f e w s))
986 (else (values 'other #f e w s)))))
989 (lambda (e r w m esew)
990 (define-syntax eval-if-c&e
994 (if (eq? m 'c&e) (top-level-eval-hook x))
997 (lambda () (syntax-type e r w no-source #f))
998 (lambda (type value e w s)
1004 (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
1005 ((local-syntax-form)
1006 (chi-local-syntax value e r w s
1007 (lambda (body r w s)
1008 (chi-top-sequence body r w s m esew))))
1011 ((_ (x ...) e1 e2 ...)
1012 (let ((when-list (chi-when-list e (syntax (x ...)) w))
1013 (body (syntax (e1 e2 ...))))
1016 (if (memq 'eval when-list)
1017 (chi-top-sequence body r w s 'e '(eval))
1019 ((memq 'load when-list)
1020 (if (or (memq 'compile when-list)
1021 (and (eq? m 'c&e) (memq 'eval when-list)))
1022 (chi-top-sequence body r w s 'c&e '(compile load))
1023 (if (memq m '(c c&e))
1024 (chi-top-sequence body r w s 'c '(load))
1026 ((or (memq 'compile when-list)
1027 (and (eq? m 'c&e) (memq 'eval when-list)))
1028 (top-level-eval-hook
1029 (chi-top-sequence body r w s 'e '(eval)))
1031 (else (chi-void)))))))
1032 ((define-syntax-form)
1033 (let ((n (id-var-name value w)) (r (macros-only-env r)))
1036 (if (memq 'compile esew)
1037 (let ((e (chi-install-global n (chi e r w))))
1038 (top-level-eval-hook e)
1039 (if (memq 'load esew) e (chi-void)))
1040 (if (memq 'load esew)
1041 (chi-install-global n (chi e r w))
1044 (let ((e (chi-install-global n (chi e r w))))
1045 (top-level-eval-hook e)
1048 (if (memq 'eval esew)
1049 (top-level-eval-hook
1050 (chi-install-global n (chi e r w))))
1053 (let* ((n (id-var-name value w))
1054 (type (binding-type (lookup n r))))
1058 (build-global-definition s n (chi e r w))))
1059 ((displaced-lexical)
1060 (syntax-error (wrap value w) "identifier out of context"))
1062 (if (eq? type 'external-macro)
1064 (build-global-definition s n (chi e r w)))
1065 (syntax-error (wrap value w)
1066 "cannot define keyword at top level"))))))
1067 (else (eval-if-c&e m (chi-expr type value e r w s))))))))
1072 (lambda () (syntax-type e r w no-source #f))
1073 (lambda (type value e w s)
1074 (chi-expr type value e r w s)))))
1077 (lambda (type value e r w s)
1080 (build-lexical-reference 'value s value))
1081 ((core external-macro) (value e r w s))
1084 (build-lexical-reference 'fun (source-annotation (car e)) value)
1088 (build-global-reference (source-annotation (car e)) value)
1090 ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
1091 ((global) (build-global-reference s value))
1092 ((call) (chi-application (chi (car e) r w) e r w s))
1095 ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
1096 ((local-syntax-form)
1097 (chi-local-syntax value e r w s chi-sequence))
1100 ((_ (x ...) e1 e2 ...)
1101 (let ((when-list (chi-when-list e (syntax (x ...)) w)))
1102 (if (memq 'eval when-list)
1103 (chi-sequence (syntax (e1 e2 ...)) r w s)
1105 ((define-form define-syntax-form)
1106 (syntax-error (wrap value w) "invalid context for definition of"))
1108 (syntax-error (source-wrap e w s)
1109 "reference to pattern variable outside syntax form"))
1110 ((displaced-lexical)
1111 (syntax-error (source-wrap e w s)
1112 "reference to identifier outside its scope"))
1113 (else (syntax-error (source-wrap e w s))))))
1115 (define chi-application
1119 (build-application s x
1120 (map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))
1123 (lambda (p e r w rib)
1124 (define rebuild-macro-output
1127 (cons (rebuild-macro-output (car x) m)
1128 (rebuild-macro-output (cdr x) m)))
1130 (let ((w (syntax-object-wrap x)))
1131 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1132 (make-syntax-object (syntax-object-expression x)
1133 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1135 (if rib (cons rib (cdr s)) (cdr s)))
1136 (make-wrap (cons m ms)
1138 (cons rib (cons 'shift s))
1139 (cons 'shift s))))))))
1141 (let* ((n (vector-length x)) (v (make-vector n)))
1142 (do ((i 0 (fx+ i 1)))
1145 (rebuild-macro-output (vector-ref x i) m)))))
1147 (syntax-error x "encountered raw symbol in macro output"))
1149 (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))
1152 ;; In processing the forms of the body, we create a new, empty wrap.
1153 ;; This wrap is augmented (destructively) each time we discover that
1154 ;; the next form is a definition. This is done:
1156 ;; (1) to allow the first nondefinition form to be a call to
1157 ;; one of the defined ids even if the id previously denoted a
1158 ;; definition keyword or keyword for a macro expanding into a
1160 ;; (2) to prevent subsequent definition forms (but unfortunately
1161 ;; not earlier ones) and the first nondefinition form from
1162 ;; confusing one of the bound identifiers for an auxiliary
1164 ;; (3) so that we do not need to restart the expansion of the
1165 ;; first nondefinition form, which is problematic anyway
1166 ;; since it might be the first element of a begin that we
1167 ;; have just spliced into the body (meaning if we restarted,
1168 ;; we'd really need to restart with the begin or the macro
1169 ;; call that expanded into the begin, and we'd have to give
1170 ;; up allowing (begin <defn>+ <expr>+), which is itself
1171 ;; problematic since we don't know if a begin contains only
1172 ;; definitions until we've expanded it).
1174 ;; Before processing the body, we also create a new environment
1175 ;; containing a placeholder for the bindings we will add later and
1176 ;; associate this environment with each form. In processing a
1177 ;; let-syntax or letrec-syntax, the associated environment may be
1178 ;; augmented with local keyword bindings, so the environment may
1179 ;; be different for different forms in the body. Once we have
1180 ;; gathered up all of the definitions, we evaluate the transformer
1181 ;; expressions and splice into r at the placeholder the new variable
1182 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1183 ;; forms local to a portion or all of the body to shadow the
1184 ;; definition bindings.
1186 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1189 ;; outer-form is fully wrapped w/source
1190 (lambda (body outer-form r w)
1191 (let* ((r (cons '("placeholder" . (placeholder)) r))
1192 (ribcage (make-empty-ribcage))
1193 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1194 (let parse ((body (map (lambda (x) (cons r (wrap x w))) body))
1195 (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
1197 (syntax-error outer-form "no expressions in body")
1198 (let ((e (cdar body)) (er (caar body)))
1200 (lambda () (syntax-type e er empty-wrap no-source ribcage))
1201 (lambda (type value e w s)
1204 (let ((id (wrap value w)) (label (gen-label)))
1205 (let ((var (gen-var id)))
1206 (extend-ribcage! ribcage id label)
1208 (cons id ids) (cons label labels)
1209 (cons var vars) (cons (cons er (wrap e w)) vals)
1210 (cons (make-binding 'lexical var) bindings)))))
1211 ((define-syntax-form)
1212 (let ((id (wrap value w)) (label (gen-label)))
1213 (extend-ribcage! ribcage id label)
1215 (cons id ids) (cons label labels)
1217 (cons (make-binding 'macro (cons er (wrap e w)))
1222 (parse (let f ((forms (syntax (e1 ...))))
1225 (cons (cons er (wrap (car forms) w))
1227 ids labels vars vals bindings))))
1228 ((local-syntax-form)
1229 (chi-local-syntax value e er w s
1230 (lambda (forms er w s)
1231 (parse (let f ((forms forms))
1234 (cons (cons er (wrap (car forms) w))
1236 ids labels vars vals bindings))))
1237 (else ; found a non-definition
1239 (build-sequence no-source
1241 (chi (cdr x) (car x) empty-wrap))
1242 (cons (cons er (source-wrap e w s))
1245 (if (not (valid-bound-ids? ids))
1246 (syntax-error outer-form
1247 "invalid or duplicate identifier in definition"))
1248 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1249 (if (not (null? bs))
1250 (let* ((b (car bs)))
1251 (if (eq? (car b) 'macro)
1252 (let* ((er (cadr b))
1254 (if (eq? er er-cache)
1256 (macros-only-env er))))
1258 (eval-local-transformer
1259 (chi (cddr b) r-cache empty-wrap)))
1260 (loop (cdr bs) er r-cache))
1261 (loop (cdr bs) er-cache r-cache)))))
1262 (set-cdr! r (extend-env labels bindings (cdr r)))
1263 (build-letrec no-source
1266 (chi (cdr x) (car x) empty-wrap))
1268 (build-sequence no-source
1270 (chi (cdr x) (car x) empty-wrap))
1271 (cons (cons er (source-wrap e w s))
1272 (cdr body)))))))))))))))))
1274 (define chi-lambda-clause
1277 (((id ...) e1 e2 ...)
1278 (let ((ids (syntax (id ...))))
1279 (if (not (valid-bound-ids? ids))
1280 (syntax-error e "invalid parameter list in")
1281 (let ((labels (gen-labels ids))
1282 (new-vars (map gen-var ids)))
1284 (chi-body (syntax (e1 e2 ...))
1286 (extend-var-env labels new-vars r)
1287 (make-binding-wrap ids labels w)))))))
1289 (let ((old-ids (lambda-var-list (syntax ids))))
1290 (if (not (valid-bound-ids? old-ids))
1291 (syntax-error e "invalid parameter list in")
1292 (let ((labels (gen-labels old-ids))
1293 (new-vars (map gen-var old-ids)))
1294 (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
1297 (f (cdr ls1) (cons (car ls1) ls2))))
1298 (chi-body (syntax (e1 e2 ...))
1300 (extend-var-env labels new-vars r)
1301 (make-binding-wrap old-ids labels w)))))))
1302 (_ (syntax-error e)))))
1304 (define chi-local-syntax
1305 (lambda (rec? e r w s k)
1307 ((_ ((id val) ...) e1 e2 ...)
1308 (let ((ids (syntax (id ...))))
1309 (if (not (valid-bound-ids? ids))
1310 (syntax-error e "duplicate bound keyword in")
1311 (let ((labels (gen-labels ids)))
1312 (let ((new-w (make-binding-wrap ids labels w)))
1313 (k (syntax (e1 e2 ...))
1316 (let ((w (if rec? new-w w))
1317 (trans-r (macros-only-env r)))
1319 (make-binding 'macro
1320 (eval-local-transformer (chi x trans-r w))))
1321 (syntax (val ...))))
1325 (_ (syntax-error (source-wrap e w s))))))
1327 (define eval-local-transformer
1329 (let ((p (local-eval-hook expanded)))
1332 (syntax-error p "nonprocedure transformer")))))
1336 (build-application no-source (build-primref no-source 'void) '())))
1340 (and (nonsymbol-id? x)
1341 (free-id=? x (syntax (... ...))))))
1345 ;;; strips all annotations from potentially circular reader output
1347 (define strip-annotation
1351 (let ((new (cons #f #f)))
1352 (when parent (set-annotation-stripped! parent new))
1353 (set-car! new (strip-annotation (car x) #f))
1354 (set-cdr! new (strip-annotation (cdr x) #f))
1357 (or (annotation-stripped x)
1358 (strip-annotation (annotation-expression x) x)))
1360 (let ((new (make-vector (vector-length x))))
1361 (when parent (set-annotation-stripped! parent new))
1362 (let loop ((i (- (vector-length x) 1)))
1364 (vector-set! new i (strip-annotation (vector-ref x i) #f))
1369 ;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
1370 ;;; on an annotation, strips the annotation as well.
1371 ;;; since only the head of a list is annotated by the reader, not each pair
1372 ;;; in the spine, we also check for pairs whose cars are annotated in case
1373 ;;; we've been passed the cdr of an annotated list
1378 (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
1379 (strip-annotation x #f)
1384 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1386 (let ((a (f (car x))) (d (f (cdr x))))
1387 (if (and (eq? a (car x)) (eq? d (cdr x)))
1391 (let ((old (vector->list x)))
1392 (let ((new (map f old)))
1393 (if (andmap eq? old new) x (list->vector new)))))
1396 ;;; lexical variables
1400 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1401 (if (annotation? id)
1402 (build-lexical-var (annotation-source id) (annotation-expression id))
1403 (build-lexical-var no-source id)))))
1405 (define lambda-var-list
1407 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1409 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
1410 ((id? vars) (cons (wrap vars w) ls))
1412 ((syntax-object? vars)
1413 (lvl (syntax-object-expression vars)
1415 (join-wraps w (syntax-object-wrap vars))))
1417 (lvl (annotation-expression vars) ls w))
1418 ; include anything else to be caught by subsequent error
1420 (else (cons vars ls))))))
1422 ;;; core transformers
1424 (global-extend 'local-syntax 'letrec-syntax #t)
1425 (global-extend 'local-syntax 'let-syntax #f)
1427 (global-extend 'core 'fluid-let-syntax
1430 ((_ ((var val) ...) e1 e2 ...)
1431 (valid-bound-ids? (syntax (var ...)))
1432 (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
1435 (case (binding-type (lookup n r))
1436 ((displaced-lexical)
1437 (syntax-error (source-wrap id w s)
1438 "identifier out of context"))))
1442 (syntax (e1 e2 ...))
1446 (let ((trans-r (macros-only-env r)))
1448 (make-binding 'macro
1449 (eval-local-transformer (chi x trans-r w))))
1450 (syntax (val ...))))
1453 (_ (syntax-error (source-wrap e w s))))))
1455 (global-extend 'core 'quote
1458 ((_ e) (build-data s (strip (syntax e) w)))
1459 (_ (syntax-error (source-wrap e w s))))))
1461 (global-extend 'core 'syntax
1464 (lambda (src e r maps ellipsis?)
1466 (let ((label (id-var-name e empty-wrap)))
1467 (let ((b (lookup label r)))
1468 (if (eq? (binding-type b) 'syntax)
1471 (let ((var.lev (binding-value b)))
1472 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1473 (lambda (var maps) (values `(ref ,var) maps)))
1475 (syntax-error src "misplaced ellipsis in syntax form")
1476 (values `(quote ,e) maps)))))
1479 (ellipsis? (syntax dots))
1480 (gen-syntax src (syntax e) r maps (lambda (x) #f)))
1482 ; this could be about a dozen lines of code, except that we
1483 ; choose to handle (syntax (x ... ...)) forms
1484 (ellipsis? (syntax dots))
1485 (let f ((y (syntax y))
1489 (gen-syntax src (syntax x) r
1490 (cons '() maps) ellipsis?))
1492 (if (null? (car maps))
1494 "extra ellipsis in syntax form")
1495 (values (gen-map x (car maps))
1499 (ellipsis? (syntax dots))
1503 (lambda () (k (cons '() maps)))
1505 (if (null? (car maps))
1507 "extra ellipsis in syntax form")
1508 (values (gen-mappend x (car maps))
1510 (_ (call-with-values
1511 (lambda () (gen-syntax src y r maps ellipsis?))
1514 (lambda () (k maps))
1516 (values (gen-append x y) maps)))))))))
1519 (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
1522 (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
1523 (lambda (y maps) (values (gen-cons x y) maps))))))
1527 (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
1528 (lambda (e maps) (values (gen-vector e) maps))))
1529 (_ (values `(quote ,e) maps))))))
1532 (lambda (src var level maps)
1536 (syntax-error src "missing ellipsis in syntax form")
1538 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1539 (lambda (outer-var outer-maps)
1540 (let ((b (assq outer-var (car maps))))
1542 (values (cdr b) maps)
1543 (let ((inner-var (gen-var 'tmp)))
1545 (cons (cons (cons outer-var inner-var)
1547 outer-maps)))))))))))
1551 `(apply (primitive append) ,(gen-map e map-env))))
1555 (let ((formals (map cdr map-env))
1556 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1559 ; identity map equivalence:
1560 ; (map (lambda (x) x) y) == y
1563 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1565 ; eta map equivalence:
1566 ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1567 `(map (primitive ,(car e))
1568 ,@(map (let ((r (map cons formals actuals)))
1569 (lambda (x) (cdr (assq (cadr x) r))))
1571 (else `(map (lambda ,formals ,e) ,@actuals))))))
1577 (if (eq? (car x) 'quote)
1578 `(quote (,(cadr x) . ,(cadr y)))
1579 (if (eq? (cadr y) '())
1582 ((list) `(list ,x ,@(cdr y)))
1583 (else `(cons ,x ,y)))))
1587 (if (equal? y '(quote ()))
1594 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1595 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1596 (else `(list->vector ,x)))))
1602 ((ref) (build-lexical-reference 'value no-source (cadr x)))
1603 ((primitive) (build-primref no-source (cadr x)))
1604 ((quote) (build-data no-source (cadr x)))
1605 ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
1606 ((map) (let ((ls (map regen (cdr x))))
1607 (build-application no-source
1608 (if (fx= (length ls) 2)
1609 (build-primref no-source 'map)
1610 ; really need to do our own checking here
1611 (build-primref no-source 2 'map)) ; require error check
1613 (else (build-application no-source
1614 (build-primref no-source (car x))
1615 (map regen (cdr x)))))))
1618 (let ((e (source-wrap e w s)))
1622 (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
1623 (lambda (e maps) (regen e))))
1624 (_ (syntax-error e)))))))
1627 (global-extend 'core 'lambda
1631 (chi-lambda-clause (source-wrap e w s) (syntax c) r w
1632 (lambda (vars body) (build-lambda s vars body)))))))
1635 (global-extend 'core 'let
1637 (define (chi-let e r w s constructor ids vals exps)
1638 (if (not (valid-bound-ids? ids))
1639 (syntax-error e "duplicate bound variable in")
1640 (let ((labels (gen-labels ids))
1641 (new-vars (map gen-var ids)))
1642 (let ((nw (make-binding-wrap ids labels w))
1643 (nr (extend-var-env labels new-vars r)))
1646 (map (lambda (x) (chi x r w)) vals)
1647 (chi-body exps (source-wrap e nw s) nr nw))))))
1650 ((_ ((id val) ...) e1 e2 ...)
1655 (syntax (e1 e2 ...))))
1656 ((_ f ((id val) ...) e1 e2 ...)
1662 (syntax (e1 e2 ...))))
1663 (_ (syntax-error (source-wrap e w s)))))))
1666 (global-extend 'core 'letrec
1669 ((_ ((id val) ...) e1 e2 ...)
1670 (let ((ids (syntax (id ...))))
1671 (if (not (valid-bound-ids? ids))
1672 (syntax-error e "duplicate bound variable in")
1673 (let ((labels (gen-labels ids))
1674 (new-vars (map gen-var ids)))
1675 (let ((w (make-binding-wrap ids labels w))
1676 (r (extend-var-env labels new-vars r)))
1679 (map (lambda (x) (chi x r w)) (syntax (val ...)))
1680 (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
1681 (_ (syntax-error (source-wrap e w s))))))
1684 (global-extend 'core 'set!
1689 (let ((val (chi (syntax val) r w))
1690 (n (id-var-name (syntax id) w)))
1691 (let ((b (lookup n r)))
1692 (case (binding-type b)
1694 (build-lexical-assignment s (binding-value b) val))
1695 ((global) (build-global-assignment s n val))
1696 ((displaced-lexical)
1697 (syntax-error (wrap (syntax id) w)
1698 "identifier out of context"))
1699 (else (syntax-error (source-wrap e w s)))))))
1700 ((_ (getter arg ...) val)
1701 (build-application s
1702 (chi (syntax (setter getter)) r w)
1703 (map (lambda (e) (chi e r w))
1704 (syntax (arg ... val)))))
1705 (_ (syntax-error (source-wrap e w s))))))
1707 (global-extend 'begin 'begin '())
1709 (global-extend 'define 'define '())
1711 (global-extend 'define-syntax 'define-syntax '())
1713 (global-extend 'eval-when 'eval-when '())
1715 (global-extend 'core 'syntax-case
1717 (define convert-pattern
1718 ; accepts pattern & keys
1719 ; returns syntax-dispatch pattern & ids
1720 (lambda (pattern keys)
1721 (let cvt ((p pattern) (n 0) (ids '()))
1723 (if (bound-id-member? p keys)
1724 (values (vector 'free-id p) ids)
1725 (values 'any (cons (cons p n) ids)))
1728 (ellipsis? (syntax dots))
1730 (lambda () (cvt (syntax x) (fx+ n 1) ids))
1732 (values (if (eq? p 'any) 'each-any (vector 'each p))
1736 (lambda () (cvt (syntax y) n ids))
1739 (lambda () (cvt (syntax x) n ids))
1741 (values (cons x y) ids))))))
1742 (() (values '() ids))
1745 (lambda () (cvt (syntax (x ...)) n ids))
1746 (lambda (p ids) (values (vector 'vector p) ids))))
1747 (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
1749 (define build-dispatch-call
1750 (lambda (pvars exp y r)
1751 (let ((ids (map car pvars)) (levels (map cdr pvars)))
1752 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1753 (build-application no-source
1754 (build-primref no-source 'apply)
1755 (list (build-lambda no-source new-vars
1759 (map (lambda (var level)
1760 (make-binding 'syntax `(,var . ,level)))
1764 (make-binding-wrap ids labels empty-wrap)))
1768 (lambda (x keys clauses r pat fender exp)
1770 (lambda () (convert-pattern pat keys))
1773 ((not (distinct-bound-ids? (map car pvars)))
1775 "duplicate pattern variable in syntax-case pattern"))
1776 ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
1778 "misplaced ellipsis in syntax-case pattern"))
1780 (let ((y (gen-var 'tmp)))
1781 ; fat finger binding and references to temp variable y
1782 (build-application no-source
1783 (build-lambda no-source (list y)
1784 (let ((y (build-lexical-reference 'value no-source y)))
1785 (build-conditional no-source
1786 (syntax-case fender ()
1788 (_ (build-conditional no-source
1790 (build-dispatch-call pvars fender y r)
1791 (build-data no-source #f))))
1792 (build-dispatch-call pvars exp y r)
1793 (gen-syntax-case x keys clauses r))))
1794 (list (if (eq? p 'any)
1795 (build-application no-source
1796 (build-primref no-source 'list)
1798 (build-application no-source
1799 (build-primref no-source 'syntax-dispatch)
1800 (list x (build-data no-source p)))))))))))))
1802 (define gen-syntax-case
1803 (lambda (x keys clauses r)
1805 (build-application no-source
1806 (build-primref no-source 'syntax-error)
1808 (syntax-case (car clauses) ()
1810 (if (and (id? (syntax pat))
1811 (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
1812 (cons (syntax (... ...)) keys)))
1813 (let ((labels (list (gen-label)))
1814 (var (gen-var (syntax pat))))
1815 (build-application no-source
1816 (build-lambda no-source (list var)
1819 (list (make-binding 'syntax `(,var . 0)))
1821 (make-binding-wrap (syntax (pat))
1822 labels empty-wrap)))
1824 (gen-clause x keys (cdr clauses) r
1825 (syntax pat) #t (syntax exp))))
1827 (gen-clause x keys (cdr clauses) r
1828 (syntax pat) (syntax fender) (syntax exp)))
1829 (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
1832 (let ((e (source-wrap e w s)))
1834 ((_ val (key ...) m ...)
1835 (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
1837 (let ((x (gen-var 'tmp)))
1838 ; fat finger binding and references to temp variable x
1839 (build-application s
1840 (build-lambda no-source (list x)
1841 (gen-syntax-case (build-lexical-reference 'value no-source x)
1842 (syntax (key ...)) (syntax (m ...))
1844 (list (chi (syntax val) r empty-wrap))))
1845 (syntax-error e "invalid literals list in"))))))))
1847 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
1848 ;;; evaluating) and esew (which stands for "eval syntax expanders
1849 ;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
1850 ;;; if we are compiling a file, and esew is set to
1851 ;;; (eval-syntactic-expanders-when), which defaults to the list
1852 ;;; '(compile load eval). This means that, by default, top-level
1853 ;;; syntactic definitions are evaluated immediately after they are
1854 ;;; expanded, and the expanded definitions are also residualized into
1855 ;;; the object file if we are compiling a file.
1857 (let ((m 'e) (esew '(eval)))
1859 (if (and (pair? x) (equal? (car x) noexpand))
1861 (chi-top x null-env top-wrap m esew)))))
1864 (let ((m 'e) (esew '(eval)))
1866 (if (and (pair? x) (equal? (car x) noexpand))
1871 (if (null? rest) m (car rest))
1872 (if (or (null? rest) (null? (cdr rest)))
1880 (set! datum->syntax-object
1882 (make-syntax-object datum (syntax-object-wrap id))))
1884 (set! syntax-object->datum
1885 ; accepts any object, since syntax objects may consist partially
1886 ; or entirely of unwrapped, nonsymbolic data
1888 (strip x empty-wrap)))
1890 (set! generate-temporaries
1892 (arg-check list? ls 'generate-temporaries)
1893 (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
1895 (set! free-identifier=?
1897 (arg-check nonsymbol-id? x 'free-identifier=?)
1898 (arg-check nonsymbol-id? y 'free-identifier=?)
1901 (set! bound-identifier=?
1903 (arg-check nonsymbol-id? x 'bound-identifier=?)
1904 (arg-check nonsymbol-id? y 'bound-identifier=?)
1908 (lambda (object . messages)
1909 (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
1910 (let ((message (if (null? messages)
1912 (apply string-append messages))))
1913 (error-hook #f message (strip object empty-wrap)))))
1915 (set! install-global-transformer
1917 (arg-check symbol? sym 'define-syntax)
1918 (arg-check procedure? v 'define-syntax)
1919 (global-extend 'macro sym v)))
1921 ;;; syntax-dispatch expects an expression and a pattern. If the expression
1922 ;;; matches the pattern a list of the matching expressions for each
1923 ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
1924 ;;; not work on r4rs implementations that violate the ieee requirement
1925 ;;; that #f and () be distinct.)
1927 ;;; The expression is matched with the pattern as follows:
1929 ;;; pattern: matches:
1932 ;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
1934 ;;; #(free-id <key>) <key> with free-identifier=?
1935 ;;; #(each <pattern>) (<pattern>*)
1936 ;;; #(vector <pattern>) (list->vector <pattern>)
1937 ;;; #(atom <object>) <object> with "equal?"
1939 ;;; Vector cops out to pair under assumption that vectors are rare. If
1940 ;;; not, should convert to:
1941 ;;; #(vector <pattern>*) #(<pattern>*)
1949 (match-each (annotation-expression e) p w))
1951 (let ((first (match (car e) p w '())))
1953 (let ((rest (match-each (cdr e) p w)))
1954 (and rest (cons first rest))))))
1957 (match-each (syntax-object-expression e)
1959 (join-wraps w (syntax-object-wrap e))))
1962 (define match-each-any
1966 (match-each-any (annotation-expression e) w))
1968 (let ((l (match-each-any (cdr e) w)))
1969 (and l (cons (wrap (car e) w) l))))
1972 (match-each-any (syntax-object-expression e)
1973 (join-wraps w (syntax-object-wrap e))))
1980 ((eq? p 'any) (cons '() r))
1981 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
1982 ((eq? p 'each-any) (cons '() r))
1984 (case (vector-ref p 0)
1985 ((each) (match-empty (vector-ref p 1) r))
1987 ((vector) (match-empty (vector-ref p 1) r)))))))
1992 ((null? p) (and (null? e) r))
1994 (and (pair? e) (match (car e) (car p) w
1995 (match (cdr e) (cdr p) w r))))
1997 (let ((l (match-each-any e w))) (and l (cons l r))))
1999 (case (vector-ref p 0)
2002 (match-empty (vector-ref p 1) r)
2003 (let ((l (match-each e (vector-ref p 1) w)))
2005 (let collect ((l l))
2008 (cons (map car l) (collect (map cdr l)))))))))
2009 ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r))
2010 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2013 (match (vector->list e) (vector-ref p 1) w r))))))))
2019 ((eq? p 'any) (cons (wrap e w) r))
2022 (unannotate (syntax-object-expression e))
2024 (join-wraps w (syntax-object-wrap e))
2026 (else (match* (unannotate e) p w r)))))
2028 (set! syntax-dispatch
2031 ((eq? p 'any) (list e))
2033 (match* (unannotate (syntax-object-expression e))
2034 p (syntax-object-wrap e) '()))
2035 (else (match* (unannotate e) p empty-wrap '())))))
2041 (define-syntax with-syntax
2045 (syntax (begin e1 e2 ...)))
2046 ((_ ((out in)) e1 e2 ...)
2047 (syntax (syntax-case in () (out (begin e1 e2 ...)))))
2048 ((_ ((out in) ...) e1 e2 ...)
2049 (syntax (syntax-case (list in ...) ()
2050 ((out ...) (begin e1 e2 ...))))))))
2052 (define-syntax syntax-rules
2055 ((_ (k ...) ((keyword . pattern) template) ...)
2057 (syntax-case x (k ...)
2058 ((dummy . pattern) (syntax template))
2064 ((let* ((x v) ...) e1 e2 ...)
2065 (andmap identifier? (syntax (x ...)))
2066 (let f ((bindings (syntax ((x v) ...))))
2067 (if (null? bindings)
2068 (syntax (let () e1 e2 ...))
2069 (with-syntax ((body (f (cdr bindings)))
2070 (binding (car bindings)))
2071 (syntax (let (binding) body)))))))))
2075 (syntax-case orig-x ()
2076 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2077 (with-syntax (((step ...)
2082 (_ (syntax-error orig-x))))
2084 (syntax (step ...)))))
2085 (syntax-case (syntax (e1 ...)) ()
2086 (() (syntax (let doloop ((var init) ...)
2088 (begin c ... (doloop step ...))))))
2090 (syntax (let doloop ((var init) ...)
2093 (begin c ... (doloop step ...))))))))))))
2095 (define-syntax quasiquote
2099 (with-syntax ((x x) (y y))
2100 (syntax-case (syntax y) (quote list)
2102 (syntax-case (syntax x) (quote)
2103 ((quote dx) (syntax (quote (dx . dy))))
2104 (_ (if (null? (syntax dy))
2106 (syntax (cons x y))))))
2107 ((list . stuff) (syntax (list x . stuff)))
2108 (else (syntax (cons x y)))))))
2111 (with-syntax ((x x) (y y))
2112 (syntax-case (syntax y) (quote)
2113 ((quote ()) (syntax x))
2114 (_ (syntax (append x y)))))))
2117 (with-syntax ((x x))
2118 (syntax-case (syntax x) (quote list)
2119 ((quote (x ...)) (syntax (quote #(x ...))))
2120 ((list x ...) (syntax (vector x ...)))
2121 (_ (syntax (list->vector x)))))))
2124 (syntax-case p (unquote unquote-splicing quasiquote)
2128 (quasicons (syntax (quote unquote))
2129 (quasi (syntax (p)) (- lev 1)))))
2130 (((unquote-splicing p) . q)
2132 (quasiappend (syntax p) (quasi (syntax q) lev))
2133 (quasicons (quasicons (syntax (quote unquote-splicing))
2134 (quasi (syntax (p)) (- lev 1)))
2135 (quasi (syntax q) lev))))
2137 (quasicons (syntax (quote quasiquote))
2138 (quasi (syntax (p)) (+ lev 1))))
2140 (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
2141 (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
2142 (p (syntax (quote p)))))))
2145 ((_ e) (quasi (syntax e) 0))))))
2147 (define-syntax include
2151 (let ((p (open-input-file fn)))
2152 (let f ((x (read p)))
2154 (begin (close-input-port p) '())
2155 (cons (datum->syntax-object k x)
2159 (let ((fn (syntax-object->datum (syntax filename))))
2160 (with-syntax (((exp ...) (read-file fn (syntax k))))
2161 (syntax (begin exp ...))))))))
2163 (define-syntax unquote
2168 "expression ,~s not valid outside of quasiquote"
2169 (syntax-object->datum (syntax e)))))))
2171 (define-syntax unquote-splicing
2175 (error 'unquote-splicing
2176 "expression ,@~s not valid outside of quasiquote"
2177 (syntax-object->datum (syntax e)))))))
2184 ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
2186 (syntax-case clause (else)
2187 ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
2188 (((k ...) e1 e2 ...)
2189 (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
2190 (_ (syntax-error x)))
2191 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2192 (syntax-case clause (else)
2193 (((k ...) e1 e2 ...)
2194 (syntax (if (memv t '(k ...))
2197 (_ (syntax-error x))))))))
2198 (syntax (let ((t e)) body)))))))
2200 (define-syntax identifier-syntax
2208 (identifier? (syntax id))
2211 (syntax (e x (... ...)))))))))))