3 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011 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 ;;; Originally extracted from Chez Scheme Version 5.9f
23 ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
25 ;;; Copyright (c) 1992-1997 Cadence Research Systems
26 ;;; Permission to copy this software, in whole or in part, to use this
27 ;;; software for any lawful purpose, and to redistribute this software
28 ;;; is granted subject to the restriction that all copies made of this
29 ;;; software must include this copyright notice in full. This software
30 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
31 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
32 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
33 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
34 ;;; NATURE WHATSOEVER.
36 ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
37 ;;; to the ChangeLog distributed in the same directory as this file:
38 ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
39 ;;; 2000-09-12, 2001-03-08
41 ;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
42 ;;; revision control logs corresponding to this file: 2009, 2010.
45 ;;; This file defines the syntax-case expander, macroexpand, and a set
46 ;;; of associated syntactic forms and procedures. Of these, the
47 ;;; following are documented in The Scheme Programming Language,
48 ;;; Fourth Edition (R. Kent Dybvig, MIT Press, 2009), and in the
51 ;;; bound-identifier=?
56 ;;; generate-temporaries
67 ;;; Additionally, the expander provides definitions for a number of core
68 ;;; Scheme syntactic bindings, such as `let', `lambda', and the like.
70 ;;; The remaining exports are listed below:
72 ;;; (macroexpand datum)
73 ;;; if datum represents a valid expression, macroexpand returns an
74 ;;; expanded version of datum in a core language that includes no
75 ;;; syntactic abstractions. The core language includes begin,
76 ;;; define, if, lambda, letrec, quote, and set!.
77 ;;; (eval-when situations expr ...)
78 ;;; conditionally evaluates expr ... at compile-time or run-time
79 ;;; depending upon situations (see the Chez Scheme System Manual,
80 ;;; Revision 3, for a complete description)
81 ;;; (syntax-violation who message form [subform])
82 ;;; used to report errors found during expansion
83 ;;; ($sc-dispatch e p)
84 ;;; used by expanded code to handle syntax-case matching
86 ;;; This file is shipped along with an expanded version of itself,
87 ;;; psyntax-pp.scm, which is loaded when psyntax.scm has not yet been
88 ;;; compiled. In this way, psyntax bootstraps off of an expanded
89 ;;; version of itself.
91 ;;; This implementation of the expander sometimes uses syntactic
92 ;;; abstractions when procedural abstractions would suffice. For
93 ;;; example, we define top-wrap and top-marked? as
95 ;;; (define-syntax top-wrap (identifier-syntax '((top))))
96 ;;; (define-syntax top-marked?
98 ;;; ((_ w) (memq 'top (wrap-marks w)))))
102 ;;; (define top-wrap '((top)))
103 ;;; (define top-marked?
104 ;;; (lambda (w) (memq 'top (wrap-marks w))))
106 ;;; On the other hand, we don't do this consistently; we define
107 ;;; make-wrap, wrap-marks, and wrap-subst simply as
109 ;;; (define make-wrap cons)
110 ;;; (define wrap-marks car)
111 ;;; (define wrap-subst cdr)
113 ;;; In Chez Scheme, the syntactic and procedural forms of these
114 ;;; abstractions are equivalent, since the optimizer consistently
115 ;;; integrates constants and small procedures. This will be true of
116 ;;; Guile as well, once we implement a proper inliner.
119 ;;; Implementation notes:
121 ;;; Objects with no standard print syntax, including objects containing
122 ;;; cycles and syntax object, are allowed in quoted data as long as they
123 ;;; are contained within a syntax form or produced by datum->syntax.
124 ;;; Such objects are never copied.
126 ;;; All identifiers that don't have macro definitions and are not bound
127 ;;; lexically are assumed to be global variables.
129 ;;; Top-level definitions of macro-introduced identifiers are allowed.
130 ;;; This may not be appropriate for implementations in which the
131 ;;; model is that bindings are created by definitions, as opposed to
132 ;;; one in which initial values are assigned by definitions.
134 ;;; Identifiers and syntax objects are implemented as vectors for
135 ;;; portability. As a result, it is possible to "forge" syntax objects.
137 ;;; The implementation of generate-temporaries assumes that it is
138 ;;; possible to generate globally unique symbols (gensyms).
140 ;;; The source location associated with incoming expressions is tracked
141 ;;; via the source-properties mechanism, a weak map from expression to
142 ;;; source information. At times the source is separated from the
143 ;;; expression; see the note below about "efficiency and confusion".
148 ;;; When changing syntax-object representations, it is necessary to support
149 ;;; both old and new syntax-object representations in id-var-name. It
150 ;;; should be sufficient to recognize old representations and treat
151 ;;; them as not lexically bound.
156 (set-current-module (resolve-module '(guile))))
159 ;; Private version of and-map that handles multiple lists.
161 (lambda (f first . rest)
164 (let andmap ((first first))
165 (let ((x (car first)) (first (cdr first)))
168 (and (f x) (andmap first)))))
169 (let andmap ((first first) (rest rest))
170 (let ((x (car first))
173 (rest (map cdr rest)))
176 (and (apply f x xr) (andmap first rest)))))))))
178 (define-syntax define-expansion-constructors
182 (let lp ((n 0) (out '()))
183 (if (< n (vector-length %expanded-vtables))
185 (let* ((vtable (vector-ref %expanded-vtables n))
186 (stem (struct-ref vtable (+ vtable-offset-user 0)))
187 (fields (struct-ref vtable (+ vtable-offset-user 2)))
188 (sfields (map (lambda (f) (datum->syntax x f)) fields))
189 (ctor (datum->syntax x (symbol-append 'make- stem))))
190 (cons #`(define (#,ctor #,@sfields)
191 (make-struct (vector-ref %expanded-vtables #,n) 0
194 #`(begin #,@(reverse out))))))))
196 (define-syntax define-expansion-accessors
201 (let ((vtable (vector-ref %expanded-vtables n))
202 (stem (syntax->datum #'stem)))
203 (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
205 (define (#,(datum->syntax x (symbol-append stem '?)) x)
207 (eq? (struct-vtable x)
208 (vector-ref %expanded-vtables #,n))))
211 (let ((get (datum->syntax x (symbol-append stem '- f)))
212 (set (datum->syntax x (symbol-append 'set- stem '- f '!)))
213 (idx (list-index (struct-ref vtable
214 (+ vtable-offset-user 2))
218 (struct-ref x #,idx))
220 (struct-set! x #,idx v)))))
221 (syntax->datum #'(field ...))))
224 (define-syntax define-structure
226 (define construct-name
227 (lambda (template-identifier . args)
235 (symbol->string (syntax->datum x))))
239 (and-map identifier? #'(name id1 ...))
241 ((constructor (construct-name #'name "make-" #'name))
242 (predicate (construct-name #'name #'name "?"))
244 (map (lambda (x) (construct-name x #'name "-" x))
248 (construct-name x "set-" #'name "-" x "!"))
251 (+ (length #'(id1 ...)) 1))
253 (let f ((i 1) (ids #'(id1 ...)))
256 (cons i (f (+ i 1) (cdr ids)))))))
260 (vector 'name id1 ... )))
264 (= (vector-length x) structure-length)
265 (eq? (vector-ref x 0) 'name))))
268 (vector-ref x index)))
272 (vector-set! x index update)))
276 (define-expansion-constructors)
277 (define-expansion-accessors lambda meta)
279 ;; hooks to nonportable run-time helpers
286 (define top-level-eval-hook
290 (define local-eval-hook
294 (define-syntax gensym-hook
298 (define put-global-definition-hook
299 (lambda (symbol type val)
300 (module-define! (current-module)
302 (make-syntax-transformer symbol type val))))
304 (define get-global-definition-hook
305 (lambda (symbol module)
306 (if (and (not module) (current-module))
307 (warn "module system is booted, we should have a module" symbol))
308 (let ((v (module-variable (if module
309 (resolve-module (cdr module))
312 (and v (variable-bound? v)
313 (let ((val (variable-ref v)))
314 (and (macro? val) (macro-type val)
315 (cons (macro-type val)
316 (macro-binding val)))))))))
319 (define (decorate-source e s)
320 (if (and (pair? e) s)
321 (set-source-properties! e s))
324 (define (maybe-name-value! name val)
326 (let ((meta (lambda-meta val)))
327 (if (not (assq 'name meta))
328 (set-lambda-meta! val (acons 'name name meta))))))
330 ;; output constructors
335 (define build-application
336 (lambda (source fun-exp arg-exps)
337 (make-application source fun-exp arg-exps)))
339 (define build-conditional
340 (lambda (source test-exp then-exp else-exp)
341 (make-conditional source test-exp then-exp else-exp)))
344 (lambda (source fluids vals body)
345 (make-dynlet source fluids vals body)))
347 (define build-lexical-reference
348 (lambda (type source name var)
349 (make-lexical-ref source name var)))
351 (define build-lexical-assignment
352 (lambda (source name var exp)
353 (maybe-name-value! name exp)
354 (make-lexical-set source name var exp)))
356 (define (analyze-variable mod var modref-cont bare-cont)
359 (let ((kind (car mod))
362 ((public) (modref-cont mod var #t))
363 ((private) (if (not (equal? mod (module-name (current-module))))
364 (modref-cont mod var #f)
366 ((bare) (bare-cont var))
367 ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
368 (module-variable (resolve-module mod) var))
369 (modref-cont mod var #f)
371 (else (syntax-violation #f "bad module kind" var mod))))))
373 (define build-global-reference
374 (lambda (source var mod)
377 (lambda (mod var public?)
378 (make-module-ref source mod var public?))
380 (make-toplevel-ref source var)))))
382 (define build-global-assignment
383 (lambda (source var exp mod)
384 (maybe-name-value! var exp)
387 (lambda (mod var public?)
388 (make-module-set source mod var public? exp))
390 (make-toplevel-set source var exp)))))
392 (define build-global-definition
393 (lambda (source var exp)
394 (maybe-name-value! var exp)
395 (make-toplevel-define source var exp)))
397 (define build-simple-lambda
398 (lambda (src req rest vars meta exp)
401 ;; hah, a case in which kwargs would be nice.
403 ;; src req opt rest kw inits vars body else
404 src req #f rest #f '() vars exp #f))))
406 (define build-case-lambda
407 (lambda (src meta body)
408 (make-lambda src meta body)))
410 (define build-lambda-case
412 ;; opt := (name ...) | #f
414 ;; kw := (allow-other-keys? (keyword name var) ...) | #f
417 ;; vars map to named arguments in the following order:
418 ;; required, optional (positional), rest, keyword.
419 ;; the body of a lambda: anything, already expanded
420 ;; else: lambda-case | #f
421 (lambda (src req opt rest kw inits vars body else-case)
422 (make-lambda-case src req opt rest kw inits vars body else-case)))
424 (define build-primref
426 (if (equal? (module-name (current-module)) '(guile))
427 (make-toplevel-ref src name)
428 (make-module-ref src '(guile) name #f))))
430 (define (build-data src exp)
431 (make-const src exp))
433 (define build-sequence
435 (if (null? (cdr exps))
437 (make-sequence src exps))))
440 (lambda (src ids vars val-exps body-exp)
441 (for-each maybe-name-value! ids val-exps)
444 (make-let src ids vars val-exps body-exp))))
446 (define build-named-let
447 (lambda (src ids vars val-exps body-exp)
452 (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
453 (maybe-name-value! f-name proc)
454 (for-each maybe-name-value! ids val-exps)
457 (list f-name) (list f) (list proc)
458 (build-application src (build-lexical-reference 'fun src f-name f)
462 (lambda (src in-order? ids vars val-exps body-exp)
466 (for-each maybe-name-value! ids val-exps)
467 (make-letrec src in-order? ids vars val-exps body-exp)))))
470 ;; FIXME: use a faster gensym
471 (define-syntax build-lexical-var
473 ((_ src id) (gensym (string-append (symbol->string id) " ")))))
475 (define-structure (syntax-object expression wrap module))
477 (define-syntax no-source (identifier-syntax #f))
479 (define source-annotation
483 (source-annotation (syntax-object-expression x)))
484 ((pair? x) (let ((props (source-properties x)))
490 (define-syntax arg-check
494 (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
496 ;; compile-time environments
498 ;; wrap and environment comprise two level mapping.
499 ;; wrap : id --> label
500 ;; env : label --> <element>
502 ;; environments are represented in two parts: a lexical part and a global
503 ;; part. The lexical part is a simple list of associations from labels
504 ;; to bindings. The global part is implemented by
505 ;; {put,get}-global-definition-hook and associates symbols with
508 ;; global (assumed global variable) and displaced-lexical (see below)
509 ;; do not show up in any environment; instead, they are fabricated by
510 ;; lookup when it finds no other bindings.
512 ;; <environment> ::= ((<label> . <binding>)*)
514 ;; identifier bindings include a type and a value
516 ;; <binding> ::= (macro . <procedure>) macros
517 ;; (core . <procedure>) core forms
518 ;; (module-ref . <procedure>) @ or @@
521 ;; (define-syntax) define-syntax
522 ;; (local-syntax . rec?) let-syntax/letrec-syntax
523 ;; (eval-when) eval-when
524 ;; (syntax . (<var> . <level>)) pattern variables
525 ;; (global) assumed global variable
526 ;; (lexical . <var>) lexical variables
527 ;; (displaced-lexical) displaced lexicals
528 ;; <level> ::= <nonnegative integer>
529 ;; <var> ::= variable returned by build-lexical-var
531 ;; a macro is a user-defined syntactic-form. a core is a system-defined
532 ;; syntactic form. begin, define, define-syntax, and eval-when are
533 ;; treated specially since they are sensitive to whether the form is
534 ;; at top-level and (except for eval-when) can denote valid internal
537 ;; a pattern variable is a variable introduced by syntax-case and can
538 ;; be referenced only within a syntax form.
540 ;; any identifier for which no top-level syntax definition or local
541 ;; binding of any kind has been seen is assumed to be a global
544 ;; a lexical variable is a lambda- or letrec-bound variable.
546 ;; a displaced-lexical identifier is a lexical identifier removed from
547 ;; it's scope by the return of a syntax object containing the identifier.
548 ;; a displaced lexical can also appear when a letrec-syntax-bound
549 ;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
550 ;; a displaced lexical should never occur with properly written macros.
552 (define-syntax make-binding
553 (syntax-rules (quote)
554 ((_ type value) (cons type value))
556 ((_ type) (cons type '()))))
557 (define-syntax binding-type
560 (define-syntax binding-value
564 (define-syntax null-env (identifier-syntax '()))
567 (lambda (labels bindings r)
570 (extend-env (cdr labels) (cdr bindings)
571 (cons (cons (car labels) (car bindings)) r)))))
573 (define extend-var-env
574 ;; variant of extend-env that forms "lexical" binding
575 (lambda (labels vars r)
578 (extend-var-env (cdr labels) (cdr vars)
579 (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
581 ;; we use a "macros only" environment in expansion of local macro
582 ;; definitions so that their definitions can use local macros without
583 ;; attempting to use other lexical identifiers.
584 (define macros-only-env
589 (if (eq? (cadr a) 'macro)
590 (cons a (macros-only-env (cdr r)))
591 (macros-only-env (cdr r)))))))
594 ;; x may be a label or a symbol
595 ;; although symbols are usually global, we check the environment first
596 ;; anyway because a temporary binding may have been established by
602 (or (get-global-definition-hook x mod) (make-binding 'global)))
603 (else (make-binding 'displaced-lexical)))))
605 (define global-extend
606 (lambda (type sym val)
607 (put-global-definition-hook sym type val)))
610 ;; Conceptually, identifiers are always syntax objects. Internally,
611 ;; however, the wrap is sometimes maintained separately (a source of
612 ;; efficiency and confusion), so that symbols are also considered
613 ;; identifiers by id?. Externally, they are always wrapped.
615 (define nonsymbol-id?
617 (and (syntax-object? x)
618 (symbol? (syntax-object-expression x)))))
624 ((syntax-object? x) (symbol? (syntax-object-expression x)))
627 (define-syntax id-sym-name
631 (if (syntax-object? x)
632 (syntax-object-expression x)
635 (define id-sym-name&marks
637 (if (syntax-object? x)
639 (syntax-object-expression x)
640 (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
641 (values x (wrap-marks w)))))
643 ;; syntax object wraps
645 ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
646 ;; <subst> ::= <shift> | <subs>
647 ;; <subs> ::= #(<old name> <label> (<mark> ...))
648 ;; <shift> ::= positive fixnum
650 (define-syntax make-wrap (identifier-syntax cons))
651 (define-syntax wrap-marks (identifier-syntax car))
652 (define-syntax wrap-subst (identifier-syntax cdr))
654 (define-syntax subst-rename? (identifier-syntax vector?))
655 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
656 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
657 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
658 (define-syntax make-rename
660 ((_ old new marks) (vector old new marks))))
662 ;; labels must be comparable with "eq?", have read-write invariance,
663 ;; and distinct from symbols.
665 (lambda () (symbol->string (gensym "i"))))
671 (cons (gen-label) (gen-labels (cdr ls))))))
673 (define-structure (ribcage symnames marks labels))
675 (define-syntax empty-wrap (identifier-syntax '(())))
677 (define-syntax top-wrap (identifier-syntax '((top))))
679 (define-syntax top-marked?
681 ((_ w) (memq 'top (wrap-marks w)))))
683 ;; Marks must be comparable with "eq?" and distinct from pairs and
684 ;; the symbol top. We do not use integers so that marks will remain
685 ;; unique even across file compiles.
687 (define-syntax the-anti-mark (identifier-syntax #f))
691 (make-wrap (cons the-anti-mark (wrap-marks w))
692 (cons 'shift (wrap-subst w)))))
694 (define-syntax new-mark
698 ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
699 ;; internal definitions, in which the ribcages are built incrementally
700 (define-syntax make-empty-ribcage
702 ((_) (make-ribcage '() '() '()))))
704 (define extend-ribcage!
705 ;; must receive ids with complete wraps
706 (lambda (ribcage id label)
707 (set-ribcage-symnames! ribcage
708 (cons (syntax-object-expression id)
709 (ribcage-symnames ribcage)))
710 (set-ribcage-marks! ribcage
711 (cons (wrap-marks (syntax-object-wrap id))
712 (ribcage-marks ribcage)))
713 (set-ribcage-labels! ribcage
714 (cons label (ribcage-labels ribcage)))))
716 ;; make-binding-wrap creates vector-based ribcages
717 (define make-binding-wrap
718 (lambda (ids labels w)
724 (let ((labelvec (list->vector labels)))
725 (let ((n (vector-length labelvec)))
726 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
727 (let f ((ids ids) (i 0))
728 (if (not (null? ids))
730 (lambda () (id-sym-name&marks (car ids) w))
731 (lambda (symname marks)
732 (vector-set! symnamevec i symname)
733 (vector-set! marksvec i marks)
734 (f (cdr ids) (fx+ i 1))))))
735 (make-ribcage symnamevec marksvec labelvec))))
746 (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
752 (smart-append s1 (wrap-subst w2))))
754 (smart-append m1 (wrap-marks w2))
755 (smart-append s1 (wrap-subst w2)))))))
759 (smart-append m1 m2)))
766 (eq? (car x) (car y))
767 (same-marks? (cdr x) (cdr y))))))
773 ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
775 (lambda (sym subst marks)
778 (let ((fst (car subst)))
780 (search sym (cdr subst) (cdr marks))
781 (let ((symnames (ribcage-symnames fst)))
782 (if (vector? symnames)
783 (search-vector-rib sym subst marks symnames fst)
784 (search-list-rib sym subst marks symnames fst))))))))
785 (define search-list-rib
786 (lambda (sym subst marks symnames ribcage)
787 (let f ((symnames symnames) (i 0))
789 ((null? symnames) (search sym (cdr subst) marks))
790 ((and (eq? (car symnames) sym)
791 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
792 (values (list-ref (ribcage-labels ribcage) i) marks))
793 (else (f (cdr symnames) (fx+ i 1)))))))
794 (define search-vector-rib
795 (lambda (sym subst marks symnames ribcage)
796 (let ((n (vector-length symnames)))
799 ((fx= i n) (search sym (cdr subst) marks))
800 ((and (eq? (vector-ref symnames i) sym)
801 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
802 (values (vector-ref (ribcage-labels ribcage) i) marks))
803 (else (f (fx+ i 1))))))))
806 (or (first (search id (wrap-subst w) (wrap-marks w))) id))
808 (let ((id (syntax-object-expression id))
809 (w1 (syntax-object-wrap id)))
810 (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
811 (call-with-values (lambda () (search id (wrap-subst w) marks))
812 (lambda (new-id marks)
814 (first (search id (wrap-subst w1) marks))
816 (else (syntax-violation 'id-var-name "invalid id" id)))))
818 ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
819 ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
823 (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
824 (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
826 ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
827 ;; long as the missing portion of the wrap is common to both of the ids
828 ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
832 (if (and (syntax-object? i) (syntax-object? j))
833 (and (eq? (syntax-object-expression i)
834 (syntax-object-expression j))
835 (same-marks? (wrap-marks (syntax-object-wrap i))
836 (wrap-marks (syntax-object-wrap j))))
839 ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
840 ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
841 ;; as long as the missing portion of the wrap is common to all of the
844 (define valid-bound-ids?
846 (and (let all-ids? ((ids ids))
849 (all-ids? (cdr ids)))))
850 (distinct-bound-ids? ids))))
852 ;; distinct-bound-ids? expects a list of ids and returns #t if there are
853 ;; no duplicates. It is quadratic on the length of the id list; long
854 ;; lists could be sorted to make it more efficient. distinct-bound-ids?
855 ;; may be passed unwrapped (or partially wrapped) ids as long as the
856 ;; missing portion of the wrap is common to all of the ids.
858 (define distinct-bound-ids?
860 (let distinct? ((ids ids))
862 (and (not (bound-id-member? (car ids) (cdr ids)))
863 (distinct? (cdr ids)))))))
865 (define bound-id-member?
867 (and (not (null? list))
868 (or (bound-id=? x (car list))
869 (bound-id-member? x (cdr list))))))
871 ;; wrapping expressions and identifiers
876 ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
879 (syntax-object-expression x)
880 (join-wraps w (syntax-object-wrap x))
881 (syntax-object-module x)))
883 (else (make-syntax-object x w defmod)))))
886 (lambda (x w s defmod)
887 (wrap (decorate-source x s) w defmod)))
892 (lambda (body r w s mod)
894 (let dobody ((body body) (r r) (w w) (mod mod))
897 (let ((first (chi (car body) r w mod)))
898 (cons first (dobody (cdr body) r w mod))))))))
900 (define chi-top-sequence
901 (lambda (body r w s m esew mod)
902 (define (scan body r w s m esew mod exps)
903 (define-syntax eval-if-c&e
907 (if (eq? m 'c&e) (top-level-eval-hook x mod))
918 (let ((e (car body)))
919 (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
920 (lambda (type value e w s mod)
926 (scan #'(e1 e2 ...) r w s m esew mod exps))))
928 (chi-local-syntax value e r w s mod
929 (lambda (body r w s mod)
930 (scan body r w s m esew mod exps))))
933 ((_ (x ...) e1 e2 ...)
934 (let ((when-list (chi-when-list e #'(x ...) w))
935 (body #'(e1 e2 ...)))
938 (if (memq 'eval when-list)
940 (if (memq 'expand when-list) 'c&e 'e)
944 (if (memq 'expand when-list)
946 (chi-top-sequence body r w s 'e '(eval) mod)
949 ((memq 'load when-list)
950 (if (or (memq 'compile when-list)
951 (memq 'expand when-list)
952 (and (eq? m 'c&e) (memq 'eval when-list)))
953 (scan body r w s 'c&e '(compile load) mod exps)
954 (if (memq m '(c c&e))
955 (scan body r w s 'c '(load) mod exps)
957 ((or (memq 'compile when-list)
958 (memq 'expand when-list)
959 (and (eq? m 'c&e) (memq 'eval when-list)))
961 (chi-top-sequence body r w s 'e '(eval) mod)
966 ((define-syntax-form)
967 (let ((n (id-var-name value w)) (r (macros-only-env r)))
970 (if (memq 'compile esew)
971 (let ((e (chi-install-global n (chi e r w mod))))
972 (top-level-eval-hook e mod)
973 (if (memq 'load esew)
974 (values (cons e exps))
976 (if (memq 'load esew)
977 (values (cons (chi-install-global n (chi e r w mod))
981 (let ((e (chi-install-global n (chi e r w mod))))
982 (top-level-eval-hook e mod)
983 (values (cons e exps))))
985 (if (memq 'eval esew)
987 (chi-install-global n (chi e r w mod))
991 (let* ((n (id-var-name value w))
992 ;; Lookup the name in the module of the define form.
993 (type (binding-type (lookup n r mod))))
995 ((global core macro module-ref)
996 ;; affect compile-time environment (once we have booted)
997 (if (and (memq m '(c c&e))
998 (not (module-local-variable (current-module) n))
1000 (let ((old (module-variable (current-module) n)))
1001 ;; use value of the same-named imported variable, if
1003 (if (and (variable? old) (variable-bound? old))
1004 (module-define! (current-module) n (variable-ref old))
1005 (module-add! (current-module) n (make-undefined-variable)))))
1009 (build-global-definition s n (chi e r w mod))
1012 ((displaced-lexical)
1013 (syntax-violation #f "identifier out of context"
1014 e (wrap value w mod)))
1016 (syntax-violation #f "cannot define keyword at top level"
1017 e (wrap value w mod))))))
1020 (eval-if-c&e m (chi-expr type value e r w s mod) mod)
1023 (scan (cdr body) r w s m esew mod exps))))))
1025 (call-with-values (lambda ()
1026 (scan body r w s m esew mod '()))
1030 (build-sequence s (reverse exps)))))))
1032 (define chi-install-global
1034 (build-global-definition
1039 (build-primref no-source 'make-syntax-transformer)
1040 (list (build-data no-source name)
1041 (build-data no-source 'macro)
1044 (define chi-when-list
1045 (lambda (e when-list w)
1046 ;; when-list is syntax'd version of list of situations
1047 (let f ((when-list when-list) (situations '()))
1048 (if (null? when-list)
1051 (cons (let ((x (car when-list)))
1053 ((free-id=? x #'compile) 'compile)
1054 ((free-id=? x #'load) 'load)
1055 ((free-id=? x #'eval) 'eval)
1056 ((free-id=? x #'expand) 'expand)
1057 (else (syntax-violation 'eval-when
1062 ;; syntax-type returns six values: type, value, e, w, s, and mod. The
1063 ;; first two are described in the table below.
1065 ;; type value explanation
1066 ;; -------------------------------------------------------------------
1067 ;; core procedure core singleton
1068 ;; core-form procedure core form
1069 ;; module-ref procedure @ or @@ singleton
1070 ;; lexical name lexical variable reference
1071 ;; global name global variable reference
1072 ;; begin none begin keyword
1073 ;; define none define keyword
1074 ;; define-syntax none define-syntax keyword
1075 ;; local-syntax rec? letrec-syntax/let-syntax keyword
1076 ;; eval-when none eval-when keyword
1077 ;; syntax level pattern variable
1078 ;; displaced-lexical none displaced lexical identifier
1079 ;; lexical-call name call to lexical variable
1080 ;; global-call name call to global variable
1081 ;; call none any other call
1082 ;; begin-form none begin expression
1083 ;; define-form id variable definition
1084 ;; define-syntax-form id syntax definition
1085 ;; local-syntax-form rec? syntax definition
1086 ;; eval-when-form none eval-when form
1087 ;; constant none self-evaluating datum
1088 ;; other none anything else
1090 ;; For define-form and define-syntax-form, e is the rhs expression.
1091 ;; For all others, e is the entire form. w is the wrap for e.
1092 ;; s is the source for the entire form. mod is the module for e.
1094 ;; syntax-type expands macros and unwraps as necessary to get to
1095 ;; one of the forms above. It also parses define and define-syntax
1096 ;; forms, although perhaps this should be done by the consumer.
1099 (lambda (e r w s rib mod for-car?)
1102 (let* ((n (id-var-name e w))
1103 (b (lookup n r mod))
1104 (type (binding-type b)))
1106 ((lexical) (values type (binding-value b) e w s mod))
1107 ((global) (values type n e w s mod))
1110 (values type (binding-value b) e w s mod)
1111 (syntax-type (chi-macro (binding-value b) e r w s rib mod)
1112 r empty-wrap s rib mod #f)))
1113 (else (values type (binding-value b) e w s mod)))))
1115 (let ((first (car e)))
1117 (lambda () (syntax-type first r w s rib mod #t))
1118 (lambda (ftype fval fe fw fs fmod)
1121 (values 'lexical-call fval e w s mod))
1123 ;; If we got here via an (@@ ...) expansion, we need to
1124 ;; make sure the fmod information is propagated back
1125 ;; correctly -- hence this consing.
1126 (values 'global-call (make-syntax-object fval w fmod)
1129 (syntax-type (chi-macro fval e r w s rib mod)
1130 r empty-wrap s rib mod for-car?))
1132 (call-with-values (lambda () (fval e r w))
1133 (lambda (e r w s mod)
1134 (syntax-type e r w s rib mod for-car?))))
1136 (values 'core-form fval e w s mod))
1138 (values 'local-syntax-form fval e w s mod))
1140 (values 'begin-form #f e w s mod))
1142 (values 'eval-when-form #f e w s mod))
1147 (values 'define-form #'name #'val w s mod))
1148 ((_ (name . args) e1 e2 ...)
1150 (valid-bound-ids? (lambda-var-list #'args)))
1151 ;; need lambda here...
1152 (values 'define-form (wrap #'name w mod)
1154 (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
1159 (values 'define-form (wrap #'name w mod)
1161 empty-wrap s mod))))
1166 (values 'define-syntax-form #'name
1169 (values 'call #f e w s mod)))))))
1171 (syntax-type (syntax-object-expression e)
1173 (join-wraps w (syntax-object-wrap e))
1174 (or (source-annotation e) s) rib
1175 (or (syntax-object-module e) mod) for-car?))
1176 ((self-evaluating? e) (values 'constant #f e w s mod))
1177 (else (values 'other #f e w s mod)))))
1182 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
1183 (lambda (type value e w s mod)
1184 (chi-expr type value e r w s mod)))))
1187 (lambda (type value e r w s mod)
1190 (build-lexical-reference 'value s e value))
1192 ;; apply transformer
1193 (value e r w s mod))
1195 (call-with-values (lambda () (value e r w))
1196 (lambda (e r w s mod)
1201 (build-lexical-reference 'fun (source-annotation id)
1202 (if (syntax-object? id)
1209 (build-global-reference (source-annotation (car e))
1210 (if (syntax-object? value)
1211 (syntax-object-expression value)
1213 (if (syntax-object? value)
1214 (syntax-object-module value)
1217 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1218 ((global) (build-global-reference s value mod))
1219 ((call) (chi-application (chi (car e) r w mod) e r w s mod))
1222 ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
1223 ((local-syntax-form)
1224 (chi-local-syntax value e r w s mod chi-sequence))
1227 ((_ (x ...) e1 e2 ...)
1228 (let ((when-list (chi-when-list e #'(x ...) w)))
1229 (if (memq 'eval when-list)
1230 (chi-sequence #'(e1 e2 ...) r w s mod)
1232 ((define-form define-syntax-form)
1233 (syntax-violation #f "definition in expression context"
1234 e (wrap value w mod)))
1236 (syntax-violation #f "reference to pattern variable outside syntax form"
1237 (source-wrap e w s mod)))
1238 ((displaced-lexical)
1239 (syntax-violation #f "reference to identifier outside its scope"
1240 (source-wrap e w s mod)))
1241 (else (syntax-violation #f "unexpected syntax"
1242 (source-wrap e w s mod))))))
1244 (define chi-application
1245 (lambda (x e r w s mod)
1248 (build-application s x
1249 (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
1251 ;; (What follows is my interpretation of what's going on here -- Andy)
1253 ;; A macro takes an expression, a tree, the leaves of which are identifiers
1254 ;; and datums. Identifiers are symbols along with a wrap and a module. For
1255 ;; efficiency, subtrees that share wraps and modules may be grouped as one
1258 ;; Going into the expansion, the expression is given an anti-mark, which
1259 ;; logically propagates to all leaves. Then, in the new expression returned
1260 ;; from the transfomer, if we see an expression with an anti-mark, we know it
1261 ;; pertains to the original expression; conversely, expressions without the
1262 ;; anti-mark are known to be introduced by the transformer.
1264 ;; OK, good until now. We know this algorithm does lexical scoping
1265 ;; appropriately because it's widely known in the literature, and psyntax is
1266 ;; widely used. But what about modules? Here we're on our own. What we do is
1267 ;; to mark the module of expressions produced by a macro as pertaining to the
1268 ;; module that was current when the macro was defined -- that is, free
1269 ;; identifiers introduced by a macro are scoped in the macro's module, not in
1270 ;; the expansion's module. Seems to work well.
1272 ;; The only wrinkle is when we want a macro to expand to code in another
1273 ;; module, as is the case for the r6rs `library' form -- the body expressions
1274 ;; should be scoped relative the the new module, the one defined by the macro.
1275 ;; For that, use `(@@ mod-name body)'.
1277 ;; Part of the macro output will be from the site of the macro use and part
1278 ;; from the macro definition. We allow source information from the macro use
1279 ;; to pass through, but we annotate the parts coming from the macro with the
1280 ;; source location information corresponding to the macro use. It would be
1281 ;; really nice if we could also annotate introduced expressions with the
1282 ;; locations corresponding to the macro definition, but that is not yet
1285 (lambda (p e r w s rib mod)
1286 (define rebuild-macro-output
1290 (cons (rebuild-macro-output (car x) m)
1291 (rebuild-macro-output (cdr x) m))
1294 (let ((w (syntax-object-wrap x)))
1295 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1296 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1297 ;; output is from original text
1299 (syntax-object-expression x)
1300 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1301 (syntax-object-module x))
1302 ;; output introduced by macro
1304 (decorate-source (syntax-object-expression x) s)
1305 (make-wrap (cons m ms)
1307 (cons rib (cons 'shift s))
1309 (syntax-object-module x))))))
1312 (let* ((n (vector-length x))
1313 (v (decorate-source (make-vector n) x)))
1314 (do ((i 0 (fx+ i 1)))
1317 (rebuild-macro-output (vector-ref x i) m)))))
1319 (syntax-violation #f "encountered raw symbol in macro output"
1320 (source-wrap e w (wrap-subst w) mod) x))
1321 (else (decorate-source x s)))))
1322 (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
1326 ;; In processing the forms of the body, we create a new, empty wrap.
1327 ;; This wrap is augmented (destructively) each time we discover that
1328 ;; the next form is a definition. This is done:
1330 ;; (1) to allow the first nondefinition form to be a call to
1331 ;; one of the defined ids even if the id previously denoted a
1332 ;; definition keyword or keyword for a macro expanding into a
1334 ;; (2) to prevent subsequent definition forms (but unfortunately
1335 ;; not earlier ones) and the first nondefinition form from
1336 ;; confusing one of the bound identifiers for an auxiliary
1338 ;; (3) so that we do not need to restart the expansion of the
1339 ;; first nondefinition form, which is problematic anyway
1340 ;; since it might be the first element of a begin that we
1341 ;; have just spliced into the body (meaning if we restarted,
1342 ;; we'd really need to restart with the begin or the macro
1343 ;; call that expanded into the begin, and we'd have to give
1344 ;; up allowing (begin <defn>+ <expr>+), which is itself
1345 ;; problematic since we don't know if a begin contains only
1346 ;; definitions until we've expanded it).
1348 ;; Before processing the body, we also create a new environment
1349 ;; containing a placeholder for the bindings we will add later and
1350 ;; associate this environment with each form. In processing a
1351 ;; let-syntax or letrec-syntax, the associated environment may be
1352 ;; augmented with local keyword bindings, so the environment may
1353 ;; be different for different forms in the body. Once we have
1354 ;; gathered up all of the definitions, we evaluate the transformer
1355 ;; expressions and splice into r at the placeholder the new variable
1356 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1357 ;; forms local to a portion or all of the body to shadow the
1358 ;; definition bindings.
1360 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1363 ;; outer-form is fully wrapped w/source
1364 (lambda (body outer-form r w mod)
1365 (let* ((r (cons '("placeholder" . (placeholder)) r))
1366 (ribcage (make-empty-ribcage))
1367 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1368 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1369 (ids '()) (labels '())
1370 (var-ids '()) (vars '()) (vals '()) (bindings '()))
1372 (syntax-violation #f "no expressions in body" outer-form)
1373 (let ((e (cdar body)) (er (caar body)))
1375 (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
1376 (lambda (type value e w s mod)
1379 (let ((id (wrap value w mod)) (label (gen-label)))
1380 (let ((var (gen-var id)))
1381 (extend-ribcage! ribcage id label)
1383 (cons id ids) (cons label labels)
1385 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1386 (cons (make-binding 'lexical var) bindings)))))
1387 ((define-syntax-form)
1388 (let ((id (wrap value w mod)) (label (gen-label)))
1389 (extend-ribcage! ribcage id label)
1391 (cons id ids) (cons label labels)
1393 (cons (make-binding 'macro (cons er (wrap e w mod)))
1398 (parse (let f ((forms #'(e1 ...)))
1401 (cons (cons er (wrap (car forms) w mod))
1403 ids labels var-ids vars vals bindings))))
1404 ((local-syntax-form)
1405 (chi-local-syntax value e er w s mod
1406 (lambda (forms er w s mod)
1407 (parse (let f ((forms forms))
1410 (cons (cons er (wrap (car forms) w mod))
1412 ids labels var-ids vars vals bindings))))
1413 (else ; found a non-definition
1415 (build-sequence no-source
1417 (chi (cdr x) (car x) empty-wrap mod))
1418 (cons (cons er (source-wrap e w s mod))
1421 (if (not (valid-bound-ids? ids))
1423 #f "invalid or duplicate identifier in definition"
1425 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1426 (if (not (null? bs))
1427 (let* ((b (car bs)))
1428 (if (eq? (car b) 'macro)
1429 (let* ((er (cadr b))
1431 (if (eq? er er-cache)
1433 (macros-only-env er))))
1435 (eval-local-transformer
1436 (chi (cddr b) r-cache empty-wrap mod)
1438 (loop (cdr bs) er r-cache))
1439 (loop (cdr bs) er-cache r-cache)))))
1440 (set-cdr! r (extend-env labels bindings (cdr r)))
1441 (build-letrec no-source #t
1442 (reverse (map syntax->datum var-ids))
1445 (chi (cdr x) (car x) empty-wrap mod))
1447 (build-sequence no-source
1449 (chi (cdr x) (car x) empty-wrap mod))
1450 (cons (cons er (source-wrap e w s mod))
1451 (cdr body)))))))))))))))))
1453 (define chi-local-syntax
1454 (lambda (rec? e r w s mod k)
1456 ((_ ((id val) ...) e1 e2 ...)
1457 (let ((ids #'(id ...)))
1458 (if (not (valid-bound-ids? ids))
1459 (syntax-violation #f "duplicate bound keyword" e)
1460 (let ((labels (gen-labels ids)))
1461 (let ((new-w (make-binding-wrap ids labels w)))
1465 (let ((w (if rec? new-w w))
1466 (trans-r (macros-only-env r)))
1468 (make-binding 'macro
1469 (eval-local-transformer
1470 (chi x trans-r w mod)
1477 (_ (syntax-violation #f "bad local syntax definition"
1478 (source-wrap e w s mod))))))
1480 (define eval-local-transformer
1481 (lambda (expanded mod)
1482 (let ((p (local-eval-hook expanded mod)))
1485 (syntax-violation #f "nonprocedure transformer" p)))))
1489 (build-void no-source)))
1493 (and (nonsymbol-id? x)
1494 (free-id=? x #'(... ...)))))
1496 (define lambda-formals
1498 (define (req args rreq)
1499 (syntax-case args ()
1501 (check (reverse rreq) #f))
1503 (req #'b (cons #'a rreq)))
1505 (check (reverse rreq) #'r))
1507 (syntax-violation 'lambda "invalid argument list" orig-args args))))
1508 (define (check req rest)
1510 ((distinct-bound-ids? (if rest (cons rest req) req))
1511 (values req #f rest #f))
1513 (syntax-violation 'lambda "duplicate identifier in argument list"
1515 (req orig-args '())))
1517 (define chi-simple-lambda
1518 (lambda (e r w s mod req rest meta body)
1519 (let* ((ids (if rest (append req (list rest)) req))
1520 (vars (map gen-var ids))
1521 (labels (gen-labels ids)))
1522 (build-simple-lambda
1524 (map syntax->datum req) (and rest (syntax->datum rest)) vars
1526 (chi-body body (source-wrap e w s mod)
1527 (extend-var-env labels vars r)
1528 (make-binding-wrap ids labels w)
1531 (define lambda*-formals
1533 (define (req args rreq)
1534 (syntax-case args ()
1536 (check (reverse rreq) '() #f '()))
1538 (req #'b (cons #'a rreq)))
1539 ((a . b) (eq? (syntax->datum #'a) #:optional)
1540 (opt #'b (reverse rreq) '()))
1541 ((a . b) (eq? (syntax->datum #'a) #:key)
1542 (key #'b (reverse rreq) '() '()))
1543 ((a b) (eq? (syntax->datum #'a) #:rest)
1544 (rest #'b (reverse rreq) '() '()))
1546 (rest #'r (reverse rreq) '() '()))
1548 (syntax-violation 'lambda* "invalid argument list" orig-args args))))
1549 (define (opt args req ropt)
1550 (syntax-case args ()
1552 (check req (reverse ropt) #f '()))
1554 (opt #'b req (cons #'(a #f) ropt)))
1555 (((a init) . b) (id? #'a)
1556 (opt #'b req (cons #'(a init) ropt)))
1557 ((a . b) (eq? (syntax->datum #'a) #:key)
1558 (key #'b req (reverse ropt) '()))
1559 ((a b) (eq? (syntax->datum #'a) #:rest)
1560 (rest #'b req (reverse ropt) '()))
1562 (rest #'r req (reverse ropt) '()))
1564 (syntax-violation 'lambda* "invalid optional argument list"
1566 (define (key args req opt rkey)
1567 (syntax-case args ()
1569 (check req opt #f (cons #f (reverse rkey))))
1571 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1572 (key #'b req opt (cons #'(k a #f) rkey))))
1573 (((a init) . b) (id? #'a)
1574 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1575 (key #'b req opt (cons #'(k a init) rkey))))
1576 (((a init k) . b) (and (id? #'a)
1577 (keyword? (syntax->datum #'k)))
1578 (key #'b req opt (cons #'(k a init) rkey)))
1579 ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
1580 (check req opt #f (cons #t (reverse rkey))))
1581 ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1582 (eq? (syntax->datum #'a) #:rest))
1583 (rest #'b req opt (cons #t (reverse rkey))))
1584 ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1586 (rest #'r req opt (cons #t (reverse rkey))))
1587 ((a b) (eq? (syntax->datum #'a) #:rest)
1588 (rest #'b req opt (cons #f (reverse rkey))))
1590 (rest #'r req opt (cons #f (reverse rkey))))
1592 (syntax-violation 'lambda* "invalid keyword argument list"
1594 (define (rest args req opt kw)
1595 (syntax-case args ()
1597 (check req opt #'r kw))
1599 (syntax-violation 'lambda* "invalid rest argument"
1601 (define (check req opt rest kw)
1603 ((distinct-bound-ids?
1604 (append req (map car opt) (if rest (list rest) '())
1605 (if (pair? kw) (map cadr (cdr kw)) '())))
1606 (values req opt rest kw))
1608 (syntax-violation 'lambda* "duplicate identifier in argument list"
1610 (req orig-args '())))
1612 (define chi-lambda-case
1613 (lambda (e r w s mod get-formals clauses)
1614 (define (expand-req req opt rest kw body)
1615 (let ((vars (map gen-var req))
1616 (labels (gen-labels req)))
1617 (let ((r* (extend-var-env labels vars r))
1618 (w* (make-binding-wrap req labels w)))
1619 (expand-opt (map syntax->datum req)
1620 opt rest kw body (reverse vars) r* w* '() '()))))
1621 (define (expand-opt req opt rest kw body vars r* w* out inits)
1624 (syntax-case (car opt) ()
1626 (let* ((v (gen-var #'id))
1627 (l (gen-labels (list v)))
1628 (r** (extend-var-env l (list v) r*))
1629 (w** (make-binding-wrap (list #'id) l w*)))
1630 (expand-opt req (cdr opt) rest kw body (cons v vars)
1631 r** w** (cons (syntax->datum #'id) out)
1632 (cons (chi #'i r* w* mod) inits))))))
1634 (let* ((v (gen-var rest))
1635 (l (gen-labels (list v)))
1636 (r* (extend-var-env l (list v) r*))
1637 (w* (make-binding-wrap (list rest) l w*)))
1638 (expand-kw req (if (pair? out) (reverse out) #f)
1639 (syntax->datum rest)
1640 (if (pair? kw) (cdr kw) kw)
1641 body (cons v vars) r* w*
1642 (if (pair? kw) (car kw) #f)
1645 (expand-kw req (if (pair? out) (reverse out) #f) #f
1646 (if (pair? kw) (cdr kw) kw)
1648 (if (pair? kw) (car kw) #f)
1650 (define (expand-kw req opt rest kw body vars r* w* aok out inits)
1653 (syntax-case (car kw) ()
1655 (let* ((v (gen-var #'id))
1656 (l (gen-labels (list v)))
1657 (r** (extend-var-env l (list v) r*))
1658 (w** (make-binding-wrap (list #'id) l w*)))
1659 (expand-kw req opt rest (cdr kw) body (cons v vars)
1661 (cons (list (syntax->datum #'k)
1662 (syntax->datum #'id)
1665 (cons (chi #'i r* w* mod) inits))))))
1667 (expand-body req opt rest
1668 (if (or aok (pair? out)) (cons aok (reverse out)) #f)
1669 body (reverse vars) r* w* (reverse inits) '()))))
1670 (define (expand-body req opt rest kw body vars r* w* inits meta)
1671 (syntax-case body ()
1672 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1673 (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1676 . ,(syntax->datum #'docstring))))))
1677 ((#((k . v) ...) e1 e2 ...)
1678 (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1679 (append meta (syntax->datum #'((k . v) ...)))))
1681 (values meta req opt rest kw inits vars
1682 (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
1685 (syntax-case clauses ()
1686 (() (values '() #f))
1687 (((args e1 e2 ...) (args* e1* e2* ...) ...)
1688 (call-with-values (lambda () (get-formals #'args))
1689 (lambda (req opt rest kw)
1690 (call-with-values (lambda ()
1691 (expand-req req opt rest kw #'(e1 e2 ...)))
1692 (lambda (meta req opt rest kw inits vars body)
1695 (chi-lambda-case e r w s mod get-formals
1696 #'((args* e1* e2* ...) ...)))
1697 (lambda (meta* else*)
1700 (build-lambda-case s req opt rest kw inits vars
1701 body else*))))))))))))
1705 ;; strips syntax-objects down to top-wrap
1707 ;; since only the head of a list is annotated by the reader, not each pair
1708 ;; in the spine, we also check for pairs whose cars are annotated in case
1709 ;; we've been passed the cdr of an annotated list
1718 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1720 (let ((a (f (car x))) (d (f (cdr x))))
1721 (if (and (eq? a (car x)) (eq? d (cdr x)))
1725 (let ((old (vector->list x)))
1726 (let ((new (map f old)))
1727 (if (and-map* eq? old new) x (list->vector new)))))
1730 ;; lexical variables
1734 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1735 (build-lexical-var no-source id))))
1737 ;; appears to return a reversed list
1738 (define lambda-var-list
1740 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1742 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1743 ((id? vars) (cons (wrap vars w #f) ls))
1745 ((syntax-object? vars)
1746 (lvl (syntax-object-expression vars)
1748 (join-wraps w (syntax-object-wrap vars))))
1749 ;; include anything else to be caught by subsequent error
1751 (else (cons vars ls))))))
1753 ;; core transformers
1755 (global-extend 'local-syntax 'letrec-syntax #t)
1756 (global-extend 'local-syntax 'let-syntax #f)
1758 (global-extend 'core 'fluid-let-syntax
1759 (lambda (e r w s mod)
1761 ((_ ((var val) ...) e1 e2 ...)
1762 (valid-bound-ids? #'(var ...))
1763 (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
1766 (case (binding-type (lookup n r mod))
1767 ((displaced-lexical)
1768 (syntax-violation 'fluid-let-syntax
1769 "identifier out of context"
1771 (source-wrap id w s mod)))))
1776 (source-wrap e w s mod)
1779 (let ((trans-r (macros-only-env r)))
1781 (make-binding 'macro
1782 (eval-local-transformer (chi x trans-r w mod)
1788 (_ (syntax-violation 'fluid-let-syntax "bad syntax"
1789 (source-wrap e w s mod))))))
1791 (global-extend 'core 'quote
1792 (lambda (e r w s mod)
1794 ((_ e) (build-data s (strip #'e w)))
1795 (_ (syntax-violation 'quote "bad syntax"
1796 (source-wrap e w s mod))))))
1798 (global-extend 'core 'syntax
1801 (lambda (src e r maps ellipsis? mod)
1803 (let ((label (id-var-name e empty-wrap)))
1804 ;; Mod does not matter, we are looking to see if
1805 ;; the id is lexical syntax.
1806 (let ((b (lookup label r mod)))
1807 (if (eq? (binding-type b) 'syntax)
1810 (let ((var.lev (binding-value b)))
1811 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1812 (lambda (var maps) (values `(ref ,var) maps)))
1814 (syntax-violation 'syntax "misplaced ellipsis" src)
1815 (values `(quote ,e) maps)))))
1819 (gen-syntax src #'e r maps (lambda (x) #f) mod))
1821 ;; this could be about a dozen lines of code, except that we
1822 ;; choose to handle #'(x ... ...) forms
1828 (gen-syntax src #'x r
1829 (cons '() maps) ellipsis? mod))
1831 (if (null? (car maps))
1832 (syntax-violation 'syntax "extra ellipsis"
1834 (values (gen-map x (car maps))
1842 (lambda () (k (cons '() maps)))
1844 (if (null? (car maps))
1845 (syntax-violation 'syntax "extra ellipsis" src)
1846 (values (gen-mappend x (car maps))
1848 (_ (call-with-values
1849 (lambda () (gen-syntax src y r maps ellipsis? mod))
1852 (lambda () (k maps))
1854 (values (gen-append x y) maps)))))))))
1857 (lambda () (gen-syntax src #'x r maps ellipsis? mod))
1860 (lambda () (gen-syntax src #'y r maps ellipsis? mod))
1861 (lambda (y maps) (values (gen-cons x y) maps))))))
1865 (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
1866 (lambda (e maps) (values (gen-vector e) maps))))
1867 (_ (values `(quote ,e) maps))))))
1870 (lambda (src var level maps)
1874 (syntax-violation 'syntax "missing ellipsis" src)
1876 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1877 (lambda (outer-var outer-maps)
1878 (let ((b (assq outer-var (car maps))))
1880 (values (cdr b) maps)
1881 (let ((inner-var (gen-var 'tmp)))
1883 (cons (cons (cons outer-var inner-var)
1885 outer-maps)))))))))))
1889 `(apply (primitive append) ,(gen-map e map-env))))
1893 (let ((formals (map cdr map-env))
1894 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1897 ;; identity map equivalence:
1898 ;; (map (lambda (x) x) y) == y
1901 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1903 ;; eta map equivalence:
1904 ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1905 `(map (primitive ,(car e))
1906 ,@(map (let ((r (map cons formals actuals)))
1907 (lambda (x) (cdr (assq (cadr x) r))))
1909 (else `(map (lambda ,formals ,e) ,@actuals))))))
1915 (if (eq? (car x) 'quote)
1916 `(quote (,(cadr x) . ,(cadr y)))
1917 (if (eq? (cadr y) '())
1920 ((list) `(list ,x ,@(cdr y)))
1921 (else `(cons ,x ,y)))))
1925 (if (equal? y '(quote ()))
1932 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1933 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1934 (else `(list->vector ,x)))))
1940 ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
1941 ((primitive) (build-primref no-source (cadr x)))
1942 ((quote) (build-data no-source (cadr x)))
1944 (if (list? (cadr x))
1945 (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
1946 (error "how did we get here" x)))
1947 (else (build-application no-source
1948 (build-primref no-source (car x))
1949 (map regen (cdr x)))))))
1951 (lambda (e r w s mod)
1952 (let ((e (source-wrap e w s mod)))
1956 (lambda () (gen-syntax e #'x r '() ellipsis? mod))
1957 (lambda (e maps) (regen e))))
1958 (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
1960 (global-extend 'core 'lambda
1961 (lambda (e r w s mod)
1964 (call-with-values (lambda () (lambda-formals #'args))
1965 (lambda (req opt rest kw)
1966 (let lp ((body #'(e1 e2 ...)) (meta '()))
1967 (syntax-case body ()
1968 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1972 . ,(syntax->datum #'docstring))))))
1973 ((#((k . v) ...) e1 e2 ...)
1975 (append meta (syntax->datum #'((k . v) ...)))))
1976 (_ (chi-simple-lambda e r w s mod req rest meta body)))))))
1977 (_ (syntax-violation 'lambda "bad lambda" e)))))
1979 (global-extend 'core 'lambda*
1980 (lambda (e r w s mod)
1985 (chi-lambda-case e r w s mod
1986 lambda*-formals #'((args e1 e2 ...))))
1987 (lambda (meta lcase)
1988 (build-case-lambda s meta lcase))))
1989 (_ (syntax-violation 'lambda "bad lambda*" e)))))
1991 (global-extend 'core 'case-lambda
1992 (lambda (e r w s mod)
1994 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
1997 (chi-lambda-case e r w s mod
1999 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2000 (lambda (meta lcase)
2001 (build-case-lambda s meta lcase))))
2002 (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
2004 (global-extend 'core 'case-lambda*
2005 (lambda (e r w s mod)
2007 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
2010 (chi-lambda-case e r w s mod
2012 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2013 (lambda (meta lcase)
2014 (build-case-lambda s meta lcase))))
2015 (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
2017 (global-extend 'core 'let
2019 (define (chi-let e r w s mod constructor ids vals exps)
2020 (if (not (valid-bound-ids? ids))
2021 (syntax-violation 'let "duplicate bound variable" e)
2022 (let ((labels (gen-labels ids))
2023 (new-vars (map gen-var ids)))
2024 (let ((nw (make-binding-wrap ids labels w))
2025 (nr (extend-var-env labels new-vars r)))
2027 (map syntax->datum ids)
2029 (map (lambda (x) (chi x r w mod)) vals)
2030 (chi-body exps (source-wrap e nw s mod)
2032 (lambda (e r w s mod)
2034 ((_ ((id val) ...) e1 e2 ...)
2035 (and-map id? #'(id ...))
2036 (chi-let e r w s mod
2041 ((_ f ((id val) ...) e1 e2 ...)
2042 (and (id? #'f) (and-map id? #'(id ...)))
2043 (chi-let e r w s mod
2048 (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
2051 (global-extend 'core 'letrec
2052 (lambda (e r w s mod)
2054 ((_ ((id val) ...) e1 e2 ...)
2055 (and-map id? #'(id ...))
2056 (let ((ids #'(id ...)))
2057 (if (not (valid-bound-ids? ids))
2058 (syntax-violation 'letrec "duplicate bound variable" e)
2059 (let ((labels (gen-labels ids))
2060 (new-vars (map gen-var ids)))
2061 (let ((w (make-binding-wrap ids labels w))
2062 (r (extend-var-env labels new-vars r)))
2064 (map syntax->datum ids)
2066 (map (lambda (x) (chi x r w mod)) #'(val ...))
2067 (chi-body #'(e1 e2 ...)
2068 (source-wrap e w s mod) r w mod)))))))
2069 (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
2072 (global-extend 'core 'letrec*
2073 (lambda (e r w s mod)
2075 ((_ ((id val) ...) e1 e2 ...)
2076 (and-map id? #'(id ...))
2077 (let ((ids #'(id ...)))
2078 (if (not (valid-bound-ids? ids))
2079 (syntax-violation 'letrec* "duplicate bound variable" e)
2080 (let ((labels (gen-labels ids))
2081 (new-vars (map gen-var ids)))
2082 (let ((w (make-binding-wrap ids labels w))
2083 (r (extend-var-env labels new-vars r)))
2085 (map syntax->datum ids)
2087 (map (lambda (x) (chi x r w mod)) #'(val ...))
2088 (chi-body #'(e1 e2 ...)
2089 (source-wrap e w s mod) r w mod)))))))
2090 (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
2093 (global-extend 'core 'set!
2094 (lambda (e r w s mod)
2098 (let ((n (id-var-name #'id w))
2099 ;; Lookup id in its module
2100 (id-mod (if (syntax-object? #'id)
2101 (syntax-object-module #'id)
2103 (let ((b (lookup n r id-mod)))
2104 (case (binding-type b)
2106 (build-lexical-assignment s
2107 (syntax->datum #'id)
2109 (chi #'val r w mod)))
2111 (build-global-assignment s n (chi #'val r w mod) id-mod))
2113 (let ((p (binding-value b)))
2114 (if (procedure-property p 'variable-transformer)
2115 ;; As syntax-type does, call chi-macro with
2116 ;; the mod of the expression. Hmm.
2117 (chi (chi-macro p e r w s #f mod) r empty-wrap mod)
2118 (syntax-violation 'set! "not a variable transformer"
2120 (wrap #'id w id-mod)))))
2121 ((displaced-lexical)
2122 (syntax-violation 'set! "identifier out of context"
2124 (else (syntax-violation 'set! "bad set!"
2125 (source-wrap e w s mod)))))))
2126 ((_ (head tail ...) val)
2128 (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
2129 (lambda (type value ee ww ss modmod)
2132 (let ((val (chi #'val r w mod)))
2133 (call-with-values (lambda () (value #'(head tail ...) r w))
2134 (lambda (e r w s* mod)
2137 (build-global-assignment s (syntax->datum #'e)
2140 (build-application s
2141 (chi #'(setter head) r w mod)
2142 (map (lambda (e) (chi e r w mod))
2143 #'(tail ... val))))))))
2144 (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
2146 (global-extend 'module-ref '@
2150 (and (and-map id? #'(mod ...)) (id? #'id))
2151 (values (syntax->datum #'id) r w #f
2153 #'(public mod ...)))))))
2155 (global-extend 'module-ref '@@
2160 (cons (remodulate (car x) mod)
2161 (remodulate (cdr x) mod)))
2164 (remodulate (syntax-object-expression x) mod)
2165 (syntax-object-wrap x)
2166 ;; hither the remodulation
2169 (let* ((n (vector-length x)) (v (make-vector n)))
2170 (do ((i 0 (fx+ i 1)))
2172 (vector-set! v i (remodulate (vector-ref x i) mod)))))
2176 (and-map id? #'(mod ...))
2177 (let ((mod (syntax->datum #'(private mod ...))))
2178 (values (remodulate #'exp mod)
2179 r w (source-annotation #'exp)
2182 (global-extend 'core 'if
2183 (lambda (e r w s mod)
2188 (chi #'test r w mod)
2189 (chi #'then r w mod)
2190 (build-void no-source)))
2194 (chi #'test r w mod)
2195 (chi #'then r w mod)
2196 (chi #'else r w mod))))))
2198 (global-extend 'core 'with-fluids
2199 (lambda (e r w s mod)
2201 ((_ ((fluid val) ...) b b* ...)
2204 (map (lambda (x) (chi x r w mod)) #'(fluid ...))
2205 (map (lambda (x) (chi x r w mod)) #'(val ...))
2206 (chi-body #'(b b* ...)
2207 (source-wrap e w s mod) r w mod))))))
2209 (global-extend 'begin 'begin '())
2211 (global-extend 'define 'define '())
2213 (global-extend 'define-syntax 'define-syntax '())
2215 (global-extend 'eval-when 'eval-when '())
2217 (global-extend 'core 'syntax-case
2219 (define convert-pattern
2220 ;; accepts pattern & keys
2221 ;; returns $sc-dispatch pattern & ids
2222 (lambda (pattern keys)
2228 (lambda () (cvt* (cdr p*) n ids))
2231 (lambda () (cvt (car p*) n ids))
2233 (values (cons x y) ids))))))))
2238 ((bound-id-member? p keys)
2239 (values (vector 'free-id p) ids))
2243 (values 'any (cons (cons p n) ids))))
2246 (ellipsis? (syntax dots))
2248 (lambda () (cvt (syntax x) (fx+ n 1) ids))
2250 (values (if (eq? p 'any) 'each-any (vector 'each p))
2253 (ellipsis? (syntax dots))
2255 (lambda () (cvt* (syntax (ys ...)) n ids))
2258 (lambda () (cvt (syntax x) (+ n 1) ids))
2260 (values `#(each+ ,x ,(reverse ys) ()) ids))))))
2263 (lambda () (cvt (syntax y) n ids))
2266 (lambda () (cvt (syntax x) n ids))
2268 (values (cons x y) ids))))))
2269 (() (values '() ids))
2272 (lambda () (cvt (syntax (x ...)) n ids))
2273 (lambda (p ids) (values (vector 'vector p) ids))))
2274 (x (values (vector 'atom (strip p empty-wrap)) ids))))))
2275 (cvt pattern 0 '())))
2277 (define build-dispatch-call
2278 (lambda (pvars exp y r mod)
2279 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2280 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2281 (build-application no-source
2282 (build-primref no-source 'apply)
2283 (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
2287 (map (lambda (var level)
2288 (make-binding 'syntax `(,var . ,level)))
2292 (make-binding-wrap ids labels empty-wrap)
2297 (lambda (x keys clauses r pat fender exp mod)
2299 (lambda () (convert-pattern pat keys))
2302 ((not (distinct-bound-ids? (map car pvars)))
2303 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2304 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2305 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2307 (let ((y (gen-var 'tmp)))
2308 ;; fat finger binding and references to temp variable y
2309 (build-application no-source
2310 (build-simple-lambda no-source (list 'tmp) #f (list y) '()
2311 (let ((y (build-lexical-reference 'value no-source
2313 (build-conditional no-source
2314 (syntax-case fender ()
2316 (_ (build-conditional no-source
2318 (build-dispatch-call pvars fender y r mod)
2319 (build-data no-source #f))))
2320 (build-dispatch-call pvars exp y r mod)
2321 (gen-syntax-case x keys clauses r mod))))
2322 (list (if (eq? p 'any)
2323 (build-application no-source
2324 (build-primref no-source 'list)
2326 (build-application no-source
2327 (build-primref no-source '$sc-dispatch)
2328 (list x (build-data no-source p)))))))))))))
2330 (define gen-syntax-case
2331 (lambda (x keys clauses r mod)
2333 (build-application no-source
2334 (build-primref no-source 'syntax-violation)
2335 (list (build-data no-source #f)
2336 (build-data no-source
2337 "source expression failed to match any pattern")
2339 (syntax-case (car clauses) ()
2341 (if (and (id? #'pat)
2342 (and-map (lambda (x) (not (free-id=? #'pat x)))
2343 (cons #'(... ...) keys)))
2344 (if (free-id=? #'pad #'_)
2345 (chi #'exp r empty-wrap mod)
2346 (let ((labels (list (gen-label)))
2347 (var (gen-var #'pat)))
2348 (build-application no-source
2349 (build-simple-lambda
2350 no-source (list (syntax->datum #'pat)) #f (list var)
2354 (list (make-binding 'syntax `(,var . 0)))
2356 (make-binding-wrap #'(pat)
2360 (gen-clause x keys (cdr clauses) r
2361 #'pat #t #'exp mod)))
2363 (gen-clause x keys (cdr clauses) r
2364 #'pat #'fender #'exp mod))
2365 (_ (syntax-violation 'syntax-case "invalid clause"
2368 (lambda (e r w s mod)
2369 (let ((e (source-wrap e w s mod)))
2371 ((_ val (key ...) m ...)
2372 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
2374 (let ((x (gen-var 'tmp)))
2375 ;; fat finger binding and references to temp variable x
2376 (build-application s
2377 (build-simple-lambda no-source (list 'tmp) #f (list x) '()
2378 (gen-syntax-case (build-lexical-reference 'value no-source
2380 #'(key ...) #'(m ...)
2383 (list (chi #'val r empty-wrap mod))))
2384 (syntax-violation 'syntax-case "invalid literals list" e))))))))
2386 ;; The portable macroexpand seeds chi-top's mode m with 'e (for
2387 ;; evaluating) and esew (which stands for "eval syntax expanders
2388 ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
2389 ;; if we are compiling a file, and esew is set to
2390 ;; (eval-syntactic-expanders-when), which defaults to the list
2391 ;; '(compile load eval). This means that, by default, top-level
2392 ;; syntactic definitions are evaluated immediately after they are
2393 ;; expanded, and the expanded definitions are also residualized into
2394 ;; the object file if we are compiling a file.
2396 (lambda* (x #:optional (m 'e) (esew '(eval)))
2397 (chi-top-sequence (list x) null-env top-wrap #f m esew
2398 (cons 'hygiene (module-name (current-module))))))
2406 (make-syntax-object datum (syntax-object-wrap id)
2407 (syntax-object-module id))))
2410 ;; accepts any object, since syntax objects may consist partially
2411 ;; or entirely of unwrapped, nonsymbolic data
2413 (strip x empty-wrap)))
2416 (lambda (x) (source-annotation x)))
2418 (set! generate-temporaries
2420 (arg-check list? ls 'generate-temporaries)
2421 (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
2423 (set! free-identifier=?
2425 (arg-check nonsymbol-id? x 'free-identifier=?)
2426 (arg-check nonsymbol-id? y 'free-identifier=?)
2429 (set! bound-identifier=?
2431 (arg-check nonsymbol-id? x 'bound-identifier=?)
2432 (arg-check nonsymbol-id? y 'bound-identifier=?)
2435 (set! syntax-violation
2436 (lambda* (who message form #:optional subform)
2437 (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2438 who 'syntax-violation)
2439 (arg-check string? message 'syntax-violation)
2440 (throw 'syntax-error who message
2441 (source-annotation (or form subform))
2442 (strip form empty-wrap)
2443 (and subform (strip subform empty-wrap)))))
2445 ;; $sc-dispatch expects an expression and a pattern. If the expression
2446 ;; matches the pattern a list of the matching expressions for each
2447 ;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2448 ;; not work on r4rs implementations that violate the ieee requirement
2449 ;; that #f and () be distinct.)
2451 ;; The expression is matched with the pattern as follows:
2453 ;; pattern: matches:
2456 ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2458 ;; #(free-id <key>) <key> with free-identifier=?
2459 ;; #(each <pattern>) (<pattern>*)
2460 ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
2461 ;; #(vector <pattern>) (list->vector <pattern>)
2462 ;; #(atom <object>) <object> with "equal?"
2464 ;; Vector cops out to pair under assumption that vectors are rare. If
2465 ;; not, should convert to:
2466 ;; #(vector <pattern>*) #(<pattern>*)
2474 (let ((first (match (car e) p w '() mod)))
2476 (let ((rest (match-each (cdr e) p w mod)))
2477 (and rest (cons first rest))))))
2480 (match-each (syntax-object-expression e)
2482 (join-wraps w (syntax-object-wrap e))
2483 (syntax-object-module e)))
2487 (lambda (e x-pat y-pat z-pat w r mod)
2488 (let f ((e e) (w w))
2491 (call-with-values (lambda () (f (cdr e) w))
2492 (lambda (xr* y-pat r)
2495 (let ((xr (match (car e) x-pat w '() mod)))
2497 (values (cons xr xr*) y-pat r)
2502 (match (car e) (car y-pat) w r mod)))
2503 (values #f #f #f)))))
2505 (f (syntax-object-expression e) (join-wraps w e)))
2507 (values '() y-pat (match e z-pat w r mod)))))))
2509 (define match-each-any
2513 (let ((l (match-each-any (cdr e) w mod)))
2514 (and l (cons (wrap (car e) w mod) l))))
2517 (match-each-any (syntax-object-expression e)
2518 (join-wraps w (syntax-object-wrap e))
2527 ((eq? p 'any) (cons '() r))
2528 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2529 ((eq? p 'each-any) (cons '() r))
2531 (case (vector-ref p 0)
2532 ((each) (match-empty (vector-ref p 1) r))
2533 ((each+) (match-empty (vector-ref p 1)
2535 (reverse (vector-ref p 2))
2536 (match-empty (vector-ref p 3) r))))
2538 ((vector) (match-empty (vector-ref p 1) r)))))))
2542 (if (null? (car r*))
2544 (cons (map car r*) (combine (map cdr r*) r)))))
2547 (lambda (e p w r mod)
2549 ((null? p) (and (null? e) r))
2551 (and (pair? e) (match (car e) (car p) w
2552 (match (cdr e) (cdr p) w r mod)
2555 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2557 (case (vector-ref p 0)
2560 (match-empty (vector-ref p 1) r)
2561 (let ((l (match-each e (vector-ref p 1) w mod)))
2563 (let collect ((l l))
2566 (cons (map car l) (collect (map cdr l)))))))))
2570 (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
2571 (lambda (xr* y-pat r)
2575 (match-empty (vector-ref p 1) r)
2576 (combine xr* r))))))
2577 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2578 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2581 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2584 (lambda (e p w r mod)
2588 ((eq? p 'any) (cons (wrap e w mod) r))
2591 (syntax-object-expression e)
2593 (join-wraps w (syntax-object-wrap e))
2595 (syntax-object-module e)))
2596 (else (match* e p w r mod)))))
2601 ((eq? p 'any) (list e))
2604 (match* (syntax-object-expression e)
2605 p (syntax-object-wrap e) '() (syntax-object-module e)))
2606 (else (match* e p empty-wrap '() #f))))))))
2609 (define-syntax with-syntax
2613 #'(begin e1 e2 ...))
2614 ((_ ((out in)) e1 e2 ...)
2615 #'(syntax-case in () (out (begin e1 e2 ...))))
2616 ((_ ((out in) ...) e1 e2 ...)
2617 #'(syntax-case (list in ...) ()
2618 ((out ...) (begin e1 e2 ...)))))))
2620 (define-syntax syntax-rules
2623 ((_ (k ...) ((keyword . pattern) template) ...)
2625 ;; embed patterns as procedure metadata
2626 #((macro-type . syntax-rules)
2627 (patterns pattern ...))
2628 (syntax-case x (k ...)
2629 ((dummy . pattern) #'template)
2631 ((_ (k ...) docstring ((keyword . pattern) template) ...)
2632 (string? (syntax->datum #'docstring))
2634 ;; the same, but allow a docstring
2636 #((macro-type . syntax-rules)
2637 (patterns pattern ...))
2638 (syntax-case x (k ...)
2639 ((dummy . pattern) #'template)
2645 ((let* ((x v) ...) e1 e2 ...)
2646 (and-map identifier? #'(x ...))
2647 (let f ((bindings #'((x v) ...)))
2648 (if (null? bindings)
2649 #'(let () e1 e2 ...)
2650 (with-syntax ((body (f (cdr bindings)))
2651 (binding (car bindings)))
2652 #'(let (binding) body))))))))
2656 (syntax-case orig-x ()
2657 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2658 (with-syntax (((step ...)
2663 (_ (syntax-violation
2664 'do "bad step expression"
2668 (syntax-case #'(e1 ...) ()
2669 (() #'(let doloop ((var init) ...)
2671 (begin c ... (doloop step ...)))))
2673 #'(let doloop ((var init) ...)
2676 (begin c ... (doloop step ...)))))))))))
2678 (define-syntax quasiquote
2680 (define (quasi p lev)
2681 (syntax-case p (unquote quasiquote)
2685 (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
2686 ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
2688 (syntax-case #'p (unquote unquote-splicing)
2691 (quasilist* #'(("value" p) ...) (quasi #'q lev))
2693 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2695 ((unquote-splicing p ...)
2697 (quasiappend #'(("value" p) ...) (quasi #'q lev))
2699 (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
2701 (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
2702 (#(x ...) (quasivector (vquasi #'(x ...) lev)))
2704 (define (vquasi p lev)
2707 (syntax-case #'p (unquote unquote-splicing)
2710 (quasilist* #'(("value" p) ...) (vquasi #'q lev))
2712 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2714 ((unquote-splicing p ...)
2716 (quasiappend #'(("value" p) ...) (vquasi #'q lev))
2719 #'("quote" unquote-splicing)
2720 (quasi #'(p ...) (- lev 1)))
2722 (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
2723 (() #'("quote" ()))))
2724 (define (quasicons x y)
2725 (with-syntax ((x x) (y y))
2729 (("quote" dx) #'("quote" (dx . dy)))
2730 (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
2731 (("list" . stuff) #'("list" x . stuff))
2732 (("list*" . stuff) #'("list*" x . stuff))
2733 (_ #'("list*" x y)))))
2734 (define (quasiappend x y)
2738 ((null? x) #'("quote" ()))
2739 ((null? (cdr x)) (car x))
2740 (else (with-syntax (((p ...) x)) #'("append" p ...)))))
2744 (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
2745 (define (quasilist* x y)
2749 (quasicons (car x) (f (cdr x))))))
2750 (define (quasivector x)
2752 (("quote" (x ...)) #'("quote" #(x ...)))
2754 (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
2756 (("quote" (y ...)) (k #'(("quote" y) ...)))
2757 (("list" y ...) (k #'(y ...)))
2758 (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
2759 (else #`("list->vector" #,x)))))))
2763 (("list" x ...) #`(list #,@(map emit #'(x ...))))
2764 ;; could emit list* for 3+ arguments if implementation supports
2767 (let f ((x* #'(x ...)))
2770 #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
2771 (("append" x ...) #`(append #,@(map emit #'(x ...))))
2772 (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
2773 (("list->vector" x) #`(list->vector #,(emit #'x)))
2777 ;; convert to intermediate language, combining introduced (but
2778 ;; not unquoted source) quote expressions where possible and
2779 ;; choosing optimal construction code otherwise, then emit
2780 ;; Scheme code corresponding to the intermediate language forms.
2781 ((_ e) (emit (quasi #'e 0)))))))
2783 (define-syntax include
2787 (let ((p (open-input-file fn)))
2788 (let f ((x (read p))
2792 (close-input-port p)
2795 (cons (datum->syntax k x) result)))))))
2798 (let ((fn (syntax->datum #'filename)))
2799 (with-syntax (((exp ...) (read-file fn #'filename)))
2800 #'(begin exp ...)))))))
2802 (define-syntax include-from-path
2806 (let ((fn (syntax->datum #'filename)))
2807 (with-syntax ((fn (datum->syntax
2809 (or (%search-load-path fn)
2810 (syntax-violation 'include-from-path
2811 "file not found in path"
2813 #'(include fn)))))))
2815 (define-syntax unquote
2817 (syntax-violation 'unquote
2818 "expression not valid outside of quasiquote"
2821 (define-syntax unquote-splicing
2823 (syntax-violation 'unquote-splicing
2824 "expression not valid outside of quasiquote"
2832 ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
2834 (syntax-case clause (else)
2835 ((else e1 e2 ...) #'(begin e1 e2 ...))
2836 (((k ...) e1 e2 ...)
2837 #'(if (memv t '(k ...)) (begin e1 e2 ...)))
2838 (_ (syntax-violation 'case "bad clause" x clause)))
2839 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2840 (syntax-case clause (else)
2841 (((k ...) e1 e2 ...)
2842 #'(if (memv t '(k ...))
2845 (_ (syntax-violation 'case "bad clause" x
2847 #'(let ((t e)) body))))))
2849 (define (make-variable-transformer proc)
2850 (if (procedure? proc)
2851 (let ((trans (lambda (x)
2852 #((macro-type . variable-transformer))
2854 (set-procedure-property! trans 'variable-transformer #t)
2856 (error "variable transformer not a procedure" proc)))
2858 (define-syntax identifier-syntax
2860 (syntax-case x (set!)
2863 #((macro-type . identifier-syntax))
2869 #'(e x (... ...))))))
2870 ((_ (id exp1) ((set! var val) exp2))
2871 (and (identifier? #'id) (identifier? #'var))
2872 #'(make-variable-transformer
2874 #((macro-type . variable-transformer))
2875 (syntax-case x (set!)
2876 ((set! var val) #'exp2)
2877 ((id x (... ...)) #'(exp1 x (... ...)))
2878 (id (identifier? #'id) #'exp1))))))))
2880 (define-syntax define*
2883 ((_ (id . args) b0 b1 ...)
2884 #'(define id (lambda* args b0 b1 ...)))
2885 ((_ id val) (identifier? #'x)
2886 #'(define id val)))))