module/language/r5rs/psyntax.ss

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