1 /* Copyright (C) 1998,2000,2001,2002, 2003, 2004, 2006, 2008 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
26 #include "libguile/_scm.h"
28 #include "libguile/eval.h"
29 #include "libguile/smob.h"
30 #include "libguile/procprop.h"
31 #include "libguile/vectors.h"
32 #include "libguile/hashtab.h"
33 #include "libguile/struct.h"
34 #include "libguile/variable.h"
35 #include "libguile/fluids.h"
36 #include "libguile/deprecation.h"
38 #include "libguile/modules.h"
40 int scm_module_system_booted_p = 0;
42 scm_t_bits scm_module_tag;
44 static SCM the_module;
46 static SCM the_root_module_var;
51 if (scm_module_system_booted_p)
52 return SCM_VARIABLE_REF (the_root_module_var);
57 SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
59 "Return the current module.")
60 #define FUNC_NAME s_scm_current_module
62 SCM curr = scm_fluid_ref (the_module);
64 return scm_is_true (curr) ? curr : the_root_module ();
68 static void scm_post_boot_init_modules (void);
70 SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
72 "Set the current module to @var{module} and return\n"
73 "the previous current module.")
74 #define FUNC_NAME s_scm_set_current_module
78 if (!scm_module_system_booted_p)
79 scm_post_boot_init_modules ();
81 SCM_VALIDATE_MODULE (SCM_ARG1, module);
83 old = scm_current_module ();
84 scm_fluid_set_x (the_module, module);
90 SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
92 "Return a specifier for the environment that contains\n"
93 "implementation--defined bindings, typically a superset of those\n"
94 "listed in the report. The intent is that this procedure will\n"
95 "return the environment in which the implementation would\n"
96 "evaluate expressions dynamically typed by the user.")
97 #define FUNC_NAME s_scm_interaction_environment
99 return scm_current_module ();
104 scm_c_call_with_current_module (SCM module,
105 SCM (*func)(void *), void *data)
107 return scm_c_with_fluid (the_module, module, func, data);
111 scm_dynwind_current_module (SCM module)
113 scm_dynwind_fluid (the_module, module);
117 convert "A B C" to scheme list (A B C)
120 convert_module_name (const char *name)
131 while (*ptr && *ptr != ' ')
135 SCM sym = scm_from_locale_symboln (name, ptr-name);
136 *tail = scm_cons (sym, SCM_EOL);
137 tail = SCM_CDRLOC (*tail);
145 static SCM process_define_module_var;
146 static SCM process_use_modules_var;
147 static SCM resolve_module_var;
150 scm_c_resolve_module (const char *name)
152 return scm_resolve_module (convert_module_name (name));
156 scm_resolve_module (SCM name)
158 return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
162 scm_c_define_module (const char *name,
163 void (*init)(void *), void *data)
165 SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
166 scm_list_1 (convert_module_name (name)));
168 scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
173 scm_c_use_module (const char *name)
175 scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
176 scm_list_1 (scm_list_1 (convert_module_name (name))));
179 static SCM module_export_x_var;
183 TODO: should export this function? --hwn.
186 scm_export (SCM module, SCM namelist)
188 return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
194 @code{scm_c_export}(@var{name-list})
196 @code{scm_c_export} exports the named bindings from the current
197 module, making them visible to users of the module. This function
198 takes a list of string arguments, terminated by NULL, e.g.
201 scm_c_export ("add-double-record", "bamboozle-money", NULL);
205 scm_c_export (const char *name, ...)
210 SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
211 SCM *tail = SCM_CDRLOC (names);
215 const char *n = va_arg (ap, const char *);
218 *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
219 tail = SCM_CDRLOC (*tail);
222 scm_export (scm_current_module(), names);
230 scm_top_level_env (SCM thunk)
235 return scm_cons (thunk, SCM_EOL);
239 scm_env_top_level (SCM env)
241 while (scm_is_pair (env))
243 SCM car_env = SCM_CAR (env);
244 if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
251 SCM_SYMBOL (sym_module, "module");
254 scm_lookup_closure_module (SCM proc)
256 if (scm_is_false (proc))
257 return the_root_module ();
258 else if (SCM_EVAL_CLOSURE_P (proc))
259 return SCM_PACK (SCM_SMOB_DATA (proc));
262 SCM mod = scm_procedure_property (proc, sym_module);
263 if (scm_is_false (mod))
264 mod = the_root_module ();
269 SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
271 "Return the module of @var{ENV}, a lexical environment.")
272 #define FUNC_NAME s_scm_env_module
274 return scm_lookup_closure_module (scm_env_top_level (env));
279 * C level implementation of the standard eval closure
281 * This increases loading speed substantially.
282 * The code will be replaced by the low-level environments in next release.
285 static SCM module_make_local_var_x_var;
288 module_variable (SCM module, SCM sym)
290 #define SCM_BOUND_THING_P(b) \
293 /* 1. Check module obarray */
294 SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
295 if (SCM_BOUND_THING_P (b))
298 SCM binder = SCM_MODULE_BINDER (module);
299 if (scm_is_true (binder))
300 /* 2. Custom binder */
302 b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
303 if (SCM_BOUND_THING_P (b))
308 /* 3. Search the use list */
309 SCM uses = SCM_MODULE_USES (module);
310 while (scm_is_pair (uses))
312 b = module_variable (SCM_CAR (uses), sym);
313 if (SCM_BOUND_THING_P (b))
315 uses = SCM_CDR (uses);
319 #undef SCM_BOUND_THING_P
322 scm_t_bits scm_tc16_eval_closure;
324 #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
325 #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
326 (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
328 /* NOTE: This function may be called by a smob application
329 or from another C function directly. */
331 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
333 SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
334 if (scm_is_true (definep))
336 if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
338 return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
342 return module_variable (module, sym);
345 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
347 "Return an eval closure for the module @var{module}.")
348 #define FUNC_NAME s_scm_standard_eval_closure
350 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
355 SCM_DEFINE (scm_standard_interface_eval_closure,
356 "standard-interface-eval-closure", 1, 0, 0,
358 "Return a interface eval closure for the module @var{module}. "
359 "Such a closure does not allow new bindings to be added.")
360 #define FUNC_NAME s_scm_standard_interface_eval_closure
362 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
363 SCM_UNPACK (module));
368 scm_module_lookup_closure (SCM module)
370 if (scm_is_false (module))
373 return SCM_MODULE_EVAL_CLOSURE (module);
377 scm_current_module_lookup_closure ()
379 if (scm_module_system_booted_p)
380 return scm_module_lookup_closure (scm_current_module ());
386 scm_module_transformer (SCM module)
388 if (scm_is_false (module))
391 return SCM_MODULE_TRANSFORMER (module);
395 scm_current_module_transformer ()
397 if (scm_module_system_booted_p)
398 return scm_module_transformer (scm_current_module ());
403 SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
404 (SCM module, SCM sym),
406 #define FUNC_NAME s_scm_module_import_interface
408 #define SCM_BOUND_THING_P(b) (scm_is_true (b))
410 SCM_VALIDATE_MODULE (SCM_ARG1, module);
411 /* Search the use list */
412 uses = SCM_MODULE_USES (module);
413 while (scm_is_pair (uses))
415 SCM _interface = SCM_CAR (uses);
416 /* 1. Check module obarray */
417 SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
418 if (SCM_BOUND_THING_P (b))
421 SCM binder = SCM_MODULE_BINDER (_interface);
422 if (scm_is_true (binder))
423 /* 2. Custom binder */
425 b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
426 if (SCM_BOUND_THING_P (b))
430 /* 3. Search use list recursively. */
431 _interface = scm_module_import_interface (_interface, sym);
432 if (scm_is_true (_interface))
434 uses = SCM_CDR (uses);
442 * looks up the variable bound to SYM according to PROC. PROC should be
443 * a `eval closure' of some module.
445 * When no binding exists, and DEFINEP is true, create a new binding
446 * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
447 * false and no binding exists.
449 * When PROC is `#f', it is ignored and the binding is searched for in
450 * the scm_pre_modules_obarray (a `eq' hash table).
453 SCM scm_pre_modules_obarray;
456 scm_sym2var (SCM sym, SCM proc, SCM definep)
457 #define FUNC_NAME "scm_sym2var"
463 if (SCM_EVAL_CLOSURE_P (proc))
465 /* Bypass evaluator in the standard case. */
466 var = scm_eval_closure_lookup (proc, sym, definep);
469 var = scm_call_2 (proc, sym, definep);
475 if (scm_is_false (definep))
476 var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
479 handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
481 var = SCM_CDR (handle);
482 if (scm_is_false (var))
484 var = scm_make_variable (SCM_UNDEFINED);
485 SCM_SETCDR (handle, var);
490 if (scm_is_true (var) && !SCM_VARIABLEP (var))
491 SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
498 scm_c_module_lookup (SCM module, const char *name)
500 return scm_module_lookup (module, scm_from_locale_symbol (name));
504 scm_module_lookup (SCM module, SCM sym)
505 #define FUNC_NAME "module-lookup"
508 SCM_VALIDATE_MODULE (1, module);
510 var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
511 if (scm_is_false (var))
512 SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
518 scm_c_lookup (const char *name)
520 return scm_lookup (scm_from_locale_symbol (name));
527 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
528 if (scm_is_false (var))
529 scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
534 scm_c_module_define (SCM module, const char *name, SCM value)
536 return scm_module_define (module, scm_from_locale_symbol (name), value);
540 scm_module_define (SCM module, SCM sym, SCM value)
541 #define FUNC_NAME "module-define"
544 SCM_VALIDATE_MODULE (1, module);
546 var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
547 SCM_VARIABLE_SET (var, value);
553 scm_c_define (const char *name, SCM value)
555 return scm_define (scm_from_locale_symbol (name), value);
559 scm_define (SCM sym, SCM value)
562 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
563 SCM_VARIABLE_SET (var, value);
568 scm_module_reverse_lookup (SCM module, SCM variable)
569 #define FUNC_NAME "module-reverse-lookup"
574 if (scm_is_false (module))
575 obarray = scm_pre_modules_obarray;
578 SCM_VALIDATE_MODULE (1, module);
579 obarray = SCM_MODULE_OBARRAY (module);
582 if (!SCM_HASHTABLE_P (obarray))
585 /* XXX - We do not use scm_hash_fold here to avoid searching the
586 whole obarray. We should have a scm_hash_find procedure. */
588 n = SCM_HASHTABLE_N_BUCKETS (obarray);
589 for (i = 0; i < n; ++i)
591 SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
592 while (!scm_is_null (ls))
594 handle = SCM_CAR (ls);
595 if (SCM_CDR (handle) == variable)
596 return SCM_CAR (handle);
601 /* Try the `uses' list.
604 SCM uses = SCM_MODULE_USES (module);
605 while (scm_is_pair (uses))
607 SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
608 if (scm_is_true (sym))
610 uses = SCM_CDR (uses);
618 SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
620 "Return the obarray that is used for all new bindings before "
621 "the module system is booted. The first call to "
622 "@code{set-current-module} will boot the module system.")
623 #define FUNC_NAME s_scm_get_pre_modules_obarray
625 return scm_pre_modules_obarray;
629 SCM_SYMBOL (scm_sym_system_module, "system-module");
632 scm_system_module_env_p (SCM env)
634 SCM proc = scm_env_top_level (env);
635 if (scm_is_false (proc))
637 return ((scm_is_true (scm_procedure_property (proc,
638 scm_sym_system_module)))
644 scm_modules_prehistory ()
646 scm_pre_modules_obarray
647 = scm_permanent_object (scm_c_make_hash_table (1533));
653 #include "libguile/modules.x"
654 module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
656 scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
657 scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
658 scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
660 the_module = scm_permanent_object (scm_make_fluid ());
664 scm_post_boot_init_modules ()
666 #define PERM(x) scm_permanent_object(x)
668 SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
669 scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
671 resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
672 process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
673 process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
674 module_export_x_var = PERM (scm_c_lookup ("module-export!"));
675 the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
677 scm_module_system_booted_p = 1;