share/guile/1.6.0/ice-9/psyntax.ss

   1 ;;;; -*-scheme-*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; As a special exception, the Free Software Foundation gives permission
  21 ;;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;;
  23 ;;;; The exception is that, if you link the GUILE library with other files
  24 ;;;; to produce an executable, this does not by itself cause the
  25 ;;;; resulting executable to be covered by the GNU General Public License.
  26 ;;;; Your use of that executable is in no way restricted on account of
  27 ;;;; linking the GUILE library code into it.
  28 ;;;;
  29 ;;;; This exception does not however invalidate any other reasons why
  30 ;;;; the executable file might be covered by the GNU General Public License.
  31 ;;;;
  32 ;;;; This exception applies only to the code released by the
  33 ;;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;;; code from other Free Software Foundation releases into a copy of
  35 ;;;; GUILE, as the General Public License permits, the exception does
  36 ;;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;;; anyone as to the status of such modified files, you must delete
  38 ;;;; this exception notice from them.
  39 ;;;;
  40 ;;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;;; whether to permit this exception to apply to your modifications.
  42 ;;;; If you do not wish that, delete this exception notice.
  43 ;;;;
  44 \f
  45
  46 ;;; Portable implementation of syntax-case
  47 ;;; Extracted from Chez Scheme Version 5.9f
  48 ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
  49
  50 ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
  51 ;;; to the ChangeLog distributed in the same directory as this file:
  52 ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
  53 ;;; 2000-09-12, 2001-03-08
  54
  55 ;;; Copyright (c) 1992-1997 Cadence Research Systems
  56 ;;; Permission to copy this software, in whole or in part, to use this
  57 ;;; software for any lawful purpose, and to redistribute this software
  58 ;;; is granted subject to the restriction that all copies made of this
  59 ;;; software must include this copyright notice in full.  This software
  60 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
  61 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
  62 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
  63 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
  64 ;;; NATURE WHATSOEVER.
  65
  66 ;;; Before attempting to port this code to a new implementation of
  67 ;;; Scheme, please read the notes below carefully.
  68
  69
  70 ;;; This file defines the syntax-case expander, sc-expand, and a set
  71 ;;; of associated syntactic forms and procedures.  Of these, the
  72 ;;; following are documented in The Scheme Programming Language,
  73 ;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996).  Most are
  74 ;;; also documented in the R4RS and draft R5RS.
  75 ;;;
  76 ;;;   bound-identifier=?
  77 ;;;   datum->syntax-object
  78 ;;;   define-syntax
  79 ;;;   fluid-let-syntax
  80 ;;;   free-identifier=?
  81 ;;;   generate-temporaries
  82 ;;;   identifier?
  83 ;;;   identifier-syntax
  84 ;;;   let-syntax
  85 ;;;   letrec-syntax
  86 ;;;   syntax
  87 ;;;   syntax-case
  88 ;;;   syntax-object->datum
  89 ;;;   syntax-rules
  90 ;;;   with-syntax
  91 ;;;
  92 ;;; All standard Scheme syntactic forms are supported by the expander
  93 ;;; or syntactic abstractions defined in this file.  Only the R4RS
  94 ;;; delay is omitted, since its expansion is implementation-dependent.
  95
  96 ;;; The remaining exports are listed below:
  97 ;;;
  98 ;;;   (sc-expand datum)
  99 ;;;      if datum represents a valid expression, sc-expand returns an
 100 ;;;      expanded version of datum in a core language that includes no
 101 ;;;      syntactic abstractions.  The core language includes begin,
 102 ;;;      define, if, lambda, letrec, quote, and set!.
 103 ;;;   (eval-when situations expr ...)
 104 ;;;      conditionally evaluates expr ... at compile-time or run-time
 105 ;;;      depending upon situations (see the Chez Scheme System Manual,
 106 ;;;      Revision 3, for a complete description)
 107 ;;;   (syntax-error object message)
 108 ;;;      used to report errors found during expansion
 109 ;;;   (install-global-transformer symbol value)
 110 ;;;      used by expanded code to install top-level syntactic abstractions
 111 ;;;   (syntax-dispatch e p)
 112 ;;;      used by expanded code to handle syntax-case matching
 113
 114 ;;; The following nonstandard procedures must be provided by the
 115 ;;; implementation for this code to run.
 116 ;;;
 117 ;;; (void)
 118 ;;; returns the implementation's cannonical "unspecified value".  This
 119 ;;; usually works: (define void (lambda () (if #f #f))).
 120 ;;;
 121 ;;; (andmap proc list1 list2 ...)
 122 ;;; returns true if proc returns true when applied to each element of list1
 123 ;;; along with the corresponding elements of list2 ....
 124 ;;; The following definition works but does no error checking:
 125 ;;;
 126 ;;; (define andmap
 127 ;;;   (lambda (f first . rest)
 128 ;;;     (or (null? first)
 129 ;;;         (if (null? rest)
 130 ;;;             (let andmap ((first first))
 131 ;;;               (let ((x (car first)) (first (cdr first)))
 132 ;;;                 (if (null? first)
 133 ;;;                     (f x)
 134 ;;;                     (and (f x) (andmap first)))))
 135 ;;;             (let andmap ((first first) (rest rest))
 136 ;;;               (let ((x (car first))
 137 ;;;                     (xr (map car rest))
 138 ;;;                     (first (cdr first))
 139 ;;;                     (rest (map cdr rest)))
 140 ;;;                 (if (null? first)
 141 ;;;                     (apply f (cons x xr))
 142 ;;;                     (and (apply f (cons x xr)) (andmap first rest)))))))))
 143 ;;;
 144 ;;; The following nonstandard procedures must also be provided by the
 145 ;;; implementation for this code to run using the standard portable
 146 ;;; hooks and output constructors.  They are not used by expanded code,
 147 ;;; and so need be present only at expansion time.
 148 ;;;
 149 ;;; (eval x)
 150 ;;; where x is always in the form ("noexpand" expr).
 151 ;;; returns the value of expr.  the "noexpand" flag is used to tell the
 152 ;;; evaluator/expander that no expansion is necessary, since expr has
 153 ;;; already been fully expanded to core forms.
 154 ;;;
 155 ;;; eval will not be invoked during the loading of psyntax.pp.  After
 156 ;;; psyntax.pp has been loaded, the expansion of any macro definition,
 157 ;;; whether local or global, will result in a call to eval.  If, however,
 158 ;;; sc-expand has already been registered as the expander to be used
 159 ;;; by eval, and eval accepts one argument, nothing special must be done
 160 ;;; to support the "noexpand" flag, since it is handled by sc-expand.
 161 ;;;
 162 ;;; (error who format-string why what)
 163 ;;; where who is either a symbol or #f, format-string is always "~a ~s",
 164 ;;; why is always a string, and what may be any object.  error should
 165 ;;; signal an error with a message something like
 166 ;;;
 167 ;;;    "error in <who>: <why> <what>"
 168 ;;;
 169 ;;; (gensym)
 170 ;;; returns a unique symbol each time it's called
 171 ;;;
 172 ;;; (putprop symbol key value)
 173 ;;; (getprop symbol key)
 174 ;;; key is always the symbol *sc-expander*; value may be any object.
 175 ;;; putprop should associate the given value with the given symbol in
 176 ;;; some way that it can be retrieved later with getprop.
 177
 178 ;;; When porting to a new Scheme implementation, you should define the
 179 ;;; procedures listed above, load the expanded version of psyntax.ss
 180 ;;; (psyntax.pp, which should be available whereever you found
 181 ;;; psyntax.ss), and register sc-expand as the current expander (how
 182 ;;; you do this depends upon your implementation of Scheme).  You may
 183 ;;; change the hooks and constructors defined toward the beginning of
 184 ;;; the code below, but to avoid bootstrapping problems, do so only
 185 ;;; after you have a working version of the expander.
 186
 187 ;;; Chez Scheme allows the syntactic form (syntax <template>) to be
 188 ;;; abbreviated to #'<template>, just as (quote <datum>) may be
 189 ;;; abbreviated to '<datum>.  The #' syntax makes programs written
 190 ;;; using syntax-case shorter and more readable and draws out the
 191 ;;; intuitive connection between syntax and quote.
 192
 193 ;;; If you find that this code loads or runs slowly, consider
 194 ;;; switching to faster hardware or a faster implementation of
 195 ;;; Scheme.  In Chez Scheme on a 200Mhz Pentium Pro, expanding,
 196 ;;; compiling (with full optimization), and loading this file takes
 197 ;;; between one and two seconds.
 198
 199 ;;; In the expander implementation, we sometimes use syntactic abstractions
 200 ;;; when procedural abstractions would suffice.  For example, we define
 201 ;;; top-wrap and top-marked? as
 202 ;;;   (define-syntax top-wrap (identifier-syntax '((top))))
 203 ;;;   (define-syntax top-marked?
 204 ;;;     (syntax-rules ()
 205 ;;;       ((_ w) (memq 'top (wrap-marks w)))))
 206 ;;; rather than
 207 ;;;   (define top-wrap '((top)))
 208 ;;;   (define top-marked?
 209 ;;;     (lambda (w) (memq 'top (wrap-marks w))))
 210 ;;; On ther other hand, we don't do this consistently; we define make-wrap,
 211 ;;; wrap-marks, and wrap-subst simply as
 212 ;;;   (define make-wrap cons)
 213 ;;;   (define wrap-marks car)
 214 ;;;   (define wrap-subst cdr)
 215 ;;; In Chez Scheme, the syntactic and procedural forms of these
 216 ;;; abstractions are equivalent, since the optimizer consistently
 217 ;;; integrates constants and small procedures.  Some Scheme
 218 ;;; implementations, however, may benefit from more consistent use
 219 ;;; of one form or the other.
 220
 221
 222 ;;; implementation information:
 223
 224 ;;; "begin" is treated as a splicing construct at top level and at
 225 ;;; the beginning of bodies.  Any sequence of expressions that would
 226 ;;; be allowed where the "begin" occurs is allowed.
 227
 228 ;;; "let-syntax" and "letrec-syntax" are also treated as splicing
 229 ;;; constructs, in violation of the R4RS appendix and probably the R5RS
 230 ;;; when it comes out.  A consequence, let-syntax and letrec-syntax do
 231 ;;; not create local contours, as do let and letrec.  Although the
 232 ;;; functionality is greater as it is presently implemented, we will
 233 ;;; probably change it to conform to the R4RS/expected R5RS.
 234
 235 ;;; Objects with no standard print syntax, including objects containing
 236 ;;; cycles and syntax object, are allowed in quoted data as long as they
 237 ;;; are contained within a syntax form or produced by datum->syntax-object.
 238 ;;; Such objects are never copied.
 239
 240 ;;; All identifiers that don't have macro definitions and are not bound
 241 ;;; lexically are assumed to be global variables
 242
 243 ;;; Top-level definitions of macro-introduced identifiers are allowed.
 244 ;;; This may not be appropriate for implementations in which the
 245 ;;; model is that bindings are created by definitions, as opposed to
 246 ;;; one in which initial values are assigned by definitions.
 247
 248 ;;; Top-level variable definitions of syntax keywords is not permitted.
 249 ;;; Any solution allowing this would be kludgey and would yield
 250 ;;; surprising results in some cases.  We can provide an undefine-syntax
 251 ;;; form.  The questions is, should define be an implicit undefine-syntax?
 252 ;;; We've decided no for now.
 253
 254 ;;; Identifiers and syntax objects are implemented as vectors for
 255 ;;; portability.  As a result, it is possible to "forge" syntax
 256 ;;; objects.
 257
 258 ;;; The implementation of generate-temporaries assumes that it is possible
 259 ;;; to generate globally unique symbols (gensyms).
 260
 261 ;;; The input to sc-expand may contain "annotations" describing, e.g., the
 262 ;;; source file and character position from where each object was read if
 263 ;;; it was read from a file.  These annotations are handled properly by
 264 ;;; sc-expand only if the annotation? hook (see hooks below) is implemented
 265 ;;; properly and the operators make-annotation, annotation-expression,
 266 ;;; annotation-source, annotation-stripped, and set-annotation-stripped!
 267 ;;; are supplied.  If annotations are supplied, the proper annotation
 268 ;;; source is passed to the various output constructors, allowing
 269 ;;; implementations to accurately correlate source and expanded code.
 270 ;;; Contact one of the authors for details if you wish to make use of
 271 ;;; this feature.
 272
 273
 274
 275 ;;; Bootstrapping:
 276
 277 ;;; When changing syntax-object representations, it is necessary to support
 278 ;;; both old and new syntax-object representations in id-var-name.  It
 279 ;;; should be sufficient to recognize old representations and treat
 280 ;;; them as not lexically bound.
 281
 282
 283
 284 (let ()
 285 (define-syntax define-structure
 286   (lambda (x)
 287     (define construct-name
 288       (lambda (template-identifier . args)
 289         (datum->syntax-object
 290           template-identifier
 291           (string->symbol
 292             (apply string-append
 293                    (map (lambda (x)
 294                           (if (string? x)
 295                               x
 296                               (symbol->string (syntax-object->datum x))))
 297                         args))))))
 298     (syntax-case x ()
 299       ((_ (name id1 ...))
 300        (andmap identifier? (syntax (name id1 ...)))
 301        (with-syntax
 302          ((constructor (construct-name (syntax name) "make-" (syntax name)))
 303           (predicate (construct-name (syntax name) (syntax name) "?"))
 304           ((access ...)
 305            (map (lambda (x) (construct-name x (syntax name) "-" x))
 306                 (syntax (id1 ...))))
 307           ((assign ...)
 308            (map (lambda (x)
 309                   (construct-name x "set-" (syntax name) "-" x "!"))
 310                 (syntax (id1 ...))))
 311           (structure-length
 312            (+ (length (syntax (id1 ...))) 1))
 313           ((index ...)
 314            (let f ((i 1) (ids (syntax (id1 ...))))
 315               (if (null? ids)
 316                   '()
 317                   (cons i (f (+ i 1) (cdr ids)))))))
 318          (syntax (begin
 319                    (define constructor
 320                      (lambda (id1 ...)
 321                        (vector 'name id1 ... )))
 322                    (define predicate
 323                      (lambda (x)
 324                        (and (vector? x)
 325                             (= (vector-length x) structure-length)
 326                             (eq? (vector-ref x 0) 'name))))
 327                    (define access
 328                      (lambda (x)
 329                        (vector-ref x index)))
 330                    ...
 331                    (define assign
 332                      (lambda (x update)
 333                        (vector-set! x index update)))
 334                    ...)))))))
 335
 336 (let ()
 337 (define noexpand "noexpand")
 338
 339 ;;; hooks to nonportable run-time helpers
 340 (begin
 341 (define fx+ +)
 342 (define fx- -)
 343 (define fx= =)
 344 (define fx< <)
 345
 346 (define annotation? (lambda (x) #f))
 347
 348 (define top-level-eval-hook
 349   (lambda (x)
 350     (eval `(,noexpand ,x) (interaction-environment))))
 351
 352 (define local-eval-hook
 353   (lambda (x)
 354     (eval `(,noexpand ,x) (interaction-environment))))
 355
 356 (define error-hook
 357   (lambda (who why what)
 358     (error who "~a ~s" why what)))
 359
 360 (define-syntax gensym-hook
 361   (syntax-rules ()
 362     ((_) (gensym))))
 363
 364 (define put-global-definition-hook
 365   (lambda (symbol binding)
 366      (putprop symbol '*sc-expander* binding)))
 367
 368 (define get-global-definition-hook
 369   (lambda (symbol)
 370      (getprop symbol '*sc-expander*)))
 371 )
 372
 373
 374 ;;; output constructors
 375 (begin
 376 (define-syntax build-application
 377   (syntax-rules ()
 378     ((_ source fun-exp arg-exps)
 379      `(,fun-exp . ,arg-exps))))
 380
 381 (define-syntax build-conditional
 382   (syntax-rules ()
 383     ((_ source test-exp then-exp else-exp)
 384      `(if ,test-exp ,then-exp ,else-exp))))
 385
 386 (define-syntax build-lexical-reference
 387   (syntax-rules ()
 388     ((_ type source var)
 389      var)))
 390
 391 (define-syntax build-lexical-assignment
 392   (syntax-rules ()
 393     ((_ source var exp)
 394      `(set! ,var ,exp))))
 395
 396 (define-syntax build-global-reference
 397   (syntax-rules ()
 398     ((_ source var)
 399      var)))
 400
 401 (define-syntax build-global-assignment
 402   (syntax-rules ()
 403     ((_ source var exp)
 404      `(set! ,var ,exp))))
 405
 406 (define-syntax build-global-definition
 407   (syntax-rules ()
 408     ((_ source var exp)
 409      `(define ,var ,exp))))
 410
 411 (define-syntax build-lambda
 412   (syntax-rules ()
 413     ((_ src vars exp)
 414      `(lambda ,vars ,exp))))
 415
 416 (define-syntax build-primref
 417   (syntax-rules ()
 418     ((_ src name) name)
 419     ((_ src level name) name)))
 420
 421 (define-syntax build-data
 422   (syntax-rules ()
 423     ((_ src exp) `',exp)))
 424
 425 (define build-sequence
 426   (lambda (src exps)
 427     (if (null? (cdr exps))
 428         (car exps)
 429         `(begin ,@exps))))
 430
 431 (define build-let
 432   (lambda (src vars val-exps body-exp)
 433     (if (null? vars)
 434         body-exp
 435         `(let ,(map list vars val-exps) ,body-exp))))
 436
 437 (define build-named-let
 438   (lambda (src vars val-exps body-exp)
 439     (if (null? vars)
 440         body-exp
 441         `(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp))))
 442
 443 (define build-letrec
 444   (lambda (src vars val-exps body-exp)
 445     (if (null? vars)
 446         body-exp
 447         `(letrec ,(map list vars val-exps) ,body-exp))))
 448
 449 (define-syntax build-lexical-var
 450   (syntax-rules ()
 451     ((_ src id) (gensym (symbol->string id)))))
 452
 453 (define-syntax self-evaluating?
 454   (syntax-rules ()
 455     ((_ e)
 456      (let ((x e))
 457        (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x))))))
 458 )
 459
 460 (define-structure (syntax-object expression wrap))
 461
 462 (define-syntax unannotate
 463   (syntax-rules ()
 464     ((_ x)
 465      (let ((e x))
 466        (if (annotation? e)
 467            (annotation-expression e)
 468            e)))))
 469
 470 (define-syntax no-source (identifier-syntax #f))
 471
 472 (define source-annotation
 473   (lambda (x)
 474      (cond
 475        ((annotation? x) (annotation-source x))
 476        ((syntax-object? x) (source-annotation (syntax-object-expression x)))
 477        (else no-source))))
 478
 479 (define-syntax arg-check
 480   (syntax-rules ()
 481     ((_ pred? e who)
 482      (let ((x e))
 483        (if (not (pred? x)) (error-hook who "invalid argument" x))))))
 484
 485 ;;; compile-time environments
 486
 487 ;;; wrap and environment comprise two level mapping.
 488 ;;;   wrap : id --> label
 489 ;;;   env : label --> <element>
 490
 491 ;;; environments are represented in two parts: a lexical part and a global
 492 ;;; part.  The lexical part is a simple list of associations from labels
 493 ;;; to bindings.  The global part is implemented by
 494 ;;; {put,get}-global-definition-hook and associates symbols with
 495 ;;; bindings.
 496
 497 ;;; global (assumed global variable) and displaced-lexical (see below)
 498 ;;; do not show up in any environment; instead, they are fabricated by
 499 ;;; lookup when it finds no other bindings.
 500
 501 ;;; <environment>              ::= ((<label> . <binding>)*)
 502
 503 ;;; identifier bindings include a type and a value
 504
 505 ;;; <binding> ::= (macro . <procedure>)           macros
 506 ;;;               (core . <procedure>)            core forms
 507 ;;;               (begin)                         begin
 508 ;;;               (define)                        define
 509 ;;;               (define-syntax)                 define-syntax
 510 ;;;               (local-syntax . rec?)           let-syntax/letrec-syntax
 511 ;;;               (eval-when)                     eval-when
 512 ;;;               (syntax . (<var> . <level>))    pattern variables
 513 ;;;               (global)                        assumed global variable
 514 ;;;               (lexical . <var>)               lexical variables
 515 ;;;               (displaced-lexical)             displaced lexicals
 516 ;;; <level>   ::= <nonnegative integer>
 517 ;;; <var>     ::= variable returned by build-lexical-var
 518
 519 ;;; a macro is a user-defined syntactic-form.  a core is a system-defined
 520 ;;; syntactic form.  begin, define, define-syntax, and eval-when are
 521 ;;; treated specially since they are sensitive to whether the form is
 522 ;;; at top-level and (except for eval-when) can denote valid internal
 523 ;;; definitions.
 524
 525 ;;; a pattern variable is a variable introduced by syntax-case and can
 526 ;;; be referenced only within a syntax form.
 527
 528 ;;; any identifier for which no top-level syntax definition or local
 529 ;;; binding of any kind has been seen is assumed to be a global
 530 ;;; variable.
 531
 532 ;;; a lexical variable is a lambda- or letrec-bound variable.
 533
 534 ;;; a displaced-lexical identifier is a lexical identifier removed from
 535 ;;; it's scope by the return of a syntax object containing the identifier.
 536 ;;; a displaced lexical can also appear when a letrec-syntax-bound
 537 ;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
 538 ;;; a displaced lexical should never occur with properly written macros.
 539
 540 (define-syntax make-binding
 541   (syntax-rules (quote)
 542     ((_ type value) (cons type value))
 543     ((_ 'type) '(type))
 544     ((_ type) (cons type '()))))
 545 (define binding-type car)
 546 (define binding-value cdr)
 547
 548 (define-syntax null-env (identifier-syntax '()))
 549
 550 (define extend-env
 551   (lambda (labels bindings r)
 552     (if (null? labels)
 553         r
 554         (extend-env (cdr labels) (cdr bindings)
 555           (cons (cons (car labels) (car bindings)) r)))))
 556
 557 (define extend-var-env
 558   ; variant of extend-env that forms "lexical" binding
 559   (lambda (labels vars r)
 560     (if (null? labels)
 561         r
 562         (extend-var-env (cdr labels) (cdr vars)
 563           (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
 564
 565 ;;; we use a "macros only" environment in expansion of local macro
 566 ;;; definitions so that their definitions can use local macros without
 567 ;;; attempting to use other lexical identifiers.
 568 (define macros-only-env
 569   (lambda (r)
 570     (if (null? r)
 571         '()
 572         (let ((a (car r)))
 573           (if (eq? (cadr a) 'macro)
 574               (cons a (macros-only-env (cdr r)))
 575               (macros-only-env (cdr r)))))))
 576
 577 (define lookup
 578   ; x may be a label or a symbol
 579   ; although symbols are usually global, we check the environment first
 580   ; anyway because a temporary binding may have been established by
 581   ; fluid-let-syntax
 582   (lambda (x r)
 583     (cond
 584       ((assq x r) => cdr)
 585       ((symbol? x)
 586        (or (get-global-definition-hook x) (make-binding 'global)))
 587       (else (make-binding 'displaced-lexical)))))
 588
 589 (define global-extend
 590   (lambda (type sym val)
 591     (put-global-definition-hook sym (make-binding type val))))
 592
 593
 594 ;;; Conceptually, identifiers are always syntax objects.  Internally,
 595 ;;; however, the wrap is sometimes maintained separately (a source of
 596 ;;; efficiency and confusion), so that symbols are also considered
 597 ;;; identifiers by id?.  Externally, they are always wrapped.
 598
 599 (define nonsymbol-id?
 600   (lambda (x)
 601     (and (syntax-object? x)
 602          (symbol? (unannotate (syntax-object-expression x))))))
 603
 604 (define id?
 605   (lambda (x)
 606     (cond
 607       ((symbol? x) #t)
 608       ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
 609       ((annotation? x) (symbol? (annotation-expression x)))
 610       (else #f))))
 611
 612 (define-syntax id-sym-name
 613   (syntax-rules ()
 614     ((_ e)
 615      (let ((x e))
 616        (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
 617
 618 (define id-sym-name&marks
 619   (lambda (x w)
 620     (if (syntax-object? x)
 621         (values
 622           (unannotate (syntax-object-expression x))
 623           (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
 624         (values (unannotate x) (wrap-marks w)))))
 625
 626 ;;; syntax object wraps
 627
 628 ;;;         <wrap> ::= ((<mark> ...) . (<subst> ...))
 629 ;;;        <subst> ::= <shift> | <subs>
 630 ;;;         <subs> ::= #(<old name> <label> (<mark> ...))
 631 ;;;        <shift> ::= positive fixnum
 632
 633 (define make-wrap cons)
 634 (define wrap-marks car)
 635 (define wrap-subst cdr)
 636
 637 (define-syntax subst-rename? (identifier-syntax vector?))
 638 (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
 639 (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
 640 (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
 641 (define-syntax make-rename
 642   (syntax-rules ()
 643     ((_ old new marks) (vector old new marks))))
 644
 645 ;;; labels must be comparable with "eq?" and distinct from symbols.
 646 (define gen-label
 647   (lambda () (string #\i)))
 648
 649 (define gen-labels
 650   (lambda (ls)
 651     (if (null? ls)
 652         '()
 653         (cons (gen-label) (gen-labels (cdr ls))))))
 654
 655 (define-structure (ribcage symnames marks labels))
 656
 657 (define-syntax empty-wrap (identifier-syntax '(())))
 658
 659 (define-syntax top-wrap (identifier-syntax '((top))))
 660
 661 (define-syntax top-marked?
 662   (syntax-rules ()
 663     ((_ w) (memq 'top (wrap-marks w)))))
 664
 665 ;;; Marks must be comparable with "eq?" and distinct from pairs and
 666 ;;; the symbol top.  We do not use integers so that marks will remain
 667 ;;; unique even across file compiles.
 668
 669 (define-syntax the-anti-mark (identifier-syntax #f))
 670
 671 (define anti-mark
 672   (lambda (w)
 673     (make-wrap (cons the-anti-mark (wrap-marks w))
 674                (cons 'shift (wrap-subst w)))))
 675
 676 (define-syntax new-mark
 677   (syntax-rules ()
 678     ((_) (string #\m))))
 679
 680 ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
 681 ;;; internal definitions, in which the ribcages are built incrementally
 682 (define-syntax make-empty-ribcage
 683   (syntax-rules ()
 684     ((_) (make-ribcage '() '() '()))))
 685
 686 (define extend-ribcage!
 687   ; must receive ids with complete wraps
 688   (lambda (ribcage id label)
 689     (set-ribcage-symnames! ribcage
 690       (cons (unannotate (syntax-object-expression id))
 691             (ribcage-symnames ribcage)))
 692     (set-ribcage-marks! ribcage
 693       (cons (wrap-marks (syntax-object-wrap id))
 694             (ribcage-marks ribcage)))
 695     (set-ribcage-labels! ribcage
 696       (cons label (ribcage-labels ribcage)))))
 697
 698 ;;; make-binding-wrap creates vector-based ribcages
 699 (define make-binding-wrap
 700   (lambda (ids labels w)
 701     (if (null? ids)
 702         w
 703         (make-wrap
 704           (wrap-marks w)
 705           (cons
 706             (let ((labelvec (list->vector labels)))
 707               (let ((n (vector-length labelvec)))
 708                 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
 709                   (let f ((ids ids) (i 0))
 710                     (if (not (null? ids))
 711                         (call-with-values
 712                           (lambda () (id-sym-name&marks (car ids) w))
 713                           (lambda (symname marks)
 714                             (vector-set! symnamevec i symname)
 715                             (vector-set! marksvec i marks)
 716                             (f (cdr ids) (fx+ i 1))))))
 717                   (make-ribcage symnamevec marksvec labelvec))))
 718             (wrap-subst w))))))
 719
 720 (define smart-append
 721   (lambda (m1 m2)
 722     (if (null? m2)
 723         m1
 724         (append m1 m2))))
 725
 726 (define join-wraps
 727   (lambda (w1 w2)
 728     (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
 729       (if (null? m1)
 730           (if (null? s1)
 731               w2
 732               (make-wrap
 733                 (wrap-marks w2)
 734                 (smart-append s1 (wrap-subst w2))))
 735           (make-wrap
 736             (smart-append m1 (wrap-marks w2))
 737             (smart-append s1 (wrap-subst w2)))))))
 738
 739 (define join-marks
 740   (lambda (m1 m2)
 741     (smart-append m1 m2)))
 742
 743 (define same-marks?
 744   (lambda (x y)
 745     (or (eq? x y)
 746         (and (not (null? x))
 747              (not (null? y))
 748              (eq? (car x) (car y))
 749              (same-marks? (cdr x) (cdr y))))))
 750
 751 (define id-var-name
 752   (lambda (id w)
 753     (define-syntax first
 754       (syntax-rules ()
 755         ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
 756     (define search
 757       (lambda (sym subst marks)
 758         (if (null? subst)
 759             (values #f marks)
 760             (let ((fst (car subst)))
 761               (if (eq? fst 'shift)
 762                   (search sym (cdr subst) (cdr marks))
 763                   (let ((symnames (ribcage-symnames fst)))
 764                     (if (vector? symnames)
 765                         (search-vector-rib sym subst marks symnames fst)
 766                         (search-list-rib sym subst marks symnames fst))))))))
 767     (define search-list-rib
 768       (lambda (sym subst marks symnames ribcage)
 769         (let f ((symnames symnames) (i 0))
 770           (cond
 771             ((null? symnames) (search sym (cdr subst) marks))
 772             ((and (eq? (car symnames) sym)
 773                   (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
 774              (values (list-ref (ribcage-labels ribcage) i) marks))
 775             (else (f (cdr symnames) (fx+ i 1)))))))
 776     (define search-vector-rib
 777       (lambda (sym subst marks symnames ribcage)
 778         (let ((n (vector-length symnames)))
 779           (let f ((i 0))
 780             (cond
 781               ((fx= i n) (search sym (cdr subst) marks))
 782               ((and (eq? (vector-ref symnames i) sym)
 783                     (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
 784                (values (vector-ref (ribcage-labels ribcage) i) marks))
 785               (else (f (fx+ i 1))))))))
 786     (cond
 787       ((symbol? id)
 788        (or (first (search id (wrap-subst w) (wrap-marks w))) id))
 789       ((syntax-object? id)
 790         (let ((id (unannotate (syntax-object-expression id)))
 791               (w1 (syntax-object-wrap id)))
 792           (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
 793             (call-with-values (lambda () (search id (wrap-subst w) marks))
 794               (lambda (new-id marks)
 795                 (or new-id
 796                     (first (search id (wrap-subst w1) marks))
 797                     id))))))
 798       ((annotation? id)
 799        (let ((id (unannotate id)))
 800          (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
 801       (else (error-hook 'id-var-name "invalid id" id)))))
 802
 803 ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
 804 ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
 805
 806 (define free-id=?
 807   (lambda (i j)
 808     (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
 809          (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
 810
 811 ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
 812 ;;; long as the missing portion of the wrap is common to both of the ids
 813 ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
 814
 815 (define bound-id=?
 816   (lambda (i j)
 817     (if (and (syntax-object? i) (syntax-object? j))
 818         (and (eq? (unannotate (syntax-object-expression i))
 819                   (unannotate (syntax-object-expression j)))
 820              (same-marks? (wrap-marks (syntax-object-wrap i))
 821                   (wrap-marks (syntax-object-wrap j))))
 822         (eq? (unannotate i) (unannotate j)))))
 823
 824 ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
 825 ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
 826 ;;; as long as the missing portion of the wrap is common to all of the
 827 ;;; ids.
 828
 829 (define valid-bound-ids?
 830   (lambda (ids)
 831      (and (let all-ids? ((ids ids))
 832             (or (null? ids)
 833                 (and (id? (car ids))
 834                      (all-ids? (cdr ids)))))
 835           (distinct-bound-ids? ids))))
 836
 837 ;;; distinct-bound-ids? expects a list of ids and returns #t if there are
 838 ;;; no duplicates.  It is quadratic on the length of the id list; long
 839 ;;; lists could be sorted to make it more efficient.  distinct-bound-ids?
 840 ;;; may be passed unwrapped (or partially wrapped) ids as long as the
 841 ;;; missing portion of the wrap is common to all of the ids.
 842
 843 (define distinct-bound-ids?
 844   (lambda (ids)
 845     (let distinct? ((ids ids))
 846       (or (null? ids)
 847           (and (not (bound-id-member? (car ids) (cdr ids)))
 848                (distinct? (cdr ids)))))))
 849
 850 (define bound-id-member?
 851    (lambda (x list)
 852       (and (not (null? list))
 853            (or (bound-id=? x (car list))
 854                (bound-id-member? x (cdr list))))))
 855
 856 ;;; wrapping expressions and identifiers
 857
 858 (define wrap
 859   (lambda (x w)
 860     (cond
 861       ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
 862       ((syntax-object? x)
 863        (make-syntax-object
 864          (syntax-object-expression x)
 865          (join-wraps w (syntax-object-wrap x))))
 866       ((null? x) x)
 867       (else (make-syntax-object x w)))))
 868
 869 (define source-wrap
 870   (lambda (x w s)
 871     (wrap (if s (make-annotation x s #f) x) w)))
 872
 873 ;;; expanding
 874
 875 (define chi-sequence
 876   (lambda (body r w s)
 877     (build-sequence s
 878       (let dobody ((body body) (r r) (w w))
 879         (if (null? body)
 880             '()
 881             (let ((first (chi (car body) r w)))
 882               (cons first (dobody (cdr body) r w))))))))
 883
 884 (define chi-top-sequence
 885   (lambda (body r w s m esew)
 886     (build-sequence s
 887       (let dobody ((body body) (r r) (w w) (m m) (esew esew))
 888         (if (null? body)
 889             '()
 890             (let ((first (chi-top (car body) r w m esew)))
 891               (cons first (dobody (cdr body) r w m esew))))))))
 892
 893 (define chi-install-global
 894   (lambda (name e)
 895     (build-application no-source
 896       (build-primref no-source 'install-global-transformer)
 897       (list (build-data no-source name) e))))
 898
 899 (define chi-when-list
 900   (lambda (e when-list w)
 901     ; when-list is syntax'd version of list of situations
 902     (let f ((when-list when-list) (situations '()))
 903       (if (null? when-list)
 904           situations
 905           (f (cdr when-list)
 906              (cons (let ((x (car when-list)))
 907                      (cond
 908                        ((free-id=? x (syntax compile)) 'compile)
 909                        ((free-id=? x (syntax load)) 'load)
 910                        ((free-id=? x (syntax eval)) 'eval)
 911                        (else (syntax-error (wrap x w)
 912                                "invalid eval-when situation"))))
 913                    situations))))))
 914
 915 ;;; syntax-type returns five values: type, value, e, w, and s.  The first
 916 ;;; two are described in the table below.
 917 ;;;
 918 ;;;    type                   value         explanation
 919 ;;;    -------------------------------------------------------------------
 920 ;;;    core                   procedure     core form (including singleton)
 921 ;;;    lexical                name          lexical variable reference
 922 ;;;    global                 name          global variable reference
 923 ;;;    begin                  none          begin keyword
 924 ;;;    define                 none          define keyword
 925 ;;;    define-syntax          none          define-syntax keyword
 926 ;;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
 927 ;;;    eval-when              none          eval-when keyword
 928 ;;;    syntax                 level         pattern variable
 929 ;;;    displaced-lexical      none          displaced lexical identifier
 930 ;;;    lexical-call           name          call to lexical variable
 931 ;;;    global-call            name          call to global variable
 932 ;;;    call                   none          any other call
 933 ;;;    begin-form             none          begin expression
 934 ;;;    define-form            id            variable definition
 935 ;;;    define-syntax-form     id            syntax definition
 936 ;;;    local-syntax-form      rec?          syntax definition
 937 ;;;    eval-when-form         none          eval-when form
 938 ;;;    constant               none          self-evaluating datum
 939 ;;;    other                  none          anything else
 940 ;;;
 941 ;;; For define-form and define-syntax-form, e is the rhs expression.
 942 ;;; For all others, e is the entire form.  w is the wrap for e.
 943 ;;; s is the source for the entire form.
 944 ;;;
 945 ;;; syntax-type expands macros and unwraps as necessary to get to
 946 ;;; one of the forms above.  It also parses define and define-syntax
 947 ;;; forms, although perhaps this should be done by the consumer.
 948
 949 (define syntax-type
 950   (lambda (e r w s rib)
 951     (cond
 952       ((symbol? e)
 953        (let* ((n (id-var-name e w))
 954               (b (lookup n r))
 955               (type (binding-type b)))
 956          (case type
 957            ((lexical) (values type (binding-value b) e w s))
 958            ((global) (values type n e w s))
 959            ((macro)
 960             (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
 961            (else (values type (binding-value b) e w s)))))
 962       ((pair? e)
 963        (let ((first (car e)))
 964          (if (id? first)
 965              (let* ((n (id-var-name first w))
 966                     (b (lookup n r))
 967                     (type (binding-type b)))
 968                (case type
 969                  ((lexical) (values 'lexical-call (binding-value b) e w s))
 970                  ((global) (values 'global-call n e w s))
 971                  ((macro)
 972                   (syntax-type (chi-macro (binding-value b) e r w rib)
 973                     r empty-wrap s rib))
 974                  ((core) (values type (binding-value b) e w s))
 975                  ((local-syntax)
 976                   (values 'local-syntax-form (binding-value b) e w s))
 977                  ((begin) (values 'begin-form #f e w s))
 978                  ((eval-when) (values 'eval-when-form #f e w s))
 979                  ((define)
 980                   (syntax-case e ()
 981                     ((_ name val)
 982                      (id? (syntax name))
 983                      (values 'define-form (syntax name) (syntax val) w s))
 984                     ((_ (name . args) e1 e2 ...)
 985                      (and (id? (syntax name))
 986                           (valid-bound-ids? (lambda-var-list (syntax args))))
 987                      ; need lambda here...
 988                      (values 'define-form (wrap (syntax name) w)
 989                        (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
 990                        empty-wrap s))
 991                     ((_ name)
 992                      (id? (syntax name))
 993                      (values 'define-form (wrap (syntax name) w)
 994                        (syntax (void))
 995                        empty-wrap s))))
 996                  ((define-syntax)
 997                   (syntax-case e ()
 998                     ((_ name val)
 999                      (id? (syntax name))
1000                      (values 'define-syntax-form (syntax name)
1001                        (syntax val) w s))))
1002                  (else (values 'call #f e w s))))
1003              (values 'call #f e w s))))
1004       ((syntax-object? e)
1005        ;; s can't be valid source if we've unwrapped
1006        (syntax-type (syntax-object-expression e)
1007                     r
1008                     (join-wraps w (syntax-object-wrap e))
1009                     no-source rib))
1010       ((annotation? e)
1011        (syntax-type (annotation-expression e) r w (annotation-source e) rib))
1012       ((self-evaluating? e) (values 'constant #f e w s))
1013       (else (values 'other #f e w s)))))
1014
1015 (define chi-top
1016   (lambda (e r w m esew)
1017     (define-syntax eval-if-c&e
1018       (syntax-rules ()
1019         ((_ m e)
1020          (let ((x e))
1021            (if (eq? m 'c&e) (top-level-eval-hook x))
1022            x))))
1023     (call-with-values
1024       (lambda () (syntax-type e r w no-source #f))
1025       (lambda (type value e w s)
1026         (case type
1027           ((begin-form)
1028            (syntax-case e ()
1029              ((_) (chi-void))
1030              ((_ e1 e2 ...)
1031               (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
1032           ((local-syntax-form)
1033            (chi-local-syntax value e r w s
1034              (lambda (body r w s)
1035                (chi-top-sequence body r w s m esew))))
1036           ((eval-when-form)
1037            (syntax-case e ()
1038              ((_ (x ...) e1 e2 ...)
1039               (let ((when-list (chi-when-list e (syntax (x ...)) w))
1040                     (body (syntax (e1 e2 ...))))
1041                 (cond
1042                   ((eq? m 'e)
1043                    (if (memq 'eval when-list)
1044                        (chi-top-sequence body r w s 'e '(eval))
1045                        (chi-void)))
1046                   ((memq 'load when-list)
1047                    (if (or (memq 'compile when-list)
1048                            (and (eq? m 'c&e) (memq 'eval when-list)))
1049                        (chi-top-sequence body r w s 'c&e '(compile load))
1050                        (if (memq m '(c c&e))
1051                            (chi-top-sequence body r w s 'c '(load))
1052                            (chi-void))))
1053                   ((or (memq 'compile when-list)
1054                        (and (eq? m 'c&e) (memq 'eval when-list)))
1055                    (top-level-eval-hook
1056                      (chi-top-sequence body r w s 'e '(eval)))
1057                    (chi-void))
1058                   (else (chi-void)))))))
1059           ((define-syntax-form)
1060            (let ((n (id-var-name value w)) (r (macros-only-env r)))
1061              (case m
1062                ((c)
1063                 (if (memq 'compile esew)
1064                     (let ((e (chi-install-global n (chi e r w))))
1065                       (top-level-eval-hook e)
1066                       (if (memq 'load esew) e (chi-void)))
1067                     (if (memq 'load esew)
1068                         (chi-install-global n (chi e r w))
1069                         (chi-void))))
1070                ((c&e)
1071                 (let ((e (chi-install-global n (chi e r w))))
1072                   (top-level-eval-hook e)
1073                   e))
1074                (else
1075                 (if (memq 'eval esew)
1076                     (top-level-eval-hook
1077                       (chi-install-global n (chi e r w))))
1078                 (chi-void)))))
1079           ((define-form)
1080            (let ((n (id-var-name value w)))
1081              (case (binding-type (lookup n r))
1082                ((global)
1083                 (eval-if-c&e m
1084                   (build-global-definition s n (chi e r w))))
1085                ((displaced-lexical)
1086                 (syntax-error (wrap value w) "identifier out of context"))
1087                (else (syntax-error (wrap value w)
1088                        "cannot define keyword at top level")))))
1089           (else (eval-if-c&e m (chi-expr type value e r w s))))))))
1090
1091 (define chi
1092   (lambda (e r w)
1093     (call-with-values
1094       (lambda () (syntax-type e r w no-source #f))
1095       (lambda (type value e w s)
1096         (chi-expr type value e r w s)))))
1097
1098 (define chi-expr
1099   (lambda (type value e r w s)
1100     (case type
1101       ((lexical)
1102        (build-lexical-reference 'value s value))
1103       ((core) (value e r w s))
1104       ((lexical-call)
1105        (chi-application
1106          (build-lexical-reference 'fun (source-annotation (car e)) value)
1107          e r w s))
1108       ((global-call)
1109        (chi-application
1110          (build-global-reference (source-annotation (car e)) value)
1111          e r w s))
1112       ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
1113       ((global) (build-global-reference s value))
1114       ((call) (chi-application (chi (car e) r w) e r w s))
1115       ((begin-form)
1116        (syntax-case e ()
1117          ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
1118       ((local-syntax-form)
1119        (chi-local-syntax value e r w s chi-sequence))
1120       ((eval-when-form)
1121        (syntax-case e ()
1122          ((_ (x ...) e1 e2 ...)
1123           (let ((when-list (chi-when-list e (syntax (x ...)) w)))
1124             (if (memq 'eval when-list)
1125                 (chi-sequence (syntax (e1 e2 ...)) r w s)
1126                 (chi-void))))))
1127       ((define-form define-syntax-form)
1128        (syntax-error (wrap value w) "invalid context for definition of"))
1129       ((syntax)
1130        (syntax-error (source-wrap e w s)
1131          "reference to pattern variable outside syntax form"))
1132       ((displaced-lexical)
1133        (syntax-error (source-wrap e w s)
1134          "reference to identifier outside its scope"))
1135       (else (syntax-error (source-wrap e w s))))))
1136
1137 (define chi-application
1138   (lambda (x e r w s)
1139     (syntax-case e ()
1140       ((e0 e1 ...)
1141        (build-application s x
1142          (map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))
1143
1144 (define chi-macro
1145   (lambda (p e r w rib)
1146     (define rebuild-macro-output
1147       (lambda (x m)
1148         (cond ((pair? x)
1149                (cons (rebuild-macro-output (car x) m)
1150                      (rebuild-macro-output (cdr x) m)))
1151               ((syntax-object? x)
1152                (let ((w (syntax-object-wrap x)))
1153                  (let ((ms (wrap-marks w)) (s (wrap-subst w)))
1154                    (make-syntax-object (syntax-object-expression x)
1155                      (if (and (pair? ms) (eq? (car ms) the-anti-mark))
1156                          (make-wrap (cdr ms)
1157                            (if rib (cons rib (cdr s)) (cdr s)))
1158                          (make-wrap (cons m ms)
1159                            (if rib
1160                                (cons rib (cons 'shift s))
1161                                (cons 'shift s))))))))
1162               ((vector? x)
1163                (let* ((n (vector-length x)) (v (make-vector n)))
1164                  (do ((i 0 (fx+ i 1)))
1165                      ((fx= i n) v)
1166                      (vector-set! v i
1167                        (rebuild-macro-output (vector-ref x i) m)))))
1168               ((symbol? x)
1169                (syntax-error x "encountered raw symbol in macro output"))
1170               (else x))))
1171     (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))
1172
1173 (define chi-body
1174   ;; In processing the forms of the body, we create a new, empty wrap.
1175   ;; This wrap is augmented (destructively) each time we discover that
1176   ;; the next form is a definition.  This is done:
1177   ;;
1178   ;;   (1) to allow the first nondefinition form to be a call to
1179   ;;       one of the defined ids even if the id previously denoted a
1180   ;;       definition keyword or keyword for a macro expanding into a
1181   ;;       definition;
1182   ;;   (2) to prevent subsequent definition forms (but unfortunately
1183   ;;       not earlier ones) and the first nondefinition form from
1184   ;;       confusing one of the bound identifiers for an auxiliary
1185   ;;       keyword; and
1186   ;;   (3) so that we do not need to restart the expansion of the
1187   ;;       first nondefinition form, which is problematic anyway
1188   ;;       since it might be the first element of a begin that we
1189   ;;       have just spliced into the body (meaning if we restarted,
1190   ;;       we'd really need to restart with the begin or the macro
1191   ;;       call that expanded into the begin, and we'd have to give
1192   ;;       up allowing (begin <defn>+ <expr>+), which is itself
1193   ;;       problematic since we don't know if a begin contains only
1194   ;;       definitions until we've expanded it).
1195   ;;
1196   ;; Before processing the body, we also create a new environment
1197   ;; containing a placeholder for the bindings we will add later and
1198   ;; associate this environment with each form.  In processing a
1199   ;; let-syntax or letrec-syntax, the associated environment may be
1200   ;; augmented with local keyword bindings, so the environment may
1201   ;; be different for different forms in the body.  Once we have
1202   ;; gathered up all of the definitions, we evaluate the transformer
1203   ;; expressions and splice into r at the placeholder the new variable
1204   ;; and keyword bindings.  This allows let-syntax or letrec-syntax
1205   ;; forms local to a portion or all of the body to shadow the
1206   ;; definition bindings.
1207   ;;
1208   ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
1209   ;; into the body.
1210   ;;
1211   ;; outer-form is fully wrapped w/source
1212   (lambda (body outer-form r w)
1213     (let* ((r (cons '("placeholder" . (placeholder)) r))
1214            (ribcage (make-empty-ribcage))
1215            (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
1216       (let parse ((body (map (lambda (x) (cons r (wrap x w))) body))
1217                   (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
1218         (if (null? body)
1219             (syntax-error outer-form "no expressions in body")
1220             (let ((e (cdar body)) (er (caar body)))
1221               (call-with-values
1222                 (lambda () (syntax-type e er empty-wrap no-source ribcage))
1223                 (lambda (type value e w s)
1224                   (case type
1225                     ((define-form)
1226                      (let ((id (wrap value w)) (label (gen-label)))
1227                        (let ((var (gen-var id)))
1228                          (extend-ribcage! ribcage id label)
1229                          (parse (cdr body)
1230                            (cons id ids) (cons label labels)
1231                            (cons var vars) (cons (cons er (wrap e w)) vals)
1232                            (cons (make-binding 'lexical var) bindings)))))
1233                     ((define-syntax-form)
1234                      (let ((id (wrap value w)) (label (gen-label)))
1235                        (extend-ribcage! ribcage id label)
1236                        (parse (cdr body)
1237                          (cons id ids) (cons label labels)
1238                          vars vals
1239                          (cons (make-binding 'macro (cons er (wrap e w)))
1240                                bindings))))
1241                     ((begin-form)
1242                      (syntax-case e ()
1243                        ((_ e1 ...)
1244                         (parse (let f ((forms (syntax (e1 ...))))
1245                                  (if (null? forms)
1246                                      (cdr body)
1247                                      (cons (cons er (wrap (car forms) w))
1248                                            (f (cdr forms)))))
1249                           ids labels vars vals bindings))))
1250                     ((local-syntax-form)
1251                      (chi-local-syntax value e er w s
1252                        (lambda (forms er w s)
1253                          (parse (let f ((forms forms))
1254                                   (if (null? forms)
1255                                       (cdr body)
1256                                       (cons (cons er (wrap (car forms) w))
1257                                             (f (cdr forms)))))
1258                            ids labels vars vals bindings))))
1259                     (else ; found a non-definition
1260                      (if (null? ids)
1261                          (build-sequence no-source
1262                            (map (lambda (x)
1263                                   (chi (cdr x) (car x) empty-wrap))
1264                                 (cons (cons er (source-wrap e w s))
1265                                       (cdr body))))
1266                          (begin
1267                            (if (not (valid-bound-ids? ids))
1268                                (syntax-error outer-form
1269                                  "invalid or duplicate identifier in definition"))
1270                            (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1271                              (if (not (null? bs))
1272                                  (let* ((b (car bs)))
1273                                    (if (eq? (car b) 'macro)
1274                                        (let* ((er (cadr b))
1275                                               (r-cache
1276                                                 (if (eq? er er-cache)
1277                                                     r-cache
1278                                                     (macros-only-env er))))
1279                                          (set-cdr! b
1280                                            (eval-local-transformer
1281                                              (chi (cddr b) r-cache empty-wrap)))
1282                                          (loop (cdr bs) er r-cache))
1283                                        (loop (cdr bs) er-cache r-cache)))))
1284                            (set-cdr! r (extend-env labels bindings (cdr r)))
1285                            (build-letrec no-source
1286                              vars
1287                              (map (lambda (x)
1288                                     (chi (cdr x) (car x) empty-wrap))
1289                                   vals)
1290                              (build-sequence no-source
1291                                (map (lambda (x)
1292                                       (chi (cdr x) (car x) empty-wrap))
1293                                     (cons (cons er (source-wrap e w s))
1294                                           (cdr body)))))))))))))))))
1295
1296 (define chi-lambda-clause
1297   (lambda (e c r w k)
1298     (syntax-case c ()
1299       (((id ...) e1 e2 ...)
1300        (let ((ids (syntax (id ...))))
1301          (if (not (valid-bound-ids? ids))
1302              (syntax-error e "invalid parameter list in")
1303              (let ((labels (gen-labels ids))
1304                    (new-vars (map gen-var ids)))
1305                (k new-vars
1306                   (chi-body (syntax (e1 e2 ...))
1307                             e
1308                             (extend-var-env labels new-vars r)
1309                             (make-binding-wrap ids labels w)))))))
1310       ((ids e1 e2 ...)
1311        (let ((old-ids (lambda-var-list (syntax ids))))
1312          (if (not (valid-bound-ids? old-ids))
1313              (syntax-error e "invalid parameter list in")
1314              (let ((labels (gen-labels old-ids))
1315                    (new-vars (map gen-var old-ids)))
1316                (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
1317                     (if (null? ls1)
1318                         ls2
1319                         (f (cdr ls1) (cons (car ls1) ls2))))
1320                   (chi-body (syntax (e1 e2 ...))
1321                             e
1322                             (extend-var-env labels new-vars r)
1323                             (make-binding-wrap old-ids labels w)))))))
1324       (_ (syntax-error e)))))
1325
1326 (define chi-local-syntax
1327   (lambda (rec? e r w s k)
1328     (syntax-case e ()
1329       ((_ ((id val) ...) e1 e2 ...)
1330        (let ((ids (syntax (id ...))))
1331          (if (not (valid-bound-ids? ids))
1332              (syntax-error e "duplicate bound keyword in")
1333              (let ((labels (gen-labels ids)))
1334                (let ((new-w (make-binding-wrap ids labels w)))
1335                  (k (syntax (e1 e2 ...))
1336                     (extend-env
1337                       labels
1338                       (let ((w (if rec? new-w w))
1339                             (trans-r (macros-only-env r)))
1340                         (map (lambda (x)
1341                                (make-binding 'macro
1342                                  (eval-local-transformer (chi x trans-r w))))
1343                              (syntax (val ...))))
1344                       r)
1345                     new-w
1346                     s))))))
1347       (_ (syntax-error (source-wrap e w s))))))
1348
1349 (define eval-local-transformer
1350   (lambda (expanded)
1351     (let ((p (local-eval-hook expanded)))
1352       (if (procedure? p)
1353           p
1354           (syntax-error p "nonprocedure transfomer")))))
1355
1356 (define chi-void
1357   (lambda ()
1358     (build-application no-source (build-primref no-source 'void) '())))
1359
1360 (define ellipsis?
1361   (lambda (x)
1362     (and (nonsymbol-id? x)
1363          (free-id=? x (syntax (... ...))))))
1364
1365 ;;; data
1366
1367 ;;; strips all annotations from potentially circular reader output
1368
1369 (define strip-annotation
1370   (lambda (x parent)
1371     (cond
1372       ((pair? x)
1373        (let ((new (cons #f #f)))
1374          (when parent (set-annotation-stripped! parent new))
1375          (set-car! new (strip-annotation (car x) #f))
1376          (set-cdr! new (strip-annotation (cdr x) #f))
1377          new))
1378       ((annotation? x)
1379        (or (annotation-stripped x)
1380            (strip-annotation (annotation-expression x) x)))
1381       ((vector? x)
1382        (let ((new (make-vector (vector-length x))))
1383          (when parent (set-annotation-stripped! parent new))
1384          (let loop ((i (- (vector-length x) 1)))
1385            (unless (fx< i 0)
1386              (vector-set! new i (strip-annotation (vector-ref x i) #f))
1387              (loop (fx- i 1))))
1388          new))
1389       (else x))))
1390
1391 ;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
1392 ;;; on an annotation, strips the annotation as well.
1393 ;;; since only the head of a list is annotated by the reader, not each pair
1394 ;;; in the spine, we also check for pairs whose cars are annotated in case
1395 ;;; we've been passed the cdr of an annotated list
1396
1397 (define strip
1398   (lambda (x w)
1399     (if (top-marked? w)
1400         (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
1401             (strip-annotation x #f)
1402             x)
1403         (let f ((x x))
1404           (cond
1405             ((syntax-object? x)
1406              (strip (syntax-object-expression x) (syntax-object-wrap x)))
1407             ((pair? x)
1408              (let ((a (f (car x))) (d (f (cdr x))))
1409                (if (and (eq? a (car x)) (eq? d (cdr x)))
1410                    x
1411                    (cons a d))))
1412             ((vector? x)
1413              (let ((old (vector->list x)))
1414                 (let ((new (map f old)))
1415                    (if (andmap eq? old new) x (list->vector new)))))
1416             (else x))))))
1417
1418 ;;; lexical variables
1419
1420 (define gen-var
1421   (lambda (id)
1422     (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1423       (if (annotation? id)
1424           (build-lexical-var (annotation-source id) (annotation-expression id))
1425           (build-lexical-var no-source id)))))
1426
1427 (define lambda-var-list
1428   (lambda (vars)
1429     (let lvl ((vars vars) (ls '()) (w empty-wrap))
1430        (cond
1431          ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
1432          ((id? vars) (cons (wrap vars w) ls))
1433          ((null? vars) ls)
1434          ((syntax-object? vars)
1435           (lvl (syntax-object-expression vars)
1436                ls
1437                (join-wraps w (syntax-object-wrap vars))))
1438          ((annotation? vars)
1439           (lvl (annotation-expression vars) ls w))
1440        ; include anything else to be caught by subsequent error
1441        ; checking
1442          (else (cons vars ls))))))
1443
1444 ;;; core transformers
1445
1446 (global-extend 'local-syntax 'letrec-syntax #t)
1447 (global-extend 'local-syntax 'let-syntax #f)
1448
1449 (global-extend 'core 'fluid-let-syntax
1450   (lambda (e r w s)
1451     (syntax-case e ()
1452       ((_ ((var val) ...) e1 e2 ...)
1453        (valid-bound-ids? (syntax (var ...)))
1454        (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
1455          (for-each
1456            (lambda (id n)
1457              (case (binding-type (lookup n r))
1458                ((displaced-lexical)
1459                 (syntax-error (source-wrap id w s)
1460                   "identifier out of context"))))
1461            (syntax (var ...))
1462            names)
1463          (chi-body
1464            (syntax (e1 e2 ...))
1465            (source-wrap e w s)
1466            (extend-env
1467              names
1468              (let ((trans-r (macros-only-env r)))
1469                (map (lambda (x)
1470                       (make-binding 'macro
1471                         (eval-local-transformer (chi x trans-r w))))
1472                     (syntax (val ...))))
1473              r)
1474            w)))
1475       (_ (syntax-error (source-wrap e w s))))))
1476
1477 (global-extend 'core 'quote
1478    (lambda (e r w s)
1479       (syntax-case e ()
1480          ((_ e) (build-data s (strip (syntax e) w)))
1481          (_ (syntax-error (source-wrap e w s))))))
1482
1483 (global-extend 'core 'syntax
1484   (let ()
1485     (define gen-syntax
1486       (lambda (src e r maps ellipsis?)
1487         (if (id? e)
1488             (let ((label (id-var-name e empty-wrap)))
1489               (let ((b (lookup label r)))
1490                 (if (eq? (binding-type b) 'syntax)
1491                     (call-with-values
1492                       (lambda ()
1493                         (let ((var.lev (binding-value b)))
1494                           (gen-ref src (car var.lev) (cdr var.lev) maps)))
1495                       (lambda (var maps) (values `(ref ,var) maps)))
1496                     (if (ellipsis? e)
1497                         (syntax-error src "misplaced ellipsis in syntax form")
1498                         (values `(quote ,e) maps)))))
1499             (syntax-case e ()
1500               ((dots e)
1501                (ellipsis? (syntax dots))
1502                (gen-syntax src (syntax e) r maps (lambda (x) #f)))
1503               ((x dots . y)
1504                ; this could be about a dozen lines of code, except that we
1505                ; choose to handle (syntax (x ... ...)) forms
1506                (ellipsis? (syntax dots))
1507                (let f ((y (syntax y))
1508                        (k (lambda (maps)
1509                             (call-with-values
1510                               (lambda ()
1511                                 (gen-syntax src (syntax x) r
1512                                   (cons '() maps) ellipsis?))
1513                               (lambda (x maps)
1514                                 (if (null? (car maps))
1515                                     (syntax-error src
1516                                       "extra ellipsis in syntax form")
1517                                     (values (gen-map x (car maps))
1518                                             (cdr maps))))))))
1519                  (syntax-case y ()
1520                    ((dots . y)
1521                     (ellipsis? (syntax dots))
1522                     (f (syntax y)
1523                        (lambda (maps)
1524                          (call-with-values
1525                            (lambda () (k (cons '() maps)))
1526                            (lambda (x maps)
1527                              (if (null? (car maps))
1528                                  (syntax-error src
1529                                    "extra ellipsis in syntax form")
1530                                  (values (gen-mappend x (car maps))
1531                                          (cdr maps))))))))
1532                    (_ (call-with-values
1533                         (lambda () (gen-syntax src y r maps ellipsis?))
1534                         (lambda (y maps)
1535                           (call-with-values
1536                             (lambda () (k maps))
1537                             (lambda (x maps)
1538                               (values (gen-append x y) maps)))))))))
1539               ((x . y)
1540                (call-with-values
1541                  (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
1542                  (lambda (x maps)
1543                    (call-with-values
1544                      (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
1545                      (lambda (y maps) (values (gen-cons x y) maps))))))
1546               (#(e1 e2 ...)
1547                (call-with-values
1548                  (lambda ()
1549                    (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
1550                  (lambda (e maps) (values (gen-vector e) maps))))
1551               (_ (values `(quote ,e) maps))))))
1552
1553     (define gen-ref
1554       (lambda (src var level maps)
1555         (if (fx= level 0)
1556             (values var maps)
1557             (if (null? maps)
1558                 (syntax-error src "missing ellipsis in syntax form")
1559                 (call-with-values
1560                   (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
1561                   (lambda (outer-var outer-maps)
1562                     (let ((b (assq outer-var (car maps))))
1563                       (if b
1564                           (values (cdr b) maps)
1565                           (let ((inner-var (gen-var 'tmp)))
1566                             (values inner-var
1567                                     (cons (cons (cons outer-var inner-var)
1568                                                 (car maps))
1569                                           outer-maps)))))))))))
1570
1571     (define gen-mappend
1572       (lambda (e map-env)
1573         `(apply (primitive append) ,(gen-map e map-env))))
1574
1575     (define gen-map
1576       (lambda (e map-env)
1577         (let ((formals (map cdr map-env))
1578               (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
1579           (cond
1580             ((eq? (car e) 'ref)
1581              ; identity map equivalence:
1582              ; (map (lambda (x) x) y) == y
1583              (car actuals))
1584             ((andmap
1585                 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1586                 (cdr e))
1587              ; eta map equivalence:
1588              ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
1589              `(map (primitive ,(car e))
1590                    ,@(map (let ((r (map cons formals actuals)))
1591                             (lambda (x) (cdr (assq (cadr x) r))))
1592                           (cdr e))))
1593             (else `(map (lambda ,formals ,e) ,@actuals))))))
1594
1595     (define gen-cons
1596       (lambda (x y)
1597         (case (car y)
1598           ((quote)
1599            (if (eq? (car x) 'quote)
1600                `(quote (,(cadr x) . ,(cadr y)))
1601                (if (eq? (cadr y) '())
1602                    `(list ,x)
1603                    `(cons ,x ,y))))
1604           ((list) `(list ,x ,@(cdr y)))
1605           (else `(cons ,x ,y)))))
1606
1607     (define gen-append
1608       (lambda (x y)
1609         (if (equal? y '(quote ()))
1610             x
1611             `(append ,x ,y))))
1612
1613     (define gen-vector
1614       (lambda (x)
1615         (cond
1616           ((eq? (car x) 'list) `(vector ,@(cdr x)))
1617           ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
1618           (else `(list->vector ,x)))))
1619
1620
1621     (define regen
1622       (lambda (x)
1623         (case (car x)
1624           ((ref) (build-lexical-reference 'value no-source (cadr x)))
1625           ((primitive) (build-primref no-source (cadr x)))
1626           ((quote) (build-data no-source (cadr x)))
1627           ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
1628           ((map) (let ((ls (map regen (cdr x))))
1629                    (build-application no-source
1630                      (if (fx= (length ls) 2)
1631                          (build-primref no-source 'map)
1632                         ; really need to do our own checking here
1633                          (build-primref no-source 2 'map)) ; require error check
1634                      ls)))
1635           (else (build-application no-source
1636                   (build-primref no-source (car x))
1637                   (map regen (cdr x)))))))
1638
1639     (lambda (e r w s)
1640       (let ((e (source-wrap e w s)))
1641         (syntax-case e ()
1642           ((_ x)
1643            (call-with-values
1644              (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
1645              (lambda (e maps) (regen e))))
1646           (_ (syntax-error e)))))))
1647
1648
1649 (global-extend 'core 'lambda
1650    (lambda (e r w s)
1651       (syntax-case e ()
1652          ((_ . c)
1653           (chi-lambda-clause (source-wrap e w s) (syntax c) r w
1654             (lambda (vars body) (build-lambda s vars body)))))))
1655
1656
1657 (global-extend 'core 'let
1658   (let ()
1659     (define (chi-let e r w s constructor ids vals exps)
1660       (if (not (valid-bound-ids? ids))
1661           (syntax-error e "duplicate bound variable in")
1662           (let ((labels (gen-labels ids))
1663                 (new-vars (map gen-var ids)))
1664             (let ((nw (make-binding-wrap ids labels w))
1665                   (nr (extend-var-env labels new-vars r)))
1666               (constructor s
1667                            new-vars
1668                            (map (lambda (x) (chi x r w)) vals)
1669                            (chi-body exps (source-wrap e nw s) nr nw))))))
1670     (lambda (e r w s)
1671       (syntax-case e ()
1672         ((_ ((id val) ...) e1 e2 ...)
1673          (chi-let e r w s
1674                   build-let
1675                   (syntax (id ...))
1676                   (syntax (val ...))
1677                   (syntax (e1 e2 ...))))
1678         ((_ f ((id val) ...) e1 e2 ...)
1679          (id? (syntax f))
1680          (chi-let e r w s
1681                   build-named-let
1682                   (syntax (f id ...))
1683                   (syntax (val ...))
1684                   (syntax (e1 e2 ...))))
1685         (_ (syntax-error (source-wrap e w s)))))))
1686
1687
1688 (global-extend 'core 'letrec
1689   (lambda (e r w s)
1690     (syntax-case e ()
1691       ((_ ((id val) ...) e1 e2 ...)
1692        (let ((ids (syntax (id ...))))
1693          (if (not (valid-bound-ids? ids))
1694              (syntax-error e "duplicate bound variable in")
1695              (let ((labels (gen-labels ids))
1696                    (new-vars (map gen-var ids)))
1697                (let ((w (make-binding-wrap ids labels w))
1698                     (r (extend-var-env labels new-vars r)))
1699                  (build-letrec s
1700                    new-vars
1701                    (map (lambda (x) (chi x r w)) (syntax (val ...)))
1702                    (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
1703       (_ (syntax-error (source-wrap e w s))))))
1704
1705
1706 (global-extend 'core 'set!
1707   (lambda (e r w s)
1708     (syntax-case e ()
1709       ((_ id val)
1710        (id? (syntax id))
1711        (let ((val (chi (syntax val) r w))
1712              (n (id-var-name (syntax id) w)))
1713          (let ((b (lookup n r)))
1714            (case (binding-type b)
1715              ((lexical)
1716               (build-lexical-assignment s (binding-value b) val))
1717              ((global) (build-global-assignment s n val))
1718              ((displaced-lexical)
1719               (syntax-error (wrap (syntax id) w)
1720                 "identifier out of context"))
1721              (else (syntax-error (source-wrap e w s)))))))
1722       ((_ (getter arg ...) val)
1723        (build-application s
1724                           (chi (syntax (setter getter)) r w)
1725                           (map (lambda (e) (chi e r w))
1726                                (syntax (arg ... val)))))
1727       (_ (syntax-error (source-wrap e w s))))))
1728
1729 (global-extend 'begin 'begin '())
1730
1731 (global-extend 'define 'define '())
1732
1733 (global-extend 'define-syntax 'define-syntax '())
1734
1735 (global-extend 'eval-when 'eval-when '())
1736
1737 (global-extend 'core 'syntax-case
1738   (let ()
1739     (define convert-pattern
1740       ; accepts pattern & keys
1741       ; returns syntax-dispatch pattern & ids
1742       (lambda (pattern keys)
1743         (let cvt ((p pattern) (n 0) (ids '()))
1744           (if (id? p)
1745               (if (bound-id-member? p keys)
1746                   (values (vector 'free-id p) ids)
1747                   (values 'any (cons (cons p n) ids)))
1748               (syntax-case p ()
1749                 ((x dots)
1750                  (ellipsis? (syntax dots))
1751                  (call-with-values
1752                    (lambda () (cvt (syntax x) (fx+ n 1) ids))
1753                    (lambda (p ids)
1754                      (values (if (eq? p 'any) 'each-any (vector 'each p))
1755                              ids))))
1756                 ((x . y)
1757                  (call-with-values
1758                    (lambda () (cvt (syntax y) n ids))
1759                    (lambda (y ids)
1760                      (call-with-values
1761                        (lambda () (cvt (syntax x) n ids))
1762                        (lambda (x ids)
1763                          (values (cons x y) ids))))))
1764                 (() (values '() ids))
1765                 (#(x ...)
1766                  (call-with-values
1767                    (lambda () (cvt (syntax (x ...)) n ids))
1768                    (lambda (p ids) (values (vector 'vector p) ids))))
1769                 (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
1770
1771     (define build-dispatch-call
1772       (lambda (pvars exp y r)
1773         (let ((ids (map car pvars)) (levels (map cdr pvars)))
1774           (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1775             (build-application no-source
1776               (build-primref no-source 'apply)
1777               (list (build-lambda no-source new-vars
1778                       (chi exp
1779                          (extend-env
1780                              labels
1781                              (map (lambda (var level)
1782                                     (make-binding 'syntax `(,var . ,level)))
1783                                   new-vars
1784                                   (map cdr pvars))
1785                              r)
1786                            (make-binding-wrap ids labels empty-wrap)))
1787                     y))))))
1788
1789     (define gen-clause
1790       (lambda (x keys clauses r pat fender exp)
1791         (call-with-values
1792           (lambda () (convert-pattern pat keys))
1793           (lambda (p pvars)
1794             (cond
1795               ((not (distinct-bound-ids? (map car pvars)))
1796                (syntax-error pat
1797                  "duplicate pattern variable in syntax-case pattern"))
1798               ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
1799                (syntax-error pat
1800                  "misplaced ellipsis in syntax-case pattern"))
1801               (else
1802                (let ((y (gen-var 'tmp)))
1803                  ; fat finger binding and references to temp variable y
1804                  (build-application no-source
1805                    (build-lambda no-source (list y)
1806                      (let ((y (build-lexical-reference 'value no-source y)))
1807                        (build-conditional no-source
1808                          (syntax-case fender ()
1809                            (#t y)
1810                            (_ (build-conditional no-source
1811                                 y
1812                                 (build-dispatch-call pvars fender y r)
1813                                 (build-data no-source #f))))
1814                          (build-dispatch-call pvars exp y r)
1815                          (gen-syntax-case x keys clauses r))))
1816                    (list (if (eq? p 'any)
1817                              (build-application no-source
1818                                (build-primref no-source 'list)
1819                                (list x))
1820                              (build-application no-source
1821                                (build-primref no-source 'syntax-dispatch)
1822                                (list x (build-data no-source p)))))))))))))
1823
1824     (define gen-syntax-case
1825       (lambda (x keys clauses r)
1826         (if (null? clauses)
1827             (build-application no-source
1828               (build-primref no-source 'syntax-error)
1829               (list x))
1830             (syntax-case (car clauses) ()
1831               ((pat exp)
1832                (if (and (id? (syntax pat))
1833                         (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
1834                           (cons (syntax (... ...)) keys)))
1835                    (let ((labels (list (gen-label)))
1836                          (var (gen-var (syntax pat))))
1837                      (build-application no-source
1838                        (build-lambda no-source (list var)
1839                          (chi (syntax exp)
1840                               (extend-env labels
1841                                 (list (make-binding 'syntax `(,var . 0)))
1842                                 r)
1843                               (make-binding-wrap (syntax (pat))
1844                                 labels empty-wrap)))
1845                        (list x)))
1846                    (gen-clause x keys (cdr clauses) r
1847                      (syntax pat) #t (syntax exp))))
1848               ((pat fender exp)
1849                (gen-clause x keys (cdr clauses) r
1850                  (syntax pat) (syntax fender) (syntax exp)))
1851               (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
1852
1853     (lambda (e r w s)
1854       (let ((e (source-wrap e w s)))
1855         (syntax-case e ()
1856           ((_ val (key ...) m ...)
1857            (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
1858                        (syntax (key ...)))
1859                (let ((x (gen-var 'tmp)))
1860                  ; fat finger binding and references to temp variable x
1861                  (build-application s
1862                    (build-lambda no-source (list x)
1863                      (gen-syntax-case (build-lexical-reference 'value no-source x)
1864                        (syntax (key ...)) (syntax (m ...))
1865                        r))
1866                    (list (chi (syntax val) r empty-wrap))))
1867                (syntax-error e "invalid literals list in"))))))))
1868
1869 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
1870 ;;; evaluating) and esew (which stands for "eval syntax expanders
1871 ;;; when") with '(eval).  In Chez Scheme, m is set to 'c instead of e
1872 ;;; if we are compiling a file, and esew is set to
1873 ;;; (eval-syntactic-expanders-when), which defaults to the list
1874 ;;; '(compile load eval).  This means that, by default, top-level
1875 ;;; syntactic definitions are evaluated immediately after they are
1876 ;;; expanded, and the expanded definitions are also residualized into
1877 ;;; the object file if we are compiling a file.
1878 (set! sc-expand
1879   (let ((m 'e) (esew '(eval)))
1880     (lambda (x)
1881       (if (and (pair? x) (equal? (car x) noexpand))
1882           (cadr x)
1883           (chi-top x null-env top-wrap m esew)))))
1884
1885 (set! sc-expand3
1886   (let ((m 'e) (esew '(eval)))
1887     (lambda (x . rest)
1888       (if (and (pair? x) (equal? (car x) noexpand))
1889           (cadr x)
1890           (chi-top x
1891                    null-env
1892                    top-wrap
1893                    (if (null? rest) m (car rest))
1894                    (if (or (null? rest) (null? (cdr rest)))
1895                        esew
1896                        (cadr rest)))))))
1897
1898 (set! identifier?
1899   (lambda (x)
1900     (nonsymbol-id? x)))
1901
1902 (set! datum->syntax-object
1903   (lambda (id datum)
1904     (arg-check nonsymbol-id? id 'datum->syntax-object)
1905     (make-syntax-object datum (syntax-object-wrap id))))
1906
1907 (set! syntax-object->datum
1908   ; accepts any object, since syntax objects may consist partially
1909   ; or entirely of unwrapped, nonsymbolic data
1910   (lambda (x)
1911     (strip x empty-wrap)))
1912
1913 (set! generate-temporaries
1914   (lambda (ls)
1915     (arg-check list? ls 'generate-temporaries)
1916     (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
1917
1918 (set! free-identifier=?
1919    (lambda (x y)
1920       (arg-check nonsymbol-id? x 'free-identifier=?)
1921       (arg-check nonsymbol-id? y 'free-identifier=?)
1922       (free-id=? x y)))
1923
1924 (set! bound-identifier=?
1925    (lambda (x y)
1926       (arg-check nonsymbol-id? x 'bound-identifier=?)
1927       (arg-check nonsymbol-id? y 'bound-identifier=?)
1928       (bound-id=? x y)))
1929
1930 (set! syntax-error
1931   (lambda (object . messages)
1932     (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
1933     (let ((message (if (null? messages)
1934                        "invalid syntax"
1935                        (apply string-append messages))))
1936       (error-hook #f message (strip object empty-wrap)))))
1937
1938 (set! install-global-transformer
1939   (lambda (sym v)
1940     (arg-check symbol? sym 'define-syntax)
1941     (arg-check procedure? v 'define-syntax)
1942     (global-extend 'macro sym v)))
1943
1944 ;;; syntax-dispatch expects an expression and a pattern.  If the expression
1945 ;;; matches the pattern a list of the matching expressions for each
1946 ;;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
1947 ;;; not work on r4rs implementations that violate the ieee requirement
1948 ;;; that #f and () be distinct.)
1949
1950 ;;; The expression is matched with the pattern as follows:
1951
1952 ;;; pattern:                           matches:
1953 ;;;   ()                                 empty list
1954 ;;;   any                                anything
1955 ;;;   (<pattern>1 . <pattern>2)          (<pattern>1 . <pattern>2)
1956 ;;;   each-any                           (any*)
1957 ;;;   #(free-id <key>)                   <key> with free-identifier=?
1958 ;;;   #(each <pattern>)                  (<pattern>*)
1959 ;;;   #(vector <pattern>)                (list->vector <pattern>)
1960 ;;;   #(atom <object>)                   <object> with "equal?"
1961
1962 ;;; Vector cops out to pair under assumption that vectors are rare.  If
1963 ;;; not, should convert to:
1964 ;;;   #(vector <pattern>*)               #(<pattern>*)
1965
1966 (let ()
1967
1968 (define match-each
1969   (lambda (e p w)
1970     (cond
1971       ((annotation? e)
1972        (match-each (annotation-expression e) p w))
1973       ((pair? e)
1974        (let ((first (match (car e) p w '())))
1975          (and first
1976               (let ((rest (match-each (cdr e) p w)))
1977                  (and rest (cons first rest))))))
1978       ((null? e) '())
1979       ((syntax-object? e)
1980        (match-each (syntax-object-expression e)
1981                    p
1982                    (join-wraps w (syntax-object-wrap e))))
1983       (else #f))))
1984
1985 (define match-each-any
1986   (lambda (e w)
1987     (cond
1988       ((annotation? e)
1989        (match-each-any (annotation-expression e) w))
1990       ((pair? e)
1991        (let ((l (match-each-any (cdr e) w)))
1992          (and l (cons (wrap (car e) w) l))))
1993       ((null? e) '())
1994       ((syntax-object? e)
1995        (match-each-any (syntax-object-expression e)
1996                        (join-wraps w (syntax-object-wrap e))))
1997       (else #f))))
1998
1999 (define match-empty
2000   (lambda (p r)
2001     (cond
2002       ((null? p) r)
2003       ((eq? p 'any) (cons '() r))
2004       ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2005       ((eq? p 'each-any) (cons '() r))
2006       (else
2007        (case (vector-ref p 0)
2008          ((each) (match-empty (vector-ref p 1) r))
2009          ((free-id atom) r)
2010          ((vector) (match-empty (vector-ref p 1) r)))))))
2011
2012 (define match*
2013   (lambda (e p w r)
2014     (cond
2015       ((null? p) (and (null? e) r))
2016       ((pair? p)
2017        (and (pair? e) (match (car e) (car p) w
2018                         (match (cdr e) (cdr p) w r))))
2019       ((eq? p 'each-any)
2020        (let ((l (match-each-any e w))) (and l (cons l r))))
2021       (else
2022        (case (vector-ref p 0)
2023          ((each)
2024           (if (null? e)
2025               (match-empty (vector-ref p 1) r)
2026               (let ((l (match-each e (vector-ref p 1) w)))
2027                 (and l
2028                      (let collect ((l l))
2029                        (if (null? (car l))
2030                            r
2031                            (cons (map car l) (collect (map cdr l)))))))))
2032          ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r))
2033          ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
2034          ((vector)
2035           (and (vector? e)
2036                (match (vector->list e) (vector-ref p 1) w r))))))))
2037
2038 (define match
2039   (lambda (e p w r)
2040     (cond
2041       ((not r) #f)
2042       ((eq? p 'any) (cons (wrap e w) r))
2043       ((syntax-object? e)
2044        (match*
2045          (unannotate (syntax-object-expression e))
2046          p
2047          (join-wraps w (syntax-object-wrap e))
2048          r))
2049       (else (match* (unannotate e) p w r)))))
2050
2051 (set! syntax-dispatch
2052   (lambda (e p)
2053     (cond
2054       ((eq? p 'any) (list e))
2055       ((syntax-object? e)
2056        (match* (unannotate (syntax-object-expression e))
2057          p (syntax-object-wrap e) '()))
2058       (else (match* (unannotate e) p empty-wrap '())))))
2059 ))
2060 )
2061
2062 (define-syntax with-syntax
2063    (lambda (x)
2064       (syntax-case x ()
2065          ((_ () e1 e2 ...)
2066           (syntax (begin e1 e2 ...)))
2067          ((_ ((out in)) e1 e2 ...)
2068           (syntax (syntax-case in () (out (begin e1 e2 ...)))))
2069          ((_ ((out in) ...) e1 e2 ...)
2070           (syntax (syntax-case (list in ...) ()
2071                      ((out ...) (begin e1 e2 ...))))))))
2072
2073 (define-syntax syntax-rules
2074   (lambda (x)
2075     (syntax-case x ()
2076       ((_ (k ...) ((keyword . pattern) template) ...)
2077        (syntax (lambda (x)
2078                 (syntax-case x (k ...)
2079                   ((dummy . pattern) (syntax template))
2080                   ...)))))))
2081
2082 (define-syntax let*
2083   (lambda (x)
2084     (syntax-case x ()
2085       ((let* ((x v) ...) e1 e2 ...)
2086        (andmap identifier? (syntax (x ...)))
2087        (let f ((bindings (syntax ((x v)  ...))))
2088          (if (null? bindings)
2089              (syntax (let () e1 e2 ...))
2090              (with-syntax ((body (f (cdr bindings)))
2091                            (binding (car bindings)))
2092                (syntax (let (binding) body)))))))))
2093
2094 (define-syntax do
2095    (lambda (orig-x)
2096       (syntax-case orig-x ()
2097          ((_ ((var init . step) ...) (e0 e1 ...) c ...)
2098           (with-syntax (((step ...)
2099                          (map (lambda (v s)
2100                                  (syntax-case s ()
2101                                     (() v)
2102                                     ((e) (syntax e))
2103                                     (_ (syntax-error orig-x))))
2104                               (syntax (var ...))
2105                               (syntax (step ...)))))
2106              (syntax-case (syntax (e1 ...)) ()
2107                 (() (syntax (let doloop ((var init) ...)
2108                                (if (not e0)
2109                                    (begin c ... (doloop step ...))))))
2110                 ((e1 e2 ...)
2111                  (syntax (let doloop ((var init) ...)
2112                             (if e0
2113                                 (begin e1 e2 ...)
2114                                 (begin c ... (doloop step ...))))))))))))
2115
2116 (define-syntax quasiquote
2117    (letrec
2118       ((quasicons
2119         (lambda (x y)
2120           (with-syntax ((x x) (y y))
2121             (syntax-case (syntax y) (quote list)
2122               ((quote dy)
2123                (syntax-case (syntax x) (quote)
2124                  ((quote dx) (syntax (quote (dx . dy))))
2125                  (_ (if (null? (syntax dy))
2126                         (syntax (list x))
2127                         (syntax (cons x y))))))
2128               ((list . stuff) (syntax (list x . stuff)))
2129               (else (syntax (cons x y)))))))
2130        (quasiappend
2131         (lambda (x y)
2132           (with-syntax ((x x) (y y))
2133             (syntax-case (syntax y) (quote)
2134               ((quote ()) (syntax x))
2135               (_ (syntax (append x y)))))))
2136        (quasivector
2137         (lambda (x)
2138           (with-syntax ((x x))
2139             (syntax-case (syntax x) (quote list)
2140               ((quote (x ...)) (syntax (quote #(x ...))))
2141               ((list x ...) (syntax (vector x ...)))
2142               (_ (syntax (list->vector x)))))))
2143        (quasi
2144         (lambda (p lev)
2145            (syntax-case p (unquote unquote-splicing quasiquote)
2146               ((unquote p)
2147                (if (= lev 0)
2148                    (syntax p)
2149                    (quasicons (syntax (quote unquote))
2150                               (quasi (syntax (p)) (- lev 1)))))
2151               (((unquote-splicing p) . q)
2152                (if (= lev 0)
2153                    (quasiappend (syntax p) (quasi (syntax q) lev))
2154                    (quasicons (quasicons (syntax (quote unquote-splicing))
2155                                          (quasi (syntax (p)) (- lev 1)))
2156                               (quasi (syntax q) lev))))
2157               ((quasiquote p)
2158                (quasicons (syntax (quote quasiquote))
2159                           (quasi (syntax (p)) (+ lev 1))))
2160               ((p . q)
2161                (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
2162               (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
2163               (p (syntax (quote p)))))))
2164     (lambda (x)
2165        (syntax-case x ()
2166           ((_ e) (quasi (syntax e) 0))))))
2167
2168 (define-syntax include
2169   (lambda (x)
2170     (define read-file
2171       (lambda (fn k)
2172         (let ((p (open-input-file fn)))
2173           (let f ((x (read p)))
2174             (if (eof-object? x)
2175                 (begin (close-input-port p) '())
2176                 (cons (datum->syntax-object k x)
2177                       (f (read p))))))))
2178     (syntax-case x ()
2179       ((k filename)
2180        (let ((fn (syntax-object->datum (syntax filename))))
2181          (with-syntax (((exp ...) (read-file fn (syntax k))))
2182            (syntax (begin exp ...))))))))
2183
2184 (define-syntax unquote
2185    (lambda (x)
2186       (syntax-case x ()
2187          ((_ e)
2188           (error 'unquote
2189                  "expression ,~s not valid outside of quasiquote"
2190                  (syntax-object->datum (syntax e)))))))
2191
2192 (define-syntax unquote-splicing
2193    (lambda (x)
2194       (syntax-case x ()
2195          ((_ e)
2196           (error 'unquote-splicing
2197                  "expression ,@~s not valid outside of quasiquote"
2198                  (syntax-object->datum (syntax e)))))))
2199
2200 (define-syntax case
2201   (lambda (x)
2202     (syntax-case x ()
2203       ((_ e m1 m2 ...)
2204        (with-syntax
2205          ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
2206                   (if (null? clauses)
2207                       (syntax-case clause (else)
2208                         ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
2209                         (((k ...) e1 e2 ...)
2210                          (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
2211                         (_ (syntax-error x)))
2212                       (with-syntax ((rest (f (car clauses) (cdr clauses))))
2213                         (syntax-case clause (else)
2214                           (((k ...) e1 e2 ...)
2215                            (syntax (if (memv t '(k ...))
2216                                        (begin e1 e2 ...)
2217                                        rest)))
2218                           (_ (syntax-error x))))))))
2219          (syntax (let ((t e)) body)))))))
2220
2221 (define-syntax identifier-syntax
2222   (lambda (x)
2223     (syntax-case x ()
2224       ((_ e)
2225        (syntax
2226          (lambda (x)
2227            (syntax-case x ()
2228              (id
2229               (identifier? (syntax id))
2230               (syntax e))
2231              ((_ x (... ...))
2232               (syntax (e x (... ...)))))))))))
2233