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
281 (define-syntax fx+ (identifier-syntax +))
282 (define-syntax fx- (identifier-syntax -))
283 (define-syntax fx= (identifier-syntax =))
284 (define-syntax fx< (identifier-syntax <))
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 ;; At top-level, we allow mixed definitions and expressions. Like
901 ;; chi-body we expand in two passes.
903 ;; First, from left to right, we expand just enough to know what
904 ;; expressions are definitions, syntax definitions, and splicing
905 ;; statements (`begin'). If we anything needs evaluating at
906 ;; expansion-time, it is expanded directly.
908 ;; Otherwise we collect expressions to expand, in thunks, and then
909 ;; expand them all at the end. This allows all syntax expanders
910 ;; visible in a toplevel sequence to be visible during the
911 ;; expansions of all normal definitions and expressions in the
914 (define chi-top-sequence
915 (lambda (body r w s m esew mod)
916 (define (scan body r w s m esew mod exps)
926 (let ((e (car body)))
927 (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
928 (lambda (type value e w s mod)
934 (scan #'(e1 e2 ...) r w s m esew mod exps))))
936 (chi-local-syntax value e r w s mod
937 (lambda (body r w s mod)
938 (scan body r w s m esew mod exps))))
941 ((_ (x ...) e1 e2 ...)
942 (let ((when-list (chi-when-list e #'(x ...) w))
943 (body #'(e1 e2 ...)))
946 (if (memq 'eval when-list)
948 (if (memq 'expand when-list) 'c&e 'e)
952 (if (memq 'expand when-list)
954 (chi-top-sequence body r w s 'e '(eval) mod)
957 ((memq 'load when-list)
958 (if (or (memq 'compile when-list)
959 (memq 'expand when-list)
960 (and (eq? m 'c&e) (memq 'eval when-list)))
961 (scan body r w s 'c&e '(compile load) mod exps)
962 (if (memq m '(c c&e))
963 (scan body r w s 'c '(load) mod exps)
965 ((or (memq 'compile when-list)
966 (memq 'expand when-list)
967 (and (eq? m 'c&e) (memq 'eval when-list)))
969 (chi-top-sequence body r w s 'e '(eval) mod)
974 ((define-syntax-form)
975 (let ((n (id-var-name value w)) (r (macros-only-env r)))
978 (if (memq 'compile esew)
979 (let ((e (chi-install-global n (chi e r w mod))))
980 (top-level-eval-hook e mod)
981 (if (memq 'load esew)
982 (values (cons e exps))
984 (if (memq 'load esew)
985 (values (cons (chi-install-global n (chi e r w mod))
989 (let ((e (chi-install-global n (chi e r w mod))))
990 (top-level-eval-hook e mod)
991 (values (cons e exps))))
993 (if (memq 'eval esew)
995 (chi-install-global n (chi e r w mod))
999 (let* ((n (id-var-name value w))
1000 ;; Lookup the name in the module of the define form.
1001 (type (binding-type (lookup n r mod))))
1003 ((global core macro module-ref)
1004 ;; affect compile-time environment (once we have booted)
1005 (if (and (memq m '(c c&e))
1006 (not (module-local-variable (current-module) n))
1008 (let ((old (module-variable (current-module) n)))
1009 ;; use value of the same-named imported variable, if
1011 (if (and (variable? old) (variable-bound? old))
1012 (module-define! (current-module) n (variable-ref old))
1013 (module-add! (current-module) n (make-undefined-variable)))))
1017 (let ((x (build-global-definition s n (chi e r w mod))))
1018 (top-level-eval-hook x mod)
1021 (build-global-definition s n (chi e r w mod))))
1023 ((displaced-lexical)
1024 (syntax-violation #f "identifier out of context"
1025 e (wrap value w mod)))
1027 (syntax-violation #f "cannot define keyword at top level"
1028 e (wrap value w mod))))))
1032 (let ((x (chi-expr type value e r w s mod)))
1033 (top-level-eval-hook x mod)
1036 (chi-expr type value e r w s mod)))
1039 (scan (cdr body) r w s m esew mod exps))))))
1041 (call-with-values (lambda ()
1042 (scan body r w s m esew mod '()))
1048 (let lp ((in exps) (out '()))
1052 (cons (if (procedure? e) (e) e) out)))))))))))
1054 (define chi-install-global
1056 (build-global-definition
1061 (build-primref no-source 'make-syntax-transformer)
1062 (list (build-data no-source name)
1063 (build-data no-source 'macro)
1066 (define chi-when-list
1067 (lambda (e when-list w)
1068 ;; when-list is syntax'd version of list of situations
1069 (let f ((when-list when-list) (situations '()))
1070 (if (null? when-list)
1073 (cons (let ((x (car when-list)))
1075 ((free-id=? x #'compile) 'compile)
1076 ((free-id=? x #'load) 'load)
1077 ((free-id=? x #'eval) 'eval)
1078 ((free-id=? x #'expand) 'expand)
1079 (else (syntax-violation 'eval-when
1084 ;; syntax-type returns six values: type, value, e, w, s, and mod. The
1085 ;; first two are described in the table below.
1087 ;; type value explanation
1088 ;; -------------------------------------------------------------------
1089 ;; core procedure core singleton
1090 ;; core-form procedure core form
1091 ;; module-ref procedure @ or @@ singleton
1092 ;; lexical name lexical variable reference
1093 ;; global name global variable reference
1094 ;; begin none begin keyword
1095 ;; define none define keyword
1096 ;; define-syntax none define-syntax keyword
1097 ;; local-syntax rec? letrec-syntax/let-syntax keyword
1098 ;; eval-when none eval-when keyword
1099 ;; syntax level pattern variable
1100 ;; displaced-lexical none displaced lexical identifier
1101 ;; lexical-call name call to lexical variable
1102 ;; global-call name call to global variable
1103 ;; call none any other call
1104 ;; begin-form none begin expression
1105 ;; define-form id variable definition
1106 ;; define-syntax-form id syntax definition
1107 ;; local-syntax-form rec? syntax definition
1108 ;; eval-when-form none eval-when form
1109 ;; constant none self-evaluating datum
1110 ;; other none anything else
1112 ;; For define-form and define-syntax-form, e is the rhs expression.
1113 ;; For all others, e is the entire form. w is the wrap for e.
1114 ;; s is the source for the entire form. mod is the module for e.
1116 ;; syntax-type expands macros and unwraps as necessary to get to
1117 ;; one of the forms above. It also parses define and define-syntax
1118 ;; forms, although perhaps this should be done by the consumer.
1121 (lambda (e r w s rib mod for-car?)
1124 (let* ((n (id-var-name e w))
1125 (b (lookup n r mod))
1126 (type (binding-type b)))
1128 ((lexical) (values type (binding-value b) e w s mod))
1129 ((global) (values type n e w s mod))
1132 (values type (binding-value b) e w s mod)
1133 (syntax-type (chi-macro (binding-value b) e r w s rib mod)
1134 r empty-wrap s rib mod #f)))
1135 (else (values type (binding-value b) e w s mod)))))
1137 (let ((first (car e)))
1139 (lambda () (syntax-type first r w s rib mod #t))
1140 (lambda (ftype fval fe fw fs fmod)
1143 (values 'lexical-call fval e w s mod))
1145 ;; If we got here via an (@@ ...) expansion, we need to
1146 ;; make sure the fmod information is propagated back
1147 ;; correctly -- hence this consing.
1148 (values 'global-call (make-syntax-object fval w fmod)
1151 (syntax-type (chi-macro fval e r w s rib mod)
1152 r empty-wrap s rib mod for-car?))
1154 (call-with-values (lambda () (fval e r w))
1155 (lambda (e r w s mod)
1156 (syntax-type e r w s rib mod for-car?))))
1158 (values 'core-form fval e w s mod))
1160 (values 'local-syntax-form fval e w s mod))
1162 (values 'begin-form #f e w s mod))
1164 (values 'eval-when-form #f e w s mod))
1169 (values 'define-form #'name #'val w s mod))
1170 ((_ (name . args) e1 e2 ...)
1172 (valid-bound-ids? (lambda-var-list #'args)))
1173 ;; need lambda here...
1174 (values 'define-form (wrap #'name w mod)
1176 (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
1181 (values 'define-form (wrap #'name w mod)
1183 empty-wrap s mod))))
1188 (values 'define-syntax-form #'name
1191 (values 'call #f e w s mod)))))))
1193 (syntax-type (syntax-object-expression e)
1195 (join-wraps w (syntax-object-wrap e))
1196 (or (source-annotation e) s) rib
1197 (or (syntax-object-module e) mod) for-car?))
1198 ((self-evaluating? e) (values 'constant #f e w s mod))
1199 (else (values 'other #f e w s mod)))))
1204 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
1205 (lambda (type value e w s mod)
1206 (chi-expr type value e r w s mod)))))
1209 (lambda (type value e r w s mod)
1212 (build-lexical-reference 'value s e value))
1214 ;; apply transformer
1215 (value e r w s mod))
1217 (call-with-values (lambda () (value e r w))
1218 (lambda (e r w s mod)
1223 (build-lexical-reference 'fun (source-annotation id)
1224 (if (syntax-object? id)
1231 (build-global-reference (source-annotation (car e))
1232 (if (syntax-object? value)
1233 (syntax-object-expression value)
1235 (if (syntax-object? value)
1236 (syntax-object-module value)
1239 ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1240 ((global) (build-global-reference s value mod))
1241 ((call) (chi-application (chi (car e) r w mod) e r w s mod))
1244 ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
1245 ((local-syntax-form)
1246 (chi-local-syntax value e r w s mod chi-sequence))
1249 ((_ (x ...) e1 e2 ...)
1250 (let ((when-list (chi-when-list e #'(x ...) w)))
1251 (if (memq 'eval when-list)
1252 (chi-sequence #'(e1 e2 ...) r w s mod)
1254 ((define-form define-syntax-form)
1255 (syntax-violation #f "definition in expression context"
1256 e (wrap value w mod)))
1258 (syntax-violation #f "reference to pattern variable outside syntax form"
1259 (source-wrap e w s mod)))
1260 ((displaced-lexical)
1261 (syntax-violation #f "reference to identifier outside its scope"
1262 (source-wrap e w s mod)))
1263 (else (syntax-violation #f "unexpected syntax"
1264 (source-wrap e w s mod))))))
1266 (define chi-application
1267 (lambda (x e r w s mod)
1270 (build-application s x
1271 (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
1273 ;; (What follows is my interpretation of what's going on here -- Andy)
1275 ;; A macro takes an expression, a tree, the leaves of which are identifiers
1276 ;; and datums. Identifiers are symbols along with a wrap and a module. For
1277 ;; efficiency, subtrees that share wraps and modules may be grouped as one
1280 ;; Going into the expansion, the expression is given an anti-mark, which
1281 ;; logically propagates to all leaves. Then, in the new expression returned
1282 ;; from the transfomer, if we see an expression with an anti-mark, we know it
1283 ;; pertains to the original expression; conversely, expressions without the
1284 ;; anti-mark are known to be introduced by the transformer.
1286 ;; OK, good until now. We know this algorithm does lexical scoping
1287 ;; appropriately because it's widely known in the literature, and psyntax is
1288 ;; widely used. But what about modules? Here we're on our own. What we do is
1289 ;; to mark the module of expressions produced by a macro as pertaining to the
1290 ;; module that was current when the macro was defined -- that is, free
1291 ;; identifiers introduced by a macro are scoped in the macro's module, not in
1292 ;; the expansion's module. Seems to work well.
1294 ;; The only wrinkle is when we want a macro to expand to code in another
1295 ;; module, as is the case for the r6rs `library' form -- the body expressions
1296 ;; should be scoped relative the the new module, the one defined by the macro.
1297 ;; For that, use `(@@ mod-name body)'.
1299 ;; Part of the macro output will be from the site of the macro use and part
1300 ;; from the macro definition. We allow source information from the macro use
1301 ;; to pass through, but we annotate the parts coming from the macro with the
1302 ;; source location information corresponding to the macro use. It would be
1303 ;; really nice if we could also annotate introduced expressions with the
1304 ;; locations corresponding to the macro definition, but that is not yet
1307 (lambda (p e r w s rib mod)
1308 (define rebuild-macro-output
1312 (cons (rebuild-macro-output (car x) m)
1313 (rebuild-macro-output (cdr x) m))
1316 (let ((w (syntax-object-wrap x)))
1317 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1318 (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1319 ;; output is from original text
1321 (syntax-object-expression x)
1322 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1323 (syntax-object-module x))
1324 ;; output introduced by macro
1326 (decorate-source (syntax-object-expression x) s)
1327 (make-wrap (cons m ms)
1329 (cons rib (cons 'shift s))
1331 (syntax-object-module x))))))
1334 (let* ((n (vector-length x))
1335 (v (decorate-source (make-vector n) x)))
1336 (do ((i 0 (fx+ i 1)))
1339 (rebuild-macro-output (vector-ref x i) m)))))
1341 (syntax-violation #f "encountered raw symbol in macro output"
1342 (source-wrap e w (wrap-subst w) mod) x))
1343 (else (decorate-source x s)))))
1344 (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
1348 ;; In processing the forms of the body, we create a new, empty wrap.
1349 ;; This wrap is augmented (destructively) each time we discover that
1350 ;; the next form is a definition. This is done:
1352 ;; (1) to allow the first nondefinition form to be a call to
1353 ;; one of the defined ids even if the id previously denoted a
1354 ;; definition keyword or keyword for a macro expanding into a
1356 ;; (2) to prevent subsequent definition forms (but unfortunately
1357 ;; not earlier ones) and the first nondefinition form from
1358 ;; confusing one of the bound identifiers for an auxiliary
1360 ;; (3) so that we do not need to restart the expansion of the
1361 ;; first nondefinition form, which is problematic anyway
1362 ;; since it might be the first element of a begin that we
1363 ;; have just spliced into the body (meaning if we restarted,
1364 ;; we'd really need to restart with the begin or the macro
1365 ;; call that expanded into the begin, and we'd have to give
1366 ;; up allowing (begin <defn>+ <expr>+), which is itself
1367 ;; problematic since we don't know if a begin contains only
1368 ;; definitions until we've expanded it).
1370 ;; Before processing the body, we also create a new environment
1371 ;; containing a placeholder for the bindings we will add later and
1372 ;; associate this environment with each form. In processing a
1373 ;; let-syntax or letrec-syntax, the associated environment may be
1374 ;; augmented with local keyword bindings, so the environment may
1375 ;; be different for different forms in the body. Once we have
1376 ;; gathered up all of the definitions, we evaluate the transformer
1377 ;; expressions and splice into r at the placeholder the new variable
1378 ;; and keyword bindings. This allows let-syntax or letrec-syntax
1379 ;; forms local to a portion or all of the body to shadow the
1380 ;; definition bindings.
1382 ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1385 ;; outer-form is fully wrapped w/source
1386 (lambda (body outer-form r w mod)
1387 (let* ((r (cons '("placeholder" . (placeholder)) r))
1388 (ribcage (make-empty-ribcage))
1389 (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1390 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1391 (ids '()) (labels '())
1392 (var-ids '()) (vars '()) (vals '()) (bindings '()))
1394 (syntax-violation #f "no expressions in body" outer-form)
1395 (let ((e (cdar body)) (er (caar body)))
1397 (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
1398 (lambda (type value e w s mod)
1401 (let ((id (wrap value w mod)) (label (gen-label)))
1402 (let ((var (gen-var id)))
1403 (extend-ribcage! ribcage id label)
1405 (cons id ids) (cons label labels)
1407 (cons var vars) (cons (cons er (wrap e w mod)) vals)
1408 (cons (make-binding 'lexical var) bindings)))))
1409 ((define-syntax-form)
1410 (let ((id (wrap value w mod)) (label (gen-label)))
1411 (extend-ribcage! ribcage id label)
1413 (cons id ids) (cons label labels)
1415 (cons (make-binding 'macro (cons er (wrap e w mod)))
1420 (parse (let f ((forms #'(e1 ...)))
1423 (cons (cons er (wrap (car forms) w mod))
1425 ids labels var-ids vars vals bindings))))
1426 ((local-syntax-form)
1427 (chi-local-syntax value e er w s mod
1428 (lambda (forms er w s mod)
1429 (parse (let f ((forms forms))
1432 (cons (cons er (wrap (car forms) w mod))
1434 ids labels var-ids vars vals bindings))))
1435 (else ; found a non-definition
1437 (build-sequence no-source
1439 (chi (cdr x) (car x) empty-wrap mod))
1440 (cons (cons er (source-wrap e w s mod))
1443 (if (not (valid-bound-ids? ids))
1445 #f "invalid or duplicate identifier in definition"
1447 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1448 (if (not (null? bs))
1449 (let* ((b (car bs)))
1450 (if (eq? (car b) 'macro)
1451 (let* ((er (cadr b))
1453 (if (eq? er er-cache)
1455 (macros-only-env er))))
1457 (eval-local-transformer
1458 (chi (cddr b) r-cache empty-wrap mod)
1460 (loop (cdr bs) er r-cache))
1461 (loop (cdr bs) er-cache r-cache)))))
1462 (set-cdr! r (extend-env labels bindings (cdr r)))
1463 (build-letrec no-source #t
1464 (reverse (map syntax->datum var-ids))
1467 (chi (cdr x) (car x) empty-wrap mod))
1469 (build-sequence no-source
1471 (chi (cdr x) (car x) empty-wrap mod))
1472 (cons (cons er (source-wrap e w s mod))
1473 (cdr body)))))))))))))))))
1475 (define chi-local-syntax
1476 (lambda (rec? e r w s mod k)
1478 ((_ ((id val) ...) e1 e2 ...)
1479 (let ((ids #'(id ...)))
1480 (if (not (valid-bound-ids? ids))
1481 (syntax-violation #f "duplicate bound keyword" e)
1482 (let ((labels (gen-labels ids)))
1483 (let ((new-w (make-binding-wrap ids labels w)))
1487 (let ((w (if rec? new-w w))
1488 (trans-r (macros-only-env r)))
1490 (make-binding 'macro
1491 (eval-local-transformer
1492 (chi x trans-r w mod)
1499 (_ (syntax-violation #f "bad local syntax definition"
1500 (source-wrap e w s mod))))))
1502 (define eval-local-transformer
1503 (lambda (expanded mod)
1504 (let ((p (local-eval-hook expanded mod)))
1507 (syntax-violation #f "nonprocedure transformer" p)))))
1511 (build-void no-source)))
1515 (and (nonsymbol-id? x)
1516 (free-id=? x #'(... ...)))))
1518 (define lambda-formals
1520 (define (req args rreq)
1521 (syntax-case args ()
1523 (check (reverse rreq) #f))
1525 (req #'b (cons #'a rreq)))
1527 (check (reverse rreq) #'r))
1529 (syntax-violation 'lambda "invalid argument list" orig-args args))))
1530 (define (check req rest)
1532 ((distinct-bound-ids? (if rest (cons rest req) req))
1533 (values req #f rest #f))
1535 (syntax-violation 'lambda "duplicate identifier in argument list"
1537 (req orig-args '())))
1539 (define chi-simple-lambda
1540 (lambda (e r w s mod req rest meta body)
1541 (let* ((ids (if rest (append req (list rest)) req))
1542 (vars (map gen-var ids))
1543 (labels (gen-labels ids)))
1544 (build-simple-lambda
1546 (map syntax->datum req) (and rest (syntax->datum rest)) vars
1548 (chi-body body (source-wrap e w s mod)
1549 (extend-var-env labels vars r)
1550 (make-binding-wrap ids labels w)
1553 (define lambda*-formals
1555 (define (req args rreq)
1556 (syntax-case args ()
1558 (check (reverse rreq) '() #f '()))
1560 (req #'b (cons #'a rreq)))
1561 ((a . b) (eq? (syntax->datum #'a) #:optional)
1562 (opt #'b (reverse rreq) '()))
1563 ((a . b) (eq? (syntax->datum #'a) #:key)
1564 (key #'b (reverse rreq) '() '()))
1565 ((a b) (eq? (syntax->datum #'a) #:rest)
1566 (rest #'b (reverse rreq) '() '()))
1568 (rest #'r (reverse rreq) '() '()))
1570 (syntax-violation 'lambda* "invalid argument list" orig-args args))))
1571 (define (opt args req ropt)
1572 (syntax-case args ()
1574 (check req (reverse ropt) #f '()))
1576 (opt #'b req (cons #'(a #f) ropt)))
1577 (((a init) . b) (id? #'a)
1578 (opt #'b req (cons #'(a init) ropt)))
1579 ((a . b) (eq? (syntax->datum #'a) #:key)
1580 (key #'b req (reverse ropt) '()))
1581 ((a b) (eq? (syntax->datum #'a) #:rest)
1582 (rest #'b req (reverse ropt) '()))
1584 (rest #'r req (reverse ropt) '()))
1586 (syntax-violation 'lambda* "invalid optional argument list"
1588 (define (key args req opt rkey)
1589 (syntax-case args ()
1591 (check req opt #f (cons #f (reverse rkey))))
1593 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1594 (key #'b req opt (cons #'(k a #f) rkey))))
1595 (((a init) . b) (id? #'a)
1596 (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1597 (key #'b req opt (cons #'(k a init) rkey))))
1598 (((a init k) . b) (and (id? #'a)
1599 (keyword? (syntax->datum #'k)))
1600 (key #'b req opt (cons #'(k a init) rkey)))
1601 ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
1602 (check req opt #f (cons #t (reverse rkey))))
1603 ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1604 (eq? (syntax->datum #'a) #:rest))
1605 (rest #'b req opt (cons #t (reverse rkey))))
1606 ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1608 (rest #'r req opt (cons #t (reverse rkey))))
1609 ((a b) (eq? (syntax->datum #'a) #:rest)
1610 (rest #'b req opt (cons #f (reverse rkey))))
1612 (rest #'r req opt (cons #f (reverse rkey))))
1614 (syntax-violation 'lambda* "invalid keyword argument list"
1616 (define (rest args req opt kw)
1617 (syntax-case args ()
1619 (check req opt #'r kw))
1621 (syntax-violation 'lambda* "invalid rest argument"
1623 (define (check req opt rest kw)
1625 ((distinct-bound-ids?
1626 (append req (map car opt) (if rest (list rest) '())
1627 (if (pair? kw) (map cadr (cdr kw)) '())))
1628 (values req opt rest kw))
1630 (syntax-violation 'lambda* "duplicate identifier in argument list"
1632 (req orig-args '())))
1634 (define chi-lambda-case
1635 (lambda (e r w s mod get-formals clauses)
1636 (define (expand-req req opt rest kw body)
1637 (let ((vars (map gen-var req))
1638 (labels (gen-labels req)))
1639 (let ((r* (extend-var-env labels vars r))
1640 (w* (make-binding-wrap req labels w)))
1641 (expand-opt (map syntax->datum req)
1642 opt rest kw body (reverse vars) r* w* '() '()))))
1643 (define (expand-opt req opt rest kw body vars r* w* out inits)
1646 (syntax-case (car opt) ()
1648 (let* ((v (gen-var #'id))
1649 (l (gen-labels (list v)))
1650 (r** (extend-var-env l (list v) r*))
1651 (w** (make-binding-wrap (list #'id) l w*)))
1652 (expand-opt req (cdr opt) rest kw body (cons v vars)
1653 r** w** (cons (syntax->datum #'id) out)
1654 (cons (chi #'i r* w* mod) inits))))))
1656 (let* ((v (gen-var rest))
1657 (l (gen-labels (list v)))
1658 (r* (extend-var-env l (list v) r*))
1659 (w* (make-binding-wrap (list rest) l w*)))
1660 (expand-kw req (if (pair? out) (reverse out) #f)
1661 (syntax->datum rest)
1662 (if (pair? kw) (cdr kw) kw)
1663 body (cons v vars) r* w*
1664 (if (pair? kw) (car kw) #f)
1667 (expand-kw req (if (pair? out) (reverse out) #f) #f
1668 (if (pair? kw) (cdr kw) kw)
1670 (if (pair? kw) (car kw) #f)
1672 (define (expand-kw req opt rest kw body vars r* w* aok out inits)
1675 (syntax-case (car kw) ()
1677 (let* ((v (gen-var #'id))
1678 (l (gen-labels (list v)))
1679 (r** (extend-var-env l (list v) r*))
1680 (w** (make-binding-wrap (list #'id) l w*)))
1681 (expand-kw req opt rest (cdr kw) body (cons v vars)
1683 (cons (list (syntax->datum #'k)
1684 (syntax->datum #'id)
1687 (cons (chi #'i r* w* mod) inits))))))
1689 (expand-body req opt rest
1690 (if (or aok (pair? out)) (cons aok (reverse out)) #f)
1691 body (reverse vars) r* w* (reverse inits) '()))))
1692 (define (expand-body req opt rest kw body vars r* w* inits meta)
1693 (syntax-case body ()
1694 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1695 (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1698 . ,(syntax->datum #'docstring))))))
1699 ((#((k . v) ...) e1 e2 ...)
1700 (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1701 (append meta (syntax->datum #'((k . v) ...)))))
1703 (values meta req opt rest kw inits vars
1704 (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
1707 (syntax-case clauses ()
1708 (() (values '() #f))
1709 (((args e1 e2 ...) (args* e1* e2* ...) ...)
1710 (call-with-values (lambda () (get-formals #'args))
1711 (lambda (req opt rest kw)
1712 (call-with-values (lambda ()
1713 (expand-req req opt rest kw #'(e1 e2 ...)))
1714 (lambda (meta req opt rest kw inits vars body)
1717 (chi-lambda-case e r w s mod get-formals
1718 #'((args* e1* e2* ...) ...)))
1719 (lambda (meta* else*)
1722 (build-lambda-case s req opt rest kw inits vars
1723 body else*))))))))))))
1727 ;; strips syntax-objects down to top-wrap
1729 ;; since only the head of a list is annotated by the reader, not each pair
1730 ;; in the spine, we also check for pairs whose cars are annotated in case
1731 ;; we've been passed the cdr of an annotated list
1740 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1742 (let ((a (f (car x))) (d (f (cdr x))))
1743 (if (and (eq? a (car x)) (eq? d (cdr x)))
1747 (let ((old (vector->list x)))
1748 (let ((new (map f old)))
1749 (if (and-map* eq? old new) x (list->vector new)))))
1752 ;; lexical variables
1756 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1757 (build-lexical-var no-source id))))
1759 ;; appears to return a reversed list
1760 (define lambda-var-list
1762 (let lvl ((vars vars) (ls '()) (w empty-wrap))
1764 ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1765 ((id? vars) (cons (wrap vars w #f) ls))
1767 ((syntax-object? vars)
1768 (lvl (syntax-object-expression vars)
1770 (join-wraps w (syntax-object-wrap vars))))
1771 ;; include anything else to be caught by subsequent error
1773 (else (cons vars ls))))))
1775 ;; core transformers
1777 (global-extend 'local-syntax 'letrec-syntax #t)
1778 (global-extend 'local-syntax 'let-syntax #f)
1780 (global-extend 'core 'fluid-let-syntax
1781 (lambda (e r w s mod)
1783 ((_ ((var val) ...) e1 e2 ...)
1784 (valid-bound-ids? #'(var ...))
1785 (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
1788 (case (binding-type (lookup n r mod))
1789 ((displaced-lexical)
1790 (syntax-violation 'fluid-let-syntax
1791 "identifier out of context"
1793 (source-wrap id w s mod)))))
1798 (source-wrap e w s mod)
1801 (let ((trans-r (macros-only-env r)))
1803 (make-binding 'macro
1804 (eval-local-transformer (chi x trans-r w mod)
1810 (_ (syntax-violation 'fluid-let-syntax "bad syntax"
1811 (source-wrap e w s mod))))))
1813 (global-extend 'core 'quote
1814 (lambda (e r w s mod)
1816 ((_ e) (build-data s (strip #'e w)))
1817 (_ (syntax-violation 'quote "bad syntax"
1818 (source-wrap e w s mod))))))
1820 (global-extend 'core 'syntax
1823 (lambda (src e r maps ellipsis? mod)
1825 (let ((label (id-var-name e empty-wrap)))
1826 ;; Mod does not matter, we are looking to see if
1827 ;; the id is lexical syntax.
1828 (let ((b (lookup label r mod)))
1829 (if (eq? (binding-type b) 'syntax)
1832 (let ((var.lev (binding-value b)))
1833 (gen-ref src (car var.lev) (cdr var.lev) maps)))
1834 (lambda (var maps) (values `(ref ,var) maps)))
1836 (syntax-violation 'syntax "misplaced ellipsis" src)
1837 (values `(quote ,e) maps)))))
1841 (gen-syntax src #'e r maps (lambda (x) #f) mod))
1843 ;; this could be about a dozen lines of code, except that we
1844 ;; choose to handle #'(x ... ...) forms
1850 (gen-syntax src #'x r
1851 (cons '() maps) ellipsis? mod))
1853 (if (null? (car maps))
1854 (syntax-violation 'syntax "extra ellipsis"
1856 (values (gen-map x (car maps))
1864 (lambda () (k (cons '() maps)))
1866 (if (null? (car maps))
1867 (syntax-violation 'syntax "extra ellipsis" src)
1868 (values (gen-mappend x (car maps))
1870 (_ (call-with-values
1871 (lambda () (gen-syntax src y r maps ellipsis? mod))
1874 (lambda () (k maps))
1876 (values (gen-append x y) maps)))))))))
1879 (lambda () (gen-syntax src #'x r maps ellipsis? mod))
1882 (lambda () (gen-syntax src #'y r maps ellipsis? mod))
1883 (lambda (y maps) (values (gen-cons x y) maps))))))
1887 (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
1888 (lambda (e maps) (values (gen-vector e) maps))))
1889 (_ (values `(quote ,e) maps))))))
1892 (lambda (src var level maps)
1896 (syntax-violation 'syntax "missing ellipsis" src)
1898 (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1899 (lambda (outer-var outer-maps)
1900 (let ((b (assq outer-var (car maps))))
1902 (values (cdr b) maps)
1903 (let ((inner-var (gen-var 'tmp)))
1905 (cons (cons (cons outer-var inner-var)
1907 outer-maps)))))))))))
1911 `(apply (primitive append) ,(gen-map e map-env))))
1915 (let ((formals (map cdr map-env))
1916 (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1919 ;; identity map equivalence:
1920 ;; (map (lambda (x) x) y) == y
1923 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1925 ;; eta map equivalence:
1926 ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1927 `(map (primitive ,(car e))
1928 ,@(map (let ((r (map cons formals actuals)))
1929 (lambda (x) (cdr (assq (cadr x) r))))
1931 (else `(map (lambda ,formals ,e) ,@actuals))))))
1937 (if (eq? (car x) 'quote)
1938 `(quote (,(cadr x) . ,(cadr y)))
1939 (if (eq? (cadr y) '())
1942 ((list) `(list ,x ,@(cdr y)))
1943 (else `(cons ,x ,y)))))
1947 (if (equal? y '(quote ()))
1954 ((eq? (car x) 'list) `(vector ,@(cdr x)))
1955 ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1956 (else `(list->vector ,x)))))
1962 ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
1963 ((primitive) (build-primref no-source (cadr x)))
1964 ((quote) (build-data no-source (cadr x)))
1966 (if (list? (cadr x))
1967 (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
1968 (error "how did we get here" x)))
1969 (else (build-application no-source
1970 (build-primref no-source (car x))
1971 (map regen (cdr x)))))))
1973 (lambda (e r w s mod)
1974 (let ((e (source-wrap e w s mod)))
1978 (lambda () (gen-syntax e #'x r '() ellipsis? mod))
1979 (lambda (e maps) (regen e))))
1980 (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
1982 (global-extend 'core 'lambda
1983 (lambda (e r w s mod)
1986 (call-with-values (lambda () (lambda-formals #'args))
1987 (lambda (req opt rest kw)
1988 (let lp ((body #'(e1 e2 ...)) (meta '()))
1989 (syntax-case body ()
1990 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1994 . ,(syntax->datum #'docstring))))))
1995 ((#((k . v) ...) e1 e2 ...)
1997 (append meta (syntax->datum #'((k . v) ...)))))
1998 (_ (chi-simple-lambda e r w s mod req rest meta body)))))))
1999 (_ (syntax-violation 'lambda "bad lambda" e)))))
2001 (global-extend 'core 'lambda*
2002 (lambda (e r w s mod)
2007 (chi-lambda-case e r w s mod
2008 lambda*-formals #'((args e1 e2 ...))))
2009 (lambda (meta lcase)
2010 (build-case-lambda s meta lcase))))
2011 (_ (syntax-violation 'lambda "bad lambda*" e)))))
2013 (global-extend 'core 'case-lambda
2014 (lambda (e r w s mod)
2016 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
2019 (chi-lambda-case e r w s mod
2021 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2022 (lambda (meta lcase)
2023 (build-case-lambda s meta lcase))))
2024 (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
2026 (global-extend 'core 'case-lambda*
2027 (lambda (e r w s mod)
2029 ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
2032 (chi-lambda-case e r w s mod
2034 #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2035 (lambda (meta lcase)
2036 (build-case-lambda s meta lcase))))
2037 (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
2039 (global-extend 'core 'let
2041 (define (chi-let e r w s mod constructor ids vals exps)
2042 (if (not (valid-bound-ids? ids))
2043 (syntax-violation 'let "duplicate bound variable" e)
2044 (let ((labels (gen-labels ids))
2045 (new-vars (map gen-var ids)))
2046 (let ((nw (make-binding-wrap ids labels w))
2047 (nr (extend-var-env labels new-vars r)))
2049 (map syntax->datum ids)
2051 (map (lambda (x) (chi x r w mod)) vals)
2052 (chi-body exps (source-wrap e nw s mod)
2054 (lambda (e r w s mod)
2056 ((_ ((id val) ...) e1 e2 ...)
2057 (and-map id? #'(id ...))
2058 (chi-let e r w s mod
2063 ((_ f ((id val) ...) e1 e2 ...)
2064 (and (id? #'f) (and-map id? #'(id ...)))
2065 (chi-let e r w s mod
2070 (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
2073 (global-extend 'core 'letrec
2074 (lambda (e r w s mod)
2076 ((_ ((id val) ...) e1 e2 ...)
2077 (and-map id? #'(id ...))
2078 (let ((ids #'(id ...)))
2079 (if (not (valid-bound-ids? ids))
2080 (syntax-violation 'letrec "duplicate bound variable" e)
2081 (let ((labels (gen-labels ids))
2082 (new-vars (map gen-var ids)))
2083 (let ((w (make-binding-wrap ids labels w))
2084 (r (extend-var-env labels new-vars r)))
2086 (map syntax->datum ids)
2088 (map (lambda (x) (chi x r w mod)) #'(val ...))
2089 (chi-body #'(e1 e2 ...)
2090 (source-wrap e w s mod) r w mod)))))))
2091 (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
2094 (global-extend 'core 'letrec*
2095 (lambda (e r w s mod)
2097 ((_ ((id val) ...) e1 e2 ...)
2098 (and-map id? #'(id ...))
2099 (let ((ids #'(id ...)))
2100 (if (not (valid-bound-ids? ids))
2101 (syntax-violation 'letrec* "duplicate bound variable" e)
2102 (let ((labels (gen-labels ids))
2103 (new-vars (map gen-var ids)))
2104 (let ((w (make-binding-wrap ids labels w))
2105 (r (extend-var-env labels new-vars r)))
2107 (map syntax->datum ids)
2109 (map (lambda (x) (chi x r w mod)) #'(val ...))
2110 (chi-body #'(e1 e2 ...)
2111 (source-wrap e w s mod) r w mod)))))))
2112 (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
2115 (global-extend 'core 'set!
2116 (lambda (e r w s mod)
2120 (let ((n (id-var-name #'id w))
2121 ;; Lookup id in its module
2122 (id-mod (if (syntax-object? #'id)
2123 (syntax-object-module #'id)
2125 (let ((b (lookup n r id-mod)))
2126 (case (binding-type b)
2128 (build-lexical-assignment s
2129 (syntax->datum #'id)
2131 (chi #'val r w mod)))
2133 (build-global-assignment s n (chi #'val r w mod) id-mod))
2135 (let ((p (binding-value b)))
2136 (if (procedure-property p 'variable-transformer)
2137 ;; As syntax-type does, call chi-macro with
2138 ;; the mod of the expression. Hmm.
2139 (chi (chi-macro p e r w s #f mod) r empty-wrap mod)
2140 (syntax-violation 'set! "not a variable transformer"
2142 (wrap #'id w id-mod)))))
2143 ((displaced-lexical)
2144 (syntax-violation 'set! "identifier out of context"
2146 (else (syntax-violation 'set! "bad set!"
2147 (source-wrap e w s mod)))))))
2148 ((_ (head tail ...) val)
2150 (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
2151 (lambda (type value ee ww ss modmod)
2154 (let ((val (chi #'val r w mod)))
2155 (call-with-values (lambda () (value #'(head tail ...) r w))
2156 (lambda (e r w s* mod)
2159 (build-global-assignment s (syntax->datum #'e)
2162 (build-application s
2163 (chi #'(setter head) r w mod)
2164 (map (lambda (e) (chi e r w mod))
2165 #'(tail ... val))))))))
2166 (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
2168 (global-extend 'module-ref '@
2172 (and (and-map id? #'(mod ...)) (id? #'id))
2173 (values (syntax->datum #'id) r w #f
2175 #'(public mod ...)))))))
2177 (global-extend 'module-ref '@@
2182 (cons (remodulate (car x) mod)
2183 (remodulate (cdr x) mod)))
2186 (remodulate (syntax-object-expression x) mod)
2187 (syntax-object-wrap x)
2188 ;; hither the remodulation
2191 (let* ((n (vector-length x)) (v (make-vector n)))
2192 (do ((i 0 (fx+ i 1)))
2194 (vector-set! v i (remodulate (vector-ref x i) mod)))))
2198 (and-map id? #'(mod ...))
2199 (let ((mod (syntax->datum #'(private mod ...))))
2200 (values (remodulate #'exp mod)
2201 r w (source-annotation #'exp)
2204 (global-extend 'core 'if
2205 (lambda (e r w s mod)
2210 (chi #'test r w mod)
2211 (chi #'then r w mod)
2212 (build-void no-source)))
2216 (chi #'test r w mod)
2217 (chi #'then r w mod)
2218 (chi #'else r w mod))))))
2220 (global-extend 'core 'with-fluids
2221 (lambda (e r w s mod)
2223 ((_ ((fluid val) ...) b b* ...)
2226 (map (lambda (x) (chi x r w mod)) #'(fluid ...))
2227 (map (lambda (x) (chi x r w mod)) #'(val ...))
2228 (chi-body #'(b b* ...)
2229 (source-wrap e w s mod) r w mod))))))
2231 (global-extend 'begin 'begin '())
2233 (global-extend 'define 'define '())
2235 (global-extend 'define-syntax 'define-syntax '())
2237 (global-extend 'eval-when 'eval-when '())
2239 (global-extend 'core 'syntax-case
2241 (define convert-pattern
2242 ;; accepts pattern & keys
2243 ;; returns $sc-dispatch pattern & ids
2244 (lambda (pattern keys)
2250 (lambda () (cvt* (cdr p*) n ids))
2253 (lambda () (cvt (car p*) n ids))
2255 (values (cons x y) ids))))))))
2260 ((bound-id-member? p keys)
2261 (values (vector 'free-id p) ids))
2265 (values 'any (cons (cons p n) ids))))
2268 (ellipsis? (syntax dots))
2270 (lambda () (cvt (syntax x) (fx+ n 1) ids))
2272 (values (if (eq? p 'any) 'each-any (vector 'each p))
2275 (ellipsis? (syntax dots))
2277 (lambda () (cvt* (syntax (ys ...)) n ids))
2280 (lambda () (cvt (syntax x) (+ n 1) ids))
2282 (values `#(each+ ,x ,(reverse ys) ()) ids))))))
2285 (lambda () (cvt (syntax y) n ids))
2288 (lambda () (cvt (syntax x) n ids))
2290 (values (cons x y) ids))))))
2291 (() (values '() ids))
2294 (lambda () (cvt (syntax (x ...)) n ids))
2295 (lambda (p ids) (values (vector 'vector p) ids))))
2296 (x (values (vector 'atom (strip p empty-wrap)) ids))))))
2297 (cvt pattern 0 '())))
2299 (define build-dispatch-call
2300 (lambda (pvars exp y r mod)
2301 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2302 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2303 (build-application no-source
2304 (build-primref no-source 'apply)
2305 (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
2309 (map (lambda (var level)
2310 (make-binding 'syntax `(,var . ,level)))
2314 (make-binding-wrap ids labels empty-wrap)
2319 (lambda (x keys clauses r pat fender exp mod)
2321 (lambda () (convert-pattern pat keys))
2324 ((not (distinct-bound-ids? (map car pvars)))
2325 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2326 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2327 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2329 (let ((y (gen-var 'tmp)))
2330 ;; fat finger binding and references to temp variable y
2331 (build-application no-source
2332 (build-simple-lambda no-source (list 'tmp) #f (list y) '()
2333 (let ((y (build-lexical-reference 'value no-source
2335 (build-conditional no-source
2336 (syntax-case fender ()
2338 (_ (build-conditional no-source
2340 (build-dispatch-call pvars fender y r mod)
2341 (build-data no-source #f))))
2342 (build-dispatch-call pvars exp y r mod)
2343 (gen-syntax-case x keys clauses r mod))))
2344 (list (if (eq? p 'any)
2345 (build-application no-source
2346 (build-primref no-source 'list)
2348 (build-application no-source
2349 (build-primref no-source '$sc-dispatch)
2350 (list x (build-data no-source p)))))))))))))
2352 (define gen-syntax-case
2353 (lambda (x keys clauses r mod)
2355 (build-application no-source
2356 (build-primref no-source 'syntax-violation)
2357 (list (build-data no-source #f)
2358 (build-data no-source
2359 "source expression failed to match any pattern")
2361 (syntax-case (car clauses) ()
2363 (if (and (id? #'pat)
2364 (and-map (lambda (x) (not (free-id=? #'pat x)))
2365 (cons #'(... ...) keys)))
2366 (if (free-id=? #'pad #'_)
2367 (chi #'exp r empty-wrap mod)
2368 (let ((labels (list (gen-label)))
2369 (var (gen-var #'pat)))
2370 (build-application no-source
2371 (build-simple-lambda
2372 no-source (list (syntax->datum #'pat)) #f (list var)
2376 (list (make-binding 'syntax `(,var . 0)))
2378 (make-binding-wrap #'(pat)
2382 (gen-clause x keys (cdr clauses) r
2383 #'pat #t #'exp mod)))
2385 (gen-clause x keys (cdr clauses) r
2386 #'pat #'fender #'exp mod))
2387 (_ (syntax-violation 'syntax-case "invalid clause"
2390 (lambda (e r w s mod)
2391 (let ((e (source-wrap e w s mod)))
2393 ((_ val (key ...) m ...)
2394 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
2396 (let ((x (gen-var 'tmp)))
2397 ;; fat finger binding and references to temp variable x
2398 (build-application s
2399 (build-simple-lambda no-source (list 'tmp) #f (list x) '()
2400 (gen-syntax-case (build-lexical-reference 'value no-source
2402 #'(key ...) #'(m ...)
2405 (list (chi #'val r empty-wrap mod))))
2406 (syntax-violation 'syntax-case "invalid literals list" e))))))))
2408 ;; The portable macroexpand seeds chi-top's mode m with 'e (for
2409 ;; evaluating) and esew (which stands for "eval syntax expanders
2410 ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
2411 ;; if we are compiling a file, and esew is set to
2412 ;; (eval-syntactic-expanders-when), which defaults to the list
2413 ;; '(compile load eval). This means that, by default, top-level
2414 ;; syntactic definitions are evaluated immediately after they are
2415 ;; expanded, and the expanded definitions are also residualized into
2416 ;; the object file if we are compiling a file.
2418 (lambda* (x #:optional (m 'e) (esew '(eval)))
2419 (chi-top-sequence (list x) null-env top-wrap #f m esew
2420 (cons 'hygiene (module-name (current-module))))))
2428 (make-syntax-object datum (syntax-object-wrap id)
2429 (syntax-object-module id))))
2432 ;; accepts any object, since syntax objects may consist partially
2433 ;; or entirely of unwrapped, nonsymbolic data
2435 (strip x empty-wrap)))
2438 (lambda (x) (source-annotation x)))
2440 (set! generate-temporaries
2442 (arg-check list? ls 'generate-temporaries)
2443 (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
2445 (set! free-identifier=?
2447 (arg-check nonsymbol-id? x 'free-identifier=?)
2448 (arg-check nonsymbol-id? y 'free-identifier=?)
2451 (set! bound-identifier=?
2453 (arg-check nonsymbol-id? x 'bound-identifier=?)
2454 (arg-check nonsymbol-id? y 'bound-identifier=?)
2457 (set! syntax-violation
2458 (lambda* (who message form #:optional subform)
2459 (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2460 who 'syntax-violation)
2461 (arg-check string? message 'syntax-violation)
2462 (throw 'syntax-error who message
2463 (source-annotation (or form subform))
2464 (strip form empty-wrap)
2465 (and subform (strip subform empty-wrap)))))
2467 ;; $sc-dispatch expects an expression and a pattern. If the expression
2468 ;; matches the pattern a list of the matching expressions for each
2469 ;; "any" is returned. Otherwise, #f is returned. (This use of #f will
2470 ;; not work on r4rs implementations that violate the ieee requirement
2471 ;; that #f and () be distinct.)
2473 ;; The expression is matched with the pattern as follows:
2475 ;; pattern: matches:
2478 ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
2480 ;; #(free-id <key>) <key> with free-identifier=?
2481 ;; #(each <pattern>) (<pattern>*)
2482 ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
2483 ;; #(vector <pattern>) (list->vector <pattern>)
2484 ;; #(atom <object>) <object> with "equal?"
2486 ;; Vector cops out to pair under assumption that vectors are rare. If
2487 ;; not, should convert to:
2488 ;; #(vector <pattern>*) #(<pattern>*)
2496 (let ((first (match (car e) p w '() mod)))
2498 (let ((rest (match-each (cdr e) p w mod)))
2499 (and rest (cons first rest))))))
2502 (match-each (syntax-object-expression e)
2504 (join-wraps w (syntax-object-wrap e))
2505 (syntax-object-module e)))
2509 (lambda (e x-pat y-pat z-pat w r mod)
2510 (let f ((e e) (w w))
2513 (call-with-values (lambda () (f (cdr e) w))
2514 (lambda (xr* y-pat r)
2517 (let ((xr (match (car e) x-pat w '() mod)))
2519 (values (cons xr xr*) y-pat r)
2524 (match (car e) (car y-pat) w r mod)))
2525 (values #f #f #f)))))
2527 (f (syntax-object-expression e) (join-wraps w e)))
2529 (values '() y-pat (match e z-pat w r mod)))))))
2531 (define match-each-any
2535 (let ((l (match-each-any (cdr e) w mod)))
2536 (and l (cons (wrap (car e) w mod) l))))
2539 (match-each-any (syntax-object-expression e)
2540 (join-wraps w (syntax-object-wrap e))
2549 ((eq? p 'any) (cons '() r))
2550 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2551 ((eq? p 'each-any) (cons '() r))
2553 (case (vector-ref p 0)
2554 ((each) (match-empty (vector-ref p 1) r))
2555 ((each+) (match-empty (vector-ref p 1)
2557 (reverse (vector-ref p 2))
2558 (match-empty (vector-ref p 3) r))))
2560 ((vector) (match-empty (vector-ref p 1) r)))))))
2564 (if (null? (car r*))
2566 (cons (map car r*) (combine (map cdr r*) r)))))
2569 (lambda (e p w r mod)
2571 ((null? p) (and (null? e) r))
2573 (and (pair? e) (match (car e) (car p) w
2574 (match (cdr e) (cdr p) w r mod)
2577 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2579 (case (vector-ref p 0)
2582 (match-empty (vector-ref p 1) r)
2583 (let ((l (match-each e (vector-ref p 1) w mod)))
2585 (let collect ((l l))
2588 (cons (map car l) (collect (map cdr l)))))))))
2592 (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
2593 (lambda (xr* y-pat r)
2597 (match-empty (vector-ref p 1) r)
2598 (combine xr* r))))))
2599 ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2600 ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2603 (match (vector->list e) (vector-ref p 1) w r mod))))))))
2606 (lambda (e p w r mod)
2610 ((eq? p 'any) (cons (wrap e w mod) r))
2613 (syntax-object-expression e)
2615 (join-wraps w (syntax-object-wrap e))
2617 (syntax-object-module e)))
2618 (else (match* e p w r mod)))))
2623 ((eq? p 'any) (list e))
2626 (match* (syntax-object-expression e)
2627 p (syntax-object-wrap e) '() (syntax-object-module e)))
2628 (else (match* e p empty-wrap '() #f))))))))
2631 (define-syntax with-syntax
2635 #'(let () e1 e2 ...))
2636 ((_ ((out in)) e1 e2 ...)
2637 #'(syntax-case in ()
2638 (out (let () e1 e2 ...))))
2639 ((_ ((out in) ...) e1 e2 ...)
2640 #'(syntax-case (list in ...) ()
2641 ((out ...) (let () e1 e2 ...)))))))
2643 (define-syntax syntax-rules
2646 ((_ (k ...) ((keyword . pattern) template) ...)
2648 ;; embed patterns as procedure metadata
2649 #((macro-type . syntax-rules)
2650 (patterns pattern ...))
2651 (syntax-case x (k ...)
2652 ((dummy . pattern) #'template)
2654 ((_ (k ...) docstring ((keyword . pattern) template) ...)
2655 (string? (syntax->datum #'docstring))
2657 ;; the same, but allow a docstring
2659 #((macro-type . syntax-rules)
2660 (patterns pattern ...))
2661 (syntax-case x (k ...)
2662 ((dummy . pattern) #'template)
2668 ((let* ((x v) ...) e1 e2 ...)
2669 (and-map identifier? #'(x ...))
2670 (let f ((bindings #'((x v) ...)))
2671 (if (null? bindings)
2672 #'(let () e1 e2 ...)
2673 (with-syntax ((body (f (cdr bindings)))
2674 (binding (car bindings)))
2675 #'(let (binding) body))))))))
2679 (syntax-case orig-x ()
2680 ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2681 (with-syntax (((step ...)
2686 (_ (syntax-violation
2687 'do "bad step expression"
2691 (syntax-case #'(e1 ...) ()
2692 (() #'(let doloop ((var init) ...)
2694 (begin c ... (doloop step ...)))))
2696 #'(let doloop ((var init) ...)
2699 (begin c ... (doloop step ...)))))))))))
2701 (define-syntax quasiquote
2703 (define (quasi p lev)
2704 (syntax-case p (unquote quasiquote)
2708 (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
2709 ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
2711 (syntax-case #'p (unquote unquote-splicing)
2714 (quasilist* #'(("value" p) ...) (quasi #'q lev))
2716 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2718 ((unquote-splicing p ...)
2720 (quasiappend #'(("value" p) ...) (quasi #'q lev))
2722 (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
2724 (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
2725 (#(x ...) (quasivector (vquasi #'(x ...) lev)))
2727 (define (vquasi p lev)
2730 (syntax-case #'p (unquote unquote-splicing)
2733 (quasilist* #'(("value" p) ...) (vquasi #'q lev))
2735 (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2737 ((unquote-splicing p ...)
2739 (quasiappend #'(("value" p) ...) (vquasi #'q lev))
2742 #'("quote" unquote-splicing)
2743 (quasi #'(p ...) (- lev 1)))
2745 (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
2746 (() #'("quote" ()))))
2747 (define (quasicons x y)
2748 (with-syntax ((x x) (y y))
2752 (("quote" dx) #'("quote" (dx . dy)))
2753 (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
2754 (("list" . stuff) #'("list" x . stuff))
2755 (("list*" . stuff) #'("list*" x . stuff))
2756 (_ #'("list*" x y)))))
2757 (define (quasiappend x y)
2761 ((null? x) #'("quote" ()))
2762 ((null? (cdr x)) (car x))
2763 (else (with-syntax (((p ...) x)) #'("append" p ...)))))
2767 (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
2768 (define (quasilist* x y)
2772 (quasicons (car x) (f (cdr x))))))
2773 (define (quasivector x)
2775 (("quote" (x ...)) #'("quote" #(x ...)))
2777 (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
2779 (("quote" (y ...)) (k #'(("quote" y) ...)))
2780 (("list" y ...) (k #'(y ...)))
2781 (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
2782 (else #`("list->vector" #,x)))))))
2786 (("list" x ...) #`(list #,@(map emit #'(x ...))))
2787 ;; could emit list* for 3+ arguments if implementation supports
2790 (let f ((x* #'(x ...)))
2793 #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
2794 (("append" x ...) #`(append #,@(map emit #'(x ...))))
2795 (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
2796 (("list->vector" x) #`(list->vector #,(emit #'x)))
2800 ;; convert to intermediate language, combining introduced (but
2801 ;; not unquoted source) quote expressions where possible and
2802 ;; choosing optimal construction code otherwise, then emit
2803 ;; Scheme code corresponding to the intermediate language forms.
2804 ((_ e) (emit (quasi #'e 0)))))))
2806 (define-syntax include
2810 (let ((p (open-input-file fn)))
2811 (let f ((x (read p))
2815 (close-input-port p)
2818 (cons (datum->syntax k x) result)))))))
2821 (let ((fn (syntax->datum #'filename)))
2822 (with-syntax (((exp ...) (read-file fn #'filename)))
2823 #'(begin exp ...)))))))
2825 (define-syntax include-from-path
2829 (let ((fn (syntax->datum #'filename)))
2830 (with-syntax ((fn (datum->syntax
2832 (or (%search-load-path fn)
2833 (syntax-violation 'include-from-path
2834 "file not found in path"
2836 #'(include fn)))))))
2838 (define-syntax unquote
2840 (syntax-violation 'unquote
2841 "expression not valid outside of quasiquote"
2844 (define-syntax unquote-splicing
2846 (syntax-violation 'unquote-splicing
2847 "expression not valid outside of quasiquote"
2855 ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
2857 (syntax-case clause (else)
2858 ((else e1 e2 ...) #'(begin e1 e2 ...))
2859 (((k ...) e1 e2 ...)
2860 #'(if (memv t '(k ...)) (begin e1 e2 ...)))
2861 (_ (syntax-violation 'case "bad clause" x clause)))
2862 (with-syntax ((rest (f (car clauses) (cdr clauses))))
2863 (syntax-case clause (else)
2864 (((k ...) e1 e2 ...)
2865 #'(if (memv t '(k ...))
2868 (_ (syntax-violation 'case "bad clause" x
2870 #'(let ((t e)) body))))))
2872 (define (make-variable-transformer proc)
2873 (if (procedure? proc)
2874 (let ((trans (lambda (x)
2875 #((macro-type . variable-transformer))
2877 (set-procedure-property! trans 'variable-transformer #t)
2879 (error "variable transformer not a procedure" proc)))
2881 (define-syntax identifier-syntax
2883 (syntax-case x (set!)
2886 #((macro-type . identifier-syntax))
2892 #'(e x (... ...))))))
2893 ((_ (id exp1) ((set! var val) exp2))
2894 (and (identifier? #'id) (identifier? #'var))
2895 #'(make-variable-transformer
2897 #((macro-type . variable-transformer))
2898 (syntax-case x (set!)
2899 ((set! var val) #'exp2)
2900 ((id x (... ...)) #'(exp1 x (... ...)))
2901 (id (identifier? #'id) #'exp1))))))))
2903 (define-syntax define*
2906 ((_ (id . args) b0 b1 ...)
2907 #'(define id (lambda* args b0 b1 ...)))
2908 ((_ id val) (identifier? #'x)
2909 #'(define id val)))))