3 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010 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 3 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 Andy Wingo <wingo@pobox.com> according to the Git
26 ;;; revision control logs corresponding to this file: 2009.
28 ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
29 ;;; to the ChangeLog distributed in the same directory as this file:
30 ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
31 ;;; 2000-09-12, 2001-03-08
33 ;;; Copyright (c) 1992-1997 Cadence Research Systems
34 ;;; Permission to copy this software, in whole or in part, to use this
35 ;;; software for any lawful purpose, and to redistribute this software
36 ;;; is granted subject to the restriction that all copies made of this
37 ;;; software must include this copyright notice in full. This software
38 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
39 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
40 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
41 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
42 ;;; NATURE WHATSOEVER.
44 ;;; Before attempting to port this code to a new implementation of
45 ;;; Scheme, please read the notes below carefully.
48 ;;; This file defines the syntax-case expander, macroexpand, and a set
49 ;;; of associated syntactic forms and procedures. Of these, the
50 ;;; following are documented in The Scheme Programming Language,
51 ;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). Most are
52 ;;; also documented in the R4RS and draft R5RS.
54 ;;; bound-identifier=?
59 ;;; generate-temporaries
70 ;;; All standard Scheme syntactic forms are supported by the expander
71 ;;; or syntactic abstractions defined in this file. Only the R4RS
72 ;;; delay is omitted, since its expansion is implementation-dependent.
74 ;;; The remaining exports are listed below:
76 ;;; (macroexpand datum)
77 ;;; if datum represents a valid expression, macroexpand returns an
78 ;;; expanded version of datum in a core language that includes no
79 ;;; syntactic abstractions. The core language includes begin,
80 ;;; define, if, lambda, letrec, quote, and set!.
81 ;;; (eval-when situations expr ...)
82 ;;; conditionally evaluates expr ... at compile-time or run-time
83 ;;; depending upon situations (see the Chez Scheme System Manual,
84 ;;; Revision 3, for a complete description)
85 ;;; (syntax-violation who message form [subform])
86 ;;; used to report errors found during expansion
87 ;;; ($sc-dispatch e p)
88 ;;; used by expanded code to handle syntax-case matching
90 ;;; The following nonstandard procedures must be provided by the
91 ;;; implementation for this code to run using the standard portable
92 ;;; hooks and output constructors. They are not used by expanded code,
93 ;;; and so need be present only at expansion time.
96 ;;; where x is always in the form ("noexpand" expr).
97 ;;; returns the value of expr. the "noexpand" flag is used to tell the
98 ;;; evaluator/expander that no expansion is necessary, since expr has
99 ;;; already been fully expanded to core forms.
101 ;;; eval will not be invoked during the loading of psyntax.pp. After
102 ;;; psyntax.pp has been loaded, the expansion of any macro definition,
103 ;;; whether local or global, will result in a call to eval. If, however,
104 ;;; macroexpand has already been registered as the expander to be used
105 ;;; by eval, and eval accepts one argument, nothing special must be done
106 ;;; to support the "noexpand" flag, since it is handled by macroexpand.
109 ;;; returns a unique symbol each time it's called
111 ;;; When porting to a new Scheme implementation, you should define the
112 ;;; procedures listed above, load the expanded version of psyntax.ss
113 ;;; (psyntax.pp, which should be available whereever you found
114 ;;; psyntax.ss), and register macroexpand as the current expander (how
115 ;;; you do this depends upon your implementation of Scheme). You may
116 ;;; change the hooks and constructors defined toward the beginning of
117 ;;; the code below, but to avoid bootstrapping problems, do so only
118 ;;; after you have a working version of the expander.
120 ;;; Chez Scheme allows the syntactic form (syntax <template>) to be
121 ;;; abbreviated to #'<template>, just as (quote <datum>) may be
122 ;;; abbreviated to '<datum>. The #' syntax makes programs written
123 ;;; using syntax-case shorter and more readable and draws out the
124 ;;; intuitive connection between syntax and quote.
126 ;;; If you find that this code loads or runs slowly, consider
127 ;;; switching to faster hardware or a faster implementation of
128 ;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
129 ;;; compiling (with full optimization), and loading this file takes
130 ;;; between one and two seconds.
132 ;;; In the expander implementation, we sometimes use syntactic abstractions
133 ;;; when procedural abstractions would suffice. For example, we define
134 ;;; top-wrap and top-marked? as
135 ;;; (define-syntax top-wrap (identifier-syntax '((top))))
136 ;;; (define-syntax top-marked?
138 ;;; ((_ w) (memq 'top (wrap-marks w)))))
140 ;;; (define top-wrap '((top)))
141 ;;; (define top-marked?
142 ;;; (lambda (w) (memq 'top (wrap-marks w))))
143 ;;; On ther other hand, we don't do this consistently; we define make-wrap,
144 ;;; wrap-marks, and wrap-subst simply as
145 ;;; (define make-wrap cons)
146 ;;; (define wrap-marks car)
147 ;;; (define wrap-subst cdr)
148 ;;; In Chez Scheme, the syntactic and procedural forms of these
149 ;;; abstractions are equivalent, since the optimizer consistently
150 ;;; integrates constants and small procedures. Some Scheme
151 ;;; implementations, however, may benefit from more consistent use
152 ;;; of one form or the other.
155 ;;; implementation information:
157 ;;; "begin" is treated as a splicing construct at top level and at
158 ;;; the beginning of bodies. Any sequence of expressions that would
159 ;;; be allowed where the "begin" occurs is allowed.
161 ;;; "let-syntax" and "letrec-syntax" are also treated as splicing
162 ;;; constructs, in violation of the R4RS appendix and probably the R5RS
163 ;;; when it comes out. A consequence, let-syntax and letrec-syntax do
164 ;;; not create local contours, as do let and letrec. Although the
165 ;;; functionality is greater as it is presently implemented, we will
166 ;;; probably change it to conform to the R4RS/expected R5RS.
168 ;;; Objects with no standard print syntax, including objects containing
169 ;;; cycles and syntax object, are allowed in quoted data as long as they
170 ;;; are contained within a syntax form or produced by datum->syntax.
171 ;;; Such objects are never copied.
173 ;;; All identifiers that don't have macro definitions and are not bound
174 ;;; lexically are assumed to be global variables
176 ;;; Top-level definitions of macro-introduced identifiers are allowed.
177 ;;; This may not be appropriate for implementations in which the
178 ;;; model is that bindings are created by definitions, as opposed to
179 ;;; one in which initial values are assigned by definitions.
181 ;;; Top-level variable definitions of syntax keywords is not permitted.
182 ;;; Any solution allowing this would be kludgey and would yield
183 ;;; surprising results in some cases. We can provide an undefine-syntax
184 ;;; form. The questions is, should define be an implicit undefine-syntax?
185 ;;; We've decided no for now.
187 ;;; Identifiers and syntax objects are implemented as vectors for
188 ;;; portability. As a result, it is possible to "forge" syntax
191 ;;; The implementation of generate-temporaries assumes that it is possible
192 ;;; to generate globally unique symbols (gensyms).
194 ;;; The source location associated with incoming expressions is tracked via the
195 ;;; source-properties mechanism, a weak map from expression to source
196 ;;; information. At times the source is separated from the expression; see the
197 ;;; note below about "efficiency and confusion".
202 ;;; When changing syntax-object representations, it is necessary to support
203 ;;; both old and new syntax-object representations in id-var-name. It
204 ;;; should be sufficient to recognize old representations and treat
205 ;;; them as not lexically bound.
210 (set-current-module (resolve-module '(guile))))
213 ;;; Private version of and-map that handles multiple lists.
215 (lambda (f first . rest)
218 (let andmap ((first first))
219 (let ((x (car first)) (first (cdr first)))
222 (and (f x) (andmap first)))))
223 (let andmap ((first first) (rest rest))
224 (let ((x (car first))
227 (rest (map cdr rest)))
229 (apply f (cons x xr))
230 (and (apply f (cons x xr)) (andmap first rest)))))))))
232 (define-syntax define-expansion-constructors
236 (let lp ((n 0) (out '()))
237 (if (< n (vector-length %expanded-vtables))
239 (let* ((vtable (vector-ref %expanded-vtables n))
240 (stem (struct-ref vtable (+ vtable-offset-user 0)))
241 (fields (struct-ref vtable (+ vtable-offset-user 2)))
242 (sfields (map (lambda (f) (datum->syntax x f)) fields))
243 (ctor (datum->syntax x (symbol-append 'make- stem))))
244 (cons #`(define (#,ctor #,@sfields)
245 (make-struct (vector-ref %expanded-vtables #,n) 0
248 #`(begin #,@(reverse out))))))))
250 (define-syntax define-expansion-accessors
255 (let ((vtable (vector-ref %expanded-vtables n))
256 (stem (syntax->datum #'stem)))
257 (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
259 (define (#,(datum->syntax x (symbol-append stem '?)) x)
261 (eq? (struct-vtable x)
262 (vector-ref %expanded-vtables #,n))))
265 (let ((get (datum->syntax x (symbol-append stem '- f)))
266 (set (datum->syntax x (symbol-append 'set- stem '- f '!)))
267 (idx (list-index (struct-ref vtable
268 (+ vtable-offset-user 2))
272 (struct-ref x #,idx))
274 (struct-set! x #,idx v)))))
275 (syntax->datum #'(field ...))))
278 (define-syntax define-structure
280 (define construct-name
281 (lambda (template-identifier . args)
289 (symbol->string (syntax->datum x))))
293 (and-map identifier? #'(name id1 ...))
295 ((constructor (construct-name #'name "make-" #'name))
296 (predicate (construct-name #'name #'name "?"))
298 (map (lambda (x) (construct-name x #'name "-" x))
302 (construct-name x "set-" #'name "-" x "!"))
305 (+ (length #'(id1 ...)) 1))
307 (let f ((i 1) (ids #'(id1 ...)))
310 (cons i (f (+ i 1) (cdr ids)))))))
314 (vector 'name id1 ... )))
318 (= (vector-length x) structure-length)
319 (eq? (vector-ref x 0) 'name))))
322 (vector-ref x index)))
326 (vector-set! x index update)))
330 (define-expansion-constructors)
331 (define-expansion-accessors lambda meta)
333 ;;; hooks to nonportable run-time helpers
340 (define top-level-eval-hook
344 (define local-eval-hook
348 (define-syntax gensym-hook
352 (define put-global-definition-hook
353 (lambda (symbol type val)
354 (module-define! (current-module)
356 (make-syntax-transformer symbol type val))))
358 (define get-global-definition-hook
359 (lambda (symbol module)
360 (if (and (not module) (current-module))
361 (warn "module system is booted, we should have a module" symbol))
362 (let ((v (module-variable (if module
363 (resolve-module (cdr module))
366 (and v (variable-bound? v)
367 (let ((val (variable-ref v)))
368 (and (macro? val) (macro-type val)
369 (cons (macro-type val)
370 (macro-binding val))))))))
375 (define (decorate-source e s)
376 (if (and (pair? e) s)
377 (set-source-properties! e s))
380 ;;; output constructors
385 (define build-application
386 (lambda (source fun-exp arg-exps)
387 (make-application source fun-exp arg-exps)))
389 (define build-conditional
390 (lambda (source test-exp then-exp else-exp)
391 (make-conditional source test-exp then-exp else-exp)))
394 (lambda (source fluids vals body)
395 (make-dynlet source fluids vals body)))
397 (define build-lexical-reference
398 (lambda (type source name var)
399 (make-lexical-ref source name var)))
401 (define build-lexical-assignment
402 (lambda (source name var exp)
403 (make-lexical-set source name var exp)))
405 ;; Before modules are booted, we can't expand into data structures from
406 ;; (language tree-il) -- we need to give the evaluator the
407 ;; s-expressions that it understands natively. Actually the real truth
408 ;; of the matter is that the evaluator doesn't understand tree-il
409 ;; structures at all. So until we fix the evaluator, if ever, the
410 ;; conflation that we should use tree-il iff we are compiling
413 (define (analyze-variable mod var modref-cont bare-cont)
416 (let ((kind (car mod))
419 ((public) (modref-cont mod var #t))
420 ((private) (if (not (equal? mod (module-name (current-module))))
421 (modref-cont mod var #f)
423 ((bare) (bare-cont var))
424 ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
425 (module-variable (resolve-module mod) var))
426 (modref-cont mod var #f)
428 (else (syntax-violation #f "bad module kind" var mod))))))
430 (define build-global-reference
431 (lambda (source var mod)
434 (lambda (mod var public?)
435 (make-module-ref source mod var public?))
437 (make-toplevel-ref source var)))))
439 (define build-global-assignment
440 (lambda (source var exp mod)
443 (lambda (mod var public?)
444 (make-module-set source mod var public? exp))
446 (make-toplevel-set source var exp)))))
448 (define (maybe-name-value! name val)
450 (let ((meta (lambda-meta val)))
451 (if (not (assq 'name meta))
452 (set-lambda-meta! val (acons 'name name meta))))))
454 (define build-global-definition
455 (lambda (source var exp)
456 (maybe-name-value! var exp)
457 (make-toplevel-define source var exp)))
459 ;; Ideally we would have all lambdas be case lambdas, but that would
460 ;; need special support in the interpreter for the full capabilities
461 ;; of case-lambda, with optional and keyword args and else clauses.
462 ;; This will come with the new interpreter, but for now we separate
464 (define build-simple-lambda
465 (lambda (src req rest vars meta exp)
468 ;; hah, a case in which kwargs would be nice.
470 ;; src req opt rest kw inits vars body else
471 src req #f rest #f '() vars exp #f))))
473 (define build-case-lambda
474 (lambda (src meta body)
475 (make-lambda src meta body)))
477 (define build-lambda-case
479 ;; opt := (name ...) | #f
481 ;; kw := (allow-other-keys? (keyword name var) ...) | #f
484 ;; vars map to named arguments in the following order:
485 ;; required, optional (positional), rest, keyword.
486 ;; the body of a lambda: anything, already expanded
487 ;; else: lambda-case | #f
488 (lambda (src req opt rest kw inits vars body else-case)
489 (make-lambda-case src req opt rest kw inits vars body else-case)))
491 (define build-primref
493 (if (equal? (module-name (current-module)) '(guile))
494 (make-toplevel-ref src name)
495 (make-module-ref src '(guile) name #f))))
497 (define (build-data src exp)
498 (make-const src exp))
500 (define build-sequence
502 (if (null? (cdr exps))
504 (make-sequence src exps))))
507 (lambda (src ids vars val-exps body-exp)
508 (for-each maybe-name-value! ids val-exps)
511 (make-let src ids vars val-exps body-exp))))
513 (define build-named-let
514 (lambda (src ids vars val-exps body-exp)
519 (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
520 (maybe-name-value! f-name proc)
521 (for-each maybe-name-value! ids val-exps)
524 (list f-name) (list f) (list proc)
525 (build-application src (build-lexical-reference 'fun src f-name f)
529 (lambda (src in-order? ids vars val-exps body-exp)
533 (for-each maybe-name-value! ids val-exps)
534 (make-letrec src in-order? ids vars val-exps body-exp)))))
537 ;; FIXME: use a faster gensym
538 (define-syntax build-lexical-var
540 ((_ src id) (gensym (string-append (symbol->string id) " ")))))
542 (define-structure (syntax-object expression wrap module))
544 (define-syntax no-source (identifier-syntax #f))
546 (define source-annotation
550 (source-annotation (syntax-object-expression x)))
551 ((pair? x) (let ((props (source-properties x)))
557 (define-syntax arg-check
561 (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
563 ;;; compile-time environments
565 ;;; wrap and environment comprise two level mapping.
566 ;;; wrap : id --> label
567 ;;; env : label --> <element>
569 ;;; environments are represented in two parts: a lexical part and a global
570 ;;; part. The lexical part is a simple list of associations from labels
571 ;;; to bindings. The global part is implemented by
572 ;;; {put,get}-global-definition-hook and associates symbols with
575 ;;; global (assumed global variable) and displaced-lexical (see below)
576 ;;; do not show up in any environment; instead, they are fabricated by
577 ;;; lookup when it finds no other bindings.
579 ;;; <environment> ::= ((<label> . <binding>)*)
581 ;;; identifier bindings include a type and a value
583 ;;; <binding> ::= (macro . <procedure>) macros
584 ;;; (core . <procedure>) core forms
585 ;;; (module-ref . <procedure>) @ or @@
588 ;;; (define-syntax) define-syntax
589 ;;; (local-syntax . rec?) let-syntax/letrec-syntax
590 ;;; (eval-when) eval-when
591 ;;; #'. (<var> . <level>) pattern variables
592 ;;; (global) assumed global variable
593 ;;; (lexical . <var>) lexical variables
594 ;;; (displaced-lexical) displaced lexicals
595 ;;; <level> ::= <nonnegative integer>
596 ;;; <var> ::= variable returned by build-lexical-var
598 ;;; a macro is a user-defined syntactic-form. a core is a system-defined
599 ;;; syntactic form. begin, define, define-syntax, and eval-when are
600 ;;; treated specially since they are sensitive to whether the form is
601 ;;; at top-level and (except for eval-when) can denote valid internal
604 ;;; a pattern variable is a variable introduced by syntax-case and can
605 ;;; be referenced only within a syntax form.
607 ;;; any identifier for which no top-level syntax definition or local
608 ;;; binding of any kind has been seen is assumed to be a global
611 ;;; a lexical variable is a lambda- or letrec-bound variable.
613 ;;; a displaced-lexical identifier is a lexical identifier removed from
614 ;;; it's scope by the return of a syntax object containing the identifier.
615 ;;; a displaced lexical can also appear when a letrec-syntax-bound
616 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
617 ;;; a displaced lexical should never occur with properly written macros.
619 (define-syntax make-binding
620 (syntax-rules (quote)
621 ((_ type value) (cons type value))
623 ((_ type) (cons type '()))))
624 (define binding-type car)
625 (define binding-value cdr)
627 (define-syntax null-env (identifier-syntax '()))
630 (lambda (labels bindings r)
633 (extend-env (cdr labels) (cdr bindings)
634 (cons (cons (car labels) (car bindings)) r)))))
636 (define extend-var-env
637 ; variant of extend-env that forms "lexical" binding
638 (lambda (labels vars r)
641 (extend-var-env (cdr labels) (cdr vars)
642 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
644 ;;; we use a "macros only" environment in expansion of local macro
645 ;;; definitions so that their definitions can use local macros without
646 ;;; attempting to use other lexical identifiers.
647 (define macros-only-env
652 (if (eq? (cadr a) 'macro)
653 (cons a (macros-only-env (cdr r)))
654 (macros-only-env (cdr r)))))))
657 ; x may be a label or a symbol
658 ; although symbols are usually global, we check the environment first
659 ; anyway because a temporary binding may have been established by
665 (or (get-global-definition-hook x mod) (make-binding 'global)))
666 (else (make-binding 'displaced-lexical)))))
668 (define global-extend
669 (lambda (type sym val)
670 (put-global-definition-hook sym type val)))
673 ;;; Conceptually, identifiers are always syntax objects. Internally,
674 ;;; however, the wrap is sometimes maintained separately (a source of
675 ;;; efficiency and confusion), so that symbols are also considered
676 ;;; identifiers by id?. Externally, they are always wrapped.
678 (define nonsymbol-id?
680 (and (syntax-object? x)
681 (symbol? (syntax-object-expression x)))))
687 ((syntax-object? x) (symbol? (syntax-object-expression x)))
690 (define-syntax id-sym-name
694 (if (syntax-object? x)
695 (syntax-object-expression x)
698 (define id-sym-name&marks
700 (if (syntax-object? x)
702 (syntax-object-expression x)
703 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
704 (values x (wrap-marks w)))))
706 ;;; syntax object wraps
708 ;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
709 ;;; <subst> ::= <shift> | <subs>
710 ;;; <subs> ::= #(<old name> <label> (<mark> ...))
711 ;;; <shift> ::= positive fixnum
713 (define make-wrap cons)
714 (define wrap-marks car)
715 (define wrap-subst cdr)
717 (define-syntax subst-rename? (identifier-syntax vector?))
718 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
719 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
720 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
721 (define-syntax make-rename
723 ((_ old new marks) (vector old new marks))))
725 ;;; labels must be comparable with "eq?", have read-write invariance,
726 ;;; and distinct from symbols.
728 (lambda () (symbol->string (gensym "i"))))
734 (cons (gen-label) (gen-labels (cdr ls))))))
736 (define-structure (ribcage symnames marks labels))
738 (define-syntax empty-wrap (identifier-syntax '(())))
740 (define-syntax top-wrap (identifier-syntax '((top))))
742 (define-syntax top-marked?
744 ((_ w) (memq 'top (wrap-marks w)))))
746 ;;; Marks must be comparable with "eq?" and distinct from pairs and
747 ;;; the symbol top. We do not use integers so that marks will remain
748 ;;; unique even across file compiles.
750 (define-syntax the-anti-mark (identifier-syntax #f))
754 (make-wrap (cons the-anti-mark (wrap-marks w))
755 (cons 'shift (wrap-subst w)))))
757 (define-syntax new-mark
761 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
762 ;;; internal definitions, in which the ribcages are built incrementally
763 (define-syntax make-empty-ribcage
765 ((_) (make-ribcage '() '() '()))))
767 (define extend-ribcage!
768 ; must receive ids with complete wraps
769 (lambda (ribcage id label)
770 (set-ribcage-symnames! ribcage
771 (cons (syntax-object-expression id)
772 (ribcage-symnames ribcage)))
773 (set-ribcage-marks! ribcage
774 (cons (wrap-marks (syntax-object-wrap id))
775 (ribcage-marks ribcage)))
776 (set-ribcage-labels! ribcage
777 (cons label (ribcage-labels ribcage)))))
779 ;;; make-binding-wrap creates vector-based ribcages
780 (define make-binding-wrap
781 (lambda (ids labels w)
787 (let ((labelvec (list->vector labels)))
788 (let ((n (vector-length labelvec)))
789 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
790 (let f ((ids ids) (i 0))
791 (if (not (null? ids))
793 (lambda () (id-sym-name&marks (car ids) w))
794 (lambda (symname marks)
795 (vector-set! symnamevec i symname)
796 (vector-set! marksvec i marks)
797 (f (cdr ids) (fx+ i 1))))))
798 (make-ribcage symnamevec marksvec labelvec))))
809 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
815 (smart-append s1 (wrap-subst w2))))
817 (smart-append m1 (wrap-marks w2))
818 (smart-append s1 (wrap-subst w2)))))))
822 (smart-append m1 m2)))
829 (eq? (car x) (car y))
830 (same-marks? (cdr x) (cdr y))))))
836 ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
838 (lambda (sym subst marks)
841 (let ((fst (car subst)))
843 (search sym (cdr subst) (cdr marks))
844 (let ((symnames (ribcage-symnames fst)))
845 (if (vector? symnames)
846 (search-vector-rib sym subst marks symnames fst)
847 (search-list-rib sym subst marks symnames fst))))))))
848 (define search-list-rib
849 (lambda (sym subst marks symnames ribcage)
850 (let f ((symnames symnames) (i 0))
852 ((null? symnames) (search sym (cdr subst) marks))
853 ((and (eq? (car symnames) sym)
854 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
855 (values (list-ref (ribcage-labels ribcage) i) marks))
856 (else (f (cdr symnames) (fx+ i 1)))))))
857 (define search-vector-rib
858 (lambda (sym subst marks symnames ribcage)
859 (let ((n (vector-length symnames)))
862 ((fx= i n) (search sym (cdr subst) marks))
863 ((and (eq? (vector-ref symnames i) sym)
864 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
865 (values (vector-ref (ribcage-labels ribcage) i) marks))
866 (else (f (fx+ i 1))))))))
869 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
871 (let ((id (syntax-object-expression id))
872 (w1 (syntax-object-wrap id)))
873 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
874 (call-with-values (lambda () (search id (wrap-subst w) marks))
875 (lambda (new-id marks)
877 (first (search id (wrap-subst w1) marks))
879 (else (syntax-violation 'id-var-name "invalid id" id)))))
881 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
882 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
886 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
887 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
889 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
890 ;;; long as the missing portion of the wrap is common to both of the ids
891 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
895 (if (and (syntax-object? i) (syntax-object? j))
896 (and (eq? (syntax-object-expression i)
897 (syntax-object-expression j))
898 (same-marks? (wrap-marks (syntax-object-wrap i))
899 (wrap-marks (syntax-object-wrap j))))
902 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
903 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
904 ;;; as long as the missing portion of the wrap is common to all of the
907 (define valid-bound-ids?
909 (and (let all-ids? ((ids ids))
912 (all-ids? (cdr ids)))))
913 (distinct-bound-ids? ids))))
915 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
916 ;;; no duplicates. It is quadratic on the length of the id list; long
917 ;;; lists could be sorted to make it more efficient. distinct-bound-ids?
918 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
919 ;;; missing portion of the wrap is common to all of the ids.
921 (define distinct-bound-ids?
923 (let distinct? ((ids ids))
925 (and (not (bound-id-member? (car ids) (cdr ids)))
926 (distinct? (cdr ids)))))))
928 (define bound-id-member?
930 (and (not (null? list))
931 (or (bound-id=? x (car list))
932 (bound-id-member? x (cdr list))))))
934 ;;; wrapping expressions and identifiers
939 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
942 (syntax-object-expression x)
943 (join-wraps w (syntax-object-wrap x))
944 (syntax-object-module x)))
946 (else (make-syntax-object x w defmod)))))
949 (lambda (x w s defmod)
950 (wrap (decorate-source x s) w defmod)))
955 (lambda (body r w s mod)
957 (let dobody ((body body) (r r) (w w) (mod mod))
960 (let ((first (chi (car body) r w mod)))
961 (cons first (dobody (cdr body) r w mod))))))))
963 (define chi-top-sequence
964 (lambda (body r w s m esew mod)
966 (let dobody ((body body) (r r) (w w) (m m) (esew esew)
970 (dobody (cdr body) r w m esew mod
971 (cons (chi-top (car body) r w m esew mod) out)))))))
973 (define chi-install-global
975 (build-global-definition
980 (build-primref no-source 'make-syntax-transformer)
981 (list (build-data no-source name)
982 (build-data no-source 'macro)
985 (define chi-when-list
986 (lambda (e when-list w)
987 ; when-list is syntax'd version of list of situations
988 (let f ((when-list when-list) (situations '()))
989 (if (null? when-list)
992 (cons (let ((x (car when-list)))
994 ((free-id=? x #'compile) 'compile)
995 ((free-id=? x #'load) 'load)
996 ((free-id=? x #'eval) 'eval)
997 ((free-id=? x #'expand) 'expand)
998 (else (syntax-violation 'eval-when
1003 ;;; syntax-type returns six values: type, value, e, w, s, and mod. The
1004 ;;; first two are described in the table below.
1006 ;;; type value explanation
1007 ;;; -------------------------------------------------------------------
1008 ;;; core procedure core singleton
1009 ;;; core-form procedure core form
1010 ;;; module-ref procedure @ or @@ singleton
1011 ;;; lexical name lexical variable reference
1012 ;;; global name global variable reference
1013 ;;; begin none begin keyword
1014 ;;; define none define keyword
1015 ;;; define-syntax none define-syntax keyword
1016 ;;; local-syntax rec? letrec-syntax/let-syntax keyword
1017 ;;; eval-when none eval-when keyword
1018 ;;; syntax level pattern variable
1019 ;;; displaced-lexical none displaced lexical identifier
1020 ;;; lexical-call name call to lexical variable
1021 ;;; global-call name call to global variable
1022 ;;; call none any other call
1023 ;;; begin-form none begin expression
1024 ;;; define-form id variable definition
1025 ;;; define-syntax-form id syntax definition
1026 ;;; local-syntax-form rec? syntax definition
1027 ;;; eval-when-form none eval-when form
1028 ;;; constant none self-evaluating datum
1029 ;;; other none anything else
1031 ;;; For define-form and define-syntax-form, e is the rhs expression.
1032 ;;; For all others, e is the entire form. w is the wrap for e.
1033 ;;; s is the source for the entire form. mod is the module for e.
1035 ;;; syntax-type expands macros and unwraps as necessary to get to
1036 ;;; one of the forms above. It also parses define and define-syntax
1037 ;;; forms, although perhaps this should be done by the consumer.
1040 (lambda (e r w s rib mod for-car?)
1043 (let* ((n (id-var-name e w))
1044 (b (lookup n r mod))
1045 (type (binding-type b)))
1047 ((lexical) (values type (binding-value b) e w s mod))
1048 ((global) (values type n e w s mod))
1051 (values type (binding-value b) e w s mod)
1052 (syntax-type (chi-macro (binding-value b) e r w s rib mod)
1053 r empty-wrap s rib mod #f)))
1054 (else (values type (binding-value b) e w s mod)))))
1056 (let ((first (car e)))
1058 (lambda () (syntax-type first r w s rib mod #t))
1059 (lambda (ftype fval fe fw fs fmod)
1062 (values 'lexical-call fval e w s mod))
1064 ;; If we got here via an (@@ ...) expansion, we need to
1065 ;; make sure the fmod information is propagated back
1066 ;; correctly -- hence this consing.
1067 (values 'global-call (make-syntax-object fval w fmod)
1070 (syntax-type (chi-macro fval e r w s rib mod)
1071 r empty-wrap s rib mod for-car?))
1073 (call-with-values (lambda () (fval e r w))
1074 (lambda (e r w s mod)
1075 (syntax-type e r w s rib mod for-car?))))
1077 (values 'core-form fval e w s mod))
1079 (values 'local-syntax-form fval e w s mod))
1081 (values 'begin-form #f e w s mod))
1083 (values 'eval-when-form #f e w s mod))
1088 (values 'define-form #'name #'val w s mod))
1089 ((_ (name . args) e1 e2 ...)
1091 (valid-bound-ids? (lambda-var-list #'args)))
1092 ; need lambda here...
1093 (values 'define-form (wrap #'name w mod)
1095 (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
1100 (values 'define-form (wrap #'name w mod)
1102 empty-wrap s mod))))
1107 (values 'define-syntax-form #'name
1110 (values 'call #f e w s mod)))))))
1112 (syntax-type (syntax-object-expression e)
1114 (join-wraps w (syntax-object-wrap e))
1115 (or (source-annotation e) s) rib
1116 (or (syntax-object-module e) mod) for-car?))
1117 ((self-evaluating? e) (values 'constant #f e w s mod))
1118 (else (values 'other #f e w s mod)))))
1121 (lambda (e r w m esew mod)
1122 (define-syntax eval-if-c&e
1126 (if (eq? m 'c&e) (top-level-eval-hook x mod))
1129 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
1130 (lambda (type value e w s mod)
1136 (chi-top-sequence #'(e1 e2 ...) r w s m esew mod))))
1137 ((local-syntax-form)
1138 (chi-local-syntax value e r w s mod
1139 (lambda (body r w s mod)
1140 (chi-top-sequence body r w s m esew mod))))
1143 ((_ (x ...) e1 e2 ...)
1144 (let ((when-list (chi-when-list e #'(x ...) w))
1145 (body #'(e1 e2 ...)))
1148 (if (memq 'eval when-list)
1149 (chi-top-sequence body r w s
1150 (if (memq 'expand when-list) 'c&e 'e)
1154 (if (memq 'expand when-list)
1155 (top-level-eval-hook
1156 (chi-top-sequence body r w s 'e '(eval) mod)
1159 ((memq 'load when-list)
1160 (if (or (memq 'compile when-list)
1161 (memq 'expand when-list)
1162 (and (eq? m 'c&e) (memq 'eval when-list)))
1163 (chi-top-sequence body r w s 'c&e '(compile load) mod)
1164 (if (memq m '(c c&e))
1165 (chi-top-sequence body r w s 'c '(load) mod)
1167 ((or (memq 'compile when-list)
1168 (memq 'expand when-list)
1169 (and (eq? m 'c&e) (memq 'eval when-list)))
1170 (top-level-eval-hook
1171 (chi-top-sequence body r w s 'e '(eval) mod)
1174 (else (chi-void)))))))
1175 ((define-syntax-form)
1176 (let ((n (id-var-name value w)) (r (macros-only-env r)))
1179 (if (memq 'compile esew)
1180 (let ((e (chi-install-global n (chi e r w mod))))
1181 (top-level-eval-hook e mod)
1182 (if (memq 'load esew) e (chi-void)))
1183 (if (memq 'load esew)
1184 (chi-install-global n (chi e r w mod))
1187 (let ((e (chi-install-global n (chi e r w mod))))
1188 (top-level-eval-hook e mod)
1191 (if (memq 'eval esew)
1192 (top-level-eval-hook
1193 (chi-install-global n (chi e r w mod))
1197 (let* ((n (id-var-name value w))
1198 (type (binding-type (lookup n r mod))))
1200 ((global core macro module-ref)
1201 ;; affect compile-time environment (once we have booted)
1202 (if (and (memq m '(c c&e))
1203 (not (module-local-variable (current-module) n))
1205 (let ((old (module-variable (current-module) n)))
1206 ;; use value of the same-named imported variable, if
1208 (module-define! (current-module) n
1213 (build-global-definition s n (chi e r w mod))
1215 ((displaced-lexical)
1216 (syntax-violation #f "identifier out of context"
1217 e (wrap value w mod)))
1219 (syntax-violation #f "cannot define keyword at top level"
1220 e (wrap value w mod))))))
1221 (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
1226 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
1227 (lambda (type value e w s mod)
1228 (chi-expr type value e r w s mod)))))
1231 (lambda (type value e r w s mod)
1234 (build-lexical-reference 'value s e value))
1236 ;; apply transformer
1237 (value e r w s mod))
1239 (call-with-values (lambda () (value e r w))
1240 (lambda (e r w s mod)
1245 (build-lexical-reference 'fun (source-annotation id)
1246 (if (syntax-object? id)
1253 (build-global-reference (source-annotation (car e))
1254 (if (syntax-object? value)
1255 (syntax-object-expression value)
1257 (if (syntax-object? value)
1258 (syntax-object-module value)
1261 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1262 ((global) (build-global-reference s value mod))
1263 ((call) (chi-application (chi (car e) r w mod) e r w s mod))
1266 ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
1267 ((local-syntax-form)
1268 (chi-local-syntax value e r w s mod chi-sequence))
1271 ((_ (x ...) e1 e2 ...)
1272 (let ((when-list (chi-when-list e #'(x ...) w)))
1273 (if (memq 'eval when-list)
1274 (chi-sequence #'(e1 e2 ...) r w s mod)
1276 ((define-form define-syntax-form)
1277 (syntax-violation #f "definition in expression context"
1278 e (wrap value w mod)))
1280 (syntax-violation #f "reference to pattern variable outside syntax form"
1281 (source-wrap e w s mod)))
1282 ((displaced-lexical)
1283 (syntax-violation #f "reference to identifier outside its scope"
1284 (source-wrap e w s mod)))
1285 (else (syntax-violation #f "unexpected syntax"
1286 (source-wrap e w s mod))))))
1288 (define chi-application
1289 (lambda (x e r w s mod)
1292 (build-application s x
1293 (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
1295 ;; (What follows is my interpretation of what's going on here -- Andy)
1297 ;; A macro takes an expression, a tree, the leaves of which are identifiers
1298 ;; and datums. Identifiers are symbols along with a wrap and a module. For
1299 ;; efficiency, subtrees that share wraps and modules may be grouped as one
1302 ;; Going into the expansion, the expression is given an anti-mark, which
1303 ;; logically propagates to all leaves. Then, in the new expression returned
1304 ;; from the transfomer, if we see an expression with an anti-mark, we know it
1305 ;; pertains to the original expression; conversely, expressions without the
1306 ;; anti-mark are known to be introduced by the transformer.
1308 ;; OK, good until now. We know this algorithm does lexical scoping
1309 ;; appropriately because it's widely known in the literature, and psyntax is
1310 ;; widely used. But what about modules? Here we're on our own. What we do is
1311 ;; to mark the module of expressions produced by a macro as pertaining to the
1312 ;; module that was current when the macro was defined -- that is, free
1313 ;; identifiers introduced by a macro are scoped in the macro's module, not in
1314 ;; the expansion's module. Seems to work well.
1316 ;; The only wrinkle is when we want a macro to expand to code in another
1317 ;; module, as is the case for the r6rs `library' form -- the body expressions
1318 ;; should be scoped relative the the new module, the one defined by the macro.
1319 ;; For that, use `(@@ mod-name body)'.
1321 ;; Part of the macro output will be from the site of the macro use and part
1322 ;; from the macro definition. We allow source information from the macro use
1323 ;; to pass through, but we annotate the parts coming from the macro with the
1324 ;; source location information corresponding to the macro use. It would be
1325 ;; really nice if we could also annotate introduced expressions with the
1326 ;; locations corresponding to the macro definition, but that is not yet
1329 (lambda (p e r w s rib mod)
1330 ;; p := (procedure . module-name)
1331 (define rebuild-macro-output
1335 (cons (rebuild-macro-output (car x) m)
1336 (rebuild-macro-output (cdr x) m))
1339 (let ((w (syntax-object-wrap x)))
1340 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1341 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1342 ;; output is from original text
1344 (syntax-object-expression x)
1345 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1346 (syntax-object-module x))
1347 ;; output introduced by macro
1349 (decorate-source (syntax-object-expression x) s)
1350 (make-wrap (cons m ms)
1352 (cons rib (cons 'shift s))
1354 (syntax-object-module x))))))
1357 (let* ((n (vector-length x))
1358 (v (decorate-source (make-vector n) x)))
1359 (do ((i 0 (fx+ i 1)))
1362 (rebuild-macro-output (vector-ref x i) m)))))
1364 (syntax-violation #f "encountered raw symbol in macro output"
1365 (source-wrap e w (wrap-subst w) mod) x))
1366 (else (decorate-source x s)))))
1367 (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
1371 ;; In processing the forms of the body, we create a new, empty wrap.
1372 ;; This wrap is augmented (destructively) each time we discover that
1373 ;; the next form is a definition. This is done:
1375 ;; (1) to allow the first nondefinition form to be a call to
1376 ;; one of the defined ids even if the id previously denoted a
1377 ;; definition keyword or keyword for a macro expanding into a
1379 ;; (2) to prevent subsequent definition forms (but unfortunately
1380 ;; not earlier ones) and the first nondefinition form from
1381 ;; confusing one of the bound identifiers for an auxiliary
1383 ;; (3) so that we do not need to restart the expansion of the
1384 ;; first nondefinition form, which is problematic anyway
1385 ;; since it might be the first element of a begin that we
1386 ;; have just spliced into the body (meaning if we restarted,
1387 ;; we'd really need to restart with the begin or the macro
1388 ;; call that expanded into the begin, and we'd have to give
1389 ;; up allowing (begin <defn>+ <expr>+), which is itself
1390 ;; problematic since we don't know if a begin contains only
1391 ;; definitions until we've expanded it).
1393 ;; Before processing the body, we also create a new environment
1394 ;; containing a placeholder for the bindings we will add later and
1395 ;; associate this environment with each form. In processing a
1396 ;; let-syntax or letrec-syntax, the associated environment may be
1397 ;; augmented with local keyword bindings, so the environment may
1398 ;; be different for different forms in the body. Once we have
1399 ;; gathered up all of the definitions, we evaluate the transformer
1400 ;; expressions and splice into r at the placeholder the new variable
1401 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1402 ;; forms local to a portion or all of the body to shadow the
1403 ;; definition bindings.
1405 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1408 ;; outer-form is fully wrapped w/source
1409 (lambda (body outer-form r w mod)
1410 (let* ((r (cons '("placeholder" . (placeholder)) r))
1411 (ribcage (make-empty-ribcage))
1412 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1413 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1414 (ids '()) (labels '())
1415 (var-ids '()) (vars '()) (vals '()) (bindings '()))
1417 (syntax-violation #f "no expressions in body" outer-form)
1418 (let ((e (cdar body)) (er (caar body)))
1420 (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
1421 (lambda (type value e w s mod)
1424 (let ((id (wrap value w mod)) (label (gen-label)))
1425 (let ((var (gen-var id)))
1426 (extend-ribcage! ribcage id label)
1428 (cons id ids) (cons label labels)
1430 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1431 (cons (make-binding 'lexical var) bindings)))))
1432 ((define-syntax-form)
1433 (let ((id (wrap value w mod)) (label (gen-label)))
1434 (extend-ribcage! ribcage id label)
1436 (cons id ids) (cons label labels)
1438 (cons (make-binding 'macro (cons er (wrap e w mod)))
1443 (parse (let f ((forms #'(e1 ...)))
1446 (cons (cons er (wrap (car forms) w mod))
1448 ids labels var-ids vars vals bindings))))
1449 ((local-syntax-form)
1450 (chi-local-syntax value e er w s mod
1451 (lambda (forms er w s mod)
1452 (parse (let f ((forms forms))
1455 (cons (cons er (wrap (car forms) w mod))
1457 ids labels var-ids vars vals bindings))))
1458 (else ; found a non-definition
1460 (build-sequence no-source
1462 (chi (cdr x) (car x) empty-wrap mod))
1463 (cons (cons er (source-wrap e w s mod))
1466 (if (not (valid-bound-ids? ids))
1468 #f "invalid or duplicate identifier in definition"
1470 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1471 (if (not (null? bs))
1472 (let* ((b (car bs)))
1473 (if (eq? (car b) 'macro)
1474 (let* ((er (cadr b))
1476 (if (eq? er er-cache)
1478 (macros-only-env er))))
1480 (eval-local-transformer
1481 (chi (cddr b) r-cache empty-wrap mod)
1483 (loop (cdr bs) er r-cache))
1484 (loop (cdr bs) er-cache r-cache)))))
1485 (set-cdr! r (extend-env labels bindings (cdr r)))
1486 (build-letrec no-source #t
1487 (map syntax->datum var-ids)
1490 (chi (cdr x) (car x) empty-wrap mod))
1492 (build-sequence no-source
1494 (chi (cdr x) (car x) empty-wrap mod))
1495 (cons (cons er (source-wrap e w s mod))
1496 (cdr body)))))))))))))))))
1498 (define chi-local-syntax
1499 (lambda (rec? e r w s mod k)
1501 ((_ ((id val) ...) e1 e2 ...)
1502 (let ((ids #'(id ...)))
1503 (if (not (valid-bound-ids? ids))
1504 (syntax-violation #f "duplicate bound keyword" e)
1505 (let ((labels (gen-labels ids)))
1506 (let ((new-w (make-binding-wrap ids labels w)))
1510 (let ((w (if rec? new-w w))
1511 (trans-r (macros-only-env r)))
1513 (make-binding 'macro
1514 (eval-local-transformer
1515 (chi x trans-r w mod)
1522 (_ (syntax-violation #f "bad local syntax definition"
1523 (source-wrap e w s mod))))))
1525 (define eval-local-transformer
1526 (lambda (expanded mod)
1527 (let ((p (local-eval-hook expanded mod)))
1530 (syntax-violation #f "nonprocedure transformer" p)))))
1534 (build-void no-source)))
1538 (and (nonsymbol-id? x)
1539 (free-id=? x #'(... ...)))))
1541 (define lambda-formals
1543 (define (req args rreq)
1544 (syntax-case args ()
1546 (check (reverse rreq) #f))
1548 (req #'b (cons #'a rreq)))
1550 (check (reverse rreq) #'r))
1552 (syntax-violation 'lambda "invalid argument list" orig-args args))))
1553 (define (check req rest)
1555 ((distinct-bound-ids? (if rest (cons rest req) req))
1556 (values req #f rest #f))
1558 (syntax-violation 'lambda "duplicate identifier in argument list"
1560 (req orig-args '())))
1562 (define chi-simple-lambda
1563 (lambda (e r w s mod req rest meta body)
1564 (let* ((ids (if rest (append req (list rest)) req))
1565 (vars (map gen-var ids))
1566 (labels (gen-labels ids)))
1567 (build-simple-lambda
1569 (map syntax->datum req) (and rest (syntax->datum rest)) vars
1571 (chi-body body (source-wrap e w s mod)
1572 (extend-var-env labels vars r)
1573 (make-binding-wrap ids labels w)
1576 (define lambda*-formals
1578 (define (req args rreq)
1579 (syntax-case args ()
1581 (check (reverse rreq) '() #f '()))
1583 (req #'b (cons #'a rreq)))
1584 ((a . b) (eq? (syntax->datum #'a) #:optional)
1585 (opt #'b (reverse rreq) '()))
1586 ((a . b) (eq? (syntax->datum #'a) #:key)
1587 (key #'b (reverse rreq) '() '()))
1588 ((a b) (eq? (syntax->datum #'a) #:rest)
1589 (rest #'b (reverse rreq) '() '()))
1591 (rest #'r (reverse rreq) '() '()))
1593 (syntax-violation 'lambda* "invalid argument list" orig-args args))))
1594 (define (opt args req ropt)
1595 (syntax-case args ()
1597 (check req (reverse ropt) #f '()))
1599 (opt #'b req (cons #'(a #f) ropt)))
1600 (((a init) . b) (id? #'a)
1601 (opt #'b req (cons #'(a init) ropt)))
1602 ((a . b) (eq? (syntax->datum #'a) #:key)
1603 (key #'b req (reverse ropt) '()))
1604 ((a b) (eq? (syntax->datum #'a) #:rest)
1605 (rest #'b req (reverse ropt) '()))
1607 (rest #'r req (reverse ropt) '()))
1609 (syntax-violation 'lambda* "invalid optional argument list"
1611 (define (key args req opt rkey)
1612 (syntax-case args ()
1614 (check req opt #f (cons #f (reverse rkey))))
1616 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1617 (key #'b req opt (cons #'(k a #f) rkey))))
1618 (((a init) . b) (id? #'a)
1619 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1620 (key #'b req opt (cons #'(k a init) rkey))))
1621 (((a init k) . b) (and (id? #'a)
1622 (keyword? (syntax->datum #'k)))
1623 (key #'b req opt (cons #'(k a init) rkey)))
1624 ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
1625 (check req opt #f (cons #t (reverse rkey))))
1626 ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1627 (eq? (syntax->datum #'a) #:rest))
1628 (rest #'b req opt (cons #t (reverse rkey))))
1629 ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1631 (rest #'r req opt (cons #t (reverse rkey))))
1632 ((a b) (eq? (syntax->datum #'a) #:rest)
1633 (rest #'b req opt (cons #f (reverse rkey))))
1635 (rest #'r req opt (cons #f (reverse rkey))))
1637 (syntax-violation 'lambda* "invalid keyword argument list"
1639 (define (rest args req opt kw)
1640 (syntax-case args ()
1642 (check req opt #'r kw))
1644 (syntax-violation 'lambda* "invalid rest argument"
1646 (define (check req opt rest kw)
1648 ((distinct-bound-ids?
1649 (append req (map car opt) (if rest (list rest) '())
1650 (if (pair? kw) (map cadr (cdr kw)) '())))
1651 (values req opt rest kw))
1653 (syntax-violation 'lambda* "duplicate identifier in argument list"
1655 (req orig-args '())))
1657 (define chi-lambda-case
1658 (lambda (e r w s mod get-formals clauses)
1659 (define (expand-req req opt rest kw body)
1660 (let ((vars (map gen-var req))
1661 (labels (gen-labels req)))
1662 (let ((r* (extend-var-env labels vars r))
1663 (w* (make-binding-wrap req labels w)))
1664 (expand-opt (map syntax->datum req)
1665 opt rest kw body (reverse vars) r* w* '() '()))))
1666 (define (expand-opt req opt rest kw body vars r* w* out inits)
1669 (syntax-case (car opt) ()
1671 (let* ((v (gen-var #'id))
1672 (l (gen-labels (list v)))
1673 (r** (extend-var-env l (list v) r*))
1674 (w** (make-binding-wrap (list #'id) l w*)))
1675 (expand-opt req (cdr opt) rest kw body (cons v vars)
1676 r** w** (cons (syntax->datum #'id) out)
1677 (cons (chi #'i r* w* mod) inits))))))
1679 (let* ((v (gen-var rest))
1680 (l (gen-labels (list v)))
1681 (r* (extend-var-env l (list v) r*))
1682 (w* (make-binding-wrap (list rest) l w*)))
1683 (expand-kw req (if (pair? out) (reverse out) #f)
1684 (syntax->datum rest)
1685 (if (pair? kw) (cdr kw) kw)
1686 body (cons v vars) r* w*
1687 (if (pair? kw) (car kw) #f)
1690 (expand-kw req (if (pair? out) (reverse out) #f) #f
1691 (if (pair? kw) (cdr kw) kw)
1693 (if (pair? kw) (car kw) #f)
1695 (define (expand-kw req opt rest kw body vars r* w* aok out inits)
1698 (syntax-case (car kw) ()
1700 (let* ((v (gen-var #'id))
1701 (l (gen-labels (list v)))
1702 (r** (extend-var-env l (list v) r*))
1703 (w** (make-binding-wrap (list #'id) l w*)))
1704 (expand-kw req opt rest (cdr kw) body (cons v vars)
1706 (cons (list (syntax->datum #'k)
1707 (syntax->datum #'id)
1710 (cons (chi #'i r* w* mod) inits))))))
1712 (expand-body req opt rest
1713 (if (or aok (pair? out)) (cons aok (reverse out)) #f)
1714 body (reverse vars) r* w* (reverse inits) '()))))
1715 (define (expand-body req opt rest kw body vars r* w* inits meta)
1716 (syntax-case body ()
1717 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1718 (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1721 . ,(syntax->datum #'docstring))))))
1722 ((#((k . v) ...) e1 e2 ...)
1723 (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1724 (append meta (syntax->datum #'((k . v) ...)))))
1726 (values meta req opt rest kw inits vars
1727 (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
1730 (syntax-case clauses ()
1731 (() (values '() #f))
1732 (((args e1 e2 ...) (args* e1* e2* ...) ...)
1733 (call-with-values (lambda () (get-formals #'args))
1734 (lambda (req opt rest kw)
1735 (call-with-values (lambda ()
1736 (expand-req req opt rest kw #'(e1 e2 ...)))
1737 (lambda (meta req opt rest kw inits vars body)
1740 (chi-lambda-case e r w s mod get-formals
1741 #'((args* e1* e2* ...) ...)))
1742 (lambda (meta* else*)
1745 (build-lambda-case s req opt rest kw inits vars
1746 body else*))))))))))))
1750 ;;; strips syntax-objects down to top-wrap
1752 ;;; since only the head of a list is annotated by the reader, not each pair
1753 ;;; in the spine, we also check for pairs whose cars are annotated in case
1754 ;;; we've been passed the cdr of an annotated list
1763 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1765 (let ((a (f (car x))) (d (f (cdr x))))
1766 (if (and (eq? a (car x)) (eq? d (cdr x)))
1770 (let ((old (vector->list x)))
1771 (let ((new (map f old)))
1772 (if (and-map* eq? old new) x (list->vector new)))))
1775 ;;; lexical variables
1779 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1780 (build-lexical-var no-source id))))
1782 ;; appears to return a reversed list
1783 (define lambda-var-list
1785 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1787 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1788 ((id? vars) (cons (wrap vars w #f) ls))
1790 ((syntax-object? vars)
1791 (lvl (syntax-object-expression vars)
1793 (join-wraps w (syntax-object-wrap vars))))
1794 ; include anything else to be caught by subsequent error
1796 (else (cons vars ls))))))
1798 ;;; core transformers
1800 (global-extend 'local-syntax 'letrec-syntax #t)
1801 (global-extend 'local-syntax 'let-syntax #f)
1803 (global-extend 'core 'fluid-let-syntax
1804 (lambda (e r w s mod)
1806 ((_ ((var val) ...) e1 e2 ...)
1807 (valid-bound-ids? #'(var ...))
1808 (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
1811 (case (binding-type (lookup n r mod))
1812 ((displaced-lexical)
1813 (syntax-violation 'fluid-let-syntax
1814 "identifier out of context"
1816 (source-wrap id w s mod)))))
1821 (source-wrap e w s mod)
1824 (let ((trans-r (macros-only-env r)))
1826 (make-binding 'macro
1827 (eval-local-transformer (chi x trans-r w mod)
1833 (_ (syntax-violation 'fluid-let-syntax "bad syntax"
1834 (source-wrap e w s mod))))))
1836 (global-extend 'core 'quote
1837 (lambda (e r w s mod)
1839 ((_ e) (build-data s (strip #'e w)))
1840 (_ (syntax-violation 'quote "bad syntax"
1841 (source-wrap e w s mod))))))
1843 (global-extend 'core 'syntax
1846 (lambda (src e r maps ellipsis? mod)
1848 (let ((label (id-var-name e empty-wrap)))
1849 (let ((b (lookup label r mod)))
1850 (if (eq? (binding-type b) 'syntax)
1853 (let ((var.lev (binding-value b)))
1854 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1855 (lambda (var maps) (values `(ref ,var) maps)))
1857 (syntax-violation 'syntax "misplaced ellipsis" src)
1858 (values `(quote ,e) maps)))))
1862 (gen-syntax src #'e r maps (lambda (x) #f) mod))
1864 ; this could be about a dozen lines of code, except that we
1865 ; choose to handle #'(x ... ...) forms
1871 (gen-syntax src #'x r
1872 (cons '() maps) ellipsis? mod))
1874 (if (null? (car maps))
1875 (syntax-violation 'syntax "extra ellipsis"
1877 (values (gen-map x (car maps))
1885 (lambda () (k (cons '() maps)))
1887 (if (null? (car maps))
1888 (syntax-violation 'syntax "extra ellipsis" src)
1889 (values (gen-mappend x (car maps))
1891 (_ (call-with-values
1892 (lambda () (gen-syntax src y r maps ellipsis? mod))
1895 (lambda () (k maps))
1897 (values (gen-append x y) maps)))))))))
1900 (lambda () (gen-syntax src #'x r maps ellipsis? mod))
1903 (lambda () (gen-syntax src #'y r maps ellipsis? mod))
1904 (lambda (y maps) (values (gen-cons x y) maps))))))
1908 (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
1909 (lambda (e maps) (values (gen-vector e) maps))))
1910 (_ (values `(quote ,e) maps))))))
1913 (lambda (src var level maps)
1917 (syntax-violation 'syntax "missing ellipsis" src)
1919 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1920 (lambda (outer-var outer-maps)
1921 (let ((b (assq outer-var (car maps))))
1923 (values (cdr b) maps)
1924 (let ((inner-var (gen-var 'tmp)))
1926 (cons (cons (cons outer-var inner-var)
1928 outer-maps)))))))))))
1932 `(apply (primitive append) ,(gen-map e map-env))))
1936 (let ((formals (map cdr map-env))
1937 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1940 ; identity map equivalence:
1941 ; (map (lambda (x) x) y) == y
1944 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1946 ; eta map equivalence:
1947 ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1948 `(map (primitive ,(car e))
1949 ,@(map (let ((r (map cons formals actuals)))
1950 (lambda (x) (cdr (assq (cadr x) r))))
1952 (else `(map (lambda ,formals ,e) ,@actuals))))))
1958 (if (eq? (car x) 'quote)
1959 `(quote (,(cadr x) . ,(cadr y)))
1960 (if (eq? (cadr y) '())
1963 ((list) `(list ,x ,@(cdr y)))
1964 (else `(cons ,x ,y)))))
1968 (if (equal? y '(quote ()))
1975 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1976 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1977 (else `(list->vector ,x)))))
1983 ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
1984 ((primitive) (build-primref no-source (cadr x)))
1985 ((quote) (build-data no-source (cadr x)))
1987 (if (list? (cadr x))
1988 (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
1989 (error "how did we get here" x)))
1990 (else (build-application no-source
1991 (build-primref no-source (car x))
1992 (map regen (cdr x)))))))
1994 (lambda (e r w s mod)
1995 (let ((e (source-wrap e w s mod)))
1999 (lambda () (gen-syntax e #'x r '() ellipsis? mod))
2000 (lambda (e maps) (regen e))))
2001 (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
2003 (global-extend 'core 'lambda
2004 (lambda (e r w s mod)
2007 (call-with-values (lambda () (lambda-formals #'args))
2008 (lambda (req opt rest kw)
2009 (let lp ((body #'(e1 e2 ...)) (meta '()))
2010 (syntax-case body ()
2011 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
2015 . ,(syntax->datum #'docstring))))))
2016 ((#((k . v) ...) e1 e2 ...)
2018 (append meta (syntax->datum #'((k . v) ...)))))
2019 (_ (chi-simple-lambda e r w s mod req rest meta body)))))))
2020 (_ (syntax-violation 'lambda "bad lambda" e)))))
2022 (global-extend 'core 'lambda*
2023 (lambda (e r w s mod)
2028 (chi-lambda-case e r w s mod
2029 lambda*-formals #'((args e1 e2 ...))))
2030 (lambda (meta lcase)
2031 (build-case-lambda s meta lcase))))
2032 (_ (syntax-violation 'lambda "bad lambda*" e)))))
2034 (global-extend 'core 'case-lambda
2035 (lambda (e r w s mod)
2037 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
2040 (chi-lambda-case e r w s mod
2042 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2043 (lambda (meta lcase)
2044 (build-case-lambda s meta lcase))))
2045 (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
2047 (global-extend 'core 'case-lambda*
2048 (lambda (e r w s mod)
2050 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
2053 (chi-lambda-case e r w s mod
2055 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2056 (lambda (meta lcase)
2057 (build-case-lambda s meta lcase))))
2058 (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
2060 (global-extend 'core 'let
2062 (define (chi-let e r w s mod constructor ids vals exps)
2063 (if (not (valid-bound-ids? ids))
2064 (syntax-violation 'let "duplicate bound variable" e)
2065 (let ((labels (gen-labels ids))
2066 (new-vars (map gen-var ids)))
2067 (let ((nw (make-binding-wrap ids labels w))
2068 (nr (extend-var-env labels new-vars r)))
2070 (map syntax->datum ids)
2072 (map (lambda (x) (chi x r w mod)) vals)
2073 (chi-body exps (source-wrap e nw s mod)
2075 (lambda (e r w s mod)
2077 ((_ ((id val) ...) e1 e2 ...)
2078 (and-map id? #'(id ...))
2079 (chi-let e r w s mod
2084 ((_ f ((id val) ...) e1 e2 ...)
2085 (and (id? #'f) (and-map id? #'(id ...)))
2086 (chi-let e r w s mod
2091 (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
2094 (global-extend 'core 'letrec
2095 (lambda (e r w s mod)
2097 ((_ ((id val) ...) e1 e2 ...)
2098 (and-map id? #'(id ...))
2099 (let ((ids #'(id ...)))
2100 (if (not (valid-bound-ids? ids))
2101 (syntax-violation 'letrec "duplicate bound variable" e)
2102 (let ((labels (gen-labels ids))
2103 (new-vars (map gen-var ids)))
2104 (let ((w (make-binding-wrap ids labels w))
2105 (r (extend-var-env labels new-vars r)))
2107 (map syntax->datum ids)
2109 (map (lambda (x) (chi x r w mod)) #'(val ...))
2110 (chi-body #'(e1 e2 ...)
2111 (source-wrap e w s mod) r w mod)))))))
2112 (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
2115 (global-extend 'core 'letrec*
2116 (lambda (e r w s mod)
2118 ((_ ((id val) ...) e1 e2 ...)
2119 (and-map id? #'(id ...))
2120 (let ((ids #'(id ...)))
2121 (if (not (valid-bound-ids? ids))
2122 (syntax-violation 'letrec* "duplicate bound variable" e)
2123 (let ((labels (gen-labels ids))
2124 (new-vars (map gen-var ids)))
2125 (let ((w (make-binding-wrap ids labels w))
2126 (r (extend-var-env labels new-vars r)))
2128 (map syntax->datum ids)
2130 (map (lambda (x) (chi x r w mod)) #'(val ...))
2131 (chi-body #'(e1 e2 ...)
2132 (source-wrap e w s mod) r w mod)))))))
2133 (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
2136 (global-extend 'core 'set!
2137 (lambda (e r w s mod)
2141 (let ((val (chi #'val r w mod))
2142 (n (id-var-name #'id w)))
2143 (let ((b (lookup n r mod)))
2144 (case (binding-type b)
2146 (build-lexical-assignment s
2147 (syntax->datum #'id)
2150 ((global) (build-global-assignment s n val mod))
2151 ((displaced-lexical)
2152 (syntax-violation 'set! "identifier out of context"
2154 (else (syntax-violation 'set! "bad set!"
2155 (source-wrap e w s mod)))))))
2156 ((_ (head tail ...) val)
2158 (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
2159 (lambda (type value ee ww ss modmod)
2162 (let ((val (chi #'val r w mod)))
2163 (call-with-values (lambda () (value #'(head tail ...) r w))
2164 (lambda (e r w s* mod)
2167 (build-global-assignment s (syntax->datum #'e)
2170 (build-application s
2171 (chi #'(setter head) r w mod)
2172 (map (lambda (e) (chi e r w mod))
2173 #'(tail ... val))))))))
2174 (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
2176 (global-extend 'module-ref '@
2180 (and (and-map id? #'(mod ...)) (id? #'id))
2181 (values (syntax->datum #'id) r w #f
2183 #'(public mod ...)))))))
2185 (global-extend 'module-ref '@@
2190 (cons (remodulate (car x) mod)
2191 (remodulate (cdr x) mod)))
2194 (remodulate (syntax-object-expression x) mod)
2195 (syntax-object-wrap x)
2196 ;; hither the remodulation
2199 (let* ((n (vector-length x)) (v (make-vector n)))
2200 (do ((i 0 (fx+ i 1)))
2202 (vector-set! v i (remodulate (vector-ref x i) mod)))))
2206 (and-map id? #'(mod ...))
2207 (let ((mod (syntax->datum #'(private mod ...))))
2208 (values (remodulate #'exp mod)
2209 r w (source-annotation #'exp)
2212 (global-extend 'core 'if
2213 (lambda (e r w s mod)
2218 (chi #'test r w mod)
2219 (chi #'then r w mod)
2220 (build-void no-source)))
2224 (chi #'test r w mod)
2225 (chi #'then r w mod)
2226 (chi #'else r w mod))))))
2228 (global-extend 'core 'with-fluids
2229 (lambda (e r w s mod)
2231 ((_ ((fluid val) ...) b b* ...)
2234 (map (lambda (x) (chi x r w mod)) #'(fluid ...))
2235 (map (lambda (x) (chi x r w mod)) #'(val ...))
2236 (chi-body #'(b b* ...)
2237 (source-wrap e w s mod) r w mod))))))
2239 (global-extend 'begin 'begin '())
2241 (global-extend 'define 'define '())
2243 (global-extend 'define-syntax 'define-syntax '())
2245 (global-extend 'eval-when 'eval-when '())
2247 (global-extend 'core 'syntax-case
2249 (define convert-pattern
2250 ; accepts pattern & keys
2251 ; returns $sc-dispatch pattern & ids
2252 (lambda (pattern keys)
2258 (lambda () (cvt* (cdr p*) n ids))
2261 (lambda () (cvt (car p*) n ids))
2263 (values (cons x y) ids))))))))
2267 (if (bound-id-member? p keys)
2268 (values (vector 'free-id p) ids)
2269 (values 'any (cons (cons p n) ids)))
2272 (ellipsis? (syntax dots))
2274 (lambda () (cvt (syntax x) (fx+ n 1) ids))
2276 (values (if (eq? p 'any) 'each-any (vector 'each p))
2279 (ellipsis? (syntax dots))
2281 (lambda () (cvt* (syntax (ys ...)) n ids))
2284 (lambda () (cvt (syntax x) (+ n 1) ids))
2286 (values `#(each+ ,x ,(reverse ys) ()) ids))))))
2289 (lambda () (cvt (syntax y) n ids))
2292 (lambda () (cvt (syntax x) n ids))
2294 (values (cons x y) ids))))))
2295 (() (values '() ids))
2298 (lambda () (cvt (syntax (x ...)) n ids))
2299 (lambda (p ids) (values (vector 'vector p) ids))))
2300 (x (values (vector 'atom (strip p empty-wrap)) ids))))))
2301 (cvt pattern 0 '())))
2303 (define build-dispatch-call
2304 (lambda (pvars exp y r mod)
2305 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2306 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2307 (build-application no-source
2308 (build-primref no-source 'apply)
2309 (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
2313 (map (lambda (var level)
2314 (make-binding 'syntax `(,var . ,level)))
2318 (make-binding-wrap ids labels empty-wrap)
2323 (lambda (x keys clauses r pat fender exp mod)
2325 (lambda () (convert-pattern pat keys))
2328 ((not (distinct-bound-ids? (map car pvars)))
2329 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2330 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2331 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2333 (let ((y (gen-var 'tmp)))
2334 ; fat finger binding and references to temp variable y
2335 (build-application no-source
2336 (build-simple-lambda no-source (list 'tmp) #f (list y) '()
2337 (let ((y (build-lexical-reference 'value no-source
2339 (build-conditional no-source
2340 (syntax-case fender ()
2342 (_ (build-conditional no-source
2344 (build-dispatch-call pvars fender y r mod)
2345 (build-data no-source #f))))
2346 (build-dispatch-call pvars exp y r mod)
2347 (gen-syntax-case x keys clauses r mod))))
2348 (list (if (eq? p 'any)
2349 (build-application no-source
2350 (build-primref no-source 'list)
2352 (build-application no-source
2353 (build-primref no-source '$sc-dispatch)
2354 (list x (build-data no-source p)))))))))))))
2356 (define gen-syntax-case
2357 (lambda (x keys clauses r mod)
2359 (build-application no-source
2360 (build-primref no-source 'syntax-violation)
2361 (list (build-data no-source #f)
2362 (build-data no-source
2363 "source expression failed to match any pattern")
2365 (syntax-case (car clauses) ()
2367 (if (and (id? #'pat)
2368 (and-map (lambda (x) (not (free-id=? #'pat x)))
2369 (cons #'(... ...) keys)))
2370 (let ((labels (list (gen-label)))
2371 (var (gen-var #'pat)))
2372 (build-application no-source
2373 (build-simple-lambda
2374 no-source (list (syntax->datum #'pat)) #f (list var)
2378 (list (make-binding 'syntax `(,var . 0)))
2380 (make-binding-wrap #'(pat)
2384 (gen-clause x keys (cdr clauses) r
2385 #'pat #t #'exp mod)))
2387 (gen-clause x keys (cdr clauses) r
2388 #'pat #'fender #'exp mod))
2389 (_ (syntax-violation 'syntax-case "invalid clause"
2392 (lambda (e r w s mod)
2393 (let ((e (source-wrap e w s mod)))
2395 ((_ val (key ...) m ...)
2396 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
2398 (let ((x (gen-var 'tmp)))
2399 ; fat finger binding and references to temp variable x
2400 (build-application s
2401 (build-simple-lambda no-source (list 'tmp) #f (list x) '()
2402 (gen-syntax-case (build-lexical-reference 'value no-source
2404 #'(key ...) #'(m ...)
2407 (list (chi #'val r empty-wrap mod))))
2408 (syntax-violation 'syntax-case "invalid literals list" e))))))))
2410 ;;; The portable macroexpand seeds chi-top's mode m with 'e (for
2411 ;;; evaluating) and esew (which stands for "eval syntax expanders
2412 ;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
2413 ;;; if we are compiling a file, and esew is set to
2414 ;;; (eval-syntactic-expanders-when), which defaults to the list
2415 ;;; '(compile load eval). This means that, by default, top-level
2416 ;;; syntactic definitions are evaluated immediately after they are
2417 ;;; expanded, and the expanded definitions are also residualized into
2418 ;;; the object file if we are compiling a file.
2420 (lambda* (x #:optional (m 'e) (esew '(eval)))
2421 (chi-top x null-env top-wrap m esew
2422 (cons 'hygiene (module-name (current-module))))))
2430 (make-syntax-object datum (syntax-object-wrap id)
2431 (syntax-object-module id))))
2434 ; accepts any object, since syntax objects may consist partially
2435 ; or entirely of unwrapped, nonsymbolic data
2437 (strip x empty-wrap)))
2440 (lambda (x) (source-annotation x)))
2442 (set! generate-temporaries
2444 (arg-check list? ls 'generate-temporaries)
2445 (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
2447 (set! free-identifier=?
2449 (arg-check nonsymbol-id? x 'free-identifier=?)
2450 (arg-check nonsymbol-id? y 'free-identifier=?)
2453 (set! bound-identifier=?
2455 (arg-check nonsymbol-id? x 'bound-identifier=?)
2456 (arg-check nonsymbol-id? y 'bound-identifier=?)
2459 (set! syntax-violation
2460 (lambda (who message form . subform)
2461 (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2462 who 'syntax-violation)
2463 (arg-check string? message 'syntax-violation)
2464 (scm-error 'syntax-error 'macroexpand
2468 (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
2469 (let ((tail (cons message
2470 (map (lambda (x) (strip x empty-wrap))
2471 (append subform (list form))))))
2472 (if who (cons who tail) tail))
2475 ;;; $sc-dispatch expects an expression and a pattern. If the expression
2476 ;;; matches the pattern a list of the matching expressions for each
2477 ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2478 ;;; not work on r4rs implementations that violate the ieee requirement
2479 ;;; that #f and () be distinct.)
2481 ;;; The expression is matched with the pattern as follows:
2483 ;;; pattern: matches:
2486 ;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2488 ;;; #(free-id <key>) <key> with free-identifier=?
2489 ;;; #(each <pattern>) (<pattern>*)
2490 ;;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
2491 ;;; #(vector <pattern>) (list->vector <pattern>)
2492 ;;; #(atom <object>) <object> with "equal?"
2494 ;;; Vector cops out to pair under assumption that vectors are rare. If
2495 ;;; not, should convert to:
2496 ;;; #(vector <pattern>*) #(<pattern>*)
2504 (let ((first (match (car e) p w '() mod)))
2506 (let ((rest (match-each (cdr e) p w mod)))
2507 (and rest (cons first rest))))))
2510 (match-each (syntax-object-expression e)
2512 (join-wraps w (syntax-object-wrap e))
2513 (syntax-object-module e)))
2517 (lambda (e x-pat y-pat z-pat w r mod)
2518 (let f ((e e) (w w))
2521 (call-with-values (lambda () (f (cdr e) w))
2522 (lambda (xr* y-pat r)
2525 (let ((xr (match (car e) x-pat w '() mod)))
2527 (values (cons xr xr*) y-pat r)
2532 (match (car e) (car y-pat) w r mod)))
2533 (values #f #f #f)))))
2535 (f (syntax-object-expression e) (join-wraps w e)))
2537 (values '() y-pat (match e z-pat w r mod)))))))
2539 (define match-each-any
2543 (let ((l (match-each-any (cdr e) w mod)))
2544 (and l (cons (wrap (car e) w mod) l))))
2547 (match-each-any (syntax-object-expression e)
2548 (join-wraps w (syntax-object-wrap e))
2556 ((eq? p 'any) (cons '() r))
2557 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2558 ((eq? p 'each-any) (cons '() r))
2560 (case (vector-ref p 0)
2561 ((each) (match-empty (vector-ref p 1) r))
2562 ((each+) (match-empty (vector-ref p 1)
2564 (reverse (vector-ref p 2))
2565 (match-empty (vector-ref p 3) r))))
2567 ((vector) (match-empty (vector-ref p 1) r)))))))
2571 (if (null? (car r*))
2573 (cons (map car r*) (combine (map cdr r*) r)))))
2576 (lambda (e p w r mod)
2578 ((null? p) (and (null? e) r))
2580 (and (pair? e) (match (car e) (car p) w
2581 (match (cdr e) (cdr p) w r mod)
2584 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2586 (case (vector-ref p 0)
2589 (match-empty (vector-ref p 1) r)
2590 (let ((l (match-each e (vector-ref p 1) w mod)))
2592 (let collect ((l l))
2595 (cons (map car l) (collect (map cdr l)))))))))
2599 (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
2600 (lambda (xr* y-pat r)
2604 (match-empty (vector-ref p 1) r)
2605 (combine xr* r))))))
2606 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2607 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2610 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2613 (lambda (e p w r mod)
2616 ((eq? p 'any) (cons (wrap e w mod) r))
2619 (syntax-object-expression e)
2621 (join-wraps w (syntax-object-wrap e))
2623 (syntax-object-module e)))
2624 (else (match* e p w r mod)))))
2629 ((eq? p 'any) (list e))
2631 (match* (syntax-object-expression e)
2632 p (syntax-object-wrap e) '() (syntax-object-module e)))
2633 (else (match* e p empty-wrap '() #f)))))
2638 (define-syntax with-syntax
2642 #'(begin e1 e2 ...))
2643 ((_ ((out in)) e1 e2 ...)
2644 #'(syntax-case in () (out (begin e1 e2 ...))))
2645 ((_ ((out in) ...) e1 e2 ...)
2646 #'(syntax-case (list in ...) ()
2647 ((out ...) (begin e1 e2 ...)))))))
2649 (define-syntax syntax-rules
2652 ((_ (k ...) ((keyword . pattern) template) ...)
2654 ;; embed patterns as procedure metadata
2655 #((macro-type . syntax-rules)
2656 (patterns pattern ...))
2657 (syntax-case x (k ...)
2658 ((dummy . pattern) #'template)
2664 ((let* ((x v) ...) e1 e2 ...)
2665 (and-map identifier? #'(x ...))
2666 (let f ((bindings #'((x v) ...)))
2667 (if (null? bindings)
2668 #'(let () e1 e2 ...)
2669 (with-syntax ((body (f (cdr bindings)))
2670 (binding (car bindings)))
2671 #'(let (binding) body))))))))
2675 (syntax-case orig-x ()
2676 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2677 (with-syntax (((step ...)
2682 (_ (syntax-violation
2683 'do "bad step expression"
2687 (syntax-case #'(e1 ...) ()
2688 (() #'(let doloop ((var init) ...)
2690 (begin c ... (doloop step ...)))))
2692 #'(let doloop ((var init) ...)
2695 (begin c ... (doloop step ...)))))))))))
2697 (define-syntax quasiquote
2701 (with-syntax ((x x) (y y))
2702 (syntax-case #'y (quote list)
2704 (syntax-case #'x (quote)
2705 ((quote dx) #'(quote (dx . dy)))
2709 ((list . stuff) #'(list x . stuff))
2710 (else #'(cons x y))))))
2713 (with-syntax ((x x) (y y))
2714 (syntax-case #'y (quote)
2716 (_ #'(append x y))))))
2719 (with-syntax ((x x))
2720 (syntax-case #'x (quote list)
2721 ((quote (x ...)) #'(quote #(x ...)))
2722 ((list x ...) #'(vector x ...))
2723 (_ #'(list->vector x))))))
2726 (syntax-case p (unquote unquote-splicing quasiquote)
2730 (quasicons #'(quote unquote)
2731 (quasi #'(p) (- lev 1)))))
2734 (syntax-violation 'unquote
2735 "unquote takes exactly one argument"
2736 p #'(unquote . args)))
2737 (((unquote-splicing p) . q)
2739 (quasiappend #'p (quasi #'q lev))
2740 (quasicons (quasicons #'(quote unquote-splicing)
2741 (quasi #'(p) (- lev 1)))
2743 (((unquote-splicing . args) . q)
2745 (syntax-violation 'unquote-splicing
2746 "unquote-splicing takes exactly one argument"
2747 p #'(unquote-splicing . args)))
2749 (quasicons #'(quote quasiquote)
2750 (quasi #'(p) (+ lev 1))))
2752 (quasicons (quasi #'p lev) (quasi #'q lev)))
2753 (#(x ...) (quasivector (quasi #'(x ...) lev)))
2757 ((_ e) (quasi #'e 0))))))
2759 (define-syntax include
2763 (let ((p (open-input-file fn)))
2764 (let f ((x (read p))
2768 (close-input-port p)
2771 (cons (datum->syntax k x) result)))))))
2774 (let ((fn (syntax->datum #'filename)))
2775 (with-syntax (((exp ...) (read-file fn #'filename)))
2776 #'(begin exp ...)))))))
2778 (define-syntax include-from-path
2782 (let ((fn (syntax->datum #'filename)))
2783 (with-syntax ((fn (datum->syntax
2785 (or (%search-load-path fn)
2786 (syntax-violation 'include-from-path
2787 "file not found in path"
2789 #'(include fn)))))))
2791 (define-syntax unquote
2795 (syntax-violation 'unquote
2796 "expression not valid outside of quasiquote"
2799 (define-syntax unquote-splicing
2803 (syntax-violation 'unquote-splicing
2804 "expression not valid outside of quasiquote"
2812 ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
2814 (syntax-case clause (else)
2815 ((else e1 e2 ...) #'(begin e1 e2 ...))
2816 (((k ...) e1 e2 ...)
2817 #'(if (memv t '(k ...)) (begin e1 e2 ...)))
2818 (_ (syntax-violation 'case "bad clause" x clause)))
2819 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2820 (syntax-case clause (else)
2821 (((k ...) e1 e2 ...)
2822 #'(if (memv t '(k ...))
2825 (_ (syntax-violation 'case "bad clause" x
2827 #'(let ((t e)) body))))))
2829 (define-syntax identifier-syntax
2834 #((macro-type . identifier-syntax))
2840 #'(e x (... ...)))))))))
2842 (define-syntax define*
2845 ((_ (id . args) b0 b1 ...)
2846 #'(define id (lambda* args b0 b1 ...)))
2847 ((_ id val) (identifier? #'x)
2848 #'(define id val)))))