module/ice-9/psyntax.scm

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