module/ice-9/psyntax.scm

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