module/ice-9/psyntax.scm

   1 ;;;; -*-scheme-*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
   4 ;;;;
   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.
   9 ;;;;
  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.
  14 ;;;;
  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
  18 ;;;;
  19 \f
  20
  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
  24
  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.
  35
  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
  40
  41 ;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
  42 ;;; revision control logs corresponding to this file: 2009, 2010.
  43
  44
  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
  49 ;;; R6RS:
  50 ;;;
  51 ;;;   bound-identifier=?
  52 ;;;   datum->syntax
  53 ;;;   define-syntax
  54 ;;;   fluid-let-syntax
  55 ;;;   free-identifier=?
  56 ;;;   generate-temporaries
  57 ;;;   identifier?
  58 ;;;   identifier-syntax
  59 ;;;   let-syntax
  60 ;;;   letrec-syntax
  61 ;;;   syntax
  62 ;;;   syntax-case
  63 ;;;   syntax->datum
  64 ;;;   syntax-rules
  65 ;;;   with-syntax
  66 ;;;
  67 ;;; Additionally, the expander provides definitions for a number of core
  68 ;;; Scheme syntactic bindings, such as `let', `lambda', and the like.
  69
  70 ;;; The remaining exports are listed below:
  71 ;;;
  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
  85
  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.
  90
  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
  94 ;;;
  95 ;;;   (define-syntax top-wrap (identifier-syntax '((top))))
  96 ;;;   (define-syntax top-marked?
  97 ;;;     (syntax-rules ()
  98 ;;;       ((_ w) (memq 'top (wrap-marks w)))))
  99 ;;;
 100 ;;; rather than
 101 ;;;
 102 ;;;   (define top-wrap '((top)))
 103 ;;;   (define top-marked?
 104 ;;;     (lambda (w) (memq 'top (wrap-marks w))))
 105 ;;;
 106 ;;; On the other hand, we don't do this consistently; we define
 107 ;;; make-wrap, wrap-marks, and wrap-subst simply as
 108 ;;;
 109 ;;;   (define make-wrap cons)
 110 ;;;   (define wrap-marks car)
 111 ;;;   (define wrap-subst cdr)
 112 ;;;
 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.
 117
 118
 119 ;;; Implementation notes:
 120
 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.
 125
 126 ;;; All identifiers that don't have macro definitions and are not bound
 127 ;;; lexically are assumed to be global variables.
 128
 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.
 133
 134 ;;; Identifiers and syntax objects are implemented as vectors for
 135 ;;; portability.  As a result, it is possible to "forge" syntax objects.
 136
 137 ;;; The implementation of generate-temporaries assumes that it is
 138 ;;; possible to generate globally unique symbols (gensyms).
 139
 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".
 144
 145
 146 ;;; Bootstrapping:
 147
 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.
 152
 153
 154
 155 (eval-when (compile)
 156   (set-current-module (resolve-module '(guile))))
 157
 158 (let ()
 159   (define-syntax define-expansion-constructors
 160     (lambda (x)
 161       (syntax-case x ()
 162         ((_)
 163          (let lp ((n 0) (out '()))
 164            (if (< n (vector-length %expanded-vtables))
 165                (lp (1+ n)
 166                    (let* ((vtable (vector-ref %expanded-vtables n))
 167                           (stem (struct-ref vtable (+ vtable-offset-user 0)))
 168                           (fields (struct-ref vtable (+ vtable-offset-user 2)))
 169                           (sfields (map (lambda (f) (datum->syntax x f)) fields))
 170                           (ctor (datum->syntax x (symbol-append 'make- stem))))
 171                      (cons #`(define (#,ctor #,@sfields)
 172                                (make-struct (vector-ref %expanded-vtables #,n) 0
 173                                             #,@sfields))
 174                            out)))
 175                #`(begin #,@(reverse out))))))))
 176
 177   (define-syntax define-expansion-accessors
 178     (lambda (x)
 179       (syntax-case x ()
 180         ((_ stem field ...)
 181          (let lp ((n 0))
 182            (let ((vtable (vector-ref %expanded-vtables n))
 183                  (stem (syntax->datum #'stem)))
 184              (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
 185                  #`(begin
 186                      (define (#,(datum->syntax x (symbol-append stem '?)) x)
 187                        (and (struct? x)
 188                             (eq? (struct-vtable x)
 189                                  (vector-ref %expanded-vtables #,n))))
 190                      #,@(map
 191                          (lambda (f)
 192                            (let ((get (datum->syntax x (symbol-append stem '- f)))
 193                                  (set (datum->syntax x (symbol-append 'set- stem '- f '!)))
 194                                  (idx (list-index (struct-ref vtable
 195                                                               (+ vtable-offset-user 2))
 196                                                   f)))
 197                              #`(begin
 198                                  (define (#,get x)
 199                                    (struct-ref x #,idx))
 200                                  (define (#,set x v)
 201                                    (struct-set! x #,idx v)))))
 202                          (syntax->datum #'(field ...))))
 203                  (lp (1+ n)))))))))
 204
 205   (define-syntax define-structure
 206     (lambda (x)
 207       (define construct-name
 208         (lambda (template-identifier . args)
 209           (datum->syntax
 210            template-identifier
 211            (string->symbol
 212             (apply string-append
 213                    (map (lambda (x)
 214                           (if (string? x)
 215                               x
 216                               (symbol->string (syntax->datum x))))
 217                         args))))))
 218       (syntax-case x ()
 219         ((_ (name id1 ...))
 220          (and-map identifier? #'(name id1 ...))
 221          (with-syntax
 222              ((constructor (construct-name #'name "make-" #'name))
 223               (predicate (construct-name #'name #'name "?"))
 224               ((access ...)
 225                (map (lambda (x) (construct-name x #'name "-" x))
 226                     #'(id1 ...)))
 227               ((assign ...)
 228                (map (lambda (x)
 229                       (construct-name x "set-" #'name "-" x "!"))
 230                     #'(id1 ...)))
 231               (structure-length
 232                (+ (length #'(id1 ...)) 1))
 233               ((index ...)
 234                (let f ((i 1) (ids #'(id1 ...)))
 235                  (if (null? ids)
 236                      '()
 237                      (cons i (f (+ i 1) (cdr ids)))))))
 238            #'(begin
 239                (define constructor
 240                  (lambda (id1 ...)
 241                    (vector 'name id1 ... )))
 242                (define predicate
 243                  (lambda (x)
 244                    (and (vector? x)
 245                         (= (vector-length x) structure-length)
 246                         (eq? (vector-ref x 0) 'name))))
 247                (define access
 248                  (lambda (x)
 249                    (vector-ref x index)))
 250                ...
 251                (define assign
 252                  (lambda (x update)
 253                    (vector-set! x index update)))
 254                ...))))))
 255
 256   (let ()
 257     (define-expansion-constructors)
 258     (define-expansion-accessors lambda meta)
 259
 260     ;; hooks to nonportable run-time helpers
 261     (begin
 262       (define-syntax fx+ (identifier-syntax +))
 263       (define-syntax fx- (identifier-syntax -))
 264       (define-syntax fx= (identifier-syntax =))
 265       (define-syntax fx< (identifier-syntax <))
 266
 267       (define top-level-eval-hook
 268         (lambda (x mod)
 269           (primitive-eval x)))
 270
 271       (define local-eval-hook
 272         (lambda (x mod)
 273           (primitive-eval x)))
 274
 275       (define-syntax-rule (gensym-hook)
 276         (gensym))
 277
 278       (define put-global-definition-hook
 279         (lambda (symbol type val)
 280           (module-define! (current-module)
 281                           symbol
 282                           (make-syntax-transformer symbol type val))))
 283
 284       (define get-global-definition-hook
 285         (lambda (symbol module)
 286           (if (and (not module) (current-module))
 287               (warn "module system is booted, we should have a module" symbol))
 288           (let ((v (module-variable (if module
 289                                         (resolve-module (cdr module))
 290                                         (current-module))
 291                                     symbol)))
 292             (and v (variable-bound? v)
 293                  (let ((val (variable-ref v)))
 294                    (and (macro? val) (macro-type val)
 295                         (cons (macro-type val)
 296                               (macro-binding val)))))))))
 297
 298
 299     (define (decorate-source e s)
 300       (if (and (pair? e) s)
 301           (set-source-properties! e s))
 302       e)
 303
 304     (define (maybe-name-value! name val)
 305       (if (lambda? val)
 306           (let ((meta (lambda-meta val)))
 307             (if (not (assq 'name meta))
 308                 (set-lambda-meta! val (acons 'name name meta))))))
 309
 310     ;; output constructors
 311     (define build-void
 312       (lambda (source)
 313         (make-void source)))
 314
 315     (define build-application
 316       (lambda (source fun-exp arg-exps)
 317         (make-application source fun-exp arg-exps)))
 318
 319     (define build-conditional
 320       (lambda (source test-exp then-exp else-exp)
 321         (make-conditional source test-exp then-exp else-exp)))
 322
 323     (define build-dynlet
 324       (lambda (source fluids vals body)
 325         (make-dynlet source fluids vals body)))
 326
 327     (define build-lexical-reference
 328       (lambda (type source name var)
 329         (make-lexical-ref source name var)))
 330
 331     (define build-lexical-assignment
 332       (lambda (source name var exp)
 333         (maybe-name-value! name exp)
 334         (make-lexical-set source name var exp)))
 335
 336     (define (analyze-variable mod var modref-cont bare-cont)
 337       (if (not mod)
 338           (bare-cont var)
 339           (let ((kind (car mod))
 340                 (mod (cdr mod)))
 341             (case kind
 342               ((public) (modref-cont mod var #t))
 343               ((private) (if (not (equal? mod (module-name (current-module))))
 344                              (modref-cont mod var #f)
 345                              (bare-cont var)))
 346               ((bare) (bare-cont var))
 347               ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
 348                                   (module-variable (resolve-module mod) var))
 349                              (modref-cont mod var #f)
 350                              (bare-cont var)))
 351               (else (syntax-violation #f "bad module kind" var mod))))))
 352
 353     (define build-global-reference
 354       (lambda (source var mod)
 355         (analyze-variable
 356          mod var
 357          (lambda (mod var public?)
 358            (make-module-ref source mod var public?))
 359          (lambda (var)
 360            (make-toplevel-ref source var)))))
 361
 362     (define build-global-assignment
 363       (lambda (source var exp mod)
 364         (maybe-name-value! var exp)
 365         (analyze-variable
 366          mod var
 367          (lambda (mod var public?)
 368            (make-module-set source mod var public? exp))
 369          (lambda (var)
 370            (make-toplevel-set source var exp)))))
 371
 372     (define build-global-definition
 373       (lambda (source var exp)
 374         (maybe-name-value! var exp)
 375         (make-toplevel-define source var exp)))
 376
 377     (define build-simple-lambda
 378       (lambda (src req rest vars meta exp)
 379         (make-lambda src
 380                      meta
 381                      ;; hah, a case in which kwargs would be nice.
 382                      (make-lambda-case
 383                       ;; src req opt rest kw inits vars body else
 384                       src req #f rest #f '() vars exp #f))))
 385
 386     (define build-case-lambda
 387       (lambda (src meta body)
 388         (make-lambda src meta body)))
 389
 390     (define build-lambda-case
 391       ;; req := (name ...)
 392       ;; opt := (name ...) | #f
 393       ;; rest := name | #f
 394       ;; kw := (allow-other-keys? (keyword name var) ...) | #f
 395       ;; inits: (init ...)
 396       ;; vars: (sym ...)
 397       ;; vars map to named arguments in the following order:
 398       ;;  required, optional (positional), rest, keyword.
 399       ;; the body of a lambda: anything, already expanded
 400       ;; else: lambda-case | #f
 401       (lambda (src req opt rest kw inits vars body else-case)
 402         (make-lambda-case src req opt rest kw inits vars body else-case)))
 403
 404     (define build-primref
 405       (lambda (src name)
 406         (if (equal? (module-name (current-module)) '(guile))
 407             (make-toplevel-ref src name)
 408             (make-module-ref src '(guile) name #f))))
 409
 410     (define (build-data src exp)
 411       (make-const src exp))
 412
 413     (define build-sequence
 414       (lambda (src exps)
 415         (if (null? (cdr exps))
 416             (car exps)
 417             (make-sequence src exps))))
 418
 419     (define build-let
 420       (lambda (src ids vars val-exps body-exp)
 421         (for-each maybe-name-value! ids val-exps)
 422         (if (null? vars)
 423             body-exp
 424             (make-let src ids vars val-exps body-exp))))
 425
 426     (define build-named-let
 427       (lambda (src ids vars val-exps body-exp)
 428         (let ((f (car vars))
 429               (f-name (car ids))
 430               (vars (cdr vars))
 431               (ids (cdr ids)))
 432           (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
 433             (maybe-name-value! f-name proc)
 434             (for-each maybe-name-value! ids val-exps)
 435             (make-letrec
 436              src #f
 437              (list f-name) (list f) (list proc)
 438              (build-application src (build-lexical-reference 'fun src f-name f)
 439                                 val-exps))))))
 440
 441     (define build-letrec
 442       (lambda (src in-order? ids vars val-exps body-exp)
 443         (if (null? vars)
 444             body-exp
 445             (begin
 446               (for-each maybe-name-value! ids val-exps)
 447               (make-letrec src in-order? ids vars val-exps body-exp)))))
 448
 449
 450     ;; FIXME: use a faster gensym
 451     (define-syntax-rule (build-lexical-var src id)
 452       (gensym (string-append (symbol->string id) " ")))
 453
 454     (define-structure (syntax-object expression wrap module))
 455
 456     (define-syntax no-source (identifier-syntax #f))
 457
 458     (define source-annotation
 459       (lambda (x)
 460         (cond
 461          ((syntax-object? x)
 462           (source-annotation (syntax-object-expression x)))
 463          ((pair? x) (let ((props (source-properties x)))
 464                       (if (pair? props)
 465                           props
 466                           #f)))
 467          (else #f))))
 468
 469     (define-syntax-rule (arg-check pred? e who)
 470       (let ((x e))
 471         (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
 472
 473     ;; compile-time environments
 474
 475     ;; wrap and environment comprise two level mapping.
 476     ;;   wrap : id --> label
 477     ;;   env : label --> <element>
 478
 479     ;; environments are represented in two parts: a lexical part and a global
 480     ;; part.  The lexical part is a simple list of associations from labels
 481     ;; to bindings.  The global part is implemented by
 482     ;; {put,get}-global-definition-hook and associates symbols with
 483     ;; bindings.
 484
 485     ;; global (assumed global variable) and displaced-lexical (see below)
 486     ;; do not show up in any environment; instead, they are fabricated by
 487     ;; lookup when it finds no other bindings.
 488
 489     ;; <environment>              ::= ((<label> . <binding>)*)
 490
 491     ;; identifier bindings include a type and a value
 492
 493     ;; <binding> ::= (macro . <procedure>)           macros
 494     ;;               (core . <procedure>)            core forms
 495     ;;               (module-ref . <procedure>)      @ or @@
 496     ;;               (begin)                         begin
 497     ;;               (define)                        define
 498     ;;               (define-syntax)                 define-syntax
 499     ;;               (local-syntax . rec?)           let-syntax/letrec-syntax
 500     ;;               (eval-when)                     eval-when
 501     ;;               (syntax . (<var> . <level>))    pattern variables
 502     ;;               (global)                        assumed global variable
 503     ;;               (lexical . <var>)               lexical variables
 504     ;;               (displaced-lexical)             displaced lexicals
 505     ;; <level>   ::= <nonnegative integer>
 506     ;; <var>     ::= variable returned by build-lexical-var
 507
 508     ;; a macro is a user-defined syntactic-form.  a core is a system-defined
 509     ;; syntactic form.  begin, define, define-syntax, and eval-when are
 510     ;; treated specially since they are sensitive to whether the form is
 511     ;; at top-level and (except for eval-when) can denote valid internal
 512     ;; definitions.
 513
 514     ;; a pattern variable is a variable introduced by syntax-case and can
 515     ;; be referenced only within a syntax form.
 516
 517     ;; any identifier for which no top-level syntax definition or local
 518     ;; binding of any kind has been seen is assumed to be a global
 519     ;; variable.
 520
 521     ;; a lexical variable is a lambda- or letrec-bound variable.
 522
 523     ;; a displaced-lexical identifier is a lexical identifier removed from
 524     ;; it's scope by the return of a syntax object containing the identifier.
 525     ;; a displaced lexical can also appear when a letrec-syntax-bound
 526     ;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
 527     ;; a displaced lexical should never occur with properly written macros.
 528
 529     (define-syntax make-binding
 530       (syntax-rules (quote)
 531         ((_ type value) (cons type value))
 532         ((_ 'type) '(type))
 533         ((_ type) (cons type '()))))
 534     (define-syntax-rule (binding-type x)
 535       (car x))
 536     (define-syntax-rule (binding-value x)
 537       (cdr x))
 538
 539     (define-syntax null-env (identifier-syntax '()))
 540
 541     (define extend-env
 542       (lambda (labels bindings r)
 543         (if (null? labels)
 544             r
 545             (extend-env (cdr labels) (cdr bindings)
 546                         (cons (cons (car labels) (car bindings)) r)))))
 547
 548     (define extend-var-env
 549       ;; variant of extend-env that forms "lexical" binding
 550       (lambda (labels vars r)
 551         (if (null? labels)
 552             r
 553             (extend-var-env (cdr labels) (cdr vars)
 554                             (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
 555
 556     ;; we use a "macros only" environment in expansion of local macro
 557     ;; definitions so that their definitions can use local macros without
 558     ;; attempting to use other lexical identifiers.
 559     (define macros-only-env
 560       (lambda (r)
 561         (if (null? r)
 562             '()
 563             (let ((a (car r)))
 564               (if (eq? (cadr a) 'macro)
 565                   (cons a (macros-only-env (cdr r)))
 566                   (macros-only-env (cdr r)))))))
 567
 568     (define lookup
 569       ;; x may be a label or a symbol
 570       ;; although symbols are usually global, we check the environment first
 571       ;; anyway because a temporary binding may have been established by
 572       ;; fluid-let-syntax
 573       (lambda (x r mod)
 574         (cond
 575          ((assq x r) => cdr)
 576          ((symbol? x)
 577           (or (get-global-definition-hook x mod) (make-binding 'global)))
 578          (else (make-binding 'displaced-lexical)))))
 579
 580     (define global-extend
 581       (lambda (type sym val)
 582         (put-global-definition-hook sym type val)))
 583
 584
 585     ;; Conceptually, identifiers are always syntax objects.  Internally,
 586     ;; however, the wrap is sometimes maintained separately (a source of
 587     ;; efficiency and confusion), so that symbols are also considered
 588     ;; identifiers by id?.  Externally, they are always wrapped.
 589
 590     (define nonsymbol-id?
 591       (lambda (x)
 592         (and (syntax-object? x)
 593              (symbol? (syntax-object-expression x)))))
 594
 595     (define id?
 596       (lambda (x)
 597         (cond
 598          ((symbol? x) #t)
 599          ((syntax-object? x) (symbol? (syntax-object-expression x)))
 600          (else #f))))
 601
 602     (define-syntax-rule (id-sym-name e)
 603       (let ((x e))
 604         (if (syntax-object? x)
 605             (syntax-object-expression x)
 606             x)))
 607
 608     (define id-sym-name&marks
 609       (lambda (x w)
 610         (if (syntax-object? x)
 611             (values
 612              (syntax-object-expression x)
 613              (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
 614             (values x (wrap-marks w)))))
 615
 616     ;; syntax object wraps
 617
 618     ;;         <wrap> ::= ((<mark> ...) . (<subst> ...))
 619     ;;        <subst> ::= <shift> | <subs>
 620     ;;         <subs> ::= #(<old name> <label> (<mark> ...))
 621     ;;        <shift> ::= positive fixnum
 622
 623     (define-syntax make-wrap (identifier-syntax cons))
 624     (define-syntax wrap-marks (identifier-syntax car))
 625     (define-syntax wrap-subst (identifier-syntax cdr))
 626
 627     (define-syntax subst-rename? (identifier-syntax vector?))
 628     (define-syntax-rule (rename-old x) (vector-ref x 0))
 629     (define-syntax-rule (rename-new x) (vector-ref x 1))
 630     (define-syntax-rule (rename-marks x) (vector-ref x 2))
 631     (define-syntax-rule (make-rename old new marks)
 632       (vector old new marks))
 633
 634     ;; labels must be comparable with "eq?", have read-write invariance,
 635     ;; and distinct from symbols.
 636     (define gen-label
 637       (lambda () (symbol->string (gensym "i"))))
 638
 639     (define gen-labels
 640       (lambda (ls)
 641         (if (null? ls)
 642             '()
 643             (cons (gen-label) (gen-labels (cdr ls))))))
 644
 645     (define-structure (ribcage symnames marks labels))
 646
 647     (define-syntax empty-wrap (identifier-syntax '(())))
 648
 649     (define-syntax top-wrap (identifier-syntax '((top))))
 650
 651     (define-syntax-rule (top-marked? w)
 652       (memq 'top (wrap-marks w)))
 653
 654     ;; Marks must be comparable with "eq?" and distinct from pairs and
 655     ;; the symbol top.  We do not use integers so that marks will remain
 656     ;; unique even across file compiles.
 657
 658     (define-syntax the-anti-mark (identifier-syntax #f))
 659
 660     (define anti-mark
 661       (lambda (w)
 662         (make-wrap (cons the-anti-mark (wrap-marks w))
 663                    (cons 'shift (wrap-subst w)))))
 664
 665     (define-syntax-rule (new-mark)
 666       (gensym "m"))
 667
 668     ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
 669     ;; internal definitions, in which the ribcages are built incrementally
 670     (define-syntax-rule (make-empty-ribcage)
 671       (make-ribcage '() '() '()))
 672
 673     (define extend-ribcage!
 674       ;; must receive ids with complete wraps
 675       (lambda (ribcage id label)
 676         (set-ribcage-symnames! ribcage
 677                                (cons (syntax-object-expression id)
 678                                      (ribcage-symnames ribcage)))
 679         (set-ribcage-marks! ribcage
 680                             (cons (wrap-marks (syntax-object-wrap id))
 681                                   (ribcage-marks ribcage)))
 682         (set-ribcage-labels! ribcage
 683                              (cons label (ribcage-labels ribcage)))))
 684
 685     ;; make-binding-wrap creates vector-based ribcages
 686     (define make-binding-wrap
 687       (lambda (ids labels w)
 688         (if (null? ids)
 689             w
 690             (make-wrap
 691              (wrap-marks w)
 692              (cons
 693               (let ((labelvec (list->vector labels)))
 694                 (let ((n (vector-length labelvec)))
 695                   (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
 696                     (let f ((ids ids) (i 0))
 697                       (if (not (null? ids))
 698                           (call-with-values
 699                               (lambda () (id-sym-name&marks (car ids) w))
 700                             (lambda (symname marks)
 701                               (vector-set! symnamevec i symname)
 702                               (vector-set! marksvec i marks)
 703                               (f (cdr ids) (fx+ i 1))))))
 704                     (make-ribcage symnamevec marksvec labelvec))))
 705               (wrap-subst w))))))
 706
 707     (define smart-append
 708       (lambda (m1 m2)
 709         (if (null? m2)
 710             m1
 711             (append m1 m2))))
 712
 713     (define join-wraps
 714       (lambda (w1 w2)
 715         (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
 716           (if (null? m1)
 717               (if (null? s1)
 718                   w2
 719                   (make-wrap
 720                    (wrap-marks w2)
 721                    (smart-append s1 (wrap-subst w2))))
 722               (make-wrap
 723                (smart-append m1 (wrap-marks w2))
 724                (smart-append s1 (wrap-subst w2)))))))
 725
 726     (define join-marks
 727       (lambda (m1 m2)
 728         (smart-append m1 m2)))
 729
 730     (define same-marks?
 731       (lambda (x y)
 732         (or (eq? x y)
 733             (and (not (null? x))
 734                  (not (null? y))
 735                  (eq? (car x) (car y))
 736                  (same-marks? (cdr x) (cdr y))))))
 737
 738     (define id-var-name
 739       (lambda (id w)
 740         (define-syntax-rule (first e)
 741           ;; Rely on Guile's multiple-values truncation.
 742           e)
 743         (define search
 744           (lambda (sym subst marks)
 745             (if (null? subst)
 746                 (values #f marks)
 747                 (let ((fst (car subst)))
 748                   (if (eq? fst 'shift)
 749                       (search sym (cdr subst) (cdr marks))
 750                       (let ((symnames (ribcage-symnames fst)))
 751                         (if (vector? symnames)
 752                             (search-vector-rib sym subst marks symnames fst)
 753                             (search-list-rib sym subst marks symnames fst))))))))
 754         (define search-list-rib
 755           (lambda (sym subst marks symnames ribcage)
 756             (let f ((symnames symnames) (i 0))
 757               (cond
 758                ((null? symnames) (search sym (cdr subst) marks))
 759                ((and (eq? (car symnames) sym)
 760                      (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
 761                 (values (list-ref (ribcage-labels ribcage) i) marks))
 762                (else (f (cdr symnames) (fx+ i 1)))))))
 763         (define search-vector-rib
 764           (lambda (sym subst marks symnames ribcage)
 765             (let ((n (vector-length symnames)))
 766               (let f ((i 0))
 767                 (cond
 768                  ((fx= i n) (search sym (cdr subst) marks))
 769                  ((and (eq? (vector-ref symnames i) sym)
 770                        (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
 771                   (values (vector-ref (ribcage-labels ribcage) i) marks))
 772                  (else (f (fx+ i 1))))))))
 773         (cond
 774          ((symbol? id)
 775           (or (first (search id (wrap-subst w) (wrap-marks w))) id))
 776          ((syntax-object? id)
 777           (let ((id (syntax-object-expression id))
 778                 (w1 (syntax-object-wrap id)))
 779             (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
 780               (call-with-values (lambda () (search id (wrap-subst w) marks))
 781                 (lambda (new-id marks)
 782                   (or new-id
 783                       (first (search id (wrap-subst w1) marks))
 784                       id))))))
 785          (else (syntax-violation 'id-var-name "invalid id" id)))))
 786
 787     ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
 788     ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
 789
 790     (define free-id=?
 791       (lambda (i j)
 792         (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
 793              (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
 794
 795     ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
 796     ;; long as the missing portion of the wrap is common to both of the ids
 797     ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
 798
 799     (define bound-id=?
 800       (lambda (i j)
 801         (if (and (syntax-object? i) (syntax-object? j))
 802             (and (eq? (syntax-object-expression i)
 803                       (syntax-object-expression j))
 804                  (same-marks? (wrap-marks (syntax-object-wrap i))
 805                               (wrap-marks (syntax-object-wrap j))))
 806             (eq? i j))))
 807
 808     ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
 809     ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
 810     ;; as long as the missing portion of the wrap is common to all of the
 811     ;; ids.
 812
 813     (define valid-bound-ids?
 814       (lambda (ids)
 815         (and (let all-ids? ((ids ids))
 816                (or (null? ids)
 817                    (and (id? (car ids))
 818                         (all-ids? (cdr ids)))))
 819              (distinct-bound-ids? ids))))
 820
 821     ;; distinct-bound-ids? expects a list of ids and returns #t if there are
 822     ;; no duplicates.  It is quadratic on the length of the id list; long
 823     ;; lists could be sorted to make it more efficient.  distinct-bound-ids?
 824     ;; may be passed unwrapped (or partially wrapped) ids as long as the
 825     ;; missing portion of the wrap is common to all of the ids.
 826
 827     (define distinct-bound-ids?
 828       (lambda (ids)
 829         (let distinct? ((ids ids))
 830           (or (null? ids)
 831               (and (not (bound-id-member? (car ids) (cdr ids)))
 832                    (distinct? (cdr ids)))))))
 833
 834     (define bound-id-member?
 835       (lambda (x list)
 836         (and (not (null? list))
 837              (or (bound-id=? x (car list))
 838                  (bound-id-member? x (cdr list))))))
 839
 840     ;; wrapping expressions and identifiers
 841
 842     (define wrap
 843       (lambda (x w defmod)
 844         (cond
 845          ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
 846          ((syntax-object? x)
 847           (make-syntax-object
 848            (syntax-object-expression x)
 849            (join-wraps w (syntax-object-wrap x))
 850            (syntax-object-module x)))
 851          ((null? x) x)
 852          (else (make-syntax-object x w defmod)))))
 853
 854     (define source-wrap
 855       (lambda (x w s defmod)
 856         (wrap (decorate-source x s) w defmod)))
 857
 858     ;; expanding
 859
 860     (define expand-sequence
 861       (lambda (body r w s mod)
 862         (build-sequence s
 863                         (let dobody ((body body) (r r) (w w) (mod mod))
 864                           (if (null? body)
 865                               '()
 866                               (let ((first (expand (car body) r w mod)))
 867                                 (cons first (dobody (cdr body) r w mod))))))))
 868
 869     ;; At top-level, we allow mixed definitions and expressions.  Like
 870     ;; expand-body we expand in two passes.
 871     ;;
 872     ;; First, from left to right, we expand just enough to know what
 873     ;; expressions are definitions, syntax definitions, and splicing
 874     ;; statements (`begin').  If we anything needs evaluating at
 875     ;; expansion-time, it is expanded directly.
 876     ;;
 877     ;; Otherwise we collect expressions to expand, in thunks, and then
 878     ;; expand them all at the end.  This allows all syntax expanders
 879     ;; visible in a toplevel sequence to be visible during the
 880     ;; expansions of all normal definitions and expressions in the
 881     ;; sequence.
 882     ;;
 883     (define expand-top-sequence
 884       (lambda (body r w s m esew mod)
 885         (define (scan body r w s m esew mod exps)
 886           (cond
 887            ((null? body)
 888             ;; in reversed order
 889             exps)
 890            (else
 891             (call-with-values
 892                 (lambda ()
 893                   (call-with-values
 894                       (lambda ()
 895                         (let ((e (car body)))
 896                           (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
 897                     (lambda (type value e w s mod)
 898                       (case type
 899                         ((begin-form)
 900                          (syntax-case e ()
 901                            ((_) exps)
 902                            ((_ e1 e2 ...)
 903                             (scan #'(e1 e2 ...) r w s m esew mod exps))))
 904                         ((local-syntax-form)
 905                          (expand-local-syntax value e r w s mod
 906                                               (lambda (body r w s mod)
 907                                                 (scan body r w s m esew mod exps))))
 908                         ((eval-when-form)
 909                          (syntax-case e ()
 910                            ((_ (x ...) e1 e2 ...)
 911                             (let ((when-list (parse-when-list e #'(x ...)))
 912                                   (body #'(e1 e2 ...)))
 913                               (cond
 914                                ((eq? m 'e)
 915                                 (if (memq 'eval when-list)
 916                                     (scan body r w s
 917                                           (if (memq 'expand when-list) 'c&e 'e)
 918                                           '(eval)
 919                                           mod exps)
 920                                     (begin
 921                                       (if (memq 'expand when-list)
 922                                           (top-level-eval-hook
 923                                            (expand-top-sequence body r w s 'e '(eval) mod)
 924                                            mod))
 925                                       (values exps))))
 926                                ((memq 'load when-list)
 927                                 (if (or (memq 'compile when-list)
 928                                         (memq 'expand when-list)
 929                                         (and (eq? m 'c&e) (memq 'eval when-list)))
 930                                     (scan body r w s 'c&e '(compile load) mod exps)
 931                                     (if (memq m '(c c&e))
 932                                         (scan body r w s 'c '(load) mod exps)
 933                                         (values exps))))
 934                                ((or (memq 'compile when-list)
 935                                     (memq 'expand when-list)
 936                                     (and (eq? m 'c&e) (memq 'eval when-list)))
 937                                 (top-level-eval-hook
 938                                  (expand-top-sequence body r w s 'e '(eval) mod)
 939                                  mod)
 940                                 (values exps))
 941                                (else
 942                                 (values exps)))))))
 943                         ((define-syntax-form)
 944                          (let ((n (id-var-name value w)) (r (macros-only-env r)))
 945                            (case m
 946                              ((c)
 947                               (if (memq 'compile esew)
 948                                   (let ((e (expand-install-global n (expand e r w mod))))
 949                                     (top-level-eval-hook e mod)
 950                                     (if (memq 'load esew)
 951                                         (values (cons e exps))
 952                                         (values exps)))
 953                                   (if (memq 'load esew)
 954                                       (values (cons (expand-install-global n (expand e r w mod))
 955                                                     exps))
 956                                       (values exps))))
 957                              ((c&e)
 958                               (let ((e (expand-install-global n (expand e r w mod))))
 959                                 (top-level-eval-hook e mod)
 960                                 (values (cons e exps))))
 961                              (else
 962                               (if (memq 'eval esew)
 963                                   (top-level-eval-hook
 964                                    (expand-install-global n (expand e r w mod))
 965                                    mod))
 966                               (values exps)))))
 967                         ((define-form)
 968                          (let* ((n (id-var-name value w))
 969                                 ;; Lookup the name in the module of the define form.
 970                                 (type (binding-type (lookup n r mod))))
 971                            (case type
 972                              ((global core macro module-ref)
 973                               ;; affect compile-time environment (once we have booted)
 974                               (if (and (memq m '(c c&e))
 975                                        (not (module-local-variable (current-module) n))
 976                                        (current-module))
 977                                   (let ((old (module-variable (current-module) n)))
 978                                     ;; use value of the same-named imported variable, if
 979                                     ;; any
 980                                     (if (and (variable? old) (variable-bound? old))
 981                                         (module-define! (current-module) n (variable-ref old))
 982                                         (module-add! (current-module) n (make-undefined-variable)))))
 983                               (values
 984                                (cons
 985                                 (if (eq? m 'c&e)
 986                                     (let ((x (build-global-definition s n (expand e r w mod))))
 987                                       (top-level-eval-hook x mod)
 988                                       x)
 989                                     (lambda ()
 990                                       (build-global-definition s n (expand e r w mod))))
 991                                 exps)))
 992                              ((displaced-lexical)
 993                               (syntax-violation #f "identifier out of context"
 994                                                 e (wrap value w mod)))
 995                              (else
 996                               (syntax-violation #f "cannot define keyword at top level"
 997                                                 e (wrap value w mod))))))
 998                         (else
 999                          (values (cons
1000                                   (if (eq? m 'c&e)
1001                                       (let ((x (expand-expr type value e r w s mod)))
1002                                         (top-level-eval-hook x mod)
1003                                         x)
1004                                       (lambda ()
1005                                         (expand-expr type value e r w s mod)))
1006                                   exps)))))))
1007               (lambda (exps)
1008                 (scan (cdr body) r w s m esew mod exps))))))
1009
1010         (call-with-values (lambda ()
1011                             (scan body r w s m esew mod '()))
1012           (lambda (exps)
1013             (if (null? exps)
1014                 (build-void s)
1015                 (build-sequence
1016                  s
1017                  (let lp ((in exps) (out '()))
1018                    (if (null? in) out
1019                        (let ((e (car in)))
1020                          (lp (cdr in)
1021                              (cons (if (procedure? e) (e) e) out)))))))))))
1022
1023     (define expand-install-global
1024       (lambda (name e)
1025         (build-global-definition
1026          no-source
1027          name
1028          (build-application
1029           no-source
1030           (build-primref no-source 'make-syntax-transformer)
1031           (list (build-data no-source name)
1032                 (build-data no-source 'macro)
1033                 e)))))
1034
1035     (define parse-when-list
1036       (lambda (e when-list)
1037         ;; when-list is syntax'd version of list of situations
1038         (let ((result (strip when-list empty-wrap)))
1039           (let lp ((l result))
1040             (if (null? l)
1041                 result
1042                 (if (memq (car l) '(compile load eval expand))
1043                     (lp (cdr l))
1044                     (syntax-violation 'eval-when "invalid situation" e
1045                                       (car l))))))))
1046
1047     ;; syntax-type returns six values: type, value, e, w, s, and mod. The
1048     ;; first two are described in the table below.
1049     ;;
1050     ;;    type                   value         explanation
1051     ;;    -------------------------------------------------------------------
1052     ;;    core                   procedure     core singleton
1053     ;;    core-form              procedure     core form
1054     ;;    module-ref             procedure     @ or @@ singleton
1055     ;;    lexical                name          lexical variable reference
1056     ;;    global                 name          global variable reference
1057     ;;    begin                  none          begin keyword
1058     ;;    define                 none          define keyword
1059     ;;    define-syntax          none          define-syntax keyword
1060     ;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
1061     ;;    eval-when              none          eval-when keyword
1062     ;;    syntax                 level         pattern variable
1063     ;;    displaced-lexical      none          displaced lexical identifier
1064     ;;    lexical-call           name          call to lexical variable
1065     ;;    global-call            name          call to global variable
1066     ;;    call                   none          any other call
1067     ;;    begin-form             none          begin expression
1068     ;;    define-form            id            variable definition
1069     ;;    define-syntax-form     id            syntax definition
1070     ;;    local-syntax-form      rec?          syntax definition
1071     ;;    eval-when-form         none          eval-when form
1072     ;;    constant               none          self-evaluating datum
1073     ;;    other                  none          anything else
1074     ;;
1075     ;; For define-form and define-syntax-form, e is the rhs expression.
1076     ;; For all others, e is the entire form.  w is the wrap for e.
1077     ;; s is the source for the entire form. mod is the module for e.
1078     ;;
1079     ;; syntax-type expands macros and unwraps as necessary to get to
1080     ;; one of the forms above.  It also parses define and define-syntax
1081     ;; forms, although perhaps this should be done by the consumer.
1082
1083     (define syntax-type
1084       (lambda (e r w s rib mod for-car?)
1085         (cond
1086          ((symbol? e)
1087           (let* ((n (id-var-name e w))
1088                  (b (lookup n r mod))
1089                  (type (binding-type b)))
1090             (case type
1091               ((lexical) (values type (binding-value b) e w s mod))
1092               ((global) (values type n e w s mod))
1093               ((macro)
1094                (if for-car?
1095                    (values type (binding-value b) e w s mod)
1096                    (syntax-type (expand-macro (binding-value b) e r w s rib mod)
1097                                 r empty-wrap s rib mod #f)))
1098               (else (values type (binding-value b) e w s mod)))))
1099          ((pair? e)
1100           (let ((first (car e)))
1101             (call-with-values
1102                 (lambda () (syntax-type first r w s rib mod #t))
1103               (lambda (ftype fval fe fw fs fmod)
1104                 (case ftype
1105                   ((lexical)
1106                    (values 'lexical-call fval e w s mod))
1107                   ((global)
1108                    ;; If we got here via an (@@ ...) expansion, we need to
1109                    ;; make sure the fmod information is propagated back
1110                    ;; correctly -- hence this consing.
1111                    (values 'global-call (make-syntax-object fval w fmod)
1112                            e w s mod))
1113                   ((macro)
1114                    (syntax-type (expand-macro fval e r w s rib mod)
1115                                 r empty-wrap s rib mod for-car?))
1116                   ((module-ref)
1117                    (call-with-values (lambda () (fval e r w))
1118                      (lambda (e r w s mod)
1119                        (syntax-type e r w s rib mod for-car?))))
1120                   ((core)
1121                    (values 'core-form fval e w s mod))
1122                   ((local-syntax)
1123                    (values 'local-syntax-form fval e w s mod))
1124                   ((begin)
1125                    (values 'begin-form #f e w s mod))
1126                   ((eval-when)
1127                    (values 'eval-when-form #f e w s mod))
1128                   ((define)
1129                    (syntax-case e ()
1130                      ((_ name val)
1131                       (id? #'name)
1132                       (values 'define-form #'name #'val w s mod))
1133                      ((_ (name . args) e1 e2 ...)
1134                       (and (id? #'name)
1135                            (valid-bound-ids? (lambda-var-list #'args)))
1136                       ;; need lambda here...
1137                       (values 'define-form (wrap #'name w mod)
1138                               (decorate-source
1139                                (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
1140                                s)
1141                               empty-wrap s mod))
1142                      ((_ name)
1143                       (id? #'name)
1144                       (values 'define-form (wrap #'name w mod)
1145                               #'(if #f #f)
1146                               empty-wrap s mod))))
1147                   ((define-syntax)
1148                    (syntax-case e ()
1149                      ((_ name val)
1150                       (id? #'name)
1151                       (values 'define-syntax-form #'name
1152                               #'val w s mod))))
1153                   (else
1154                    (values 'call #f e w s mod)))))))
1155          ((syntax-object? e)
1156           (syntax-type (syntax-object-expression e)
1157                        r
1158                        (join-wraps w (syntax-object-wrap e))
1159                        (or (source-annotation e) s) rib
1160                        (or (syntax-object-module e) mod) for-car?))
1161          ((self-evaluating? e) (values 'constant #f e w s mod))
1162          (else (values 'other #f e w s mod)))))
1163
1164     (define expand
1165       (lambda (e r w mod)
1166         (call-with-values
1167             (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
1168           (lambda (type value e w s mod)
1169             (expand-expr type value e r w s mod)))))
1170
1171     (define expand-expr
1172       (lambda (type value e r w s mod)
1173         (case type
1174           ((lexical)
1175            (build-lexical-reference 'value s e value))
1176           ((core core-form)
1177            ;; apply transformer
1178            (value e r w s mod))
1179           ((module-ref)
1180            (call-with-values (lambda () (value e r w))
1181              (lambda (e r w s mod)
1182                (expand e r w mod))))
1183           ((lexical-call)
1184            (expand-application
1185             (let ((id (car e)))
1186               (build-lexical-reference 'fun (source-annotation id)
1187                                        (if (syntax-object? id)
1188                                            (syntax->datum id)
1189                                            id)
1190                                        value))
1191             e r w s mod))
1192           ((global-call)
1193            (expand-application
1194             (build-global-reference (source-annotation (car e))
1195                                     (if (syntax-object? value)
1196                                         (syntax-object-expression value)
1197                                         value)
1198                                     (if (syntax-object? value)
1199                                         (syntax-object-module value)
1200                                         mod))
1201             e r w s mod))
1202           ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
1203           ((global) (build-global-reference s value mod))
1204           ((call) (expand-application (expand (car e) r w mod) e r w s mod))
1205           ((begin-form)
1206            (syntax-case e ()
1207              ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))))
1208           ((local-syntax-form)
1209            (expand-local-syntax value e r w s mod expand-sequence))
1210           ((eval-when-form)
1211            (syntax-case e ()
1212              ((_ (x ...) e1 e2 ...)
1213               (let ((when-list (parse-when-list e #'(x ...))))
1214                 (if (memq 'eval when-list)
1215                     (expand-sequence #'(e1 e2 ...) r w s mod)
1216                     (expand-void))))))
1217           ((define-form define-syntax-form)
1218            (syntax-violation #f "definition in expression context"
1219                              e (wrap value w mod)))
1220           ((syntax)
1221            (syntax-violation #f "reference to pattern variable outside syntax form"
1222                              (source-wrap e w s mod)))
1223           ((displaced-lexical)
1224            (syntax-violation #f "reference to identifier outside its scope"
1225                              (source-wrap e w s mod)))
1226           (else (syntax-violation #f "unexpected syntax"
1227                                   (source-wrap e w s mod))))))
1228
1229     (define expand-application
1230       (lambda (x e r w s mod)
1231         (syntax-case e ()
1232           ((e0 e1 ...)
1233            (build-application s x
1234                               (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
1235
1236     ;; (What follows is my interpretation of what's going on here -- Andy)
1237     ;;
1238     ;; A macro takes an expression, a tree, the leaves of which are identifiers
1239     ;; and datums. Identifiers are symbols along with a wrap and a module. For
1240     ;; efficiency, subtrees that share wraps and modules may be grouped as one
1241     ;; syntax object.
1242     ;;
1243     ;; Going into the expansion, the expression is given an anti-mark, which
1244     ;; logically propagates to all leaves. Then, in the new expression returned
1245     ;; from the transfomer, if we see an expression with an anti-mark, we know it
1246     ;; pertains to the original expression; conversely, expressions without the
1247     ;; anti-mark are known to be introduced by the transformer.
1248     ;;
1249     ;; OK, good until now. We know this algorithm does lexical scoping
1250     ;; appropriately because it's widely known in the literature, and psyntax is
1251     ;; widely used. But what about modules? Here we're on our own. What we do is
1252     ;; to mark the module of expressions produced by a macro as pertaining to the
1253     ;; module that was current when the macro was defined -- that is, free
1254     ;; identifiers introduced by a macro are scoped in the macro's module, not in
1255     ;; the expansion's module. Seems to work well.
1256     ;;
1257     ;; The only wrinkle is when we want a macro to expand to code in another
1258     ;; module, as is the case for the r6rs `library' form -- the body expressions
1259     ;; should be scoped relative the the new module, the one defined by the macro.
1260     ;; For that, use `(@@ mod-name body)'.
1261     ;;
1262     ;; Part of the macro output will be from the site of the macro use and part
1263     ;; from the macro definition. We allow source information from the macro use
1264     ;; to pass through, but we annotate the parts coming from the macro with the
1265     ;; source location information corresponding to the macro use. It would be
1266     ;; really nice if we could also annotate introduced expressions with the
1267     ;; locations corresponding to the macro definition, but that is not yet
1268     ;; possible.
1269     (define expand-macro
1270       (lambda (p e r w s rib mod)
1271         (define rebuild-macro-output
1272           (lambda (x m)
1273             (cond ((pair? x)
1274                    (decorate-source
1275                     (cons (rebuild-macro-output (car x) m)
1276                           (rebuild-macro-output (cdr x) m))
1277                     s))
1278                   ((syntax-object? x)
1279                    (let ((w (syntax-object-wrap x)))
1280                      (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1281                        (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1282                            ;; output is from original text
1283                            (make-syntax-object
1284                             (syntax-object-expression x)
1285                             (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
1286                             (syntax-object-module x))
1287                            ;; output introduced by macro
1288                            (make-syntax-object
1289                             (decorate-source (syntax-object-expression x) s)
1290                             (make-wrap (cons m ms)
1291                                        (if rib
1292                                            (cons rib (cons 'shift s))
1293                                            (cons 'shift s)))
1294                             (syntax-object-module x))))))
1295
1296                   ((vector? x)
1297                    (let* ((n (vector-length x))
1298                           (v (decorate-source (make-vector n) x)))
1299                      (do ((i 0 (fx+ i 1)))
1300                          ((fx= i n) v)
1301                        (vector-set! v i
1302                                     (rebuild-macro-output (vector-ref x i) m)))))
1303                   ((symbol? x)
1304                    (syntax-violation #f "encountered raw symbol in macro output"
1305                                      (source-wrap e w (wrap-subst w) mod) x))
1306                   (else (decorate-source x s)))))
1307         (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
1308                               (new-mark))))
1309
1310     (define expand-body
1311       ;; In processing the forms of the body, we create a new, empty wrap.
1312       ;; This wrap is augmented (destructively) each time we discover that
1313       ;; the next form is a definition.  This is done:
1314       ;;
1315       ;;   (1) to allow the first nondefinition form to be a call to
1316       ;;       one of the defined ids even if the id previously denoted a
1317       ;;       definition keyword or keyword for a macro expanding into a
1318       ;;       definition;
1319       ;;   (2) to prevent subsequent definition forms (but unfortunately
1320       ;;       not earlier ones) and the first nondefinition form from
1321       ;;       confusing one of the bound identifiers for an auxiliary
1322       ;;       keyword; and
1323       ;;   (3) so that we do not need to restart the expansion of the
1324       ;;       first nondefinition form, which is problematic anyway
1325       ;;       since it might be the first element of a begin that we
1326       ;;       have just spliced into the body (meaning if we restarted,
1327       ;;       we'd really need to restart with the begin or the macro
1328       ;;       call that expanded into the begin, and we'd have to give
1329       ;;       up allowing (begin <defn>+ <expr>+), which is itself
1330       ;;       problematic since we don't know if a begin contains only
1331       ;;       definitions until we've expanded it).
1332       ;;
1333       ;; Before processing the body, we also create a new environment
1334       ;; containing a placeholder for the bindings we will add later and
1335       ;; associate this environment with each form.  In processing a
1336       ;; let-syntax or letrec-syntax, the associated environment may be
1337       ;; augmented with local keyword bindings, so the environment may
1338       ;; be different for different forms in the body.  Once we have
1339       ;; gathered up all of the definitions, we evaluate the transformer
1340       ;; expressions and splice into r at the placeholder the new variable
1341       ;; and keyword bindings.  This allows let-syntax or letrec-syntax
1342       ;; forms local to a portion or all of the body to shadow the
1343       ;; definition bindings.
1344       ;;
1345       ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1346       ;; into the body.
1347       ;;
1348       ;; outer-form is fully wrapped w/source
1349       (lambda (body outer-form r w mod)
1350         (let* ((r (cons '("placeholder" . (placeholder)) r))
1351                (ribcage (make-empty-ribcage))
1352                (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1353           (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
1354                       (ids '()) (labels '())
1355                       (var-ids '()) (vars '()) (vals '()) (bindings '()))
1356             (if (null? body)
1357                 (syntax-violation #f "no expressions in body" outer-form)
1358                 (let ((e (cdar body)) (er (caar body)))
1359                   (call-with-values
1360                       (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
1361                     (lambda (type value e w s mod)
1362                       (case type
1363                         ((define-form)
1364                          (let ((id (wrap value w mod)) (label (gen-label)))
1365                            (let ((var (gen-var id)))
1366                              (extend-ribcage! ribcage id label)
1367                              (parse (cdr body)
1368                                     (cons id ids) (cons label labels)
1369                                     (cons id var-ids)
1370                                     (cons var vars) (cons (cons er (wrap e w mod)) vals)
1371                                     (cons (make-binding 'lexical var) bindings)))))
1372                         ((define-syntax-form)
1373                          (let ((id (wrap value w mod)) (label (gen-label)))
1374                            (extend-ribcage! ribcage id label)
1375                            (parse (cdr body)
1376                                   (cons id ids) (cons label labels)
1377                                   var-ids vars vals
1378                                   (cons (make-binding 'macro (cons er (wrap e w mod)))
1379                                         bindings))))
1380                         ((begin-form)
1381                          (syntax-case e ()
1382                            ((_ e1 ...)
1383                             (parse (let f ((forms #'(e1 ...)))
1384                                      (if (null? forms)
1385                                          (cdr body)
1386                                          (cons (cons er (wrap (car forms) w mod))
1387                                                (f (cdr forms)))))
1388                                    ids labels var-ids vars vals bindings))))
1389                         ((local-syntax-form)
1390                          (expand-local-syntax value e er w s mod
1391                                               (lambda (forms er w s mod)
1392                                                 (parse (let f ((forms forms))
1393                                                          (if (null? forms)
1394                                                              (cdr body)
1395                                                              (cons (cons er (wrap (car forms) w mod))
1396                                                                    (f (cdr forms)))))
1397                                                        ids labels var-ids vars vals bindings))))
1398                         (else           ; found a non-definition
1399                          (if (null? ids)
1400                              (build-sequence no-source
1401                                              (map (lambda (x)
1402                                                     (expand (cdr x) (car x) empty-wrap mod))
1403                                                   (cons (cons er (source-wrap e w s mod))
1404                                                         (cdr body))))
1405                              (begin
1406                                (if (not (valid-bound-ids? ids))
1407                                    (syntax-violation
1408                                     #f "invalid or duplicate identifier in definition"
1409                                     outer-form))
1410                                (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1411                                  (if (not (null? bs))
1412                                      (let* ((b (car bs)))
1413                                        (if (eq? (car b) 'macro)
1414                                            (let* ((er (cadr b))
1415                                                   (r-cache
1416                                                    (if (eq? er er-cache)
1417                                                        r-cache
1418                                                        (macros-only-env er))))
1419                                              (set-cdr! b
1420                                                        (eval-local-transformer
1421                                                         (expand (cddr b) r-cache empty-wrap mod)
1422                                                         mod))
1423                                              (loop (cdr bs) er r-cache))
1424                                            (loop (cdr bs) er-cache r-cache)))))
1425                                (set-cdr! r (extend-env labels bindings (cdr r)))
1426                                (build-letrec no-source #t
1427                                              (reverse (map syntax->datum var-ids))
1428                                              (reverse vars)
1429                                              (map (lambda (x)
1430                                                     (expand (cdr x) (car x) empty-wrap mod))
1431                                                   (reverse vals))
1432                                              (build-sequence no-source
1433                                                              (map (lambda (x)
1434                                                                     (expand (cdr x) (car x) empty-wrap mod))
1435                                                                   (cons (cons er (source-wrap e w s mod))
1436                                                                         (cdr body)))))))))))))))))
1437
1438     (define expand-local-syntax
1439       (lambda (rec? e r w s mod k)
1440         (syntax-case e ()
1441           ((_ ((id val) ...) e1 e2 ...)
1442            (let ((ids #'(id ...)))
1443              (if (not (valid-bound-ids? ids))
1444                  (syntax-violation #f "duplicate bound keyword" e)
1445                  (let ((labels (gen-labels ids)))
1446                    (let ((new-w (make-binding-wrap ids labels w)))
1447                      (k #'(e1 e2 ...)
1448                         (extend-env
1449                          labels
1450                          (let ((w (if rec? new-w w))
1451                                (trans-r (macros-only-env r)))
1452                            (map (lambda (x)
1453                                   (make-binding 'macro
1454                                                 (eval-local-transformer
1455                                                  (expand x trans-r w mod)
1456                                                  mod)))
1457                                 #'(val ...)))
1458                          r)
1459                         new-w
1460                         s
1461                         mod))))))
1462           (_ (syntax-violation #f "bad local syntax definition"
1463                                (source-wrap e w s mod))))))
1464
1465     (define eval-local-transformer
1466       (lambda (expanded mod)
1467         (let ((p (local-eval-hook expanded mod)))
1468           (if (procedure? p)
1469               p
1470               (syntax-violation #f "nonprocedure transformer" p)))))
1471
1472     (define expand-void
1473       (lambda ()
1474         (build-void no-source)))
1475
1476     (define ellipsis?
1477       (lambda (x)
1478         (and (nonsymbol-id? x)
1479              (free-id=? x #'(... ...)))))
1480
1481     (define lambda-formals
1482       (lambda (orig-args)
1483         (define (req args rreq)
1484           (syntax-case args ()
1485             (()
1486              (check (reverse rreq) #f))
1487             ((a . b) (id? #'a)
1488              (req #'b (cons #'a rreq)))
1489             (r (id? #'r)
1490                (check (reverse rreq) #'r))
1491             (else
1492              (syntax-violation 'lambda "invalid argument list" orig-args args))))
1493         (define (check req rest)
1494           (cond
1495            ((distinct-bound-ids? (if rest (cons rest req) req))
1496             (values req #f rest #f))
1497            (else
1498             (syntax-violation 'lambda "duplicate identifier in argument list"
1499                               orig-args))))
1500         (req orig-args '())))
1501
1502     (define expand-simple-lambda
1503       (lambda (e r w s mod req rest meta body)
1504         (let* ((ids (if rest (append req (list rest)) req))
1505                (vars (map gen-var ids))
1506                (labels (gen-labels ids)))
1507           (build-simple-lambda
1508            s
1509            (map syntax->datum req) (and rest (syntax->datum rest)) vars
1510            meta
1511            (expand-body body (source-wrap e w s mod)
1512                         (extend-var-env labels vars r)
1513                         (make-binding-wrap ids labels w)
1514                         mod)))))
1515
1516     (define lambda*-formals
1517       (lambda (orig-args)
1518         (define (req args rreq)
1519           (syntax-case args ()
1520             (()
1521              (check (reverse rreq) '() #f '()))
1522             ((a . b) (id? #'a)
1523              (req #'b (cons #'a rreq)))
1524             ((a . b) (eq? (syntax->datum #'a) #:optional)
1525              (opt #'b (reverse rreq) '()))
1526             ((a . b) (eq? (syntax->datum #'a) #:key)
1527              (key #'b (reverse rreq) '() '()))
1528             ((a b) (eq? (syntax->datum #'a) #:rest)
1529              (rest #'b (reverse rreq) '() '()))
1530             (r (id? #'r)
1531                (rest #'r (reverse rreq) '() '()))
1532             (else
1533              (syntax-violation 'lambda* "invalid argument list" orig-args args))))
1534         (define (opt args req ropt)
1535           (syntax-case args ()
1536             (()
1537              (check req (reverse ropt) #f '()))
1538             ((a . b) (id? #'a)
1539              (opt #'b req (cons #'(a #f) ropt)))
1540             (((a init) . b) (id? #'a)
1541              (opt #'b req (cons #'(a init) ropt)))
1542             ((a . b) (eq? (syntax->datum #'a) #:key)
1543              (key #'b req (reverse ropt) '()))
1544             ((a b) (eq? (syntax->datum #'a) #:rest)
1545              (rest #'b req (reverse ropt) '()))
1546             (r (id? #'r)
1547                (rest #'r req (reverse ropt) '()))
1548             (else
1549              (syntax-violation 'lambda* "invalid optional argument list"
1550                                orig-args args))))
1551         (define (key args req opt rkey)
1552           (syntax-case args ()
1553             (()
1554              (check req opt #f (cons #f (reverse rkey))))
1555             ((a . b) (id? #'a)
1556              (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1557                (key #'b req opt (cons #'(k a #f) rkey))))
1558             (((a init) . b) (id? #'a)
1559              (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
1560                (key #'b req opt (cons #'(k a init) rkey))))
1561             (((a init k) . b) (and (id? #'a)
1562                                    (keyword? (syntax->datum #'k)))
1563              (key #'b req opt (cons #'(k a init) rkey)))
1564             ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
1565              (check req opt #f (cons #t (reverse rkey))))
1566             ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1567                             (eq? (syntax->datum #'a) #:rest))
1568              (rest #'b req opt (cons #t (reverse rkey))))
1569             ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
1570                             (id? #'r))
1571              (rest #'r req opt (cons #t (reverse rkey))))
1572             ((a b) (eq? (syntax->datum #'a) #:rest)
1573              (rest #'b req opt (cons #f (reverse rkey))))
1574             (r (id? #'r)
1575                (rest #'r req opt (cons #f (reverse rkey))))
1576             (else
1577              (syntax-violation 'lambda* "invalid keyword argument list"
1578                                orig-args args))))
1579         (define (rest args req opt kw)
1580           (syntax-case args ()
1581             (r (id? #'r)
1582                (check req opt #'r kw))
1583             (else
1584              (syntax-violation 'lambda* "invalid rest argument"
1585                                orig-args args))))
1586         (define (check req opt rest kw)
1587           (cond
1588            ((distinct-bound-ids?
1589              (append req (map car opt) (if rest (list rest) '())
1590                      (if (pair? kw) (map cadr (cdr kw)) '())))
1591             (values req opt rest kw))
1592            (else
1593             (syntax-violation 'lambda* "duplicate identifier in argument list"
1594                               orig-args))))
1595         (req orig-args '())))
1596
1597     (define expand-lambda-case
1598       (lambda (e r w s mod get-formals clauses)
1599         (define (parse-req req opt rest kw body)
1600           (let ((vars (map gen-var req))
1601                 (labels (gen-labels req)))
1602             (let ((r* (extend-var-env labels vars r))
1603                   (w* (make-binding-wrap req labels w)))
1604               (parse-opt (map syntax->datum req)
1605                          opt rest kw body (reverse vars) r* w* '() '()))))
1606         (define (parse-opt req opt rest kw body vars r* w* out inits)
1607           (cond
1608            ((pair? opt)
1609             (syntax-case (car opt) ()
1610               ((id i)
1611                (let* ((v (gen-var #'id))
1612                       (l (gen-labels (list v)))
1613                       (r** (extend-var-env l (list v) r*))
1614                       (w** (make-binding-wrap (list #'id) l w*)))
1615                  (parse-opt req (cdr opt) rest kw body (cons v vars)
1616                             r** w** (cons (syntax->datum #'id) out)
1617                             (cons (expand #'i r* w* mod) inits))))))
1618            (rest
1619             (let* ((v (gen-var rest))
1620                    (l (gen-labels (list v)))
1621                    (r* (extend-var-env l (list v) r*))
1622                    (w* (make-binding-wrap (list rest) l w*)))
1623               (parse-kw req (if (pair? out) (reverse out) #f)
1624                         (syntax->datum rest)
1625                         (if (pair? kw) (cdr kw) kw)
1626                         body (cons v vars) r* w*
1627                         (if (pair? kw) (car kw) #f)
1628                         '() inits)))
1629            (else
1630             (parse-kw req (if (pair? out) (reverse out) #f) #f
1631                       (if (pair? kw) (cdr kw) kw)
1632                       body vars r* w*
1633                       (if (pair? kw) (car kw) #f)
1634                       '() inits))))
1635         (define (parse-kw req opt rest kw body vars r* w* aok out inits)
1636           (cond
1637            ((pair? kw)
1638             (syntax-case (car kw) ()
1639               ((k id i)
1640                (let* ((v (gen-var #'id))
1641                       (l (gen-labels (list v)))
1642                       (r** (extend-var-env l (list v) r*))
1643                       (w** (make-binding-wrap (list #'id) l w*)))
1644                  (parse-kw req opt rest (cdr kw) body (cons v vars)
1645                            r** w** aok
1646                            (cons (list (syntax->datum #'k)
1647                                        (syntax->datum #'id)
1648                                        v)
1649                                  out)
1650                            (cons (expand #'i r* w* mod) inits))))))
1651            (else
1652             (parse-body req opt rest
1653                         (if (or aok (pair? out)) (cons aok (reverse out)) #f)
1654                         body (reverse vars) r* w* (reverse inits) '()))))
1655         (define (parse-body req opt rest kw body vars r* w* inits meta)
1656           (syntax-case body ()
1657             ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1658              (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1659                          (append meta
1660                                  `((documentation
1661                                     . ,(syntax->datum #'docstring))))))
1662             ((#((k . v) ...) e1 e2 ...)
1663              (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
1664                          (append meta (syntax->datum #'((k . v) ...)))))
1665             ((e1 e2 ...)
1666              (values meta req opt rest kw inits vars
1667                      (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
1668                                   r* w* mod)))))
1669
1670         (syntax-case clauses ()
1671           (() (values '() #f))
1672           (((args e1 e2 ...) (args* e1* e2* ...) ...)
1673            (call-with-values (lambda () (get-formals #'args))
1674              (lambda (req opt rest kw)
1675                (call-with-values (lambda ()
1676                                    (parse-req req opt rest kw #'(e1 e2 ...)))
1677                  (lambda (meta req opt rest kw inits vars body)
1678                    (call-with-values
1679                        (lambda ()
1680                          (expand-lambda-case e r w s mod get-formals
1681                                              #'((args* e1* e2* ...) ...)))
1682                      (lambda (meta* else*)
1683                        (values
1684                         (append meta meta*)
1685                         (build-lambda-case s req opt rest kw inits vars
1686                                            body else*))))))))))))
1687
1688     ;; data
1689
1690     ;; strips syntax-objects down to top-wrap
1691     ;;
1692     ;; since only the head of a list is annotated by the reader, not each pair
1693     ;; in the spine, we also check for pairs whose cars are annotated in case
1694     ;; we've been passed the cdr of an annotated list
1695
1696     (define strip
1697       (lambda (x w)
1698         (if (top-marked? w)
1699             x
1700             (let f ((x x))
1701               (cond
1702                ((syntax-object? x)
1703                 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1704                ((pair? x)
1705                 (let ((a (f (car x))) (d (f (cdr x))))
1706                   (if (and (eq? a (car x)) (eq? d (cdr x)))
1707                       x
1708                       (cons a d))))
1709                ((vector? x)
1710                 (let ((old (vector->list x)))
1711                   (let ((new (map f old)))
1712                     ;; inlined and-map with two args
1713                     (let lp ((l1 old) (l2 new))
1714                       (if (null? l1)
1715                           x
1716                           (if (eq? (car l1) (car l2))
1717                               (lp (cdr l1) (cdr l2))
1718                               (list->vector new)))))))
1719                (else x))))))
1720
1721     ;; lexical variables
1722
1723     (define gen-var
1724       (lambda (id)
1725         (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1726           (build-lexical-var no-source id))))
1727
1728     ;; appears to return a reversed list
1729     (define lambda-var-list
1730       (lambda (vars)
1731         (let lvl ((vars vars) (ls '()) (w empty-wrap))
1732           (cond
1733            ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1734            ((id? vars) (cons (wrap vars w #f) ls))
1735            ((null? vars) ls)
1736            ((syntax-object? vars)
1737             (lvl (syntax-object-expression vars)
1738                  ls
1739                  (join-wraps w (syntax-object-wrap vars))))
1740            ;; include anything else to be caught by subsequent error
1741            ;; checking
1742            (else (cons vars ls))))))
1743
1744     ;; core transformers
1745
1746     (global-extend 'local-syntax 'letrec-syntax #t)
1747     (global-extend 'local-syntax 'let-syntax #f)
1748
1749     (global-extend 'core 'fluid-let-syntax
1750                    (lambda (e r w s mod)
1751                      (syntax-case e ()
1752                        ((_ ((var val) ...) e1 e2 ...)
1753                         (valid-bound-ids? #'(var ...))
1754                         (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
1755                           (for-each
1756                            (lambda (id n)
1757                              (case (binding-type (lookup n r mod))
1758                                ((displaced-lexical)
1759                                 (syntax-violation 'fluid-let-syntax
1760                                                   "identifier out of context"
1761                                                   e
1762                                                   (source-wrap id w s mod)))))
1763                            #'(var ...)
1764                            names)
1765                           (expand-body
1766                            #'(e1 e2 ...)
1767                            (source-wrap e w s mod)
1768                            (extend-env
1769                             names
1770                             (let ((trans-r (macros-only-env r)))
1771                               (map (lambda (x)
1772                                      (make-binding 'macro
1773                                                    (eval-local-transformer (expand x trans-r w mod)
1774                                                                            mod)))
1775                                    #'(val ...)))
1776                             r)
1777                            w
1778                            mod)))
1779                        (_ (syntax-violation 'fluid-let-syntax "bad syntax"
1780                                             (source-wrap e w s mod))))))
1781
1782     (global-extend 'core 'quote
1783                    (lambda (e r w s mod)
1784                      (syntax-case e ()
1785                        ((_ e) (build-data s (strip #'e w)))
1786                        (_ (syntax-violation 'quote "bad syntax"
1787                                             (source-wrap e w s mod))))))
1788
1789     (global-extend 'core 'syntax
1790                    (let ()
1791                      (define gen-syntax
1792                        (lambda (src e r maps ellipsis? mod)
1793                          (if (id? e)
1794                              (let ((label (id-var-name e empty-wrap)))
1795                                ;; Mod does not matter, we are looking to see if
1796                                ;; the id is lexical syntax.
1797                                (let ((b (lookup label r mod)))
1798                                  (if (eq? (binding-type b) 'syntax)
1799                                      (call-with-values
1800                                          (lambda ()
1801                                            (let ((var.lev (binding-value b)))
1802                                              (gen-ref src (car var.lev) (cdr var.lev) maps)))
1803                                        (lambda (var maps) (values `(ref ,var) maps)))
1804                                      (if (ellipsis? e)
1805                                          (syntax-violation 'syntax "misplaced ellipsis" src)
1806                                          (values `(quote ,e) maps)))))
1807                              (syntax-case e ()
1808                                ((dots e)
1809                                 (ellipsis? #'dots)
1810                                 (gen-syntax src #'e r maps (lambda (x) #f) mod))
1811                                ((x dots . y)
1812                                 ;; this could be about a dozen lines of code, except that we
1813                                 ;; choose to handle #'(x ... ...) forms
1814                                 (ellipsis? #'dots)
1815                                 (let f ((y #'y)
1816                                         (k (lambda (maps)
1817                                              (call-with-values
1818                                                  (lambda ()
1819                                                    (gen-syntax src #'x r
1820                                                                (cons '() maps) ellipsis? mod))
1821                                                (lambda (x maps)
1822                                                  (if (null? (car maps))
1823                                                      (syntax-violation 'syntax "extra ellipsis"
1824                                                                        src)
1825                                                      (values (gen-map x (car maps))
1826                                                              (cdr maps))))))))
1827                                   (syntax-case y ()
1828                                     ((dots . y)
1829                                      (ellipsis? #'dots)
1830                                      (f #'y
1831                                         (lambda (maps)
1832                                           (call-with-values
1833                                               (lambda () (k (cons '() maps)))
1834                                             (lambda (x maps)
1835                                               (if (null? (car maps))
1836                                                   (syntax-violation 'syntax "extra ellipsis" src)
1837                                                   (values (gen-mappend x (car maps))
1838                                                           (cdr maps))))))))
1839                                     (_ (call-with-values
1840                                            (lambda () (gen-syntax src y r maps ellipsis? mod))
1841                                          (lambda (y maps)
1842                                            (call-with-values
1843                                                (lambda () (k maps))
1844                                              (lambda (x maps)
1845                                                (values (gen-append x y) maps)))))))))
1846                                ((x . y)
1847                                 (call-with-values
1848                                     (lambda () (gen-syntax src #'x r maps ellipsis? mod))
1849                                   (lambda (x maps)
1850                                     (call-with-values
1851                                         (lambda () (gen-syntax src #'y r maps ellipsis? mod))
1852                                       (lambda (y maps) (values (gen-cons x y) maps))))))
1853                                (#(e1 e2 ...)
1854                                 (call-with-values
1855                                     (lambda ()
1856                                       (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
1857                                   (lambda (e maps) (values (gen-vector e) maps))))
1858                                (_ (values `(quote ,e) maps))))))
1859
1860                      (define gen-ref
1861                        (lambda (src var level maps)
1862                          (if (fx= level 0)
1863                              (values var maps)
1864                              (if (null? maps)
1865                                  (syntax-violation 'syntax "missing ellipsis" src)
1866                                  (call-with-values
1867                                      (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1868                                    (lambda (outer-var outer-maps)
1869                                      (let ((b (assq outer-var (car maps))))
1870                                        (if b
1871                                            (values (cdr b) maps)
1872                                            (let ((inner-var (gen-var 'tmp)))
1873                                              (values inner-var
1874                                                      (cons (cons (cons outer-var inner-var)
1875                                                                  (car maps))
1876                                                            outer-maps)))))))))))
1877
1878                      (define gen-mappend
1879                        (lambda (e map-env)
1880                          `(apply (primitive append) ,(gen-map e map-env))))
1881
1882                      (define gen-map
1883                        (lambda (e map-env)
1884                          (let ((formals (map cdr map-env))
1885                                (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1886                            (cond
1887                             ((eq? (car e) 'ref)
1888                              ;; identity map equivalence:
1889                              ;; (map (lambda (x) x) y) == y
1890                              (car actuals))
1891                             ((and-map
1892                               (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1893                               (cdr e))
1894                              ;; eta map equivalence:
1895                              ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1896                              `(map (primitive ,(car e))
1897                                    ,@(map (let ((r (map cons formals actuals)))
1898                                             (lambda (x) (cdr (assq (cadr x) r))))
1899                                           (cdr e))))
1900                             (else `(map (lambda ,formals ,e) ,@actuals))))))
1901
1902                      (define gen-cons
1903                        (lambda (x y)
1904                          (case (car y)
1905                            ((quote)
1906                             (if (eq? (car x) 'quote)
1907                                 `(quote (,(cadr x) . ,(cadr y)))
1908                                 (if (eq? (cadr y) '())
1909                                     `(list ,x)
1910                                     `(cons ,x ,y))))
1911                            ((list) `(list ,x ,@(cdr y)))
1912                            (else `(cons ,x ,y)))))
1913
1914                      (define gen-append
1915                        (lambda (x y)
1916                          (if (equal? y '(quote ()))
1917                              x
1918                              `(append ,x ,y))))
1919
1920                      (define gen-vector
1921                        (lambda (x)
1922                          (cond
1923                           ((eq? (car x) 'list) `(vector ,@(cdr x)))
1924                           ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1925                           (else `(list->vector ,x)))))
1926
1927
1928                      (define regen
1929                        (lambda (x)
1930                          (case (car x)
1931                            ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
1932                            ((primitive) (build-primref no-source (cadr x)))
1933                            ((quote) (build-data no-source (cadr x)))
1934                            ((lambda)
1935                             (if (list? (cadr x))
1936                                 (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
1937                                 (error "how did we get here" x)))
1938                            (else (build-application no-source
1939                                                     (build-primref no-source (car x))
1940                                                     (map regen (cdr x)))))))
1941
1942                      (lambda (e r w s mod)
1943                        (let ((e (source-wrap e w s mod)))
1944                          (syntax-case e ()
1945                            ((_ x)
1946                             (call-with-values
1947                                 (lambda () (gen-syntax e #'x r '() ellipsis? mod))
1948                               (lambda (e maps) (regen e))))
1949                            (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
1950
1951     (global-extend 'core 'lambda
1952                    (lambda (e r w s mod)
1953                      (syntax-case e ()
1954                        ((_ args e1 e2 ...)
1955                         (call-with-values (lambda () (lambda-formals #'args))
1956                           (lambda (req opt rest kw)
1957                             (let lp ((body #'(e1 e2 ...)) (meta '()))
1958                               (syntax-case body ()
1959                                 ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
1960                                  (lp #'(e1 e2 ...)
1961                                      (append meta
1962                                              `((documentation
1963                                                 . ,(syntax->datum #'docstring))))))
1964                                 ((#((k . v) ...) e1 e2 ...)
1965                                  (lp #'(e1 e2 ...)
1966                                      (append meta (syntax->datum #'((k . v) ...)))))
1967                                 (_ (expand-simple-lambda e r w s mod req rest meta body)))))))
1968                        (_ (syntax-violation 'lambda "bad lambda" e)))))
1969
1970     (global-extend 'core 'lambda*
1971                    (lambda (e r w s mod)
1972                      (syntax-case e ()
1973                        ((_ args e1 e2 ...)
1974                         (call-with-values
1975                             (lambda ()
1976                               (expand-lambda-case e r w s mod
1977                                                   lambda*-formals #'((args e1 e2 ...))))
1978                           (lambda (meta lcase)
1979                             (build-case-lambda s meta lcase))))
1980                        (_ (syntax-violation 'lambda "bad lambda*" e)))))
1981
1982     (global-extend 'core 'case-lambda
1983                    (lambda (e r w s mod)
1984                      (syntax-case e ()
1985                        ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
1986                         (call-with-values
1987                             (lambda ()
1988                               (expand-lambda-case e r w s mod
1989                                                   lambda-formals
1990                                                   #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
1991                           (lambda (meta lcase)
1992                             (build-case-lambda s meta lcase))))
1993                        (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
1994
1995     (global-extend 'core 'case-lambda*
1996                    (lambda (e r w s mod)
1997                      (syntax-case e ()
1998                        ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
1999                         (call-with-values
2000                             (lambda ()
2001                               (expand-lambda-case e r w s mod
2002                                                   lambda*-formals
2003                                                   #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
2004                           (lambda (meta lcase)
2005                             (build-case-lambda s meta lcase))))
2006                        (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
2007
2008     (global-extend 'core 'let
2009                    (let ()
2010                      (define (expand-let e r w s mod constructor ids vals exps)
2011                        (if (not (valid-bound-ids? ids))
2012                            (syntax-violation 'let "duplicate bound variable" e)
2013                            (let ((labels (gen-labels ids))
2014                                  (new-vars (map gen-var ids)))
2015                              (let ((nw (make-binding-wrap ids labels w))
2016                                    (nr (extend-var-env labels new-vars r)))
2017                                (constructor s
2018                                             (map syntax->datum ids)
2019                                             new-vars
2020                                             (map (lambda (x) (expand x r w mod)) vals)
2021                                             (expand-body exps (source-wrap e nw s mod)
2022                                                          nr nw mod))))))
2023                      (lambda (e r w s mod)
2024                        (syntax-case e ()
2025                          ((_ ((id val) ...) e1 e2 ...)
2026                           (and-map id? #'(id ...))
2027                           (expand-let e r w s mod
2028                                       build-let
2029                                       #'(id ...)
2030                                       #'(val ...)
2031                                       #'(e1 e2 ...)))
2032                          ((_ f ((id val) ...) e1 e2 ...)
2033                           (and (id? #'f) (and-map id? #'(id ...)))
2034                           (expand-let e r w s mod
2035                                       build-named-let
2036                                       #'(f id ...)
2037                                       #'(val ...)
2038                                       #'(e1 e2 ...)))
2039                          (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
2040
2041
2042     (global-extend 'core 'letrec
2043                    (lambda (e r w s mod)
2044                      (syntax-case e ()
2045                        ((_ ((id val) ...) e1 e2 ...)
2046                         (and-map id? #'(id ...))
2047                         (let ((ids #'(id ...)))
2048                           (if (not (valid-bound-ids? ids))
2049                               (syntax-violation 'letrec "duplicate bound variable" e)
2050                               (let ((labels (gen-labels ids))
2051                                     (new-vars (map gen-var ids)))
2052                                 (let ((w (make-binding-wrap ids labels w))
2053                                       (r (extend-var-env labels new-vars r)))
2054                                   (build-letrec s #f
2055                                                 (map syntax->datum ids)
2056                                                 new-vars
2057                                                 (map (lambda (x) (expand x r w mod)) #'(val ...))
2058                                                 (expand-body #'(e1 e2 ...)
2059                                                              (source-wrap e w s mod) r w mod)))))))
2060                        (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
2061
2062
2063     (global-extend 'core 'letrec*
2064                    (lambda (e r w s mod)
2065                      (syntax-case e ()
2066                        ((_ ((id val) ...) e1 e2 ...)
2067                         (and-map id? #'(id ...))
2068                         (let ((ids #'(id ...)))
2069                           (if (not (valid-bound-ids? ids))
2070                               (syntax-violation 'letrec* "duplicate bound variable" e)
2071                               (let ((labels (gen-labels ids))
2072                                     (new-vars (map gen-var ids)))
2073                                 (let ((w (make-binding-wrap ids labels w))
2074                                       (r (extend-var-env labels new-vars r)))
2075                                   (build-letrec s #t
2076                                                 (map syntax->datum ids)
2077                                                 new-vars
2078                                                 (map (lambda (x) (expand x r w mod)) #'(val ...))
2079                                                 (expand-body #'(e1 e2 ...)
2080                                                              (source-wrap e w s mod) r w mod)))))))
2081                        (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
2082
2083
2084     (global-extend 'core 'set!
2085                    (lambda (e r w s mod)
2086                      (syntax-case e ()
2087                        ((_ id val)
2088                         (id? #'id)
2089                         (let ((n (id-var-name #'id w))
2090                               ;; Lookup id in its module
2091                               (id-mod (if (syntax-object? #'id)
2092                                           (syntax-object-module #'id)
2093                                           mod)))
2094                           (let ((b (lookup n r id-mod)))
2095                             (case (binding-type b)
2096                               ((lexical)
2097                                (build-lexical-assignment s
2098                                                          (syntax->datum #'id)
2099                                                          (binding-value b)
2100                                                          (expand #'val r w mod)))
2101                               ((global)
2102                                (build-global-assignment s n (expand #'val r w mod) id-mod))
2103                               ((macro)
2104                                (let ((p (binding-value b)))
2105                                  (if (procedure-property p 'variable-transformer)
2106                                      ;; As syntax-type does, call expand-macro with
2107                                      ;; the mod of the expression. Hmm.
2108                                      (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
2109                                      (syntax-violation 'set! "not a variable transformer"
2110                                                        (wrap e w mod)
2111                                                        (wrap #'id w id-mod)))))
2112                               ((displaced-lexical)
2113                                (syntax-violation 'set! "identifier out of context"
2114                                                  (wrap #'id w mod)))
2115                               (else (syntax-violation 'set! "bad set!"
2116                                                       (source-wrap e w s mod)))))))
2117                        ((_ (head tail ...) val)
2118                         (call-with-values
2119                             (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
2120                           (lambda (type value ee ww ss modmod)
2121                             (case type
2122                               ((module-ref)
2123                                (let ((val (expand #'val r w mod)))
2124                                  (call-with-values (lambda () (value #'(head tail ...) r w))
2125                                    (lambda (e r w s* mod)
2126                                      (syntax-case e ()
2127                                        (e (id? #'e)
2128                                           (build-global-assignment s (syntax->datum #'e)
2129                                                                    val mod)))))))
2130                               (else
2131                                (build-application s
2132                                                   (expand #'(setter head) r w mod)
2133                                                   (map (lambda (e) (expand e r w mod))
2134                                                        #'(tail ... val))))))))
2135                        (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
2136
2137     (global-extend 'module-ref '@
2138                    (lambda (e r w)
2139                      (syntax-case e ()
2140                        ((_ (mod ...) id)
2141                         (and (and-map id? #'(mod ...)) (id? #'id))
2142                         (values (syntax->datum #'id) r w #f
2143                                 (syntax->datum
2144                                  #'(public mod ...)))))))
2145
2146     (global-extend 'module-ref '@@
2147                    (lambda (e r w)
2148                      (define remodulate
2149                        (lambda (x mod)
2150                          (cond ((pair? x)
2151                                 (cons (remodulate (car x) mod)
2152                                       (remodulate (cdr x) mod)))
2153                                ((syntax-object? x)
2154                                 (make-syntax-object
2155                                  (remodulate (syntax-object-expression x) mod)
2156                                  (syntax-object-wrap x)
2157                                  ;; hither the remodulation
2158                                  mod))
2159                                ((vector? x)
2160                                 (let* ((n (vector-length x)) (v (make-vector n)))
2161                                   (do ((i 0 (fx+ i 1)))
2162                                       ((fx= i n) v)
2163                                     (vector-set! v i (remodulate (vector-ref x i) mod)))))
2164                                (else x))))
2165                      (syntax-case e ()
2166                        ((_ (mod ...) exp)
2167                         (and-map id? #'(mod ...))
2168                         (let ((mod (syntax->datum #'(private mod ...))))
2169                           (values (remodulate #'exp mod)
2170                                   r w (source-annotation #'exp)
2171                                   mod))))))
2172
2173     (global-extend 'core 'if
2174                    (lambda (e r w s mod)
2175                      (syntax-case e ()
2176                        ((_ test then)
2177                         (build-conditional
2178                          s
2179                          (expand #'test r w mod)
2180                          (expand #'then r w mod)
2181                          (build-void no-source)))
2182                        ((_ test then else)
2183                         (build-conditional
2184                          s
2185                          (expand #'test r w mod)
2186                          (expand #'then r w mod)
2187                          (expand #'else r w mod))))))
2188
2189     (global-extend 'core 'with-fluids
2190                    (lambda (e r w s mod)
2191                      (syntax-case e ()
2192                        ((_ ((fluid val) ...) b b* ...)
2193                         (build-dynlet
2194                          s
2195                          (map (lambda (x) (expand x r w mod)) #'(fluid ...))
2196                          (map (lambda (x) (expand x r w mod)) #'(val ...))
2197                          (expand-body #'(b b* ...)
2198                                       (source-wrap e w s mod) r w mod))))))
2199
2200     (global-extend 'begin 'begin '())
2201
2202     (global-extend 'define 'define '())
2203
2204     (global-extend 'define-syntax 'define-syntax '())
2205
2206     (global-extend 'eval-when 'eval-when '())
2207
2208     (global-extend 'core 'syntax-case
2209                    (let ()
2210                      (define convert-pattern
2211                        ;; accepts pattern & keys
2212                        ;; returns $sc-dispatch pattern & ids
2213                        (lambda (pattern keys)
2214                          (define cvt*
2215                            (lambda (p* n ids)
2216                              (if (not (pair? p*))
2217                                  (cvt p* n ids)
2218                                  (call-with-values
2219                                      (lambda () (cvt* (cdr p*) n ids))
2220                                    (lambda (y ids)
2221                                      (call-with-values
2222                                          (lambda () (cvt (car p*) n ids))
2223                                        (lambda (x ids)
2224                                          (values (cons x y) ids))))))))
2225
2226                          (define (v-reverse x)
2227                            (let loop ((r '()) (x x))
2228                              (if (not (pair? x))
2229                                  (values r x)
2230                                  (loop (cons (car x) r) (cdr x)))))
2231
2232                          (define cvt
2233                            (lambda (p n ids)
2234                              (if (id? p)
2235                                  (cond
2236                                   ((bound-id-member? p keys)
2237                                    (values (vector 'free-id p) ids))
2238                                   ((free-id=? p #'_)
2239                                    (values '_ ids))
2240                                   (else
2241                                    (values 'any (cons (cons p n) ids))))
2242                                  (syntax-case p ()
2243                                    ((x dots)
2244                                     (ellipsis? (syntax dots))
2245                                     (call-with-values
2246                                         (lambda () (cvt (syntax x) (fx+ n 1) ids))
2247                                       (lambda (p ids)
2248                                         (values (if (eq? p 'any) 'each-any (vector 'each p))
2249                                                 ids))))
2250                                    ((x dots . ys)
2251                                     (ellipsis? (syntax dots))
2252                                     (call-with-values
2253                                         (lambda () (cvt* (syntax ys) n ids))
2254                                       (lambda (ys ids)
2255                                         (call-with-values
2256                                             (lambda () (cvt (syntax x) (+ n 1) ids))
2257                                           (lambda (x ids)
2258                                             (call-with-values
2259                                                 (lambda () (v-reverse ys))
2260                                               (lambda (ys e)
2261                                                 (values `#(each+ ,x ,ys ,e)
2262                                                         ids))))))))
2263                                    ((x . y)
2264                                     (call-with-values
2265                                         (lambda () (cvt (syntax y) n ids))
2266                                       (lambda (y ids)
2267                                         (call-with-values
2268                                             (lambda () (cvt (syntax x) n ids))
2269                                           (lambda (x ids)
2270                                             (values (cons x y) ids))))))
2271                                    (() (values '() ids))
2272                                    (#(x ...)
2273                                     (call-with-values
2274                                         (lambda () (cvt (syntax (x ...)) n ids))
2275                                       (lambda (p ids) (values (vector 'vector p) ids))))
2276                                    (x (values (vector 'atom (strip p empty-wrap)) ids))))))
2277                          (cvt pattern 0 '())))
2278
2279                      (define build-dispatch-call
2280                        (lambda (pvars exp y r mod)
2281                          (let ((ids (map car pvars)) (levels (map cdr pvars)))
2282                            (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2283                              (build-application no-source
2284                                                 (build-primref no-source 'apply)
2285                                                 (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
2286                                                                            (expand exp
2287                                                                                    (extend-env
2288                                                                                     labels
2289                                                                                     (map (lambda (var level)
2290                                                                                            (make-binding 'syntax `(,var . ,level)))
2291                                                                                          new-vars
2292                                                                                          (map cdr pvars))
2293                                                                                     r)
2294                                                                                    (make-binding-wrap ids labels empty-wrap)
2295                                                                                    mod))
2296                                                       y))))))
2297
2298                      (define gen-clause
2299                        (lambda (x keys clauses r pat fender exp mod)
2300                          (call-with-values
2301                              (lambda () (convert-pattern pat keys))
2302                            (lambda (p pvars)
2303                              (cond
2304                               ((not (distinct-bound-ids? (map car pvars)))
2305                                (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2306                               ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2307                                (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2308                               (else
2309                                (let ((y (gen-var 'tmp)))
2310                                  ;; fat finger binding and references to temp variable y
2311                                  (build-application no-source
2312                                                     (build-simple-lambda no-source (list 'tmp) #f (list y) '()
2313                                                                          (let ((y (build-lexical-reference 'value no-source
2314                                                                                                            'tmp y)))
2315                                                                            (build-conditional no-source
2316                                                                                               (syntax-case fender ()
2317                                                                                                 (#t y)
2318                                                                                                 (_ (build-conditional no-source
2319                                                                                                                       y
2320                                                                                                                       (build-dispatch-call pvars fender y r mod)
2321                                                                                                                       (build-data no-source #f))))
2322                                                                                               (build-dispatch-call pvars exp y r mod)
2323                                                                                               (gen-syntax-case x keys clauses r mod))))
2324                                                     (list (if (eq? p 'any)
2325                                                               (build-application no-source
2326                                                                                  (build-primref no-source 'list)
2327                                                                                  (list x))
2328                                                               (build-application no-source
2329                                                                                  (build-primref no-source '$sc-dispatch)
2330                                                                                  (list x (build-data no-source p)))))))))))))
2331
2332                      (define gen-syntax-case
2333                        (lambda (x keys clauses r mod)
2334                          (if (null? clauses)
2335                              (build-application no-source
2336                                                 (build-primref no-source 'syntax-violation)
2337                                                 (list (build-data no-source #f)
2338                                                       (build-data no-source
2339                                                                   "source expression failed to match any pattern")
2340                                                       x))
2341                              (syntax-case (car clauses) ()
2342                                ((pat exp)
2343                                 (if (and (id? #'pat)
2344                                          (and-map (lambda (x) (not (free-id=? #'pat x)))
2345                                                   (cons #'(... ...) keys)))
2346                                     (if (free-id=? #'pad #'_)
2347                                         (expand #'exp r empty-wrap mod)
2348                                         (let ((labels (list (gen-label)))
2349                                               (var (gen-var #'pat)))
2350                                           (build-application no-source
2351                                                              (build-simple-lambda
2352                                                               no-source (list (syntax->datum #'pat)) #f (list var)
2353                                                               '()
2354                                                               (expand #'exp
2355                                                                       (extend-env labels
2356                                                                                   (list (make-binding 'syntax `(,var . 0)))
2357                                                                                   r)
2358                                                                       (make-binding-wrap #'(pat)
2359                                                                                          labels empty-wrap)
2360                                                                       mod))
2361                                                              (list x))))
2362                                     (gen-clause x keys (cdr clauses) r
2363                                                 #'pat #t #'exp mod)))
2364                                ((pat fender exp)
2365                                 (gen-clause x keys (cdr clauses) r
2366                                             #'pat #'fender #'exp mod))
2367                                (_ (syntax-violation 'syntax-case "invalid clause"
2368                                                     (car clauses)))))))
2369
2370                      (lambda (e r w s mod)
2371                        (let ((e (source-wrap e w s mod)))
2372                          (syntax-case e ()
2373                            ((_ val (key ...) m ...)
2374                             (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
2375                                          #'(key ...))
2376                                 (let ((x (gen-var 'tmp)))
2377                                   ;; fat finger binding and references to temp variable x
2378                                   (build-application s
2379                                                      (build-simple-lambda no-source (list 'tmp) #f (list x) '()
2380                                                                           (gen-syntax-case (build-lexical-reference 'value no-source
2381                                                                                                                     'tmp x)
2382                                                                                            #'(key ...) #'(m ...)
2383                                                                                            r
2384                                                                                            mod))
2385                                                      (list (expand #'val r empty-wrap mod))))
2386                                 (syntax-violation 'syntax-case "invalid literals list" e))))))))
2387
2388     ;; The portable macroexpand seeds expand-top's mode m with 'e (for
2389     ;; evaluating) and esew (which stands for "eval syntax expanders
2390     ;; when") with '(eval).  In Chez Scheme, m is set to 'c instead of e
2391     ;; if we are compiling a file, and esew is set to
2392     ;; (eval-syntactic-expanders-when), which defaults to the list
2393     ;; '(compile load eval).  This means that, by default, top-level
2394     ;; syntactic definitions are evaluated immediately after they are
2395     ;; expanded, and the expanded definitions are also residualized into
2396     ;; the object file if we are compiling a file.
2397     (set! macroexpand
2398           (lambda* (x #:optional (m 'e) (esew '(eval)))
2399             (expand-top-sequence (list x) null-env top-wrap #f m esew
2400                                  (cons 'hygiene (module-name (current-module))))))
2401
2402     (set! identifier?
2403           (lambda (x)
2404             (nonsymbol-id? x)))
2405
2406     (set! datum->syntax
2407           (lambda (id datum)
2408             (make-syntax-object datum (syntax-object-wrap id)
2409                                 (syntax-object-module id))))
2410
2411     (set! syntax->datum
2412           ;; accepts any object, since syntax objects may consist partially
2413           ;; or entirely of unwrapped, nonsymbolic data
2414           (lambda (x)
2415             (strip x empty-wrap)))
2416
2417     (set! syntax-source
2418           (lambda (x) (source-annotation x)))
2419
2420     (set! generate-temporaries
2421           (lambda (ls)
2422             (arg-check list? ls 'generate-temporaries)
2423             (let ((mod (cons 'hygiene (module-name (current-module)))))
2424               (map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
2425
2426     (set! free-identifier=?
2427           (lambda (x y)
2428             (arg-check nonsymbol-id? x 'free-identifier=?)
2429             (arg-check nonsymbol-id? y 'free-identifier=?)
2430             (free-id=? x y)))
2431
2432     (set! bound-identifier=?
2433           (lambda (x y)
2434             (arg-check nonsymbol-id? x 'bound-identifier=?)
2435             (arg-check nonsymbol-id? y 'bound-identifier=?)
2436             (bound-id=? x y)))
2437
2438     (set! syntax-violation
2439           (lambda* (who message form #:optional subform)
2440             (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
2441                        who 'syntax-violation)
2442             (arg-check string? message 'syntax-violation)
2443             (throw 'syntax-error who message
2444                    (source-annotation (or form subform))
2445                    (strip form empty-wrap)
2446                    (and subform (strip subform empty-wrap)))))
2447
2448     ;; $sc-dispatch expects an expression and a pattern.  If the expression
2449     ;; matches the pattern a list of the matching expressions for each
2450     ;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
2451     ;; not work on r4rs implementations that violate the ieee requirement
2452     ;; that #f and () be distinct.)
2453
2454     ;; The expression is matched with the pattern as follows:
2455
2456     ;; pattern:                           matches:
2457     ;;   ()                                 empty list
2458     ;;   any                                anything
2459     ;;   (<pattern>1 . <pattern>2)          (<pattern>1 . <pattern>2)
2460     ;;   each-any                           (any*)
2461     ;;   #(free-id <key>)                   <key> with free-identifier=?
2462     ;;   #(each <pattern>)                  (<pattern>*)
2463     ;;   #(each+ p1 (p2_1 ... p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
2464     ;;   #(vector <pattern>)                (list->vector <pattern>)
2465     ;;   #(atom <object>)                   <object> with "equal?"
2466
2467     ;; Vector cops out to pair under assumption that vectors are rare.  If
2468     ;; not, should convert to:
2469     ;;   #(vector <pattern>*)               #(<pattern>*)
2470
2471     (let ()
2472
2473       (define match-each
2474         (lambda (e p w mod)
2475           (cond
2476            ((pair? e)
2477             (let ((first (match (car e) p w '() mod)))
2478               (and first
2479                    (let ((rest (match-each (cdr e) p w mod)))
2480                      (and rest (cons first rest))))))
2481            ((null? e) '())
2482            ((syntax-object? e)
2483             (match-each (syntax-object-expression e)
2484                         p
2485                         (join-wraps w (syntax-object-wrap e))
2486                         (syntax-object-module e)))
2487            (else #f))))
2488
2489       (define match-each+
2490         (lambda (e x-pat y-pat z-pat w r mod)
2491           (let f ((e e) (w w))
2492             (cond
2493              ((pair? e)
2494               (call-with-values (lambda () (f (cdr e) w))
2495                 (lambda (xr* y-pat r)
2496                   (if r
2497                       (if (null? y-pat)
2498                           (let ((xr (match (car e) x-pat w '() mod)))
2499                             (if xr
2500                                 (values (cons xr xr*) y-pat r)
2501                                 (values #f #f #f)))
2502                           (values
2503                            '()
2504                            (cdr y-pat)
2505                            (match (car e) (car y-pat) w r mod)))
2506                       (values #f #f #f)))))
2507              ((syntax-object? e)
2508               (f (syntax-object-expression e) (join-wraps w e)))
2509              (else
2510               (values '() y-pat (match e z-pat w r mod)))))))
2511
2512       (define match-each-any
2513         (lambda (e w mod)
2514           (cond
2515            ((pair? e)
2516             (let ((l (match-each-any (cdr e) w mod)))
2517               (and l (cons (wrap (car e) w mod) l))))
2518            ((null? e) '())
2519            ((syntax-object? e)
2520             (match-each-any (syntax-object-expression e)
2521                             (join-wraps w (syntax-object-wrap e))
2522                             mod))
2523            (else #f))))
2524
2525       (define match-empty
2526         (lambda (p r)
2527           (cond
2528            ((null? p) r)
2529            ((eq? p '_) r)
2530            ((eq? p 'any) (cons '() r))
2531            ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2532            ((eq? p 'each-any) (cons '() r))
2533            (else
2534             (case (vector-ref p 0)
2535               ((each) (match-empty (vector-ref p 1) r))
2536               ((each+) (match-empty (vector-ref p 1)
2537                                     (match-empty
2538                                      (reverse (vector-ref p 2))
2539                                      (match-empty (vector-ref p 3) r))))
2540               ((free-id atom) r)
2541               ((vector) (match-empty (vector-ref p 1) r)))))))
2542
2543       (define combine
2544         (lambda (r* r)
2545           (if (null? (car r*))
2546               r
2547               (cons (map car r*) (combine (map cdr r*) r)))))
2548
2549       (define match*
2550         (lambda (e p w r mod)
2551           (cond
2552            ((null? p) (and (null? e) r))
2553            ((pair? p)
2554             (and (pair? e) (match (car e) (car p) w
2555                              (match (cdr e) (cdr p) w r mod)
2556                              mod)))
2557            ((eq? p 'each-any)
2558             (let ((l (match-each-any e w mod))) (and l (cons l r))))
2559            (else
2560             (case (vector-ref p 0)
2561               ((each)
2562                (if (null? e)
2563                    (match-empty (vector-ref p 1) r)
2564                    (let ((l (match-each e (vector-ref p 1) w mod)))
2565                      (and l
2566                           (let collect ((l l))
2567                             (if (null? (car l))
2568                                 r
2569                                 (cons (map car l) (collect (map cdr l)))))))))
2570               ((each+)
2571                (call-with-values
2572                    (lambda ()
2573                      (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
2574                  (lambda (xr* y-pat r)
2575                    (and r
2576                         (null? y-pat)
2577                         (if (null? xr*)
2578                             (match-empty (vector-ref p 1) r)
2579                             (combine xr* r))))))
2580               ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2581               ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2582               ((vector)
2583                (and (vector? e)
2584                     (match (vector->list e) (vector-ref p 1) w r mod))))))))
2585
2586       (define match
2587         (lambda (e p w r mod)
2588           (cond
2589            ((not r) #f)
2590            ((eq? p '_) r)
2591            ((eq? p 'any) (cons (wrap e w mod) r))
2592            ((syntax-object? e)
2593             (match*
2594              (syntax-object-expression e)
2595              p
2596              (join-wraps w (syntax-object-wrap e))
2597              r
2598              (syntax-object-module e)))
2599            (else (match* e p w r mod)))))
2600
2601       (set! $sc-dispatch
2602             (lambda (e p)
2603               (cond
2604                ((eq? p 'any) (list e))
2605                ((eq? p '_) '())
2606                ((syntax-object? e)
2607                 (match* (syntax-object-expression e)
2608                         p (syntax-object-wrap e) '() (syntax-object-module e)))
2609                (else (match* e p empty-wrap '() #f))))))))
2610
2611
2612 (define-syntax with-syntax
2613    (lambda (x)
2614       (syntax-case x ()
2615          ((_ () e1 e2 ...)
2616           #'(let () e1 e2 ...))
2617          ((_ ((out in)) e1 e2 ...)
2618           #'(syntax-case in ()
2619               (out (let () e1 e2 ...))))
2620          ((_ ((out in) ...) e1 e2 ...)
2621           #'(syntax-case (list in ...) ()
2622               ((out ...) (let () e1 e2 ...)))))))
2623
2624 (define-syntax syntax-rules
2625   (lambda (x)
2626     (syntax-case x ()
2627       ((_ (k ...) ((keyword . pattern) template) ...)
2628        #'(lambda (x)
2629            ;; embed patterns as procedure metadata
2630            #((macro-type . syntax-rules)
2631              (patterns pattern ...))
2632            (syntax-case x (k ...)
2633              ((dummy . pattern) #'template)
2634              ...)))
2635       ((_ (k ...) docstring ((keyword . pattern) template) ...)
2636        (string? (syntax->datum #'docstring))
2637        #'(lambda (x)
2638            ;; the same, but allow a docstring
2639            docstring
2640            #((macro-type . syntax-rules)
2641              (patterns pattern ...))
2642            (syntax-case x (k ...)
2643              ((dummy . pattern) #'template)
2644              ...))))))
2645
2646 (define-syntax define-syntax-rule
2647   (lambda (x)
2648     (syntax-case x ()
2649       ((_ (name . pattern) template)
2650        #'(define-syntax name
2651            (syntax-rules ()
2652              ((_ . pattern) template))))
2653       ((_ (name . pattern) docstring template)
2654        (string? (syntax->datum #'docstring))
2655        #'(define-syntax name
2656            (syntax-rules ()
2657              docstring
2658              ((_ . pattern) template)))))))
2659
2660 (define-syntax let*
2661   (lambda (x)
2662     (syntax-case x ()
2663       ((let* ((x v) ...) e1 e2 ...)
2664        (and-map identifier? #'(x ...))
2665        (let f ((bindings #'((x v)  ...)))
2666          (if (null? bindings)
2667              #'(let () e1 e2 ...)
2668              (with-syntax ((body (f (cdr bindings)))
2669                            (binding (car bindings)))
2670                #'(let (binding) body))))))))
2671
2672 (define-syntax do
2673    (lambda (orig-x)
2674       (syntax-case orig-x ()
2675          ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2676           (with-syntax (((step ...)
2677                          (map (lambda (v s)
2678                                 (syntax-case s ()
2679                                   (() v)
2680                                   ((e) #'e)
2681                                   (_ (syntax-violation
2682                                       'do "bad step expression"
2683                                       orig-x s))))
2684                               #'(var ...)
2685                               #'(step ...))))
2686              (syntax-case #'(e1 ...) ()
2687                (() #'(let doloop ((var init) ...)
2688                        (if (not e0)
2689                            (begin c ... (doloop step ...)))))
2690                ((e1 e2 ...)
2691                 #'(let doloop ((var init) ...)
2692                     (if e0
2693                         (begin e1 e2 ...)
2694                         (begin c ... (doloop step ...)))))))))))
2695
2696 (define-syntax quasiquote
2697   (let ()
2698     (define (quasi p lev)
2699       (syntax-case p (unquote quasiquote)
2700         ((unquote p)
2701          (if (= lev 0)
2702              #'("value" p)
2703              (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
2704         ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
2705         ((p . q)
2706          (syntax-case #'p (unquote unquote-splicing)
2707            ((unquote p ...)
2708             (if (= lev 0)
2709                 (quasilist* #'(("value" p) ...) (quasi #'q lev))
2710                 (quasicons
2711                  (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2712                  (quasi #'q lev))))
2713            ((unquote-splicing p ...)
2714             (if (= lev 0)
2715                 (quasiappend #'(("value" p) ...) (quasi #'q lev))
2716                 (quasicons
2717                  (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
2718                  (quasi #'q lev))))
2719            (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
2720         (#(x ...) (quasivector (vquasi #'(x ...) lev)))
2721         (p #'("quote" p))))
2722     (define (vquasi p lev)
2723       (syntax-case p ()
2724         ((p . q)
2725          (syntax-case #'p (unquote unquote-splicing)
2726            ((unquote p ...)
2727             (if (= lev 0)
2728                 (quasilist* #'(("value" p) ...) (vquasi #'q lev))
2729                 (quasicons
2730                  (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
2731                  (vquasi #'q lev))))
2732            ((unquote-splicing p ...)
2733             (if (= lev 0)
2734                 (quasiappend #'(("value" p) ...) (vquasi #'q lev))
2735                 (quasicons
2736                  (quasicons
2737                   #'("quote" unquote-splicing)
2738                   (quasi #'(p ...) (- lev 1)))
2739                  (vquasi #'q lev))))
2740            (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
2741         (() #'("quote" ()))))
2742     (define (quasicons x y)
2743       (with-syntax ((x x) (y y))
2744         (syntax-case #'y ()
2745           (("quote" dy)
2746            (syntax-case #'x ()
2747              (("quote" dx) #'("quote" (dx . dy)))
2748              (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
2749           (("list" . stuff) #'("list" x . stuff))
2750           (("list*" . stuff) #'("list*" x . stuff))
2751           (_ #'("list*" x y)))))
2752     (define (quasiappend x y)
2753       (syntax-case y ()
2754         (("quote" ())
2755          (cond
2756           ((null? x) #'("quote" ()))
2757           ((null? (cdr x)) (car x))
2758           (else (with-syntax (((p ...) x)) #'("append" p ...)))))
2759         (_
2760          (cond
2761           ((null? x) y)
2762           (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
2763     (define (quasilist* x y)
2764       (let f ((x x))
2765         (if (null? x)
2766             y
2767             (quasicons (car x) (f (cdr x))))))
2768     (define (quasivector x)
2769       (syntax-case x ()
2770         (("quote" (x ...)) #'("quote" #(x ...)))
2771         (_
2772          (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
2773            (syntax-case y ()
2774              (("quote" (y ...)) (k #'(("quote" y) ...)))
2775              (("list" y ...) (k #'(y ...)))
2776              (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
2777              (else #`("list->vector" #,x)))))))
2778     (define (emit x)
2779       (syntax-case x ()
2780         (("quote" x) #''x)
2781         (("list" x ...) #`(list #,@(map emit #'(x ...))))
2782         ;; could emit list* for 3+ arguments if implementation supports
2783         ;; list*
2784         (("list*" x ... y)
2785          (let f ((x* #'(x ...)))
2786            (if (null? x*)
2787                (emit #'y)
2788                #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
2789         (("append" x ...) #`(append #,@(map emit #'(x ...))))
2790         (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
2791         (("list->vector" x) #`(list->vector #,(emit #'x)))
2792         (("value" x) #'x)))
2793     (lambda (x)
2794       (syntax-case x ()
2795         ;; convert to intermediate language, combining introduced (but
2796         ;; not unquoted source) quote expressions where possible and
2797         ;; choosing optimal construction code otherwise, then emit
2798         ;; Scheme code corresponding to the intermediate language forms.
2799         ((_ e) (emit (quasi #'e 0)))))))
2800
2801 (define-syntax include
2802   (lambda (x)
2803     (define read-file
2804       (lambda (fn k)
2805         (let ((p (open-input-file fn)))
2806           (let f ((x (read p))
2807                   (result '()))
2808             (if (eof-object? x)
2809                 (begin
2810                   (close-input-port p)
2811                   (reverse result))
2812                 (f (read p)
2813                    (cons (datum->syntax k x) result)))))))
2814     (syntax-case x ()
2815       ((k filename)
2816        (let ((fn (syntax->datum #'filename)))
2817          (with-syntax (((exp ...) (read-file fn #'filename)))
2818            #'(begin exp ...)))))))
2819
2820 (define-syntax include-from-path
2821   (lambda (x)
2822     (syntax-case x ()
2823       ((k filename)
2824        (let ((fn (syntax->datum #'filename)))
2825          (with-syntax ((fn (datum->syntax
2826                             #'filename
2827                             (or (%search-load-path fn)
2828                                 (syntax-violation 'include-from-path
2829                                                   "file not found in path"
2830                                                   x #'filename)))))
2831            #'(include fn)))))))
2832
2833 (define-syntax unquote
2834   (lambda (x)
2835     (syntax-violation 'unquote
2836                       "expression not valid outside of quasiquote"
2837                       x)))
2838
2839 (define-syntax unquote-splicing
2840   (lambda (x)
2841     (syntax-violation 'unquote-splicing
2842                       "expression not valid outside of quasiquote"
2843                       x)))
2844
2845 (define-syntax case
2846   (lambda (x)
2847     (syntax-case x ()
2848       ((_ e m1 m2 ...)
2849        (with-syntax
2850            ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
2851                     (if (null? clauses)
2852                         (syntax-case clause (else)
2853                           ((else e1 e2 ...) #'(begin e1 e2 ...))
2854                           (((k ...) e1 e2 ...)
2855                            #'(if (memv t '(k ...)) (begin e1 e2 ...)))
2856                           (_ (syntax-violation 'case "bad clause" x clause)))
2857                         (with-syntax ((rest (f (car clauses) (cdr clauses))))
2858                           (syntax-case clause (else)
2859                             (((k ...) e1 e2 ...)
2860                              #'(if (memv t '(k ...))
2861                                    (begin e1 e2 ...)
2862                                    rest))
2863                             (_ (syntax-violation 'case "bad clause" x
2864                                                  clause))))))))
2865          #'(let ((t e)) body))))))
2866
2867 (define (make-variable-transformer proc)
2868   (if (procedure? proc)
2869       (let ((trans (lambda (x)
2870                      #((macro-type . variable-transformer))
2871                      (proc x))))
2872         (set-procedure-property! trans 'variable-transformer #t)
2873         trans)
2874       (error "variable transformer not a procedure" proc)))
2875
2876 (define-syntax identifier-syntax
2877   (lambda (x)
2878     (syntax-case x (set!)
2879       ((_ e)
2880        #'(lambda (x)
2881            #((macro-type . identifier-syntax))
2882            (syntax-case x ()
2883              (id
2884               (identifier? #'id)
2885               #'e)
2886              ((_ x (... ...))
2887               #'(e x (... ...))))))
2888       ((_ (id exp1) ((set! var val) exp2))
2889        (and (identifier? #'id) (identifier? #'var))
2890        #'(make-variable-transformer
2891           (lambda (x)
2892             #((macro-type . variable-transformer))
2893             (syntax-case x (set!)
2894               ((set! var val) #'exp2)
2895               ((id x (... ...)) #'(exp1 x (... ...)))
2896               (id (identifier? #'id) #'exp1))))))))
2897
2898 (define-syntax define*
2899   (lambda (x)
2900     (syntax-case x ()
2901       ((_ (id . args) b0 b1 ...)
2902        #'(define id (lambda* args b0 b1 ...)))
2903       ((_ id val) (identifier? #'x)
2904        #'(define id val)))))