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 ;;; ($sc-dispatch e p)
85 ;;; used by expanded code to handle syntax-case matching
87 ;;; The following nonstandard procedures must be provided by the
88 ;;; implementation for this code to run.
91 ;;; returns the implementation's cannonical "unspecified value". This
92 ;;; usually works: (define void (lambda () (if #f #f))).
94 ;;; The following nonstandard procedures must also be provided by the
95 ;;; implementation for this code to run using the standard portable
96 ;;; hooks and output constructors. They are not used by expanded code,
97 ;;; and so need be present only at expansion time.
100 ;;; where x is always in the form ("noexpand" expr).
101 ;;; returns the value of expr. the "noexpand" flag is used to tell the
102 ;;; evaluator/expander that no expansion is necessary, since expr has
103 ;;; already been fully expanded to core forms.
105 ;;; eval will not be invoked during the loading of psyntax.pp. After
106 ;;; psyntax.pp has been loaded, the expansion of any macro definition,
107 ;;; whether local or global, will result in a call to eval. If, however,
108 ;;; sc-expand has already been registered as the expander to be used
109 ;;; by eval, and eval accepts one argument, nothing special must be done
110 ;;; to support the "noexpand" flag, since it is handled by sc-expand.
112 ;;; (error who format-string why what)
113 ;;; where who is either a symbol or #f, format-string is always "~a ~s",
114 ;;; why is always a string, and what may be any object. error should
115 ;;; signal an error with a message something like
117 ;;; "error in <who>: <why> <what>"
120 ;;; returns a unique symbol each time it's called
122 ;;; (putprop symbol key value)
123 ;;; (getprop symbol key)
124 ;;; key is always the symbol *sc-expander*; value may be any object.
125 ;;; putprop should associate the given value with the given symbol in
126 ;;; some way that it can be retrieved later with getprop.
128 ;;; When porting to a new Scheme implementation, you should define the
129 ;;; procedures listed above, load the expanded version of psyntax.ss
130 ;;; (psyntax.pp, which should be available whereever you found
131 ;;; psyntax.ss), and register sc-expand as the current expander (how
132 ;;; you do this depends upon your implementation of Scheme). You may
133 ;;; change the hooks and constructors defined toward the beginning of
134 ;;; the code below, but to avoid bootstrapping problems, do so only
135 ;;; after you have a working version of the expander.
137 ;;; Chez Scheme allows the syntactic form (syntax <template>) to be
138 ;;; abbreviated to #'<template>, just as (quote <datum>) may be
139 ;;; abbreviated to '<datum>. The #' syntax makes programs written
140 ;;; using syntax-case shorter and more readable and draws out the
141 ;;; intuitive connection between syntax and quote.
143 ;;; If you find that this code loads or runs slowly, consider
144 ;;; switching to faster hardware or a faster implementation of
145 ;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
146 ;;; compiling (with full optimization), and loading this file takes
147 ;;; between one and two seconds.
149 ;;; In the expander implementation, we sometimes use syntactic abstractions
150 ;;; when procedural abstractions would suffice. For example, we define
151 ;;; top-wrap and top-marked? as
152 ;;; (define-syntax top-wrap (identifier-syntax '((top))))
153 ;;; (define-syntax top-marked?
155 ;;; ((_ w) (memq 'top (wrap-marks w)))))
157 ;;; (define top-wrap '((top)))
158 ;;; (define top-marked?
159 ;;; (lambda (w) (memq 'top (wrap-marks w))))
160 ;;; On ther other hand, we don't do this consistently; we define make-wrap,
161 ;;; wrap-marks, and wrap-subst simply as
162 ;;; (define make-wrap cons)
163 ;;; (define wrap-marks car)
164 ;;; (define wrap-subst cdr)
165 ;;; In Chez Scheme, the syntactic and procedural forms of these
166 ;;; abstractions are equivalent, since the optimizer consistently
167 ;;; integrates constants and small procedures. Some Scheme
168 ;;; implementations, however, may benefit from more consistent use
169 ;;; of one form or the other.
172 ;;; implementation information:
174 ;;; "begin" is treated as a splicing construct at top level and at
175 ;;; the beginning of bodies. Any sequence of expressions that would
176 ;;; be allowed where the "begin" occurs is allowed.
178 ;;; "let-syntax" and "letrec-syntax" are also treated as splicing
179 ;;; constructs, in violation of the R4RS appendix and probably the R5RS
180 ;;; when it comes out. A consequence, let-syntax and letrec-syntax do
181 ;;; not create local contours, as do let and letrec. Although the
182 ;;; functionality is greater as it is presently implemented, we will
183 ;;; probably change it to conform to the R4RS/expected R5RS.
185 ;;; Objects with no standard print syntax, including objects containing
186 ;;; cycles and syntax object, are allowed in quoted data as long as they
187 ;;; are contained within a syntax form or produced by datum->syntax.
188 ;;; Such objects are never copied.
190 ;;; All identifiers that don't have macro definitions and are not bound
191 ;;; lexically are assumed to be global variables
193 ;;; Top-level definitions of macro-introduced identifiers are allowed.
194 ;;; This may not be appropriate for implementations in which the
195 ;;; model is that bindings are created by definitions, as opposed to
196 ;;; one in which initial values are assigned by definitions.
198 ;;; Top-level variable definitions of syntax keywords is not permitted.
199 ;;; Any solution allowing this would be kludgey and would yield
200 ;;; surprising results in some cases. We can provide an undefine-syntax
201 ;;; form. The questions is, should define be an implicit undefine-syntax?
202 ;;; We've decided no for now.
204 ;;; Identifiers and syntax objects are implemented as vectors for
205 ;;; portability. As a result, it is possible to "forge" syntax
208 ;;; The implementation of generate-temporaries assumes that it is possible
209 ;;; to generate globally unique symbols (gensyms).
211 ;;; The input to sc-expand may contain "annotations" describing, e.g., the
212 ;;; source file and character position from where each object was read if
213 ;;; it was read from a file. These annotations are handled properly by
214 ;;; sc-expand only if the annotation? hook (see hooks below) is implemented
215 ;;; properly and the operators make-annotation, annotation-expression,
216 ;;; annotation-source, annotation-stripped, and set-annotation-stripped!
217 ;;; are supplied. If annotations are supplied, the proper annotation
218 ;;; source is passed to the various output constructors, allowing
219 ;;; implementations to accurately correlate source and expanded code.
220 ;;; Contact one of the authors for details if you wish to make use of
227 ;;; When changing syntax-object representations, it is necessary to support
228 ;;; both old and new syntax-object representations in id-var-name. It
229 ;;; should be sufficient to recognize old representations and treat
230 ;;; them as not lexically bound.
235 (set-current-module (resolve-module '(guile))))
238 ;;; Private version of and-map that handles multiple lists.
240 (lambda (f first . rest)
243 (let andmap ((first first))
244 (let ((x (car first)) (first (cdr first)))
247 (and (f x) (andmap first)))))
248 (let andmap ((first first) (rest rest))
249 (let ((x (car first))
252 (rest (map cdr rest)))
254 (apply f (cons x xr))
255 (and (apply f (cons x xr)) (andmap first rest)))))))))
257 (define-syntax define-structure
259 (define construct-name
260 (lambda (template-identifier . args)
268 (symbol->string (syntax->datum x))))
272 ;; But here we use and-map, because andmap isn't yet in scope for
274 (and-map identifier? (syntax (name id1 ...)))
276 ((constructor (construct-name (syntax name) "make-" (syntax name)))
277 (predicate (construct-name (syntax name) (syntax name) "?"))
279 (map (lambda (x) (construct-name x (syntax name) "-" x))
283 (construct-name x "set-" (syntax name) "-" x "!"))
286 (+ (length (syntax (id1 ...))) 1))
288 (let f ((i 1) (ids (syntax (id1 ...))))
291 (cons i (f (+ i 1) (cdr ids)))))))
295 (vector 'name id1 ... )))
299 (= (vector-length x) structure-length)
300 (eq? (vector-ref x 0) 'name))))
303 (vector-ref x index)))
307 (vector-set! x index update)))
311 (define noexpand "noexpand")
313 ;;; hooks to nonportable run-time helpers
320 (define top-level-eval-hook
322 (primitive-eval `(,noexpand ,x))))
324 (define local-eval-hook
326 (primitive-eval `(,noexpand ,x))))
329 (lambda (who why what)
330 (error who "~a ~s" why what)))
332 (define-syntax gensym-hook
336 (define put-global-definition-hook
337 (lambda (symbol type val)
338 (let ((existing (let ((v (module-variable (current-module) symbol)))
339 (and v (variable-bound? v)
340 (let ((val (variable-ref v)))
342 (not (syncase-macro-type val))
344 (module-define! (current-module)
347 (make-extended-syncase-macro existing type val)
348 (make-syncase-macro type val))))))
350 (define get-global-definition-hook
351 (lambda (symbol module)
352 (if (and (not module) (current-module))
353 (warn "module system is booted, we should have a module" symbol))
354 (let ((v (module-variable (if module
355 (resolve-module (cdr module))
358 (and v (variable-bound? v)
359 (let ((val (variable-ref v)))
360 (and (macro? val) (syncase-macro-type val)
361 (cons (syncase-macro-type val)
362 (syncase-macro-binding val))))))))
367 ;;; output constructors
368 (define (build-annotated src exp)
369 (if (and src (not (annotation? exp)))
370 (make-annotation exp src #t)
373 (define-syntax build-application
375 ((_ source fun-exp arg-exps)
376 (build-annotated source `(,fun-exp . ,arg-exps)))))
378 (define-syntax build-conditional
380 ((_ source test-exp then-exp else-exp)
381 (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
383 (define-syntax build-lexical-reference
386 (build-annotated source var))))
388 (define-syntax build-lexical-assignment
391 (build-annotated source `(set! ,var ,exp)))))
393 (define-syntax build-global-reference
399 (make-module-ref (cdr mod) var (car mod))
400 (make-module-ref mod var 'bare))))))
402 (define-syntax build-global-assignment
404 ((_ source var exp mod)
405 (build-annotated source
407 (make-module-ref (cdr mod) var (car mod))
408 (make-module-ref mod var 'bare))
411 (define-syntax build-global-definition
413 ((_ source var exp mod)
414 (build-annotated source `(define ,var ,exp)))))
416 (define-syntax build-lambda
418 ((_ src vars docstring exp)
419 (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
422 (build-annotated src `(lambda ,vars ,exp)))))
424 ;; FIXME: wingo: add modules here somehow?
425 (define-syntax build-primref
427 ((_ src name) (build-annotated src name))
428 ((_ src level name) (build-annotated src name))))
430 (define (build-data src exp)
431 (if (and (self-evaluating? exp)
433 (build-annotated src exp)
434 (build-annotated src (list 'quote exp))))
436 (define build-sequence
438 (if (null? (cdr exps))
439 (build-annotated src (car exps))
440 (build-annotated src `(begin ,@exps)))))
443 (lambda (src vars val-exps body-exp)
445 (build-annotated src body-exp)
446 (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
448 (define build-named-let
449 (lambda (src vars val-exps body-exp)
451 (build-annotated src body-exp)
454 ,(map list (cdr vars) val-exps) ,body-exp)))))
457 (lambda (src vars val-exps body-exp)
459 (build-annotated src body-exp)
461 `(letrec ,(map list vars val-exps) ,body-exp)))))
463 ;; FIXME: wingo: use make-lexical
464 (define-syntax build-lexical-var
466 ((_ src id) (build-annotated src (gensym (symbol->string id))))))
468 (define-structure (syntax-object expression wrap module))
470 (define-syntax unannotate
475 (annotation-expression e)
478 (define-syntax no-source (identifier-syntax #f))
480 (define source-annotation
483 ((annotation? x) (annotation-source x))
484 ((syntax-object? x) (source-annotation (syntax-object-expression x)))
487 (define-syntax arg-check
491 (if (not (pred? x)) (error-hook who "invalid argument" x))))))
493 ;;; compile-time environments
495 ;;; wrap and environment comprise two level mapping.
496 ;;; wrap : id --> label
497 ;;; env : label --> <element>
499 ;;; environments are represented in two parts: a lexical part and a global
500 ;;; part. The lexical part is a simple list of associations from labels
501 ;;; to bindings. The global part is implemented by
502 ;;; {put,get}-global-definition-hook and associates symbols with
505 ;;; global (assumed global variable) and displaced-lexical (see below)
506 ;;; do not show up in any environment; instead, they are fabricated by
507 ;;; lookup when it finds no other bindings.
509 ;;; <environment> ::= ((<label> . <binding>)*)
511 ;;; identifier bindings include a type and a value
513 ;;; <binding> ::= (macro . <procedure>) macros
514 ;;; (core . <procedure>) core forms
515 ;;; (external-macro . <procedure>) external-macro
516 ;;; (module-ref . <procedure>) @ or @@
519 ;;; (define-syntax) define-syntax
520 ;;; (local-syntax . rec?) let-syntax/letrec-syntax
521 ;;; (eval-when) eval-when
522 ;;; (syntax . (<var> . <level>)) pattern variables
523 ;;; (global) assumed global variable
524 ;;; (lexical . <var>) lexical variables
525 ;;; (displaced-lexical) displaced lexicals
526 ;;; <level> ::= <nonnegative integer>
527 ;;; <var> ::= variable returned by build-lexical-var
529 ;;; a macro is a user-defined syntactic-form. a core is a system-defined
530 ;;; syntactic form. begin, define, define-syntax, and eval-when are
531 ;;; treated specially since they are sensitive to whether the form is
532 ;;; at top-level and (except for eval-when) can denote valid internal
535 ;;; a pattern variable is a variable introduced by syntax-case and can
536 ;;; be referenced only within a syntax form.
538 ;;; any identifier for which no top-level syntax definition or local
539 ;;; binding of any kind has been seen is assumed to be a global
542 ;;; a lexical variable is a lambda- or letrec-bound variable.
544 ;;; a displaced-lexical identifier is a lexical identifier removed from
545 ;;; it's scope by the return of a syntax object containing the identifier.
546 ;;; a displaced lexical can also appear when a letrec-syntax-bound
547 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
548 ;;; a displaced lexical should never occur with properly written macros.
550 (define-syntax make-binding
551 (syntax-rules (quote)
552 ((_ type value) (cons type value))
554 ((_ type) (cons type '()))))
555 (define binding-type car)
556 (define binding-value cdr)
558 (define-syntax null-env (identifier-syntax '()))
561 (lambda (labels bindings r)
564 (extend-env (cdr labels) (cdr bindings)
565 (cons (cons (car labels) (car bindings)) r)))))
567 (define extend-var-env
568 ; variant of extend-env that forms "lexical" binding
569 (lambda (labels vars r)
572 (extend-var-env (cdr labels) (cdr vars)
573 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
575 ;;; we use a "macros only" environment in expansion of local macro
576 ;;; definitions so that their definitions can use local macros without
577 ;;; attempting to use other lexical identifiers.
578 (define macros-only-env
583 (if (eq? (cadr a) 'macro)
584 (cons a (macros-only-env (cdr r)))
585 (macros-only-env (cdr r)))))))
588 ; x may be a label or a symbol
589 ; although symbols are usually global, we check the environment first
590 ; anyway because a temporary binding may have been established by
596 (or (get-global-definition-hook x mod) (make-binding 'global)))
597 (else (make-binding 'displaced-lexical)))))
599 (define global-extend
600 (lambda (type sym val)
601 (put-global-definition-hook sym type val)))
604 ;;; Conceptually, identifiers are always syntax objects. Internally,
605 ;;; however, the wrap is sometimes maintained separately (a source of
606 ;;; efficiency and confusion), so that symbols are also considered
607 ;;; identifiers by id?. Externally, they are always wrapped.
609 (define nonsymbol-id?
611 (and (syntax-object? x)
612 (symbol? (unannotate (syntax-object-expression x))))))
618 ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
619 ((annotation? x) (symbol? (annotation-expression x)))
622 (define-syntax id-sym-name
626 (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
628 (define id-sym-name&marks
630 (if (syntax-object? x)
632 (unannotate (syntax-object-expression x))
633 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
634 (values (unannotate x) (wrap-marks w)))))
636 ;;; syntax object wraps
638 ;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
639 ;;; <subst> ::= <shift> | <subs>
640 ;;; <subs> ::= #(<old name> <label> (<mark> ...))
641 ;;; <shift> ::= positive fixnum
643 (define make-wrap cons)
644 (define wrap-marks car)
645 (define wrap-subst cdr)
647 (define-syntax subst-rename? (identifier-syntax vector?))
648 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
649 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
650 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
651 (define-syntax make-rename
653 ((_ old new marks) (vector old new marks))))
655 ;;; labels must be comparable with "eq?" and distinct from symbols.
657 (lambda () (string #\i)))
663 (cons (gen-label) (gen-labels (cdr ls))))))
665 (define-structure (ribcage symnames marks labels))
667 (define-syntax empty-wrap (identifier-syntax '(())))
669 (define-syntax top-wrap (identifier-syntax '((top))))
671 (define-syntax top-marked?
673 ((_ w) (memq 'top (wrap-marks w)))))
675 ;;; Marks must be comparable with "eq?" and distinct from pairs and
676 ;;; the symbol top. We do not use integers so that marks will remain
677 ;;; unique even across file compiles.
679 (define-syntax the-anti-mark (identifier-syntax #f))
683 (make-wrap (cons the-anti-mark (wrap-marks w))
684 (cons 'shift (wrap-subst w)))))
686 (define-syntax new-mark
690 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
691 ;;; internal definitions, in which the ribcages are built incrementally
692 (define-syntax make-empty-ribcage
694 ((_) (make-ribcage '() '() '()))))
696 (define extend-ribcage!
697 ; must receive ids with complete wraps
698 (lambda (ribcage id label)
699 (set-ribcage-symnames! ribcage
700 (cons (unannotate (syntax-object-expression id))
701 (ribcage-symnames ribcage)))
702 (set-ribcage-marks! ribcage
703 (cons (wrap-marks (syntax-object-wrap id))
704 (ribcage-marks ribcage)))
705 (set-ribcage-labels! ribcage
706 (cons label (ribcage-labels ribcage)))))
708 ;;; make-binding-wrap creates vector-based ribcages
709 (define make-binding-wrap
710 (lambda (ids labels w)
716 (let ((labelvec (list->vector labels)))
717 (let ((n (vector-length labelvec)))
718 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
719 (let f ((ids ids) (i 0))
720 (if (not (null? ids))
722 (lambda () (id-sym-name&marks (car ids) w))
723 (lambda (symname marks)
724 (vector-set! symnamevec i symname)
725 (vector-set! marksvec i marks)
726 (f (cdr ids) (fx+ i 1))))))
727 (make-ribcage symnamevec marksvec labelvec))))
738 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
744 (smart-append s1 (wrap-subst w2))))
746 (smart-append m1 (wrap-marks w2))
747 (smart-append s1 (wrap-subst w2)))))))
751 (smart-append m1 m2)))
758 (eq? (car x) (car y))
759 (same-marks? (cdr x) (cdr y))))))
765 ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
767 (lambda (sym subst marks)
770 (let ((fst (car subst)))
772 (search sym (cdr subst) (cdr marks))
773 (let ((symnames (ribcage-symnames fst)))
774 (if (vector? symnames)
775 (search-vector-rib sym subst marks symnames fst)
776 (search-list-rib sym subst marks symnames fst))))))))
777 (define search-list-rib
778 (lambda (sym subst marks symnames ribcage)
779 (let f ((symnames symnames) (i 0))
781 ((null? symnames) (search sym (cdr subst) marks))
782 ((and (eq? (car symnames) sym)
783 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
784 (values (list-ref (ribcage-labels ribcage) i) marks))
785 (else (f (cdr symnames) (fx+ i 1)))))))
786 (define search-vector-rib
787 (lambda (sym subst marks symnames ribcage)
788 (let ((n (vector-length symnames)))
791 ((fx= i n) (search sym (cdr subst) marks))
792 ((and (eq? (vector-ref symnames i) sym)
793 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
794 (values (vector-ref (ribcage-labels ribcage) i) marks))
795 (else (f (fx+ i 1))))))))
798 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
800 (let ((id (unannotate (syntax-object-expression id)))
801 (w1 (syntax-object-wrap id)))
802 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
803 (call-with-values (lambda () (search id (wrap-subst w) marks))
804 (lambda (new-id marks)
806 (first (search id (wrap-subst w1) marks))
809 (let ((id (unannotate id)))
810 (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
811 (else (error-hook 'id-var-name "invalid id" id)))))
813 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
814 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
818 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
819 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
821 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
822 ;;; long as the missing portion of the wrap is common to both of the ids
823 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
827 (if (and (syntax-object? i) (syntax-object? j))
828 (and (eq? (unannotate (syntax-object-expression i))
829 (unannotate (syntax-object-expression j)))
830 (same-marks? (wrap-marks (syntax-object-wrap i))
831 (wrap-marks (syntax-object-wrap j))))
832 (eq? (unannotate i) (unannotate j)))))
834 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
835 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
836 ;;; as long as the missing portion of the wrap is common to all of the
839 (define valid-bound-ids?
841 (and (let all-ids? ((ids ids))
844 (all-ids? (cdr ids)))))
845 (distinct-bound-ids? ids))))
847 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
848 ;;; no duplicates. It is quadratic on the length of the id list; long
849 ;;; lists could be sorted to make it more efficient. distinct-bound-ids?
850 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
851 ;;; missing portion of the wrap is common to all of the ids.
853 (define distinct-bound-ids?
855 (let distinct? ((ids ids))
857 (and (not (bound-id-member? (car ids) (cdr ids)))
858 (distinct? (cdr ids)))))))
860 (define bound-id-member?
862 (and (not (null? list))
863 (or (bound-id=? x (car list))
864 (bound-id-member? x (cdr list))))))
866 ;;; wrapping expressions and identifiers
871 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
874 (syntax-object-expression x)
875 (join-wraps w (syntax-object-wrap x))
876 (syntax-object-module x)))
878 (else (make-syntax-object x w defmod)))))
881 (lambda (x w s defmod)
882 (wrap (if s (make-annotation x s #f) x) w defmod)))
887 (lambda (body r w s mod)
889 (let dobody ((body body) (r r) (w w) (mod mod))
892 (let ((first (chi (car body) r w mod)))
893 (cons first (dobody (cdr body) r w mod))))))))
895 (define chi-top-sequence
896 (lambda (body r w s m esew mod)
898 (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
901 (let ((first (chi-top (car body) r w m esew mod)))
902 (cons first (dobody (cdr body) r w m esew mod))))))))
905 (define chi-install-global
907 (build-application no-source
908 (build-primref no-source 'define)
911 ;; FIXME: seems nasty to call current-module here
912 (if (let ((v (module-variable (current-module) name)))
913 ;; FIXME use primitive-macro?
914 (and v (variable-bound? v) (macro? (variable-ref v))
915 (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
916 (build-application no-source
917 (build-primref no-source 'make-extended-syncase-macro)
918 (list (build-application no-source
919 (build-primref no-source 'module-ref)
920 (list (build-application no-source 'current-module '())
921 (build-data no-source name)))
922 (build-data no-source 'macro)
924 (build-application no-source
925 (build-primref no-source 'make-syncase-macro)
926 (list (build-data no-source 'macro) e)))))))
928 (define chi-when-list
929 (lambda (e when-list w)
930 ; when-list is syntax'd version of list of situations
931 (let f ((when-list when-list) (situations '()))
932 (if (null? when-list)
935 (cons (let ((x (car when-list)))
937 ((free-id=? x (syntax compile)) 'compile)
938 ((free-id=? x (syntax load)) 'load)
939 ((free-id=? x (syntax eval)) 'eval)
940 (else (syntax-violation 'eval-when
945 ;;; syntax-type returns six values: type, value, e, w, s, and mod. The
946 ;;; first two are described in the table below.
948 ;;; type value explanation
949 ;;; -------------------------------------------------------------------
950 ;;; core procedure core form (including singleton)
951 ;;; external-macro procedure external macro
952 ;;; module-ref procedure @ or @@ form
953 ;;; lexical name lexical variable reference
954 ;;; global name global variable reference
955 ;;; begin none begin keyword
956 ;;; define none define keyword
957 ;;; define-syntax none define-syntax keyword
958 ;;; local-syntax rec? letrec-syntax/let-syntax keyword
959 ;;; eval-when none eval-when keyword
960 ;;; syntax level pattern variable
961 ;;; displaced-lexical none displaced lexical identifier
962 ;;; lexical-call name call to lexical variable
963 ;;; global-call name call to global variable
964 ;;; call none any other call
965 ;;; begin-form none begin expression
966 ;;; define-form id variable definition
967 ;;; define-syntax-form id syntax definition
968 ;;; local-syntax-form rec? syntax definition
969 ;;; eval-when-form none eval-when form
970 ;;; constant none self-evaluating datum
971 ;;; other none anything else
973 ;;; For define-form and define-syntax-form, e is the rhs expression.
974 ;;; For all others, e is the entire form. w is the wrap for e.
975 ;;; s is the source for the entire form. mod is the module for e.
977 ;;; syntax-type expands macros and unwraps as necessary to get to
978 ;;; one of the forms above. It also parses define and define-syntax
979 ;;; forms, although perhaps this should be done by the consumer.
982 (lambda (e r w s rib mod)
985 (let* ((n (id-var-name e w))
987 (type (binding-type b)))
989 ((lexical) (values type (binding-value b) e w s mod))
990 ((global) (values type n e w s mod))
992 (syntax-type (chi-macro (binding-value b) e r w rib mod)
993 r empty-wrap s rib mod))
994 (else (values type (binding-value b) e w s mod)))))
996 (let ((first (car e)))
998 (let* ((n (id-var-name first w))
999 (b (lookup n r (or (and (syntax-object? first)
1000 (syntax-object-module first))
1002 (type (binding-type b)))
1005 (values 'lexical-call (binding-value b) e w s mod))
1007 (values 'global-call n e w s mod))
1009 (syntax-type (chi-macro (binding-value b) e r w rib mod)
1010 r empty-wrap s rib mod))
1011 ((core external-macro module-ref)
1012 (values type (binding-value b) e w s mod))
1014 (values 'local-syntax-form (binding-value b) e w s mod))
1016 (values 'begin-form #f e w s mod))
1018 (values 'eval-when-form #f e w s mod))
1023 (values 'define-form (syntax name) (syntax val) w s mod))
1024 ((_ (name . args) e1 e2 ...)
1025 (and (id? (syntax name))
1026 (valid-bound-ids? (lambda-var-list (syntax args))))
1027 ; need lambda here...
1028 (values 'define-form (wrap (syntax name) w mod)
1029 (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
1033 (values 'define-form (wrap (syntax name) w mod)
1035 empty-wrap s mod))))
1040 (values 'define-syntax-form (syntax name)
1041 (syntax val) w s mod))))
1043 (values 'call #f e w s mod))))
1044 (values 'call #f e w s mod))))
1046 ;; s can't be valid source if we've unwrapped
1047 (syntax-type (syntax-object-expression e)
1049 (join-wraps w (syntax-object-wrap e))
1050 no-source rib (or (syntax-object-module e) mod)))
1052 (syntax-type (annotation-expression e) r w (annotation-source e) rib mod))
1053 ((self-evaluating? e) (values 'constant #f e w s mod))
1054 (else (values 'other #f e w s mod)))))
1057 (lambda (e r w m esew mod)
1058 (define-syntax eval-if-c&e
1062 (if (eq? m 'c&e) (top-level-eval-hook x mod))
1065 (lambda () (syntax-type e r w no-source #f mod))
1066 (lambda (type value e w s mod)
1072 (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
1073 ((local-syntax-form)
1074 (chi-local-syntax value e r w s mod
1075 (lambda (body r w s mod)
1076 (chi-top-sequence body r w s m esew mod))))
1079 ((_ (x ...) e1 e2 ...)
1080 (let ((when-list (chi-when-list e (syntax (x ...)) w))
1081 (body (syntax (e1 e2 ...))))
1084 (if (memq 'eval when-list)
1085 (chi-top-sequence body r w s 'e '(eval) mod)
1087 ((memq 'load when-list)
1088 (if (or (memq 'compile when-list)
1089 (and (eq? m 'c&e) (memq 'eval when-list)))
1090 (chi-top-sequence body r w s 'c&e '(compile load) mod)
1091 (if (memq m '(c c&e))
1092 (chi-top-sequence body r w s 'c '(load) mod)
1094 ((or (memq 'compile when-list)
1095 (and (eq? m 'c&e) (memq 'eval when-list)))
1096 (top-level-eval-hook
1097 (chi-top-sequence body r w s 'e '(eval) mod)
1100 (else (chi-void)))))))
1101 ((define-syntax-form)
1102 (let ((n (id-var-name value w)) (r (macros-only-env r)))
1105 (if (memq 'compile esew)
1106 (let ((e (chi-install-global n (chi e r w mod))))
1107 (top-level-eval-hook e mod)
1108 (if (memq 'load esew) e (chi-void)))
1109 (if (memq 'load esew)
1110 (chi-install-global n (chi e r w mod))
1113 (let ((e (chi-install-global n (chi e r w mod))))
1114 (top-level-eval-hook e mod)
1117 (if (memq 'eval esew)
1118 (top-level-eval-hook
1119 (chi-install-global n (chi e r w mod))
1123 (let* ((n (id-var-name value w))
1124 (type (binding-type (lookup n r mod))))
1126 ((global core macro module-ref)
1128 (build-global-definition s n (chi e r w mod) mod)
1130 ((displaced-lexical)
1131 (syntax-violation #f "identifier out of context"
1132 e (wrap value w mod)))
1134 (syntax-violation #f "cannot define keyword at top level"
1135 e (wrap value w mod))))))
1136 (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
1141 (lambda () (syntax-type e r w no-source #f mod))
1142 (lambda (type value e w s mod)
1143 (chi-expr type value e r w s mod)))))
1146 (lambda (type value e r w s mod)
1149 (build-lexical-reference 'value s value))
1150 ((core external-macro)
1151 ;; apply transformer
1152 (value e r w s mod))
1154 (call-with-values (lambda () (value e))
1155 ;; we could add a public? arg here
1156 (lambda (id mod) (build-global-reference s id mod))))
1159 (build-lexical-reference 'fun (source-annotation (car e)) value)
1163 (build-global-reference (source-annotation (car e)) value
1164 (if (syntax-object? (car e))
1165 (syntax-object-module (car e))
1168 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1169 ((global) (build-global-reference s value mod))
1170 ((call) (chi-application (chi (car e) r w mod) e r w s mod))
1173 ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
1174 ((local-syntax-form)
1175 (chi-local-syntax value e r w s mod chi-sequence))
1178 ((_ (x ...) e1 e2 ...)
1179 (let ((when-list (chi-when-list e (syntax (x ...)) w)))
1180 (if (memq 'eval when-list)
1181 (chi-sequence (syntax (e1 e2 ...)) r w s mod)
1183 ((define-form define-syntax-form)
1184 (syntax-violation #f "definition in expression context"
1185 e (wrap value w mod)))
1187 (syntax-violation #f "reference to pattern variable outside syntax form"
1188 (source-wrap e w s mod)))
1189 ((displaced-lexical)
1190 (syntax-violation #f "reference to identifier outside its scope"
1191 (source-wrap e w s mod)))
1192 (else (syntax-violation #f "unexpected syntax"
1193 (source-wrap e w s mod))))))
1195 (define chi-application
1196 (lambda (x e r w s mod)
1199 (build-application s x
1200 (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
1203 (lambda (p e r w rib mod)
1204 (define rebuild-macro-output
1207 (cons (rebuild-macro-output (car x) m)
1208 (rebuild-macro-output (cdr x) m)))
1210 (let ((w (syntax-object-wrap x)))
1211 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1212 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1213 ;; output is from original text
1215 (syntax-object-expression x)
1216 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1217 (syntax-object-module x))
1218 ;; output introduced by macro
1220 (syntax-object-expression x)
1221 (make-wrap (cons m ms)
1223 (cons rib (cons 'shift s))
1225 (let ((pmod (procedure-module p)))
1227 ;; hither the hygiene
1228 (cons 'hygiene (module-name pmod))
1229 ;; but it's possible for the proc to have
1230 ;; no mod, if it was made before modules
1232 '(hygiene guile))))))))
1234 (let* ((n (vector-length x)) (v (make-vector n)))
1235 (do ((i 0 (fx+ i 1)))
1238 (rebuild-macro-output (vector-ref x i) m)))))
1240 (syntax-violation #f "encountered raw symbol in macro output"
1241 (source-wrap e w s mod) x))
1243 (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
1246 ;; In processing the forms of the body, we create a new, empty wrap.
1247 ;; This wrap is augmented (destructively) each time we discover that
1248 ;; the next form is a definition. This is done:
1250 ;; (1) to allow the first nondefinition form to be a call to
1251 ;; one of the defined ids even if the id previously denoted a
1252 ;; definition keyword or keyword for a macro expanding into a
1254 ;; (2) to prevent subsequent definition forms (but unfortunately
1255 ;; not earlier ones) and the first nondefinition form from
1256 ;; confusing one of the bound identifiers for an auxiliary
1258 ;; (3) so that we do not need to restart the expansion of the
1259 ;; first nondefinition form, which is problematic anyway
1260 ;; since it might be the first element of a begin that we
1261 ;; have just spliced into the body (meaning if we restarted,
1262 ;; we'd really need to restart with the begin or the macro
1263 ;; call that expanded into the begin, and we'd have to give
1264 ;; up allowing (begin <defn>+ <expr>+), which is itself
1265 ;; problematic since we don't know if a begin contains only
1266 ;; definitions until we've expanded it).
1268 ;; Before processing the body, we also create a new environment
1269 ;; containing a placeholder for the bindings we will add later and
1270 ;; associate this environment with each form. In processing a
1271 ;; let-syntax or letrec-syntax, the associated environment may be
1272 ;; augmented with local keyword bindings, so the environment may
1273 ;; be different for different forms in the body. Once we have
1274 ;; gathered up all of the definitions, we evaluate the transformer
1275 ;; expressions and splice into r at the placeholder the new variable
1276 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1277 ;; forms local to a portion or all of the body to shadow the
1278 ;; definition bindings.
1280 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1283 ;; outer-form is fully wrapped w/source
1284 (lambda (body outer-form r w mod)
1285 (let* ((r (cons '("placeholder" . (placeholder)) r))
1286 (ribcage (make-empty-ribcage))
1287 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1288 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1289 (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
1291 (syntax-violation #f "no expressions in body" outer-form)
1292 (let ((e (cdar body)) (er (caar body)))
1294 (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
1295 (lambda (type value e w s mod)
1298 (let ((id (wrap value w mod)) (label (gen-label)))
1299 (let ((var (gen-var id)))
1300 (extend-ribcage! ribcage id label)
1302 (cons id ids) (cons label labels)
1303 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1304 (cons (make-binding 'lexical var) bindings)))))
1305 ((define-syntax-form)
1306 (let ((id (wrap value w mod)) (label (gen-label)))
1307 (extend-ribcage! ribcage id label)
1309 (cons id ids) (cons label labels)
1311 (cons (make-binding 'macro (cons er (wrap e w mod)))
1316 (parse (let f ((forms (syntax (e1 ...))))
1319 (cons (cons er (wrap (car forms) w mod))
1321 ids labels vars vals bindings))))
1322 ((local-syntax-form)
1323 (chi-local-syntax value e er w s mod
1324 (lambda (forms er w s mod)
1325 (parse (let f ((forms forms))
1328 (cons (cons er (wrap (car forms) w mod))
1330 ids labels vars vals bindings))))
1331 (else ; found a non-definition
1333 (build-sequence no-source
1335 (chi (cdr x) (car x) empty-wrap mod))
1336 (cons (cons er (source-wrap e w s mod))
1339 (if (not (valid-bound-ids? ids))
1341 #f "invalid or duplicate identifier in definition"
1343 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1344 (if (not (null? bs))
1345 (let* ((b (car bs)))
1346 (if (eq? (car b) 'macro)
1347 (let* ((er (cadr b))
1349 (if (eq? er er-cache)
1351 (macros-only-env er))))
1353 (eval-local-transformer
1354 (chi (cddr b) r-cache empty-wrap mod)
1356 (loop (cdr bs) er r-cache))
1357 (loop (cdr bs) er-cache r-cache)))))
1358 (set-cdr! r (extend-env labels bindings (cdr r)))
1359 (build-letrec no-source
1362 (chi (cdr x) (car x) empty-wrap mod))
1364 (build-sequence no-source
1366 (chi (cdr x) (car x) empty-wrap mod))
1367 (cons (cons er (source-wrap e w s mod))
1368 (cdr body)))))))))))))))))
1370 (define chi-lambda-clause
1371 (lambda (e docstring c r w mod k)
1373 ((args doc e1 e2 ...)
1374 (and (string? (syntax->datum (syntax doc))) (not docstring))
1375 (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
1376 (((id ...) e1 e2 ...)
1377 (let ((ids (syntax (id ...))))
1378 (if (not (valid-bound-ids? ids))
1379 (syntax-violation 'lambda "invalid parameter list" e)
1380 (let ((labels (gen-labels ids))
1381 (new-vars (map gen-var ids)))
1384 (chi-body (syntax (e1 e2 ...))
1386 (extend-var-env labels new-vars r)
1387 (make-binding-wrap ids labels w)
1390 (let ((old-ids (lambda-var-list (syntax ids))))
1391 (if (not (valid-bound-ids? old-ids))
1392 (syntax-violation 'lambda "invalid parameter list" e)
1393 (let ((labels (gen-labels old-ids))
1394 (new-vars (map gen-var old-ids)))
1395 (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
1398 (f (cdr ls1) (cons (car ls1) ls2))))
1400 (chi-body (syntax (e1 e2 ...))
1402 (extend-var-env labels new-vars r)
1403 (make-binding-wrap old-ids labels w)
1405 (_ (syntax-violation 'lambda "bad lambda" e)))))
1407 (define chi-local-syntax
1408 (lambda (rec? e r w s mod k)
1410 ((_ ((id val) ...) e1 e2 ...)
1411 (let ((ids (syntax (id ...))))
1412 (if (not (valid-bound-ids? ids))
1413 (syntax-violation #f "duplicate bound keyword" e)
1414 (let ((labels (gen-labels ids)))
1415 (let ((new-w (make-binding-wrap ids labels w)))
1416 (k (syntax (e1 e2 ...))
1419 (let ((w (if rec? new-w w))
1420 (trans-r (macros-only-env r)))
1422 (make-binding 'macro
1423 (eval-local-transformer
1424 (chi x trans-r w mod)
1426 (syntax (val ...))))
1431 (_ (syntax-violation #f "bad local syntax definition"
1432 (source-wrap e w s mod))))))
1434 (define eval-local-transformer
1435 (lambda (expanded mod)
1436 (let ((p (local-eval-hook expanded mod)))
1439 (syntax-violation #f "nonprocedure transformer" p)))))
1443 (build-application no-source (build-primref no-source 'void) '())))
1447 (and (nonsymbol-id? x)
1448 (free-id=? x (syntax (... ...))))))
1452 ;;; strips all annotations from potentially circular reader output
1454 (define strip-annotation
1458 (let ((new (cons #f #f)))
1459 (if parent (set-annotation-stripped! parent new))
1460 (set-car! new (strip-annotation (car x) #f))
1461 (set-cdr! new (strip-annotation (cdr x) #f))
1464 (or (annotation-stripped x)
1465 (strip-annotation (annotation-expression x) x)))
1467 (let ((new (make-vector (vector-length x))))
1468 (if parent (set-annotation-stripped! parent new))
1469 (let loop ((i (- (vector-length x) 1)))
1471 (vector-set! new i (strip-annotation (vector-ref x i) #f))
1476 ;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
1477 ;;; on an annotation, strips the annotation as well.
1478 ;;; since only the head of a list is annotated by the reader, not each pair
1479 ;;; in the spine, we also check for pairs whose cars are annotated in case
1480 ;;; we've been passed the cdr of an annotated list
1485 (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
1486 (strip-annotation x #f)
1491 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1493 (let ((a (f (car x))) (d (f (cdr x))))
1494 (if (and (eq? a (car x)) (eq? d (cdr x)))
1498 (let ((old (vector->list x)))
1499 (let ((new (map f old)))
1500 (if (and-map* eq? old new) x (list->vector new)))))
1503 ;;; lexical variables
1507 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1508 (if (annotation? id)
1509 (build-lexical-var (annotation-source id) (annotation-expression id))
1510 (build-lexical-var no-source id)))))
1512 (define lambda-var-list
1514 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1516 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1517 ((id? vars) (cons (wrap vars w #f) ls))
1519 ((syntax-object? vars)
1520 (lvl (syntax-object-expression vars)
1522 (join-wraps w (syntax-object-wrap vars))))
1524 (lvl (annotation-expression vars) ls w))
1525 ; include anything else to be caught by subsequent error
1527 (else (cons vars ls))))))
1529 ;;; core transformers
1531 (global-extend 'local-syntax 'letrec-syntax #t)
1532 (global-extend 'local-syntax 'let-syntax #f)
1534 (global-extend 'core 'fluid-let-syntax
1535 (lambda (e r w s mod)
1537 ((_ ((var val) ...) e1 e2 ...)
1538 (valid-bound-ids? (syntax (var ...)))
1539 (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
1542 (case (binding-type (lookup n r mod))
1543 ((displaced-lexical)
1544 (syntax-violation 'fluid-let-syntax
1545 "identifier out of context"
1547 (source-wrap id w s mod)))))
1551 (syntax (e1 e2 ...))
1552 (source-wrap e w s mod)
1555 (let ((trans-r (macros-only-env r)))
1557 (make-binding 'macro
1558 (eval-local-transformer (chi x trans-r w mod)
1560 (syntax (val ...))))
1564 (_ (syntax-violation 'fluid-let-syntax "bad syntax"
1565 (source-wrap e w s mod))))))
1567 (global-extend 'core 'quote
1568 (lambda (e r w s mod)
1570 ((_ e) (build-data s (strip (syntax e) w)))
1571 (_ (syntax-violation 'quote "bad syntax"
1572 (source-wrap e w s mod))))))
1574 (global-extend 'core 'syntax
1577 (lambda (src e r maps ellipsis? mod)
1579 (let ((label (id-var-name e empty-wrap)))
1580 (let ((b (lookup label r mod)))
1581 (if (eq? (binding-type b) 'syntax)
1584 (let ((var.lev (binding-value b)))
1585 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1586 (lambda (var maps) (values `(ref ,var) maps)))
1588 (syntax-violation 'syntax "misplaced ellipsis" src)
1589 (values `(quote ,e) maps)))))
1592 (ellipsis? (syntax dots))
1593 (gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
1595 ; this could be about a dozen lines of code, except that we
1596 ; choose to handle (syntax (x ... ...)) forms
1597 (ellipsis? (syntax dots))
1598 (let f ((y (syntax y))
1602 (gen-syntax src (syntax x) r
1603 (cons '() maps) ellipsis? mod))
1605 (if (null? (car maps))
1606 (syntax-violation 'syntax "extra ellipsis"
1608 (values (gen-map x (car maps))
1612 (ellipsis? (syntax dots))
1616 (lambda () (k (cons '() maps)))
1618 (if (null? (car maps))
1619 (syntax-violation 'syntax "extra ellipsis" src)
1620 (values (gen-mappend x (car maps))
1622 (_ (call-with-values
1623 (lambda () (gen-syntax src y r maps ellipsis? mod))
1626 (lambda () (k maps))
1628 (values (gen-append x y) maps)))))))))
1631 (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
1634 (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod))
1635 (lambda (y maps) (values (gen-cons x y) maps))))))
1639 (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod))
1640 (lambda (e maps) (values (gen-vector e) maps))))
1641 (_ (values `(quote ,e) maps))))))
1644 (lambda (src var level maps)
1648 (syntax-violation 'syntax "missing ellipsis" src)
1650 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1651 (lambda (outer-var outer-maps)
1652 (let ((b (assq outer-var (car maps))))
1654 (values (cdr b) maps)
1655 (let ((inner-var (gen-var 'tmp)))
1657 (cons (cons (cons outer-var inner-var)
1659 outer-maps)))))))))))
1663 `(apply (primitive append) ,(gen-map e map-env))))
1667 (let ((formals (map cdr map-env))
1668 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1671 ; identity map equivalence:
1672 ; (map (lambda (x) x) y) == y
1675 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1677 ; eta map equivalence:
1678 ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1679 `(map (primitive ,(car e))
1680 ,@(map (let ((r (map cons formals actuals)))
1681 (lambda (x) (cdr (assq (cadr x) r))))
1683 (else `(map (lambda ,formals ,e) ,@actuals))))))
1689 (if (eq? (car x) 'quote)
1690 `(quote (,(cadr x) . ,(cadr y)))
1691 (if (eq? (cadr y) '())
1694 ((list) `(list ,x ,@(cdr y)))
1695 (else `(cons ,x ,y)))))
1699 (if (equal? y '(quote ()))
1706 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1707 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1708 (else `(list->vector ,x)))))
1714 ((ref) (build-lexical-reference 'value no-source (cadr x)))
1715 ((primitive) (build-primref no-source (cadr x)))
1716 ((quote) (build-data no-source (cadr x)))
1717 ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
1718 ((map) (let ((ls (map regen (cdr x))))
1719 (build-application no-source
1720 (if (fx= (length ls) 2)
1721 (build-primref no-source 'map)
1722 ; really need to do our own checking here
1723 (build-primref no-source 2 'map)) ; require error check
1725 (else (build-application no-source
1726 (build-primref no-source (car x))
1727 (map regen (cdr x)))))))
1729 (lambda (e r w s mod)
1730 (let ((e (source-wrap e w s mod)))
1734 (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
1735 (lambda (e maps) (regen e))))
1736 (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
1739 (global-extend 'core 'lambda
1740 (lambda (e r w s mod)
1743 (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
1744 (lambda (vars docstring body) (build-lambda s vars docstring body)))))))
1747 (global-extend 'core 'let
1749 (define (chi-let e r w s mod constructor ids vals exps)
1750 (if (not (valid-bound-ids? ids))
1751 (syntax-violation 'let "duplicate bound variable" e)
1752 (let ((labels (gen-labels ids))
1753 (new-vars (map gen-var ids)))
1754 (let ((nw (make-binding-wrap ids labels w))
1755 (nr (extend-var-env labels new-vars r)))
1758 (map (lambda (x) (chi x r w mod)) vals)
1759 (chi-body exps (source-wrap e nw s mod)
1761 (lambda (e r w s mod)
1763 ((_ ((id val) ...) e1 e2 ...)
1764 (chi-let e r w s mod
1768 (syntax (e1 e2 ...))))
1769 ((_ f ((id val) ...) e1 e2 ...)
1771 (chi-let e r w s mod
1775 (syntax (e1 e2 ...))))
1776 (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
1779 (global-extend 'core 'letrec
1780 (lambda (e r w s mod)
1782 ((_ ((id val) ...) e1 e2 ...)
1783 (let ((ids (syntax (id ...))))
1784 (if (not (valid-bound-ids? ids))
1785 (syntax-violation 'letrec "duplicate bound variable" e)
1786 (let ((labels (gen-labels ids))
1787 (new-vars (map gen-var ids)))
1788 (let ((w (make-binding-wrap ids labels w))
1789 (r (extend-var-env labels new-vars r)))
1792 (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
1793 (chi-body (syntax (e1 e2 ...))
1794 (source-wrap e w s mod) r w mod)))))))
1795 (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
1798 (global-extend 'core 'set!
1799 (lambda (e r w s mod)
1803 (let ((val (chi (syntax val) r w mod))
1804 (n (id-var-name (syntax id) w)))
1805 (let ((b (lookup n r mod)))
1806 (case (binding-type b)
1808 (build-lexical-assignment s (binding-value b) val))
1809 ((global) (build-global-assignment s n val mod))
1810 ((displaced-lexical)
1811 (syntax-violation 'set! "identifier out of context"
1812 (wrap (syntax id) w mod)))
1813 (else (syntax-violation 'set! "bad set!"
1814 (source-wrap e w s mod)))))))
1815 ((_ (head tail ...) val)
1817 (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod))
1818 (lambda (type value ee ww ss modmod)
1821 (let ((val (chi (syntax val) r w mod)))
1822 (call-with-values (lambda () (value (syntax (head tail ...))))
1824 (build-global-assignment s id val mod)))))
1826 (build-application s
1827 (chi (syntax (setter head)) r w mod)
1828 (map (lambda (e) (chi e r w mod))
1829 (syntax (tail ... val)))))))))
1830 (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
1832 (global-extend 'module-ref '@
1836 (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
1837 (values (syntax->datum (syntax id))
1839 (syntax (public mod ...))))))))
1841 (global-extend 'module-ref '@@
1845 (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
1846 (values (syntax->datum (syntax id))
1848 (syntax (private mod ...))))))))
1850 (global-extend 'begin 'begin '())
1852 (global-extend 'define 'define '())
1854 (global-extend 'define-syntax 'define-syntax '())
1856 (global-extend 'eval-when 'eval-when '())
1858 (global-extend 'core 'syntax-case
1860 (define convert-pattern
1861 ; accepts pattern & keys
1862 ; returns $sc-dispatch pattern & ids
1863 (lambda (pattern keys)
1864 (let cvt ((p pattern) (n 0) (ids '()))
1866 (if (bound-id-member? p keys)
1867 (values (vector 'free-id p) ids)
1868 (values 'any (cons (cons p n) ids)))
1871 (ellipsis? (syntax dots))
1873 (lambda () (cvt (syntax x) (fx+ n 1) ids))
1875 (values (if (eq? p 'any) 'each-any (vector 'each p))
1879 (lambda () (cvt (syntax y) n ids))
1882 (lambda () (cvt (syntax x) n ids))
1884 (values (cons x y) ids))))))
1885 (() (values '() ids))
1888 (lambda () (cvt (syntax (x ...)) n ids))
1889 (lambda (p ids) (values (vector 'vector p) ids))))
1890 (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
1892 (define build-dispatch-call
1893 (lambda (pvars exp y r mod)
1894 (let ((ids (map car pvars)) (levels (map cdr pvars)))
1895 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1896 (build-application no-source
1897 (build-primref no-source 'apply)
1898 (list (build-lambda no-source new-vars
1902 (map (lambda (var level)
1903 (make-binding 'syntax `(,var . ,level)))
1907 (make-binding-wrap ids labels empty-wrap)
1912 (lambda (x keys clauses r pat fender exp mod)
1914 (lambda () (convert-pattern pat keys))
1917 ((not (distinct-bound-ids? (map car pvars)))
1918 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
1919 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
1920 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
1922 (let ((y (gen-var 'tmp)))
1923 ; fat finger binding and references to temp variable y
1924 (build-application no-source
1925 (build-lambda no-source (list y)
1926 (let ((y (build-lexical-reference 'value no-source y)))
1927 (build-conditional no-source
1928 (syntax-case fender ()
1930 (_ (build-conditional no-source
1932 (build-dispatch-call pvars fender y r mod)
1933 (build-data no-source #f))))
1934 (build-dispatch-call pvars exp y r mod)
1935 (gen-syntax-case x keys clauses r mod))))
1936 (list (if (eq? p 'any)
1937 (build-application no-source
1938 (build-primref no-source 'list)
1940 (build-application no-source
1941 (build-primref no-source '$sc-dispatch)
1942 (list x (build-data no-source p)))))))))))))
1944 (define gen-syntax-case
1945 (lambda (x keys clauses r mod)
1947 (build-application no-source
1948 (build-primref no-source 'syntax-violation)
1949 (list #f "source expression failed to match any pattern" x))
1950 (syntax-case (car clauses) ()
1952 (if (and (id? (syntax pat))
1953 (and-map (lambda (x) (not (free-id=? (syntax pat) x)))
1954 (cons (syntax (... ...)) keys)))
1955 (let ((labels (list (gen-label)))
1956 (var (gen-var (syntax pat))))
1957 (build-application no-source
1958 (build-lambda no-source (list var)
1961 (list (make-binding 'syntax `(,var . 0)))
1963 (make-binding-wrap (syntax (pat))
1967 (gen-clause x keys (cdr clauses) r
1968 (syntax pat) #t (syntax exp) mod)))
1970 (gen-clause x keys (cdr clauses) r
1971 (syntax pat) (syntax fender) (syntax exp) mod))
1972 (_ (syntax-violation 'syntax-case "invalid clause"
1975 (lambda (e r w s mod)
1976 (let ((e (source-wrap e w s mod)))
1978 ((_ val (key ...) m ...)
1979 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
1981 (let ((x (gen-var 'tmp)))
1982 ; fat finger binding and references to temp variable x
1983 (build-application s
1984 (build-lambda no-source (list x)
1985 (gen-syntax-case (build-lexical-reference 'value no-source x)
1986 (syntax (key ...)) (syntax (m ...))
1989 (list (chi (syntax val) r empty-wrap mod))))
1990 (syntax-violation 'syntax-case "invalid literals list" e))))))))
1992 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
1993 ;;; evaluating) and esew (which stands for "eval syntax expanders
1994 ;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
1995 ;;; if we are compiling a file, and esew is set to
1996 ;;; (eval-syntactic-expanders-when), which defaults to the list
1997 ;;; '(compile load eval). This means that, by default, top-level
1998 ;;; syntactic definitions are evaluated immediately after they are
1999 ;;; expanded, and the expanded definitions are also residualized into
2000 ;;; the object file if we are compiling a file.
2002 (let ((m 'e) (esew '(eval)))
2004 (if (and (pair? x) (equal? (car x) noexpand))
2006 (chi-top x null-env top-wrap m esew
2007 (cons 'hygiene (module-name (current-module))))))))
2010 (let ((m 'e) (esew '(eval)))
2012 (if (and (pair? x) (equal? (car x) noexpand))
2017 (if (null? rest) m (car rest))
2018 (if (or (null? rest) (null? (cdr rest)))
2021 (cons 'hygiene (module-name (current-module))))))))
2029 (make-syntax-object datum (syntax-object-wrap id) #f)))
2032 ; accepts any object, since syntax objects may consist partially
2033 ; or entirely of unwrapped, nonsymbolic data
2035 (strip x empty-wrap)))
2037 (set! generate-temporaries
2039 (arg-check list? ls 'generate-temporaries)
2040 (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
2042 (set! free-identifier=?
2044 (arg-check nonsymbol-id? x 'free-identifier=?)
2045 (arg-check nonsymbol-id? y 'free-identifier=?)
2048 (set! bound-identifier=?
2050 (arg-check nonsymbol-id? x 'bound-identifier=?)
2051 (arg-check nonsymbol-id? y 'bound-identifier=?)
2054 (set! syntax-violation
2055 (lambda (who message form . subform)
2056 (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2057 who 'syntax-violation)
2058 (arg-check string? message 'syntax-violation)
2059 (scm-error 'syntax-error 'sc-expand
2063 (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
2064 (let ((tail (cons message
2065 (map (lambda (x) (strip x empty-wrap))
2066 (append subform (list form))))))
2067 (if who (cons who tail) tail))
2070 ;;; $sc-dispatch expects an expression and a pattern. If the expression
2071 ;;; matches the pattern a list of the matching expressions for each
2072 ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2073 ;;; not work on r4rs implementations that violate the ieee requirement
2074 ;;; that #f and () be distinct.)
2076 ;;; The expression is matched with the pattern as follows:
2078 ;;; pattern: matches:
2081 ;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2083 ;;; #(free-id <key>) <key> with free-identifier=?
2084 ;;; #(each <pattern>) (<pattern>*)
2085 ;;; #(vector <pattern>) (list->vector <pattern>)
2086 ;;; #(atom <object>) <object> with "equal?"
2088 ;;; Vector cops out to pair under assumption that vectors are rare. If
2089 ;;; not, should convert to:
2090 ;;; #(vector <pattern>*) #(<pattern>*)
2098 (match-each (annotation-expression e) p w mod))
2100 (let ((first (match (car e) p w '() mod)))
2102 (let ((rest (match-each (cdr e) p w mod)))
2103 (and rest (cons first rest))))))
2106 (match-each (syntax-object-expression e)
2108 (join-wraps w (syntax-object-wrap e))
2109 (syntax-object-module e)))
2112 (define match-each-any
2116 (match-each-any (annotation-expression e) w mod))
2118 (let ((l (match-each-any (cdr e) w mod)))
2119 (and l (cons (wrap (car e) w mod) l))))
2122 (match-each-any (syntax-object-expression e)
2123 (join-wraps w (syntax-object-wrap e))
2131 ((eq? p 'any) (cons '() r))
2132 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2133 ((eq? p 'each-any) (cons '() r))
2135 (case (vector-ref p 0)
2136 ((each) (match-empty (vector-ref p 1) r))
2138 ((vector) (match-empty (vector-ref p 1) r)))))))
2141 (lambda (e p w r mod)
2143 ((null? p) (and (null? e) r))
2145 (and (pair? e) (match (car e) (car p) w
2146 (match (cdr e) (cdr p) w r mod)
2149 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2151 (case (vector-ref p 0)
2154 (match-empty (vector-ref p 1) r)
2155 (let ((l (match-each e (vector-ref p 1) w mod)))
2157 (let collect ((l l))
2160 (cons (map car l) (collect (map cdr l)))))))))
2161 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2162 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2165 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2168 (lambda (e p w r mod)
2171 ((eq? p 'any) (cons (wrap e w mod) r))
2174 (unannotate (syntax-object-expression e))
2176 (join-wraps w (syntax-object-wrap e))
2178 (syntax-object-module e)))
2179 (else (match* (unannotate e) p w r mod)))))
2184 ((eq? p 'any) (list e))
2186 (match* (unannotate (syntax-object-expression e))
2187 p (syntax-object-wrap e) '() (syntax-object-module e)))
2188 (else (match* (unannotate e) p empty-wrap '() #f)))))
2193 (define-syntax with-syntax
2197 (syntax (begin e1 e2 ...)))
2198 ((_ ((out in)) e1 e2 ...)
2199 (syntax (syntax-case in () (out (begin e1 e2 ...)))))
2200 ((_ ((out in) ...) e1 e2 ...)
2201 (syntax (syntax-case (list in ...) ()
2202 ((out ...) (begin e1 e2 ...))))))))
2204 (define-syntax syntax-rules
2207 ((_ (k ...) ((keyword . pattern) template) ...)
2209 (syntax-case x (k ...)
2210 ((dummy . pattern) (syntax template))
2216 ((let* ((x v) ...) e1 e2 ...)
2217 (and-map identifier? (syntax (x ...)))
2218 (let f ((bindings (syntax ((x v) ...))))
2219 (if (null? bindings)
2220 (syntax (let () e1 e2 ...))
2221 (with-syntax ((body (f (cdr bindings)))
2222 (binding (car bindings)))
2223 (syntax (let (binding) body)))))))))
2227 (syntax-case orig-x ()
2228 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2229 (with-syntax (((step ...)
2234 (_ (syntax-violation
2235 'do "bad step expression"
2238 (syntax (step ...)))))
2239 (syntax-case (syntax (e1 ...)) ()
2240 (() (syntax (let doloop ((var init) ...)
2242 (begin c ... (doloop step ...))))))
2244 (syntax (let doloop ((var init) ...)
2247 (begin c ... (doloop step ...))))))))))))
2249 (define-syntax quasiquote
2253 (with-syntax ((x x) (y y))
2254 (syntax-case (syntax y) (quote list)
2256 (syntax-case (syntax x) (quote)
2257 ((quote dx) (syntax (quote (dx . dy))))
2258 (_ (if (null? (syntax dy))
2260 (syntax (cons x y))))))
2261 ((list . stuff) (syntax (list x . stuff)))
2262 (else (syntax (cons x y)))))))
2265 (with-syntax ((x x) (y y))
2266 (syntax-case (syntax y) (quote)
2267 ((quote ()) (syntax x))
2268 (_ (syntax (append x y)))))))
2271 (with-syntax ((x x))
2272 (syntax-case (syntax x) (quote list)
2273 ((quote (x ...)) (syntax (quote #(x ...))))
2274 ((list x ...) (syntax (vector x ...)))
2275 (_ (syntax (list->vector x)))))))
2278 (syntax-case p (unquote unquote-splicing quasiquote)
2282 (quasicons (syntax (quote unquote))
2283 (quasi (syntax (p)) (- lev 1)))))
2284 (((unquote-splicing p) . q)
2286 (quasiappend (syntax p) (quasi (syntax q) lev))
2287 (quasicons (quasicons (syntax (quote unquote-splicing))
2288 (quasi (syntax (p)) (- lev 1)))
2289 (quasi (syntax q) lev))))
2291 (quasicons (syntax (quote quasiquote))
2292 (quasi (syntax (p)) (+ lev 1))))
2294 (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
2295 (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
2296 (p (syntax (quote p)))))))
2299 ((_ e) (quasi (syntax e) 0))))))
2301 (define-syntax include
2305 (let ((p (open-input-file fn)))
2306 (let f ((x (read p)))
2308 (begin (close-input-port p) '())
2309 (cons (datum->syntax k x)
2313 (let ((fn (syntax->datum (syntax filename))))
2314 (with-syntax (((exp ...) (read-file fn (syntax k))))
2315 (syntax (begin exp ...))))))))
2317 (define-syntax unquote
2322 "expression ,~s not valid outside of quasiquote"
2323 (syntax->datum (syntax e)))))))
2325 (define-syntax unquote-splicing
2329 (error 'unquote-splicing
2330 "expression ,@~s not valid outside of quasiquote"
2331 (syntax->datum (syntax e)))))))
2338 ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
2340 (syntax-case clause (else)
2341 ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
2342 (((k ...) e1 e2 ...)
2343 (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
2344 (_ (syntax-violation 'case "bad clause" x clause)))
2345 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2346 (syntax-case clause (else)
2347 (((k ...) e1 e2 ...)
2348 (syntax (if (memv t '(k ...))
2351 (_ (syntax-violation 'case "bad clause" x
2353 (syntax (let ((t e)) body)))))))
2355 (define-syntax identifier-syntax
2363 (identifier? (syntax id))
2366 (syntax (e x (... ...)))))))))))