;;;; Copyright (c) 2001 Jonathan Bachrach

(use goo)
(use goo/boot)
(use goo/types)
(use goo/sym)
(use goo/system)
(use eval/dependency)

(ddv *dynamic-compilation?* #f)

(dc <namespace-error> (<compiler-error> <simple-error>))

(dm namespace-error (msg|<str> args|...)
  (sig (new <namespace-error> 
         condition-message msg condition-arguments (as <lst> args))))

(export <namespace-error> namespace-error)

;;; The name of the module which contains all of goo's primitives,
;;; magic bindings, and core code.
(dv $goo-boot-module-name    'goo/boot)

;;; bindings are not programs! they represent bindings.

(dv <binding-name> <any>) ;; (type-union <sym> <int>)

(export <binding-name> *dynamic-compilation?*)

(dc <binding> (<any>))
  (dp! binding-name (<binding> => <binding-name>))
  (dp! binding-mangled-name (<binding> => (t? <str>)) #f)
  (dp! binding-type (<binding> => <any>))
  (dp! binding-inferred-type (<binding> => <any>) $bot)

;; Global boxes are used by the interpreter to store the values of
;; global variables.
(dc <global-box> (<any>))
  (dp! global-box-value (<global-box> => <any>))

(dc <module-binding> (<binding> <dependable>))
  ;; The name of the module in which this binding is defined.
  (dp! binding-kind (<module-binding> => <any>) 'global)
  (dp! binding-module (<module-binding> => <any>) #f) ;; (t? <module>))
  (dp! binding-free? (<module-binding> => <log>) #f)
  (dp! binding-info (<module-binding> => <any>)  #f)
  (dp! binding-prop (<module-binding> => <any>) #f)

(dm binding-module-name (b|<module-binding> => <sym>)
  (def mod (binding-module b))
  (if mod (module-name mod) $goo-boot-module-name))

;; TODO: GET RID OF ALIASES OR MAKE SEPARATE INFO OBJECT

(dv binding-global-box        binding-info)
(dv binding-global-box-setter binding-info-setter)
(dv binding-locative          binding-info)
(dv binding-locative-setter   binding-info-setter)
(dv binding-handler           binding-info)
(dv binding-handler-setter    binding-info-setter)

(export
  <binding>
  <module-binding>
  binding-kind binding-kind-setter
  binding-handler binding-handler-setter
  binding-prop binding-prop-setter
  binding-mangled-name binding-mangled-name-setter
  binding-global-box
  binding-global-box-setter
  binding-locative binding-locative-setter
  binding-module-name
  binding-module
  binding-name
  binding-free? binding-free?-setter
  binding-type binding-type-setter
  binding-inferred-type binding-inferred-type-setter
  binding-info binding-info-setter
  <global-box>
  global-box-value
  global-box-value-setter
  $goo-boot-module-name
)

;;; ENVIRONMENT

(dc <static-environment> (<any>))
  (dp! environment-next (<static-environment> => <any>) #f)
  (dp! environment-bindings (<static-environment> => <col>))

(dc <static-global-environment> (<static-environment>))
  ;; The module associated with this environment.
  (dp! environment-module (<static-global-environment> => <any>)) ;<module>
  ;; The module-loader which should be used to load new modules for
  ;; use by this environment.
  (dp! environment-module-loader (<static-global-environment> => <any>)) ;<module-loader>
  ;; The modules used by this environment.
  (dp! environment-uses-modules (<static-global-environment> => <vec>)
        (fab <vec> 0))
  ;; Does this environment allow cross-module resolution of symbols
  ;; of the form 'foo::bar'?
  (dp! environment-allows-foreign-names? (<static-global-environment> => <log>)
        #f)

(dc <static-nul-environment> (<static-environment>))

(dv $nul-static-environment (new <static-nul-environment>))

(dc <static-local-environment> (<static-environment>))

;; Given an object, try to find a global binding which contains it.
;; Used by the writer.
;; TODO - This will only work in the runtime environment, not any of the
;; various syntax environments.
;; XXX - This is now horrendously broken.
(dm env-object-name (x => <any>)
  (esc return
    (do-static-global-bindings
     (fun (binding)
       (when (and (== (binding-kind binding) 'global)
                  (binding-global-box binding)
                  (== x (global-box-value (binding-global-box binding))))
         (return (binding-name binding))))
     (runtime-environment 'goo/boot))
    #f))

;; TODO: CLEANUP

(dm frame-bindings (env|<static-environment> => <col>)
  ;; (as <lst> (map identity (environment-bindings env)))
  (environment-bindings env))

;; Given a static global environment 'env', apply 'f' to all the bindings.
(dm do-static-global-bindings (f|<fun> env|<static-global-environment>)
  (rep loop ((env env))
    (unless (isa? env <static-nul-environment>)
      (do f (frame-bindings env))
      (loop (environment-next env)))))

;; As above, but also supply the local name of the bindings.
(df do-named-static-global-bindings (f|<fun> env|<static-global-environment>)
  (rep loop ((env env))
    (unless (isa? env <static-nul-environment>)
      (do-keyed f (frame-bindings env))
      (loop (environment-next env)))))

(dm insert-global! (binding r)
  (def r|<static-global-environment> (find-static-global-environment r))
  (set (elt (environment-bindings r) (binding-name binding)) binding))

(dm insert-globals! (bindings|<lst> r) 
  (do (fun (b) (insert-global! b r)) bindings))

(dm find-static-global-environment 
    (r|<static-local-environment> => <static-global-environment>)
  (find-static-global-environment (environment-next r)))

(dm find-static-global-environment
    (r|<static-global-environment> => <static-global-environment>)
  r)

(dm find-syntax-environment (r|<static-environment>
                             => <static-global-environment>)
  (module-syntax-environment (find-environment-module r)))

(dm find-environment-module (r|<static-environment>) ; => <module>
  (environment-module (find-static-global-environment r)))

(dg find-binding (<binding-name> <static-environment>))

(dm find-binding (name r|<static-global-environment> => <any>) 
  (or (elt-or (environment-bindings r) name #f)
      (find-binding name (environment-next r))))

(export
  find-binding
  find-environment-module
  find-syntax-environment
  find-static-global-environment
  do-static-global-bindings
  do-named-static-global-bindings
  frame-bindings
  environment-bindings
  environment-module
  environment-next
  env-object-name
  environment-uses-modules
  <static-environment>
  <static-local-environment>
  <static-nul-environment>
  <static-global-environment>
  insert-global!
  insert-globals!
  environment-allows-foreign-names?
  environment-module-loader
)


;;;;=======================================================================
;;;;  Transaction Information
;;;;=======================================================================
;;;;  Compilation of a Goo expression has relatively few side effects.
;;;;  So if we want to get rid of some small chunk compiled code (perhaps
;;;;  an error occurred later in the compilation process, or p2c unloaded a
;;;;  module), we can let the garbage collector do most of the work.
;;;;
;;;;  There are a few exceptions:
;;;;    1) Imported free bindings may have been defined.  This hack
;;;;       is needed for the 'need-implementation' macro.
;;;;    2) Any number of dependencies may have been registered.
;;;;
;;;;  We need to take pains to undo these operations manually.  We *could*
;;;;  do this by building destructor functions for all the ast nodes, but
;;;;  that would be bletcherous, and require rewriting half the compiler.
;;;;
;;;;  Instead, we use a simple transaction mechanism.
;;;;
;;;;  Each module has an associated transaction.  If the module is unloaded,
;;;;  the module transaction must be rolled back.
;;;;
;;;;  Each invocation of the compiler has a "subtransaction".  If
;;;;  compilation succeeds, this is merged into the module transaction.  If
;;;;  compilation fails, it is rolled back.

(dc <transaction> (<any>))
  (dp  transaction-implemented-bindings (<transaction> => <tab>) (fab <tab> 10))
  (dp  transaction-dependents (<transaction> => <tab>) (fab <tab> 10))

(ddv *current-subtransaction* #f)

(df transaction-register-implemented-binding (b)
  (unless *current-subtransaction*
    (ast-error
     "Can't register implemented foreign binding (no subtransaction)"))
  (set (elt (transaction-implemented-bindings *current-subtransaction*) b) #t))

(df transaction-register-dependent (d|<dependent>)
  (unless *current-subtransaction*
    (ast-error "Can't register dependent (no subtransaction)"))
  (set (elt (transaction-dependents *current-subtransaction*) d) #t))

(df transaction-nul? (t|<transaction> => <log>)
  (and (nul? (transaction-implemented-bindings t))
       (nul? (transaction-dependents t))))

(df merge-transactions! (t1|<transaction> t2|<transaction> => <transaction>)
  (cond
    ;; If one of the transactions is nul, return the other.
    ((transaction-nul? t2) t1)
    ((transaction-nul? t1) t2)
    ;; Otherwise, merge t2 into t1 destructively.
    (#t
     (def t1-imp-bindings (transaction-implemented-bindings t1))
     (def t2-imp-bindings (transaction-implemented-bindings t2))
     (def t1-dependents   (transaction-dependents t1))
     (def t2-dependents   (transaction-dependents t2))
     (do-keyed (fun (k v) (set (elt t1-imp-bindings k) #t)) t2-imp-bindings)
     (do-keyed (fun (k v) (set (elt t1-dependents k) #t))   t2-dependents)
     t1)))

(df roll-back-transaction (t|<transaction>)
  (do-keyed
   (fun (binding junk) (set (binding-free? binding) #t))
   (transaction-implemented-bindings t))
  (do-keyed
   (fun (dependent junk) (detach-dependent dependent))
   (transaction-dependents t)))

(df call-with-subtransaction (module thunk => <any>)
  (def success? #f)
  (def saved    *current-subtransaction*)
  (fin
    { (set *current-subtransaction* (new <transaction>))
      (def value (thunk))
      (set success? #t)
      value }
    { (if success?
          (set (module-transaction module)
               (merge-transactions!
                (module-transaction module) *current-subtransaction*))
          (roll-back-transaction *current-subtransaction*))
      (set *current-subtransaction* saved) }))

(ds with-subtransaction ((,module) ,@body)
  `(call-with-subtransaction ,module (fun () ,@body)))
           
(export
  transaction-register-dependent
  transaction-register-implemented-binding
  call-with-subtransaction
  roll-back-transaction
  with-subtransaction
  *current-subtransaction*
  )


;;;;=======================================================================
;;;;  Module Loaders & Modules
;;;;=======================================================================
;;;;  A module contains two environments: a target environment, and a
;;;;  syntax environment.  The target environment is used for objectifying
;;;;  actual programs, and the syntax environment is used for objectifying
;;;;  DS, CT, DSS and any other compile-time forms.  In some cases, the
;;;;  syntax environment and the target environment might be the same.
;;;;
;;;;  See PROPOSALS/SIMPLE-MODULES.TXT for an overview of the module
;;;;  system from a programmer's perspective.
;;;;
;;;;  A <module-loader> loads modules from disk and keeps them in memory.
;;;;  There are typically several module loaders in use:
;;;;    1. A module loader for the running image's listener.
;;;;    2. A module loader for each program being compiled.

(dc <module-loader> (<any>))
  ;; A map from module names (represented as symbols) to
  ;; <module> objects.
  (dp! module-loader-modules (<module-loader> => <tab>) (fab <tab> 1000))
  ;; A stack of all the names of modules currently being loaded.
  ;; We use this to catch circular dependencies.
  (dp! module-loader-stack (<module-loader> => <lst>) '())

(export <module-loader>)

(dc <module> (<any>))
  (dp module-name (<module> => <sym>))
  (dp! module-mangled-name (<module> => (t? <str>)) #f)
  (dp! module-mangled-string-name (<module> => (t? <str>)) #f)
  ;; The environments associated with this module.
  (dp! module-target-environment (<module> => <any>))
  (dp! module-syntax-environment (<module> => <any>))
  ;; The bindings exported by this module.
  (dp %module-exports (<module> => <tab>)            (fab <tab> 1000))
  (dp! module-data-processed? (<module> => <log>)     #t)
  (dp! module-runtime-data (<module> => <any>)        #f)
  (dp! module-transaction (<module> => <transaction>) (new <transaction>))
  (dp module-referenced-bindings (<module> => <tab>) (fab <tab> 0))
  (dp module-uses-c-files (<module> => <vec>)        (fab <vec> 0))
  (dp module-c-forms (<module> => <vec>)             (fab <vec> 0))
  (dp module-uses-c-includes (<module> => <vec>)     (fab <vec> 0))
  (dp module-uses-c-libraries (<module> => <vec>)    (fab <vec> 0))

(dg ensure-module-data (module|<module>))

(dm module-exports (x|<module> => <tab>)
  (ensure-module-data x)
  (%module-exports x))

;;; This works like 'insert-global!', but it's more careful about clobbering.
(df import-global! (b|<module-binding> env|<static-global-environment>)
  (def existing (find-binding (binding-name b) env))
  (unless (or (== existing #f) (== existing b))
    (msg out "warning: '%s' from %s clobbers local binding.\n"
         (binding-name b) (binding-module-name b)))
  (insert-global! b env)
  #f)

(dm insert-and-mangle-global! (binding mangle-prefix|<str> r)
  (def r|<static-global-environment> (find-static-global-environment r))
  (set (elt (environment-bindings r)
            (cat-sym mangle-prefix (binding-name binding)))
       binding))

(df import-and-mangle-global!
    (b|<module-binding> mangle-prefix|<str> env|<static-global-environment>)
  (def existing (find-binding (cat-sym mangle-prefix (binding-name b)) env))
  (unless (or (== existing #f) (== existing b))
    (msg out "warning: '%s' from %s clobbers local binding.\n"
         (cat-sym mangle-prefix (binding-name b)) (binding-module-name b)))
  (insert-and-mangle-global! b mangle-prefix env)
  #f)

(export
  <module>
  module-name
  module-syntax-environment
  module-target-environment
  module-runtime-data module-runtime-data-setter
  module-data-processed? module-data-processed?-setter
  ensure-module-data
  module-loader-stack
  import-global!
  import-and-mangle-global!
  )

(df set-module-environments
  (mod|<module> syntax-env target-env)
  (set (module-syntax-environment mod) syntax-env)
  (set (module-target-environment mod) target-env))

;;; Call a function 'f' for each module associated with the module loader.
(df do-module-loader-modules (f loader)
  (do (fun (mod) (f mod))
      (module-loader-modules loader)))

;; Create an nul module for use with a particular loader.
;; Override this method to use a custom module class.
(dm module-loader-module-type (loader|<module-loader> => <type>)
  <module>)

;;; Add a module to a module-loader.
(df register-module!
    (module-loader|<module-loader> mod|<module> => <module-loader>)
  (set (elt (module-loader-modules module-loader) (module-name mod)) mod)
  module-loader)

;;; Find the module with the given name, loading it if necessary.
(df probe-module (loader|<module-loader> name|<sym> => <module>)
  (or (elt-or (module-loader-modules loader) name #f)
      (load-and-register-module loader name)))

;;; This function keeps track of nesting and registration.
(df load-and-register-module (loader|<module-loader> name|<sym> => <module>)
  (def stack  (module-loader-stack loader))
  (def depth  (len stack))
  (def indent (repeat "  " depth))
  
  ;; First, make sure we aren't already loading this module.
  (when (mem? stack name)
    (namespace-error "%s: error: Circular use of %s not allowed"
                     (head stack) name))

  ;; Load the module, using a FIN form to manage the load stack.
  ;; XXX - If an error occurs, we currently neglect to mark
  ;; the environment-implements bindings of the half-created
  ;; module as free.
  (msg out "%s[Loading module %s...\n" indent name) 
  (def mod (seq (pushf (module-loader-stack loader) name)
                (fin (load-module loader name)
                     (popf (module-loader-stack loader)))))
  (register-module! loader mod)
  (msg out "%s]\n" indent)
  mod)

;;; Create a <module-loader> subclass and override this method.  It should
;;; create and register a module, call 'read-file', objectify the code in
;;; the module's target environment, and do something appropriate with the
;;; resulting ast.
;;;
;;; TODO - Block recursive loads.
;;; TODO - We must eventually be able to support runtime modules, too.
;;; this may require a fair bit of refactoring.
(dg load-module (loader|<module-loader> name|<sym> => <module>))

;;; Export a binding from a module.
(df export-binding! (module|<module> name|<binding-name> binding => (t= #f))
  (def exports (module-exports module))
  (def existing (elt-or exports name #f))
  (unless (or (== existing #f) (== existing binding))
    (namespace-error "Tried to export %= and %= from %= as %="
                     existing binding module name))
  (set (elt exports name) binding)
  #f)


(export 
  register-module!
  export-binding!)

;;; Return true iff a binding was originally defined in the current module.
(df binding-native-to? (binding module|<module> => <log>)
  (== (module-name module) (binding-module-name binding)))

;;; Report all the undefined bindings in the specified module.
(df report-undefined-global-bindings (mod|<module>)
  (do-static-global-bindings
   (fun (binding)
     (when (and (binding-free? binding)
                (binding-native-to? binding mod))
       (msg out "%s: warning: undefined binding '%s'.\n"
            (module-name mod)
            (binding-name binding))))
   (module-target-environment mod)))

;;; Compute all the modules which use the specified modules, directly or
;;; indirectly.  Yes, this function is slow and ugly.
(df compute-transitive-users
    (loader|<module-loader> modnames|<lst> => <lst>)
  (def users (fab <tab> 100))
  (loc ((add-user (modname)
          (unless (elt-or users modname #f)
            (set (elt users modname) modname)
            (do-module-loader-modules
             (fun (mod)
               (do
                (fun (uses-mod)
                  (when (== modname (module-name uses-mod))
                    (add-user (module-name mod))))
                (environment-uses-modules (module-target-environment mod))))
             loader))))
    (do add-user modnames)
    (packing () (do (fun (v) (pack v)) users))))

;;; Remove a single module object from the loader.
;;; This should not be called externally, because it does not bother to
;;; remove other modules which use this one.
(df remove-module-internal! (loader|<module-loader> mod|<module>)
  (roll-back-transaction (module-transaction mod))
  (del! (module-loader-modules loader) (module-name mod)))

;;; Unload all the named modules, and all the modules which use them.
(df remove-modules-by-name! (loader|<module-loader> modnames|<lst> => (t= #f))
  (def remove-names (compute-transitive-users loader modnames))
  (do (fun (modname)
        (def mod (elt (module-loader-modules loader) modname))
        (remove-module-internal! loader mod))
      remove-names)
  #f)

;;; Convert a module name to a relative path name.
;;;   foo/bar => "foo/bar" or "foo\\bar", etc.
(df module-name-to-relpath (name|<sym> => <str>)
  (def namestr (map to-lower (sym-name name)))
  (join (split namestr #\/) *path-separator*))

(dv *tracing-refs?* #f)

(dm zap-referenced-bindings! (mod|<module>)
  (when *tracing-refs?* 
    (post "ZAPPING REFS\n"))
  (zap! (module-referenced-bindings mod)))

(dm zap-referenced-bindings! (r)
  (zap-referenced-bindings! 
   (environment-module (find-static-global-environment r))))

(dm register-referenced-binding (mod|<module> b)
  (when *tracing-refs?* 
    (post "REG %= %=\n" (binding-name b) *dynamic-compilation?*))
  (when *dynamic-compilation?*
    (set (elt (module-referenced-bindings mod) b) b)))

(dm register-referenced-binding (r b)
  (when *dynamic-compilation?*
    (register-referenced-binding 
     (environment-module (find-static-global-environment r)) b)))

(export
  module-name
  module-mangled-name module-mangled-name-setter
  module-mangled-string-name module-mangled-string-name-setter
  module-exports
  module-uses-c-files
  module-uses-c-includes
  module-uses-c-libraries
  module-c-forms
  module-transaction
  register-referenced-binding
  zap-referenced-bindings!
  module-referenced-bindings
  set-module-environments
  module-loader-module-type
  do-module-loader-modules
  probe-module
  load-module
  binding-native-to?
  report-undefined-global-bindings
  remove-modules-by-name!
  module-name-to-relpath
)

;;;;=======================================================================
;;;;  Runtime Setup
;;;;=======================================================================
;;;;  Recover information about the modules and bindings that were built
;;;;  into our image.  This mostly involves calling build-runtime-modules
;;;;  and passing it an appropriate set of functions, then doing a small
;;;;  amount of tweaking to set up macros, magic bindings, and other
;;;;  stuff correctly.

(dc <runtime-module-loader> (<module-loader>))

(ddv *now-rt-env* #f)

(dg install-initial-bindings (<static-global-environment> <module-loader>))

;;; This is called if somebody tries to load a module at runtime which
;;; hadn't been built into the image.
(dm load-module (loader|<runtime-module-loader> name|<sym> => <module>)
  (def type       (module-loader-module-type loader))
  (def module     (new type module-name name))
  (def env        (fab-static-global-environment module loader #f))
  (def keepmod?   #f)
  (def modpath    (module-name-to-relpath name))
  (def file       (find-goo-file-in-path modpath *module-search-path*))
  (set-module-environments module env env)
  (if (not file)
      (namespace-error "Unable to find module %s" modpath))
  (fin
    (seq
      (install-initial-bindings env loader)
      (dlet ((*now-rt-env* env))
        (load-in file env))
      ;; Turn on foreign name support once the code has been loaded.
      (set (environment-allows-foreign-names? env) #t)
      (set keepmod? #t)
      module)
        ;;; Tricky unwind handler.  Our module may have altered the the state
        ;;; of other modules, and so we need to back these changes out if we
        ;;; crash midway.  This would look much nicer if we had some kind of
        ;;; try/catch/rethrow construct.
        ;;; TODO - This is much less necessary than before, since we already
        ;;; handle rollbacks for the actual compilation process using a
        ;;; subtransaction.  But there may still be errors /executing/
        ;;; the code, and we choose to apply a module rollback if that code
        ;;; fails.  Is this the right thing?  Hmmm.
    (unless keepmod?
      (roll-back-transaction (module-transaction module)))))
      
(need-implementation load-in)

(dv *runtime-module-loader* (new <runtime-module-loader>))
(df runtime-module-loader () *runtime-module-loader*)
(df runtime-module (modname|<sym>)
  (probe-module (runtime-module-loader) modname))
(df runtime-environment (modname|<sym>)
  (def module (runtime-module modname))
  (ensure-module-data module)
  (module-target-environment module))
(df runtime-core-environment (modname|<sym>)
  (module-target-environment (runtime-module modname)))
(df unchecked-runtime-environment (modname|<sym>)
  (def loader (runtime-module-loader))
  (if (== (elt-or (module-loader-stack loader) 0 #f) modname)
      *now-rt-env*
      (module-target-environment (runtime-module modname))))

;;; RELOADER METHODS FOR %BUILD-RUNTIME-MODULES
;;; These are called to reload modules which were compiled into our runtime.

(df reloader-do-create-module (modname|<str> data => <module>)
  (def loader (runtime-module-loader))
  (def type   (module-loader-module-type loader))
  (def mod    (new type module-name (as <sym> modname)))
  (def env    (fab-static-global-environment mod loader #t))
  (set (module-data-processed? mod) #f)
  (set-module-environments mod env env)
  (set (module-runtime-data mod) data)
  (register-module! loader mod)
  mod)

(df reloader-do-use-module (mod|<module> uses|<module>)
  (push! (environment-uses-modules (module-target-environment mod)) uses))

(df reloader-do-import (mod|<module> name|<str>
                        from-mod|<module> original-name|<str>)
  (def home-env (module-target-environment from-mod))
  (def binding  (find-binding (as <sym> original-name) home-env))
  ;; TODO - Add support for using 'name'.
  (when (not binding)
    (namespace-error "Can't find %s from %s for %s\n"
                     original-name (module-name from-mod) (module-name mod)))
  (insert-global! binding (module-target-environment mod)))

(df process-module-data (module|<module>)
  (%process-module 
   (module-runtime-data module) 
   reloader-do-import reloader-do-export))

(dm ensure-module-data (module|<module>)
  (unless (module-data-processed? module)
    ;; TODO: DETECT CIRCULARITIES?
    (set (module-data-processed? module) #t)
    (process-module-data module)))

(df reloader-do-runtime-binding (mod|<module> name|<str> loc|<loc>)
  (def binding (new <module-binding>
                 binding-kind     'runtime
                 binding-module   mod
                 binding-name     (as <sym> name)
                 binding-free?    #f
                 binding-locative loc))
  (insert-global! binding (module-target-environment mod)))

(df reloader-do-dynamic-binding (mod|<module> name|<str> loc|<loc>)
  (def binding (new <module-binding>
                 binding-kind     'dynamic
                 binding-module   mod
                 binding-name     (as <sym> name)
                 binding-free?    #f
                 binding-locative loc))
  (insert-global! binding (module-target-environment mod)))

;;; We create all non-runtime bindings with type 'global', so we have
;;; something to export and import while rebuilding the module structure.
;;; Later on, we'll need to update these bindings and change
;;; their types using ast-define-binding.
(df reloader-do-other-binding (mod|<module> name|<str>)
  (def binding (new <module-binding>
                 binding-kind   'predefined ;; HACK: JB
                 binding-module mod
                 binding-name   (as <sym> name)
                 binding-free?  #t))
  (insert-global! binding (module-target-environment mod)))

(df reloader-do-export (mod|<module> name|<str> as-name|<str>)
  (def binding (find-binding (as <sym> name) (module-target-environment mod)))
  (if binding
      (export-binding! mod (as <sym> as-name) binding)
      (namespace-error "Can't find %s in %s\n" name (module-name mod))))


(df reload-modules ()
  (%build-runtime-modules 
   reloader-do-create-module reloader-do-use-module
   reloader-do-runtime-binding reloader-do-other-binding
   reloader-do-dynamic-binding))

;; Create a new global environment.
(df fab-static-global-environment 
  (module|<module> module-loader|<module-loader> allow-foreign-names?|<log>
   => <static-global-environment>)
  (def new-env (new <static-global-environment>
                 environment-module module
                 environment-module-loader module-loader
                 environment-next $nul-static-environment
                 environment-allows-foreign-names? allow-foreign-names?
                 environment-bindings (fab <tab> 2000)))
  new-env)

;; Given an environment and a list of symbols, return a new environment
;; containing all the bindings in the original environment that are *not*
;; named by a symbol in 'excluded'.
(df fab-subset-environment (module|<module> src-module|<module> excluded|<col>
                            => <static-global-environment>)
  (def loader
    (environment-module-loader (module-target-environment src-module)))
  (def new-env
    (fab-static-global-environment module loader #f))
  (do-keyed
   (fun (name binding)
     (unless (mem? excluded name)
       ;; TODO - Renaming: Honor name.
       (insert-global! binding new-env)))
   (module-exports src-module))
  new-env)

(df walk-bindings (fun|<fun> mod|<sym>)
  (walk-bindings* 
   fun (runtime-environment mod) (fab <tab> 1000) (fab <tab> 10)))

(df walk-bindings* 
    (f|<fun> env|<static-global-environment> walked?|<tab> mods|<tab>)
  (for ((mod (environment-uses-modules env)))
    (unless (elt-or mods mod #f)
      (set (elt mods mod) #t)
      (walk-bindings* f (runtime-environment (module-name mod)) walked? mods)))
  (for ((b (environment-bindings env)))
    (unless (elt-or walked? b #f)
      (set (elt walked? b) #t)
      (f b))))

(export
  runtime-environment
  unchecked-runtime-environment
  install-initial-bindings
  runtime-module
  runtime-module-loader
  reload-modules
  fab-static-global-environment
  fab-subset-environment
  walk-bindings
)
