module/ice-9/psyntax.scm

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