123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898 |
- /* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include <stdarg.h>
- #include "libguile/_scm.h"
- #include "libguile/eval.h"
- #include "libguile/smob.h"
- #include "libguile/procprop.h"
- #include "libguile/vectors.h"
- #include "libguile/hashtab.h"
- #include "libguile/struct.h"
- #include "libguile/variable.h"
- #include "libguile/fluids.h"
- #include "libguile/deprecation.h"
- #include "libguile/modules.h"
- int scm_module_system_booted_p = 0;
- scm_t_bits scm_module_tag;
- /* The current module, a fluid. */
- static SCM the_module;
- /* Most of the module system is implemented in Scheme. These bindings from
- boot-9 are needed to provide the Scheme interface. */
- static SCM the_root_module_var;
- static SCM module_make_local_var_x_var;
- static SCM define_module_star_var;
- static SCM process_use_modules_var;
- static SCM resolve_module_var;
- static SCM module_public_interface_var;
- static SCM module_export_x_var;
- static SCM default_duplicate_binding_procedures_var;
- /* The #:ensure keyword. */
- static SCM k_ensure;
- static SCM unbound_variable (const char *func, SCM sym)
- {
- scm_error (scm_from_latin1_symbol ("unbound-variable"), func,
- "Unbound variable: ~S", scm_list_1 (sym), SCM_BOOL_F);
- }
- SCM
- scm_the_root_module (void)
- {
- if (scm_module_system_booted_p)
- return SCM_VARIABLE_REF (the_root_module_var);
- else
- return SCM_BOOL_F;
- }
- SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
- (),
- "Return the current module.")
- #define FUNC_NAME s_scm_current_module
- {
- if (scm_module_system_booted_p)
- return scm_fluid_ref (the_module);
- else
- return SCM_BOOL_F;
- }
- #undef FUNC_NAME
- static void scm_post_boot_init_modules (void);
- SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
- (SCM module),
- "Set the current module to @var{module} and return\n"
- "the previous current module.")
- #define FUNC_NAME s_scm_set_current_module
- {
- SCM old;
- 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);
- return old;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
- (),
- "Return a specifier for the environment that contains\n"
- "implementation--defined bindings, typically a superset of those\n"
- "listed in the report. The intent is that this procedure will\n"
- "return the environment in which the implementation would\n"
- "evaluate expressions dynamically typed by the user.")
- #define FUNC_NAME s_scm_interaction_environment
- {
- return scm_current_module ();
- }
- #undef FUNC_NAME
- SCM
- scm_c_call_with_current_module (SCM module,
- SCM (*func)(void *), void *data)
- {
- return scm_c_with_fluid (the_module, module, func, data);
- }
- void
- scm_dynwind_current_module (SCM module)
- {
- scm_dynwind_fluid (the_module, module);
- }
- /*
- convert "A B C" to scheme list (A B C)
- */
- static SCM
- convert_module_name (const char *name)
- {
- SCM list = SCM_EOL;
- SCM *tail = &list;
- const char *ptr;
- while (*name)
- {
- while (*name == ' ')
- name++;
- ptr = name;
- while (*ptr && *ptr != ' ')
- ptr++;
- if (ptr > name)
- {
- SCM sym = scm_from_utf8_symboln (name, ptr-name);
- *tail = scm_cons (sym, SCM_EOL);
- tail = SCM_CDRLOC (*tail);
- }
- name = ptr;
- }
- return list;
- }
- SCM
- scm_c_resolve_module (const char *name)
- {
- return scm_resolve_module (convert_module_name (name));
- }
- SCM
- scm_resolve_module (SCM name)
- {
- return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
- }
- SCM
- scm_c_define_module (const char *name,
- void (*init)(void *), void *data)
- {
- SCM module = scm_call_1 (SCM_VARIABLE_REF (define_module_star_var),
- convert_module_name (name));
- if (init)
- scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
- return module;
- }
- void
- scm_c_use_module (const char *name)
- {
- scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
- scm_list_1 (scm_list_1 (convert_module_name (name))));
- }
- SCM
- scm_module_export (SCM module, SCM namelist)
- {
- return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
- module, namelist);
- }
- /*
- @code{scm_c_export}(@var{name-list})
- @code{scm_c_export} exports the named bindings from the current
- module, making them visible to users of the module. This function
- takes a list of string arguments, terminated by NULL, e.g.
- @example
- scm_c_export ("add-double-record", "bamboozle-money", NULL);
- @end example
- */
- void
- scm_c_export (const char *name, ...)
- {
- if (name)
- {
- va_list ap;
- SCM names = scm_cons (scm_from_utf8_symbol (name), SCM_EOL);
- SCM *tail = SCM_CDRLOC (names);
- va_start (ap, name);
- while (1)
- {
- const char *n = va_arg (ap, const char *);
- if (n == NULL)
- break;
- *tail = scm_cons (scm_from_utf8_symbol (n), SCM_EOL);
- tail = SCM_CDRLOC (*tail);
- }
- va_end (ap);
- scm_module_export (scm_current_module (), names);
- }
- }
- /*
- * C level implementation of the standard eval closure
- *
- * This increases loading speed substantially. The code may be
- * replaced by something based on environments.[ch], in a future
- * release.
- */
- /* Return the list of default duplicate binding handlers (procedures). */
- static inline SCM
- default_duplicate_binding_handlers (void)
- {
- SCM get_handlers;
- get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var);
- return (scm_call_0 (get_handlers));
- }
- /* Resolve the import of SYM in MODULE, where SYM is currently provided by
- both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
- duplicate binding handlers or `#f'. */
- static inline SCM
- resolve_duplicate_binding (SCM module, SCM sym,
- SCM iface1, SCM var1,
- SCM iface2, SCM var2)
- {
- SCM args[8];
- SCM handlers;
- SCM result = SCM_BOOL_F;
- if (scm_is_eq (var1, var2))
- return var1;
-
- args[0] = module;
- args[1] = sym;
- args[2] = iface1;
- args[3] = SCM_VARIABLE_REF (var1);
- if (SCM_UNBNDP (args[3]))
- args[3] = SCM_BOOL_F;
- args[4] = iface2;
- args[5] = SCM_VARIABLE_REF (var2);
- if (SCM_UNBNDP (args[5]))
- args[5] = SCM_BOOL_F;
- args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F);
- args[7] = SCM_BOOL_F;
-
- handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
- if (scm_is_false (handlers))
- handlers = default_duplicate_binding_handlers ();
- for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers))
- {
- if (scm_is_true (args[6]))
- {
- args[7] = SCM_VARIABLE_REF (args[6]);
- if (SCM_UNBNDP (args[7]))
- args[7] = SCM_BOOL_F;
- }
-
- result = scm_call_n (SCM_CAR (handlers), args, 8);
- if (scm_is_true (result))
- return result;
- }
- return SCM_BOOL_F;
- }
- /* No lock is needed for access to this variable, as there are no
- threads before modules are booted. */
- SCM scm_pre_modules_obarray;
- /* Lookup SYM as an imported variable of MODULE. */
- static inline SCM
- module_imported_variable (SCM module, SCM sym)
- {
- #define SCM_BOUND_THING_P scm_is_true
- register SCM var, imports;
- /* Search cached imported bindings. */
- imports = SCM_MODULE_IMPORT_OBARRAY (module);
- var = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
- if (SCM_BOUND_THING_P (var))
- return var;
- {
- /* Search the use list for yet uncached imported bindings, possibly
- resolving duplicates as needed and caching the result in the import
- obarray. */
- SCM uses;
- SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F;
- for (uses = SCM_MODULE_USES (module);
- scm_is_pair (uses);
- uses = SCM_CDR (uses))
- {
- SCM iface;
- iface = SCM_CAR (uses);
- var = scm_module_variable (iface, sym);
- if (SCM_BOUND_THING_P (var))
- {
- if (SCM_BOUND_THING_P (found_var))
- {
- /* SYM is a duplicate binding (imported more than once) so we
- need to resolve it. */
- found_var = resolve_duplicate_binding (module, sym,
- found_iface, found_var,
- iface, var);
- /* Note that it could be that FOUND_VAR doesn't belong
- either to FOUND_IFACE or to IFACE, if it was created
- by merge-generics. The right thing to do there would
- be to treat the import obarray as the iface, but the
- import obarray isn't actually a module. Oh well. */
- if (scm_is_eq (found_var, var))
- found_iface = iface;
- }
- else
- /* Keep track of the variable we found and check for other
- occurences of SYM in the use list. */
- found_var = var, found_iface = iface;
- }
- }
- if (SCM_BOUND_THING_P (found_var))
- {
- /* Save the lookup result for future reference. */
- (void) scm_hashq_set_x (imports, sym, found_var);
- return found_var;
- }
- }
- return SCM_BOOL_F;
- #undef SCM_BOUND_THING_P
- }
- SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
- (SCM module, SCM sym),
- "Return the variable bound to @var{sym} in @var{module}. Return "
- "@code{#f} is @var{sym} is not bound locally in @var{module}.")
- #define FUNC_NAME s_scm_module_local_variable
- {
- #define SCM_BOUND_THING_P(b) \
- (scm_is_true (b))
- register SCM b;
- if (scm_module_system_booted_p)
- SCM_VALIDATE_MODULE (1, module);
- SCM_VALIDATE_SYMBOL (2, sym);
- if (scm_is_false (module))
- return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
- /* 1. Check module obarray */
- b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
- if (SCM_BOUND_THING_P (b))
- return b;
- /* At this point we should just be able to return #f, but there is the
- possibility that a custom binder establishes a mapping for this
- variable.
- However a custom binder should be called only if there is no
- imported binding with the name SYM. So here instead of the order:
- 2. Search imported bindings. In order to be consistent with
- `module-variable', the binder gets called only when no
- imported binding matches SYM.
-
- 3. Query the custom binder.
- we first check if there is a binder at all, and if not, just return
- #f directly.
- */
- {
- SCM binder = SCM_MODULE_BINDER (module);
- if (scm_is_true (binder))
- {
- /* 2. */
- b = module_imported_variable (module, sym);
- if (SCM_BOUND_THING_P (b))
- return SCM_BOOL_F;
- /* 3. */
- b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
- if (SCM_BOUND_THING_P (b))
- return b;
- }
- }
- return SCM_BOOL_F;
- #undef SCM_BOUND_THING_P
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
- (SCM module, SCM sym),
- "Return the variable bound to @var{sym} in @var{module}. This "
- "may be both a local variable or an imported variable. Return "
- "@code{#f} is @var{sym} is not bound in @var{module}.")
- #define FUNC_NAME s_scm_module_variable
- {
- #define SCM_BOUND_THING_P(b) \
- (scm_is_true (b))
- register SCM var;
- if (scm_module_system_booted_p)
- SCM_VALIDATE_MODULE (1, module);
- SCM_VALIDATE_SYMBOL (2, sym);
- if (scm_is_false (module))
- return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
- /* 1. Check module obarray */
- var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
- if (SCM_BOUND_THING_P (var))
- return var;
- /* 2. Search among the imported variables. */
- var = module_imported_variable (module, sym);
- if (SCM_BOUND_THING_P (var))
- return var;
- {
- /* 3. Query the custom binder. */
- SCM binder;
- binder = SCM_MODULE_BINDER (module);
- if (scm_is_true (binder))
- {
- var = scm_call_3 (binder, module, sym, SCM_BOOL_F);
- if (SCM_BOUND_THING_P (var))
- return var;
- }
- }
- return SCM_BOOL_F;
- #undef SCM_BOUND_THING_P
- }
- #undef FUNC_NAME
- SCM
- scm_module_ensure_local_variable (SCM module, SCM sym)
- #define FUNC_NAME "module-ensure-local-variable"
- {
- if (SCM_LIKELY (scm_module_system_booted_p))
- {
- SCM_VALIDATE_MODULE (1, module);
- SCM_VALIDATE_SYMBOL (2, sym);
- return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
- module, sym);
- }
- {
- SCM handle, var;
- handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
- sym, SCM_BOOL_F);
- var = SCM_CDR (handle);
- if (scm_is_false (var))
- {
- var = scm_make_variable (SCM_UNDEFINED);
- SCM_SETCDR (handle, var);
- }
- return var;
- }
- }
- #undef FUNC_NAME
- SCM_SYMBOL (sym_macroexpand, "macroexpand");
- SCM_DEFINE (scm_module_transformer, "module-transformer", 1, 0, 0,
- (SCM module),
- "Returns the syntax expander for the given module.")
- #define FUNC_NAME s_scm_module_transformer
- {
- if (SCM_UNLIKELY (scm_is_false (module)))
- {
- SCM v = scm_hashq_ref (scm_pre_modules_obarray,
- sym_macroexpand,
- SCM_BOOL_F);
- if (scm_is_false (v))
- SCM_MISC_ERROR ("no module, and `macroexpand' unbound", SCM_EOL);
- return SCM_VARIABLE_REF (v);
- }
- else
- {
- SCM_VALIDATE_MODULE (SCM_ARG1, module);
- return SCM_MODULE_TRANSFORMER (module);
- }
- }
- #undef FUNC_NAME
- SCM
- scm_current_module_transformer ()
- {
- return scm_module_transformer (scm_current_module ());
- }
- SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
- (SCM module, SCM sym),
- "Return the module or interface from which @var{sym} is imported "
- "in @var{module}. If @var{sym} is not imported (i.e., it is not "
- "defined in @var{module} or it is a module-local binding instead "
- "of an imported one), then @code{#f} is returned.")
- #define FUNC_NAME s_scm_module_import_interface
- {
- SCM var, result = SCM_BOOL_F;
- SCM_VALIDATE_MODULE (1, module);
- SCM_VALIDATE_SYMBOL (2, sym);
- var = scm_module_variable (module, sym);
- if (scm_is_true (var))
- {
- /* Look for the module that provides VAR. */
- SCM local_var;
- local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
- SCM_UNDEFINED);
- if (scm_is_eq (local_var, var))
- result = module;
- else
- {
- /* Look for VAR among the used modules. */
- SCM uses, imported_var;
- for (uses = SCM_MODULE_USES (module);
- scm_is_pair (uses) && scm_is_false (result);
- uses = SCM_CDR (uses))
- {
- imported_var = scm_module_variable (SCM_CAR (uses), sym);
- if (scm_is_eq (imported_var, var))
- result = SCM_CAR (uses);
- }
- }
- }
- return result;
- }
- #undef FUNC_NAME
- SCM
- scm_module_public_interface (SCM module)
- {
- return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var), module);
- }
- SCM
- scm_c_module_lookup (SCM module, const char *name)
- {
- return scm_module_lookup (module, scm_from_utf8_symbol (name));
- }
- SCM
- scm_module_lookup (SCM module, SCM sym)
- #define FUNC_NAME "module-lookup"
- {
- SCM var;
- var = scm_module_variable (module, sym);
- if (scm_is_false (var))
- unbound_variable (FUNC_NAME, sym);
- return var;
- }
- #undef FUNC_NAME
- SCM
- scm_c_lookup (const char *name)
- {
- return scm_lookup (scm_from_utf8_symbol (name));
- }
- SCM
- scm_lookup (SCM sym)
- {
- return scm_module_lookup (scm_current_module (), sym);
- }
- SCM
- scm_public_variable (SCM module_name, SCM name)
- {
- SCM mod, iface;
-
- mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
- k_ensure, SCM_BOOL_F);
- if (scm_is_false (mod))
- scm_misc_error ("public-lookup", "Module named ~s does not exist",
- scm_list_1 (module_name));
-
- iface = scm_module_public_interface (mod);
- if (scm_is_false (iface))
- scm_misc_error ("public-lookup", "Module ~s has no public interface",
- scm_list_1 (mod));
-
- return scm_module_variable (iface, name);
- }
- SCM
- scm_private_variable (SCM module_name, SCM name)
- {
- SCM mod;
-
- mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
- k_ensure, SCM_BOOL_F);
- if (scm_is_false (mod))
- scm_misc_error ("private-lookup", "Module named ~s does not exist",
- scm_list_1 (module_name));
-
- return scm_module_variable (mod, name);
- }
- SCM
- scm_c_public_variable (const char *module_name, const char *name)
- {
- return scm_public_variable (convert_module_name (module_name),
- scm_from_utf8_symbol (name));
- }
- SCM
- scm_c_private_variable (const char *module_name, const char *name)
- {
- return scm_private_variable (convert_module_name (module_name),
- scm_from_utf8_symbol (name));
- }
- SCM
- scm_public_lookup (SCM module_name, SCM name)
- {
- SCM var;
-
- var = scm_public_variable (module_name, name);
- if (scm_is_false (var))
- scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s",
- scm_list_2 (name, module_name));
-
- return var;
- }
- SCM
- scm_private_lookup (SCM module_name, SCM name)
- {
- SCM var;
-
- var = scm_private_variable (module_name, name);
- if (scm_is_false (var))
- scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s",
- scm_list_2 (name, module_name));
-
- return var;
- }
- SCM
- scm_c_public_lookup (const char *module_name, const char *name)
- {
- return scm_public_lookup (convert_module_name (module_name),
- scm_from_utf8_symbol (name));
- }
- SCM
- scm_c_private_lookup (const char *module_name, const char *name)
- {
- return scm_private_lookup (convert_module_name (module_name),
- scm_from_utf8_symbol (name));
- }
- SCM
- scm_public_ref (SCM module_name, SCM name)
- {
- return scm_variable_ref (scm_public_lookup (module_name, name));
- }
- SCM
- scm_private_ref (SCM module_name, SCM name)
- {
- return scm_variable_ref (scm_private_lookup (module_name, name));
- }
- SCM
- scm_c_public_ref (const char *module_name, const char *name)
- {
- return scm_public_ref (convert_module_name (module_name),
- scm_from_utf8_symbol (name));
- }
- SCM
- scm_c_private_ref (const char *module_name, const char *name)
- {
- return scm_private_ref (convert_module_name (module_name),
- scm_from_utf8_symbol (name));
- }
- SCM
- scm_c_module_define (SCM module, const char *name, SCM value)
- {
- return scm_module_define (module, scm_from_utf8_symbol (name), value);
- }
- SCM
- scm_module_define (SCM module, SCM sym, SCM value)
- #define FUNC_NAME "module-define"
- {
- SCM var;
- var = scm_module_ensure_local_variable (module, sym);
- SCM_VARIABLE_SET (var, value);
- return var;
- }
- #undef FUNC_NAME
- SCM
- scm_c_define (const char *name, SCM value)
- {
- return scm_define (scm_from_utf8_symbol (name), value);
- }
- SCM_DEFINE (scm_define, "define!", 2, 0, 0,
- (SCM sym, SCM value),
- "Define @var{sym} to be @var{value} in the current module."
- "Returns the variable itself. Note that this is a procedure, "
- "not a macro.")
- #define FUNC_NAME s_scm_define
- {
- SCM_VALIDATE_SYMBOL (SCM_ARG1, sym);
- return scm_module_define (scm_current_module (), sym, value);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
- (SCM module, SCM variable),
- "Return the symbol under which @var{variable} is bound in "
- "@var{module} or @var{#f} if @var{variable} is not visible "
- "from @var{module}. If @var{module} is @code{#f}, then the "
- "pre-module obarray is used.")
- #define FUNC_NAME s_scm_module_reverse_lookup
- {
- SCM obarray;
- long i, n;
- if (scm_is_false (module))
- obarray = scm_pre_modules_obarray;
- else
- {
- SCM_VALIDATE_MODULE (1, module);
- obarray = SCM_MODULE_OBARRAY (module);
- }
- SCM_VALIDATE_VARIABLE (SCM_ARG2, variable);
- if (!SCM_HASHTABLE_P (obarray))
- return SCM_BOOL_F;
- /* 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_HASHTABLE_N_BUCKETS (obarray);
- for (i = 0; i < n; ++i)
- {
- SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
- while (!scm_is_null (ls))
- {
- handle = SCM_CAR (ls);
- if (scm_is_eq (SCM_CDR (handle), variable))
- return SCM_CAR (handle);
- ls = SCM_CDR (ls);
- }
- }
- if (!scm_is_false (module))
- {
- /* Try the `uses' list. */
- SCM uses = SCM_MODULE_USES (module);
- while (scm_is_pair (uses))
- {
- SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
- if (scm_is_true (sym))
- 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
- SCM_SYMBOL (scm_sym_system_module, "system-module");
- void
- scm_modules_prehistory ()
- {
- scm_pre_modules_obarray = scm_c_make_hash_table (1790);
- }
- void
- scm_init_modules ()
- {
- #include "libguile/modules.x"
- module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
- SCM_UNDEFINED);
- the_module = scm_make_fluid ();
- }
- static void
- scm_post_boot_init_modules ()
- {
- SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
- scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
- resolve_module_var = scm_c_lookup ("resolve-module");
- define_module_star_var = scm_c_lookup ("define-module*");
- process_use_modules_var = scm_c_lookup ("process-use-modules");
- module_export_x_var = scm_c_lookup ("module-export!");
- the_root_module_var = scm_c_lookup ("the-root-module");
- default_duplicate_binding_procedures_var =
- scm_c_lookup ("default-duplicate-binding-procedures");
- module_public_interface_var = scm_c_lookup ("module-public-interface");
- k_ensure = scm_from_locale_keyword ("ensure");
- scm_module_system_booted_p = 1;
- }
- /*
- Local Variables:
- c-file-style: "gnu"
- End:
- */
|