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=?
56 ;;; generate-temporaries
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-violation who message form [subform])
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 ;;; ($sc-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.
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 (set-current-module (resolve-module '(guile))))
263 (define-syntax define-structure
265 (define construct-name
266 (lambda (template-identifier . args)
274 (symbol->string (syntax->datum x))))
278 (andmap identifier? (syntax (name id1 ...)))
280 ((constructor (construct-name (syntax name) "make-" (syntax name)))
281 (predicate (construct-name (syntax name) (syntax name) "?"))
283 (map (lambda (x) (construct-name x (syntax name) "-" x))
287 (construct-name x "set-" (syntax name) "-" x "!"))
290 (+ (length (syntax (id1 ...))) 1))
292 (let f ((i 1) (ids (syntax (id1 ...))))
295 (cons i (f (+ i 1) (cdr ids)))))))
299 (vector 'name id1 ... )))
303 (= (vector-length x) structure-length)
304 (eq? (vector-ref x 0) 'name))))
307 (vector-ref x index)))
311 (vector-set! x index update)))
315 (define noexpand "noexpand")
317 ;;; hooks to nonportable run-time helpers
324 (define top-level-eval-hook
326 (primitive-eval `(,noexpand ,x))))
328 (define local-eval-hook
330 (primitive-eval `(,noexpand ,x))))
333 (lambda (who why what)
334 (error who "~a ~s" why what)))
336 (define-syntax gensym-hook
340 (define put-global-definition-hook
341 (lambda (symbol type val)
342 (module-define-keyword! (current-module) symbol type val)))
344 (define remove-global-definition-hook
346 (module-undefine-keyword! (current-module) symbol)))
348 (define get-global-definition-hook
349 (lambda (symbol module)
350 (if (and (not module) (current-module))
351 (warn "module system is booted, we should have a module" symbol))
352 (module-lookup-keyword (if module (resolve-module (cdr module))
359 ;;; output constructors
360 (define (build-annotated src exp)
361 (if (and src (not (annotation? exp)))
362 (make-annotation exp src #t)
365 (define-syntax build-application
367 ((_ source fun-exp arg-exps)
368 (build-annotated source `(,fun-exp . ,arg-exps)))))
370 (define-syntax build-conditional
372 ((_ source test-exp then-exp else-exp)
373 (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
375 (define-syntax build-lexical-reference
378 (build-annotated source var))))
380 (define-syntax build-lexical-assignment
383 (build-annotated source `(set! ,var ,exp)))))
385 (define-syntax build-global-reference
391 (make-module-ref (cdr mod) var (car mod))
392 (make-module-ref mod var 'bare))))))
394 (define-syntax build-global-assignment
396 ((_ source var exp mod)
397 (build-annotated source
399 (make-module-ref (cdr mod) var (car mod))
400 (make-module-ref mod var 'bare))
403 (define-syntax build-global-definition
405 ((_ source var exp mod)
406 (build-annotated source `(define ,var ,exp)))))
408 (define-syntax build-lambda
410 ((_ src vars docstring exp)
411 (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
414 (build-annotated src `(lambda ,vars ,exp)))))
416 ;; FIXME: wingo: add modules here somehow?
417 (define-syntax build-primref
419 ((_ src name) (build-annotated src name))
420 ((_ src level name) (build-annotated src name))))
422 (define (build-data src exp)
423 (if (and (self-evaluating? exp)
425 (build-annotated src exp)
426 (build-annotated src (list 'quote exp))))
428 (define build-sequence
430 (if (null? (cdr exps))
431 (build-annotated src (car exps))
432 (build-annotated src `(begin ,@exps)))))
435 (lambda (src vars val-exps body-exp)
437 (build-annotated src body-exp)
438 (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
440 (define build-named-let
441 (lambda (src vars val-exps body-exp)
443 (build-annotated src body-exp)
446 ,(map list (cdr vars) val-exps) ,body-exp)))))
449 (lambda (src vars val-exps body-exp)
451 (build-annotated src body-exp)
453 `(letrec ,(map list vars val-exps) ,body-exp)))))
455 ;; FIXME: wingo: use make-lexical
456 (define-syntax build-lexical-var
458 ((_ src id) (build-annotated src (gensym (symbol->string id))))))
460 (define-structure (syntax-object expression wrap module))
462 (define-syntax unannotate
467 (annotation-expression e)
470 (define-syntax no-source (identifier-syntax #f))
472 (define source-annotation
475 ((annotation? x) (annotation-source x))
476 ((syntax-object? x) (source-annotation (syntax-object-expression x)))
479 (define-syntax arg-check
483 (if (not (pred? x)) (error-hook who "invalid argument" x))))))
485 ;;; compile-time environments
487 ;;; wrap and environment comprise two level mapping.
488 ;;; wrap : id --> label
489 ;;; env : label --> <element>
491 ;;; environments are represented in two parts: a lexical part and a global
492 ;;; part. The lexical part is a simple list of associations from labels
493 ;;; to bindings. The global part is implemented by
494 ;;; {put,get}-global-definition-hook and associates symbols with
497 ;;; global (assumed global variable) and displaced-lexical (see below)
498 ;;; do not show up in any environment; instead, they are fabricated by
499 ;;; lookup when it finds no other bindings.
501 ;;; <environment> ::= ((<label> . <binding>)*)
503 ;;; identifier bindings include a type and a value
505 ;;; <binding> ::= (macro . <procedure>) macros
506 ;;; (core . <procedure>) core forms
507 ;;; (external-macro . <procedure>) external-macro
508 ;;; (module-ref . <procedure>) @ or @@
511 ;;; (define-syntax) define-syntax
512 ;;; (local-syntax . rec?) let-syntax/letrec-syntax
513 ;;; (eval-when) eval-when
514 ;;; (syntax . (<var> . <level>)) pattern variables
515 ;;; (global) assumed global variable
516 ;;; (lexical . <var>) lexical variables
517 ;;; (displaced-lexical) displaced lexicals
518 ;;; <level> ::= <nonnegative integer>
519 ;;; <var> ::= variable returned by build-lexical-var
521 ;;; a macro is a user-defined syntactic-form. a core is a system-defined
522 ;;; syntactic form. begin, define, define-syntax, and eval-when are
523 ;;; treated specially since they are sensitive to whether the form is
524 ;;; at top-level and (except for eval-when) can denote valid internal
527 ;;; a pattern variable is a variable introduced by syntax-case and can
528 ;;; be referenced only within a syntax form.
530 ;;; any identifier for which no top-level syntax definition or local
531 ;;; binding of any kind has been seen is assumed to be a global
534 ;;; a lexical variable is a lambda- or letrec-bound variable.
536 ;;; a displaced-lexical identifier is a lexical identifier removed from
537 ;;; it's scope by the return of a syntax object containing the identifier.
538 ;;; a displaced lexical can also appear when a letrec-syntax-bound
539 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
540 ;;; a displaced lexical should never occur with properly written macros.
542 (define-syntax make-binding
543 (syntax-rules (quote)
544 ((_ type value) (cons type value))
546 ((_ type) (cons type '()))))
547 (define binding-type car)
548 (define binding-value cdr)
550 (define-syntax null-env (identifier-syntax '()))
553 (lambda (labels bindings r)
556 (extend-env (cdr labels) (cdr bindings)
557 (cons (cons (car labels) (car bindings)) r)))))
559 (define extend-var-env
560 ; variant of extend-env that forms "lexical" binding
561 (lambda (labels vars r)
564 (extend-var-env (cdr labels) (cdr vars)
565 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
567 ;;; we use a "macros only" environment in expansion of local macro
568 ;;; definitions so that their definitions can use local macros without
569 ;;; attempting to use other lexical identifiers.
570 (define macros-only-env
575 (if (eq? (cadr a) 'macro)
576 (cons a (macros-only-env (cdr r)))
577 (macros-only-env (cdr r)))))))
580 ; x may be a label or a symbol
581 ; although symbols are usually global, we check the environment first
582 ; anyway because a temporary binding may have been established by
588 (or (get-global-definition-hook x mod) (make-binding 'global)))
589 (else (make-binding 'displaced-lexical)))))
591 (define global-extend
592 (lambda (type sym val)
593 (put-global-definition-hook sym type val)))
596 ;;; Conceptually, identifiers are always syntax objects. Internally,
597 ;;; however, the wrap is sometimes maintained separately (a source of
598 ;;; efficiency and confusion), so that symbols are also considered
599 ;;; identifiers by id?. Externally, they are always wrapped.
601 (define nonsymbol-id?
603 (and (syntax-object? x)
604 (symbol? (unannotate (syntax-object-expression x))))))
610 ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
611 ((annotation? x) (symbol? (annotation-expression x)))
614 (define-syntax id-sym-name
618 (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
620 (define id-sym-name&marks
622 (if (syntax-object? x)
624 (unannotate (syntax-object-expression x))
625 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
626 (values (unannotate x) (wrap-marks w)))))
628 ;;; syntax object wraps
630 ;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
631 ;;; <subst> ::= <shift> | <subs>
632 ;;; <subs> ::= #(<old name> <label> (<mark> ...))
633 ;;; <shift> ::= positive fixnum
635 (define make-wrap cons)
636 (define wrap-marks car)
637 (define wrap-subst cdr)
639 (define-syntax subst-rename? (identifier-syntax vector?))
640 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
641 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
642 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
643 (define-syntax make-rename
645 ((_ old new marks) (vector old new marks))))
647 ;;; labels must be comparable with "eq?" and distinct from symbols.
649 (lambda () (string #\i)))
655 (cons (gen-label) (gen-labels (cdr ls))))))
657 (define-structure (ribcage symnames marks labels))
659 (define-syntax empty-wrap (identifier-syntax '(())))
661 (define-syntax top-wrap (identifier-syntax '((top))))
663 (define-syntax top-marked?
665 ((_ w) (memq 'top (wrap-marks w)))))
667 ;;; Marks must be comparable with "eq?" and distinct from pairs and
668 ;;; the symbol top. We do not use integers so that marks will remain
669 ;;; unique even across file compiles.
671 (define-syntax the-anti-mark (identifier-syntax #f))
675 (make-wrap (cons the-anti-mark (wrap-marks w))
676 (cons 'shift (wrap-subst w)))))
678 (define-syntax new-mark
682 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
683 ;;; internal definitions, in which the ribcages are built incrementally
684 (define-syntax make-empty-ribcage
686 ((_) (make-ribcage '() '() '()))))
688 (define extend-ribcage!
689 ; must receive ids with complete wraps
690 (lambda (ribcage id label)
691 (set-ribcage-symnames! ribcage
692 (cons (unannotate (syntax-object-expression id))
693 (ribcage-symnames ribcage)))
694 (set-ribcage-marks! ribcage
695 (cons (wrap-marks (syntax-object-wrap id))
696 (ribcage-marks ribcage)))
697 (set-ribcage-labels! ribcage
698 (cons label (ribcage-labels ribcage)))))
700 ;;; make-binding-wrap creates vector-based ribcages
701 (define make-binding-wrap
702 (lambda (ids labels w)
708 (let ((labelvec (list->vector labels)))
709 (let ((n (vector-length labelvec)))
710 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
711 (let f ((ids ids) (i 0))
712 (if (not (null? ids))
714 (lambda () (id-sym-name&marks (car ids) w))
715 (lambda (symname marks)
716 (vector-set! symnamevec i symname)
717 (vector-set! marksvec i marks)
718 (f (cdr ids) (fx+ i 1))))))
719 (make-ribcage symnamevec marksvec labelvec))))
730 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
736 (smart-append s1 (wrap-subst w2))))
738 (smart-append m1 (wrap-marks w2))
739 (smart-append s1 (wrap-subst w2)))))))
743 (smart-append m1 m2)))
750 (eq? (car x) (car y))
751 (same-marks? (cdr x) (cdr y))))))
757 ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
759 (lambda (sym subst marks)
762 (let ((fst (car subst)))
764 (search sym (cdr subst) (cdr marks))
765 (let ((symnames (ribcage-symnames fst)))
766 (if (vector? symnames)
767 (search-vector-rib sym subst marks symnames fst)
768 (search-list-rib sym subst marks symnames fst))))))))
769 (define search-list-rib
770 (lambda (sym subst marks symnames ribcage)
771 (let f ((symnames symnames) (i 0))
773 ((null? symnames) (search sym (cdr subst) marks))
774 ((and (eq? (car symnames) sym)
775 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
776 (values (list-ref (ribcage-labels ribcage) i) marks))
777 (else (f (cdr symnames) (fx+ i 1)))))))
778 (define search-vector-rib
779 (lambda (sym subst marks symnames ribcage)
780 (let ((n (vector-length symnames)))
783 ((fx= i n) (search sym (cdr subst) marks))
784 ((and (eq? (vector-ref symnames i) sym)
785 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
786 (values (vector-ref (ribcage-labels ribcage) i) marks))
787 (else (f (fx+ i 1))))))))
790 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
792 (let ((id (unannotate (syntax-object-expression id)))
793 (w1 (syntax-object-wrap id)))
794 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
795 (call-with-values (lambda () (search id (wrap-subst w) marks))
796 (lambda (new-id marks)
798 (first (search id (wrap-subst w1) marks))
801 (let ((id (unannotate id)))
802 (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
803 (else (error-hook 'id-var-name "invalid id" id)))))
805 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
806 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
810 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
811 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
813 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
814 ;;; long as the missing portion of the wrap is common to both of the ids
815 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
819 (if (and (syntax-object? i) (syntax-object? j))
820 (and (eq? (unannotate (syntax-object-expression i))
821 (unannotate (syntax-object-expression j)))
822 (same-marks? (wrap-marks (syntax-object-wrap i))
823 (wrap-marks (syntax-object-wrap j))))
824 (eq? (unannotate i) (unannotate j)))))
826 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
827 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
828 ;;; as long as the missing portion of the wrap is common to all of the
831 (define valid-bound-ids?
833 (and (let all-ids? ((ids ids))
836 (all-ids? (cdr ids)))))
837 (distinct-bound-ids? ids))))
839 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
840 ;;; no duplicates. It is quadratic on the length of the id list; long
841 ;;; lists could be sorted to make it more efficient. distinct-bound-ids?
842 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
843 ;;; missing portion of the wrap is common to all of the ids.
845 (define distinct-bound-ids?
847 (let distinct? ((ids ids))
849 (and (not (bound-id-member? (car ids) (cdr ids)))
850 (distinct? (cdr ids)))))))
852 (define bound-id-member?
854 (and (not (null? list))
855 (or (bound-id=? x (car list))
856 (bound-id-member? x (cdr list))))))
858 ;;; wrapping expressions and identifiers
863 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
866 (syntax-object-expression x)
867 (join-wraps w (syntax-object-wrap x))
868 (syntax-object-module x)))
870 (else (make-syntax-object x w defmod)))))
873 (lambda (x w s defmod)
874 (wrap (if s (make-annotation x s #f) x) w defmod)))
879 (lambda (body r w s mod)
881 (let dobody ((body body) (r r) (w w) (mod mod))
884 (let ((first (chi (car body) r w mod)))
885 (cons first (dobody (cdr body) r w mod))))))))
887 (define chi-top-sequence
888 (lambda (body r w s m esew mod)
890 (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
893 (let ((first (chi-top (car body) r w m esew mod)))
894 (cons first (dobody (cdr body) r w m esew mod))))))))
897 (define chi-install-global
899 (build-application no-source
900 (build-primref no-source 'install-global-transformer)
901 (list (build-data no-source name) e))))
903 (define chi-when-list
904 (lambda (e when-list w)
905 ; when-list is syntax'd version of list of situations
906 (let f ((when-list when-list) (situations '()))
907 (if (null? when-list)
910 (cons (let ((x (car when-list)))
912 ((free-id=? x (syntax compile)) 'compile)
913 ((free-id=? x (syntax load)) 'load)
914 ((free-id=? x (syntax eval)) 'eval)
915 (else (syntax-violation 'eval-when
920 ;;; syntax-type returns six values: type, value, e, w, s, and mod. The
921 ;;; first two are described in the table below.
923 ;;; type value explanation
924 ;;; -------------------------------------------------------------------
925 ;;; core procedure core form (including singleton)
926 ;;; external-macro procedure external macro
927 ;;; module-ref procedure @ or @@ form
928 ;;; lexical name lexical variable reference
929 ;;; global name global variable reference
930 ;;; begin none begin keyword
931 ;;; define none define keyword
932 ;;; define-syntax none define-syntax keyword
933 ;;; local-syntax rec? letrec-syntax/let-syntax keyword
934 ;;; eval-when none eval-when keyword
935 ;;; syntax level pattern variable
936 ;;; displaced-lexical none displaced lexical identifier
937 ;;; lexical-call name call to lexical variable
938 ;;; global-call name call to global variable
939 ;;; call none any other call
940 ;;; begin-form none begin expression
941 ;;; define-form id variable definition
942 ;;; define-syntax-form id syntax definition
943 ;;; local-syntax-form rec? syntax definition
944 ;;; eval-when-form none eval-when form
945 ;;; constant none self-evaluating datum
946 ;;; other none anything else
948 ;;; For define-form and define-syntax-form, e is the rhs expression.
949 ;;; For all others, e is the entire form. w is the wrap for e.
950 ;;; s is the source for the entire form. mod is the module for e.
952 ;;; syntax-type expands macros and unwraps as necessary to get to
953 ;;; one of the forms above. It also parses define and define-syntax
954 ;;; forms, although perhaps this should be done by the consumer.
957 (lambda (e r w s rib mod)
960 (let* ((n (id-var-name e w))
962 (type (binding-type b)))
964 ((lexical) (values type (binding-value b) e w s mod))
965 ((global) (values type n e w s mod))
967 (syntax-type (chi-macro (binding-value b) e r w rib mod)
968 r empty-wrap s rib mod))
969 (else (values type (binding-value b) e w s mod)))))
971 (let ((first (car e)))
973 (let* ((n (id-var-name first w))
974 (b (lookup n r (or (and (syntax-object? first)
975 (syntax-object-module first))
977 (type (binding-type b)))
980 (values 'lexical-call (binding-value b) e w s mod))
982 (values 'global-call n e w s mod))
984 (syntax-type (chi-macro (binding-value b) e r w rib mod)
985 r empty-wrap s rib mod))
986 ((core external-macro module-ref)
987 (values type (binding-value b) e w s mod))
989 (values 'local-syntax-form (binding-value b) e w s mod))
991 (values 'begin-form #f e w s mod))
993 (values 'eval-when-form #f e w s mod))
998 (values 'define-form (syntax name) (syntax val) w s mod))
999 ((_ (name . args) e1 e2 ...)
1000 (and (id? (syntax name))
1001 (valid-bound-ids? (lambda-var-list (syntax args))))
1002 ; need lambda here...
1003 (values 'define-form (wrap (syntax name) w mod)
1004 (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
1008 (values 'define-form (wrap (syntax name) w mod)
1010 empty-wrap s mod))))
1015 (values 'define-syntax-form (syntax name)
1016 (syntax val) w s mod))))
1018 (values 'call #f e w s mod))))
1019 (values 'call #f e w s mod))))
1021 ;; s can't be valid source if we've unwrapped
1022 (syntax-type (syntax-object-expression e)
1024 (join-wraps w (syntax-object-wrap e))
1025 no-source rib (or (syntax-object-module e) mod)))
1027 (syntax-type (annotation-expression e) r w (annotation-source e) rib mod))
1028 ((self-evaluating? e) (values 'constant #f e w s mod))
1029 (else (values 'other #f e w s mod)))))
1032 (lambda (e r w m esew mod)
1033 (define-syntax eval-if-c&e
1037 (if (eq? m 'c&e) (top-level-eval-hook x mod))
1040 (lambda () (syntax-type e r w no-source #f mod))
1041 (lambda (type value e w s mod)
1047 (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
1048 ((local-syntax-form)
1049 (chi-local-syntax value e r w s mod
1050 (lambda (body r w s mod)
1051 (chi-top-sequence body r w s m esew mod))))
1054 ((_ (x ...) e1 e2 ...)
1055 (let ((when-list (chi-when-list e (syntax (x ...)) w))
1056 (body (syntax (e1 e2 ...))))
1059 (if (memq 'eval when-list)
1060 (chi-top-sequence body r w s 'e '(eval) mod)
1062 ((memq 'load when-list)
1063 (if (or (memq 'compile when-list)
1064 (and (eq? m 'c&e) (memq 'eval when-list)))
1065 (chi-top-sequence body r w s 'c&e '(compile load) mod)
1066 (if (memq m '(c c&e))
1067 (chi-top-sequence body r w s 'c '(load) mod)
1069 ((or (memq 'compile when-list)
1070 (and (eq? m 'c&e) (memq 'eval when-list)))
1071 (top-level-eval-hook
1072 (chi-top-sequence body r w s 'e '(eval) mod)
1075 (else (chi-void)))))))
1076 ((define-syntax-form)
1077 (let ((n (id-var-name value w)) (r (macros-only-env r)))
1080 (if (memq 'compile esew)
1081 (let ((e (chi-install-global n (chi e r w mod))))
1082 (top-level-eval-hook e mod)
1083 (if (memq 'load esew) e (chi-void)))
1084 (if (memq 'load esew)
1085 (chi-install-global n (chi e r w mod))
1088 (let ((e (chi-install-global n (chi e r w mod))))
1089 (top-level-eval-hook e mod)
1092 (if (memq 'eval esew)
1093 (top-level-eval-hook
1094 (chi-install-global n (chi e r w mod))
1098 (let* ((n (id-var-name value w))
1099 (type (binding-type (lookup n r mod))))
1103 (build-global-definition s n (chi e r w mod) mod)
1105 ((displaced-lexical)
1106 (syntax-violation #f "identifier out of context"
1107 e (wrap value w mod)))
1108 ((core macro module-ref)
1109 (remove-global-definition-hook n)
1111 (build-global-definition s n (chi e r w mod) mod)
1114 (syntax-violation #f "cannot define keyword at top level"
1115 e (wrap value w mod))))))
1116 (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
1121 (lambda () (syntax-type e r w no-source #f mod))
1122 (lambda (type value e w s mod)
1123 (chi-expr type value e r w s mod)))))
1126 (lambda (type value e r w s mod)
1129 (build-lexical-reference 'value s value))
1130 ((core external-macro)
1131 ;; apply transformer
1132 (value e r w s mod))
1134 (call-with-values (lambda () (value e))
1135 ;; we could add a public? arg here
1136 (lambda (id mod) (build-global-reference s id mod))))
1139 (build-lexical-reference 'fun (source-annotation (car e)) value)
1143 (build-global-reference (source-annotation (car e)) value
1144 (if (syntax-object? (car e))
1145 (syntax-object-module (car e))
1148 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1149 ((global) (build-global-reference s value mod))
1150 ((call) (chi-application (chi (car e) r w mod) e r w s mod))
1153 ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
1154 ((local-syntax-form)
1155 (chi-local-syntax value e r w s mod chi-sequence))
1158 ((_ (x ...) e1 e2 ...)
1159 (let ((when-list (chi-when-list e (syntax (x ...)) w)))
1160 (if (memq 'eval when-list)
1161 (chi-sequence (syntax (e1 e2 ...)) r w s mod)
1163 ((define-form define-syntax-form)
1164 (syntax-violation #f "definition in expression context"
1165 e (wrap value w mod)))
1167 (syntax-violation #f "reference to pattern variable outside syntax form"
1168 (source-wrap e w s mod)))
1169 ((displaced-lexical)
1170 (syntax-violation #f (source-wrap e w s mod)
1171 "reference to identifier outside its scope"))
1172 (else (syntax-violation #f "unexpected syntax"
1173 (source-wrap e w s mod))))))
1175 (define chi-application
1176 (lambda (x e r w s mod)
1179 (build-application s x
1180 (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
1183 (lambda (p e r w rib mod)
1184 (define rebuild-macro-output
1187 (cons (rebuild-macro-output (car x) m)
1188 (rebuild-macro-output (cdr x) m)))
1190 (let ((w (syntax-object-wrap x)))
1191 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1192 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1193 ;; output is from original text
1195 (syntax-object-expression x)
1196 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1197 (syntax-object-module x))
1198 ;; output introduced by macro
1200 (syntax-object-expression x)
1201 (make-wrap (cons m ms)
1203 (cons rib (cons 'shift s))
1205 (let ((pmod (procedure-module p)))
1207 ;; hither the hygiene
1208 (cons 'hygiene (module-name pmod))
1209 ;; but it's possible for the proc to have
1210 ;; no mod, if it was made before modules
1212 '(hygiene guile))))))))
1214 (let* ((n (vector-length x)) (v (make-vector n)))
1215 (do ((i 0 (fx+ i 1)))
1218 (rebuild-macro-output (vector-ref x i) m)))))
1220 (syntax-violation #f "encountered raw symbol in macro output"
1221 (source-wrap e w s mod) x))
1223 (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
1226 ;; In processing the forms of the body, we create a new, empty wrap.
1227 ;; This wrap is augmented (destructively) each time we discover that
1228 ;; the next form is a definition. This is done:
1230 ;; (1) to allow the first nondefinition form to be a call to
1231 ;; one of the defined ids even if the id previously denoted a
1232 ;; definition keyword or keyword for a macro expanding into a
1234 ;; (2) to prevent subsequent definition forms (but unfortunately
1235 ;; not earlier ones) and the first nondefinition form from
1236 ;; confusing one of the bound identifiers for an auxiliary
1238 ;; (3) so that we do not need to restart the expansion of the
1239 ;; first nondefinition form, which is problematic anyway
1240 ;; since it might be the first element of a begin that we
1241 ;; have just spliced into the body (meaning if we restarted,
1242 ;; we'd really need to restart with the begin or the macro
1243 ;; call that expanded into the begin, and we'd have to give
1244 ;; up allowing (begin <defn>+ <expr>+), which is itself
1245 ;; problematic since we don't know if a begin contains only
1246 ;; definitions until we've expanded it).
1248 ;; Before processing the body, we also create a new environment
1249 ;; containing a placeholder for the bindings we will add later and
1250 ;; associate this environment with each form. In processing a
1251 ;; let-syntax or letrec-syntax, the associated environment may be
1252 ;; augmented with local keyword bindings, so the environment may
1253 ;; be different for different forms in the body. Once we have
1254 ;; gathered up all of the definitions, we evaluate the transformer
1255 ;; expressions and splice into r at the placeholder the new variable
1256 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1257 ;; forms local to a portion or all of the body to shadow the
1258 ;; definition bindings.
1260 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1263 ;; outer-form is fully wrapped w/source
1264 (lambda (body outer-form r w mod)
1265 (let* ((r (cons '("placeholder" . (placeholder)) r))
1266 (ribcage (make-empty-ribcage))
1267 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1268 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1269 (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
1271 (syntax-violation #f "no expressions in body" outer-form)
1272 (let ((e (cdar body)) (er (caar body)))
1274 (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
1275 (lambda (type value e w s mod)
1278 (let ((id (wrap value w mod)) (label (gen-label)))
1279 (let ((var (gen-var id)))
1280 (extend-ribcage! ribcage id label)
1282 (cons id ids) (cons label labels)
1283 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1284 (cons (make-binding 'lexical var) bindings)))))
1285 ((define-syntax-form)
1286 (let ((id (wrap value w mod)) (label (gen-label)))
1287 (extend-ribcage! ribcage id label)
1289 (cons id ids) (cons label labels)
1291 (cons (make-binding 'macro (cons er (wrap e w mod)))
1296 (parse (let f ((forms (syntax (e1 ...))))
1299 (cons (cons er (wrap (car forms) w mod))
1301 ids labels vars vals bindings))))
1302 ((local-syntax-form)
1303 (chi-local-syntax value e er w s mod
1304 (lambda (forms er w s mod)
1305 (parse (let f ((forms forms))
1308 (cons (cons er (wrap (car forms) w mod))
1310 ids labels vars vals bindings))))
1311 (else ; found a non-definition
1313 (build-sequence no-source
1315 (chi (cdr x) (car x) empty-wrap mod))
1316 (cons (cons er (source-wrap e w s mod))
1319 (if (not (valid-bound-ids? ids))
1321 #f "invalid or duplicate identifier in definition"
1323 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1324 (if (not (null? bs))
1325 (let* ((b (car bs)))
1326 (if (eq? (car b) 'macro)
1327 (let* ((er (cadr b))
1329 (if (eq? er er-cache)
1331 (macros-only-env er))))
1333 (eval-local-transformer
1334 (chi (cddr b) r-cache empty-wrap mod)
1336 (loop (cdr bs) er r-cache))
1337 (loop (cdr bs) er-cache r-cache)))))
1338 (set-cdr! r (extend-env labels bindings (cdr r)))
1339 (build-letrec no-source
1342 (chi (cdr x) (car x) empty-wrap mod))
1344 (build-sequence no-source
1346 (chi (cdr x) (car x) empty-wrap mod))
1347 (cons (cons er (source-wrap e w s mod))
1348 (cdr body)))))))))))))))))
1350 (define chi-lambda-clause
1351 (lambda (e docstring c r w mod k)
1353 ((args doc e1 e2 ...)
1354 (and (string? (syntax->datum (syntax doc))) (not docstring))
1355 (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
1356 (((id ...) e1 e2 ...)
1357 (let ((ids (syntax (id ...))))
1358 (if (not (valid-bound-ids? ids))
1359 (syntax-violation 'lambda "invalid parameter list" e)
1360 (let ((labels (gen-labels ids))
1361 (new-vars (map gen-var ids)))
1364 (chi-body (syntax (e1 e2 ...))
1366 (extend-var-env labels new-vars r)
1367 (make-binding-wrap ids labels w)
1370 (let ((old-ids (lambda-var-list (syntax ids))))
1371 (if (not (valid-bound-ids? old-ids))
1372 (syntax-violation 'lambda "invalid parameter list" e)
1373 (let ((labels (gen-labels old-ids))
1374 (new-vars (map gen-var old-ids)))
1375 (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
1378 (f (cdr ls1) (cons (car ls1) ls2))))
1380 (chi-body (syntax (e1 e2 ...))
1382 (extend-var-env labels new-vars r)
1383 (make-binding-wrap old-ids labels w)
1385 (_ (syntax-violation 'lambda "bad lambda" e)))))
1387 (define chi-local-syntax
1388 (lambda (rec? e r w s mod k)
1390 ((_ ((id val) ...) e1 e2 ...)
1391 (let ((ids (syntax (id ...))))
1392 (if (not (valid-bound-ids? ids))
1393 (syntax-violation #f "duplicate bound keyword" e)
1394 (let ((labels (gen-labels ids)))
1395 (let ((new-w (make-binding-wrap ids labels w)))
1396 (k (syntax (e1 e2 ...))
1399 (let ((w (if rec? new-w w))
1400 (trans-r (macros-only-env r)))
1402 (make-binding 'macro
1403 (eval-local-transformer
1404 (chi x trans-r w mod)
1406 (syntax (val ...))))
1411 (_ (syntax-violation #f "bad local syntax definition"
1412 (source-wrap e w s mod))))))
1414 (define eval-local-transformer
1415 (lambda (expanded mod)
1416 (let ((p (local-eval-hook expanded mod)))
1419 (syntax-violation #f "nonprocedure transformer" p)))))
1423 (build-application no-source (build-primref no-source 'void) '())))
1427 (and (nonsymbol-id? x)
1428 (free-id=? x (syntax (... ...))))))
1432 ;;; strips all annotations from potentially circular reader output
1434 (define strip-annotation
1438 (let ((new (cons #f #f)))
1439 (if parent (set-annotation-stripped! parent new))
1440 (set-car! new (strip-annotation (car x) #f))
1441 (set-cdr! new (strip-annotation (cdr x) #f))
1444 (or (annotation-stripped x)
1445 (strip-annotation (annotation-expression x) x)))
1447 (let ((new (make-vector (vector-length x))))
1448 (if parent (set-annotation-stripped! parent new))
1449 (let loop ((i (- (vector-length x) 1)))
1451 (vector-set! new i (strip-annotation (vector-ref x i) #f))
1456 ;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
1457 ;;; on an annotation, strips the annotation as well.
1458 ;;; since only the head of a list is annotated by the reader, not each pair
1459 ;;; in the spine, we also check for pairs whose cars are annotated in case
1460 ;;; we've been passed the cdr of an annotated list
1465 (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
1466 (strip-annotation x #f)
1471 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1473 (let ((a (f (car x))) (d (f (cdr x))))
1474 (if (and (eq? a (car x)) (eq? d (cdr x)))
1478 (let ((old (vector->list x)))
1479 (let ((new (map f old)))
1480 (if (andmap eq? old new) x (list->vector new)))))
1483 ;;; lexical variables
1487 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1488 (if (annotation? id)
1489 (build-lexical-var (annotation-source id) (annotation-expression id))
1490 (build-lexical-var no-source id)))))
1492 (define lambda-var-list
1494 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1496 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1497 ((id? vars) (cons (wrap vars w #f) ls))
1499 ((syntax-object? vars)
1500 (lvl (syntax-object-expression vars)
1502 (join-wraps w (syntax-object-wrap vars))))
1504 (lvl (annotation-expression vars) ls w))
1505 ; include anything else to be caught by subsequent error
1507 (else (cons vars ls))))))
1509 ;;; core transformers
1511 (global-extend 'local-syntax 'letrec-syntax #t)
1512 (global-extend 'local-syntax 'let-syntax #f)
1514 (global-extend 'core 'fluid-let-syntax
1515 (lambda (e r w s mod)
1517 ((_ ((var val) ...) e1 e2 ...)
1518 (valid-bound-ids? (syntax (var ...)))
1519 (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
1522 (case (binding-type (lookup n r mod))
1523 ((displaced-lexical)
1524 (syntax-violation 'fluid-let-syntax
1525 "identifier out of context"
1527 (source-wrap id w s mod)))))
1531 (syntax (e1 e2 ...))
1532 (source-wrap e w s mod)
1535 (let ((trans-r (macros-only-env r)))
1537 (make-binding 'macro
1538 (eval-local-transformer (chi x trans-r w mod)
1540 (syntax (val ...))))
1544 (_ (syntax-violation 'fluid-let-syntax "bad syntax"
1545 (source-wrap e w s mod))))))
1547 (global-extend 'core 'quote
1548 (lambda (e r w s mod)
1550 ((_ e) (build-data s (strip (syntax e) w)))
1551 (_ (syntax-violation 'quote "bad syntax"
1552 (source-wrap e w s mod))))))
1554 (global-extend 'core 'syntax
1557 (lambda (src e r maps ellipsis? mod)
1559 (let ((label (id-var-name e empty-wrap)))
1560 (let ((b (lookup label r mod)))
1561 (if (eq? (binding-type b) 'syntax)
1564 (let ((var.lev (binding-value b)))
1565 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1566 (lambda (var maps) (values `(ref ,var) maps)))
1568 (syntax-violation 'syntax "misplaced ellipsis" src)
1569 (values `(quote ,e) maps)))))
1572 (ellipsis? (syntax dots))
1573 (gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
1575 ; this could be about a dozen lines of code, except that we
1576 ; choose to handle (syntax (x ... ...)) forms
1577 (ellipsis? (syntax dots))
1578 (let f ((y (syntax y))
1582 (gen-syntax src (syntax x) r
1583 (cons '() maps) ellipsis? mod))
1585 (if (null? (car maps))
1586 (syntax-violation 'syntax "extra ellipsis"
1588 (values (gen-map x (car maps))
1592 (ellipsis? (syntax dots))
1596 (lambda () (k (cons '() maps)))
1598 (if (null? (car maps))
1599 (syntax-violation 'syntax "extra ellipsis" src)
1600 (values (gen-mappend x (car maps))
1602 (_ (call-with-values
1603 (lambda () (gen-syntax src y r maps ellipsis? mod))
1606 (lambda () (k maps))
1608 (values (gen-append x y) maps)))))))))
1611 (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
1614 (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod))
1615 (lambda (y maps) (values (gen-cons x y) maps))))))
1619 (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod))
1620 (lambda (e maps) (values (gen-vector e) maps))))
1621 (_ (values `(quote ,e) maps))))))
1624 (lambda (src var level maps)
1628 (syntax-violation 'syntax "missing ellipsis" src)
1630 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1631 (lambda (outer-var outer-maps)
1632 (let ((b (assq outer-var (car maps))))
1634 (values (cdr b) maps)
1635 (let ((inner-var (gen-var 'tmp)))
1637 (cons (cons (cons outer-var inner-var)
1639 outer-maps)))))))))))
1643 `(apply (primitive append) ,(gen-map e map-env))))
1647 (let ((formals (map cdr map-env))
1648 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1651 ; identity map equivalence:
1652 ; (map (lambda (x) x) y) == y
1655 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1657 ; eta map equivalence:
1658 ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1659 `(map (primitive ,(car e))
1660 ,@(map (let ((r (map cons formals actuals)))
1661 (lambda (x) (cdr (assq (cadr x) r))))
1663 (else `(map (lambda ,formals ,e) ,@actuals))))))
1669 (if (eq? (car x) 'quote)
1670 `(quote (,(cadr x) . ,(cadr y)))
1671 (if (eq? (cadr y) '())
1674 ((list) `(list ,x ,@(cdr y)))
1675 (else `(cons ,x ,y)))))
1679 (if (equal? y '(quote ()))
1686 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1687 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1688 (else `(list->vector ,x)))))
1694 ((ref) (build-lexical-reference 'value no-source (cadr x)))
1695 ((primitive) (build-primref no-source (cadr x)))
1696 ((quote) (build-data no-source (cadr x)))
1697 ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
1698 ((map) (let ((ls (map regen (cdr x))))
1699 (build-application no-source
1700 (if (fx= (length ls) 2)
1701 (build-primref no-source 'map)
1702 ; really need to do our own checking here
1703 (build-primref no-source 2 'map)) ; require error check
1705 (else (build-application no-source
1706 (build-primref no-source (car x))
1707 (map regen (cdr x)))))))
1709 (lambda (e r w s mod)
1710 (let ((e (source-wrap e w s mod)))
1714 (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
1715 (lambda (e maps) (regen e))))
1716 (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
1719 (global-extend 'core 'lambda
1720 (lambda (e r w s mod)
1723 (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
1724 (lambda (vars docstring body) (build-lambda s vars docstring body)))))))
1727 (global-extend 'core 'let
1729 (define (chi-let e r w s mod constructor ids vals exps)
1730 (if (not (valid-bound-ids? ids))
1731 (syntax-violation 'let "duplicate bound variable" e)
1732 (let ((labels (gen-labels ids))
1733 (new-vars (map gen-var ids)))
1734 (let ((nw (make-binding-wrap ids labels w))
1735 (nr (extend-var-env labels new-vars r)))
1738 (map (lambda (x) (chi x r w mod)) vals)
1739 (chi-body exps (source-wrap e nw s mod)
1741 (lambda (e r w s mod)
1743 ((_ ((id val) ...) e1 e2 ...)
1744 (chi-let e r w s mod
1748 (syntax (e1 e2 ...))))
1749 ((_ f ((id val) ...) e1 e2 ...)
1751 (chi-let e r w s mod
1755 (syntax (e1 e2 ...))))
1756 (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
1759 (global-extend 'core 'letrec
1760 (lambda (e r w s mod)
1762 ((_ ((id val) ...) e1 e2 ...)
1763 (let ((ids (syntax (id ...))))
1764 (if (not (valid-bound-ids? ids))
1765 (syntax-violation 'letrec "duplicate bound variable" e)
1766 (let ((labels (gen-labels ids))
1767 (new-vars (map gen-var ids)))
1768 (let ((w (make-binding-wrap ids labels w))
1769 (r (extend-var-env labels new-vars r)))
1772 (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
1773 (chi-body (syntax (e1 e2 ...))
1774 (source-wrap e w s mod) r w mod)))))))
1775 (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
1778 (global-extend 'core 'set!
1779 (lambda (e r w s mod)
1783 (let ((val (chi (syntax val) r w mod))
1784 (n (id-var-name (syntax id) w)))
1785 (let ((b (lookup n r mod)))
1786 (case (binding-type b)
1788 (build-lexical-assignment s (binding-value b) val))
1789 ((global) (build-global-assignment s n val mod))
1790 ((displaced-lexical)
1791 (syntax-violation 'set! "identifier out of context"
1792 (wrap (syntax id) w mod)))
1793 (else (syntax-violation 'set! "bad set!"
1794 (source-wrap e w s mod)))))))
1795 ((_ (head tail ...) val)
1797 (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod))
1798 (lambda (type value ee ww ss modmod)
1801 (let ((val (chi (syntax val) r w mod)))
1802 (call-with-values (lambda () (value (syntax (head tail ...))))
1804 (build-global-assignment s id val mod)))))
1806 (build-application s
1807 (chi (syntax (setter head)) r w mod)
1808 (map (lambda (e) (chi e r w mod))
1809 (syntax (tail ... val)))))))))
1810 (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
1812 (global-extend 'module-ref '@
1816 (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
1817 (values (syntax->datum (syntax id))
1819 (syntax (public mod ...))))))))
1821 (global-extend 'module-ref '@@
1825 (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
1826 (values (syntax->datum (syntax id))
1828 (syntax (private mod ...))))))))
1830 (global-extend 'begin 'begin '())
1832 (global-extend 'define 'define '())
1834 (global-extend 'define-syntax 'define-syntax '())
1836 (global-extend 'eval-when 'eval-when '())
1838 (global-extend 'core 'syntax-case
1840 (define convert-pattern
1841 ; accepts pattern & keys
1842 ; returns $sc-dispatch pattern & ids
1843 (lambda (pattern keys)
1844 (let cvt ((p pattern) (n 0) (ids '()))
1846 (if (bound-id-member? p keys)
1847 (values (vector 'free-id p) ids)
1848 (values 'any (cons (cons p n) ids)))
1851 (ellipsis? (syntax dots))
1853 (lambda () (cvt (syntax x) (fx+ n 1) ids))
1855 (values (if (eq? p 'any) 'each-any (vector 'each p))
1859 (lambda () (cvt (syntax y) n ids))
1862 (lambda () (cvt (syntax x) n ids))
1864 (values (cons x y) ids))))))
1865 (() (values '() ids))
1868 (lambda () (cvt (syntax (x ...)) n ids))
1869 (lambda (p ids) (values (vector 'vector p) ids))))
1870 (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
1872 (define build-dispatch-call
1873 (lambda (pvars exp y r mod)
1874 (let ((ids (map car pvars)) (levels (map cdr pvars)))
1875 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1876 (build-application no-source
1877 (build-primref no-source 'apply)
1878 (list (build-lambda no-source new-vars
1882 (map (lambda (var level)
1883 (make-binding 'syntax `(,var . ,level)))
1887 (make-binding-wrap ids labels empty-wrap)
1892 (lambda (x keys clauses r pat fender exp mod)
1894 (lambda () (convert-pattern pat keys))
1897 ((not (distinct-bound-ids? (map car pvars)))
1898 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
1899 ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
1900 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
1902 (let ((y (gen-var 'tmp)))
1903 ; fat finger binding and references to temp variable y
1904 (build-application no-source
1905 (build-lambda no-source (list y)
1906 (let ((y (build-lexical-reference 'value no-source y)))
1907 (build-conditional no-source
1908 (syntax-case fender ()
1910 (_ (build-conditional no-source
1912 (build-dispatch-call pvars fender y r mod)
1913 (build-data no-source #f))))
1914 (build-dispatch-call pvars exp y r mod)
1915 (gen-syntax-case x keys clauses r mod))))
1916 (list (if (eq? p 'any)
1917 (build-application no-source
1918 (build-primref no-source 'list)
1920 (build-application no-source
1921 (build-primref no-source '$sc-dispatch)
1922 (list x (build-data no-source p)))))))))))))
1924 (define gen-syntax-case
1925 (lambda (x keys clauses r mod)
1927 (build-application no-source
1928 (build-primref no-source 'syntax-violation)
1929 (list #f "source expression failed to match any pattern" x))
1930 (syntax-case (car clauses) ()
1932 (if (and (id? (syntax pat))
1933 (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
1934 (cons (syntax (... ...)) keys)))
1935 (let ((labels (list (gen-label)))
1936 (var (gen-var (syntax pat))))
1937 (build-application no-source
1938 (build-lambda no-source (list var)
1941 (list (make-binding 'syntax `(,var . 0)))
1943 (make-binding-wrap (syntax (pat))
1947 (gen-clause x keys (cdr clauses) r
1948 (syntax pat) #t (syntax exp) mod)))
1950 (gen-clause x keys (cdr clauses) r
1951 (syntax pat) (syntax fender) (syntax exp) mod))
1952 (_ (syntax-violation 'syntax-case "invalid clause"
1955 (lambda (e r w s mod)
1956 (let ((e (source-wrap e w s mod)))
1958 ((_ val (key ...) m ...)
1959 (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
1961 (let ((x (gen-var 'tmp)))
1962 ; fat finger binding and references to temp variable x
1963 (build-application s
1964 (build-lambda no-source (list x)
1965 (gen-syntax-case (build-lexical-reference 'value no-source x)
1966 (syntax (key ...)) (syntax (m ...))
1969 (list (chi (syntax val) r empty-wrap mod))))
1970 (syntax-violation 'syntax-case "invalid literals list" e))))))))
1972 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
1973 ;;; evaluating) and esew (which stands for "eval syntax expanders
1974 ;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
1975 ;;; if we are compiling a file, and esew is set to
1976 ;;; (eval-syntactic-expanders-when), which defaults to the list
1977 ;;; '(compile load eval). This means that, by default, top-level
1978 ;;; syntactic definitions are evaluated immediately after they are
1979 ;;; expanded, and the expanded definitions are also residualized into
1980 ;;; the object file if we are compiling a file.
1982 (let ((m 'e) (esew '(eval)))
1984 (if (and (pair? x) (equal? (car x) noexpand))
1986 (chi-top x null-env top-wrap m esew
1987 (cons 'hygiene (module-name (current-module))))))))
1990 (let ((m 'e) (esew '(eval)))
1992 (if (and (pair? x) (equal? (car x) noexpand))
1997 (if (null? rest) m (car rest))
1998 (if (or (null? rest) (null? (cdr rest)))
2001 (cons 'hygiene (module-name (current-module))))))))
2009 (make-syntax-object datum (syntax-object-wrap id) #f)))
2012 ; accepts any object, since syntax objects may consist partially
2013 ; or entirely of unwrapped, nonsymbolic data
2015 (strip x empty-wrap)))
2017 (set! generate-temporaries
2019 (arg-check list? ls 'generate-temporaries)
2020 (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
2022 (set! free-identifier=?
2024 (arg-check nonsymbol-id? x 'free-identifier=?)
2025 (arg-check nonsymbol-id? y 'free-identifier=?)
2028 (set! bound-identifier=?
2030 (arg-check nonsymbol-id? x 'bound-identifier=?)
2031 (arg-check nonsymbol-id? y 'bound-identifier=?)
2034 (set! syntax-violation
2035 (lambda (who message form . subform)
2036 (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2037 who 'syntax-violation)
2038 (arg-check string? message 'syntax-violation)
2039 (scm-error 'syntax-error 'sc-expand
2043 (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
2044 (let ((tail (cons message
2045 (map (lambda (x) (strip x empty-wrap))
2046 (append subform (list form))))))
2047 (if who (cons who tail) tail))
2050 (set! install-global-transformer
2052 (arg-check symbol? sym 'define-syntax)
2053 (arg-check procedure? v 'define-syntax)
2054 (global-extend 'macro sym v)))
2056 ;;; $sc-dispatch expects an expression and a pattern. If the expression
2057 ;;; matches the pattern a list of the matching expressions for each
2058 ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2059 ;;; not work on r4rs implementations that violate the ieee requirement
2060 ;;; that #f and () be distinct.)
2062 ;;; The expression is matched with the pattern as follows:
2064 ;;; pattern: matches:
2067 ;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2069 ;;; #(free-id <key>) <key> with free-identifier=?
2070 ;;; #(each <pattern>) (<pattern>*)
2071 ;;; #(vector <pattern>) (list->vector <pattern>)
2072 ;;; #(atom <object>) <object> with "equal?"
2074 ;;; Vector cops out to pair under assumption that vectors are rare. If
2075 ;;; not, should convert to:
2076 ;;; #(vector <pattern>*) #(<pattern>*)
2084 (match-each (annotation-expression e) p w mod))
2086 (let ((first (match (car e) p w '() mod)))
2088 (let ((rest (match-each (cdr e) p w mod)))
2089 (and rest (cons first rest))))))
2092 (match-each (syntax-object-expression e)
2094 (join-wraps w (syntax-object-wrap e))
2095 (syntax-object-module e)))
2098 (define match-each-any
2102 (match-each-any (annotation-expression e) w mod))
2104 (let ((l (match-each-any (cdr e) w mod)))
2105 (and l (cons (wrap (car e) w mod) l))))
2108 (match-each-any (syntax-object-expression e)
2109 (join-wraps w (syntax-object-wrap e))
2117 ((eq? p 'any) (cons '() r))
2118 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2119 ((eq? p 'each-any) (cons '() r))
2121 (case (vector-ref p 0)
2122 ((each) (match-empty (vector-ref p 1) r))
2124 ((vector) (match-empty (vector-ref p 1) r)))))))
2127 (lambda (e p w r mod)
2129 ((null? p) (and (null? e) r))
2131 (and (pair? e) (match (car e) (car p) w
2132 (match (cdr e) (cdr p) w r mod)
2135 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2137 (case (vector-ref p 0)
2140 (match-empty (vector-ref p 1) r)
2141 (let ((l (match-each e (vector-ref p 1) w mod)))
2143 (let collect ((l l))
2146 (cons (map car l) (collect (map cdr l)))))))))
2147 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2148 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2151 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2154 (lambda (e p w r mod)
2157 ((eq? p 'any) (cons (wrap e w mod) r))
2160 (unannotate (syntax-object-expression e))
2162 (join-wraps w (syntax-object-wrap e))
2164 (syntax-object-module e)))
2165 (else (match* (unannotate e) p w r mod)))))
2170 ((eq? p 'any) (list e))
2172 (match* (unannotate (syntax-object-expression e))
2173 p (syntax-object-wrap e) '() (syntax-object-module e)))
2174 (else (match* (unannotate e) p empty-wrap '() #f)))))
2179 (define-syntax with-syntax
2183 (syntax (begin e1 e2 ...)))
2184 ((_ ((out in)) e1 e2 ...)
2185 (syntax (syntax-case in () (out (begin e1 e2 ...)))))
2186 ((_ ((out in) ...) e1 e2 ...)
2187 (syntax (syntax-case (list in ...) ()
2188 ((out ...) (begin e1 e2 ...))))))))
2190 (define-syntax syntax-rules
2193 ((_ (k ...) ((keyword . pattern) template) ...)
2195 (syntax-case x (k ...)
2196 ((dummy . pattern) (syntax template))
2202 ((let* ((x v) ...) e1 e2 ...)
2203 (andmap identifier? (syntax (x ...)))
2204 (let f ((bindings (syntax ((x v) ...))))
2205 (if (null? bindings)
2206 (syntax (let () e1 e2 ...))
2207 (with-syntax ((body (f (cdr bindings)))
2208 (binding (car bindings)))
2209 (syntax (let (binding) body)))))))))
2213 (syntax-case orig-x ()
2214 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2215 (with-syntax (((step ...)
2220 (_ (syntax-violation
2221 'do "bad step expression"
2224 (syntax (step ...)))))
2225 (syntax-case (syntax (e1 ...)) ()
2226 (() (syntax (let doloop ((var init) ...)
2228 (begin c ... (doloop step ...))))))
2230 (syntax (let doloop ((var init) ...)
2233 (begin c ... (doloop step ...))))))))))))
2235 (define-syntax quasiquote
2239 (with-syntax ((x x) (y y))
2240 (syntax-case (syntax y) (quote list)
2242 (syntax-case (syntax x) (quote)
2243 ((quote dx) (syntax (quote (dx . dy))))
2244 (_ (if (null? (syntax dy))
2246 (syntax (cons x y))))))
2247 ((list . stuff) (syntax (list x . stuff)))
2248 (else (syntax (cons x y)))))))
2251 (with-syntax ((x x) (y y))
2252 (syntax-case (syntax y) (quote)
2253 ((quote ()) (syntax x))
2254 (_ (syntax (append x y)))))))
2257 (with-syntax ((x x))
2258 (syntax-case (syntax x) (quote list)
2259 ((quote (x ...)) (syntax (quote #(x ...))))
2260 ((list x ...) (syntax (vector x ...)))
2261 (_ (syntax (list->vector x)))))))
2264 (syntax-case p (unquote unquote-splicing quasiquote)
2268 (quasicons (syntax (quote unquote))
2269 (quasi (syntax (p)) (- lev 1)))))
2270 (((unquote-splicing p) . q)
2272 (quasiappend (syntax p) (quasi (syntax q) lev))
2273 (quasicons (quasicons (syntax (quote unquote-splicing))
2274 (quasi (syntax (p)) (- lev 1)))
2275 (quasi (syntax q) lev))))
2277 (quasicons (syntax (quote quasiquote))
2278 (quasi (syntax (p)) (+ lev 1))))
2280 (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
2281 (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
2282 (p (syntax (quote p)))))))
2285 ((_ e) (quasi (syntax e) 0))))))
2287 (define-syntax include
2291 (let ((p (open-input-file fn)))
2292 (let f ((x (read p)))
2294 (begin (close-input-port p) '())
2295 (cons (datum->syntax k x)
2299 (let ((fn (syntax->datum (syntax filename))))
2300 (with-syntax (((exp ...) (read-file fn (syntax k))))
2301 (syntax (begin exp ...))))))))
2303 (define-syntax unquote
2308 "expression ,~s not valid outside of quasiquote"
2309 (syntax->datum (syntax e)))))))
2311 (define-syntax unquote-splicing
2315 (error 'unquote-splicing
2316 "expression ,@~s not valid outside of quasiquote"
2317 (syntax->datum (syntax e)))))))
2324 ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
2326 (syntax-case clause (else)
2327 ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
2328 (((k ...) e1 e2 ...)
2329 (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
2330 (_ (syntax-violation 'case "bad clause" x clause)))
2331 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2332 (syntax-case clause (else)
2333 (((k ...) e1 e2 ...)
2334 (syntax (if (memv t '(k ...))
2337 (_ (syntax-violation 'case "bad clause" x
2339 (syntax (let ((t e)) body)))))))
2341 (define-syntax identifier-syntax
2349 (identifier? (syntax id))
2352 (syntax (e x (... ...)))))))))))