3 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
4 ;;;; 2012, 2013 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
22 ;;; Portable implementation of syntax-case
23 ;;; Originally extracted from Chez Scheme Version 5.9f
24 ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
26 ;;; Copyright (c) 1992-1997 Cadence Research Systems
27 ;;; Permission to copy this software, in whole or in part, to use this
28 ;;; software for any lawful purpose, and to redistribute this software
29 ;;; is granted subject to the restriction that all copies made of this
30 ;;; software must include this copyright notice in full. This software
31 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
32 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
33 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
34 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
35 ;;; NATURE WHATSOEVER.
37 ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
38 ;;; to the ChangeLog distributed in the same directory as this file:
39 ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
40 ;;; 2000-09-12, 2001-03-08
42 ;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
43 ;;; revision control logs corresponding to this file: 2009, 2010.
45 ;;; Modified by Mark H Weaver <mhw@netris.org> according to the Git
46 ;;; revision control logs corresponding to this file: 2012, 2013.
49 ;;; This code is based on "Syntax Abstraction in Scheme"
50 ;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
51 ;;; Lisp and Symbolic Computation 5:4, 295-326, 1992.
52 ;;; <http://www.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf>
55 ;;; This file defines the syntax-case expander, macroexpand, and a set
56 ;;; of associated syntactic forms and procedures. Of these, the
57 ;;; following are documented in The Scheme Programming Language,
58 ;;; Fourth Edition (R. Kent Dybvig, MIT Press, 2009), and in the
61 ;;; bound-identifier=?
64 ;;; syntax-parameterize
66 ;;; generate-temporaries
77 ;;; Additionally, the expander provides definitions for a number of core
78 ;;; Scheme syntactic bindings, such as `let', `lambda', and the like.
80 ;;; The remaining exports are listed below:
82 ;;; (macroexpand datum)
83 ;;; if datum represents a valid expression, macroexpand returns an
84 ;;; expanded version of datum in a core language that includes no
85 ;;; syntactic abstractions. The core language includes begin,
86 ;;; define, if, lambda, letrec, quote, and set!.
87 ;;; (eval-when situations expr ...)
88 ;;; conditionally evaluates expr ... at compile-time or run-time
89 ;;; depending upon situations (see the Chez Scheme System Manual,
90 ;;; Revision 3, for a complete description)
91 ;;; (syntax-violation who message form [subform])
92 ;;; used to report errors found during expansion
93 ;;; ($sc-dispatch e p)
94 ;;; used by expanded code to handle syntax-case matching
96 ;;; This file is shipped along with an expanded version of itself,
97 ;;; psyntax-pp.scm, which is loaded when psyntax.scm has not yet been
98 ;;; compiled. In this way, psyntax bootstraps off of an expanded
99 ;;; version of itself.
101 ;;; This implementation of the expander sometimes uses syntactic
102 ;;; abstractions when procedural abstractions would suffice. For
103 ;;; example, we define top-wrap and top-marked? as
105 ;;; (define-syntax top-wrap (identifier-syntax '((top))))
106 ;;; (define-syntax top-marked?
108 ;;; ((_ w) (memq 'top (wrap-marks w)))))
112 ;;; (define top-wrap '((top)))
113 ;;; (define top-marked?
114 ;;; (lambda (w) (memq 'top (wrap-marks w))))
116 ;;; On the other hand, we don't do this consistently; we define
117 ;;; make-wrap, wrap-marks, and wrap-subst simply as
119 ;;; (define make-wrap cons)
120 ;;; (define wrap-marks car)
121 ;;; (define wrap-subst cdr)
123 ;;; In Chez Scheme, the syntactic and procedural forms of these
124 ;;; abstractions are equivalent, since the optimizer consistently
125 ;;; integrates constants and small procedures. This will be true of
126 ;;; Guile as well, once we implement a proper inliner.
129 ;;; Implementation notes:
131 ;;; Objects with no standard print syntax, including objects containing
132 ;;; cycles and syntax object, are allowed in quoted data as long as they
133 ;;; are contained within a syntax form or produced by datum->syntax.
134 ;;; Such objects are never copied.
136 ;;; All identifiers that don't have macro definitions and are not bound
137 ;;; lexically are assumed to be global variables.
139 ;;; Top-level definitions of macro-introduced identifiers are allowed.
140 ;;; This may not be appropriate for implementations in which the
141 ;;; model is that bindings are created by definitions, as opposed to
142 ;;; one in which initial values are assigned by definitions.
144 ;;; Identifiers and syntax objects are implemented as vectors for
145 ;;; portability. As a result, it is possible to "forge" syntax objects.
147 ;;; The implementation of generate-temporaries assumes that it is
148 ;;; possible to generate globally unique symbols (gensyms).
150 ;;; The source location associated with incoming expressions is tracked
151 ;;; via the source-properties mechanism, a weak map from expression to
152 ;;; source information. At times the source is separated from the
153 ;;; expression; see the note below about "efficiency and confusion".
158 ;;; When changing syntax-object representations, it is necessary to support
159 ;;; both old and new syntax-object representations in id-var-name. It
160 ;;; should be sufficient to recognize old representations and treat
161 ;;; them as not lexically bound.
166 (set-current-module (resolve-module '(guile))))
169 (define-syntax define-expansion-constructors
173 (let lp ((n 0) (out '()))
174 (if (< n (vector-length %expanded-vtables))
176 (let* ((vtable (vector-ref %expanded-vtables n))
177 (stem (struct-ref vtable (+ vtable-offset-user 0)))
178 (fields (struct-ref vtable (+ vtable-offset-user 2)))
179 (sfields (map (lambda (f) (datum->syntax x f)) fields))
180 (ctor (datum->syntax x (symbol-append 'make- stem))))
181 (cons #`(define (#,ctor #,@sfields)
182 (make-struct (vector-ref %expanded-vtables #,n) 0
185 #`(begin #,@(reverse out))))))))
187 (define-syntax define-expansion-accessors
192 (let ((vtable (vector-ref %expanded-vtables n))
193 (stem (syntax->datum #'stem)))
194 (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
196 (define (#,(datum->syntax x (symbol-append stem '?)) x)
198 (eq? (struct-vtable x)
199 (vector-ref %expanded-vtables #,n))))
202 (let ((get (datum->syntax x (symbol-append stem '- f)))
203 (set (datum->syntax x (symbol-append 'set- stem '- f '!)))
204 (idx (list-index (struct-ref vtable
205 (+ vtable-offset-user 2))
209 (struct-ref x #,idx))
211 (struct-set! x #,idx v)))))
212 (syntax->datum #'(field ...))))
215 (define-syntax define-structure
217 (define construct-name
218 (lambda (template-identifier . args)
226 (symbol->string (syntax->datum x))))
230 (and-map identifier? #'(name id1 ...))
232 ((constructor (construct-name #'name "make-" #'name))
233 (predicate (construct-name #'name #'name "?"))
235 (map (lambda (x) (construct-name x #'name "-" x))
239 (construct-name x "set-" #'name "-" x "!"))
242 (+ (length #'(id1 ...)) 1))
244 (let f ((i 1) (ids #'(id1 ...)))
247 (cons i (f (+ i 1) (cdr ids)))))))
251 (vector 'name id1 ... )))
255 (= (vector-length x) structure-length)
256 (eq? (vector-ref x 0) 'name))))
259 (vector-ref x index)))
263 (vector-set! x index update)))
267 (define-expansion-constructors)
268 (define-expansion-accessors lambda meta)
270 ;; hooks to nonportable run-time helpers
272 (define-syntax fx+ (identifier-syntax +))
273 (define-syntax fx- (identifier-syntax -))
274 (define-syntax fx= (identifier-syntax =))
275 (define-syntax fx< (identifier-syntax <))
277 (define top-level-eval-hook
281 (define local-eval-hook
285 ;; Capture syntax-session-id before we shove it off into a module.
287 (let ((v (module-variable (current-module) 'syntax-session-id)))
289 ((variable-ref v)))))
291 (define put-global-definition-hook
292 (lambda (symbol type val)
293 (module-define! (current-module)
295 (make-syntax-transformer symbol type val))))
297 (define get-global-definition-hook
298 (lambda (symbol module)
299 (if (and (not module) (current-module))
300 (warn "module system is booted, we should have a module" symbol))
301 (let ((v (module-variable (if module
302 (resolve-module (cdr module))
305 (and v (variable-bound? v)
306 (let ((val (variable-ref v)))
307 (and (macro? val) (macro-type val)
308 (cons (macro-type val)
309 (macro-binding val)))))))))
312 (define (decorate-source e s)
313 (if (and s (supports-source-properties? e))
314 (set-source-properties! e s))
317 (define (maybe-name-value! name val)
319 (let ((meta (lambda-meta val)))
320 (if (not (assq 'name meta))
321 (set-lambda-meta! val (acons 'name name meta))))))
323 ;; output constructors
328 (define build-application
329 (lambda (source fun-exp arg-exps)
330 (make-application source fun-exp arg-exps)))
332 (define build-conditional
333 (lambda (source test-exp then-exp else-exp)
334 (make-conditional source test-exp then-exp else-exp)))
337 (lambda (source fluids vals body)
338 (make-dynlet source fluids vals body)))
340 (define build-lexical-reference
341 (lambda (type source name var)
342 (make-lexical-ref source name var)))
344 (define build-lexical-assignment
345 (lambda (source name var exp)
346 (maybe-name-value! name exp)
347 (make-lexical-set source name var exp)))
349 (define (analyze-variable mod var modref-cont bare-cont)
352 (let ((kind (car mod))
355 ((public) (modref-cont mod var #t))
356 ((private) (if (not (equal? mod (module-name (current-module))))
357 (modref-cont mod var #f)
359 ((bare) (bare-cont var))
360 ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
361 (module-variable (resolve-module mod) var))
362 (modref-cont mod var #f)
364 (else (syntax-violation #f "bad module kind" var mod))))))
366 (define build-global-reference
367 (lambda (source var mod)
370 (lambda (mod var public?)
371 (make-module-ref source mod var public?))
373 (make-toplevel-ref source var)))))
375 (define build-global-assignment
376 (lambda (source var exp mod)
377 (maybe-name-value! var exp)
380 (lambda (mod var public?)
381 (make-module-set source mod var public? exp))
383 (make-toplevel-set source var exp)))))
385 (define build-global-definition
386 (lambda (source var exp)
387 (maybe-name-value! var exp)
388 (make-toplevel-define source var exp)))
390 (define build-simple-lambda
391 (lambda (src req rest vars meta exp)
394 ;; hah, a case in which kwargs would be nice.
396 ;; src req opt rest kw inits vars body else
397 src req #f rest #f '() vars exp #f))))
399 (define build-case-lambda
400 (lambda (src meta body)
401 (make-lambda src meta body)))
403 (define build-lambda-case
405 ;; opt := (name ...) | #f
407 ;; kw := (allow-other-keys? (keyword name var) ...) | #f
410 ;; vars map to named arguments in the following order:
411 ;; required, optional (positional), rest, keyword.
412 ;; the body of a lambda: anything, already expanded
413 ;; else: lambda-case | #f
414 (lambda (src req opt rest kw inits vars body else-case)
415 (make-lambda-case src req opt rest kw inits vars body else-case)))
417 (define build-primref
419 (if (equal? (module-name (current-module)) '(guile))
420 (make-toplevel-ref src name)
421 (make-module-ref src '(guile) name #f))))
423 (define (build-data src exp)
424 (make-const src exp))
426 (define build-sequence
428 (if (null? (cdr exps))
430 (make-sequence src exps))))
433 (lambda (src ids vars val-exps body-exp)
434 (for-each maybe-name-value! ids val-exps)
437 (make-let src ids vars val-exps body-exp))))
439 (define build-named-let
440 (lambda (src ids vars val-exps body-exp)
445 (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
446 (maybe-name-value! f-name proc)
447 (for-each maybe-name-value! ids val-exps)
450 (list f-name) (list f) (list proc)
451 (build-application src (build-lexical-reference 'fun src f-name f)
455 (lambda (src in-order? ids vars val-exps body-exp)
459 (for-each maybe-name-value! ids val-exps)
460 (make-letrec src in-order? ids vars val-exps body-exp)))))
463 ;; FIXME: use a faster gensym
464 (define-syntax-rule (build-lexical-var src id)
465 (gensym (string-append (symbol->string id) "-")))
467 (define-structure (syntax-object expression wrap module))
469 (define-syntax no-source (identifier-syntax #f))
471 (define source-annotation
473 (let ((props (source-properties
474 (if (syntax-object? x)
475 (syntax-object-expression x)
477 (and (pair? props) props))))
479 (define-syntax-rule (arg-check pred? e who)
481 (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
483 ;; compile-time environments
485 ;; wrap and environment comprise two level mapping.
486 ;; wrap : id --> label
487 ;; env : label --> <element>
489 ;; environments are represented in two parts: a lexical part and a global
490 ;; part. The lexical part is a simple list of associations from labels
491 ;; to bindings. The global part is implemented by
492 ;; {put,get}-global-definition-hook and associates symbols with
495 ;; global (assumed global variable) and displaced-lexical (see below)
496 ;; do not show up in any environment; instead, they are fabricated by
497 ;; lookup when it finds no other bindings.
499 ;; <environment> ::= ((<label> . <binding>)*)
501 ;; identifier bindings include a type and a value
503 ;; <binding> ::= (macro . <procedure>) macros
504 ;; (core . <procedure>) core forms
505 ;; (module-ref . <procedure>) @ or @@
508 ;; (define-syntax) define-syntax
509 ;; (define-syntax-parameter) define-syntax-parameter
510 ;; (local-syntax . rec?) let-syntax/letrec-syntax
511 ;; (eval-when) eval-when
512 ;; (syntax . (<var> . <level>)) pattern variables
513 ;; (global) assumed global variable
514 ;; (lexical . <var>) lexical variables
515 ;; (ellipsis . <identifier>) custom ellipsis
516 ;; (displaced-lexical) displaced lexicals
517 ;; <level> ::= <nonnegative integer>
518 ;; <var> ::= variable returned by build-lexical-var
520 ;; a macro is a user-defined syntactic-form. a core is a
521 ;; system-defined syntactic form. begin, define, define-syntax,
522 ;; define-syntax-parameter, and eval-when are treated specially
523 ;; since they are sensitive to whether the form is at top-level and
524 ;; (except for eval-when) can denote valid internal definitions.
526 ;; a pattern variable is a variable introduced by syntax-case and can
527 ;; be referenced only within a syntax form.
529 ;; any identifier for which no top-level syntax definition or local
530 ;; binding of any kind has been seen is assumed to be a global
533 ;; a lexical variable is a lambda- or letrec-bound variable.
535 ;; an ellipsis binding is introduced by the 'with-ellipsis' special
538 ;; a displaced-lexical identifier is a lexical identifier removed from
539 ;; it's scope by the return of a syntax object containing the identifier.
540 ;; a displaced lexical can also appear when a letrec-syntax-bound
541 ;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
542 ;; a displaced lexical should never occur with properly written macros.
544 (define-syntax make-binding
545 (syntax-rules (quote)
546 ((_ type value) (cons type value))
548 ((_ type) (cons type '()))))
549 (define-syntax-rule (binding-type x)
551 (define-syntax-rule (binding-value x)
554 (define-syntax null-env (identifier-syntax '()))
557 (lambda (labels bindings r)
560 (extend-env (cdr labels) (cdr bindings)
561 (cons (cons (car labels) (car bindings)) r)))))
563 (define extend-var-env
564 ;; variant of extend-env that forms "lexical" binding
565 (lambda (labels vars r)
568 (extend-var-env (cdr labels) (cdr vars)
569 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
571 ;; we use a "macros only" environment in expansion of local macro
572 ;; definitions so that their definitions can use local macros without
573 ;; attempting to use other lexical identifiers.
574 (define macros-only-env
579 (if (memq (cadr a) '(macro ellipsis))
580 (cons a (macros-only-env (cdr r)))
581 (macros-only-env (cdr r)))))))
584 ;; x may be a label or a symbol
585 ;; although symbols are usually global, we check the environment first
586 ;; anyway because a temporary binding may have been established by
592 (or (get-global-definition-hook x mod) (make-binding 'global)))
593 (else (make-binding 'displaced-lexical)))))
595 (define global-extend
596 (lambda (type sym val)
597 (put-global-definition-hook sym type val)))
600 ;; Conceptually, identifiers are always syntax objects. Internally,
601 ;; however, the wrap is sometimes maintained separately (a source of
602 ;; efficiency and confusion), so that symbols are also considered
603 ;; identifiers by id?. Externally, they are always wrapped.
605 (define nonsymbol-id?
607 (and (syntax-object? x)
608 (symbol? (syntax-object-expression x)))))
614 ((syntax-object? x) (symbol? (syntax-object-expression x)))
617 (define-syntax-rule (id-sym-name e)
619 (if (syntax-object? x)
620 (syntax-object-expression x)
623 (define id-sym-name&marks
625 (if (syntax-object? x)
627 (syntax-object-expression x)
628 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
629 (values x (wrap-marks w)))))
631 ;; syntax object wraps
633 ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
634 ;; <subst> ::= shift | <subs>
635 ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
636 ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
638 (define-syntax make-wrap (identifier-syntax cons))
639 (define-syntax wrap-marks (identifier-syntax car))
640 (define-syntax wrap-subst (identifier-syntax cdr))
642 ;; labels must be comparable with "eq?", have read-write invariance,
643 ;; and distinct from symbols.
645 (string-append "l-" (session-id) (symbol->string (gensym "-"))))
651 (cons (gen-label) (gen-labels (cdr ls))))))
653 (define-structure (ribcage symnames marks labels))
655 (define-syntax empty-wrap (identifier-syntax '(())))
657 (define-syntax top-wrap (identifier-syntax '((top))))
659 (define-syntax-rule (top-marked? w)
660 (memq 'top (wrap-marks w)))
662 ;; Marks must be comparable with "eq?" and distinct from pairs and
663 ;; the symbol top. We do not use integers so that marks will remain
664 ;; unique even across file compiles.
666 (define-syntax the-anti-mark (identifier-syntax #f))
670 (make-wrap (cons the-anti-mark (wrap-marks w))
671 (cons 'shift (wrap-subst w)))))
673 (define-syntax-rule (new-mark)
674 (gensym (string-append "m-" (session-id) "-")))
676 ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
677 ;; internal definitions, in which the ribcages are built incrementally
678 (define-syntax-rule (make-empty-ribcage)
679 (make-ribcage '() '() '()))
681 (define extend-ribcage!
682 ;; must receive ids with complete wraps
683 (lambda (ribcage id label)
684 (set-ribcage-symnames! ribcage
685 (cons (syntax-object-expression id)
686 (ribcage-symnames ribcage)))
687 (set-ribcage-marks! ribcage
688 (cons (wrap-marks (syntax-object-wrap id))
689 (ribcage-marks ribcage)))
690 (set-ribcage-labels! ribcage
691 (cons label (ribcage-labels ribcage)))))
693 ;; make-binding-wrap creates vector-based ribcages
694 (define make-binding-wrap
695 (lambda (ids labels w)
701 (let ((labelvec (list->vector labels)))
702 (let ((n (vector-length labelvec)))
703 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
704 (let f ((ids ids) (i 0))
705 (if (not (null? ids))
707 (lambda () (id-sym-name&marks (car ids) w))
708 (lambda (symname marks)
709 (vector-set! symnamevec i symname)
710 (vector-set! marksvec i marks)
711 (f (cdr ids) (fx+ i 1))))))
712 (make-ribcage symnamevec marksvec labelvec))))
723 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
729 (smart-append s1 (wrap-subst w2))))
731 (smart-append m1 (wrap-marks w2))
732 (smart-append s1 (wrap-subst w2)))))))
736 (smart-append m1 m2)))
743 (eq? (car x) (car y))
744 (same-marks? (cdr x) (cdr y))))))
748 (define-syntax-rule (first e)
749 ;; Rely on Guile's multiple-values truncation.
752 (lambda (sym subst marks)
755 (let ((fst (car subst)))
757 (search sym (cdr subst) (cdr marks))
758 (let ((symnames (ribcage-symnames fst)))
759 (if (vector? symnames)
760 (search-vector-rib sym subst marks symnames fst)
761 (search-list-rib sym subst marks symnames fst))))))))
762 (define search-list-rib
763 (lambda (sym subst marks symnames ribcage)
764 (let f ((symnames symnames) (i 0))
766 ((null? symnames) (search sym (cdr subst) marks))
767 ((and (eq? (car symnames) sym)
768 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
769 (values (list-ref (ribcage-labels ribcage) i) marks))
770 (else (f (cdr symnames) (fx+ i 1)))))))
771 (define search-vector-rib
772 (lambda (sym subst marks symnames ribcage)
773 (let ((n (vector-length symnames)))
776 ((fx= i n) (search sym (cdr subst) marks))
777 ((and (eq? (vector-ref symnames i) sym)
778 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
779 (values (vector-ref (ribcage-labels ribcage) i) marks))
780 (else (f (fx+ i 1))))))))
783 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
785 (let ((id (syntax-object-expression id))
786 (w1 (syntax-object-wrap id)))
787 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
788 (call-with-values (lambda () (search id (wrap-subst w) marks))
789 (lambda (new-id marks)
791 (first (search id (wrap-subst w1) marks))
793 (else (syntax-violation 'id-var-name "invalid id" id)))))
795 ;; A helper procedure for syntax-locally-bound-identifiers, which
796 ;; itself is a helper for transformer procedures.
797 ;; `locally-bound-identifiers' returns a list of all bindings
798 ;; visible to a syntax object with the given wrap. They are in
799 ;; order from outer to inner.
801 ;; The purpose of this procedure is to give a transformer procedure
802 ;; references on bound identifiers, that the transformer can then
803 ;; introduce some of them in its output. As such, the identifiers
804 ;; are anti-marked, so that rebuild-macro-output doesn't apply new
807 (define locally-bound-identifiers
810 (lambda (subst results)
813 (let ((fst (car subst)))
815 (scan (cdr subst) results)
816 (let ((symnames (ribcage-symnames fst))
817 (marks (ribcage-marks fst)))
818 (if (vector? symnames)
819 (scan-vector-rib subst symnames marks results)
820 (scan-list-rib subst symnames marks results))))))))
821 (define scan-list-rib
822 (lambda (subst symnames marks results)
823 (let f ((symnames symnames) (marks marks) (results results))
825 (scan (cdr subst) results)
826 (f (cdr symnames) (cdr marks)
827 (cons (wrap (car symnames)
828 (anti-mark (make-wrap (car marks) subst))
831 (define scan-vector-rib
832 (lambda (subst symnames marks results)
833 (let ((n (vector-length symnames)))
834 (let f ((i 0) (results results))
836 (scan (cdr subst) results)
838 (cons (wrap (vector-ref symnames i)
839 (anti-mark (make-wrap (vector-ref marks i) subst))
842 (scan (wrap-subst w) '())))
844 ;; Returns three values: binding type, binding value, the module (for
845 ;; resolving toplevel vars).
846 (define (resolve-identifier id w r mod)
847 (define (resolve-global var mod)
848 (let ((b (or (get-global-definition-hook var mod)
849 (make-binding 'global))))
850 (if (eq? (binding-type b) 'global)
851 (values 'global var mod)
852 (values (binding-type b) (binding-value b) mod))))
853 (define (resolve-lexical label mod)
854 (let ((b (or (assq-ref r label)
855 (make-binding 'displaced-lexical))))
856 (values (binding-type b) (binding-value b) mod)))
857 (let ((n (id-var-name id w)))
860 (resolve-global n (if (syntax-object? id)
861 (syntax-object-module id)
864 (resolve-lexical n (if (syntax-object? id)
865 (syntax-object-module id)
868 (error "unexpected id-var-name" id w n)))))
870 (define transformer-environment
873 (error "called outside the dynamic extent of a syntax transformer"))))
875 (define (with-transformer-environment k)
876 ((fluid-ref transformer-environment) k))
878 ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
879 ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
883 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
884 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
886 ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
887 ;; long as the missing portion of the wrap is common to both of the ids
888 ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
892 (if (and (syntax-object? i) (syntax-object? j))
893 (and (eq? (syntax-object-expression i)
894 (syntax-object-expression j))
895 (same-marks? (wrap-marks (syntax-object-wrap i))
896 (wrap-marks (syntax-object-wrap j))))
899 ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
900 ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
901 ;; as long as the missing portion of the wrap is common to all of the
904 (define valid-bound-ids?
906 (and (let all-ids? ((ids ids))
909 (all-ids? (cdr ids)))))
910 (distinct-bound-ids? ids))))
912 ;; distinct-bound-ids? expects a list of ids and returns #t if there are
913 ;; no duplicates. It is quadratic on the length of the id list; long
914 ;; lists could be sorted to make it more efficient. distinct-bound-ids?
915 ;; may be passed unwrapped (or partially wrapped) ids as long as the
916 ;; missing portion of the wrap is common to all of the ids.
918 (define distinct-bound-ids?
920 (let distinct? ((ids ids))
922 (and (not (bound-id-member? (car ids) (cdr ids)))
923 (distinct? (cdr ids)))))))
925 (define bound-id-member?
927 (and (not (null? list))
928 (or (bound-id=? x (car list))
929 (bound-id-member? x (cdr list))))))
931 ;; wrapping expressions and identifiers
936 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
939 (syntax-object-expression x)
940 (join-wraps w (syntax-object-wrap x))
941 (syntax-object-module x)))
943 (else (make-syntax-object x w defmod)))))
946 (lambda (x w s defmod)
947 (wrap (decorate-source x s) w defmod)))
951 (define expand-sequence
952 (lambda (body r w s mod)
954 (let dobody ((body body) (r r) (w w) (mod mod))
957 (let ((first (expand (car body) r w mod)))
958 (cons first (dobody (cdr body) r w mod))))))))
960 ;; At top-level, we allow mixed definitions and expressions. Like
961 ;; expand-body we expand in two passes.
963 ;; First, from left to right, we expand just enough to know what
964 ;; expressions are definitions, syntax definitions, and splicing
965 ;; statements (`begin'). If we anything needs evaluating at
966 ;; expansion-time, it is expanded directly.
968 ;; Otherwise we collect expressions to expand, in thunks, and then
969 ;; expand them all at the end. This allows all syntax expanders
970 ;; visible in a toplevel sequence to be visible during the
971 ;; expansions of all normal definitions and expressions in the
974 (define expand-top-sequence
975 (lambda (body r w s m esew mod)
976 (define (scan body r w s m esew mod exps)
986 (let ((e (car body)))
987 (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
988 (lambda (type value form e w s mod)
994 (scan #'(e1 e2 ...) r w s m esew mod exps))))
996 (expand-local-syntax value e r w s mod
997 (lambda (body r w s mod)
998 (scan body r w s m esew mod exps))))
1001 ((_ (x ...) e1 e2 ...)
1002 (let ((when-list (parse-when-list e #'(x ...)))
1003 (body #'(e1 e2 ...)))
1006 (if (memq 'eval when-list)
1008 (if (memq 'expand when-list) 'c&e 'e)
1012 (if (memq 'expand when-list)
1013 (top-level-eval-hook
1014 (expand-top-sequence body r w s 'e '(eval) mod)
1017 ((memq 'load when-list)
1018 (if (or (memq 'compile when-list)
1019 (memq 'expand when-list)
1020 (and (eq? m 'c&e) (memq 'eval when-list)))
1021 (scan body r w s 'c&e '(compile load) mod exps)
1022 (if (memq m '(c c&e))
1023 (scan body r w s 'c '(load) mod exps)
1025 ((or (memq 'compile when-list)
1026 (memq 'expand when-list)
1027 (and (eq? m 'c&e) (memq 'eval when-list)))
1028 (top-level-eval-hook
1029 (expand-top-sequence body r w s 'e '(eval) mod)
1034 ((define-syntax-form define-syntax-parameter-form)
1035 (let ((n (id-var-name value w)) (r (macros-only-env r)))
1038 (if (memq 'compile esew)
1039 (let ((e (expand-install-global n (expand e r w mod))))
1040 (top-level-eval-hook e mod)
1041 (if (memq 'load esew)
1042 (values (cons e exps))
1044 (if (memq 'load esew)
1045 (values (cons (expand-install-global n (expand e r w mod))
1049 (let ((e (expand-install-global n (expand e r w mod))))
1050 (top-level-eval-hook e mod)
1051 (values (cons e exps))))
1053 (if (memq 'eval esew)
1054 (top-level-eval-hook
1055 (expand-install-global n (expand e r w mod))
1059 (let* ((n (id-var-name value w))
1060 ;; Lookup the name in the module of the define form.
1061 (type (binding-type (lookup n r mod))))
1063 ((global core macro module-ref)
1064 ;; affect compile-time environment (once we have booted)
1065 (if (and (memq m '(c c&e))
1066 (not (module-local-variable (current-module) n))
1068 (let ((old (module-variable (current-module) n)))
1069 ;; use value of the same-named imported variable, if
1071 (if (and (variable? old)
1072 (variable-bound? old)
1073 (not (macro? (variable-ref old))))
1074 (module-define! (current-module) n (variable-ref old))
1075 (module-add! (current-module) n (make-undefined-variable)))))
1079 (let ((x (build-global-definition s n (expand e r w mod))))
1080 (top-level-eval-hook x mod)
1083 (build-global-definition s n (expand e r w mod))))
1085 ((displaced-lexical)
1086 (syntax-violation #f "identifier out of context"
1087 (source-wrap form w s mod)
1088 (wrap value w mod)))
1090 (syntax-violation #f "cannot define keyword at top level"
1091 (source-wrap form w s mod)
1092 (wrap value w mod))))))
1096 (let ((x (expand-expr type value form e r w s mod)))
1097 (top-level-eval-hook x mod)
1100 (expand-expr type value form e r w s mod)))
1103 (scan (cdr body) r w s m esew mod exps))))))
1105 (call-with-values (lambda ()
1106 (scan body r w s m esew mod '()))
1112 (let lp ((in exps) (out '()))
1116 (cons (if (procedure? e) (e) e) out)))))))))))
1118 (define expand-install-global
1120 (build-global-definition
1125 (build-primref no-source 'make-syntax-transformer)
1126 (list (build-data no-source name)
1127 (build-data no-source 'macro)
1130 (define parse-when-list
1131 (lambda (e when-list)
1132 ;; when-list is syntax'd version of list of situations
1133 (let ((result (strip when-list empty-wrap)))
1134 (let lp ((l result))
1137 (if (memq (car l) '(compile load eval expand))
1139 (syntax-violation 'eval-when "invalid situation" e
1142 ;; syntax-type returns seven values: type, value, form, e, w, s, and
1143 ;; mod. The first two are described in the table below.
1145 ;; type value explanation
1146 ;; -------------------------------------------------------------------
1147 ;; core procedure core singleton
1148 ;; core-form procedure core form
1149 ;; module-ref procedure @ or @@ singleton
1150 ;; lexical name lexical variable reference
1151 ;; global name global variable reference
1152 ;; begin none begin keyword
1153 ;; define none define keyword
1154 ;; define-syntax none define-syntax keyword
1155 ;; define-syntax-parameter none define-syntax-parameter keyword
1156 ;; local-syntax rec? letrec-syntax/let-syntax keyword
1157 ;; eval-when none eval-when keyword
1158 ;; syntax level pattern variable
1159 ;; displaced-lexical none displaced lexical identifier
1160 ;; lexical-call name call to lexical variable
1161 ;; global-call name call to global variable
1162 ;; call none any other call
1163 ;; begin-form none begin expression
1164 ;; define-form id variable definition
1165 ;; define-syntax-form id syntax definition
1166 ;; define-syntax-parameter-form id syntax parameter definition
1167 ;; local-syntax-form rec? syntax definition
1168 ;; eval-when-form none eval-when form
1169 ;; constant none self-evaluating datum
1170 ;; other none anything else
1172 ;; form is the entire form. For definition forms (define-form,
1173 ;; define-syntax-form, and define-syntax-parameter-form), e is the
1174 ;; rhs expression. For all others, e is the entire form. w is the
1175 ;; wrap for both form and e. s is the source for the entire form.
1176 ;; mod is the module for both form and e.
1178 ;; syntax-type expands macros and unwraps as necessary to get to one
1179 ;; of the forms above. It also parses definition forms, although
1180 ;; perhaps this should be done by the consumer.
1183 (lambda (e r w s rib mod for-car?)
1186 (let* ((n (id-var-name e w))
1187 (b (lookup n r mod))
1188 (type (binding-type b)))
1190 ((lexical) (values type (binding-value b) e e w s mod))
1191 ((global) (values type n e e w s mod))
1194 (values type (binding-value b) e e w s mod)
1195 (syntax-type (expand-macro (binding-value b) e r w s rib mod)
1196 r empty-wrap s rib mod #f)))
1197 (else (values type (binding-value b) e e w s mod)))))
1199 (let ((first (car e)))
1201 (lambda () (syntax-type first r w s rib mod #t))
1202 (lambda (ftype fval fform fe fw fs fmod)
1205 (values 'lexical-call fval e e w s mod))
1207 ;; If we got here via an (@@ ...) expansion, we need to
1208 ;; make sure the fmod information is propagated back
1209 ;; correctly -- hence this consing.
1210 (values 'global-call (make-syntax-object fval w fmod)
1213 (syntax-type (expand-macro fval e r w s rib mod)
1214 r empty-wrap s rib mod for-car?))
1216 (call-with-values (lambda () (fval e r w))
1217 (lambda (e r w s mod)
1218 (syntax-type e r w s rib mod for-car?))))
1220 (values 'core-form fval e e w s mod))
1222 (values 'local-syntax-form fval e e w s mod))
1224 (values 'begin-form #f e e w s mod))
1226 (values 'eval-when-form #f e e w s mod))
1231 (values 'define-form #'name e #'val w s mod))
1232 ((_ (name . args) e1 e2 ...)
1234 (valid-bound-ids? (lambda-var-list #'args)))
1235 ;; need lambda here...
1236 (values 'define-form (wrap #'name w mod)
1239 (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
1244 (values 'define-form (wrap #'name w mod)
1247 empty-wrap s mod))))
1252 (values 'define-syntax-form #'name e #'val w s mod))))
1253 ((define-syntax-parameter)
1257 (values 'define-syntax-parameter-form #'name e #'val w s mod))))
1259 (values 'call #f e e w s mod)))))))
1261 (syntax-type (syntax-object-expression e)
1263 (join-wraps w (syntax-object-wrap e))
1264 (or (source-annotation e) s) rib
1265 (or (syntax-object-module e) mod) for-car?))
1266 ((self-evaluating? e) (values 'constant #f e e w s mod))
1267 (else (values 'other #f e e w s mod)))))
1272 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
1273 (lambda (type value form e w s mod)
1274 (expand-expr type value form e r w s mod)))))
1277 (lambda (type value form e r w s mod)
1280 (build-lexical-reference 'value s e value))
1282 ;; apply transformer
1283 (value e r w s mod))
1285 (call-with-values (lambda () (value e r w))
1286 (lambda (e r w s mod)
1287 (expand e r w mod))))
1291 (build-lexical-reference 'fun (source-annotation id)
1292 (if (syntax-object? id)
1299 (build-global-reference (source-annotation (car e))
1300 (if (syntax-object? value)
1301 (syntax-object-expression value)
1303 (if (syntax-object? value)
1304 (syntax-object-module value)
1307 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1308 ((global) (build-global-reference s value mod))
1309 ((call) (expand-application (expand (car e) r w mod) e r w s mod))
1312 ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
1314 (if (include-deprecated-features)
1316 (issue-deprecation-warning
1317 "Sequences of zero expressions are deprecated. Use *unspecified*.")
1319 (syntax-violation #f "sequence of zero expressions"
1320 (source-wrap e w s mod))))))
1321 ((local-syntax-form)
1322 (expand-local-syntax value e r w s mod expand-sequence))
1325 ((_ (x ...) e1 e2 ...)
1326 (let ((when-list (parse-when-list e #'(x ...))))
1327 (if (memq 'eval when-list)
1328 (expand-sequence #'(e1 e2 ...) r w s mod)
1330 ((define-form define-syntax-form define-syntax-parameter-form)
1331 (syntax-violation #f "definition in expression context, where definitions are not allowed,"
1332 (source-wrap form w s mod)))
1334 (syntax-violation #f "reference to pattern variable outside syntax form"
1335 (source-wrap e w s mod)))
1336 ((displaced-lexical)
1337 (syntax-violation #f "reference to identifier outside its scope"
1338 (source-wrap e w s mod)))
1339 (else (syntax-violation #f "unexpected syntax"
1340 (source-wrap e w s mod))))))
1342 (define expand-application
1343 (lambda (x e r w s mod)
1346 (build-application s x
1347 (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
1349 ;; (What follows is my interpretation of what's going on here -- Andy)
1351 ;; A macro takes an expression, a tree, the leaves of which are identifiers
1352 ;; and datums. Identifiers are symbols along with a wrap and a module. For
1353 ;; efficiency, subtrees that share wraps and modules may be grouped as one
1356 ;; Going into the expansion, the expression is given an anti-mark, which
1357 ;; logically propagates to all leaves. Then, in the new expression returned
1358 ;; from the transfomer, if we see an expression with an anti-mark, we know it
1359 ;; pertains to the original expression; conversely, expressions without the
1360 ;; anti-mark are known to be introduced by the transformer.
1362 ;; OK, good until now. We know this algorithm does lexical scoping
1363 ;; appropriately because it's widely known in the literature, and psyntax is
1364 ;; widely used. But what about modules? Here we're on our own. What we do is
1365 ;; to mark the module of expressions produced by a macro as pertaining to the
1366 ;; module that was current when the macro was defined -- that is, free
1367 ;; identifiers introduced by a macro are scoped in the macro's module, not in
1368 ;; the expansion's module. Seems to work well.
1370 ;; The only wrinkle is when we want a macro to expand to code in another
1371 ;; module, as is the case for the r6rs `library' form -- the body expressions
1372 ;; should be scoped relative the new module, the one defined by the macro.
1373 ;; For that, use `(@@ mod-name body)'.
1375 ;; Part of the macro output will be from the site of the macro use and part
1376 ;; from the macro definition. We allow source information from the macro use
1377 ;; to pass through, but we annotate the parts coming from the macro with the
1378 ;; source location information corresponding to the macro use. It would be
1379 ;; really nice if we could also annotate introduced expressions with the
1380 ;; locations corresponding to the macro definition, but that is not yet
1382 (define expand-macro
1383 (lambda (p e r w s rib mod)
1384 (define rebuild-macro-output
1388 (cons (rebuild-macro-output (car x) m)
1389 (rebuild-macro-output (cdr x) m))
1392 (let ((w (syntax-object-wrap x)))
1393 (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
1394 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1395 ;; output is from original text
1397 (syntax-object-expression x)
1398 (make-wrap (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
1399 (syntax-object-module x))
1400 ;; output introduced by macro
1402 (decorate-source (syntax-object-expression x) s)
1403 (make-wrap (cons m ms)
1405 (cons rib (cons 'shift ss))
1407 (syntax-object-module x))))))
1410 (let* ((n (vector-length x))
1411 (v (decorate-source (make-vector n) s)))
1412 (do ((i 0 (fx+ i 1)))
1415 (rebuild-macro-output (vector-ref x i) m)))))
1417 (syntax-violation #f "encountered raw symbol in macro output"
1418 (source-wrap e w (wrap-subst w) mod) x))
1419 (else (decorate-source x s)))))
1420 (with-fluids ((transformer-environment
1421 (lambda (k) (k e r w s rib mod))))
1422 (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
1426 ;; In processing the forms of the body, we create a new, empty wrap.
1427 ;; This wrap is augmented (destructively) each time we discover that
1428 ;; the next form is a definition. This is done:
1430 ;; (1) to allow the first nondefinition form to be a call to
1431 ;; one of the defined ids even if the id previously denoted a
1432 ;; definition keyword or keyword for a macro expanding into a
1434 ;; (2) to prevent subsequent definition forms (but unfortunately
1435 ;; not earlier ones) and the first nondefinition form from
1436 ;; confusing one of the bound identifiers for an auxiliary
1438 ;; (3) so that we do not need to restart the expansion of the
1439 ;; first nondefinition form, which is problematic anyway
1440 ;; since it might be the first element of a begin that we
1441 ;; have just spliced into the body (meaning if we restarted,
1442 ;; we'd really need to restart with the begin or the macro
1443 ;; call that expanded into the begin, and we'd have to give
1444 ;; up allowing (begin <defn>+ <expr>+), which is itself
1445 ;; problematic since we don't know if a begin contains only
1446 ;; definitions until we've expanded it).
1448 ;; Before processing the body, we also create a new environment
1449 ;; containing a placeholder for the bindings we will add later and
1450 ;; associate this environment with each form. In processing a
1451 ;; let-syntax or letrec-syntax, the associated environment may be
1452 ;; augmented with local keyword bindings, so the environment may
1453 ;; be different for different forms in the body. Once we have
1454 ;; gathered up all of the definitions, we evaluate the transformer
1455 ;; expressions and splice into r at the placeholder the new variable
1456 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1457 ;; forms local to a portion or all of the body to shadow the
1458 ;; definition bindings.
1460 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1463 ;; outer-form is fully wrapped w/source
1464 (lambda (body outer-form r w mod)
1465 (let* ((r (cons '("placeholder" . (placeholder)) r))
1466 (ribcage (make-empty-ribcage))
1467 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1468 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1469 (ids '()) (labels '())
1470 (var-ids '()) (vars '()) (vals '()) (bindings '()))
1472 (syntax-violation #f "no expressions in body" outer-form)
1473 (let ((e (cdar body)) (er (caar body)))
1475 (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f))
1476 (lambda (type value form e w s mod)
1479 (let ((id (wrap value w mod)) (label (gen-label)))
1480 (let ((var (gen-var id)))
1481 (extend-ribcage! ribcage id label)
1483 (cons id ids) (cons label labels)
1485 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1486 (cons (make-binding 'lexical var) bindings)))))
1487 ((define-syntax-form define-syntax-parameter-form)
1488 (let ((id (wrap value w mod))
1490 (trans-r (macros-only-env er)))
1491 (extend-ribcage! ribcage id label)
1492 ;; As required by R6RS, evaluate the right-hand-sides of internal
1493 ;; syntax definition forms and add their transformers to the
1494 ;; compile-time environment immediately, so that the newly-defined
1495 ;; keywords may be used in definition context within the same
1497 (set-cdr! r (extend-env (list label)
1498 (list (make-binding 'macro
1499 (eval-local-transformer
1500 (expand e trans-r w mod)
1503 (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
1507 (parse (let f ((forms #'(e1 ...)))
1510 (cons (cons er (wrap (car forms) w mod))
1512 ids labels var-ids vars vals bindings))))
1513 ((local-syntax-form)
1514 (expand-local-syntax value e er w s mod
1515 (lambda (forms er w s mod)
1516 (parse (let f ((forms forms))
1519 (cons (cons er (wrap (car forms) w mod))
1521 ids labels var-ids vars vals bindings))))
1522 (else ; found a non-definition
1524 (build-sequence no-source
1526 (expand (cdr x) (car x) empty-wrap mod))
1527 (cons (cons er (source-wrap e w s mod))
1530 (if (not (valid-bound-ids? ids))
1532 #f "invalid or duplicate identifier in definition"
1534 (set-cdr! r (extend-env labels bindings (cdr r)))
1535 (build-letrec no-source #t
1536 (reverse (map syntax->datum var-ids))
1539 (expand (cdr x) (car x) empty-wrap mod))
1541 (build-sequence no-source
1543 (expand (cdr x) (car x) empty-wrap mod))
1544 (cons (cons er (source-wrap e w s mod))
1545 (cdr body)))))))))))))))))
1547 (define expand-local-syntax
1548 (lambda (rec? e r w s mod k)
1550 ((_ ((id val) ...) e1 e2 ...)
1551 (let ((ids #'(id ...)))
1552 (if (not (valid-bound-ids? ids))
1553 (syntax-violation #f "duplicate bound keyword" e)
1554 (let ((labels (gen-labels ids)))
1555 (let ((new-w (make-binding-wrap ids labels w)))
1559 (let ((w (if rec? new-w w))
1560 (trans-r (macros-only-env r)))
1562 (make-binding 'macro
1563 (eval-local-transformer
1564 (expand x trans-r w mod)
1571 (_ (syntax-violation #f "bad local syntax definition"
1572 (source-wrap e w s mod))))))
1574 (define eval-local-transformer
1575 (lambda (expanded mod)
1576 (let ((p (local-eval-hook expanded mod)))
1579 (syntax-violation #f "nonprocedure transformer" p)))))
1583 (build-void no-source)))
1587 (and (nonsymbol-id? e)
1588 ;; If there is a binding for the special identifier
1589 ;; #{ $sc-ellipsis }# in the lexical environment of E,
1590 ;; and if the associated binding type is 'ellipsis',
1591 ;; then the binding's value specifies the custom ellipsis
1592 ;; identifier within that lexical environment, and the
1593 ;; comparison is done using 'bound-id=?'.
1594 (let* ((id (make-syntax-object '#{ $sc-ellipsis }#
1595 (syntax-object-wrap e)
1596 (syntax-object-module e)))
1597 (n (id-var-name id empty-wrap))
1598 (b (lookup n r mod)))
1599 (if (eq? (binding-type b) 'ellipsis)
1600 (bound-id=? e (binding-value b))
1601 (free-id=? e #'(... ...)))))))
1603 (define lambda-formals
1605 (define (req args rreq)
1606 (syntax-case args ()
1608 (check (reverse rreq) #f))
1610 (req #'b (cons #'a rreq)))
1612 (check (reverse rreq) #'r))
1614 (syntax-violation 'lambda "invalid argument list" orig-args args))))
1615 (define (check req rest)
1617 ((distinct-bound-ids? (if rest (cons rest req) req))
1618 (values req #f rest #f))
1620 (syntax-violation 'lambda "duplicate identifier in argument list"
1622 (req orig-args '())))
1624 (define expand-simple-lambda
1625 (lambda (e r w s mod req rest meta body)
1626 (let* ((ids (if rest (append req (list rest)) req))
1627 (vars (map gen-var ids))
1628 (labels (gen-labels ids)))
1629 (build-simple-lambda
1631 (map syntax->datum req) (and rest (syntax->datum rest)) vars
1633 (expand-body body (source-wrap e w s mod)
1634 (extend-var-env labels vars r)
1635 (make-binding-wrap ids labels w)
1638 (define lambda*-formals
1640 (define (req args rreq)
1641 (syntax-case args ()
1643 (check (reverse rreq) '() #f '()))
1645 (req #'b (cons #'a rreq)))
1646 ((a . b) (eq? (syntax->datum #'a) #:optional)
1647 (opt #'b (reverse rreq) '()))
1648 ((a . b) (eq? (syntax->datum #'a) #:key)
1649 (key #'b (reverse rreq) '() '()))
1650 ((a b) (eq? (syntax->datum #'a) #:rest)
1651 (rest #'b (reverse rreq) '() '()))
1653 (rest #'r (reverse rreq) '() '()))
1655 (syntax-violation 'lambda* "invalid argument list" orig-args args))))
1656 (define (opt args req ropt)
1657 (syntax-case args ()
1659 (check req (reverse ropt) #f '()))
1661 (opt #'b req (cons #'(a #f) ropt)))
1662 (((a init) . b) (id? #'a)
1663 (opt #'b req (cons #'(a init) ropt)))
1664 ((a . b) (eq? (syntax->datum #'a) #:key)
1665 (key #'b req (reverse ropt) '()))
1666 ((a b) (eq? (syntax->datum #'a) #:rest)
1667 (rest #'b req (reverse ropt) '()))
1669 (rest #'r req (reverse ropt) '()))
1671 (syntax-violation 'lambda* "invalid optional argument list"
1673 (define (key args req opt rkey)
1674 (syntax-case args ()
1676 (check req opt #f (cons #f (reverse rkey))))
1678 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1679 (key #'b req opt (cons #'(k a #f) rkey))))
1680 (((a init) . b) (id? #'a)
1681 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1682 (key #'b req opt (cons #'(k a init) rkey))))
1683 (((a init k) . b) (and (id? #'a)
1684 (keyword? (syntax->datum #'k)))
1685 (key #'b req opt (cons #'(k a init) rkey)))
1686 ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
1687 (check req opt #f (cons #t (reverse rkey))))
1688 ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1689 (eq? (syntax->datum #'a) #:rest))
1690 (rest #'b req opt (cons #t (reverse rkey))))
1691 ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1693 (rest #'r req opt (cons #t (reverse rkey))))
1694 ((a b) (eq? (syntax->datum #'a) #:rest)
1695 (rest #'b req opt (cons #f (reverse rkey))))
1697 (rest #'r req opt (cons #f (reverse rkey))))
1699 (syntax-violation 'lambda* "invalid keyword argument list"
1701 (define (rest args req opt kw)
1702 (syntax-case args ()
1704 (check req opt #'r kw))
1706 (syntax-violation 'lambda* "invalid rest argument"
1708 (define (check req opt rest kw)
1710 ((distinct-bound-ids?
1711 (append req (map car opt) (if rest (list rest) '())
1712 (if (pair? kw) (map cadr (cdr kw)) '())))
1713 (values req opt rest kw))
1715 (syntax-violation 'lambda* "duplicate identifier in argument list"
1717 (req orig-args '())))
1719 (define expand-lambda-case
1720 (lambda (e r w s mod get-formals clauses)
1721 (define (parse-req req opt rest kw body)
1722 (let ((vars (map gen-var req))
1723 (labels (gen-labels req)))
1724 (let ((r* (extend-var-env labels vars r))
1725 (w* (make-binding-wrap req labels w)))
1726 (parse-opt (map syntax->datum req)
1727 opt rest kw body (reverse vars) r* w* '() '()))))
1728 (define (parse-opt req opt rest kw body vars r* w* out inits)
1731 (syntax-case (car opt) ()
1733 (let* ((v (gen-var #'id))
1734 (l (gen-labels (list v)))
1735 (r** (extend-var-env l (list v) r*))
1736 (w** (make-binding-wrap (list #'id) l w*)))
1737 (parse-opt req (cdr opt) rest kw body (cons v vars)
1738 r** w** (cons (syntax->datum #'id) out)
1739 (cons (expand #'i r* w* mod) inits))))))
1741 (let* ((v (gen-var rest))
1742 (l (gen-labels (list v)))
1743 (r* (extend-var-env l (list v) r*))
1744 (w* (make-binding-wrap (list rest) l w*)))
1745 (parse-kw req (if (pair? out) (reverse out) #f)
1746 (syntax->datum rest)
1747 (if (pair? kw) (cdr kw) kw)
1748 body (cons v vars) r* w*
1749 (if (pair? kw) (car kw) #f)
1752 (parse-kw req (if (pair? out) (reverse out) #f) #f
1753 (if (pair? kw) (cdr kw) kw)
1755 (if (pair? kw) (car kw) #f)
1757 (define (parse-kw req opt rest kw body vars r* w* aok out inits)
1760 (syntax-case (car kw) ()
1762 (let* ((v (gen-var #'id))
1763 (l (gen-labels (list v)))
1764 (r** (extend-var-env l (list v) r*))
1765 (w** (make-binding-wrap (list #'id) l w*)))
1766 (parse-kw req opt rest (cdr kw) body (cons v vars)
1768 (cons (list (syntax->datum #'k)
1769 (syntax->datum #'id)
1772 (cons (expand #'i r* w* mod) inits))))))
1774 (parse-body req opt rest
1775 (if (or aok (pair? out)) (cons aok (reverse out)) #f)
1776 body (reverse vars) r* w* (reverse inits) '()))))
1777 (define (parse-body req opt rest kw body vars r* w* inits meta)
1778 (syntax-case body ()
1779 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1780 (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1783 . ,(syntax->datum #'docstring))))))
1784 ((#((k . v) ...) e1 e2 ...)
1785 (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1786 (append meta (syntax->datum #'((k . v) ...)))))
1788 (values meta req opt rest kw inits vars
1789 (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
1792 (syntax-case clauses ()
1793 (() (values '() #f))
1794 (((args e1 e2 ...) (args* e1* e2* ...) ...)
1795 (call-with-values (lambda () (get-formals #'args))
1796 (lambda (req opt rest kw)
1797 (call-with-values (lambda ()
1798 (parse-req req opt rest kw #'(e1 e2 ...)))
1799 (lambda (meta req opt rest kw inits vars body)
1802 (expand-lambda-case e r w s mod get-formals
1803 #'((args* e1* e2* ...) ...)))
1804 (lambda (meta* else*)
1807 (build-lambda-case s req opt rest kw inits vars
1808 body else*))))))))))))
1812 ;; strips syntax-objects down to top-wrap
1814 ;; since only the head of a list is annotated by the reader, not each pair
1815 ;; in the spine, we also check for pairs whose cars are annotated in case
1816 ;; we've been passed the cdr of an annotated list
1825 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1827 (let ((a (f (car x))) (d (f (cdr x))))
1828 (if (and (eq? a (car x)) (eq? d (cdr x)))
1832 (let ((old (vector->list x)))
1833 (let ((new (map f old)))
1834 ;; inlined and-map with two args
1835 (let lp ((l1 old) (l2 new))
1838 (if (eq? (car l1) (car l2))
1839 (lp (cdr l1) (cdr l2))
1840 (list->vector new)))))))
1843 ;; lexical variables
1847 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1848 (build-lexical-var no-source id))))
1850 ;; appears to return a reversed list
1851 (define lambda-var-list
1853 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1855 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1856 ((id? vars) (cons (wrap vars w #f) ls))
1858 ((syntax-object? vars)
1859 (lvl (syntax-object-expression vars)
1861 (join-wraps w (syntax-object-wrap vars))))
1862 ;; include anything else to be caught by subsequent error
1864 (else (cons vars ls))))))
1866 ;; core transformers
1868 (global-extend 'local-syntax 'letrec-syntax #t)
1869 (global-extend 'local-syntax 'let-syntax #f)
1871 (global-extend 'core 'syntax-parameterize
1872 (lambda (e r w s mod)
1874 ((_ ((var val) ...) e1 e2 ...)
1875 (valid-bound-ids? #'(var ...))
1876 (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
1879 (case (binding-type (lookup n r mod))
1880 ((displaced-lexical)
1881 (syntax-violation 'syntax-parameterize
1882 "identifier out of context"
1884 (source-wrap id w s mod)))))
1889 (source-wrap e w s mod)
1892 (let ((trans-r (macros-only-env r)))
1894 (make-binding 'macro
1895 (eval-local-transformer (expand x trans-r w mod)
1901 (_ (syntax-violation 'syntax-parameterize "bad syntax"
1902 (source-wrap e w s mod))))))
1904 (global-extend 'core 'quote
1905 (lambda (e r w s mod)
1907 ((_ e) (build-data s (strip #'e w)))
1908 (_ (syntax-violation 'quote "bad syntax"
1909 (source-wrap e w s mod))))))
1911 (global-extend 'core 'syntax
1914 (lambda (src e r maps ellipsis? mod)
1916 (let ((label (id-var-name e empty-wrap)))
1917 ;; Mod does not matter, we are looking to see if
1918 ;; the id is lexical syntax.
1919 (let ((b (lookup label r mod)))
1920 (if (eq? (binding-type b) 'syntax)
1923 (let ((var.lev (binding-value b)))
1924 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1925 (lambda (var maps) (values `(ref ,var) maps)))
1926 (if (ellipsis? e r mod)
1927 (syntax-violation 'syntax "misplaced ellipsis" src)
1928 (values `(quote ,e) maps)))))
1931 (ellipsis? #'dots r mod)
1932 (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
1934 ;; this could be about a dozen lines of code, except that we
1935 ;; choose to handle #'(x ... ...) forms
1936 (ellipsis? #'dots r mod)
1941 (gen-syntax src #'x r
1942 (cons '() maps) ellipsis? mod))
1944 (if (null? (car maps))
1945 (syntax-violation 'syntax "extra ellipsis"
1947 (values (gen-map x (car maps))
1951 (ellipsis? #'dots r mod)
1955 (lambda () (k (cons '() maps)))
1957 (if (null? (car maps))
1958 (syntax-violation 'syntax "extra ellipsis" src)
1959 (values (gen-mappend x (car maps))
1961 (_ (call-with-values
1962 (lambda () (gen-syntax src y r maps ellipsis? mod))
1965 (lambda () (k maps))
1967 (values (gen-append x y) maps)))))))))
1970 (lambda () (gen-syntax src #'x r maps ellipsis? mod))
1973 (lambda () (gen-syntax src #'y r maps ellipsis? mod))
1974 (lambda (y maps) (values (gen-cons x y) maps))))))
1978 (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
1979 (lambda (e maps) (values (gen-vector e) maps))))
1980 (_ (values `(quote ,e) maps))))))
1983 (lambda (src var level maps)
1987 (syntax-violation 'syntax "missing ellipsis" src)
1989 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1990 (lambda (outer-var outer-maps)
1991 (let ((b (assq outer-var (car maps))))
1993 (values (cdr b) maps)
1994 (let ((inner-var (gen-var 'tmp)))
1996 (cons (cons (cons outer-var inner-var)
1998 outer-maps)))))))))))
2002 `(apply (primitive append) ,(gen-map e map-env))))
2006 (let ((formals (map cdr map-env))
2007 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
2010 ;; identity map equivalence:
2011 ;; (map (lambda (x) x) y) == y
2014 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
2016 ;; eta map equivalence:
2017 ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
2018 `(map (primitive ,(car e))
2019 ,@(map (let ((r (map cons formals actuals)))
2020 (lambda (x) (cdr (assq (cadr x) r))))
2022 (else `(map (lambda ,formals ,e) ,@actuals))))))
2028 (if (eq? (car x) 'quote)
2029 `(quote (,(cadr x) . ,(cadr y)))
2030 (if (eq? (cadr y) '())
2033 ((list) `(list ,x ,@(cdr y)))
2034 (else `(cons ,x ,y)))))
2038 (if (equal? y '(quote ()))
2045 ((eq? (car x) 'list) `(vector ,@(cdr x)))
2046 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
2047 (else `(list->vector ,x)))))
2053 ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
2054 ((primitive) (build-primref no-source (cadr x)))
2055 ((quote) (build-data no-source (cadr x)))
2057 (if (list? (cadr x))
2058 (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
2059 (error "how did we get here" x)))
2060 (else (build-application no-source
2061 (build-primref no-source (car x))
2062 (map regen (cdr x)))))))
2064 (lambda (e r w s mod)
2065 (let ((e (source-wrap e w s mod)))
2069 (lambda () (gen-syntax e #'x r '() ellipsis? mod))
2070 (lambda (e maps) (regen e))))
2071 (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
2073 (global-extend 'core 'lambda
2074 (lambda (e r w s mod)
2077 (call-with-values (lambda () (lambda-formals #'args))
2078 (lambda (req opt rest kw)
2079 (let lp ((body #'(e1 e2 ...)) (meta '()))
2080 (syntax-case body ()
2081 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
2085 . ,(syntax->datum #'docstring))))))
2086 ((#((k . v) ...) e1 e2 ...)
2088 (append meta (syntax->datum #'((k . v) ...)))))
2089 (_ (expand-simple-lambda e r w s mod req rest meta body)))))))
2090 (_ (syntax-violation 'lambda "bad lambda" e)))))
2092 (global-extend 'core 'lambda*
2093 (lambda (e r w s mod)
2098 (expand-lambda-case e r w s mod
2099 lambda*-formals #'((args e1 e2 ...))))
2100 (lambda (meta lcase)
2101 (build-case-lambda s meta lcase))))
2102 (_ (syntax-violation 'lambda "bad lambda*" e)))))
2104 (global-extend 'core 'case-lambda
2105 (lambda (e r w s mod)
2106 (define (build-it meta clauses)
2109 (expand-lambda-case e r w s mod
2112 (lambda (meta* lcase)
2113 (build-case-lambda s (append meta meta*) lcase))))
2115 ((_ (args e1 e2 ...) ...)
2116 (build-it '() #'((args e1 e2 ...) ...)))
2117 ((_ docstring (args e1 e2 ...) ...)
2118 (string? (syntax->datum #'docstring))
2119 (build-it `((documentation
2120 . ,(syntax->datum #'docstring)))
2121 #'((args e1 e2 ...) ...)))
2122 (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
2124 (global-extend 'core 'case-lambda*
2125 (lambda (e r w s mod)
2126 (define (build-it meta clauses)
2129 (expand-lambda-case e r w s mod
2132 (lambda (meta* lcase)
2133 (build-case-lambda s (append meta meta*) lcase))))
2135 ((_ (args e1 e2 ...) ...)
2136 (build-it '() #'((args e1 e2 ...) ...)))
2137 ((_ docstring (args e1 e2 ...) ...)
2138 (string? (syntax->datum #'docstring))
2139 (build-it `((documentation
2140 . ,(syntax->datum #'docstring)))
2141 #'((args e1 e2 ...) ...)))
2142 (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
2144 (global-extend 'core 'with-ellipsis
2145 (lambda (e r w s mod)
2149 (let ((id (if (symbol? #'dots)
2151 (make-syntax-object '#{ $sc-ellipsis }#
2152 (syntax-object-wrap #'dots)
2153 (syntax-object-module #'dots)))))
2154 (let ((ids (list id))
2155 (labels (list (gen-label)))
2156 (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
2157 (let ((nw (make-binding-wrap ids labels w))
2158 (nr (extend-env labels bindings r)))
2159 (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod)))))
2160 (_ (syntax-violation 'with-ellipsis "bad syntax"
2161 (source-wrap e w s mod))))))
2163 (global-extend 'core 'let
2165 (define (expand-let e r w s mod constructor ids vals exps)
2166 (if (not (valid-bound-ids? ids))
2167 (syntax-violation 'let "duplicate bound variable" e)
2168 (let ((labels (gen-labels ids))
2169 (new-vars (map gen-var ids)))
2170 (let ((nw (make-binding-wrap ids labels w))
2171 (nr (extend-var-env labels new-vars r)))
2173 (map syntax->datum ids)
2175 (map (lambda (x) (expand x r w mod)) vals)
2176 (expand-body exps (source-wrap e nw s mod)
2178 (lambda (e r w s mod)
2180 ((_ ((id val) ...) e1 e2 ...)
2181 (and-map id? #'(id ...))
2182 (expand-let e r w s mod
2187 ((_ f ((id val) ...) e1 e2 ...)
2188 (and (id? #'f) (and-map id? #'(id ...)))
2189 (expand-let e r w s mod
2194 (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
2197 (global-extend 'core 'letrec
2198 (lambda (e r w s mod)
2200 ((_ ((id val) ...) e1 e2 ...)
2201 (and-map id? #'(id ...))
2202 (let ((ids #'(id ...)))
2203 (if (not (valid-bound-ids? ids))
2204 (syntax-violation 'letrec "duplicate bound variable" e)
2205 (let ((labels (gen-labels ids))
2206 (new-vars (map gen-var ids)))
2207 (let ((w (make-binding-wrap ids labels w))
2208 (r (extend-var-env labels new-vars r)))
2210 (map syntax->datum ids)
2212 (map (lambda (x) (expand x r w mod)) #'(val ...))
2213 (expand-body #'(e1 e2 ...)
2214 (source-wrap e w s mod) r w mod)))))))
2215 (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
2218 (global-extend 'core 'letrec*
2219 (lambda (e r w s mod)
2221 ((_ ((id val) ...) e1 e2 ...)
2222 (and-map id? #'(id ...))
2223 (let ((ids #'(id ...)))
2224 (if (not (valid-bound-ids? ids))
2225 (syntax-violation 'letrec* "duplicate bound variable" e)
2226 (let ((labels (gen-labels ids))
2227 (new-vars (map gen-var ids)))
2228 (let ((w (make-binding-wrap ids labels w))
2229 (r (extend-var-env labels new-vars r)))
2231 (map syntax->datum ids)
2233 (map (lambda (x) (expand x r w mod)) #'(val ...))
2234 (expand-body #'(e1 e2 ...)
2235 (source-wrap e w s mod) r w mod)))))))
2236 (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
2239 (global-extend 'core 'set!
2240 (lambda (e r w s mod)
2244 (let ((n (id-var-name #'id w))
2245 ;; Lookup id in its module
2246 (id-mod (if (syntax-object? #'id)
2247 (syntax-object-module #'id)
2249 (let ((b (lookup n r id-mod)))
2250 (case (binding-type b)
2252 (build-lexical-assignment s
2253 (syntax->datum #'id)
2255 (expand #'val r w mod)))
2257 (build-global-assignment s n (expand #'val r w mod) id-mod))
2259 (let ((p (binding-value b)))
2260 (if (procedure-property p 'variable-transformer)
2261 ;; As syntax-type does, call expand-macro with
2262 ;; the mod of the expression. Hmm.
2263 (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
2264 (syntax-violation 'set! "not a variable transformer"
2266 (wrap #'id w id-mod)))))
2267 ((displaced-lexical)
2268 (syntax-violation 'set! "identifier out of context"
2270 (else (syntax-violation 'set! "bad set!"
2271 (source-wrap e w s mod)))))))
2272 ((_ (head tail ...) val)
2274 (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
2275 (lambda (type value formform ee ww ss modmod)
2278 (let ((val (expand #'val r w mod)))
2279 (call-with-values (lambda () (value #'(head tail ...) r w))
2280 (lambda (e r w s* mod)
2283 (build-global-assignment s (syntax->datum #'e)
2286 (build-application s
2287 (expand #'(setter head) r w mod)
2288 (map (lambda (e) (expand e r w mod))
2289 #'(tail ... val))))))))
2290 (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
2292 (global-extend 'module-ref '@
2296 (and (and-map id? #'(mod ...)) (id? #'id))
2297 ;; Strip the wrap from the identifier and return top-wrap
2298 ;; so that the identifier will not be captured by lexicals.
2299 (values (syntax->datum #'id) r top-wrap #f
2301 #'(public mod ...)))))))
2303 (global-extend 'module-ref '@@
2308 (cons (remodulate (car x) mod)
2309 (remodulate (cdr x) mod)))
2312 (remodulate (syntax-object-expression x) mod)
2313 (syntax-object-wrap x)
2314 ;; hither the remodulation
2317 (let* ((n (vector-length x)) (v (make-vector n)))
2318 (do ((i 0 (fx+ i 1)))
2320 (vector-set! v i (remodulate (vector-ref x i) mod)))))
2324 (and (and-map id? #'(mod ...)) (id? #'id))
2325 ;; Strip the wrap from the identifier and return top-wrap
2326 ;; so that the identifier will not be captured by lexicals.
2327 (values (syntax->datum #'id) r top-wrap #f
2329 #'(private mod ...))))
2330 ((_ @@ (mod ...) exp)
2331 (and-map id? #'(mod ...))
2332 ;; This is a special syntax used to support R6RS library forms.
2333 ;; Unlike the syntax above, the last item is not restricted to
2334 ;; be a single identifier, and the syntax objects are kept
2335 ;; intact, with only their module changed.
2336 (let ((mod (syntax->datum #'(private mod ...))))
2337 (values (remodulate #'exp mod)
2338 r w (source-annotation #'exp)
2341 (global-extend 'core 'if
2342 (lambda (e r w s mod)
2347 (expand #'test r w mod)
2348 (expand #'then r w mod)
2349 (build-void no-source)))
2353 (expand #'test r w mod)
2354 (expand #'then r w mod)
2355 (expand #'else r w mod))))))
2357 (global-extend 'core 'with-fluids
2358 (lambda (e r w s mod)
2360 ((_ ((fluid val) ...) b b* ...)
2363 (map (lambda (x) (expand x r w mod)) #'(fluid ...))
2364 (map (lambda (x) (expand x r w mod)) #'(val ...))
2365 (expand-body #'(b b* ...)
2366 (source-wrap e w s mod) r w mod))))))
2368 (global-extend 'begin 'begin '())
2370 (global-extend 'define 'define '())
2372 (global-extend 'define-syntax 'define-syntax '())
2373 (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
2375 (global-extend 'eval-when 'eval-when '())
2377 (global-extend 'core 'syntax-case
2379 (define convert-pattern
2380 ;; accepts pattern & keys
2381 ;; returns $sc-dispatch pattern & ids
2382 (lambda (pattern keys ellipsis?)
2388 (lambda () (cvt* #'y n ids))
2391 (lambda () (cvt #'x n ids))
2393 (values (cons x y) ids))))))
2394 (_ (cvt p* n ids)))))
2396 (define (v-reverse x)
2397 (let loop ((r '()) (x x))
2400 (loop (cons (car x) r) (cdr x)))))
2406 ((bound-id-member? p keys)
2407 (values (vector 'free-id p) ids))
2411 (values 'any (cons (cons p n) ids))))
2414 (ellipsis? (syntax dots))
2416 (lambda () (cvt (syntax x) (fx+ n 1) ids))
2418 (values (if (eq? p 'any) 'each-any (vector 'each p))
2421 (ellipsis? (syntax dots))
2423 (lambda () (cvt* (syntax ys) n ids))
2426 (lambda () (cvt (syntax x) (+ n 1) ids))
2429 (lambda () (v-reverse ys))
2431 (values `#(each+ ,x ,ys ,e)
2435 (lambda () (cvt (syntax y) n ids))
2438 (lambda () (cvt (syntax x) n ids))
2440 (values (cons x y) ids))))))
2441 (() (values '() ids))
2444 (lambda () (cvt (syntax (x ...)) n ids))
2445 (lambda (p ids) (values (vector 'vector p) ids))))
2446 (x (values (vector 'atom (strip p empty-wrap)) ids))))))
2447 (cvt pattern 0 '())))
2449 (define build-dispatch-call
2450 (lambda (pvars exp y r mod)
2451 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2452 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2453 (build-application no-source
2454 (build-primref no-source 'apply)
2455 (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
2459 (map (lambda (var level)
2460 (make-binding 'syntax `(,var . ,level)))
2464 (make-binding-wrap ids labels empty-wrap)
2469 (lambda (x keys clauses r pat fender exp mod)
2471 (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
2474 ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
2475 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2476 ((not (distinct-bound-ids? (map car pvars)))
2477 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2479 (let ((y (gen-var 'tmp)))
2480 ;; fat finger binding and references to temp variable y
2481 (build-application no-source
2482 (build-simple-lambda no-source (list 'tmp) #f (list y) '()
2483 (let ((y (build-lexical-reference 'value no-source
2485 (build-conditional no-source
2486 (syntax-case fender ()
2488 (_ (build-conditional no-source
2490 (build-dispatch-call pvars fender y r mod)
2491 (build-data no-source #f))))
2492 (build-dispatch-call pvars exp y r mod)
2493 (gen-syntax-case x keys clauses r mod))))
2494 (list (if (eq? p 'any)
2495 (build-application no-source
2496 (build-primref no-source 'list)
2498 (build-application no-source
2499 (build-primref no-source '$sc-dispatch)
2500 (list x (build-data no-source p)))))))))))))
2502 (define gen-syntax-case
2503 (lambda (x keys clauses r mod)
2505 (build-application no-source
2506 (build-primref no-source 'syntax-violation)
2507 (list (build-data no-source #f)
2508 (build-data no-source
2509 "source expression failed to match any pattern")
2511 (syntax-case (car clauses) ()
2513 (if (and (id? #'pat)
2514 (and-map (lambda (x) (not (free-id=? #'pat x)))
2515 (cons #'(... ...) keys)))
2516 (if (free-id=? #'pat #'_)
2517 (expand #'exp r empty-wrap mod)
2518 (let ((labels (list (gen-label)))
2519 (var (gen-var #'pat)))
2520 (build-application no-source
2521 (build-simple-lambda
2522 no-source (list (syntax->datum #'pat)) #f (list var)
2526 (list (make-binding 'syntax `(,var . 0)))
2528 (make-binding-wrap #'(pat)
2532 (gen-clause x keys (cdr clauses) r
2533 #'pat #t #'exp mod)))
2535 (gen-clause x keys (cdr clauses) r
2536 #'pat #'fender #'exp mod))
2537 (_ (syntax-violation 'syntax-case "invalid clause"
2540 (lambda (e r w s mod)
2541 (let ((e (source-wrap e w s mod)))
2543 ((_ val (key ...) m ...)
2544 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod))))
2546 (let ((x (gen-var 'tmp)))
2547 ;; fat finger binding and references to temp variable x
2548 (build-application s
2549 (build-simple-lambda no-source (list 'tmp) #f (list x) '()
2550 (gen-syntax-case (build-lexical-reference 'value no-source
2552 #'(key ...) #'(m ...)
2555 (list (expand #'val r empty-wrap mod))))
2556 (syntax-violation 'syntax-case "invalid literals list" e))))))))
2558 ;; The portable macroexpand seeds expand-top's mode m with 'e (for
2559 ;; evaluating) and esew (which stands for "eval syntax expanders
2560 ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
2561 ;; if we are compiling a file, and esew is set to
2562 ;; (eval-syntactic-expanders-when), which defaults to the list
2563 ;; '(compile load eval). This means that, by default, top-level
2564 ;; syntactic definitions are evaluated immediately after they are
2565 ;; expanded, and the expanded definitions are also residualized into
2566 ;; the object file if we are compiling a file.
2568 (lambda* (x #:optional (m 'e) (esew '(eval)))
2569 (expand-top-sequence (list x) null-env top-wrap #f m esew
2570 (cons 'hygiene (module-name (current-module))))))
2578 (make-syntax-object datum (syntax-object-wrap id)
2579 (syntax-object-module id))))
2582 ;; accepts any object, since syntax objects may consist partially
2583 ;; or entirely of unwrapped, nonsymbolic data
2585 (strip x empty-wrap)))
2588 (lambda (x) (source-annotation x)))
2590 (set! generate-temporaries
2592 (arg-check list? ls 'generate-temporaries)
2593 (let ((mod (cons 'hygiene (module-name (current-module)))))
2594 (map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls))))
2596 (set! free-identifier=?
2598 (arg-check nonsymbol-id? x 'free-identifier=?)
2599 (arg-check nonsymbol-id? y 'free-identifier=?)
2602 (set! bound-identifier=?
2604 (arg-check nonsymbol-id? x 'bound-identifier=?)
2605 (arg-check nonsymbol-id? y 'bound-identifier=?)
2608 (set! syntax-violation
2609 (lambda* (who message form #:optional subform)
2610 (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2611 who 'syntax-violation)
2612 (arg-check string? message 'syntax-violation)
2613 (throw 'syntax-error who message
2614 (or (source-annotation subform)
2615 (source-annotation form))
2616 (strip form empty-wrap)
2617 (and subform (strip subform empty-wrap)))))
2620 (define (syntax-module id)
2621 (arg-check nonsymbol-id? id 'syntax-module)
2622 (cdr (syntax-object-module id)))
2624 (define (syntax-local-binding id)
2625 (arg-check nonsymbol-id? id 'syntax-local-binding)
2626 (with-transformer-environment
2627 (lambda (e r w s rib mod)
2628 (define (strip-anti-mark w)
2629 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
2630 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
2631 ;; output is from original text
2632 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
2633 ;; output introduced by macro
2634 (make-wrap ms (if rib (cons rib s) s)))))
2635 (call-with-values (lambda ()
2637 (syntax-object-expression id)
2638 (strip-anti-mark (syntax-object-wrap id))
2640 (syntax-object-module id)))
2641 (lambda (type value mod)
2643 ((lexical) (values 'lexical value))
2644 ((macro) (values 'macro value))
2645 ((syntax) (values 'pattern-variable value))
2646 ((displaced-lexical) (values 'displaced-lexical #f))
2647 ((global) (values 'global (cons value (cdr mod))))
2650 (make-syntax-object (syntax-object-expression value)
2651 (anti-mark (syntax-object-wrap value))
2652 (syntax-object-module value))))
2653 (else (values 'other #f))))))))
2655 (define (syntax-locally-bound-identifiers id)
2656 (arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
2657 (locally-bound-identifiers (syntax-object-wrap id)
2658 (syntax-object-module id)))
2660 ;; Using define! instead of set! to avoid warnings at
2661 ;; compile-time, after the variables are stolen away into (system
2662 ;; syntax). See the end of boot-9.scm.
2664 (define! 'syntax-module syntax-module)
2665 (define! 'syntax-local-binding syntax-local-binding)
2666 (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
2668 ;; $sc-dispatch expects an expression and a pattern. If the expression
2669 ;; matches the pattern a list of the matching expressions for each
2670 ;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2671 ;; not work on r4rs implementations that violate the ieee requirement
2672 ;; that #f and () be distinct.)
2674 ;; The expression is matched with the pattern as follows:
2676 ;; pattern: matches:
2679 ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2681 ;; #(free-id <key>) <key> with free-identifier=?
2682 ;; #(each <pattern>) (<pattern>*)
2683 ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
2684 ;; #(vector <pattern>) (list->vector <pattern>)
2685 ;; #(atom <object>) <object> with "equal?"
2687 ;; Vector cops out to pair under assumption that vectors are rare. If
2688 ;; not, should convert to:
2689 ;; #(vector <pattern>*) #(<pattern>*)
2697 (let ((first (match (car e) p w '() mod)))
2699 (let ((rest (match-each (cdr e) p w mod)))
2700 (and rest (cons first rest))))))
2703 (match-each (syntax-object-expression e)
2705 (join-wraps w (syntax-object-wrap e))
2706 (syntax-object-module e)))
2710 (lambda (e x-pat y-pat z-pat w r mod)
2711 (let f ((e e) (w w))
2714 (call-with-values (lambda () (f (cdr e) w))
2715 (lambda (xr* y-pat r)
2718 (let ((xr (match (car e) x-pat w '() mod)))
2720 (values (cons xr xr*) y-pat r)
2725 (match (car e) (car y-pat) w r mod)))
2726 (values #f #f #f)))))
2728 (f (syntax-object-expression e) (join-wraps w e)))
2730 (values '() y-pat (match e z-pat w r mod)))))))
2732 (define match-each-any
2736 (let ((l (match-each-any (cdr e) w mod)))
2737 (and l (cons (wrap (car e) w mod) l))))
2740 (match-each-any (syntax-object-expression e)
2741 (join-wraps w (syntax-object-wrap e))
2750 ((eq? p 'any) (cons '() r))
2751 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2752 ((eq? p 'each-any) (cons '() r))
2754 (case (vector-ref p 0)
2755 ((each) (match-empty (vector-ref p 1) r))
2756 ((each+) (match-empty (vector-ref p 1)
2758 (reverse (vector-ref p 2))
2759 (match-empty (vector-ref p 3) r))))
2761 ((vector) (match-empty (vector-ref p 1) r)))))))
2765 (if (null? (car r*))
2767 (cons (map car r*) (combine (map cdr r*) r)))))
2770 (lambda (e p w r mod)
2772 ((null? p) (and (null? e) r))
2774 (and (pair? e) (match (car e) (car p) w
2775 (match (cdr e) (cdr p) w r mod)
2778 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2780 (case (vector-ref p 0)
2783 (match-empty (vector-ref p 1) r)
2784 (let ((l (match-each e (vector-ref p 1) w mod)))
2786 (let collect ((l l))
2789 (cons (map car l) (collect (map cdr l)))))))))
2793 (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
2794 (lambda (xr* y-pat r)
2798 (match-empty (vector-ref p 1) r)
2799 (combine xr* r))))))
2800 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2801 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2804 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2807 (lambda (e p w r mod)
2811 ((eq? p 'any) (cons (wrap e w mod) r))
2814 (syntax-object-expression e)
2816 (join-wraps w (syntax-object-wrap e))
2818 (syntax-object-module e)))
2819 (else (match* e p w r mod)))))
2824 ((eq? p 'any) (list e))
2827 (match* (syntax-object-expression e)
2828 p (syntax-object-wrap e) '() (syntax-object-module e)))
2829 (else (match* e p empty-wrap '() #f))))))))
2832 (define-syntax with-syntax
2836 #'(let () e1 e2 ...))
2837 ((_ ((out in)) e1 e2 ...)
2838 #'(syntax-case in ()
2839 (out (let () e1 e2 ...))))
2840 ((_ ((out in) ...) e1 e2 ...)
2841 #'(syntax-case (list in ...) ()
2842 ((out ...) (let () e1 e2 ...)))))))
2844 (define-syntax syntax-error
2847 ;; Extended internal syntax which provides the original form
2848 ;; as the first operand, for improved error reporting.
2849 ((_ (keyword . operands) message arg ...)
2850 (string? (syntax->datum #'message))
2851 (syntax-violation (syntax->datum #'keyword)
2852 (string-join (cons (syntax->datum #'message)
2857 (and (syntax->datum #'keyword)
2858 #'(keyword . operands))))
2859 ;; Standard R7RS syntax
2860 ((_ message arg ...)
2861 (string? (syntax->datum #'message))
2862 #'(syntax-error (#f) message arg ...)))))
2864 (define-syntax syntax-rules
2866 (define (expand-clause clause)
2867 ;; Convert a 'syntax-rules' clause into a 'syntax-case' clause.
2868 (syntax-case clause (syntax-error)
2869 ;; If the template is a 'syntax-error' form, use the extended
2870 ;; internal syntax, which adds the original form as the first
2871 ;; operand for improved error reporting.
2872 (((keyword . pattern) (syntax-error message arg ...))
2873 (string? (syntax->datum #'message))
2874 #'((dummy . pattern) #'(syntax-error (dummy . pattern) message arg ...)))
2876 (((keyword . pattern) template)
2877 #'((dummy . pattern) #'template))))
2878 (define (expand-syntax-rules dots keys docstrings clauses)
2881 ((docstring ...) docstrings)
2882 ((((keyword . pattern) template) ...) clauses)
2883 ((clause ...) (map expand-clause clauses)))
2885 ((form #'(lambda (x)
2886 docstring ... ; optional docstring
2887 #((macro-type . syntax-rules)
2888 (patterns pattern ...)) ; embed patterns as procedure metadata
2889 (syntax-case x (k ...)
2892 (with-syntax ((dots dots))
2893 #'(with-ellipsis dots form))
2896 ((_ (k ...) ((keyword . pattern) template) ...)
2897 (expand-syntax-rules #f #'(k ...) #'() #'(((keyword . pattern) template) ...)))
2898 ((_ (k ...) docstring ((keyword . pattern) template) ...)
2899 (string? (syntax->datum #'docstring))
2900 (expand-syntax-rules #f #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...)))
2901 ((_ dots (k ...) ((keyword . pattern) template) ...)
2902 (identifier? #'dots)
2903 (expand-syntax-rules #'dots #'(k ...) #'() #'(((keyword . pattern) template) ...)))
2904 ((_ dots (k ...) docstring ((keyword . pattern) template) ...)
2905 (and (identifier? #'dots) (string? (syntax->datum #'docstring)))
2906 (expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))))))
2908 (define-syntax define-syntax-rule
2911 ((_ (name . pattern) template)
2912 #'(define-syntax name
2914 ((_ . pattern) template))))
2915 ((_ (name . pattern) docstring template)
2916 (string? (syntax->datum #'docstring))
2917 #'(define-syntax name
2920 ((_ . pattern) template)))))))
2925 ((let* ((x v) ...) e1 e2 ...)
2926 (and-map identifier? #'(x ...))
2927 (let f ((bindings #'((x v) ...)))
2928 (if (null? bindings)
2929 #'(let () e1 e2 ...)
2930 (with-syntax ((body (f (cdr bindings)))
2931 (binding (car bindings)))
2932 #'(let (binding) body))))))))
2934 (define-syntax quasiquote
2936 (define (quasi p lev)
2937 (syntax-case p (unquote quasiquote)
2941 (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
2942 ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
2944 (syntax-case #'p (unquote unquote-splicing)
2947 (quasilist* #'(("value" p) ...) (quasi #'q lev))
2949 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2951 ((unquote-splicing p ...)
2953 (quasiappend #'(("value" p) ...) (quasi #'q lev))
2955 (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
2957 (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
2958 (#(x ...) (quasivector (vquasi #'(x ...) lev)))
2960 (define (vquasi p lev)
2963 (syntax-case #'p (unquote unquote-splicing)
2966 (quasilist* #'(("value" p) ...) (vquasi #'q lev))
2968 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2970 ((unquote-splicing p ...)
2972 (quasiappend #'(("value" p) ...) (vquasi #'q lev))
2975 #'("quote" unquote-splicing)
2976 (quasi #'(p ...) (- lev 1)))
2978 (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
2979 (() #'("quote" ()))))
2980 (define (quasicons x y)
2981 (with-syntax ((x x) (y y))
2985 (("quote" dx) #'("quote" (dx . dy)))
2986 (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
2987 (("list" . stuff) #'("list" x . stuff))
2988 (("list*" . stuff) #'("list*" x . stuff))
2989 (_ #'("list*" x y)))))
2990 (define (quasiappend x y)
2994 ((null? x) #'("quote" ()))
2995 ((null? (cdr x)) (car x))
2996 (else (with-syntax (((p ...) x)) #'("append" p ...)))))
3000 (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
3001 (define (quasilist* x y)
3005 (quasicons (car x) (f (cdr x))))))
3006 (define (quasivector x)
3008 (("quote" (x ...)) #'("quote" #(x ...)))
3010 (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
3012 (("quote" (y ...)) (k #'(("quote" y) ...)))
3013 (("list" y ...) (k #'(y ...)))
3014 (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
3015 (else #`("list->vector" #,x)))))))
3019 (("list" x ...) #`(list #,@(map emit #'(x ...))))
3020 ;; could emit list* for 3+ arguments if implementation supports
3023 (let f ((x* #'(x ...)))
3026 #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
3027 (("append" x ...) #`(append #,@(map emit #'(x ...))))
3028 (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
3029 (("list->vector" x) #`(list->vector #,(emit #'x)))
3033 ;; convert to intermediate language, combining introduced (but
3034 ;; not unquoted source) quote expressions where possible and
3035 ;; choosing optimal construction code otherwise, then emit
3036 ;; Scheme code corresponding to the intermediate language forms.
3037 ((_ e) (emit (quasi #'e 0)))))))
3039 (define-syntax include
3043 (let* ((p (open-input-file
3044 (cond ((absolute-file-name? fn)
3047 (in-vicinity dir fn))
3051 "relative file name only allowed when the include form is in a file"
3053 (enc (file-encoding p)))
3055 ;; Choose the input encoding deterministically.
3056 (set-port-encoding! p (or enc "UTF-8"))
3058 (let f ((x (read p))
3062 (close-input-port p)
3065 (cons (datum->syntax k x) result)))))))
3066 (let* ((src (syntax-source x))
3067 (file (and src (assq-ref src 'filename)))
3068 (dir (and (string? file) (dirname file))))
3071 (let ((fn (syntax->datum #'filename)))
3072 (with-syntax (((exp ...) (read-file fn dir #'filename)))
3073 #'(begin exp ...))))))))
3075 (define-syntax include-from-path
3079 (let ((fn (syntax->datum #'filename)))
3080 (with-syntax ((fn (datum->syntax
3082 (or (%search-load-path fn)
3083 (syntax-violation 'include-from-path
3084 "file not found in path"
3086 #'(include fn)))))))
3088 (define-syntax unquote
3090 (syntax-violation 'unquote
3091 "expression not valid outside of quasiquote"
3094 (define-syntax unquote-splicing
3096 (syntax-violation 'unquote-splicing
3097 "expression not valid outside of quasiquote"
3100 (define (make-variable-transformer proc)
3101 (if (procedure? proc)
3102 (let ((trans (lambda (x)
3103 #((macro-type . variable-transformer))
3105 (set-procedure-property! trans 'variable-transformer #t)
3107 (error "variable transformer not a procedure" proc)))
3109 (define-syntax identifier-syntax
3111 (syntax-case xx (set!)
3114 #((macro-type . identifier-syntax))
3120 #'(e x (... ...))))))
3121 ((_ (id exp1) ((set! var val) exp2))
3122 (and (identifier? #'id) (identifier? #'var))
3123 #'(make-variable-transformer
3125 #((macro-type . variable-transformer))
3126 (syntax-case x (set!)
3127 ((set! var val) #'exp2)
3128 ((id x (... ...)) #'(exp1 x (... ...)))
3129 (id (identifier? #'id) #'exp1))))))))
3131 (define-syntax define*
3134 ((_ (id . args) b0 b1 ...)
3135 #'(define id (lambda* args b0 b1 ...)))
3136 ((_ id val) (identifier? #'id)
3137 #'(define id val)))))