module/ice-9/psyntax.scm

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