(herald (synclo std)                                        ; -*- T -*-
        (env t
             (synclo synclo)
             (synclo expand)))

;;;;;;; Syntactic closures for T
;;;;;;; Standard special form & transformer keywords

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

(define (install-standard-keywords env)
  (let ((env (enforce syntactic-env? env)))
    (walk-table (lambda (id keyword)
                  (set (syntactic-env-entry env id) keyword))
                *standard-special-form-table*)
    (walk-table (lambda (id keyword-maker)
                  (set (syntactic-env-entry env id)
                       (keyword-maker env)))
                *standard-transformer-table*)))

(define *standard-special-form-table*
        (make-table 'STANDARD-SPECIAL-FORM-TABLE))

(define *standard-transformer-table*
        (make-table 'STANDARD-TRANSFORMER-TABLE))

(define-local-syntax (define-special-form id+pat expander . methods)
  (let ((predicate-id (generate-symbol 'predicate))
        (expander-id (generate-symbol 'expander)))
    `(SET (TABLE-ENTRY *STANDARD-SPECIAL-FORM-TABLE* ',(car id+pat))
          (LET ((,predicate-id (PATTERN-PREDICATE ,(cdr id+pat)))
                (,expander-id ,expander))
            (OBJECT (LAMBDA (FORM ENV)
                      (IF (,predicate-id (CDR FORM))
                          (,expander-id FORM ENV)
                          (SYNTAX-ERROR '("illegal syntax~%"
                                          "**     ~S")
                                        (CONS ',(car id+pat)
                                              (CDR FORM)))))
              ((KEYWORD? SELF) '#T)
              ((SPECIAL-FORM-KEYWORD? SELF) '#T)
              ,@methods
              ((IDENTIFICATION SELF) ',(car id+pat))
              ((PRINT-TYPE-STRING SELF) "Special-form"))))))

(define-local-syntax (define-transformer id bvl . body)
  (receive (pattern p-var id)
           (if (symbol? id)
               (return '#f '#f id)
               (return `(PATTERN-PREDICATE ,(cdr id))
                       (generate-symbol 'syntax-predicate)
                       (car id)))
    (let ((tenv-var (generate-symbol 'TRANSFORMER-ENV))
          (proc-var (generate-symbol 'PROC)))
      `(SET (TABLE-ENTRY *STANDARD-TRANSFORMER-TABLE* ',id)
            ;; This is somewhat weirdly written.  The table of standard
            ;; transformers is actually a table whose data _construct_
            ;; transformers given the transformer environment; they
            ;; aren't themselves transformers.  Also, the pattern is
            ;; optional, in case the transformer has several variants &
            ;; the procedure checks the syntax manually.
            (LET ((,proc-var (LAMBDA ,bvl ,@body))
                  ,@(if pattern
                        `((,p-var ,pattern))
                        '()))
              (LAMBDA (,tenv-var)
                (OBJECT ,(if pattern
                             `(LAMBDA (FORM ENV)
                                (IF (,p-var (CDR FORM))
                                    (,proc-var FORM ENV ,tenv-var)
                                    (SYNTAX-ERROR '("illegal syntax~%"
                                                    "**     ~S")
                                                  (CONS ',id
                                                        (CDR FORM)))))
                             `(LAMBDA (FORM ENV)
                                (,proc-var FORM ENV ,tenv-var)))
                  ((KEYWORD? SELF) '#T)
                  ((TRANSFORMER-KEYWORD? SELF) '#T)
                  ((PRINT-TYPE-STRING SELF)
                   "Syntactic-closure-transformer")
                  ((IDENTIFICATION SELF) ',id))))))))



;;; --------------------
;;; Special form keywords

(define-special-form (define-syntax identifier? (identifier? . #f))
    (lambda (form env)
      (ignore env)
      (syntax-error '("syntax definition in illegal context~%"
                      "**     ~S")
                    `(DEFINE-SYNTAX ,@(cdr form))))
  ((syntax-definer-keyword? self) '#t)
  ((expand-syntax-definition self form env)
   (ignore env)                         ; Why is ENV passed at all?
   (return (cadr form) (caddr form))))

(define-special-form (define-variable-value identifier? #f)
    (lambda (form env)
      (ignore env)
      (syntax-error '("definition in illegal context~%"
                      "**     ~S")
                    ;++ This could be prettified: it could use DEFINE &
                    ;++ generate the curried form in the error message.
                    `(DEFINE-VARIABLE-VALUE ,@(cdr form))))
  ((definer-keyword? self) '#t)
  ((expand-definition self form)
   (return 'DEFINE (cadr form) (caddr form))))

(define-special-form (lset-variable-value identifier? #f)
    (lambda (form env)
      (ignore env)
      (syntax-error '("~S definition in illegal context~%"
                      "**     ~S")
                    'LSET
                    `(LSET ,@(cdr form))))
  ((definer-keyword? self) '#t)
  ((expand-definition self form)
   (return 'LSET (cadr form) (caddr form))))

(define-special-form (set-variable-value identifier? #f)
    (lambda (form env)
      (iterate loop ((id (cadr form)))
        (let ((var (syntactic-env-entry env id)))
          (if (variable? var)
              (let ((renamed-id (variable-id var))
                    (exp (expand (caddr form) env)))
                (cond ((variable-local? var)
                       (output/local-assignment renamed-id exp))
                      ((variable-vcell var)
                       => (lambda (vcell)
                            (output/top-level-assignment renamed-id
                                                         vcell
                                                         exp)))
                      (else
                       (output/free-assignment renamed-id exp))))
              (loop (syntax-error '("illegal variable assignment~%"
                                    "**     ~S")
                                  id)))))))

(define-special-form (let-syntax (* (identifier? #f)) . (+ #f))
    (lambda (form env)
      (expand-local-syntax form
        (lambda (make-bindings)
          (make-internal-syntactic-env env (make-bindings env))))))

(define-special-form (letrec-syntax (* (identifier? #f)) . (+ #f))
    (lambda (form env)
      (expand-local-syntax form
        (lambda (make-bindings)
          (make-recursive-syntactic-env env make-bindings)))))

(define (expand-local-syntax form make-internal-env)
  (expand-body (cddr form)
               (make-internal-env
                (lambda (transformer-env)
                  (map (lambda (spec)
                         (cons (car spec)
                               (process-transformer (car spec)
                                                    (cadr spec)
                                                    transformer-env)))
                       (cadr form))))))

(define-special-form (block (* #f))
    (lambda (form env)
      (output/sequence (map (lambda (subform)
                              (expand subform env))
                            (cdr form))))
  ((sequence-keyword? self) '#t))

(define-special-form (lambda valid-bvl? . (+ #f))
    (lambda (form env)
      (receive-values output/lambda
        (lambda ()
          (expand-lambda (cadr form) (cddr form) env)))))

(define-special-form (named-lambda identifier? valid-bvl? . (+ #f))
    (lambda (form env)
      (receive (bvl body)
               (expand-lambda (caddr form) (cdddr form) env)
        (output/named-lambda (identifier->symbol (cadr form)
                                                 'NAMED-LAMBDA)
                             bvl
                             body))))

(define valid-bvl?
  (pattern-predicate (| null?
                        identifier?
                        (identifier? . valid-bvl?))))

(define (expand-lambda bvl body env)
  (let* ((ids (lambda-bvl-ids bvl))
         (vars (map (lambda (id renamed)
                     (cons id (make-local-variable renamed)))
                    ids
                    (rename-identifiers ids)))
         (internal-env (make-internal-syntactic-env env vars)))
    (return (map-bvl (lambda (id)
                       (variable-id (cdr (assq id vars))))
                     bvl)
            (expand-body body internal-env))))

(define (lambda-bvl-ids bvl)
  (iterate recur ((l bvl))
    (cond ((pair? l)
           (if (car l)
               (cons (car l) (recur (cdr l)))
               (recur (cdr l))))
          ((null? l)
           '())
          ((symbol? l)
           (cons l '()))
          (else
           (lambda-bvl-ids
            (syntax-error '("illegal lambda parameter list~%"
                            "**     ~S")
                          bvl))))))

(define (map-bvl proc bvl)
  (iterate recur ((bvl bvl))
    (cond ((pair? bvl)
           (cons (cond ((car bvl) => proc)
                       (else '#f))
                 (recur (cdr bvl))))
          ((null? bvl)
           bvl)
          ((symbol? bvl)
           (proc bvl))
          (else
           (map-bvl proc
                    (syntax-error '("illegal lambda parameter list~%"
                                    "**     ~S")
                                  bvl))))))

(define-special-form (object #f
                       (@ ((#f (| identifier?
                                  (identifier? identifier?))
                               . valid-bvl?)
                           . (+ #f))))
    (lambda (form env)
      (iterate loop ((in-methods (cddr form))
                     (out-methods '()))
        (if (null? in-methods)
            (output/object (expand (cadr form) env)
                           (reverse! out-methods))
            (loop (cdr in-methods)
                  (cons (expand-object-method (car in-methods) env)
                        out-methods))))))

(define (expand-object-method method env)
  (destructure (( ((operator state . bvl) . body)
                  method))
    (receive (self-id state-id)
             (if (pair? state)
                 (return (car state) (cadr state))
                 (return state '#f))
      (let* ((ids (lambda-bvl-ids bvl))
             (ids (if state-id
                      (cons self-id (cons state-id ids))
                      (cons self-id ids)))
             (vars (map (lambda (id renamed)
                          (cons id (make-local-variable renamed)))
                        ids
                        (rename-identifiers ids)))
             (foo (lambda (id)
                    (variable-id (cdr (assq id vars))))))
        `((,(expand operator env)
           ,(if state-id
                `(,(foo self-id) ,(foo state-id))
                (foo self-id))
           . ,(map-bvl foo bvl))
          ,(expand-body body
                        (make-internal-syntactic-env env vars)))))))

(define-special-form (if #f #f . (| null? (#f)))
    (lambda (form env)
      (output/conditional (expand (cadr  form) env)
                          (expand (caddr form) env)
                          (if (null? (cdddr form))
                              (output/undefined-conditional-value)
                              (expand (cadddr form) env)))))

(define-special-form (labels (* (| (identifier? #f)
                                   ((identifier? . valid-bvl?)
                                    . (+ #f))))
                       . (+ #f))
    (lambda (form env)
      (iterate loop ((specs (cadr form))
                     (ids '())
                     (exps '()))
        (cond ((null? specs)
               ;; Everything is reversed just to keep it consistent
               ;; with the input form.
               (let* ((ids (reverse! ids))
                      (renamed-ids (rename-identifiers ids))
                      (internal-env
                       (make-internal-syntactic-env env
                         (map (lambda (id renamed)
                                (cons id
                                      (make-local-variable renamed)))
                              ids
                              renamed-ids))))
                 (output/labels renamed-ids
                                (reverse-map (lambda (exp)
                                               (expand exp
                                                       internal-env))
                                             exps)
                                (expand-body (cddr form)
                                             internal-env))))
              ((pair? (caar specs))
               (loop (cons `(,(caaar specs)
                              (,operator/lambda ,(cdaar specs)
                                ,@(cdar specs)))
                           (cdr specs))
                     ids
                     exps))
              (else
               (loop (cdr specs)
                     (cons (caar  specs) ids)
                     (cons (cadar specs) exps)))))))

;;; Used by the expander for LABELS.

(define operator/lambda
  (keyword->operator (table-entry *standard-special-form-table*
                                  'LAMBDA)))

(define-special-form (variable-value identifier?)
    (lambda (form env)
      (iterate loop ((id (cadr form)))
        (let ((var (syntactic-env-entry env id)))
          (if (variable? var)
              (expand-reference var)
              (loop (syntax-error '("illegal variable reference~%"
                                    "**     ~S")
                                  id)))))))

(define-special-form (var-locative identifier?)
    (lambda (form env)
      (iterate loop ((id (cadr form)))
        (let ((var (syntactic-env-entry env id)))
          (if (variable? var)
              (let ((renamed-id (variable-id var)))
                (cond ((variable-local? var)
                       (output/local-var-locative renamed-id))
                      ((variable-vcell var)
                       => (lambda (vcell)
                            (output/top-level-var-locative renamed-id
                                                           vcell)))
                      (else
                       (output/free-var-locative renamed-id))))
              (loop (syntax-error '("illegal variable reference~%"
                                    "**     ~S")
                                  `(VAR-LOCATIVE ,id))))))))

;;; The difference between QUOTE & SYNTAX-QUOTE is that QUOTE strips
;;; all syntactic closure information, whereas SYNTAX-QUOTE preserves
;;; it, as is necessary for macros that generate macros, such as
;;; SYNTAX-RULES.

(define-special-form (quote #f)
    (lambda (form env)
      (ignore env)
      (output/literal (strip-syntactic-closures (cadr form)))))

(define-special-form (syntax-quote #f)
    (lambda (form env)
      (ignore env)
      (output/literal (cadr form))))



;;; --------------------
;;; Transformer keywords

;++ Perhaps these should be rewritten to be more 'syntactic-closurey.'
;++ A good set of transformers to include here should be determined as
;++ well.  Perhaps all this should be removed.  I'm leaning towards
;++ either that or slimming it down to exclude everything but the
;++ definition forms.  On the other hand, it might be a good idea not
;++ to slim this down any until T4, when moving macros to other modules
;++ will work reasonably.

(define (blockify forms keyword-env)
  (if (or (null? forms)
          (pair? (cdr forms)))
      `(,(close-syntax 'BLOCK keyword-env) ,@forms)
      (car forms)))

;;; The definition forms all support MIT's currying extension as well
;;; as an unassigned value extension.

(define-transformer (define . valid-definition?)
                    (form usage-env transformer-env)
  (ignore usage-env)
  (transform-definition form transformer-env
    (lambda (id exp)
      `(,(close-syntax 'DEFINE-VARIABLE-VALUE transformer-env)
        ,id
        ,exp))))

(define-transformer (define-integrable . valid-definition?)
                    (form usage-env transformer-env)
  (ignore usage-env)
  (transform-definition form transformer-env
    (lambda (id exp)
      `(,(close-syntax 'BLOCK transformer-env)
         (,(close-syntax 'DECLARE transformer-env) CONSTANT ,id)
         (,(close-syntax 'DEFINE-VARIABLE-VALUE transformer-env)
          ,id
          ,exp)))))

(define-transformer (define-constant . valid-definition?)
                    (form usage-env transformer-env)
  (ignore usage-env)
  (transform-definition form transformer-env
    (lambda (id exp)
      `(,(close-syntax 'BLOCK transformer-env)
         (,(close-syntax 'DECLARE transformer-env) CONSTANT ,id)
         (,(close-syntax 'DEFINE-VARIABLE-VALUE transformer-env)
          ,id
          ,exp)))))

(define valid-definition?
  (labels ((id-spec?
            (pattern-predicate ((| identifier? id-spec?)
                                . valid-bvl?))))
    (pattern-predicate
     (| (identifier? #f)                ; canonical form
        (identifier?)                   ; unassigned form
        (id-spec? . (+ #f))))))         ; curried form

(define (transform-definition form transformer-env construct)
  (let ((spec (cadr form)))
    (cond ((pair? spec)
           (let ((%lambda (close-syntax 'LAMBDA transformer-env)))
             (iterate loop ((spec (caadr form))
                            (bvl (cdadr form))
                            (body (blockify (cddr form)
                                            transformer-env)))
               (if (pair? spec)
                   (loop (car spec)
                         (cdr spec)
                         `(,%lambda ,bvl ,body))
                   (construct spec
                              `(,(close-syntax 'NAMED-LAMBDA
                                               transformer-env)
                                ,spec
                                ,bvl
                                ,body))))))
          ((pair? (cdr form))
           (construct spec (caddr form)))
          (else
           (construct spec (output/unassigned-initializer))))))

(define-transformer (lset identifier? . (| null? (#f)))
                    (form usage-env transformer-env)
  (ignore usage-env)
  `(,(close-syntax 'LSET-VARIABLE-VALUE transformer-env)
    ,(cadr form)
    ,(if (null? (cddr form))
         (output/unassigned-initializer)
         (caddr form))))

(define-transformer (let (* (identifier? #f)) . (+ #f))
                    (form usage-env transformer-env)
  (ignore usage-env)
  (let ((bindings (cadr form))
        (body     (cddr form)))
    `((,(close-syntax 'LAMBDA transformer-env) ,(map car bindings)
        ,@body)
      ,@(map cadr bindings))))

(define-transformer (let* (* (identifier? #f)) . (+ #f))
                    (form usage-env transformer-env)
  (ignore usage-env)
  (let ((%lambda (close-syntax 'LAMBDA transformer-env)))
    (if (null? (cadr form))
        ;; Necessary for internal definitions, even if we don't support
        ;; them yet.
        `((,%lambda () ,@(cddr form)))
        (iterate recur ((clause (caadr form))
                        (more   (cdadr form)))
          `((,%lambda (,(car clause))
              ,@(if (null? more)
                    (cddr form)
                    (list (recur (car more) (cdr more)))))
            ,(cadr clause))))))

(define-transformer (iterate identifier? (* (identifier? #f)) . (+ #f))
                    (form usage-env transformer-env)
  (ignore usage-env)
  (let ((id       (cadr  form))
        (bindings (caddr form))
        (body     (cdddr form)))
    `((,(close-syntax 'LABELS transformer-env)
          ((,id (,(close-syntax 'LAMBDA transformer-env)
                    ,(map car bindings)
                  ,@body)))
        ,id)
      ,@(map cadr bindings))))

(define-transformer (cond (+ (+ #f)))
                    (form usage-env transformer-env)
  (let ((%if  (close-syntax 'IF  transformer-env))
        (%or  (close-syntax 'OR  transformer-env))
        (%let (close-syntax 'LET transformer-env)))
    (iterate recur ((clause (cadr form))
                    (more (cddr form)))
      (cond ((identifier=? usage-env (car clause)
                           transformer-env 'ELSE)
             (if (null? more)
                 (blockify (cdr clause) transformer-env)
                 (syntax-error '("clauses after ~S clause in ~S~%"
                                 "**~10T~S")
                               'ELSE 'COND
                               more)))
            ((null? (cdr clause))
             (if (null? more)
                 (car clause)
                 `(,%or ,(car clause)
                        ,(recur (car more) (cdr more)))))
            (else
             (let ((maybe-more
                    (if (null? more)
                        '()
                        (list (recur (car more) (cdr more))))))
               (if (and (pair? (cddr  clause))
                        (null? (cdddr clause))
                        (identifier=? usage-env (cadr clause)
                                      transformer-env '=>))
                   (let ((id (make-synthetic-identifier 'TEMPORARY)))
                     `(,%let ((,id ,(car clause)))
                        (,%if ,id
                              (,(caddr clause) ,id)
                              ,@maybe-more)))
                   `(,%if ,(car clause)
                          ,(blockify (cdr clause) transformer-env)
                          ,@maybe-more))))))))

(define-transformer (and . (* #f))
                    (form usage-env transformer-env)
  (ignore usage-env)
  (let ((%quote (close-syntax 'QUOTE transformer-env))
        (%if (close-syntax 'IF transformer-env)))
    (if (pair? (cdr form))
        (iterate recur ((conjunct (cadr form)) (more (cddr form)))
          (if (pair? more)
              `(,%if ,conjunct
                   ,(recur (car more) (cdr more))
                   (,%quote #F))
              conjunct))
        `(,%quote #T))))

(define-transformer (or . (* #f))
                    (form usage-env transformer-env)
  (ignore usage-env)
  (let ((%quote (close-syntax 'QUOTE transformer-env))
        (%if (close-syntax 'IF transformer-env)))
    (if (pair? (cdr form))
        (iterate recur ((disjunct (cadr form)) (more (cddr form)))
          (if (pair? more)
              `(,%if ,disjunct
                   (,%quote #T)
                   ,(recur (car more) (cdr more)))
              disjunct))
        `(,%quote #F))))