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 if (scm_module_system_booted_p
)
84 return scm_fluid_ref (the_module
);
90 static void scm_post_boot_init_modules (void);
92 SCM_DEFINE (scm_set_current_module
, "set-current-module", 1, 0, 0,
94 "Set the current module to @var{module} and return\n"
95 "the previous current module.")
96 #define FUNC_NAME s_scm_set_current_module
100 if (!scm_module_system_booted_p
)
101 scm_post_boot_init_modules ();
103 SCM_VALIDATE_MODULE (SCM_ARG1
, module
);
105 old
= scm_current_module ();
106 scm_fluid_set_x (the_module
, module
);
112 SCM_DEFINE (scm_interaction_environment
, "interaction-environment", 0, 0, 0,
114 "Return a specifier for the environment that contains\n"
115 "implementation--defined bindings, typically a superset of those\n"
116 "listed in the report. The intent is that this procedure will\n"
117 "return the environment in which the implementation would\n"
118 "evaluate expressions dynamically typed by the user.")
119 #define FUNC_NAME s_scm_interaction_environment
121 return scm_current_module ();
126 scm_c_call_with_current_module (SCM module
,
127 SCM (*func
)(void *), void *data
)
129 return scm_c_with_fluid (the_module
, module
, func
, data
);
133 scm_dynwind_current_module (SCM module
)
135 scm_dynwind_fluid (the_module
, module
);
139 convert "A B C" to scheme list (A B C)
142 convert_module_name (const char *name
)
153 while (*ptr
&& *ptr
!= ' ')
157 SCM sym
= scm_from_locale_symboln (name
, ptr
-name
);
158 *tail
= scm_cons (sym
, SCM_EOL
);
159 tail
= SCM_CDRLOC (*tail
);
168 scm_c_resolve_module (const char *name
)
170 return scm_resolve_module (convert_module_name (name
));
174 scm_resolve_module (SCM name
)
176 return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var
), name
);
180 scm_c_define_module (const char *name
,
181 void (*init
)(void *), void *data
)
183 SCM module
= scm_call_1 (SCM_VARIABLE_REF (define_module_star_var
),
184 convert_module_name (name
));
186 scm_c_call_with_current_module (module
, (SCM (*)(void*))init
, data
);
191 scm_c_use_module (const char *name
)
193 scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var
),
194 scm_list_1 (scm_list_1 (convert_module_name (name
))));
198 scm_module_export (SCM module
, SCM namelist
)
200 return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var
),
206 @code{scm_c_export}(@var{name-list})
208 @code{scm_c_export} exports the named bindings from the current
209 module, making them visible to users of the module. This function
210 takes a list of string arguments, terminated by NULL, e.g.
213 scm_c_export ("add-double-record", "bamboozle-money", NULL);
217 scm_c_export (const char *name
, ...)
222 SCM names
= scm_cons (scm_from_locale_symbol (name
), SCM_EOL
);
223 SCM
*tail
= SCM_CDRLOC (names
);
227 const char *n
= va_arg (ap
, const char *);
230 *tail
= scm_cons (scm_from_locale_symbol (n
), SCM_EOL
);
231 tail
= SCM_CDRLOC (*tail
);
234 scm_module_export (scm_current_module (), names
);
240 * C level implementation of the standard eval closure
242 * This increases loading speed substantially. The code may be
243 * replaced by something based on environments.[ch], in a future
247 /* Return the list of default duplicate binding handlers (procedures). */
249 default_duplicate_binding_handlers (void)
253 get_handlers
= SCM_VARIABLE_REF (default_duplicate_binding_procedures_var
);
255 return (scm_call_0 (get_handlers
));
258 /* Resolve the import of SYM in MODULE, where SYM is currently provided by
259 both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
260 duplicate binding handlers or `#f'. */
262 resolve_duplicate_binding (SCM module
, SCM sym
,
263 SCM iface1
, SCM var1
,
264 SCM iface2
, SCM var2
)
268 SCM result
= SCM_BOOL_F
;
270 if (scm_is_eq (var1
, var2
))
276 args
[3] = SCM_VARIABLE_REF (var1
);
277 if (SCM_UNBNDP (args
[3]))
278 args
[3] = SCM_BOOL_F
;
280 args
[5] = SCM_VARIABLE_REF (var2
);
281 if (SCM_UNBNDP (args
[5]))
282 args
[5] = SCM_BOOL_F
;
283 args
[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module
), sym
, SCM_BOOL_F
);
284 args
[7] = SCM_BOOL_F
;
286 handlers
= SCM_MODULE_DUPLICATE_HANDLERS (module
);
287 if (scm_is_false (handlers
))
288 handlers
= default_duplicate_binding_handlers ();
290 for (; scm_is_pair (handlers
); handlers
= SCM_CDR (handlers
))
292 if (scm_is_true (args
[6]))
294 args
[7] = SCM_VARIABLE_REF (args
[6]);
295 if (SCM_UNBNDP (args
[7]))
296 args
[7] = SCM_BOOL_F
;
299 result
= scm_call_n (SCM_CAR (handlers
), args
, 8);
301 if (scm_is_true (result
))
308 /* No lock is needed for access to this variable, as there are no
309 threads before modules are booted. */
310 SCM scm_pre_modules_obarray
;
312 /* Lookup SYM as an imported variable of MODULE. */
314 module_imported_variable (SCM module
, SCM sym
)
316 #define SCM_BOUND_THING_P scm_is_true
317 register SCM var
, imports
;
319 /* Search cached imported bindings. */
320 imports
= SCM_MODULE_IMPORT_OBARRAY (module
);
321 var
= scm_hashq_ref (imports
, sym
, SCM_UNDEFINED
);
322 if (SCM_BOUND_THING_P (var
))
326 /* Search the use list for yet uncached imported bindings, possibly
327 resolving duplicates as needed and caching the result in the import
330 SCM found_var
= SCM_BOOL_F
, found_iface
= SCM_BOOL_F
;
332 for (uses
= SCM_MODULE_USES (module
);
334 uses
= SCM_CDR (uses
))
338 iface
= SCM_CAR (uses
);
339 var
= scm_module_variable (iface
, sym
);
341 if (SCM_BOUND_THING_P (var
))
343 if (SCM_BOUND_THING_P (found_var
))
345 /* SYM is a duplicate binding (imported more than once) so we
346 need to resolve it. */
347 found_var
= resolve_duplicate_binding (module
, sym
,
348 found_iface
, found_var
,
351 /* Note that it could be that FOUND_VAR doesn't belong
352 either to FOUND_IFACE or to IFACE, if it was created
353 by merge-generics. The right thing to do there would
354 be to treat the import obarray as the iface, but the
355 import obarray isn't actually a module. Oh well. */
356 if (scm_is_eq (found_var
, var
))
360 /* Keep track of the variable we found and check for other
361 occurences of SYM in the use list. */
362 found_var
= var
, found_iface
= iface
;
366 if (SCM_BOUND_THING_P (found_var
))
368 /* Save the lookup result for future reference. */
369 (void) scm_hashq_set_x (imports
, sym
, found_var
);
375 #undef SCM_BOUND_THING_P
378 SCM_DEFINE (scm_module_local_variable
, "module-local-variable", 2, 0, 0,
379 (SCM module
, SCM sym
),
380 "Return the variable bound to @var{sym} in @var{module}. Return "
381 "@code{#f} is @var{sym} is not bound locally in @var{module}.")
382 #define FUNC_NAME s_scm_module_local_variable
384 #define SCM_BOUND_THING_P(b) \
389 if (scm_module_system_booted_p
)
390 SCM_VALIDATE_MODULE (1, module
);
392 SCM_VALIDATE_SYMBOL (2, sym
);
394 if (scm_is_false (module
))
395 return scm_hashq_ref (scm_pre_modules_obarray
, sym
, SCM_UNDEFINED
);
397 /* 1. Check module obarray */
398 b
= scm_hashq_ref (SCM_MODULE_OBARRAY (module
), sym
, SCM_UNDEFINED
);
399 if (SCM_BOUND_THING_P (b
))
402 /* At this point we should just be able to return #f, but there is the
403 possibility that a custom binder establishes a mapping for this
406 However a custom binder should be called only if there is no
407 imported binding with the name SYM. So here instead of the order:
409 2. Search imported bindings. In order to be consistent with
410 `module-variable', the binder gets called only when no
411 imported binding matches SYM.
413 3. Query the custom binder.
415 we first check if there is a binder at all, and if not, just return
420 SCM binder
= SCM_MODULE_BINDER (module
);
422 if (scm_is_true (binder
))
425 b
= module_imported_variable (module
, sym
);
426 if (SCM_BOUND_THING_P (b
))
430 b
= scm_call_3 (binder
, module
, sym
, SCM_BOOL_F
);
431 if (SCM_BOUND_THING_P (b
))
438 #undef SCM_BOUND_THING_P
442 SCM_DEFINE (scm_module_variable
, "module-variable", 2, 0, 0,
443 (SCM module
, SCM sym
),
444 "Return the variable bound to @var{sym} in @var{module}. This "
445 "may be both a local variable or an imported variable. Return "
446 "@code{#f} is @var{sym} is not bound in @var{module}.")
447 #define FUNC_NAME s_scm_module_variable
449 #define SCM_BOUND_THING_P(b) \
454 if (scm_module_system_booted_p
)
455 SCM_VALIDATE_MODULE (1, module
);
457 SCM_VALIDATE_SYMBOL (2, sym
);
459 if (scm_is_false (module
))
460 return scm_hashq_ref (scm_pre_modules_obarray
, sym
, SCM_UNDEFINED
);
462 /* 1. Check module obarray */
463 var
= scm_hashq_ref (SCM_MODULE_OBARRAY (module
), sym
, SCM_UNDEFINED
);
464 if (SCM_BOUND_THING_P (var
))
467 /* 2. Search among the imported variables. */
468 var
= module_imported_variable (module
, sym
);
469 if (SCM_BOUND_THING_P (var
))
473 /* 3. Query the custom binder. */
476 binder
= SCM_MODULE_BINDER (module
);
477 if (scm_is_true (binder
))
479 var
= scm_call_3 (binder
, module
, sym
, SCM_BOOL_F
);
480 if (SCM_BOUND_THING_P (var
))
487 #undef SCM_BOUND_THING_P
492 scm_module_ensure_local_variable (SCM module
, SCM sym
)
493 #define FUNC_NAME "module-ensure-local-variable"
495 if (SCM_LIKELY (scm_module_system_booted_p
))
497 SCM_VALIDATE_MODULE (1, module
);
498 SCM_VALIDATE_SYMBOL (2, sym
);
500 return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var
),
507 handle
= scm_hashq_create_handle_x (scm_pre_modules_obarray
,
509 var
= SCM_CDR (handle
);
511 if (scm_is_false (var
))
513 var
= scm_make_variable (SCM_UNDEFINED
);
514 SCM_SETCDR (handle
, var
);
522 SCM_SYMBOL (sym_macroexpand
, "macroexpand");
524 SCM_DEFINE (scm_module_transformer
, "module-transformer", 1, 0, 0,
526 "Returns the syntax expander for the given module.")
527 #define FUNC_NAME s_scm_module_transformer
529 if (SCM_UNLIKELY (scm_is_false (module
)))
531 SCM v
= scm_hashq_ref (scm_pre_modules_obarray
,
534 if (scm_is_false (v
))
535 SCM_MISC_ERROR ("no module, and `macroexpand' unbound", SCM_EOL
);
536 return SCM_VARIABLE_REF (v
);
540 SCM_VALIDATE_MODULE (SCM_ARG1
, module
);
541 return SCM_MODULE_TRANSFORMER (module
);
547 scm_current_module_transformer ()
549 return scm_module_transformer (scm_current_module ());
552 SCM_DEFINE (scm_module_import_interface
, "module-import-interface", 2, 0, 0,
553 (SCM module
, SCM sym
),
554 "Return the module or interface from which @var{sym} is imported "
555 "in @var{module}. If @var{sym} is not imported (i.e., it is not "
556 "defined in @var{module} or it is a module-local binding instead "
557 "of an imported one), then @code{#f} is returned.")
558 #define FUNC_NAME s_scm_module_import_interface
560 SCM var
, result
= SCM_BOOL_F
;
562 SCM_VALIDATE_MODULE (1, module
);
563 SCM_VALIDATE_SYMBOL (2, sym
);
565 var
= scm_module_variable (module
, sym
);
566 if (scm_is_true (var
))
568 /* Look for the module that provides VAR. */
571 local_var
= scm_hashq_ref (SCM_MODULE_OBARRAY (module
), sym
,
573 if (scm_is_eq (local_var
, var
))
577 /* Look for VAR among the used modules. */
578 SCM uses
, imported_var
;
580 for (uses
= SCM_MODULE_USES (module
);
581 scm_is_pair (uses
) && scm_is_false (result
);
582 uses
= SCM_CDR (uses
))
584 imported_var
= scm_module_variable (SCM_CAR (uses
), sym
);
585 if (scm_is_eq (imported_var
, var
))
586 result
= SCM_CAR (uses
);
596 scm_module_public_interface (SCM module
)
598 return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var
), module
);
602 scm_c_module_lookup (SCM module
, const char *name
)
604 return scm_module_lookup (module
, scm_from_locale_symbol (name
));
608 scm_module_lookup (SCM module
, SCM sym
)
609 #define FUNC_NAME "module-lookup"
612 var
= scm_module_variable (module
, sym
);
613 if (scm_is_false (var
))
614 unbound_variable (FUNC_NAME
, sym
);
620 scm_c_lookup (const char *name
)
622 return scm_lookup (scm_from_locale_symbol (name
));
628 return scm_module_lookup (scm_current_module (), sym
);
632 scm_public_variable (SCM module_name
, SCM name
)
636 mod
= scm_call_3 (scm_variable_ref (resolve_module_var
), module_name
,
637 k_ensure
, SCM_BOOL_F
);
639 if (scm_is_false (mod
))
640 scm_misc_error ("public-lookup", "Module named ~s does not exist",
641 scm_list_1 (module_name
));
643 iface
= scm_module_public_interface (mod
);
645 if (scm_is_false (iface
))
646 scm_misc_error ("public-lookup", "Module ~s has no public interface",
649 return scm_module_variable (iface
, name
);
653 scm_private_variable (SCM module_name
, SCM name
)
657 mod
= scm_call_3 (scm_variable_ref (resolve_module_var
), module_name
,
658 k_ensure
, SCM_BOOL_F
);
660 if (scm_is_false (mod
))
661 scm_misc_error ("private-lookup", "Module named ~s does not exist",
662 scm_list_1 (module_name
));
664 return scm_module_variable (mod
, name
);
668 scm_c_public_variable (const char *module_name
, const char *name
)
670 return scm_public_variable (convert_module_name (module_name
),
671 scm_from_locale_symbol (name
));
675 scm_c_private_variable (const char *module_name
, const char *name
)
677 return scm_private_variable (convert_module_name (module_name
),
678 scm_from_locale_symbol (name
));
682 scm_public_lookup (SCM module_name
, SCM name
)
686 var
= scm_public_variable (module_name
, name
);
688 if (scm_is_false (var
))
689 scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s",
690 scm_list_2 (name
, module_name
));
696 scm_private_lookup (SCM module_name
, SCM name
)
700 var
= scm_private_variable (module_name
, name
);
702 if (scm_is_false (var
))
703 scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s",
704 scm_list_2 (name
, module_name
));
710 scm_c_public_lookup (const char *module_name
, const char *name
)
712 return scm_public_lookup (convert_module_name (module_name
),
713 scm_from_locale_symbol (name
));
717 scm_c_private_lookup (const char *module_name
, const char *name
)
719 return scm_private_lookup (convert_module_name (module_name
),
720 scm_from_locale_symbol (name
));
724 scm_public_ref (SCM module_name
, SCM name
)
726 return scm_variable_ref (scm_public_lookup (module_name
, name
));
730 scm_private_ref (SCM module_name
, SCM name
)
732 return scm_variable_ref (scm_private_lookup (module_name
, name
));
736 scm_c_public_ref (const char *module_name
, const char *name
)
738 return scm_public_ref (convert_module_name (module_name
),
739 scm_from_locale_symbol (name
));
743 scm_c_private_ref (const char *module_name
, const char *name
)
745 return scm_private_ref (convert_module_name (module_name
),
746 scm_from_locale_symbol (name
));
750 scm_c_module_define (SCM module
, const char *name
, SCM value
)
752 return scm_module_define (module
, scm_from_locale_symbol (name
), value
);
756 scm_module_define (SCM module
, SCM sym
, SCM value
)
757 #define FUNC_NAME "module-define"
761 var
= scm_module_ensure_local_variable (module
, sym
);
762 SCM_VARIABLE_SET (var
, value
);
769 scm_c_define (const char *name
, SCM value
)
771 return scm_define (scm_from_locale_symbol (name
), value
);
774 SCM_DEFINE (scm_define
, "define!", 2, 0, 0,
775 (SCM sym
, SCM value
),
776 "Define @var{sym} to be @var{value} in the current module."
777 "Returns the variable itself. Note that this is a procedure, "
779 #define FUNC_NAME s_scm_define
781 SCM_VALIDATE_SYMBOL (SCM_ARG1
, sym
);
783 return scm_module_define (scm_current_module (), sym
, value
);
787 SCM_DEFINE (scm_module_reverse_lookup
, "module-reverse-lookup", 2, 0, 0,
788 (SCM module
, SCM variable
),
789 "Return the symbol under which @var{variable} is bound in "
790 "@var{module} or @var{#f} if @var{variable} is not visible "
791 "from @var{module}. If @var{module} is @code{#f}, then the "
792 "pre-module obarray is used.")
793 #define FUNC_NAME s_scm_module_reverse_lookup
798 if (scm_is_false (module
))
799 obarray
= scm_pre_modules_obarray
;
802 SCM_VALIDATE_MODULE (1, module
);
803 obarray
= SCM_MODULE_OBARRAY (module
);
806 SCM_VALIDATE_VARIABLE (SCM_ARG2
, variable
);
808 if (!SCM_HASHTABLE_P (obarray
))
811 /* XXX - We do not use scm_hash_fold here to avoid searching the
812 whole obarray. We should have a scm_hash_find procedure. */
814 n
= SCM_HASHTABLE_N_BUCKETS (obarray
);
815 for (i
= 0; i
< n
; ++i
)
817 SCM ls
= SCM_HASHTABLE_BUCKET (obarray
, i
), handle
;
818 while (!scm_is_null (ls
))
820 handle
= SCM_CAR (ls
);
822 if (SCM_UNPACK (SCM_CAR (handle
)) == 0)
824 /* FIXME: We hit a weak pair whose car has become unreachable.
825 We should remove the pair in question or something. */
829 if (scm_is_eq (SCM_CDR (handle
), variable
))
830 return SCM_CAR (handle
);
837 if (!scm_is_false (module
))
839 /* Try the `uses' list. */
840 SCM uses
= SCM_MODULE_USES (module
);
841 while (scm_is_pair (uses
))
843 SCM sym
= scm_module_reverse_lookup (SCM_CAR (uses
), variable
);
844 if (scm_is_true (sym
))
846 uses
= SCM_CDR (uses
);
854 SCM_DEFINE (scm_get_pre_modules_obarray
, "%get-pre-modules-obarray", 0, 0, 0,
856 "Return the obarray that is used for all new bindings before "
857 "the module system is booted. The first call to "
858 "@code{set-current-module} will boot the module system.")
859 #define FUNC_NAME s_scm_get_pre_modules_obarray
861 return scm_pre_modules_obarray
;
865 SCM_SYMBOL (scm_sym_system_module
, "system-module");
868 scm_modules_prehistory ()
870 scm_pre_modules_obarray
= scm_c_make_hash_table (1533);
876 #include "libguile/modules.x"
877 module_make_local_var_x_var
= scm_c_define ("module-make-local-var!",
879 the_module
= scm_make_fluid ();
883 scm_post_boot_init_modules ()
885 SCM module_type
= SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
886 scm_module_tag
= (SCM_CELL_WORD_1 (module_type
) + scm_tc3_struct
);
888 resolve_module_var
= scm_c_lookup ("resolve-module");
889 define_module_star_var
= scm_c_lookup ("define-module*");
890 process_use_modules_var
= scm_c_lookup ("process-use-modules");
891 module_export_x_var
= scm_c_lookup ("module-export!");
892 the_root_module_var
= scm_c_lookup ("the-root-module");
893 default_duplicate_binding_procedures_var
=
894 scm_c_lookup ("default-duplicate-binding-procedures");
895 module_public_interface_var
= scm_c_lookup ("module-public-interface");
896 k_ensure
= scm_from_locale_keyword ("ensure");
898 scm_module_system_booted_p
= 1;