module/ice-9/psyntax.scm

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