;;;; Copyright (c) 2001 Jonathan Bachrach
;;;; BASED ON Lisp In Small Pieces by Christian Queinnec
;;;; with many many changes

(use goo)
(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/types)
(use goo/system)
(use goo/cols/lst)
(use goo/io/read)
(use eval/syntax)
(use eval/dependency)
(use/export eval/module)

;;; TODO: MOVE TYPE OUT OF SIGNATURE

;;; The <dependent> object we're currently compiling.  Any dependencies we
;;; encounter will automatically be assumed to be the resposibility of this
;;; object.
(ddv *current-dependent* #f)
(ds with-dependent (,dependent ,@body)
  (let ((saved-dependent (gensym)))
    `(let ((,saved-dependent *current-dependent*))
       (set *current-dependent* ,dependent)
       (fin
         (seq ,@body)
         (set *current-dependent* ,saved-dependent)))))

(dc <ast-error> (<compiler-error>))

(dc <simple-ast-error> (<ast-error> <simple-error>))

(dm ast-error (message|<str> arguments|...)
  (sig (new <simple-ast-error> 
         condition-message message condition-arguments arguments)))

;;; programs

(dc <program> (<any>))
  (dp! program-type (<program> => <any>)      $bot)
  (dp! program-line (<program> => (t? <int>)) #f)
  (dp! program-register (<program> => <any>)  #f) ;; TODO: T? INT

(dc <computed-program> (<program>))
  ;; (dp! program-register (<computed-program> => <any>) #f) ;; TODO: T? INT

(dc <passive-program> (<program>))

(dc <local-binding> (<binding>))
  (dp! binding-value (<local-binding> => <any>)           #f)
  (dp! binding-mutable? (<local-binding> => <any>)        #f)
  (dp! binding-dynamic-extent? (<local-binding> => <any>) #t)
  (dp! binding-dotted? (<local-binding> => <any>)         #f)
  (dp! binding-closed-over? (<local-binding> => <any>)    #f)
  (dp! binding-index (<local-binding> => <any>)           #f)

;; (dc <next-methods-binding> (<binding>))

;;; compile-time

(dc <compile-time> (<computed-program>))
  (dp! compile-time-program (<compile-time> => <any>))

;;; references are programs.

(dc <reference> (<passive-program>))

;;; special category of bindings

;; DEAL WITH INITIALIZE

(dc <real-reference> (<reference>))
  (dp! reference-binding (<real-reference> => <any>))

(dc <local-reference> (<real-reference>))
  (dp! reference-called-function? (<local-reference> => <any>) #f)
  (dp! reference-frame-number (<local-reference> => <int>))
  (dp! reference-frame-offset (<local-reference> => <int>))

;; (dc <next-methods-reference> (<real-reference>))

(dc <module-binding-reference> (<real-reference>))

(dc <global-reference> (<module-binding-reference>))

(dc <runtime-reference> (<module-binding-reference>))

(dc <dynamic-reference> (<module-binding-reference>))

(dc <predefined-reference> (<real-reference>))

(dc <static-module-binding-reference> (<module-binding-reference>))

(dc <macro-reference> (<static-module-binding-reference>))

(dc <magic-reference> (<static-module-binding-reference>))

(dc <bound?> (<computed-program>))
  (dp! bound?-reference (<bound?> => <any>))
  (dp! bound?-default (<bound?> => <any>))

(dc <assignment> (<computed-program>))
  (dp! assignment-form (<assignment> => <any>))

(dc <local-assignment> (<assignment>))
  (dp! assignment-reference (<local-assignment> => <any>))

(dc <global-assignment> (<assignment>))
  (dp! assignment-binding (<global-assignment> => <any>))

(dc <runtime-assignment> (<global-assignment>))

(dc <dynamic-assignment> (<global-assignment>))

(dc <definition> (<global-assignment>))

;;; TODO: THE FOLLOWING DEFS AREN'T REALLY USED -- PERHAPS ZAP

(dc <variable-definition> (<definition>))

(dc <dynamic-definition> (<variable-definition>))

(dc <ast-generic-definition> (<definition>))

(dc <ast-function-definition> (<definition>))

(dc <ast-method-definition> (<definition>))

(dc <ast-primitive-definition> (<definition>))

(dc <ast-macro-definition> (<definition>))

(dc <ast-signature> (<computed-program>))
  (dp! signature-bindings (<ast-signature> => <any>) '())
  (dp! signature-names (<ast-signature> => <any>)    '())
  (dp! signature-specs (<ast-signature> => <any>)    '())
  (dp! signature-nary? (<ast-signature> => <any>)    #f)
  (dp! signature-arity (<ast-signature> => <any>)    #f)
  (dp! signature-value (<ast-signature> => <any>)    #f)

;;; required only specializers
(dm req-sig-specs (sig|<ast-signature> => <any>)
  (def types (signature-specs sig))
  (if (constant-value (signature-nary? sig))
      (sub types 0 (- (len types) 1))
      types))

(dc <ast-function> (<computed-program> <dependent>))
  (dp! function-binding (<ast-function> => <any>)    #f)
  (dp! function-debug-name (<ast-function> => <any>) #f)
  ;;  (dp! function-next-methods-binding (<ast-function> => <any>))
  (dp! function-signature (<ast-function> => <any>))

(df function-bindings (x|<ast-function>) 
  (signature-bindings (function-signature x)))
(df function-names (x|<ast-function>) 
  (signature-names (function-signature x)))
(df function-specs (x|<ast-function>) 
  (signature-specs (function-signature x)))
(df function-nary? (x|<ast-function>)
  (constant-value (signature-nary? (function-signature x))))
(df function-arity (x|<ast-function>)
  (constant-value (signature-arity (function-signature x))))
(df function-value (x|<ast-function>)
  (signature-value (function-signature x)))

(dm function-kind (x|<ast-function>) "FUN")

(df function-display-name (f|<ast-function>)
  (def b (function-binding f))
  (case-by b isa?
    ((<sym>) 
     (as <str> b))
    ((<module-binding>) 
     (msg-to-str "%s:%s" (binding-module-name b) (binding-name b)))
    (#t 
     "anonymous function")))

(dm invalidate-dependent
    (dependent|<ast-function> dependable|<dependable> dtype|<dependency-type>)
  ;; Aggressively detach ourselves.  We'll eventually want
  ;; to selectively detach ourselves.
  (detach-dependent dependent)
  (def name (function-display-name dependent))
  (cond
    ((dependency-includes-any? dtype $parse-dependencies)
     (msg out "warning: %s needs to be reparsed\n" name))
    ((dependency-includes-any? dtype $optimizaton-dependencies)
     (msg out "warning: %s needs to be re-optimized\n" name))
    (#t
     (msg out "warning: unknown dependency of %s clobbered\n" name))))

(dc <programs> (<passive-program>))

(dm as-lst (e|<programs> => <lst>)
  (rep loop ((res '()) (e e))
    (if (nul? e) (rev! res) (loop (pair (head e) res) (tail e)))))

(ds def-programs (,name) `(def-list ,name (<programs>)))

(dc <ast-embodied-function> (<ast-function>))
  (dp! function-body (<ast-embodied-function> => <any>)            #f)
  (dp! function-index (<ast-embodied-function> => <any>)           0)
  (dp! function-temporaries (<ast-embodied-function> => <any>)     '())
  (dp! function-registers (<ast-embodied-function> => <vec>)       (fab <vec> 0))
  (dp! function-loop (<ast-embodied-function> => <any>)            #f)
  (dp! function-source (<ast-embodied-function> => <any>)          #f)
  (dp! function-frame-len (<ast-embodied-function> => <any>)       #f)
  (dp! function-adjectives (<ast-embodied-function> => <lst>)      '())

(def-programs free-environment)

(dc <ast-method> (<ast-embodied-function>))
  (dp! function-ref-count (<ast-method> => <int>) 0)
  (dp! function-free (<ast-method> => <free-environment>)
    (nul <free-environment>))

(dm incf-ref-count (x) x)
(dm incf-ref-count (x|<ast-method>) (incf (function-ref-count x)))

(dm function-kind (x|<ast-method>) "MET")

(dc <ast-primitive> (<ast-embodied-function>))

(dm function-kind (x|<ast-primitive>) "PRM")

(dc <ast-generic> (<ast-function>))

(dm function-kind (x|<ast-generic>) "GEN")

(dc <alternative> (<computed-program>))
  (dp! alternative-condition (<alternative> => <any>))
  (dp! alternative-consequent (<alternative> => <any>))
  (dp! alternative-alternant (<alternative> => <any>))

(dc <loop> (<computed-program>))
  (dp! loop-bindings (<loop> => <any>))
  (dp! loop-body (<loop> => <any>))
  (dp! loop-continue (<loop> => <any>) #f)

(def-programs sequential)

(dc <constant> (<passive-program>))
  (dp! constant-value (<constant> => <any>))
  (dp! constant-index (<constant> => <any>))

(dc <raw-constant> (<constant>))

(dc <immediate-constant> (<constant>))

(dc <application> (<computed-program>))
  (dp! application-arguments (<application> => <any>))
  (dp! application-tail? (<application> => <any>) #f)

(dc <loop-application> (<application>))
  (dp! application-loop (<loop-application> => <loop>))

(dm application-tail? (x|<loop-application> => <log>) #t)

(dc <regular-application> (<application>))
  (dp! application-function (<regular-application> => <any>))
  (dp! application-known? (<regular-application> => <any>) #f)

(dc <method-application> (<regular-application>))
  (dp! application-next-methods (<method-application> => <any>))

(dm application-known? (x|<method-application> => <log>) #t)

(dc <predefined-application> (<application>))
  (dp! application-binding (<predefined-application> => <any>))

(dc <fix-let> (<computed-program>))
  (dp! fix-let-bindings (<fix-let> => <any>))
  (dp! fix-let-types (<fix-let> => <any>))
  (dp! fix-let-arguments (<fix-let> => <any>))
  (dp! fix-let-body (<fix-let> => <any>))
(dc <low-let> (<fix-let>))

(def-programs fab-list)

(def-programs arguments)

(dc <locals> (<computed-program>))
  (dp! locals-bindings (<locals> => <any>))
  (dp! locals-functions (<locals> => <any>))
  (dp! locals-body (<locals> => <any>))

(def-programs inline-refs)

(dc <c-inline> (<computed-program>))
  (dp! c-inline-refs (<c-inline> => <inline-refs>))
  (dp! c-inline-strs (<c-inline> => <lst>))
  (dp! c-inline-expr? (<c-inline> => <log>) #t)

(dc <bind-exit> (<computed-program>))
  (dp! bind-exit-main-fun (<bind-exit> => <any>))
  (dp! bind-exit-light? (<bind-exit> => <log>) #t)

(dc <unwind-protect> (<computed-program>))
  (dp! unwind-protect-protected-thunk (<unwind-protect> => <any>))
  (dp! unwind-protect-cleanup-thunk (<unwind-protect> => <any>))

(dc <monitor> (<computed-program>))
  (dp! monitor-type (<monitor> => <any>))
  (dp! monitor-info (<monitor> => <any>))
  (dp! monitor-test (<monitor> => <any>))
  (dp! monitor-handler (<monitor> => <any>))
  (dp! monitor-main-thunk (<monitor> => <any>))

;;; WALKER

(dm ast-walk! (g o args|...)
  ;; (msg out "WALKING %=\n" o)
  (for ((prop (props-of o)))
    ;; (msg out "  PROP %=\n" prop)
    (def getter (prop-getter prop))
    (def setter (prop-setter prop))
    ;; TODO: HACK
    (unless (or (== getter binding-value) (== getter application-loop)) 
      (when (prop-bound? o getter)
        (def x (getter o))
        (when (isa? x <program>)
          ;; (msg out "    UPDATING %=\n" x)
          (setter (app g x args) o)))))
  o)

(dm ast-walk (g o args|...)
  (for ((prop (props-of o)))
    (def getter (prop-getter prop))
    ;; TODO: HACK
    (unless (or (== getter binding-value) (== getter application-loop)) 
      (when (prop-bound? o getter)
        (def x (getter o))
        (when (isa? x <program>)
          (app g x args)))))
  o)

(dm ast-walk (g o|<programs> args|...)
  (rep walk ((x o))
    (unless (nul? x)
      (let ((e (head x)))
        (when (isa? e <program>) (app g e args))
        (walk (tail x))))))

#/
;;;TODO: DOESN'T RETURN SIDE-EFFECT CORRECTLY FOR SOME REASON
(dm ast-walk! (g o|<programs> args|...)
  (rep walk ((x o))
    (if (nul? x)
        o
        (let ((e (head x)))
          (when (isa? e <program>)
            (set (head x) (app g e args)))
          (walk (tail x))))))
/#

(dm ast-copy (x|<program> => <any>)
  (def copy (clone x))
  (set (program-register copy) #f)
  (ast-walk! ast-copy copy))

(dm ast-copy (x|<programs> => <any>)
  (if (nul? x)
      x
      (sup x)))

;;;; CONVERT TO AST FORM

(dm objectify (e|<lst> r|<static-environment> tail? => <any>)
  (if (isa? e <program>) ;; TODO: HACK FOR <PROGRAMS>
      e
      (objectify-list (objectify (head e) r #f) e r tail?)))

(dm objectify-list
    (f|<program> e|<lst> r|<static-environment> tail? => <any>)
  (objectify-application f (tail e) r tail?))

(dm objectify-list
    (f|<magic-reference> e|<lst> r|<static-environment> tail? => <any>)
  ((binding-handler (reference-binding f)) e r tail?))

(df maybe-log-dependency (dependable|<dependable> dtype|<dependency-type>)
  (when *current-dependent*
    (log-dependency dependable *current-dependent* dtype)
    (transaction-register-dependent *current-dependent*)))

(df macro-expander (macro-binding|<module-binding> => <fun>)
  (maybe-log-dependency macro-binding $expansion-parse-dependency)
  (binding-handler macro-binding))

(dm objectify-list
    (f|<macro-reference> e|<lst> r|<static-environment> tail? => <any>)
  (objectify ((macro-expander (reference-binding f)) e r tail?) r tail?))

(dm objectify (e|<sym> r|<static-environment> tail? => <any>)
  (objectify-symbol e r))

(dm objectify (e|<module-binding> r|<static-environment> tail? => <any>)
  e)

(dm objectify (e|<program> r|<static-environment> tail? => <any>)
  e)

(dm objectify ((e (t= '())) r|<static-environment> tail? => <any>)
  (objectify-quotation e r))

(dm objectify (e r|<static-environment> tail? => <any>)
  (objectify-quotation e r))

(dm objectify-quotation (value r => <constant>)
  (new <constant> constant-value value))

(dm objectify-quotation (value|<int> r => <immediate-constant>)
  (new <immediate-constant> constant-value value))

(dm objectify-quotation (value|<chr> r => <immediate-constant>)
  (new <immediate-constant> constant-value value))

(dm objectify-raw (value r => <raw-constant>)
  (new <raw-constant> constant-value value))

(dm objectify-bound? (e|<sym> default r|<static-environment> tail? => <any>)
  (new <bound?> 
    bound?-reference (objectify-symbol e r)
    bound?-default   (objectify default r #f)))

;;; This routine always produces a version of 'program' which is accessible
;;; in the syntax environment.  If 'rt?' is true, it will make sure that
;;; there is also a version in the runtime environment.
(dm objectify-compile-time (program r tail? rt? => <program>)
  (def mod (find-environment-module r))
  (def syntax-env (module-syntax-environment mod))
  (def target-env (module-target-environment mod))
  (def ast (objectify program syntax-env tail?))
  ;; Process the program immediately.
  (ast-evaluate ast)
  ;; If we have been asked to create a runtime copy of this code--and we
  ;; are compiling--create a second copy of this code which can be
  ;; accessed in the runtime.  This parallels they way
  ;; <ast-macro-definition> works.  Otherwise, objectify #f.
  ;; The value of a CT-ALSO form is currently undefined.
  (if (and rt? (~== syntax-env target-env))
      (objectify program r tail?)
      (new <constant> constant-value #f)))

(dm objectify-alternative (t c a r tail? => <alternative>)
  (new <alternative> 
    alternative-condition  (objectify t r #f)
    alternative-consequent (objectify c r tail?)
    alternative-alternant  (objectify a r tail?)))

(dm sequentialize (e*|<lst> => <program>)
  (if (nul? e*)
      (new <constant> constant-value #f)
      (if (nul? (tail e*))
          (head e*)
          (rep loop ((r (nul <sequential>)) (e* e*))
            (if (nul? e*)
                (rev! r)
                (loop (sequential (head e*) r) (tail e*)))))))

(dm transform-defs (e*|<lst> => <lst>)
  (if (nul? e*)
      '()
      (let ((e (head e*)))
        (if (sexpr-def? e)
            `((let ((,(sexpr-def-variable e) ,(sexpr-def-value e))) 
                ,@(transform-defs (tail e*))))
            `(,e ,@(transform-defs (tail e*)))))))

(dm objectify-sequential (e*|<lst> r tail? => <program>)
  (def asts 
    (rep loop ((res '()) (e* (transform-defs e*)))
      (if (nul? e*)
          (rev! res)
          (let ((tail? (if (nul? (tail e*)) tail? #f))
                (head  (objectify (head e*) r tail?)))
            (loop (pair head res) (tail e*))))))
  (sequentialize asts))

(dm objectify-application (ff|<ast-method> e* r tail? => <program>)
  (def ee* (convert2arguments (map (fun (e) (objectify e r #f)) e*)))
  (process-closed-application ff ee* r tail?))

;; TODO: USE THIS FOR PRIMITIVES

(dm objectify-application (ff|<predefined-reference> e* r tail? => <program>)
  (def ee*  (convert2arguments (map (fun (e) (objectify e r #f)) e*)))
  (def fvf  (reference-binding ff))
  (def prim (binding-prop fvf)) ;; only happens if inlineable
  (if prim
      (process-closed-application (ast-copy prim) ee* r tail?)
      (new <predefined-application> 
        application-binding   fvf
        application-arguments ee*
        application-tail?     tail?)))

(dm objectify-application (ff e* r tail? => <program>)
  (let ((ee* (convert2arguments (map (fun (e) (objectify e r #f)) e*))))
    ;; used for dynamic extent analysis
    (when (isa? ff <local-reference>)
      (set (reference-called-function? ff) #t))
    (new <regular-application> 
      application-function  ff
      application-arguments ee*
      application-tail?     tail?)))

(dm process-closed-application 
    (f|<ast-embodied-function> e* r tail? => <fix-let>)
  (def v* (function-bindings f))
  (def b  (function-body f))
  (if (function-nary? f)
      (process-nary-closed-application f e* r tail?)
      (if (= (len e*) (len (function-bindings f)))
          (new (if (isa? f <ast-primitive>) <low-let> <fix-let>)
            fix-let-bindings  (function-bindings f)
            fix-let-types     (function-specs f)
            fix-let-arguments e*
            fix-let-body      (function-body f))
          (ast-error "incorrect regular arity" f e*))))

(dm process-nary-closed-application (f e* r tail? => <fix-let>)
  (loc ((pack-args (e* v* t*)
          (def var (head v*))
          (if (binding-dotted? var)
              (let ((dotted-type (objectify '<tup> r #f)))
                (set (binding-dotted? var) #f)
                (set (binding-type var)    dotted-type)
                (set (head t*)             dotted-type)
                (arguments 
                 (objectify `(tup ,@e*) r #f) (nul <arguments>)))
              (if (nul? e*)
                  (ast-error "incorrect dotted arity" f e*)
                  (arguments 
                   (head e*) (pack-args (tail e*) (tail v*) (tail t*)))))))
   (def v* (function-bindings f))
   (def o  (new <fix-let> 
             fix-let-bindings  v*
             fix-let-types     (function-specs f)
             fix-let-arguments (pack-args e* v* (function-specs f))
             fix-let-body      (function-body f)))
   o))
 
(dm convert2arguments (e*|<lst> => <any>)
  (if (nul? e*)
      (nul <arguments>)
      (arguments (head e*) (convert2arguments (tail e*)))))

;;; assignment on mutable local bindings are immediately
;;; processed. references to local mutable bindings must wait the
;;; second pass.

(dm objectify-assignment (binding|<lst> e r tail? => <program>)
  (def op (sexpr-operator binding))
  (if (sexpr-variable? op)
      (objectify
       (sexpr-make-application
        (objectify (sexpr-fab-setter-name op) r #f) 
        (pair e (sexpr-operands binding)))
       r tail?)
      (syntax-error "Unsupported Set!: %=" e)))

(dm objectify-assignment (binding|<sym> e r tail? => <assignment>)
  (def ref (objectify binding r #f))
  (def val (objectify e r #f))
  (objectify-assignment-using ref val))

(dm objectify-assignment-using 
    (ref|<local-reference> val|<program> => <local-assignment>)
 (set (binding-mutable? (reference-binding ref)) #t)
 (new <local-assignment> 
   assignment-reference ref
   assignment-form      val))

(dm objectify-assignment-using 
    (ref|<global-reference> val|<program> => <global-assignment>)
 (new <global-assignment> 
   assignment-binding (reference-binding ref)
   assignment-form    val))

(dm objectify-assignment-using 
    (ref|<dynamic-reference> val|<program> => <global-assignment>)
 (new <dynamic-assignment> 
   assignment-binding (reference-binding ref)
   assignment-form    val))

(dm objectify-assignment-using 
    (ref|<runtime-reference> val|<program> => <runtime-assignment>)
 (new <runtime-assignment> 
   assignment-binding (reference-binding ref)
   assignment-form    val))

(dm objectify-assignment-using 
    (ref|<static-module-binding-reference> val|<program> => <any>)
  (namespace-error "Unable to assign to static module binding %="
                   (reference-binding ref)))

;;; TODO - Attempt to change the binding kind on the fly.  This
;;; only works up to a point.  To fix this, make 'runtime and 'global
;;; bindings a single binding type, and parameterize the storage
;;; used by that type at runtime.
;;; Rationale: calling ast-define-binding one or more times with
;;; various combinations of binding-kinds must never be able to
;;; transform a 'runtime binding into a 'global binding, and thereby
;;; confuse the compiler about where binding values are stored.
(df update-binding-kind (binding new-kind)
  (if (or (~== (binding-kind binding) 'runtime) (== new-kind 'magic))
      (set (binding-kind binding) new-kind)
      (cond
        ((== new-kind 'runtime) #t) ; We're already the correct type.
        ((== new-kind 'global) #t)  ; We're an acceptably close type.
        (#t (namespace-error "Cannot set type of runtime binding %s to %s.\n"
                             (binding-name binding) new-kind)))))

(dm ast-define-binding (r name defining-method? kind => <any>)
  (def existing-binding (find-binding name r))
  (def gr (find-static-global-environment r))
  (def mod (environment-module gr))
  (def binding
    (if existing-binding
        (let ((foreign?
                (not (or (binding-native-to? existing-binding mod)
                         defining-method?))))
          (if (binding-free? existing-binding)
              ;; If the binding is free, define it.
              (seq
                (set (binding-free? existing-binding) #f)
                (when foreign?
                  (transaction-register-implemented-binding
                   existing-binding)))
              ;; Otherwise, redefine the existing binding.
              ;; TODO - We should do more useful redefinition here.
              (when foreign?
                (msg out
                     "%s: warning: '%s' clobbers binding from %s.\n"
                     (module-name mod)
                     name
                     (binding-module-name existing-binding))))
          ;; Aggressively invalidate all dependents.  We might want to
          ;; make this more selective someday.
          (invalidate-dependents existing-binding $all-dependency-types)
          (update-binding-kind existing-binding kind)
          existing-binding)
        (let ((mod (find-environment-module r))
              (binding 
               (new <module-binding> 
                 binding-kind   kind
                 binding-name   name
                 binding-free?  #f
                 binding-module mod)))
          (insert-global! binding gr)
          binding)))
  (register-referenced-binding mod binding)
  binding)

(dv *macro-tracing?* #f)

(dm objectify-definition (type kind var e r => <any>)
  (def name
    (sexpr-variable-name var))
  (def binding 
    (ast-define-binding r name #f kind))
  (def defn
    (new type
      assignment-binding binding
      assignment-form (objectify e r #f)))
  defn)

(dm objectify-variable-definition (var e r => <any>)
  (objectify-definition <variable-definition> 'global var e r))

(dm objectify-dynamic-definition (var e r => <any>)
  (objectify-definition <dynamic-definition> 'dynamic var e r))

(df %%%macro (binding expander => <module-binding>)
    ;; (msg out "DEFMACRO ") (writeln out sep-expander)
    (loc ((expand (x r tail?)
            (when *macro-tracing?*
              (msg out "MACRO ") (write out x) (msg out "\n"))
            (def exp (line-list-of x (expander x)))
            (when *macro-tracing?*
              (msg out "  => ") (write out exp) (msg out "\n"))
            exp))
      ;; (msg out "DEFMAC %=\n" name)
      (set (binding-handler binding) expand)
      binding))

(df %%macro (modname name expander env-or-false => <any>)
  (def env     (or env-or-false (unchecked-runtime-environment modname)))
  (def binding (ast-define-binding env name #f 'macro))
  (%%%macro binding expander))

;; Process a macro definition.  This is somewhat ugly, because a single
;; macro definition may need to appear in as many as three places:
;;  1) The target environment, so it may be used by the program itself.
;;  2) The syntax environment, so it can be used to write other macros.
;;  3) The runtime environment *of the image we're building*.  This
;;     means that once our program has been compiled and run, macros
;;     should remain available in the listener.  This requires some magic,
;;     which is handled by <ast-macro-definition>.
;; XXX - This function has very ugly semantics, and I don't like it.
(dm objectify-syntax-definition (name e r rt? => <any>)
  (def sep-expander (sexpr-make-macro-function name e))
  ;; (post "%s %= ** %=\n" name e sep-expander)
  ;; Build a version of the macro for use in the target and syntax
  ;; environments.
  (def syntax-env   (find-syntax-environment r))
  (def ast-expander (objectify sep-expander syntax-env #f))
  (def expander     (ast-evaluate ast-expander))
  ;; Install it into the target environment.
  (def modname (module-name (find-environment-module r)))
  (def binding (%%macro modname name expander
                        (find-static-global-environment r)))

  ;; If the syntax and current environments are different (i.e., we're
  ;; compiling code), then install it in the syntax environment, too.
  (when (~== syntax-env (find-static-global-environment r))
    (insert-global! binding syntax-env))

  ;; If the macro should be available in the runtime of the image we're
  ;; building, work some magic.  Otherwise, just return false.
  (if rt?
      (new <ast-macro-definition> 
        assignment-binding binding
        assignment-form
          ;; Re-objectify the expander, this time using bindings from
          ;; the target environment.  This should allow it to be run
          ;; in the image (if we're reasonably lucky).
          (objectify sep-expander r #f))
      (objectify-quotation #f r)))
  
(dm objectify-function-definition (name mods e r => <ast-function-definition>)
  (def binding (ast-define-binding r name #f 'global))
  (def f       (objectify e r #f))
  (set (function-binding f)    binding)
  (set (function-adjectives f) mods)
  (set (function-debug-name f) (objectify-quotation name r))
  (def defn (new <ast-function-definition>
              assignment-binding binding assignment-form f))
  defn)

(df module-binding (kind|<sym> => <module-binding>)
  (new <module-binding> binding-kind kind))

(dm function-inlineable? (e|<ast-embodied-function>)
  (or (mem? (function-adjectives e) 'inline)
      (mem? (function-adjectives e) 'inline-c)))

(dm objectify-primitive-definition 
    (name mods sig body r => <ast-primitive-definition>)
  (def binding   (ast-define-binding r name #f 'predefined))
  (def signature (objectify-signature sig r))
  (def new-r     (r-extend* r (signature-bindings signature)))
  (def body      (objectify-sequential body new-r #t))
  (def form      (new <ast-primitive> 
                   function-binding    binding
                   function-adjectives mods
                   function-debug-name (objectify-quotation name r)
                   function-signature  signature
                   function-body       body))
  (when (mem? mods 'inline)
    (set (binding-prop binding) form))
  (def defn      (new <ast-primitive-definition>
                   assignment-binding binding
                   assignment-form form))
  defn)

(dm objectify-generic-definition (name sig r => <ast-generic-definition>)
  (def binding   (ast-define-binding r name #f 'global))
  (def signature (objectify-signature sig r))
  (def form      (new <ast-generic>
                   function-binding    binding
                   function-debug-name (objectify-quotation name r)
                   function-signature  signature))
  (def defn      (new <ast-generic-definition>
                   assignment-binding binding
                   assignment-form    form))
  defn)

(dm objectify-method-definition (name mods e r => <ast-method-definition>)
  (def binding (ast-define-binding r name #t 'global))
  (def gen    `(bound? ,name #f))
  (def met     (objectify e r #f))
  ;; TODO: NAME AND MARK AS GENERIC METHOD
  (def call    (lst '%define-method gen met))
  (def form    (objectify call r #f))
  (def defn    (new <ast-method-definition>
                 assignment-binding binding
                 assignment-form    form))
  (set (function-binding met)    name)
  (set (function-adjectives met) mods)
  (set (function-debug-name met) (objectify-quotation name r))
  defn)

;;; it is important that the body is objectified first so mutability
;;; of local bindings is known and they can be appropriately handled
;;; in objectify-bindings-list. 
;;; all bindings are considered immutable at the beginning.
;;; XXX - The dependency registration code here should be refactored and
;;; redesigned into something more reasonable.

(ddv *record-source?* #f)

(dm objectify-function-source (sig body r => <constant>)
  (dlet ((*max-print-depth*  $max-int)
         (*max-print-length* $max-int))
    (objectify-quotation
     (and *record-source?* (msg-to-str "%s" `(fun ,sig ,@body))) r)))

(dm objectify-function-using (met sig body r tail? => <ast-method>)
  ;; Allocate the method up front so we can log dependencies against it.
  (with-dependent met
    (def signature (objectify-signature sig r))
    (def new-r     (r-extend* r (signature-bindings signature)))
    (def ast       (objectify-sequential body new-r #t))
    (set (function-debug-name met) (objectify-quotation #f r))
    (set (function-signature met)  signature)
    (set (function-body met)       ast)
    (set (function-source met)     (objectify-function-source sig body r))
    met))

(dm objectify-function (sig body line r tail? => <ast-method>)
  (objectify-function-using 
   (new <ast-method> program-line line) sig body r tail?))
    
(dv $sexpr-optionals-tag       '...)
(dv $sexpr-optionals-type-name '<opts>)

(dm objectify-signature (sig r => <ast-signature>)
  (def sexpr-params (sexpr-signature-parameters sig))
  (rep col ((params sexpr-params) (nary? #f) (bindings '()) 
            (names (nul <fab-list>)) (types (nul <fab-list>)))
    (if (nul? params)
        (let ((sexpr-value (sexpr-signature-value sig))
              (value (objectify (or sexpr-value (default-type r)) r #f))
              (arity (- (len names) (if nary? 1 0))))
          (new <ast-signature>
            signature-bindings (rev! bindings)
            signature-names    (objectify-quotation (rev! names) r)
            signature-specs    (rev! types)
            signature-nary?    (objectify nary? r #f)
            signature-arity    (objectify arity r #f)
            signature-value    value))
        (let ((param   (head params))
              (sname   (sexpr-variable-name param))
              (stype   (sexpr-variable-type param))
              (dotted? (== stype $sexpr-optionals-tag))
              (stype   (if dotted? $sexpr-optionals-type-name stype))
              (type    (objectify stype r #f))
              (binding
               (new <local-binding>
                 binding-name sname
                 binding-type type
                 binding-dotted? dotted?)))
          (col (tail params) dotted? 
               (pair binding bindings)
               (new <fab-list> head sname tail names)
               (new <fab-list> head type  tail types))))))

(dm compute-local-reference-offsets 
    (binding|<local-binding> r|<static-local-environment> 
     => (tup frame-number|<int> frame-offset|<int>))
 (rep loop ((i 0) (r r))
   (if (isa? r <static-local-environment>)
       (rep find ((j 0) (bindings (environment-bindings r)))
         (if (nul? bindings)
             (loop (+ i 1) (environment-next r))
             (if (== (head bindings) binding)
                 (tup i j)
                 (find (+ j 1) (tail bindings)))))
       (namespace-error "didn't find local binding %= in %="
                        (binding-name binding) r))))

(dm objectify-binding (n b|<local-binding> r => <local-reference>)
  (def (tup i j) (compute-local-reference-offsets b r))
  (incf-ref-count (binding-value b))
  (new <local-reference>
    reference-binding      b
    reference-frame-number i
    reference-frame-offset j))

;; (dm objectify-binding 
;;     (n b|<next-methods-binding> r => <next-methods-reference>)
;;   (new <next-methods-reference> reference-binding b))

(dm binding-reference-class (b|<module-binding> => <type>)
  ;; TODO: => (T< <REFERENCE>)
  (case (binding-kind b)
    (('global)     <global-reference>)
    (('predefined) <predefined-reference>)
    (('runtime)    <runtime-reference>)
    (('dynamic)    <dynamic-reference>)
    (('macro)      <macro-reference>)
    (('magic)      <magic-reference>)
    (#t            (ast-error "Unknown binding-kind %=" (binding-kind b)))))

(dm objectify-binding (n b|<module-binding> r => <any>)
  (register-referenced-binding r b)
  (def <ref> (binding-reference-class b))
  (new <ref> reference-binding b))

;;  (case (binding-kind b)
;;     (('magic 'macro) b)
;;     (#t              (def <ref> (binding-reference-class b))
;;                      (new <ref> reference-binding b)))

(dm objectify-binding (n b r => <reference>)
  (objectify-free-global-reference n r))

;;; a free binding is defined to be a global binding defined on the fly.

(dm default-type (r) 
  (objectify '<Any> r #f))

;;; Handle variables which get used before we define them.
;;; TODO - Decide if this is the best place to handle foreign names.
(dm objectify-free-global-reference (name r => <reference>)
  (def gr (find-static-global-environment r))
  (if (and (environment-allows-foreign-names? gr)
           (foreign-name? name))
      (objectify-foreign-reference name r)
      (let ((b (new <module-binding>
                  binding-free?  #t
                  binding-kind   'global
                  binding-name   name
                  binding-module (find-environment-module r))))
        (insert-global! b gr)
        (register-referenced-binding gr b)
        (new <global-reference> reference-binding b))))

;;; Does this name have the form 'foo:bar'?
(df foreign-name? (name|<sym> => <log>)
  (~== (pos (as <str> name) #\:) #f))

;;; Turn 'foo:bar' into a reference to 'bar' in the 'foo' module.
(dm objectify-foreign-reference (name r => <reference>)
  (def namestr (as <str> name))
  (def break   (pos namestr #\:))
  (def modname (sub namestr 0 break))
  (def varname (sub namestr (+ 1 break) (len namestr)))
  (unless (and (> (len modname) 0) (> (len varname) 0))
    (syntax-error "Malformed foreign name %s.\n" name))
  (def gr      (find-static-global-environment r))
  (def loader  (environment-module-loader gr))
  (def mod     (probe-module loader (as <sym> modname)))
  (def binding (find-binding (as <sym> varname)
                             (module-target-environment mod)))
  ;; TODO: THIS MIGHT BE SUSPECT BUT IT MAKES DYN-CMP HAPPY
  (insert-global! binding gr)
  (unless binding
    (namespace-error "No binding %s in %s.\n" varname modname))
  (objectify-binding name binding r))

(dm objectify-symbol (name r => <any>)
  (objectify-binding name (find-binding name r) r))

(dm ftype (r)
  (objectify '<fun> r #f))

(def-programs functions)

(dm objectify-locals (names sigs bodies body r tail? => <locals>)
  (def vars  (map (fun (n) 
                    (new <local-binding> binding-name n binding-type (ftype r)))
                  names))
  (def new-r (r-extend* r vars))
  (def mets  (map2 (fun (sig body) 
                     (def line (or (line-of sig) (line-of body)))
                     (new <ast-method> program-line line))
                   sigs bodies))
  (for ((sig sigs) (body bodies) (met mets) (var vars))
    ;; TODO: CIRCULARITIES IN AST
    (set (binding-value var) met)
    (objectify-function-using met sig body new-r #f))
  (do2 (fun (f b) 
         (set (function-binding f) b)
         (set (function-debug-name f) 
              (objectify-quotation (binding-name b) r)))
       mets vars)
  (new <locals>
    locals-bindings  vars
    locals-functions (app fabs <functions> mets)
    locals-body      (objectify-sequential body new-r #t)))

(dm objectify-bind-exit (name body line r tail? => <bind-exit>)
  (new <bind-exit>
       bind-exit-main-fun 
        (objectify 
         (sexpr-make-anonymous-method (line-list line name) body) r #f)))

(dm objectify-unwind-protect
    (protected-form cleanup-forms line r tail? => <unwind-protect>)
  (new <unwind-protect>
       unwind-protect-protected-thunk
         (objectify
          (sexpr-make-anonymous-method '() (line-list line protected-form))
          r #f)
       unwind-protect-cleanup-thunk
         (objectify
          (sexpr-make-anonymous-method '() cleanup-forms)
          r #f)))

(dm objectify-monitor (type info test handler body r tail? => <monitor>)
  (new <monitor>
    monitor-type       (objectify type r #f)
    monitor-info       (objectify info r #f)
    monitor-test       (objectify test r #f)
    monitor-handler    (objectify handler r #f)
    monitor-main-thunk (objectify body r #f)))

(dm objectify-refs (e*|<lst> r => <any>)
  (if (nul? e*)
      (nul <inline-refs>)
      (inline-refs (objectify (head e*) r #f) (objectify-refs (tail e*) r))))

;; (dm split-c-inline-vals (vals|<lst>)
;;   (rep loop ((vals (tail vals)) (strs (lst (1st vals))) (refs '()))
;;     (if (nul? vals)
;;         (tup (rev! strs) (rev! refs))
;;         (loop (tail (tail vals)) 
;;               (add strs (2nd vals)) (add refs (1st vals))))))

(dm split-c-inline-vals (vals|<lst>)
  (rep loop ((vals vals) (strs '()) (refs '()))
    (if (nul? vals)
        (tup (rev! strs) (rev! refs))
        (let ((val (head vals)))
          (if (isa? val <str>)
              (loop (tail vals) (add strs val) refs)
              (loop (tail vals) (add strs #f)  (add refs val)))))))

(dm objectify-c-expr (x expr? r tail? => <program>)
  (let (((tup strs ref-strs) (split-c-inline-vals x))
	(refs                (objectify-refs ref-strs r)))
     (new <c-inline> 
       c-inline-refs refs c-inline-strs strs c-inline-expr? expr?)))


(dm objectify-c-inline (x r tail? => <program>)
  (def res (objectify-c-expr x #f r tail?))
  (if (isa? (environment-next r) <static-nul-environment>)
      (let ((module (find-environment-module r)))
        (push! (module-c-forms module) res)
        (objectify-quotation #f r))
      res))

(dm objectify-export (names r tail? => <program>)
  (def env (find-static-global-environment r))
  (def module (find-environment-module r))
  (unless (== env (module-target-environment module))
    ;; The user tried to export bindings from a syntax environment.
    ;; (This shouldn't happen, because we don't provide 'export'.)
    (namespace-error "Can only export bindings from target environment.\n"))
  (do (fun (name)
        (def binding (find-binding name env))
        (if (== binding #f)
            (esc exit
              (try ((type <restart>)
                    (description "Continue without exporting %s" name))
                (fun (c r) (exit #f))
                (namespace-error "Can't export undefined binding %s.\n" name)))
            (export-binding! module name binding)))
      names)
  (new <constant> constant-value #f))

(dm objectify-use/export-module (name r tail? => <program>)
  (def env (find-static-global-environment r))
  (def module (find-environment-module r))
  (def loader (environment-module-loader env))
  (def used-module (probe-module loader name))
  (push! (environment-uses-modules env) used-module)
  (do (fun (b)
        (import-global! b env)
        (export-binding! module (binding-name b) b))
      (module-exports used-module))
  (new <constant> constant-value #f))

(dm objectify-use-include (name r tail? => <program>)
  (def env (find-static-global-environment r))
  (def mod (environment-module env))
  (unless (any? (fun (x) (= x name)) (module-uses-c-includes mod))
    (push! (module-uses-c-includes mod) name))
  (new <constant> constant-value #f))

(dm objectify-use-library (name r tail? => <program>)
  (def env (find-static-global-environment r))
  (def mod (environment-module env))
  (unless (any? (fun (x) (= x name)) (module-uses-c-libraries mod))
    (push! (module-uses-c-libraries mod) name))
  (new <constant> constant-value #f))

(dm objectify-use-module (name r tail? => <program>)
  (def env (find-static-global-environment r))
  (def mod (environment-module env))
  (loc ((use-mod (name)
          (let ((loader (environment-module-loader env))
                (used-module (probe-module loader name)))
            (push! (environment-uses-modules env) used-module)
            (do (fun (b) (import-global! b env)) 
                (module-exports used-module))
            used-module))
        (use-c-mod (mod name)
          (unless (mem? (module-uses-c-files mod) name)
            (push! (module-uses-c-files mod) name))))
    (case-by (as <str> name) suffix?
      ((".c" ".h")  
       (use-c-mod mod (as <sym> name)))
      ((".swig")
       (def swig-mod-name (as <sym> (1st (split (as <str> name) #\.))))
       (def swig-mod (use-mod swig-mod-name))
       (use-c-mod swig-mod (cat-sym name ".c")))
      (#t
       (use-mod name))))
  (new <constant> constant-value #f))

(dm objectify-use-mangle-module (name mangler r tail? => <program>)
  (def env (find-static-global-environment r))
  (def module (find-environment-module r))
  (def loader (environment-module-loader env))
  (def used-module (probe-module loader name))
  (def str-mangler (as <str> mangler))
  (push! (environment-uses-modules env) used-module)
  
  (do (fun (b) 
        (import-and-mangle-global! b str-mangler env))
      (module-exports used-module))

  (new <constant> constant-value #f))

(dm expand-bind-list (pat var fail => <any>)
  (syntax-error "Expected Pattern List %=\n" pat))

(dm expand-bind-list ((pat (t= '())) var fail => <lst>)
  `(match-nul-list ,var ,fail))

(dm expand-bind-list (pat|<lst> var fail => <lst>)
  (cond
    ((sexpr-unquote? pat)
      (syntax-error "Unquote Unexpected Here %=\n" pat))
    ((sexpr-unquote-splicing? pat)
     (syntax-error "Unquote Splicing Unexpected Here %=\n" pat))
    (#t
     (expand-bind-list* pat var fail))))

(dm expand-bind-list* ((pat (t= '())) var fail => <any>)
  `(match-nul-list ,var ,fail))

(dm expand-bind-list* (pat|<lst> var fail => <any>)
  `(let ((,var ,(expand-bind-element (head pat) var fail)))
     ,(expand-bind-list* (tail pat) var fail)))

(dm expand-bind-element (pat var fail => <any>)
  `(match-atom ,var ',pat ,fail))

(dm expand-bind-element (pat|<lst> var fail => <any>)
  (cond
    ((sexpr-unquote? pat)
     `(seq (set ,(2nd pat) (match-unquote ,var ,fail)) (tail ,var)))
    ((sexpr-unquote-splicing? pat)
     `(seq (set ,(2nd pat) ,var) '()))
    (#t
     `(seq (let ((,var (match-sublist ,var ,fail)))
             ,(expand-bind-list pat var fail))
           (tail ,var)))))

(dm expand-pattern (pat|<lst> var fail => <any>)
  `(if (isa? ,var <lst>)
       ,(expand-bind-list pat var fail)
       (,fail "Match Pattern Failure" ,var)))

(dm expand-syntax-if (x|<lst> => <lst>)
  (def pat   (sexpr-syntax-if-pattern x))
  (def vars  (sexpr-bind-pattern-variables pat))
  (def value (sexpr-syntax-if-value x))
  (def then  (sexpr-syntax-if-then x))
  (def else  (sexpr-syntax-if-else x))
  (def var   (gensym))
  (def fail  (gensym))
  (def epat  (expand-pattern pat var fail))
  `(esc return
     (loc ((,fail ((msg <str>) (args ...)) (return ,else)))
       (let ((,var ,value))
         (let ,(map (fun (x) `(,x #f)) vars)
           ,epat
           ,then)))))

;;; AST ENVIRONMENT

;;; these functions deal with the environment.  r is a sequential of
;;; full-environment objects containing local bindings followed by an
;;; instance of environment followed by a sequential of full-environment
;;; containing the global mutable bindings mixed with the global
;;; macros followed by the predefined bindings.

(dm r-extend* (r bindings|<lst> => <static-environment>)
  (new <static-local-environment> 
    environment-next r environment-bindings bindings))

(dm find-binding (name r|<static-local-environment> => <any>)
  (rep loop ((bindings (environment-bindings r))) ;; TODO: => (or <binding> #f)
    (if (nul? bindings)
        (find-binding name (environment-next r))
        (if (== name (binding-name (head bindings)))
            (head bindings)
            (loop (tail bindings))))))

;; TODO: => T? <BINDING>

(dm find-binding (name r|<static-nul-environment> => <any>)
  #f)

;;;; SPECIAL FORMS

(dv *magic-bindings* '())

(dm register-magic-binding (name value)
  (set *magic-bindings* (add *magic-bindings* value)))

(dm magic-bindings ()
  *magic-bindings*)

(ds define-magic-binding (,name (,@params) ,@body)
  (let ((special-name (cat-sym "special-" name))
        (sexpr-name   (cat-sym "$sexpr-" name "-tag")))
    `(seq (dv ,special-name
            (new <module-binding>
              binding-kind    'magic
              binding-name    ,sexpr-name
              binding-module  #f
              binding-handler (fun (,@params) ,@body)
              binding-free?   #f))
          (register-magic-binding ',name ,special-name))))

(define-magic-binding if (x r tail?)
  (objectify-alternative
    (sexpr-if-test x) (sexpr-if-then x) (sexpr-if-else x) r tail?))

(define-magic-binding begin (x r tail?)
  (objectify-sequential (tail x) r tail?))

(dv $sexpr-%raw-tag '%raw)

(define-magic-binding %raw (x r tail?)
  (objectify-raw (2nd x) r))

(define-magic-binding quote (x r tail?)
  (objectify-quotation (sexpr-text-of-quotation x) r))

(define-magic-binding set (x r tail?)
  (objectify-assignment
    (sexpr-assignment-variable x) (sexpr-assignment-value x) r tail?))

(define-magic-binding define (x r tail?)
  (objectify-variable-definition
    (sexpr-definition-variable x) (sexpr-definition-value x) r))

(define-magic-binding define-constant (x r tail?)
  (objectify-variable-definition
    (sexpr-definition-variable x) (sexpr-definition-value x) r))

(dv $sexpr-define-dynamic-tag 'ddv)

(define-magic-binding define-dynamic (x r tail?)
  (objectify-dynamic-definition
    (sexpr-definition-variable x) (sexpr-definition-value x) r))

(define-magic-binding define-syntax (x r tail?)
  (objectify-syntax-definition
    (sexpr-syntax-definition-variable x) (sexpr-syntax-definition-value x) r #t))

(dv $sexpr-define-static-syntax-tag 'dss)

(define-magic-binding define-static-syntax (x r tail?)
  (objectify-syntax-definition
    (sexpr-syntax-definition-variable x) (sexpr-syntax-definition-value x) r #f))

(define-magic-binding define-method (x r tail?)
  (objectify-method-definition
    (sexpr-function-definition-variable x) 
    (sexpr-function-definition-adjectives x) 
    (sexpr-function-definition-value x) r))

(define-magic-binding define-generic (x r tail?)
  (objectify-generic-definition
    (sexpr-function-definition-variable x) (sexpr-function-signature x) r))

(define-magic-binding define-function (x r tail?)
  (objectify-function-definition
    (sexpr-function-definition-variable x) 
    (sexpr-function-definition-adjectives x) 
    (sexpr-function-definition-value x) r))

(define-magic-binding method (x r tail?)
  (objectify-function 
   (sexpr-method-signature x) (sexpr-method-body x) (line-of x) r tail?))

(dv $sexpr-bound?-tag 'bound?)

(define-magic-binding bound? (x r tail?)
  (objectify-bound? (2nd x) (3rd x) r tail?))

(define-magic-binding let (x r tail?)
  (objectify (sexpr-let->combination x) r tail?))

;; (define-magic-binding let (x r tail?)
;;   (objectify (sexpr-let-value x) r tail?))

(define-magic-binding def (x r tail?)
  (objectify (sexpr-def-value x) r tail?))

(define-magic-binding locals (x r tail?)
  (objectify-locals
    (sexpr-loc-bound-names x) (sexpr-loc-bound-signatures x) 
    (sexpr-loc-bound-bodies x) (sexpr-loc-raw-body x) r tail?))

(define-magic-binding iterate (x r tail?)
  (objectify (sexpr-iterate->loc x) r tail?))

(define-magic-binding bind-exit (x r tail?)
  (objectify-bind-exit 
   (sexpr-block-name x) (sexpr-block-body x) (line-of x) r tail?))

(define-magic-binding unwind-protect (x r tail?)
  (objectify-unwind-protect
    (sexpr-unwind-protect-protected-form x) 
    (sexpr-unwind-protect-cleanup-forms x)
    (line-of x) r tail?))

(define-magic-binding monitor (x r tail?)
  (def (tup type info test handler body) (sexpr-monitor-expand x))
  (objectify-monitor type info test handler body r tail?))

(dm pairize (args|<lst> => <any>)
  (if (nul? args)
      (lst 'quote '())
      (lst 'fab-pair (head args) (pairize (tail args)))))

(define-magic-binding define-class (x r tail?)
  (def name (sexpr-definition-variable x))
  (objectify-definition <variable-definition> 'global
   name `(fab-class ',name ,(pairize (sexpr-define-class-parents x))) r))
 
(dm objectify-define-property (x setter? r tail?)
  (def name        (sexpr-prop-name x))
  (def var         (sexpr-prop-init-var x))
  (def owner       (sexpr-prop-owner x))
  (def type        (sexpr-prop-type x))
  (def line        (line-of x))
  (def setter-name (and setter? (sexpr-fab-setter-name name)))
  (objectify
   (sexpr-make-begin
    (lst (sexpr-fab-getter name owner line)
         (and setter? (sexpr-fab-setter name owner type line))
         (sexpr-make-application
          '%prop
          (lst owner
               name setter-name type
               (if (sexpr-prop-init? x)
                   (sexpr-make-anonymous-method
                    `((,var <any>)) (line-list line (sexpr-prop-init x)))
                   '%prop-unbound-error)))))
   r tail?))

(define-magic-binding prop! (x r tail?)
  (objectify-define-property x #t r tail?))

(define-magic-binding prop (x r tail?)
  (objectify-define-property x #f r tail?))

(dv $sexpr-compile-time-tag 'ct)

(define-magic-binding compile-time (x r tail?)
  (objectify-compile-time (head (tail x)) r tail? #f))

(dv $sexpr-compile-time-also-tag 'ct-also)

(define-magic-binding compile-time-also (x r tail?)
  (objectify-compile-time (head (tail x)) r tail? #t))

(dv $sexpr-define-primitive-tag 'dl)

(define-magic-binding define-primitive (x r tail?)
  (if (sexpr-forward-primitive? x)
      (seq (ast-define-binding
            r (sexpr-function-definition-variable x) #f 'predefined)
           (objectify #f r tail?))
      (objectify-primitive-definition
       (sexpr-function-definition-variable x) 
       (sexpr-function-definition-adjectives x) 
       (sexpr-function-signature x) (sexpr-function-body x) r)))

(define-magic-binding quasiquote (x r tail?)
  (objectify (sexpr-expand-backquote x) r tail?))

(dm ast-macro-expand (x r tail?)
  (def ast (objectify (head x) r tail?))
  (if (isa? ast <macro-reference>)
      (let ((mac (reference-binding ast))
            (res ((binding-handler mac) x r tail?)))
              ;; (msg out "EXPANSION ") (write out res) (msg out "\n")
              res)
      #f))

(define-magic-binding macro-expand (x r tail?)
  (objectify-quotation
    (ast-macro-expand (2nd x) r tail?) r))

(define-magic-binding syntax-if (x r tail?)
  ;; (syntax-if (?pattern ?value) ?form ...)
  ;; x   => just matches etc
  ;; x  => binds x to an sexpr
  ;; @x => binds x to a series of sexprs
  ;; TODO: make this deals with multiple bindings
  (objectify (expand-syntax-if x) r tail?))

(dv $sexpr-export-tag 'export)

(define-magic-binding export (x r tail?)
  (objectify-export (tail x) r tail?))

(dv $sexpr-use-module-tag 'use)

(define-magic-binding use-module (x r tail?)
  (objectify-use-module (2nd x) r tail?))

(dv $sexpr-use-mangle-module-tag 'use/mangle)

(define-magic-binding use-mangle-module (x r tail?)
  (objectify-use-mangle-module (2nd x) r tail?))

(dv $sexpr-use-include-tag 'use/include)

(define-magic-binding use-include (x r tail?)
  (objectify-use-include (2nd x) r tail?))

(dv $sexpr-use-library-tag 'use/library)

(define-magic-binding use-library (x r tail?)
  (objectify-use-library (2nd x) r tail?))

(dv $sexpr-use/export-module-tag 'use/export)

(define-magic-binding use/export-module (x r tail?)
  (objectify-use/export-module (2nd x) r tail?))

(dv $sexpr-c-ment-tag 'c-ment)

(define-magic-binding c-ment (x r tail?)
  (objectify-c-inline (tail x) r tail?))

(dv $sexpr-c-expr-tag 'c-expr)

(define-magic-binding c-expr (x r tail?)
  (objectify-c-expr (tail x) #t r tail?))

;;;;=======================================================================
;;;;  Set Up Initial Environments for Objectification
;;;;=======================================================================
;;;;  To objectify code, we need to look up variables in a global
;;;;  environment.  Right now, there are several possible environments:
;;;;   
;;;;    1) The listener's module, known as the "runtime" module, contains
;;;;       one environment (which is used as both the syntax
;;;;       and the target environment) per module.
;;;;
;;;;    2) p2c sets up seperate syntax and target environments for each
;;;;       module it compiles.
;;;;       
;;;;       The syntax environments are stripped down versions of the
;;;;       runtime environment.  The compiler uses these environment to
;;;;       process CT and DS forms.  They contains most of the bindings in
;;;;       core goo, but not much else.
;;;;
;;;;       The target environments contain only a few bindings.  The
;;;;       initial bootstrap environments get initialized with a selection
;;;;       of <predefined-bindings>s and a few magic bindings like IF.
;;;;       The target environments of other modules are initially supplied
;;;;       with the magic bindings SEQ and USE, which are enough to allow
;;;;       them to import bindings from other modules.

;;; Copy the binding for 'use' into the module, so it can ask for more
;;; bindings as needed.  Copy 'seq', too, because the top-level of the
;;; file gets wrapped in it.
(dm install-initial-bindings (env|<static-global-environment>
                              loader|<module-loader>)
  (def bootmod (probe-module loader $goo-boot-module-name))
  (def bootenv (module-target-environment bootmod))
  (do (fun (name) (insert-global! (find-binding name bootenv) env))
      '(SEQ USE)))

(export install-initial-bindings)

;;; Objectify the specified code within a subtransaction associated
;;; with the appropriate module.
;;;
;;; XXX - It's not strictly correct to call this from the interpreter,
;;; because it will finalize the transaction as soon as the code
;;; is succcessfully objectified, but before it is run--and I'm not
;;; sure how we should handle rollbacks if part of the code is
;;; objectified but never executed.  Nonetheless, this is nearly
;;; correct, and probably good enough for now.
(df objectify-with-subtransaction 
    (e r|<static-environment> dynamic-compilation? tail? => <any>)
  (with-subtransaction ((environment-module r))
    (objectify e r tail?)))



;;; Change the type of the magic bindings in an environment, and install
;;; the right handlers.  We only need to do this for the boot environment,
;;; because all the other modules have already imported these same binding
;;; objects, as described in reloader-do-other-binding.
(df install-magic-bindings (env)
  (do
   (fun (binding)
     (def clone (ast-define-binding env (binding-name binding) #f 'magic))
     (set (binding-handler clone) (binding-handler binding)))
   (magic-bindings)))

;;; Reload the macros, and change their appropriate binding types.
(df reload-macros ()
  (do3 (rcurry %%macro #f)
       *boot-macro-module-names*
       *boot-macro-names*
       *boot-macro-expanders*)
  (set *macros-ok?* #t))

(df install-interpreter-hacks (env)
  (init-environment-for-eval env))

(df init-runtime ()
  (reload-modules)
  (def bootmod (probe-module (runtime-module-loader) $goo-boot-module-name))
  (def bootenv (module-target-environment bootmod))
  ;; We need to make a bunch of changes to bindings the boot module,
  ;; which will affect all the modules that use those bindings.
  (install-magic-bindings bootenv)
  (reload-macros)
  (install-interpreter-hacks bootenv)
  #f)


;;;;=======================================================================
;;;;  g2c Environments 
;;;;=======================================================================
;;;;  TODO - Figure out what APIs we should export to allow this code to
;;;;  live in g2c.

;; These bindings are initially available in CT and DS forms.
;; The section numbers refer to DOC/DOC.TXT.
(dv syntax-environment-excluded-bindings
  '(CT CT-ALSO DS USE EXPORT))

;; Create a new syntax environment for processing macros.
(df fab-syntax-environment (module|<module> => <static-global-environment>)
  (fab-subset-environment module
                          (runtime-module 'goo)
                          syntax-environment-excluded-bindings))

(df fab-g2c-module (loader|<module-loader> name|<sym> => <module>)
  (def type       (module-loader-module-type loader))
  (def module     (new type module-name name))
  (def syntax-env (fab-syntax-environment module))
  (def target-env (fab-static-global-environment module loader #f))
  (set-module-environments module syntax-env target-env)
  (if (== name $goo-boot-module-name)
      (init-g2c-boot-environment target-env)
      (init-g2c-regular-environment target-env loader))
  module)

(export fab-g2c-module)

(df init-g2c-boot-environment (env|<static-global-environment>)
  ;; Copy in just our macros, since everything else
  ;; must be defined by the program being compiled.  And don't bother
  ;; to call 'init-environment-for-eval'--this is a compile-only environment.
  (insert-globals! (magic-bindings) env))
  
(df init-g2c-regular-environment
    (env|<static-global-environment> loader|<module-loader>)
  (install-initial-bindings env loader))


;;;;=======================================================================
;;;;  Other Environment Code
;;;;=======================================================================

(df init-ast ()
  (init-runtime))


;;; MISC

(dm ast-contains-fun? (x|<ast-method> => <log>) 
  #t)

(dm ast-contains-fun? (x => <log>)
  (esc return
    (loc ((walk (y) (if (isa? y <ast-method>) (return #t) (ast-walk walk y))))
      (ast-walk walk x))
    #f))

;;;;=======================================================================
;;;;  Public API
;;;;=======================================================================

(need-implementation
  ast-evaluate
  init-environment-for-eval)

(export
  <alternative>
  alternative-alternant
  alternative-condition
  alternative-consequent
  <loop>
  loop-body     loop-body-setter
  loop-bindings loop-bindings-setter
  loop-continue loop-continue-setter
  <application>
  application-arguments
  application-binding
  application-function
  application-known?
  application-known?-setter
  application-tail?
  <loop-application>
  application-loop
  <fab-list>
  <arguments>
  <assignment>
  assignment-binding
  assignment-form
  assignment-form-setter
  assignment-reference
  ast-define-binding
  <ast-function>
  <ast-generic>
  <ast-macro-definition>
  <free-environment>
  free-environment
  <ast-embodied-function>
  <ast-method>
  function-ref-count function-ref-count-setter
  function-free 
  function-free-setter
  function-index
  function-index-setter
  function-source
  function-source-setter
  function-frame-len
  function-frame-len-setter
  function-temporaries
  function-temporaries-setter
  function-registers
  function-registers-setter
  <ast-primitive>
  <ast-primitive-definition>
  <bind-exit>
  bind-exit-main-fun
  bind-exit-light?
  binding-index
  binding-index-setter
  binding-mutable?
  binding-value
  binding-value-setter
  binding-dotted?
  binding-dotted?-setter
  binding-closed-over?
  binding-closed-over?-setter
  binding-dynamic-extent?
  binding-dynamic-extent?-setter
  <bound?>
  bound?-reference
  bound?-default
  <compile-time>
  compile-time-program
  <constant>
  <immediate-constant>
  constant-value
  constant-index
  <definition>
  <dynamic-definition>
  def-list
  def-programs
  <fix-let> <low-let>
  fix-let-arguments
  fix-let-arguments-setter
  fix-let-types
  fix-let-types-setter
  fix-let-bindings
  fix-let-bindings-setter
  fix-let-body
  fix-let-body-setter
  <ast-signature>
  signature-names
  signature-names-setter
  signature-bindings
  signature-bindings-setter
  signature-specs
  signature-specs-setter
  req-sig-specs
  signature-nary?
  signature-nary?-setter
  signature-arity
  signature-arity-setter
  signature-value
  signature-value-setter
  function-signature
  function-signature-setter
  function-bindings
  function-names
  function-body
  function-body-setter
  function-binding
  function-adjectives
  function-debug-name
  function-debug-name-setter
  function-nary?
  function-arity
  function-specs
  function-value
  function-loop function-loop-setter
  function-inlineable?
  <global-assignment>
  <module-binding-reference>
  <static-module-binding-reference>
  <global-reference>
  <dynamic-reference>
  <magic-reference>
  <macro-reference>
  init-ast
  <local-assignment>
  <local-binding>
  <local-reference>
  <locals>
  locals-bindings
  locals-bindings-setter
  locals-body
  locals-body-setter
  locals-functions
  locals-functions-setter
  %%macro %%%macro
  <monitor>
  monitor-handler
  monitor-info
  monitor-main-thunk
  monitor-test
  monitor-type
  objectify-with-subtransaction
  objectify-quotation
  objectify-signature
  <predefined-application>
  <program>
  <bot> $bot
  program-type
  program-type-setter
  program-line
  <computed-program>
  <passive-program>
  program-register program-register-setter
  <programs>
  as-lst
  <raw-constant>
  <real-reference>
  <reference>
  reference-binding
  reference-called-function?
  reference-called-function?-setter
  reference-frame-number
  reference-frame-offset
  <regular-application>
  <method-application>
    application-next-methods
  <runtime-assignment>
  <dynamic-assignment>
  <runtime-reference>
  <sequential>
  sequentialize
  <functions>
  <unwind-protect>
  unwind-protect-cleanup-thunk
  unwind-protect-protected-thunk
  ast-walk ast-walk!
  ast-error
  process-closed-application
  ast-contains-fun?
  <c-inline>
    c-inline-refs
    c-inline-strs
    c-inline-expr?
  )
