guile18/ice-9/psyntax.ss

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