home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / synclo < prev    next >
Text File  |  1994-05-25  |  24KB  |  749 lines
  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.        (alist-copy 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.        (alist-copy 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)))
  749.