module/slib/synclo.scm

   1 ;;; "synclo.scm" Syntactic Closures             -*-Scheme-*-
   2 ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
   3 ;;;
   4 ;;; This material was developed by the Scheme project at the
   5 ;;; Massachusetts Institute of Technology, Department of Electrical
   6 ;;; Engineering and Computer Science.  Permission to copy this
   7 ;;; software, to redistribute it, and to use it for any purpose is
   8 ;;; granted, subject to the following restrictions and understandings.
   9 ;;;
  10 ;;; 1. Any copy made of this software must include this copyright
  11 ;;; notice in full.
  12 ;;;
  13 ;;; 2. Users of this software agree to make their best efforts (a) to
  14 ;;; return to the MIT Scheme project any improvements or extensions
  15 ;;; that they make, so that these may be included in future releases;
  16 ;;; and (b) to inform MIT of noteworthy uses of this software.
  17 ;;;
  18 ;;; 3. All materials developed as a consequence of the use of this
  19 ;;; software shall duly acknowledge such use, in accordance with the
  20 ;;; usual standards of acknowledging credit in academic research.
  21 ;;;
  22 ;;; 4. MIT has made no warrantee or representation that the operation
  23 ;;; of this software will be error-free, and MIT is under no
  24 ;;; obligation to provide any services, by way of maintenance, update,
  25 ;;; or otherwise.
  26 ;;;
  27 ;;; 5. In conjunction with products arising from the use of this
  28 ;;; material, there shall be no use of the name of the Massachusetts
  29 ;;; Institute of Technology nor of any adaptation thereof in any
  30 ;;; advertising, promotional, or sales literature without prior
  31 ;;; written consent from MIT in each case.
  32
  33 ;;;; Syntactic Closures
  34 ;;; written by Alan Bawden
  35 ;;; extensively modified by Chris Hanson
  36
  37 ;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
  38 ;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
  39 ;;; Programming, page 86.
  40
  41 ;;;; Classifier
  42 ;;;  The classifier maps forms into items.  In addition to locating
  43 ;;;  definitions so that they can be properly processed, it also
  44 ;;;  identifies keywords and variables, which allows a powerful form
  45 ;;;  of syntactic binding to be implemented.
  46
  47 (define (classify/form form environment definition-environment)
  48   (cond ((identifier? form)
  49          (syntactic-environment/lookup environment form))
  50         ((syntactic-closure? form)
  51          (let ((form (syntactic-closure/form form))
  52                (environment
  53                 (filter-syntactic-environment
  54                  (syntactic-closure/free-names form)
  55                  environment
  56                  (syntactic-closure/environment form))))
  57            (classify/form form
  58                           environment
  59                           definition-environment)))
  60         ((pair? form)
  61          (let ((item
  62                 (classify/subexpression (car form) environment)))
  63            (cond ((keyword-item? item)
  64                   ((keyword-item/classifier item) form
  65                                                   environment
  66                                                   definition-environment))
  67                  ((list? (cdr form))
  68                   (let ((items
  69                          (classify/subexpressions (cdr form)
  70                                                   environment)))
  71                     (make-expression-item
  72                      (lambda ()
  73                        (output/combination
  74                         (compile-item/expression item)
  75                         (map compile-item/expression items)))
  76                      form)))
  77                  (else
  78                   (syntax-error "combination must be a proper list"
  79                                 form)))))
  80         (else
  81          (make-expression-item ;don't quote literals evaluating to themselves
  82            (if (or (boolean? form) (char? form) (number? form) (string? form))
  83                (lambda () (output/literal-unquoted form))
  84                (lambda () (output/literal-quoted form))) form))))
  85
  86 (define (classify/subform form environment definition-environment)
  87   (classify/form form
  88                  environment
  89                  definition-environment))
  90
  91 (define (classify/subforms forms environment definition-environment)
  92   (map (lambda (form)
  93          (classify/subform form environment definition-environment))
  94        forms))
  95
  96 (define (classify/subexpression expression environment)
  97   (classify/subform expression environment environment))
  98
  99 (define (classify/subexpressions expressions environment)
 100   (classify/subforms expressions environment environment))
 101
 102 ;;;; Compiler
 103 ;;;  The compiler maps items into the output language.
 104
 105 (define (compile-item/expression item)
 106   (let ((illegal
 107          (lambda (item name)
 108            (let ((decompiled (decompile-item item))) (newline)
 109            (slib:error (string-append name
 110                                         " may not be used as an expression")
 111                          decompiled)))))
 112     (cond ((variable-item? item)
 113            (output/variable (variable-item/name item)))
 114           ((expression-item? item)
 115            ((expression-item/compiler item)))
 116           ((body-item? item)
 117            (let ((items (flatten-body-items (body-item/components item))))
 118              (if (null? items)
 119                  (illegal item "empty sequence")
 120                  (output/sequence (map compile-item/expression items)))))
 121           ((definition-item? item)
 122            (let ((binding ;allows later scheme errors, but allows top-level
 123                   (bind-definition-item! ;(if (not (defined? x)) define it)
 124                    scheme-syntactic-environment item))) ;as in Init.scm
 125              (output/top-level-definition
 126               (car binding)
 127               (compile-item/expression (cdr binding)))))
 128           ((keyword-item? item)
 129            (illegal item "keyword"))
 130           (else
 131            (impl-error "unknown item" item)))))
 132
 133 (define (compile/subexpression expression environment)
 134   (compile-item/expression
 135    (classify/subexpression expression environment)))
 136
 137 (define (compile/top-level forms environment)
 138   ;; Top-level syntactic definitions affect all forms that appear
 139   ;; after them.
 140   (output/top-level-sequence
 141    (let forms-loop ((forms forms))
 142      (if (null? forms)
 143          '()
 144          (let items-loop
 145              ((items
 146                (item->list
 147                 (classify/subform (car forms)
 148                                   environment
 149                                   environment))))
 150            (cond ((null? items)
 151                   (forms-loop (cdr forms)))
 152                  ((definition-item? (car items))
 153                   (let ((binding
 154                          (bind-definition-item! environment (car items))))
 155                     (if binding
 156                         (cons (output/top-level-definition
 157                                (car binding)
 158                                (compile-item/expression (cdr binding)))
 159                               (items-loop (cdr items)))
 160                         (items-loop (cdr items)))))
 161                  (else
 162                   (cons (compile-item/expression (car items))
 163                         (items-loop (cdr items))))))))))
 164
 165 ;;;; De-Compiler
 166 ;;;  The de-compiler maps partly-compiled things back to the input language,
 167 ;;;  as far as possible.  Used to display more meaningful macro error messages.
 168
 169 (define (decompile-item item)
 170     (display " ")
 171     (cond ((variable-item? item) (variable-item/name item))
 172           ((expression-item? item)
 173            (decompile-item (expression-item/annotation item)))
 174           ((body-item? item)
 175            (let ((items (flatten-body-items (body-item/components item))))
 176              (display "sequence")
 177              (if (null? items)
 178                  "empty sequence"
 179                  "non-empty sequence")))
 180           ((definition-item? item) "definition")
 181           ((keyword-item? item)
 182            (decompile-item (keyword-item/name item)));in case expression
 183           ((syntactic-closure? item); (display "syntactic-closure;")
 184            (decompile-item (syntactic-closure/form item)))
 185           ((list? item) (display "(")
 186                 (map decompile-item item) (display ")") "see list above")
 187           ((string? item) item);explicit name-string for keyword-item
 188           ((symbol? item) (display item) item) ;symbol for syntactic-closures
 189           ((boolean? item) (display item) item) ;symbol for syntactic-closures
 190           (else (write item) (impl-error "unknown item" item))))
 191
 192 ;;;; Syntactic Closures
 193
 194 (define syntactic-closure-type
 195   (make-record-type "syntactic-closure" '(ENVIRONMENT FREE-NAMES FORM)))
 196
 197 (define make-syntactic-closure
 198   (record-constructor syntactic-closure-type '(ENVIRONMENT FREE-NAMES FORM)))
 199
 200 (define syntactic-closure?
 201   (record-predicate syntactic-closure-type))
 202
 203 (define syntactic-closure/environment
 204   (record-accessor syntactic-closure-type 'ENVIRONMENT))
 205
 206 (define syntactic-closure/free-names
 207   (record-accessor syntactic-closure-type 'FREE-NAMES))
 208
 209 (define syntactic-closure/form
 210   (record-accessor syntactic-closure-type 'FORM))
 211
 212 (define (make-syntactic-closure-list environment free-names forms)
 213   (map (lambda (form) (make-syntactic-closure environment free-names form))
 214        forms))
 215
 216 (define (strip-syntactic-closures object)
 217   (cond ((syntactic-closure? object)
 218          (strip-syntactic-closures (syntactic-closure/form object)))
 219         ((pair? object)
 220          (cons (strip-syntactic-closures (car object))
 221                (strip-syntactic-closures (cdr object))))
 222         ((vector? object)
 223          (let ((length (vector-length object)))
 224            (let ((result (make-vector length)))
 225              (do ((i 0 (+ i 1)))
 226                  ((= i length))
 227                (vector-set! result i
 228                             (strip-syntactic-closures (vector-ref object i))))
 229              result)))
 230         (else
 231          object)))
 232
 233 (define (identifier? object)
 234   (or (symbol? object)
 235       (synthetic-identifier? object)))
 236
 237 (define (synthetic-identifier? object)
 238   (and (syntactic-closure? object)
 239        (identifier? (syntactic-closure/form object))))
 240
 241 (define (identifier->symbol identifier)
 242   (cond ((symbol? identifier)
 243          identifier)
 244         ((synthetic-identifier? identifier)
 245          (identifier->symbol (syntactic-closure/form identifier)))
 246         (else
 247          (impl-error "not an identifier" identifier))))
 248
 249 (define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
 250   (let ((item-1 (syntactic-environment/lookup environment-1 identifier-1))
 251         (item-2 (syntactic-environment/lookup environment-2 identifier-2)))
 252     (or (eq? item-1 item-2)
 253         ;; This is necessary because an identifier that is not
 254         ;; explicitly bound by an environment is mapped to a variable
 255         ;; item, and the variable items are not cached.  Therefore
 256         ;; two references to the same variable result in two
 257         ;; different variable items.
 258         (and (variable-item? item-1)
 259              (variable-item? item-2)
 260              (eq? (variable-item/name item-1)
 261                   (variable-item/name item-2))))))
 262
 263 ;;;; Syntactic Environments
 264
 265 (define syntactic-environment-type
 266   (make-record-type
 267    "syntactic-environment"
 268    '(PARENT
 269      LOOKUP-OPERATION
 270      RENAME-OPERATION
 271      DEFINE-OPERATION
 272      BINDINGS-OPERATION)))
 273
 274 (define make-syntactic-environment
 275   (record-constructor syntactic-environment-type
 276                       '(PARENT
 277                         LOOKUP-OPERATION
 278                         RENAME-OPERATION
 279                         DEFINE-OPERATION
 280                         BINDINGS-OPERATION)))
 281
 282 (define syntactic-environment?
 283   (record-predicate syntactic-environment-type))
 284
 285 (define syntactic-environment/parent
 286   (record-accessor syntactic-environment-type 'PARENT))
 287
 288 (define syntactic-environment/lookup-operation
 289   (record-accessor syntactic-environment-type 'LOOKUP-OPERATION))
 290
 291 (define (syntactic-environment/assign! environment name item)
 292   (let ((binding
 293          ((syntactic-environment/lookup-operation environment) name)))
 294     (if binding
 295         (set-cdr! binding item)
 296         (impl-error "can't assign unbound identifier" name))))
 297
 298 (define syntactic-environment/rename-operation
 299   (record-accessor syntactic-environment-type 'RENAME-OPERATION))
 300
 301 (define (syntactic-environment/rename environment name)
 302   ((syntactic-environment/rename-operation environment) name))
 303
 304 (define syntactic-environment/define!
 305   (let ((accessor
 306          (record-accessor syntactic-environment-type 'DEFINE-OPERATION)))
 307     (lambda (environment name item)
 308       ((accessor environment) name item))))
 309
 310 (define syntactic-environment/bindings
 311   (let ((accessor
 312          (record-accessor syntactic-environment-type 'BINDINGS-OPERATION)))
 313     (lambda (environment)
 314       ((accessor environment)))))
 315
 316 (define (syntactic-environment/lookup environment name)
 317   (let ((binding
 318          ((syntactic-environment/lookup-operation environment) name)))
 319     (cond (binding
 320            (let ((item (cdr binding)))
 321              (if (reserved-name-item? item)
 322                  (syntax-error "premature reference to reserved name"
 323                                name)
 324                  item)))
 325           ((symbol? name)
 326            (make-variable-item name))
 327           ((synthetic-identifier? name)
 328            (syntactic-environment/lookup (syntactic-closure/environment name)
 329                                          (syntactic-closure/form name)))
 330           (else
 331            (impl-error "not an identifier" name)))))
 332
 333 (define root-syntactic-environment
 334   (make-syntactic-environment
 335    #f
 336    (lambda (name)
 337      name
 338      #f)
 339    (lambda (name)
 340      name)
 341    (lambda (name item)
 342      (impl-error "can't bind name in root syntactic environment" name item))
 343    (lambda ()
 344      '())))
 345
 346 (define null-syntactic-environment
 347   (make-syntactic-environment
 348    #f
 349    (lambda (name)
 350      (impl-error "can't lookup name in null syntactic environment" name))
 351    (lambda (name)
 352      (impl-error "can't rename name in null syntactic environment" name))
 353    (lambda (name item)
 354      (impl-error "can't bind name in null syntactic environment" name item))
 355    (lambda ()
 356      '())))
 357
 358 (define (top-level-syntactic-environment parent)
 359   (let ((bound '()))
 360     (make-syntactic-environment
 361      parent
 362      (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
 363        (lambda (name)
 364          (or (assq name bound)
 365              (parent-lookup name))))
 366      (lambda (name)
 367        name)
 368      (lambda (name item)
 369        (let ((binding (assq name bound)))
 370          (if binding
 371              (set-cdr! binding item)
 372              (set! bound (cons (cons name item) bound)))))
 373      (lambda ()
 374        (map (lambda (pair) (cons (car pair) (cdr pair))) bound)))))
 375
 376 (define (internal-syntactic-environment parent)
 377   (let ((bound '())
 378         (free '()))
 379     (make-syntactic-environment
 380      parent
 381      (let ((parent-lookup (syntactic-environment/lookup-operation parent)))
 382        (lambda (name)
 383          (or (assq name bound)
 384              (assq name free)
 385              (let ((binding (parent-lookup name)))
 386                (if binding (set! free (cons binding free)))
 387                binding))))
 388      (make-name-generator)
 389      (lambda (name item)
 390        (cond ((assq name bound)
 391               =>
 392               (lambda (association)
 393                 (if (and (reserved-name-item? (cdr association))
 394                          (not (reserved-name-item? item)))
 395                     (set-cdr! association item)
 396                     (impl-error "can't redefine name; already bound" name))))
 397              ((assq name free)
 398               (if (reserved-name-item? item)
 399                   (syntax-error "premature reference to reserved name"
 400                                 name)
 401                   (impl-error "can't define name; already free" name)))
 402              (else
 403               (set! bound (cons (cons name item) bound)))))
 404      (lambda ()
 405        (map (lambda (pair) (cons (car pair) (cdr pair))) bound)))))
 406
 407 (define (filter-syntactic-environment names names-env else-env)
 408   (if (or (null? names)
 409           (eq? names-env else-env))
 410       else-env
 411       (let ((make-operation
 412              (lambda (get-operation)
 413                (let ((names-operation (get-operation names-env))
 414                      (else-operation (get-operation else-env)))
 415                  (lambda (name)
 416                    ((if (memq name names) names-operation else-operation)
 417                     name))))))
 418         (make-syntactic-environment
 419          else-env
 420          (make-operation syntactic-environment/lookup-operation)
 421          (make-operation syntactic-environment/rename-operation)
 422          (lambda (name item)
 423            (impl-error "can't bind name in filtered syntactic environment"
 424                        name item))
 425          (lambda ()
 426            (map (lambda (name)
 427                   (cons name
 428                         (syntactic-environment/lookup names-env name)))
 429                 names))))))
 430
 431 ;;;; Items
 432
 433 ;;; Reserved name items do not represent any form, but instead are
 434 ;;; used to reserve a particular name in a syntactic environment.  If
 435 ;;; the classifier refers to a reserved name, a syntax error is
 436 ;;; signalled.  This is used in the implementation of LETREC-SYNTAX
 437 ;;; to signal a meaningful error when one of the <init>s refers to
 438 ;;; one of the names being bound.
 439
 440 (define reserved-name-item-type
 441   (make-record-type "reserved-name-item" '()))
 442
 443 (define make-reserved-name-item
 444   (record-constructor reserved-name-item-type)) ; '()
 445
 446 (define reserved-name-item?
 447   (record-predicate reserved-name-item-type))
 448
 449 ;;; Keyword items represent macro keywords.
 450
 451 (define keyword-item-type
 452   (make-record-type "keyword-item" '(CLASSIFIER NAME)))
 453 ;  (make-record-type "keyword-item" '(CLASSIFIER)))
 454
 455 (define make-keyword-item
 456 ;  (lambda (cl) (display "make-keyword-item:") (write cl) (newline)
 457 ;       ((record-constructor keyword-item-type '(CLASSIFIER)) cl)))
 458   (record-constructor keyword-item-type '(CLASSIFIER NAME)))
 459 ;  (record-constructor keyword-item-type '(CLASSIFIER)))
 460
 461 (define keyword-item?
 462   (record-predicate keyword-item-type))
 463
 464 (define keyword-item/classifier
 465   (record-accessor keyword-item-type 'CLASSIFIER))
 466
 467 (define keyword-item/name
 468   (record-accessor keyword-item-type 'NAME))
 469
 470 ;;; Variable items represent run-time variables.
 471
 472 (define variable-item-type
 473   (make-record-type "variable-item" '(NAME)))
 474
 475 (define make-variable-item
 476   (record-constructor variable-item-type '(NAME)))
 477
 478 (define variable-item?
 479   (record-predicate variable-item-type))
 480
 481 (define variable-item/name
 482   (record-accessor variable-item-type 'NAME))
 483
 484 ;;; Expression items represent any kind of expression other than a
 485 ;;; run-time variable or a sequence.  The ANNOTATION field is used to
 486 ;;; make expression items that can appear in non-expression contexts
 487 ;;; (for example, this could be used in the implementation of SETF).
 488
 489 (define expression-item-type
 490   (make-record-type "expression-item" '(COMPILER ANNOTATION)))
 491
 492 (define make-expression-item
 493   (record-constructor expression-item-type '(COMPILER ANNOTATION)))
 494
 495 (define expression-item?
 496   (record-predicate expression-item-type))
 497
 498 (define expression-item/compiler
 499   (record-accessor expression-item-type 'COMPILER))
 500
 501 (define expression-item/annotation
 502   (record-accessor expression-item-type 'ANNOTATION))
 503
 504 ;;; Body items represent sequences (e.g. BEGIN).
 505
 506 (define body-item-type
 507   (make-record-type "body-item" '(COMPONENTS)))
 508
 509 (define make-body-item
 510   (record-constructor body-item-type '(COMPONENTS)))
 511
 512 (define body-item?
 513   (record-predicate body-item-type))
 514
 515 (define body-item/components
 516   (record-accessor body-item-type 'COMPONENTS))
 517
 518 ;;; Definition items represent definitions, whether top-level or
 519 ;;; internal, keyword or variable.
 520
 521 (define definition-item-type
 522   (make-record-type "definition-item" '(BINDING-THEORY NAME VALUE)))
 523
 524 (define make-definition-item
 525   (record-constructor definition-item-type '(BINDING-THEORY NAME VALUE)))
 526
 527 (define definition-item?
 528   (record-predicate definition-item-type))
 529
 530 (define definition-item/binding-theory
 531   (record-accessor definition-item-type 'BINDING-THEORY))
 532
 533 (define definition-item/name
 534   (record-accessor definition-item-type 'NAME))
 535
 536 (define definition-item/value
 537   (record-accessor definition-item-type 'VALUE))
 538
 539 (define (bind-definition-item! environment item)
 540   ((definition-item/binding-theory item)
 541    environment
 542    (definition-item/name item)
 543    (promise:force (definition-item/value item))))
 544
 545 (define (syntactic-binding-theory environment name item)
 546   (if (or (keyword-item? item)
 547           (variable-item? item))
 548       (begin
 549         (syntactic-environment/define! environment name item)
 550         #f)
 551       (syntax-error "syntactic binding value must be a keyword or a variable"
 552                     item)))
 553
 554 (define (variable-binding-theory environment name item)
 555   ;; If ITEM isn't a valid expression, an error will be signalled by
 556   ;; COMPILE-ITEM/EXPRESSION later.
 557   (cons (bind-variable! environment name) item))
 558
 559 (define (overloaded-binding-theory environment name item)
 560   (if (keyword-item? item)
 561       (begin
 562         (syntactic-environment/define! environment name item)
 563         #f)
 564       (cons (bind-variable! environment name) item)))
 565
 566 ;;;; Classifiers, Compilers, Expanders
 567
 568 (define (sc-expander->classifier expander keyword-environment)
 569   (lambda (form environment definition-environment)
 570     (classify/form (expander form environment)
 571                    keyword-environment
 572                    definition-environment)))
 573
 574 (define (er-expander->classifier expander keyword-environment)
 575   (sc-expander->classifier (er->sc-expander expander) keyword-environment))
 576
 577 (define (er->sc-expander expander)
 578   (lambda (form environment)
 579     (capture-syntactic-environment
 580      (lambda (keyword-environment)
 581        (make-syntactic-closure
 582         environment '()
 583         (expander form
 584                   (let ((renames '()))
 585                     (lambda (identifier)
 586                       (let ((association (assq identifier renames)))
 587                         (if association
 588                             (cdr association)
 589                             (let ((rename
 590                                    (make-syntactic-closure
 591                                     keyword-environment
 592                                     '()
 593                                     identifier)))
 594                               (set! renames
 595                                     (cons (cons identifier rename)
 596                                           renames))
 597                               rename)))))
 598                   (lambda (x y)
 599                     (identifier=? environment x
 600                                   environment y))))))))
 601
 602 (define (classifier->keyword classifier)
 603   (make-syntactic-closure
 604    (let ((environment
 605           (internal-syntactic-environment null-syntactic-environment)))
 606      (syntactic-environment/define! environment
 607                                     'KEYWORD
 608                                     (make-keyword-item classifier "c->k"))
 609      environment)
 610    '()
 611    'KEYWORD))
 612
 613 (define (compiler->keyword compiler)
 614   (classifier->keyword (compiler->classifier compiler)))
 615
 616 (define (classifier->form classifier)
 617   `(,(classifier->keyword classifier)))
 618
 619 (define (compiler->form compiler)
 620   (classifier->form (compiler->classifier compiler)))
 621
 622 (define (compiler->classifier compiler)
 623   (lambda (form environment definition-environment)
 624     definition-environment              ;ignore
 625     (make-expression-item
 626      (lambda () (compiler form environment)) form)))
 627
 628 ;;;; Macrologies
 629 ;;;  A macrology is a procedure that accepts a syntactic environment
 630 ;;;  as an argument, producing a new syntactic environment that is an
 631 ;;;  extension of the argument.
 632
 633 (define (make-primitive-macrology generate-definitions)
 634   (lambda (base-environment)
 635     (let ((environment (top-level-syntactic-environment base-environment)))
 636       (let ((define-classifier
 637               (lambda (keyword classifier)
 638                 (syntactic-environment/define!
 639                  environment
 640                  keyword
 641                  (make-keyword-item classifier keyword)))))
 642         (generate-definitions
 643          define-classifier
 644          (lambda (keyword compiler)
 645            (define-classifier keyword (compiler->classifier compiler)))))
 646       environment)))
 647
 648 (define (make-expander-macrology object->classifier generate-definitions)
 649   (lambda (base-environment)
 650     (let ((environment (top-level-syntactic-environment base-environment)))
 651       (generate-definitions
 652        (lambda (keyword object)
 653          (syntactic-environment/define!
 654           environment
 655           keyword
 656           (make-keyword-item (object->classifier object environment) keyword)))
 657        base-environment)
 658       environment)))
 659
 660 (define (make-sc-expander-macrology generate-definitions)
 661   (make-expander-macrology sc-expander->classifier generate-definitions))
 662
 663 (define (make-er-expander-macrology generate-definitions)
 664   (make-expander-macrology er-expander->classifier generate-definitions))
 665
 666 (define (compose-macrologies . macrologies)
 667   (lambda (environment)
 668     (do ((macrologies macrologies (cdr macrologies))
 669          (environment environment ((car macrologies) environment)))
 670         ((null? macrologies) environment))))
 671
 672 ;;;; Utilities
 673
 674 (define (bind-variable! environment name)
 675   (let ((rename (syntactic-environment/rename environment name)))
 676     (syntactic-environment/define! environment
 677                                    name
 678                                    (make-variable-item rename))
 679     rename))
 680
 681 (define (reserve-names! names environment)
 682   (let ((item (make-reserved-name-item)))
 683     (for-each (lambda (name)
 684                 (syntactic-environment/define! environment name item))
 685               names)))
 686
 687 (define (capture-syntactic-environment expander)
 688   (classifier->form
 689    (lambda (form environment definition-environment)
 690      form                               ;ignore
 691      (classify/form (expander environment)
 692                     environment
 693                     definition-environment))))
 694
 695 (define (unspecific-expression)
 696   (compiler->form
 697    (lambda (form environment)
 698      form environment                   ;ignore
 699      (output/unspecific))))
 700
 701 (define (unassigned-expression)
 702   (compiler->form
 703    (lambda (form environment)
 704      form environment                   ;ignore
 705      (output/unassigned))))
 706
 707 (define (syntax-quote expression)
 708   `(,(compiler->keyword
 709       (lambda (form environment)
 710         environment                     ;ignore
 711         (syntax-check '(KEYWORD DATUM) form)
 712         (output/literal-quoted (cadr form))))
 713     ,expression))
 714
 715 (define (flatten-body-items items)
 716   (append-map item->list items))
 717
 718 (define (item->list item)
 719   (if (body-item? item)
 720       (flatten-body-items (body-item/components item))
 721       (list item)))
 722
 723 (define (output/let names values body)
 724   (if (null? names)
 725       body
 726       (output/combination (output/lambda names body) values)))
 727
 728 (define (output/letrec names values body)
 729   (if (null? names)
 730       body
 731       (output/let
 732        names
 733        (map (lambda (name) name (output/unassigned)) names)
 734        (output/sequence
 735         (list (if (null? (cdr names))
 736                   (output/assignment (car names) (car values))
 737                   (let ((temps (map (make-name-generator) names)))
 738                     (output/let
 739                      temps
 740                      values
 741                      (output/sequence
 742                       (map output/assignment names temps)))))
 743               body)))))
 744
 745 (define (output/top-level-sequence expressions)
 746   (if (null? expressions)
 747       (output/unspecific)
 748       (output/sequence expressions)))