summaryrefslogtreecommitdiff
path: root/libguile/modules.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/modules.c')
-rw-r--r--libguile/modules.c339
1 files changed, 291 insertions, 48 deletions
diff --git a/libguile/modules.c b/libguile/modules.c
index 710adddc9..f889fe9aa 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -57,18 +57,20 @@
#include "libguile/modules.h"
-SCM scm_module_system_booted_p = 0;
+int scm_module_system_booted_p = 0;
SCM scm_module_tag;
-SCM scm_module_type;
-static SCM the_root_module;
+static SCM the_root_module_var;
static SCM root_module_lookup_closure;
SCM
scm_the_root_module ()
{
- return SCM_CDR (the_root_module);
+ if (scm_module_system_booted_p)
+ return SCM_VARIABLE_REF (the_root_module_var);
+ else
+ return SCM_BOOL_F;
}
static SCM the_module;
@@ -82,12 +84,7 @@ SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
}
#undef FUNC_NAME
-#define SCM_VALIDATE_STRUCT_TYPE(pos, v, type) \
- do { \
- SCM_ASSERT (SCM_NIMP (v) && SCM_NFALSEP (SCM_STRUCTP (v)) \
- && SCM_STRUCT_VTABLE (v) == (type), \
- v, pos, FUNC_NAME); \
- } while (0)
+static void scm_post_boot_init_modules (void);
SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
(SCM module),
@@ -97,21 +94,18 @@ SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
{
SCM old;
- /* XXX - we can not validate our argument when the module system
- hasn't been booted yet since we don't know the type. This
- should be fixed when we have a cleaner way of booting
- Guile.
- */
- if (scm_module_system_booted_p)
- SCM_VALIDATE_STRUCT_TYPE (SCM_ARG1, module, scm_module_type);
+ if (!scm_module_system_booted_p)
+ scm_post_boot_init_modules ();
+
+ SCM_VALIDATE_MODULE (SCM_ARG1, module);
old = scm_current_module ();
scm_fluid_set_x (the_module, module);
#if SCM_DEBUG_DEPRECATED == 0
- scm_fluid_set_x (SCM_CDR (scm_top_level_lookup_closure_var),
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_top_level_lookup_closure_var),
scm_current_module_lookup_closure ());
- scm_fluid_set_x (SCM_CDR (scm_system_transformer),
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_system_transformer),
scm_current_module_transformer ());
#endif
@@ -145,13 +139,13 @@ scm_module_full_name (SCM name)
return scm_append (SCM_LIST2 (module_prefix, name));
}
-static SCM make_modules_in;
-static SCM beautify_user_module_x;
+static SCM make_modules_in_var;
+static SCM beautify_user_module_x_var;
SCM
scm_make_module (SCM name)
{
- return scm_apply (SCM_CDR (make_modules_in),
+ return scm_apply (SCM_VARIABLE_REF (make_modules_in_var),
SCM_LIST2 (scm_the_root_module (),
scm_module_full_name (name)),
SCM_EOL);
@@ -160,14 +154,18 @@ scm_make_module (SCM name)
SCM
scm_ensure_user_module (SCM module)
{
- scm_apply (SCM_CDR (beautify_user_module_x), SCM_LIST1 (module), SCM_EOL);
+ scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var),
+ SCM_LIST1 (module), SCM_EOL);
return SCM_UNSPECIFIED;
}
SCM
scm_module_lookup_closure (SCM module)
{
- return SCM_MODULE_EVAL_CLOSURE (module);
+ if (module == SCM_BOOL_F)
+ return SCM_BOOL_F;
+ else
+ return SCM_MODULE_EVAL_CLOSURE (module);
}
SCM
@@ -182,7 +180,10 @@ scm_current_module_lookup_closure ()
SCM
scm_module_transformer (SCM module)
{
- return SCM_MODULE_TRANSFORMER (module);
+ if (module == SCM_BOOL_F)
+ return SCM_BOOL_F;
+ else
+ return SCM_MODULE_TRANSFORMER (module);
}
SCM
@@ -194,20 +195,22 @@ scm_current_module_transformer ()
return SCM_BOOL_F;
}
-static SCM resolve_module;
+static SCM resolve_module_var;
SCM
scm_resolve_module (SCM name)
{
- return scm_apply (SCM_CDR (resolve_module), SCM_LIST1 (name), SCM_EOL);
+ return scm_apply (SCM_VARIABLE_REF (resolve_module_var),
+ SCM_LIST1 (name), SCM_EOL);
}
-static SCM try_module_autoload;
+static SCM try_module_autoload_var;
SCM
scm_load_scheme_module (SCM name)
{
- return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL);
+ return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var),
+ SCM_LIST1 (name), SCM_EOL);
}
/* Environments */
@@ -234,6 +237,30 @@ scm_env_top_level (SCM env)
return SCM_BOOL_F;
}
+SCM_SYMBOL (sym_module, "module");
+
+SCM
+scm_lookup_closure_module (SCM proc)
+{
+ if (SCM_FALSEP (proc))
+ return scm_the_root_module ();
+ else if (SCM_EVAL_CLOSURE_P (proc))
+ return SCM_PACK (SCM_SMOB_DATA (proc));
+ else
+ {
+ SCM mod = scm_procedure_property (proc, sym_module);
+ if (mod == SCM_BOOL_F)
+ mod = scm_the_root_module ();
+ return mod;
+ }
+}
+
+SCM
+scm_env_module (SCM env)
+{
+ return scm_lookup_closure_module (scm_env_top_level (env));
+}
+
SCM_SYMBOL (scm_sym_system_module, "system-module");
@@ -256,7 +283,7 @@ scm_system_module_env_p (SCM env)
* The code will be replaced by the low-level environments in next release.
*/
-static SCM module_make_local_var_x;
+static SCM module_make_local_var_x_var;
static SCM
module_variable (SCM module, SCM sym)
@@ -293,6 +320,10 @@ module_variable (SCM module, SCM sym)
scm_bits_t scm_tc16_eval_closure;
+#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
+#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
+ (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
+
/* NOTE: This function may be called by a smob application
or from another C function directly. */
SCM
@@ -300,9 +331,13 @@ scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
{
SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
if (SCM_NFALSEP (definep))
- return scm_apply (SCM_CDR (module_make_local_var_x),
- SCM_LIST2 (module, sym),
- SCM_EOL);
+ {
+ if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
+ return SCM_BOOL_F;
+ return scm_apply (SCM_VARIABLE_REF (module_make_local_var_x_var),
+ SCM_LIST2 (module, sym),
+ SCM_EOL);
+ }
else
return module_variable (module, sym);
}
@@ -316,14 +351,222 @@ SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_standard_interface_eval_closure,
+ "standard-interface-eval-closure", 1, 0, 0,
+ (SCM module),
+ "Return a interface eval closure for the module @var{module}. "
+ "Such a closure does not allow new bindings to be added.")
+#define FUNC_NAME s_scm_standard_interface_eval_closure
+{
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
+ SCM_UNPACK (module));
+}
+#undef FUNC_NAME
+
+/* scm_sym2var
+ *
+ * looks up the variable bound to SYM according to PROC. PROC should be
+ * a `eval closure' of some module.
+ *
+ * When no binding exists, and DEFINEP is true, create a new binding
+ * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
+ * false and no binding exists.
+ *
+ * When PROC is `#f', it is ignored and the binding is searched for in
+ * the scm_pre_modules_obarray (a `eq' hash table).
+ */
+
+SCM scm_pre_modules_obarray;
+
+SCM
+scm_sym2var (SCM sym, SCM proc, SCM definep)
+#define FUNC_NAME "scm_sym2var"
+{
+ SCM var;
+
+ if (SCM_NIMP (proc))
+ {
+ if (SCM_EVAL_CLOSURE_P (proc))
+ {
+ /* Bypass evaluator in the standard case. */
+ var = scm_eval_closure_lookup (proc, sym, definep);
+ }
+ else
+ var = scm_apply (proc, sym, scm_cons (definep, scm_listofnull));
+ }
+ else
+ {
+ SCM handle;
+
+ if (definep == SCM_BOOL_F)
+ var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
+ else
+ {
+ handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
+ sym, SCM_BOOL_F);
+ var = SCM_CDR (handle);
+ if (var == SCM_BOOL_F)
+ {
+ var = scm_make_variable (SCM_UNDEFINED);
+#if SCM_ENABLE_VCELLS
+ scm_variable_set_name_hint (var, sym);
+#endif
+ SCM_SETCDR (handle, var);
+ }
+ }
+ }
+
+ if (var != SCM_BOOL_F && !SCM_VARIABLEP (var))
+ SCM_MISC_ERROR ("~S is not bound to a variable", SCM_LIST1 (sym));
+
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_module_lookup (SCM module, const char *name)
+{
+ return scm_module_lookup (module, scm_str2symbol (name));
+}
+
+SCM
+scm_module_lookup (SCM module, SCM sym)
+#define FUNC_NAME "module-lookup"
+{
+ SCM var;
+ SCM_VALIDATE_MODULE (1, module);
+
+ var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
+ if (SCM_FALSEP (var))
+ SCM_MISC_ERROR ("unbound variable: ~S", SCM_LIST1 (sym));
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_lookup (const char *name)
+{
+ return scm_lookup (scm_str2symbol (name));
+}
+
+SCM
+scm_lookup (SCM sym)
+{
+ SCM var =
+ scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
+ if (SCM_FALSEP (var))
+ scm_misc_error ("scm_lookup", "unbound variable: ~S", SCM_LIST1 (sym));
+ return var;
+}
+
+SCM
+scm_c_module_define (SCM module, const char *name, SCM value)
+{
+ return scm_module_define (module, scm_str2symbol (name), value);
+}
+
+SCM
+scm_module_define (SCM module, SCM sym, SCM value)
+#define FUNC_NAME "module-define"
+{
+ SCM var;
+ SCM_VALIDATE_MODULE (1, module);
+
+ var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, value);
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_define (const char *name, SCM value)
+{
+ return scm_define (scm_str2symbol (name), value);
+}
+
+SCM
+scm_define (SCM sym, SCM value)
+{
+ SCM var =
+ scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, value);
+ return var;
+}
+
+SCM
+scm_module_reverse_lookup (SCM module, SCM variable)
+#define FUNC_NAME "module-reverse-lookup"
+{
+ SCM obarray;
+ int i, n;
+
+ if (module == SCM_BOOL_F)
+ obarray = scm_pre_modules_obarray;
+ else
+ {
+ SCM_VALIDATE_MODULE (1, module);
+ obarray = SCM_MODULE_OBARRAY (module);
+ }
+
+ /* XXX - We do not use scm_hash_fold here to avoid searching the
+ whole obarray. We should have a scm_hash_find procedure. */
+
+ n = SCM_VECTOR_LENGTH (obarray);
+ for (i = 0; i < n; ++i)
+ {
+ SCM ls = SCM_VELTS (obarray)[i], handle;
+ while (!SCM_NULLP (ls))
+ {
+ handle = SCM_CAR (ls);
+ if (SCM_CDR (handle) == variable)
+ return SCM_CAR (handle);
+ ls = SCM_CDR (ls);
+ }
+ }
+
+ /* Try the `uses' list.
+ */
+ {
+ SCM uses = SCM_MODULE_USES (module);
+ while (SCM_CONSP (uses))
+ {
+ SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
+ if (sym != SCM_BOOL_F)
+ return sym;
+ uses = SCM_CDR (uses);
+ }
+ }
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
+ (),
+ "Return the obarray that is used for all new bindings before "
+ "the module system is booted. The first call to "
+ "@code{set-current-module} will boot the module system.")
+#define FUNC_NAME s_scm_get_pre_modules_obarray
+{
+ return scm_pre_modules_obarray;
+}
+#undef FUNC_NAME
+
+void
+scm_modules_prehistory ()
+{
+ scm_pre_modules_obarray
+ = scm_permanent_object (scm_c_make_hash_table (2001));
+}
+
void
scm_init_modules ()
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/modules.x"
#endif
- module_make_local_var_x = scm_sysintern ("module-make-local-var!",
- SCM_UNDEFINED);
+ module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
+ SCM_UNDEFINED);
scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
@@ -331,21 +574,21 @@ scm_init_modules ()
the_module = scm_permanent_object (scm_make_fluid ());
}
-void
+static void
scm_post_boot_init_modules ()
{
- scm_module_type =
- scm_permanent_object (SCM_CDR (scm_intern0 ("module-type")));
- scm_module_tag = (SCM_CELL_WORD_1 (scm_module_type) + scm_tc3_cons_gloc);
- module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app,
- scm_sym_modules));
- make_modules_in = scm_intern0 ("make-modules-in");
- beautify_user_module_x = scm_intern0 ("beautify-user-module!");
- the_root_module = scm_intern0 ("the-root-module");
- root_module_lookup_closure = scm_permanent_object
- (scm_module_lookup_closure (SCM_CDR (the_root_module)));
- resolve_module = scm_intern0 ("resolve-module");
- try_module_autoload = scm_intern0 ("try-module-autoload");
+#define PERM(x) scm_permanent_object(x)
+
+ SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
+ scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc);
+ module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules));
+ make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
+ beautify_user_module_x_var = PERM (scm_c_lookup ("beautify-user-module!"));
+ the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
+ root_module_lookup_closure =
+ PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var)));
+ resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
+ try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
scm_module_system_booted_p = 1;
}