(herald (synclo load))                                      ; -*- T -*-

;;;;;; Syntactic closures for T
;;;;;; Loading & compiling the system

;;; Taylor Campbell wrote this code; he places it in the public domain.

;;; Before loading this file, set a logical name for SYNCLO to this
;;; directory.  Then use (COMPILE-SYNTACTIC-CLOSURES) to compile the
;;; system, if you so desire.  To load the syntactic closures system,
;;; either run (LOAD-SIMPLE-SYNTACTIC-CLOSURES [<compile?>]) -- where
;;; COMPILE? is a flag specifying whether or not to first compile
;;; simple.t --, if you want to have the expander generate simple
;;; S-expressions; or create your own locale that defines all of the
;;; identifiers in SYNTACTIC-CLOSURES-OUTPUT-INTERFACE (see simple.t
;;; for an example) and run (LOAD-SYNTACTIC-CLOSURES <output-locale>),
;;; if you want customized output.

(block

;;; These definitions are wrapped in a block so as not to make the
;;; loader print out all of the long lists.

(define syntactic-closures-files
        '(synclo
          expand
          std))

(define syntactic-closures-output-interface
        '(output/sequence
          output/definition
          output/combination
          output/literal
          output/local-reference
          output/top-level-reference
          output/free-reference
          output/local-assignment
          output/top-level-assignment
          output/free-assignment
          output/local-var-locative
          output/top-level-var-locative
          output/free-var-locative
          output/lambda
          output/named-lambda
          output/object
          output/labels
          output/conditional
          output/undefined-conditional-value
          output/unassigned-initializer
          rename-identifiers
          rename-top-level-identifier
          self-evaluating?
          post-process-syntax-output))

;;; There are many more exports here than what Hanson describes in his
;;; 1991 syntactic closures proposal.  These are the ones that neither
;;; are described in the paper nor have obvious meaning:
;;;
;;; (SYNTAX <form> <env>)
;;; (SYNTAX* <forms> <env>)
;;;   Entry points to the syntax expander.  SYNTAX expands one form;
;;;   SYNTAX*, several.  The forms are considered to be top-level
;;;   forms if ENV is a top-level syntactic environment, so definitions
;;;   & syntax definitions will take effect.  (These procedures' names
;;;   come from MIT Scheme.  EXPAND-TOP might be a better name.)
;;;
;;; (WITH-SYNTACTIC-TOWER <tower> <procedure>)
;;; (WITH-SIMPLE-SYNTACTIC-TOWER <locale> <procedure>)
;;;   The syntactic tower is a lazy stream (odd, not even) of unary
;;;   procedures used to evaluate the transformer expressions on the
;;;   right-hand sides of syntactic binding forms (LETREC-SYNTAX,
;;;   DEFINE-SYNTAX, & LET-SYNTAX).  WITH-SYNTACTIC-TOWER binds the
;;;   current syntactic tower to TOWER for the duration of a call to
;;;   PROCEDURE; WITH-SIMPLE-SYNTACTIC-TOWER binds a syntactic tower
;;;   composed entirely of procedures that will evaluate expressions in
;;;   LOCALE for the duration of a call to PROCEDURE.
;;;
;;; (INSTALL-STANDARD-KEYWORDS <syntactic-env>)
;;;   Installs all of the standard special form & transformer keywords
;;;   into SYNTACTIC-ENV.
;;;
;;; (CLOSE-SYNTAX <form> <env>)
;;;   Equivalent to (MAKE-SYNTACTIC-CLOSURE <env> '() <form>).  This
;;;   exists purely for convenience.
;;;
;;; (STRIP-SYNTACTIC-CLOSURES <form>)
;;;   Returns FORM, with all syntactic closure information stripped.
;;;   Useful for generating readable output.
;;;
;;; (MAKE-TOP-LEVEL-SYNTACTIC-ENV <locale>)
;;; (MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT <locale>)
;;;   Constructs a top-level syntactic environment, suitable for
;;;   passing to SYNTAX, SYNTAX*, or INSTALL-STANDARD-KEYWORDS.
;;;
;;; (SYNTHETIC-IDENTIFIER? <form>)
;;;   This is like IDENTIFIER?, but it will return false if FORM is a
;;;   simple symbol.
;;;
;;; (MAKE-SYNTHETIC-IDENTIFIER <id>)
;;;   Closes ID in a null syntactic environment.
;;;
;;; (IDENTIFIER->SYMBOL <id>)
;;;   Returns the symbol for ID, which is possibly wrapped in a number
;;;   of syntactic closures.  This signals an error if ID id not an
;;;   identifier (which is why to use it, not STRIP-SYNTACTIC-CLOSURES,
;;;   for identifiers).

(define syntactic-closures-exports
        '(syntax
          syntax*
          with-syntactic-tower
          with-simple-syntactic-tower
          install-standard-keywords
          make-syntactic-closure
          close-syntax
          syntactic-closure?
          strip-syntactic-closures
          make-top-level-syntactic-env
          make-top-level-syntactic-environment
          capture-syntactic-env
          capture-syntactic-environment
          syntactic-env?
          syntactic-environment?
          identifier?
          synthetic-identifier?
          make-synthetic-identifier
          identifier->symbol
          identifier=?))

nil)                                    ; End of the block

(define (load-syntactic-closures syntax-output-env)
  (let ((synclo-env (make-locale standard-env
                                 'syntactic-closures-env)))
    (*define standard-env 'syntactic-closures-env synclo-env)
    (*define synclo-env 'env-lookup     ; Used by top-level envs.
             (*value t-implementation-env 'env-lookup))
    (walk (lambda (output-id)
            (*define synclo-env output-id
                     (*value syntax-output-env output-id)))
          syntactic-closures-output-interface)
    (walk (lambda (file)
            (load `(synclo ,file) synclo-env))
          syntactic-closures-files)
    (walk (lambda (id)
            (*define standard-env id (*value synclo-env id)))
          syntactic-closures-exports)))

(define (load-simple-syntactic-closures . compile?)
  (if (car compile?)                    ; Bloody (CAR '()) = #F & lack
      (compile-file '(synclo simple)))  ;   of real optional arguments.
  (let ((output-env (make-locale standard-env 'syntax-output-env)))
    (load '(synclo simple) output-env)
    (load-syntactic-closures output-env)))

(define (compile-syntactic-closures)
  (walk (lambda (file)
          (compile-file `(synclo ,file)))
        syntactic-closures-files))

;;; Make the loader print something nice when done, not #{Procedure xx
;;; COMPILE-SYNTACTIC-CLOSURES}.

'syntactic-closures