1 /* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "libguile/_scm.h"
29 #include "libguile/eval.h"
30 #include "libguile/smob.h"
31 #include "libguile/procprop.h"
32 #include "libguile/vectors.h"
33 #include "libguile/hashtab.h"
34 #include "libguile/struct.h"
35 #include "libguile/variable.h"
36 #include "libguile/fluids.h"
37 #include "libguile/deprecation.h"
39 #include "libguile/modules.h"
41 int scm_module_system_booted_p
= 0;
43 scm_t_bits scm_module_tag
;
45 /* The current module, a fluid. */
46 static SCM the_module
;
48 /* Most of the module system is implemented in Scheme. These bindings from
49 boot-9 are needed to provide the Scheme interface. */
50 static SCM the_root_module_var
;
51 static SCM module_make_local_var_x_var
;
52 static SCM define_module_star_var
;
53 static SCM process_use_modules_var
;
54 static SCM resolve_module_var
;
55 static SCM module_public_interface_var
;
56 static SCM module_export_x_var
;
57 static SCM default_duplicate_binding_procedures_var
;
59 /* The #:ensure keyword. */
63 static SCM
unbound_variable (const char *func
, SCM sym
)
65 scm_error (scm_from_latin1_symbol ("unbound-variable"), func
,
66 "Unbound variable: ~S", scm_list_1 (sym
), SCM_BOOL_F
);
70 scm_the_root_module (void)
72 if (scm_module_system_booted_p
)
73 return SCM_VARIABLE_REF (the_root_module_var
);
78 SCM_DEFINE (scm_current_module
, "current-module", 0, 0, 0,
80 "Return the current module.")
81 #define FUNC_NAME s_scm_current_module
83 SCM curr
= scm_fluid_ref (the_module
);
85 return scm_is_true (curr
) ? curr
: scm_the_root_module ();
89 static void scm_post_boot_init_modules (void);
91 SCM_DEFINE (scm_set_current_module
, "set-current-module", 1, 0, 0,
93 "Set the current module to @var{module} and return\n"
94 "the previous current module.")
95 #define FUNC_NAME s_scm_set_current_module
99 if (!scm_module_system_booted_p
)
100 scm_post_boot_init_modules ();
102 SCM_VALIDATE_MODULE (SCM_ARG1
, module
);
104 old
= scm_current_module ();
105 scm_fluid_set_x (the_module
, module
);
111 SCM_DEFINE (scm_interaction_environment
, "interaction-environment", 0, 0, 0,
113 "Return a specifier for the environment that contains\n"
114 "implementation--defined bindings, typically a superset of those\n"
115 "listed in the report. The intent is that this procedure will\n"
116 "return the environment in which the implementation would\n"
117 "evaluate expressions dynamically typed by the user.")
118 #define FUNC_NAME s_scm_interaction_environment
120 return scm_current_module ();
125 scm_c_call_with_current_module (SCM module
,
126 SCM (*func
)(void *), void *data
)
128 return scm_c_with_fluid (the_module
, module
, func
, data
);
132 scm_dynwind_current_module (SCM module
)
134 scm_dynwind_fluid (the_module
, module
);
138 convert "A B C" to scheme list (A B C)
141 convert_module_name (const char *name
)
152 while (*ptr
&& *ptr
!= ' ')
156 SCM sym
= scm_from_utf8_symboln (name
, ptr
-name
);
157 *tail
= scm_cons (sym
, SCM_EOL
);
158 tail
= SCM_CDRLOC (*tail
);
167 scm_c_resolve_module (const char *name
)
169 return scm_resolve_module (convert_module_name (name
));
173 scm_resolve_module (SCM name
)
175 return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var
), name
);
179 scm_c_define_module (const char *name
,
180 void (*init
)(void *), void *data
)
182 SCM module
= scm_call_1 (SCM_VARIABLE_REF (define_module_star_var
),
183 convert_module_name (name
));
185 scm_c_call_with_current_module (module
, (SCM (*)(void*))init
, data
);
190 scm_c_use_module (const char *name
)
192 scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var
),
193 scm_list_1 (scm_list_1 (convert_module_name (name
))));
197 scm_module_export (SCM module
, SCM namelist
)
199 return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var
),
205 @code{scm_c_export}(@var{name-list})
207 @code{scm_c_export} exports the named bindings from the current
208 module, making them visible to users of the module. This function
209 takes a list of string arguments, terminated by NULL, e.g.
212 scm_c_export ("add-double-record", "bamboozle-money", NULL);
216 scm_c_export (const char *name
, ...)
221 SCM names
= scm_cons (scm_from_utf8_symbol (name
), SCM_EOL
);
222 SCM
*tail
= SCM_CDRLOC (names
);
226 const char *n
= va_arg (ap
, const char *);
229 *tail
= scm_cons (scm_from_utf8_symbol (n
), SCM_EOL
);
230 tail
= SCM_CDRLOC (*tail
);
233 scm_module_export (scm_current_module (), names
);
240 SCM_SYMBOL (sym_module
, "module");
243 scm_lookup_closure_module (SCM proc
)
245 if (scm_is_false (proc
))
246 return scm_the_root_module ();
247 else if (SCM_EVAL_CLOSURE_P (proc
))
248 return SCM_PACK (SCM_SMOB_DATA (proc
));
253 /* FIXME: The `module' property is no longer set on eval closures, as it
254 introduced a circular reference that precludes garbage collection of
255 modules with the current weak hash table semantics (see
256 http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
257 http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
258 for details). Since it doesn't appear to be used (only in this
259 function, which has 1 caller), we no longer extend
260 `set-module-eval-closure!' to set the `module' property. */
263 mod
= scm_procedure_property (proc
, sym_module
);
264 if (scm_is_false (mod
))
265 mod
= scm_the_root_module ();
271 * C level implementation of the standard eval closure
273 * This increases loading speed substantially. The code may be
274 * replaced by something based on environments.[ch], in a future
278 /* Return the list of default duplicate binding handlers (procedures). */
280 default_duplicate_binding_handlers (void)
284 get_handlers
= SCM_VARIABLE_REF (default_duplicate_binding_procedures_var
);
286 return (scm_call_0 (get_handlers
));
289 /* Resolve the import of SYM in MODULE, where SYM is currently provided by
290 both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
291 duplicate binding handlers or `#f'. */
293 resolve_duplicate_binding (SCM module
, SCM sym
,
294 SCM iface1
, SCM var1
,
295 SCM iface2
, SCM var2
)
299 SCM result
= SCM_BOOL_F
;
301 if (scm_is_eq (var1
, var2
))
307 args
[3] = SCM_VARIABLE_REF (var1
);
308 if (SCM_UNBNDP (args
[3]))
309 args
[3] = SCM_BOOL_F
;
311 args
[5] = SCM_VARIABLE_REF (var2
);
312 if (SCM_UNBNDP (args
[5]))
313 args
[5] = SCM_BOOL_F
;
314 args
[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module
), sym
, SCM_BOOL_F
);
315 args
[7] = SCM_BOOL_F
;
317 handlers
= SCM_MODULE_DUPLICATE_HANDLERS (module
);
318 if (scm_is_false (handlers
))
319 handlers
= default_duplicate_binding_handlers ();
321 for (; scm_is_pair (handlers
); handlers
= SCM_CDR (handlers
))
323 if (scm_is_true (args
[6]))
325 args
[7] = SCM_VARIABLE_REF (args
[6]);
326 if (SCM_UNBNDP (args
[7]))
327 args
[7] = SCM_BOOL_F
;
330 result
= scm_call_n (SCM_CAR (handlers
), args
, 8);
332 if (scm_is_true (result
))
339 /* No lock is needed for access to this variable, as there are no
340 threads before modules are booted. */
341 SCM scm_pre_modules_obarray
;
343 /* Lookup SYM as an imported variable of MODULE. */
345 module_imported_variable (SCM module
, SCM sym
)
347 #define SCM_BOUND_THING_P scm_is_true
348 register SCM var
, imports
;
350 /* Search cached imported bindings. */
351 imports
= SCM_MODULE_IMPORT_OBARRAY (module
);
352 var
= scm_hashq_ref (imports
, sym
, SCM_UNDEFINED
);
353 if (SCM_BOUND_THING_P (var
))
357 /* Search the use list for yet uncached imported bindings, possibly
358 resolving duplicates as needed and caching the result in the import
361 SCM found_var
= SCM_BOOL_F
, found_iface
= SCM_BOOL_F
;
363 for (uses
= SCM_MODULE_USES (module
);
365 uses
= SCM_CDR (uses
))
369 iface
= SCM_CAR (uses
);
370 var
= scm_module_variable (iface
, sym
);
372 if (SCM_BOUND_THING_P (var
))
374 if (SCM_BOUND_THING_P (found_var
))
376 /* SYM is a duplicate binding (imported more than once) so we
377 need to resolve it. */
378 found_var
= resolve_duplicate_binding (module
, sym
,
379 found_iface
, found_var
,
382 /* Note that it could be that FOUND_VAR doesn't belong
383 either to FOUND_IFACE or to IFACE, if it was created
384 by merge-generics. The right thing to do there would
385 be to treat the import obarray as the iface, but the
386 import obarray isn't actually a module. Oh well. */
387 if (scm_is_eq (found_var
, var
))
391 /* Keep track of the variable we found and check for other
392 occurences of SYM in the use list. */
393 found_var
= var
, found_iface
= iface
;
397 if (SCM_BOUND_THING_P (found_var
))
399 /* Save the lookup result for future reference. */
400 (void) scm_hashq_set_x (imports
, sym
, found_var
);
406 #undef SCM_BOUND_THING_P
409 SCM_DEFINE (scm_module_local_variable
, "module-local-variable", 2, 0, 0,
410 (SCM module
, SCM sym
),
411 "Return the variable bound to @var{sym} in @var{module}. Return "
412 "@code{#f} is @var{sym} is not bound locally in @var{module}.")
413 #define FUNC_NAME s_scm_module_local_variable
415 #define SCM_BOUND_THING_P(b) \
420 if (scm_module_system_booted_p
)
421 SCM_VALIDATE_MODULE (1, module
);
423 SCM_VALIDATE_SYMBOL (2, sym
);
425 if (scm_is_false (module
))
426 return scm_hashq_ref (scm_pre_modules_obarray
, sym
, SCM_UNDEFINED
);
428 /* 1. Check module obarray */
429 b
= scm_hashq_ref (SCM_MODULE_OBARRAY (module
), sym
, SCM_UNDEFINED
);
430 if (SCM_BOUND_THING_P (b
))
433 /* At this point we should just be able to return #f, but there is the
434 possibility that a custom binder establishes a mapping for this
437 However a custom binder should be called only if there is no
438 imported binding with the name SYM. So here instead of the order:
440 2. Search imported bindings. In order to be consistent with
441 `module-variable', the binder gets called only when no
442 imported binding matches SYM.
444 3. Query the custom binder.
446 we first check if there is a binder at all, and if not, just return
451 SCM binder
= SCM_MODULE_BINDER (module
);
453 if (scm_is_true (binder
))
456 b
= module_imported_variable (module
, sym
);
457 if (SCM_BOUND_THING_P (b
))
461 b
= scm_call_3 (binder
, module
, sym
, SCM_BOOL_F
);
462 if (SCM_BOUND_THING_P (b
))
469 #undef SCM_BOUND_THING_P
473 SCM_DEFINE (scm_module_variable
, "module-variable", 2, 0, 0,
474 (SCM module
, SCM sym
),
475 "Return the variable bound to @var{sym} in @var{module}. This "
476 "may be both a local variable or an imported variable. Return "
477 "@code{#f} is @var{sym} is not bound in @var{module}.")
478 #define FUNC_NAME s_scm_module_variable
480 #define SCM_BOUND_THING_P(b) \
485 if (scm_module_system_booted_p
)
486 SCM_VALIDATE_MODULE (1, module
);
488 SCM_VALIDATE_SYMBOL (2, sym
);
490 if (scm_is_false (module
))
491 return scm_hashq_ref (scm_pre_modules_obarray
, sym
, SCM_UNDEFINED
);
493 /* 1. Check module obarray */
494 var
= scm_hashq_ref (SCM_MODULE_OBARRAY (module
), sym
, SCM_UNDEFINED
);
495 if (SCM_BOUND_THING_P (var
))
498 /* 2. Search among the imported variables. */
499 var
= module_imported_variable (module
, sym
);
500 if (SCM_BOUND_THING_P (var
))
504 /* 3. Query the custom binder. */
507 binder
= SCM_MODULE_BINDER (module
);
508 if (scm_is_true (binder
))
510 var
= scm_call_3 (binder
, module
, sym
, SCM_BOOL_F
);
511 if (SCM_BOUND_THING_P (var
))
518 #undef SCM_BOUND_THING_P
522 scm_t_bits scm_tc16_eval_closure
;
524 #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
525 #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
526 (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
528 /* NOTE: This function may be called by a smob application
529 or from another C function directly. */
531 scm_eval_closure_lookup (SCM eclo
, SCM sym
, SCM definep
)
533 SCM module
= SCM_PACK (SCM_SMOB_DATA (eclo
));
534 if (scm_is_true (definep
))
536 if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo
))
538 return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var
),
542 return scm_module_variable (module
, sym
);
545 SCM_DEFINE (scm_standard_eval_closure
, "standard-eval-closure", 1, 0, 0,
547 "Return an eval closure for the module @var{module}.")
548 #define FUNC_NAME s_scm_standard_eval_closure
550 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure
, SCM_UNPACK (module
));
555 SCM_DEFINE (scm_standard_interface_eval_closure
,
556 "standard-interface-eval-closure", 1, 0, 0,
558 "Return a interface eval closure for the module @var{module}. "
559 "Such a closure does not allow new bindings to be added.")
560 #define FUNC_NAME s_scm_standard_interface_eval_closure
562 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure
| (SCM_F_EVAL_CLOSURE_INTERFACE
<<16),
563 SCM_UNPACK (module
));
567 SCM_DEFINE (scm_eval_closure_module
,
568 "eval-closure-module", 1, 0, 0,
570 "Return the module associated with this eval closure.")
571 /* the idea is that eval closures are really not the way to do things, they're
572 superfluous given our module system. this function lets mmacros migrate away
573 from eval closures. */
574 #define FUNC_NAME s_scm_eval_closure_module
576 SCM_MAKE_VALIDATE_MSG (SCM_ARG1
, eval_closure
, EVAL_CLOSURE_P
,
578 return SCM_SMOB_OBJECT (eval_closure
);
583 scm_module_lookup_closure (SCM module
)
585 if (scm_is_false (module
))
588 return SCM_MODULE_EVAL_CLOSURE (module
);
592 scm_current_module_lookup_closure ()
594 if (scm_module_system_booted_p
)
595 return scm_module_lookup_closure (scm_current_module ());
600 SCM_SYMBOL (sym_macroexpand
, "macroexpand");
602 SCM_DEFINE (scm_module_transformer
, "module-transformer", 1, 0, 0,
604 "Returns the syntax expander for the given module.")
605 #define FUNC_NAME s_scm_module_transformer
607 if (SCM_UNLIKELY (scm_is_false (module
)))
609 SCM v
= scm_hashq_ref (scm_pre_modules_obarray
,
612 if (scm_is_false (v
))
613 SCM_MISC_ERROR ("no module, and `macroexpand' unbound", SCM_EOL
);
614 return SCM_VARIABLE_REF (v
);
618 SCM_VALIDATE_MODULE (SCM_ARG1
, module
);
619 return SCM_MODULE_TRANSFORMER (module
);
625 scm_current_module_transformer ()
627 return scm_module_transformer (scm_current_module ());
630 SCM_DEFINE (scm_module_import_interface
, "module-import-interface", 2, 0, 0,
631 (SCM module
, SCM sym
),
632 "Return the module or interface from which @var{sym} is imported "
633 "in @var{module}. If @var{sym} is not imported (i.e., it is not "
634 "defined in @var{module} or it is a module-local binding instead "
635 "of an imported one), then @code{#f} is returned.")
636 #define FUNC_NAME s_scm_module_import_interface
638 SCM var
, result
= SCM_BOOL_F
;
640 SCM_VALIDATE_MODULE (1, module
);
641 SCM_VALIDATE_SYMBOL (2, sym
);
643 var
= scm_module_variable (module
, sym
);
644 if (scm_is_true (var
))
646 /* Look for the module that provides VAR. */
649 local_var
= scm_hashq_ref (SCM_MODULE_OBARRAY (module
), sym
,
651 if (scm_is_eq (local_var
, var
))
655 /* Look for VAR among the used modules. */
656 SCM uses
, imported_var
;
658 for (uses
= SCM_MODULE_USES (module
);
659 scm_is_pair (uses
) && scm_is_false (result
);
660 uses
= SCM_CDR (uses
))
662 imported_var
= scm_module_variable (SCM_CAR (uses
), sym
);
663 if (scm_is_eq (imported_var
, var
))
664 result
= SCM_CAR (uses
);
674 scm_module_public_interface (SCM module
)
676 return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var
), module
);
681 * looks up the variable bound to SYM according to PROC. PROC should be
682 * a `eval closure' of some module.
684 * When no binding exists, and DEFINEP is true, create a new binding
685 * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
686 * false and no binding exists.
688 * When PROC is `#f', it is ignored and the binding is searched for in
689 * the scm_pre_modules_obarray (a `eq' hash table).
693 scm_sym2var (SCM sym
, SCM proc
, SCM definep
)
694 #define FUNC_NAME "scm_sym2var"
698 if (SCM_HEAP_OBJECT_P (proc
))
700 if (SCM_EVAL_CLOSURE_P (proc
))
702 /* Bypass evaluator in the standard case. */
703 var
= scm_eval_closure_lookup (proc
, sym
, definep
);
706 var
= scm_call_2 (proc
, sym
, definep
);
712 if (scm_is_false (definep
))
713 var
= scm_hashq_ref (scm_pre_modules_obarray
, sym
, SCM_BOOL_F
);
716 handle
= scm_hashq_create_handle_x (scm_pre_modules_obarray
,
718 var
= SCM_CDR (handle
);
719 if (scm_is_false (var
))
721 var
= scm_make_variable (SCM_UNDEFINED
);
722 SCM_SETCDR (handle
, var
);
727 if (scm_is_true (var
) && !SCM_VARIABLEP (var
))
728 SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym
));
735 scm_c_module_lookup (SCM module
, const char *name
)
737 return scm_module_lookup (module
, scm_from_utf8_symbol (name
));
741 scm_module_lookup (SCM module
, SCM sym
)
742 #define FUNC_NAME "module-lookup"
745 SCM_VALIDATE_MODULE (1, module
);
747 var
= scm_sym2var (sym
, scm_module_lookup_closure (module
), SCM_BOOL_F
);
748 if (scm_is_false (var
))
749 unbound_variable (FUNC_NAME
, sym
);
755 scm_c_lookup (const char *name
)
757 return scm_lookup (scm_from_utf8_symbol (name
));
764 scm_sym2var (sym
, scm_current_module_lookup_closure (), SCM_BOOL_F
);
765 if (scm_is_false (var
))
766 unbound_variable (NULL
, sym
);
771 scm_public_variable (SCM module_name
, SCM name
)
775 mod
= scm_call_3 (scm_variable_ref (resolve_module_var
), module_name
,
776 k_ensure
, SCM_BOOL_F
);
778 if (scm_is_false (mod
))
779 scm_misc_error ("public-lookup", "Module named ~s does not exist",
780 scm_list_1 (module_name
));
782 iface
= scm_module_public_interface (mod
);
784 if (scm_is_false (iface
))
785 scm_misc_error ("public-lookup", "Module ~s has no public interface",
788 return scm_module_variable (iface
, name
);
792 scm_private_variable (SCM module_name
, SCM name
)
796 mod
= scm_call_3 (scm_variable_ref (resolve_module_var
), module_name
,
797 k_ensure
, SCM_BOOL_F
);
799 if (scm_is_false (mod
))
800 scm_misc_error ("private-lookup", "Module named ~s does not exist",
801 scm_list_1 (module_name
));
803 return scm_module_variable (mod
, name
);
807 scm_c_public_variable (const char *module_name
, const char *name
)
809 return scm_public_variable (convert_module_name (module_name
),
810 scm_from_utf8_symbol (name
));
814 scm_c_private_variable (const char *module_name
, const char *name
)
816 return scm_private_variable (convert_module_name (module_name
),
817 scm_from_utf8_symbol (name
));
821 scm_public_lookup (SCM module_name
, SCM name
)
825 var
= scm_public_variable (module_name
, name
);
827 if (scm_is_false (var
))
828 scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s",
829 scm_list_2 (name
, module_name
));
835 scm_private_lookup (SCM module_name
, SCM name
)
839 var
= scm_private_variable (module_name
, name
);
841 if (scm_is_false (var
))
842 scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s",
843 scm_list_2 (name
, module_name
));
849 scm_c_public_lookup (const char *module_name
, const char *name
)
851 return scm_public_lookup (convert_module_name (module_name
),
852 scm_from_utf8_symbol (name
));
856 scm_c_private_lookup (const char *module_name
, const char *name
)
858 return scm_private_lookup (convert_module_name (module_name
),
859 scm_from_utf8_symbol (name
));
863 scm_public_ref (SCM module_name
, SCM name
)
865 return scm_variable_ref (scm_public_lookup (module_name
, name
));
869 scm_private_ref (SCM module_name
, SCM name
)
871 return scm_variable_ref (scm_private_lookup (module_name
, name
));
875 scm_c_public_ref (const char *module_name
, const char *name
)
877 return scm_public_ref (convert_module_name (module_name
),
878 scm_from_utf8_symbol (name
));
882 scm_c_private_ref (const char *module_name
, const char *name
)
884 return scm_private_ref (convert_module_name (module_name
),
885 scm_from_utf8_symbol (name
));
889 scm_c_module_define (SCM module
, const char *name
, SCM value
)
891 return scm_module_define (module
, scm_from_utf8_symbol (name
), value
);
895 scm_module_define (SCM module
, SCM sym
, SCM value
)
896 #define FUNC_NAME "module-define"
899 SCM_VALIDATE_MODULE (1, module
);
901 var
= scm_sym2var (sym
, scm_module_lookup_closure (module
), SCM_BOOL_T
);
902 SCM_VARIABLE_SET (var
, value
);
908 scm_c_define (const char *name
, SCM value
)
910 return scm_define (scm_from_utf8_symbol (name
), value
);
913 SCM_DEFINE (scm_define
, "define!", 2, 0, 0,
914 (SCM sym
, SCM value
),
915 "Define @var{sym} to be @var{value} in the current module."
916 "Returns the variable itself. Note that this is a procedure, "
918 #define FUNC_NAME s_scm_define
921 SCM_VALIDATE_SYMBOL (SCM_ARG1
, sym
);
922 var
= scm_sym2var (sym
, scm_current_module_lookup_closure (), SCM_BOOL_T
);
923 SCM_VARIABLE_SET (var
, value
);
928 SCM_DEFINE (scm_module_reverse_lookup
, "module-reverse-lookup", 2, 0, 0,
929 (SCM module
, SCM variable
),
930 "Return the symbol under which @var{variable} is bound in "
931 "@var{module} or @var{#f} if @var{variable} is not visible "
932 "from @var{module}. If @var{module} is @code{#f}, then the "
933 "pre-module obarray is used.")
934 #define FUNC_NAME s_scm_module_reverse_lookup
939 if (scm_is_false (module
))
940 obarray
= scm_pre_modules_obarray
;
943 SCM_VALIDATE_MODULE (1, module
);
944 obarray
= SCM_MODULE_OBARRAY (module
);
947 SCM_VALIDATE_VARIABLE (SCM_ARG2
, variable
);
949 if (!SCM_HASHTABLE_P (obarray
))
952 /* XXX - We do not use scm_hash_fold here to avoid searching the
953 whole obarray. We should have a scm_hash_find procedure. */
955 n
= SCM_HASHTABLE_N_BUCKETS (obarray
);
956 for (i
= 0; i
< n
; ++i
)
958 SCM ls
= SCM_HASHTABLE_BUCKET (obarray
, i
), handle
;
959 while (!scm_is_null (ls
))
961 handle
= SCM_CAR (ls
);
963 if (scm_is_eq (SCM_CDR (handle
), variable
))
964 return SCM_CAR (handle
);
970 if (!scm_is_false (module
))
972 /* Try the `uses' list. */
973 SCM uses
= SCM_MODULE_USES (module
);
974 while (scm_is_pair (uses
))
976 SCM sym
= scm_module_reverse_lookup (SCM_CAR (uses
), variable
);
977 if (scm_is_true (sym
))
979 uses
= SCM_CDR (uses
);
987 SCM_DEFINE (scm_get_pre_modules_obarray
, "%get-pre-modules-obarray", 0, 0, 0,
989 "Return the obarray that is used for all new bindings before "
990 "the module system is booted. The first call to "
991 "@code{set-current-module} will boot the module system.")
992 #define FUNC_NAME s_scm_get_pre_modules_obarray
994 return scm_pre_modules_obarray
;
998 SCM_SYMBOL (scm_sym_system_module
, "system-module");
1001 scm_modules_prehistory ()
1003 scm_pre_modules_obarray
= scm_c_make_hash_table (1790);
1009 #include "libguile/modules.x"
1010 module_make_local_var_x_var
= scm_c_define ("module-make-local-var!",
1012 scm_tc16_eval_closure
= scm_make_smob_type ("eval-closure", 0);
1013 scm_set_smob_apply (scm_tc16_eval_closure
, scm_eval_closure_lookup
, 2, 0, 0);
1015 the_module
= scm_make_fluid ();
1019 scm_post_boot_init_modules ()
1021 SCM module_type
= SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
1022 scm_module_tag
= (SCM_CELL_WORD_1 (module_type
) + scm_tc3_struct
);
1024 resolve_module_var
= scm_c_lookup ("resolve-module");
1025 define_module_star_var
= scm_c_lookup ("define-module*");
1026 process_use_modules_var
= scm_c_lookup ("process-use-modules");
1027 module_export_x_var
= scm_c_lookup ("module-export!");
1028 the_root_module_var
= scm_c_lookup ("the-root-module");
1029 default_duplicate_binding_procedures_var
=
1030 scm_c_lookup ("default-duplicate-binding-procedures");
1031 module_public_interface_var
= scm_c_lookup ("module-public-interface");
1032 k_ensure
= scm_from_locale_keyword ("ensure");
1034 scm_module_system_booted_p
= 1;