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

;;;;;; Syntactic closures for T
;;;;;; Definitions for syntactic closures & environments

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

;;; Syntactic closures themselves

(define-structure-type %syntactic-closure
  env
  free
  form
  (((print self port)
    (format port "#{Syntactic-closure~_~S~_~S~_~S}"
            (object-hash self)
            (syntactic-closure-env  self)
            (syntactic-closure-free self)))))

(define-constant syntactic-closure? %syntactic-closure?)

;;; These are defined as integrable wrappers, not constant aliases, so
;;; that the setter disappears, because they shouldn't be settable.

(define-integrable (syntactic-closure-env s)
  (%syntactic-closure-env s))

(define-integrable (syntactic-closure-free s)
  (%syntactic-closure-free s))

(define-integrable (syntactic-closure-form s)
  (%syntactic-closure-form s))

(define-integrable (%make-syntactic-closure env free form)
  (let ((synclosure (make-%syntactic-closure)))
    (set (%syntactic-closure-env  synclosure) env)
    (set (%syntactic-closure-free synclosure) free)
    (set (%syntactic-closure-form synclosure) form)
    synclosure))

(define (make-syntactic-closure env free form)
  (let ((env  (enforce syntactic-env?   env))
        (free (enforce identifier-list? free)))
    (if (cond ((memq form free) '#t)
              ((syntactic-closure? form)
               (not (or (pair? (syntactic-closure-free form))
                        (identifier? (syntactic-closure-form form)))))
              (else
               (self-evaluating? form)))
        form
        (%make-syntactic-closure env free form))))

(define-integrable (close-syntax form env)
  (make-syntactic-closure env '() form))

(define (strip-syntactic-closures object)
  (if (iterate recur ((object object))
        (if (pair? object)
            (or (recur (car object))
                (recur (cdr object)))
            (syntactic-closure? object)))
      (iterate recur ((object object))
        (cond ((pair? object)
               (cons (recur (car object))
                     (recur (cdr object))))
              ((syntactic-closure? object)
               (recur (syntactic-closure-form object)))
              (else
               object)))
      object))

;;; These both can't be integrable, unless Orbit's front end is smarter
;;; about integration than I thought.  Couldn't MAKE-SYNTACTIC-CLOSURE
;;; be modified to ensure that there will be no recursion here?  No:
;;; synthetic identifiers can be arbitrarily nested.

(define-integrable (identifier? object)
  (or (symbol? object)
      (synthetic-identifier? object)))

(define (synthetic-identifier? object)
  (and (syntactic-closure? object)
       (identifier? (syntactic-closure-form object))))

(define-integrable (make-synthetic-identifier id)
  (close-syntax (enforce identifier? id)
                null-syntactic-env))

;++ Implement this some day when I get less lazy.

(define (identifier-list? object)
  (ignore object)
  '#t)

(define (identifier=? env-a id-a env-b id-b)
  (let ((den-a (syntactic-env-entry (enforce syntactic-env? env-a)
                                    (enforce identifier?    id-a)))
        (den-b (syntactic-env-entry (enforce syntactic-env? env-b)
                                    (enforce identifier?    id-b))))
    (or (eq? den-a den-b)
        (and (variable? den-a)
             (variable? den-b)
             (not (variable-local? den-a))
             (not (variable-local? den-b))
             (eq? (variable-id den-a)
                  (variable-id den-b))
             (eq? (variable-vcell den-a)
                  (variable-vcell den-b))))))

(define (identifier->symbol identifier . context)
  (iterate loop ((id identifier))
    (cond ((syntactic-closure? id)
           (loop (syntactic-closure-form id)))
          ((symbol? id)
           id)
          (else
           (loop (error '("illegal identifier~A~%"
                          "**~10T~S")
                        (if (pair? context)
                            (format '#f " in ~A" (car context))
                            "")
                        identifier))))))

;;; This converts a keyword to a form that can be used at the head of a
;;; list, in which context it will be passed the form to expand.

(define (keyword->operator keyword)
  (close-syntax 'KEYWORD
                (make-internal-syntactic-env null-syntactic-env
                                             `((KEYWORD . ,keyword)))))

(define (capture-syntactic-env receiver)
  (let ((receiver (enforce procedure? receiver)))
    `(,(keyword->operator (object (lambda (form env)
                                    (ignore form)
                                    (receiver env))
                            ((keyword? self) '#t)
                            ((transformer-keyword? self)
                             ;; It has to be a transformer, because
                             ;; otherwise RECEIVER's output wouldn't be
                             ;; expanded.
                             '#t))))))

;;; Mumble.

(define-constant capture-syntactic-environment capture-syntactic-env)



;;; --------------------
;;; Syntactic environments

(define-predicate syntactic-env?)       ; Mumble.
(define-constant syntactic-environment? syntactic-env?)

(define-operation (syntactic-env-define env id denotation))

(define syntactic-env-entry
  (object (lambda (env id)
            (cond ((env id))
                  ((symbol? id)
                   (make-free-variable id))
                  ((syntactic-closure? id)
                   ;; We don't need to worry about free names, because
                   ;; of the way that MAKE-SYNTACTIC-CLOSURE works: it
                   ;; will never make a nested syntactic closure, and
                   ;; it will never make a syntactic closure whose form
                   ;; is one of the free names.
                   (syntactic-env-entry (syntactic-closure-env  id)
                                        (syntactic-closure-form id)))
                  (else
                   (syntactic-env-entry env
                                        (error '("illegal identifier~%"
                                                 "**~10T(~S~_~S~_~S)")
                                               'SYNTACTIC-ENV-ENTRY
                                               env
                                               id)))))
    ((setter self)
     syntactic-env-define)))

(define-predicate null-syntactic-env?)

(define-constant null-syntactic-env
  (object (lambda (id)
            (error '("unable to get denotation in null syntactic env~%"
                     "**~10T~S")
                   id))
    ((syntactic-env? self) '#t)
    ((null-syntactic-env? self) '#t)
    ((print-type-string self) "Null-syntactic-env")
    ((syntactic-env-define self id denotation)
     (error '("unable to bind identifier in null syntactic env"
              "**~10T~S")
            `(SET (SYNTACTIC-ENV-ENTRY ,self ,id) ,denotation)))))

(define-predicate top-level-syntactic-env?)

;;; When locales are made to support syntactic bindings, this will need
;;; to be changed.

(define (make-top-level-syntactic-env locale)
  (let ((bound '()))
    (object (lambda (id . mumble?)
              (cond ((car mumble?)      ; Grrrmph.
                     (make-top-level-variable
                      (rename-top-level-identifier id)
                      ;; #T -> local; #T -> create vcell
                      (env-lookup locale id '#t '#t)))
                    ((assq id bound) => cdr)
                    ;; #T -> local; #F -> don't create vcell
                    ((env-lookup locale id '#t '#f)
                     => (lambda (vcell)
                          (make-top-level-variable
                           (rename-top-level-identifier id)
                           vcell)))
                    (else
                     '#f)))
      ((syntactic-env? self) '#t)
      ((top-level-syntactic-env? self) '#t)
      ((print-type-string self) "Top-level-syntactic-env")
      ((syntactic-env-define self id denotation)
       (cond ((assq id bound)
              => (lambda (probe)
                   (set (cdr probe) denotation)))
             (else
              (push bound (cons id denotation))))
       (return)))))

;;; Mumble.

(define-constant make-top-level-syntactic-environment
  make-top-level-syntactic-env)

;;; Internal syntactic environments are defined a little weirdly so
;;; that there isn't a great deal of manual code duplication for the
;;; slight difference between what LAMBDA & LET-SYNTAX use versus what
;;; LETREC-SYNTAX uses.

(define-predicate internal-syntactic-env?)

(define-local-syntax (internal-syntactic-env parent bound)
  `(OBJECT (LAMBDA (ID)
             (COND ((OR (ASSQ ID ,bound) (ASSQ ID FREE))
                    => CDR)
                   (ELSE
                    (LET ((DENOTATION (,parent ID)))
                      (PUSH FREE (CONS ID DENOTATION))
                      DENOTATION))))
     ((SYNTACTIC-ENV? SELF) '#T)
     ((INTERNAL-SYNTACTIC-ENV? SELF) '#T)
     ((PRINT-TYPE-STRING SELF) "Internal-syntactic-env")
     ((SYNTACTIC-ENV-DEFINE SELF ID DENOTATION)
      (ERROR '("unable to bind identifier in internal syntactic env~%"
               "**~10T~S")
             ;; Don't want to get caught up in nested quasiquotation
             ;; confusation...
             (LIST 'SET
                   (LIST 'SYNTACTIC-ENV-ENTRY SELF ID)
                   DENOTATION)))))

(define (make-internal-syntactic-env parent bound)
  (let ((free '()))
    (internal-syntactic-env parent bound)))

(define (make-recursive-syntactic-env parent make-bindings)
  (let* ((bound '())
         (env (internal-syntactic-env parent bound)))
    (set bound (make-bindings env))
    env))

(define-predicate filtered-syntactic-env?)

(define (filter-syntactic-env env free-ids free-env)
  (if (or (null? free-ids)
          (eq? env free-env))
      env
      (object (lambda (id)
                (if (memq id free-ids)
                    (free-env id)
                    (env id)))
        ((syntactic-env? self) '#t)
        ((filtered-syntactic-env? self) '#t)
        ((print-type-string self) "Filtered-syntactic-env")
        ((syntactic-env-define self id denotation)
         (error
          '("unable to bind identifier in filtered syntactic env~%"
            "~10T~S")
          `(SET (SYNTACTIC-ENV-ENTRY ,self ,id) ,denotation))))))



;;; --------------------
;;; Denotations: what syntactic environments can map names to

(define-structure-type %variable
  id
  local?
  vcell
  (((print self port)
    (format port "#{~A~_~S~_~S}"
            (cond ((variable-local? self)
                   "Variable")
                  ((variable-vcell self)
                   "Top-level-variable")
                  (else
                   "Free-variable"))
            (object-hash self)
            (variable-id self)))))

(define-constant variable? %variable?)

(define-integrable (variable-id var)
  (%variable-id var))

(define-integrable (variable-local? var)
  (%variable-local? var))

(define-integrable (variable-vcell var)
  (%variable-vcell var))

(define (make-variable id local? vcell)
  (let ((var (make-%variable)))
    (set (%variable-id     var) id)
    (set (%variable-local? var) local?)
    (set (%variable-vcell  var) vcell)
    var))

(define-integrable (make-local-variable id) (make-variable id '#t '#f))
(define-integrable (make-free-variable  id) (make-variable id '#f '#f))

(define-integrable (make-top-level-variable id vcell)
  (make-variable id '#f vcell))

(define (local-variable? object)
  (and (variable? object)
       (variable-local? object)))

(define (top-level-variable? object)
  (and (variable? object)
       ;; No need to check if it's local: the VCELL will be #F if it is.
       (variable-vcell object)
       '#t))

(define (free-variable? object)
  (and (variable? object)
       (not (variable-local? object))
       (not (variable-vcell object))))

(define-predicate keyword?)
(define-predicate special-form-keyword?)
(define-predicate transformer-keyword?)

(define-predicate definer-keyword?)
(define-predicate syntax-definer-keyword?)
(define-predicate sequence-keyword?)

(define-operation (expand-definition keyword form))
(define-operation (expand-syntax-definition keyword form))

(lset *syntactic-tower* nil)

(define (with-syntactic-tower tower cont)
  (bind ((*syntactic-tower* tower))
    (cont)))

(define (with-simple-syntactic-tower locale cont)
  (let ((evaluate (lambda (exp)
                    (eval exp locale))))
    (with-syntactic-tower (iterate recur ()
                            (cons evaluate (delay (recur))))
      cont)))

(define (eval-transformer exp)
  (enforce procedure?
           (let ((evaluator (car *syntactic-tower*)))
             (with-syntactic-tower (force (cdr *syntactic-tower*))
               (lambda ()
                 (evaluator exp))))))

(define (process-transformer id form env)
  (let ((lose (lambda ()
                (process-transformer id
                  (syntax-error '("illegal transformer~%"
                                  "**     ~S~%"
                                  "**  for syntactic binding ~S")
                                form
                                id)
                  env))))
    (cond ((not (pair? form))
           (lose))
          ((symbol? (car form))
           ;++ At some point, this should probably be extensible in
           ;++ some way.
           (case (car form)
             ((SYNTACTIC-CLOSURE-TRANSFORMER)
              (make-syntactic-closure-transformer id (cadr form) env))
             ((EXPLICIT-RENAMING-TRANSFORMER)
              (make-explicit-renaming-transformer id (cadr form) env))
             (else
              (lose))))
          (else
           (lose)))))

(define (make-syntactic-closure-transformer id exp transformer-env)
  (let ((proc (eval-transformer exp)))
    (object (lambda (form usage-env)
              (proc form usage-env transformer-env))
      ((keyword? self) '#t)
      ((transformer-keyword? self) '#t)
      ((print-type-string self) "Syntactic-closure-transformer")
      ((identification self) id))))

(define (make-explicit-renaming-transformer id exp transformer-env)
  (let ((proc (eval-transformer exp)))
    (object (lambda (form usage-env)
              (proc form
                    (make-explicit-renamer transformer-env)
                    (lambda (id-a id-b)
                      (identifier=? usage-env id-a usage-env id-b))))
      ((keyword? self) '#t)
      ((transformer-keyword? self) '#t)
      ((print-type-string self) "Explicit-renaming-transformer")
      ((identification self) id))))

(define (make-explicit-renamer env)
  (let ((alist '()))
    (labels (((rename id)
              (if (identifier? id)
                  (cdr (or (assq id alist)
                           (let ((c (cons id (close-syntax id env))))
                             (push alist c)
                             c)))
                  (rename (error '("illegal identifier to rename~%"
                                   "**~10T~S")
                                 id)))))
      rename)))