prevent (resolve-module '(guile)) recursion
[bpt/guile.git] / libguile / modules.c
CommitLineData
b226295a 1/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008 Free Software Foundation, Inc.
608860a5 2 *
73be1d9e
MV
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.
1ffa265b 7 *
73be1d9e
MV
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.
1ffa265b 12 *
73be1d9e
MV
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
92205699 15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
73be1d9e 16 */
6e8d25a6 17
6e8d25a6 18
1ffa265b
MD
19\f
20
d02b98e9
MV
21#include <stdarg.h>
22
a0599745 23#include "libguile/_scm.h"
1ffa265b 24
a0599745 25#include "libguile/eval.h"
fb43bf74 26#include "libguile/smob.h"
a0599745 27#include "libguile/procprop.h"
152abe96
MD
28#include "libguile/vectors.h"
29#include "libguile/hashtab.h"
30#include "libguile/struct.h"
31#include "libguile/variable.h"
7f763132 32#include "libguile/fluids.h"
d02b98e9 33#include "libguile/deprecation.h"
1ffa265b 34
a0599745 35#include "libguile/modules.h"
1ffa265b 36
86d31dfe 37int scm_module_system_booted_p = 0;
e3365c07 38
92c2555f 39scm_t_bits scm_module_tag;
e3365c07 40
1ffa265b
MD
41static SCM the_module;
42
3ac8359a
NJ
43static SCM the_root_module_var;
44
45static SCM
46the_root_module ()
47{
48 if (scm_module_system_booted_p)
49 return SCM_VARIABLE_REF (the_root_module_var);
50 else
51 return SCM_BOOL_F;
52}
53
55000e5f
MV
54SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
55 (),
56 "Return the current module.")
57#define FUNC_NAME s_scm_current_module
1ffa265b 58{
3ac8359a
NJ
59 SCM curr = scm_fluid_ref (the_module);
60
61 return scm_is_true (curr) ? curr : the_root_module ();
1ffa265b 62}
55000e5f 63#undef FUNC_NAME
1ffa265b 64
86d31dfe 65static void scm_post_boot_init_modules (void);
1ffa265b 66
55000e5f
MV
67SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
68 (SCM module),
9401323e 69 "Set the current module to @var{module} and return\n"
55000e5f
MV
70 "the previous current module.")
71#define FUNC_NAME s_scm_set_current_module
1ffa265b 72{
55000e5f
MV
73 SCM old;
74
86d31dfe
MV
75 if (!scm_module_system_booted_p)
76 scm_post_boot_init_modules ();
77
78 SCM_VALIDATE_MODULE (SCM_ARG1, module);
55000e5f
MV
79
80 old = scm_current_module ();
81 scm_fluid_set_x (the_module, module);
82
1ffa265b
MD
83 return old;
84}
55000e5f 85#undef FUNC_NAME
1ffa265b 86
e3365c07
MD
87SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
88 (),
1e6808ea
MG
89 "Return a specifier for the environment that contains\n"
90 "implementation--defined bindings, typically a superset of those\n"
91 "listed in the report. The intent is that this procedure will\n"
92 "return the environment in which the implementation would\n"
93 "evaluate expressions dynamically typed by the user.")
e3365c07
MD
94#define FUNC_NAME s_scm_interaction_environment
95{
aa767bc5 96 return scm_current_module ();
e3365c07
MD
97}
98#undef FUNC_NAME
99
1ffa265b 100SCM
d02b98e9
MV
101scm_c_call_with_current_module (SCM module,
102 SCM (*func)(void *), void *data)
1ffa265b 103{
d02b98e9 104 return scm_c_with_fluid (the_module, module, func, data);
1ffa265b
MD
105}
106
cb1cfc42 107void
661ae7ab 108scm_dynwind_current_module (SCM module)
cb1cfc42 109{
661ae7ab 110 scm_dynwind_fluid (the_module, module);
cb1cfc42 111}
06e80f59
HWN
112
113/*
114 convert "A B C" to scheme list (A B C)
115 */
d02b98e9
MV
116static SCM
117convert_module_name (const char *name)
281004cc 118{
d02b98e9
MV
119 SCM list = SCM_EOL;
120 SCM *tail = &list;
281004cc 121
d02b98e9
MV
122 const char *ptr;
123 while (*name)
124 {
125 while (*name == ' ')
126 name++;
127 ptr = name;
128 while (*ptr && *ptr != ' ')
129 ptr++;
130 if (ptr > name)
131 {
cc95e00a
MV
132 SCM sym = scm_from_locale_symboln (name, ptr-name);
133 *tail = scm_cons (sym, SCM_EOL);
d02b98e9
MV
134 tail = SCM_CDRLOC (*tail);
135 }
136 name = ptr;
137 }
138
139 return list;
1ffa265b
MD
140}
141
d02b98e9
MV
142static SCM process_define_module_var;
143static SCM process_use_modules_var;
144static SCM resolve_module_var;
145
9e57344b 146SCM
d02b98e9 147scm_c_resolve_module (const char *name)
9e57344b 148{
d02b98e9 149 return scm_resolve_module (convert_module_name (name));
9e57344b
MV
150}
151
55000e5f 152SCM
d02b98e9 153scm_resolve_module (SCM name)
55000e5f 154{
fdc28395 155 return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
55000e5f
MV
156}
157
158SCM
d02b98e9
MV
159scm_c_define_module (const char *name,
160 void (*init)(void *), void *data)
55000e5f 161{
fdc28395 162 SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
1afff620 163 scm_list_1 (convert_module_name (name)));
d02b98e9
MV
164 if (init)
165 scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
166 return module;
55000e5f
MV
167}
168
d02b98e9
MV
169void
170scm_c_use_module (const char *name)
90184345 171{
fdc28395 172 scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
b64f4200 173 scm_list_1 (scm_list_1 (convert_module_name (name))));
90184345
MD
174}
175
d02b98e9 176static SCM module_export_x_var;
281004cc 177
608860a5
LC
178SCM
179scm_module_export (SCM module, SCM namelist)
06e80f59 180{
8c330007
MD
181 return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
182 module, namelist);
06e80f59
HWN
183}
184
eb880cef
MV
185
186/*
187 @code{scm_c_export}(@var{name-list})
188
189 @code{scm_c_export} exports the named bindings from the current
190 module, making them visible to users of the module. This function
191 takes a list of string arguments, terminated by NULL, e.g.
192
193 @example
194 scm_c_export ("add-double-record", "bamboozle-money", NULL);
195 @end example
196*/
d02b98e9
MV
197void
198scm_c_export (const char *name, ...)
281004cc 199{
eb880cef 200 if (name)
d02b98e9 201 {
eb880cef 202 va_list ap;
cc95e00a 203 SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
eb880cef
MV
204 SCM *tail = SCM_CDRLOC (names);
205 va_start (ap, name);
206 while (1)
207 {
208 const char *n = va_arg (ap, const char *);
209 if (n == NULL)
210 break;
cc95e00a 211 *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
eb880cef
MV
212 tail = SCM_CDRLOC (*tail);
213 }
214 va_end (ap);
608860a5 215 scm_module_export (scm_current_module (), names);
d02b98e9 216 }
281004cc
MD
217}
218
06e80f59 219
e3365c07 220/* Environments */
d164a5af
MD
221
222SCM
6e8d25a6 223scm_top_level_env (SCM thunk)
d164a5af
MD
224{
225 if (SCM_IMP (thunk))
226 return SCM_EOL;
227 else
228 return scm_cons (thunk, SCM_EOL);
229}
230
231SCM
232scm_env_top_level (SCM env)
233{
d2e53ed6 234 while (scm_is_pair (env))
d164a5af 235 {
c88b1456 236 SCM car_env = SCM_CAR (env);
d2e53ed6 237 if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
c88b1456 238 return car_env;
d164a5af
MD
239 env = SCM_CDR (env);
240 }
241 return SCM_BOOL_F;
242}
243
86d31dfe
MV
244SCM_SYMBOL (sym_module, "module");
245
246SCM
247scm_lookup_closure_module (SCM proc)
248{
7888309b 249 if (scm_is_false (proc))
d02b98e9 250 return the_root_module ();
86d31dfe
MV
251 else if (SCM_EVAL_CLOSURE_P (proc))
252 return SCM_PACK (SCM_SMOB_DATA (proc));
253 else
254 {
255 SCM mod = scm_procedure_property (proc, sym_module);
7888309b 256 if (scm_is_false (mod))
d02b98e9 257 mod = the_root_module ();
86d31dfe
MV
258 return mod;
259 }
260}
261
e24ca538
MV
262SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
263 (SCM env),
264 "Return the module of @var{ENV}, a lexical environment.")
265#define FUNC_NAME s_scm_env_module
86d31dfe
MV
266{
267 return scm_lookup_closure_module (scm_env_top_level (env));
268}
e24ca538 269#undef FUNC_NAME
86d31dfe 270
152abe96
MD
271/*
272 * C level implementation of the standard eval closure
273 *
dd18d312
NJ
274 * This increases loading speed substantially. The code may be
275 * replaced by something based on environments.[ch], in a future
276 * release.
152abe96
MD
277 */
278
608860a5
LC
279/* The `module-make-local-var!' variable. */
280static SCM module_make_local_var_x_var = SCM_UNSPECIFIED;
152abe96 281
608860a5
LC
282/* The `default-duplicate-binding-procedures' variable. */
283static SCM default_duplicate_binding_procedures_var = SCM_UNSPECIFIED;
284
285/* Return the list of default duplicate binding handlers (procedures). */
286static inline SCM
287default_duplicate_binding_handlers (void)
288{
289 SCM get_handlers;
290
291 get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var);
292
293 return (scm_call_0 (get_handlers));
294}
295
296/* Resolve the import of SYM in MODULE, where SYM is currently provided by
297 both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
298 duplicate binding handlers or `#f'. */
299static inline SCM
300resolve_duplicate_binding (SCM module, SCM sym,
301 SCM iface1, SCM var1,
302 SCM iface2, SCM var2)
303{
304 SCM result = SCM_BOOL_F;
305
306 if (!scm_is_eq (var1, var2))
307 {
308 SCM val1, val2;
309 SCM handlers, h, handler_args;
310
311 val1 = SCM_VARIABLE_REF (var1);
312 val2 = SCM_VARIABLE_REF (var2);
313
314 val1 = (val1 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
315 val2 = (val2 == SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
316
317 handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
318 if (scm_is_false (handlers))
319 handlers = default_duplicate_binding_handlers ();
320
321 handler_args = scm_list_n (module, sym,
322 iface1, val1, iface2, val2,
323 var1, val1,
324 SCM_UNDEFINED);
325
326 for (h = handlers;
327 scm_is_pair (h) && scm_is_false (result);
328 h = SCM_CDR (h))
329 {
330 result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
331 }
332 }
333 else
334 result = var1;
335
336 return result;
337}
338
339/* Lookup SYM as an imported variable of MODULE. */
340static inline SCM
341module_imported_variable (SCM module, SCM sym)
342{
343#define SCM_BOUND_THING_P scm_is_true
344 register SCM var, imports;
345
346 /* Search cached imported bindings. */
347 imports = SCM_MODULE_IMPORT_OBARRAY (module);
348 var = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
349 if (SCM_BOUND_THING_P (var))
350 return var;
351
352 {
353 /* Search the use list for yet uncached imported bindings, possibly
354 resolving duplicates as needed and caching the result in the import
355 obarray. */
356 SCM uses;
357 SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F;
358
359 for (uses = SCM_MODULE_USES (module);
360 scm_is_pair (uses);
361 uses = SCM_CDR (uses))
362 {
363 SCM iface;
364
365 iface = SCM_CAR (uses);
366 var = scm_module_variable (iface, sym);
367
368 if (SCM_BOUND_THING_P (var))
369 {
370 if (SCM_BOUND_THING_P (found_var))
371 {
372 /* SYM is a duplicate binding (imported more than once) so we
373 need to resolve it. */
374 found_var = resolve_duplicate_binding (module, sym,
375 found_iface, found_var,
376 iface, var);
377 if (scm_is_eq (found_var, var))
378 found_iface = iface;
379 }
380 else
381 /* Keep track of the variable we found and check for other
382 occurences of SYM in the use list. */
383 found_var = var, found_iface = iface;
384 }
385 }
386
387 if (SCM_BOUND_THING_P (found_var))
388 {
389 /* Save the lookup result for future reference. */
390 (void) scm_hashq_set_x (imports, sym, found_var);
391 return found_var;
392 }
393 }
394
395 return SCM_BOOL_F;
396#undef SCM_BOUND_THING_P
397}
398
399SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
400 (SCM module, SCM sym),
401 "Return the variable bound to @var{sym} in @var{module}. Return "
402 "@code{#f} is @var{sym} is not bound locally in @var{module}.")
403#define FUNC_NAME s_scm_module_local_variable
152abe96 404{
dc187f33 405#define SCM_BOUND_THING_P(b) \
7888309b 406 (scm_is_true (b))
dc187f33 407
608860a5
LC
408 register SCM b;
409
410 /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
411 evaluated. */
412 if (scm_module_system_booted_p)
413 SCM_VALIDATE_MODULE (1, module);
414
415 SCM_VALIDATE_SYMBOL (2, sym);
416
417
152abe96 418 /* 1. Check module obarray */
608860a5 419 b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
dc187f33 420 if (SCM_BOUND_THING_P (b))
152abe96 421 return b;
608860a5
LC
422
423 /* 2. Search imported bindings. In order to be consistent with
424 `module-variable', the binder gets called only when no imported binding
425 matches SYM. */
426 b = module_imported_variable (module, sym);
427 if (SCM_BOUND_THING_P (b))
428 return SCM_BOOL_F;
429
152abe96 430 {
608860a5 431 /* 3. Query the custom binder. */
e3365c07 432 SCM binder = SCM_MODULE_BINDER (module);
608860a5 433
7888309b 434 if (scm_is_true (binder))
152abe96 435 {
fdc28395 436 b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
dc187f33 437 if (SCM_BOUND_THING_P (b))
152abe96
MD
438 return b;
439 }
440 }
608860a5
LC
441
442 return SCM_BOOL_F;
443
444#undef SCM_BOUND_THING_P
445}
446#undef FUNC_NAME
447
448SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
449 (SCM module, SCM sym),
450 "Return the variable bound to @var{sym} in @var{module}. This "
451 "may be both a local variable or an imported variable. Return "
452 "@code{#f} is @var{sym} is not bound in @var{module}.")
453#define FUNC_NAME s_scm_module_variable
454{
455#define SCM_BOUND_THING_P(b) \
456 (scm_is_true (b))
457
458 register SCM var;
459
460 if (scm_module_system_booted_p)
461 SCM_VALIDATE_MODULE (1, module);
462
463 SCM_VALIDATE_SYMBOL (2, sym);
464
465 /* 1. Check module obarray */
466 var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
467 if (SCM_BOUND_THING_P (var))
468 return var;
469
470 /* 2. Search among the imported variables. */
471 var = module_imported_variable (module, sym);
472 if (SCM_BOUND_THING_P (var))
473 return var;
474
152abe96 475 {
608860a5
LC
476 /* 3. Query the custom binder. */
477 SCM binder;
478
479 binder = SCM_MODULE_BINDER (module);
480 if (scm_is_true (binder))
152abe96 481 {
608860a5
LC
482 var = scm_call_3 (binder, module, sym, SCM_BOOL_F);
483 if (SCM_BOUND_THING_P (var))
484 return var;
152abe96 485 }
152abe96 486 }
608860a5
LC
487
488 return SCM_BOOL_F;
489
dc187f33 490#undef SCM_BOUND_THING_P
152abe96 491}
608860a5 492#undef FUNC_NAME
152abe96 493
92c2555f 494scm_t_bits scm_tc16_eval_closure;
152abe96 495
86d31dfe
MV
496#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
497#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
498 (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
499
fb43bf74
KN
500/* NOTE: This function may be called by a smob application
501 or from another C function directly. */
502SCM
503scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
152abe96 504{
fb43bf74 505 SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
7888309b 506 if (scm_is_true (definep))
86d31dfe
MV
507 {
508 if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
509 return SCM_BOOL_F;
fdc28395
KN
510 return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
511 module, sym);
86d31dfe 512 }
152abe96 513 else
608860a5 514 return scm_module_variable (module, sym);
152abe96
MD
515}
516
517SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
518 (SCM module),
84526793 519 "Return an eval closure for the module @var{module}.")
152abe96
MD
520#define FUNC_NAME s_scm_standard_eval_closure
521{
e841c3e0 522 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
152abe96
MD
523}
524#undef FUNC_NAME
525
e4da0740 526
86d31dfe
MV
527SCM_DEFINE (scm_standard_interface_eval_closure,
528 "standard-interface-eval-closure", 1, 0, 0,
529 (SCM module),
530 "Return a interface eval closure for the module @var{module}. "
531 "Such a closure does not allow new bindings to be added.")
532#define FUNC_NAME s_scm_standard_interface_eval_closure
533{
534 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
535 SCM_UNPACK (module));
536}
537#undef FUNC_NAME
538
d02b98e9
MV
539SCM
540scm_module_lookup_closure (SCM module)
541{
7888309b 542 if (scm_is_false (module))
d02b98e9
MV
543 return SCM_BOOL_F;
544 else
545 return SCM_MODULE_EVAL_CLOSURE (module);
546}
547
548SCM
549scm_current_module_lookup_closure ()
550{
551 if (scm_module_system_booted_p)
552 return scm_module_lookup_closure (scm_current_module ());
553 else
554 return SCM_BOOL_F;
555}
556
557SCM
558scm_module_transformer (SCM module)
559{
7888309b 560 if (scm_is_false (module))
d02b98e9
MV
561 return SCM_BOOL_F;
562 else
563 return SCM_MODULE_TRANSFORMER (module);
564}
565
566SCM
567scm_current_module_transformer ()
568{
569 if (scm_module_system_booted_p)
570 return scm_module_transformer (scm_current_module ());
571 else
572 return SCM_BOOL_F;
573}
574
109c2c9f
MD
575SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
576 (SCM module, SCM sym),
608860a5
LC
577 "Return the module or interface from which @var{sym} is imported "
578 "in @var{module}. If @var{sym} is not imported (i.e., it is not "
579 "defined in @var{module} or it is a module-local binding instead "
580 "of an imported one), then @code{#f} is returned.")
109c2c9f
MD
581#define FUNC_NAME s_scm_module_import_interface
582{
608860a5
LC
583 SCM var, result = SCM_BOOL_F;
584
585 SCM_VALIDATE_MODULE (1, module);
586 SCM_VALIDATE_SYMBOL (2, sym);
587
588 var = scm_module_variable (module, sym);
589 if (scm_is_true (var))
109c2c9f 590 {
608860a5
LC
591 /* Look for the module that provides VAR. */
592 SCM local_var;
593
594 local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
595 SCM_UNDEFINED);
596 if (scm_is_eq (local_var, var))
597 result = module;
598 else
599 {
600 /* Look for VAR among the used modules. */
601 SCM uses, imported_var;
602
603 for (uses = SCM_MODULE_USES (module);
604 scm_is_pair (uses) && scm_is_false (result);
605 uses = SCM_CDR (uses))
606 {
607 imported_var = scm_module_variable (SCM_CAR (uses), sym);
608 if (scm_is_eq (imported_var, var))
609 result = SCM_CAR (uses);
610 }
611 }
109c2c9f 612 }
608860a5
LC
613
614 return result;
109c2c9f
MD
615}
616#undef FUNC_NAME
617
86d31dfe
MV
618/* scm_sym2var
619 *
620 * looks up the variable bound to SYM according to PROC. PROC should be
621 * a `eval closure' of some module.
622 *
623 * When no binding exists, and DEFINEP is true, create a new binding
624 * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
625 * false and no binding exists.
626 *
627 * When PROC is `#f', it is ignored and the binding is searched for in
628 * the scm_pre_modules_obarray (a `eq' hash table).
629 */
630
631SCM scm_pre_modules_obarray;
632
633SCM
634scm_sym2var (SCM sym, SCM proc, SCM definep)
635#define FUNC_NAME "scm_sym2var"
636{
637 SCM var;
638
639 if (SCM_NIMP (proc))
640 {
641 if (SCM_EVAL_CLOSURE_P (proc))
642 {
643 /* Bypass evaluator in the standard case. */
644 var = scm_eval_closure_lookup (proc, sym, definep);
645 }
646 else
fdc28395 647 var = scm_call_2 (proc, sym, definep);
86d31dfe
MV
648 }
649 else
650 {
651 SCM handle;
652
7888309b 653 if (scm_is_false (definep))
86d31dfe
MV
654 var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
655 else
656 {
657 handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
658 sym, SCM_BOOL_F);
659 var = SCM_CDR (handle);
7888309b 660 if (scm_is_false (var))
86d31dfe
MV
661 {
662 var = scm_make_variable (SCM_UNDEFINED);
86d31dfe
MV
663 SCM_SETCDR (handle, var);
664 }
665 }
666 }
667
7888309b 668 if (scm_is_true (var) && !SCM_VARIABLEP (var))
1afff620 669 SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
86d31dfe
MV
670
671 return var;
672}
673#undef FUNC_NAME
674
675SCM
676scm_c_module_lookup (SCM module, const char *name)
677{
cc95e00a 678 return scm_module_lookup (module, scm_from_locale_symbol (name));
86d31dfe
MV
679}
680
681SCM
682scm_module_lookup (SCM module, SCM sym)
683#define FUNC_NAME "module-lookup"
684{
685 SCM var;
686 SCM_VALIDATE_MODULE (1, module);
687
688 var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
7888309b 689 if (scm_is_false (var))
1afff620 690 SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
86d31dfe
MV
691 return var;
692}
693#undef FUNC_NAME
694
695SCM
696scm_c_lookup (const char *name)
697{
cc95e00a 698 return scm_lookup (scm_from_locale_symbol (name));
86d31dfe
MV
699}
700
701SCM
702scm_lookup (SCM sym)
703{
704 SCM var =
705 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
7888309b 706 if (scm_is_false (var))
1afff620 707 scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
86d31dfe
MV
708 return var;
709}
710
711SCM
712scm_c_module_define (SCM module, const char *name, SCM value)
713{
cc95e00a 714 return scm_module_define (module, scm_from_locale_symbol (name), value);
86d31dfe
MV
715}
716
717SCM
718scm_module_define (SCM module, SCM sym, SCM value)
719#define FUNC_NAME "module-define"
720{
721 SCM var;
722 SCM_VALIDATE_MODULE (1, module);
723
724 var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
725 SCM_VARIABLE_SET (var, value);
726 return var;
727}
728#undef FUNC_NAME
729
730SCM
731scm_c_define (const char *name, SCM value)
732{
cc95e00a 733 return scm_define (scm_from_locale_symbol (name), value);
86d31dfe
MV
734}
735
736SCM
737scm_define (SCM sym, SCM value)
738{
739 SCM var =
740 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
741 SCM_VARIABLE_SET (var, value);
742 return var;
743}
744
608860a5
LC
745SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
746 (SCM module, SCM variable),
747 "Return the symbol under which @var{variable} is bound in "
748 "@var{module} or @var{#f} if @var{variable} is not visible "
749 "from @var{module}. If @var{module} is @code{#f}, then the "
750 "pre-module obarray is used.")
751#define FUNC_NAME s_scm_module_reverse_lookup
86d31dfe
MV
752{
753 SCM obarray;
c014a02e 754 long i, n;
86d31dfe 755
7888309b 756 if (scm_is_false (module))
86d31dfe
MV
757 obarray = scm_pre_modules_obarray;
758 else
759 {
760 SCM_VALIDATE_MODULE (1, module);
761 obarray = SCM_MODULE_OBARRAY (module);
762 }
763
6dc1cd1e
MV
764 if (!SCM_HASHTABLE_P (obarray))
765 return SCM_BOOL_F;
766
86d31dfe
MV
767 /* XXX - We do not use scm_hash_fold here to avoid searching the
768 whole obarray. We should have a scm_hash_find procedure. */
769
c35738c1 770 n = SCM_HASHTABLE_N_BUCKETS (obarray);
86d31dfe
MV
771 for (i = 0; i < n; ++i)
772 {
4057a3e0 773 SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
d2e53ed6 774 while (!scm_is_null (ls))
86d31dfe
MV
775 {
776 handle = SCM_CAR (ls);
777 if (SCM_CDR (handle) == variable)
778 return SCM_CAR (handle);
779 ls = SCM_CDR (ls);
780 }
781 }
782
608860a5 783 /* Try the `uses' list. */
86d31dfe
MV
784 {
785 SCM uses = SCM_MODULE_USES (module);
d2e53ed6 786 while (scm_is_pair (uses))
86d31dfe
MV
787 {
788 SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
7888309b 789 if (scm_is_true (sym))
86d31dfe
MV
790 return sym;
791 uses = SCM_CDR (uses);
792 }
793 }
794
795 return SCM_BOOL_F;
796}
797#undef FUNC_NAME
798
799SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
800 (),
801 "Return the obarray that is used for all new bindings before "
802 "the module system is booted. The first call to "
803 "@code{set-current-module} will boot the module system.")
804#define FUNC_NAME s_scm_get_pre_modules_obarray
805{
806 return scm_pre_modules_obarray;
807}
808#undef FUNC_NAME
809
d02b98e9
MV
810SCM_SYMBOL (scm_sym_system_module, "system-module");
811
812SCM
813scm_system_module_env_p (SCM env)
814{
815 SCM proc = scm_env_top_level (env);
7888309b 816 if (scm_is_false (proc))
d02b98e9 817 return SCM_BOOL_T;
7888309b 818 return ((scm_is_true (scm_procedure_property (proc,
d02b98e9
MV
819 scm_sym_system_module)))
820 ? SCM_BOOL_T
821 : SCM_BOOL_F);
822}
823
86d31dfe
MV
824void
825scm_modules_prehistory ()
826{
827 scm_pre_modules_obarray
231a4ea8 828 = scm_permanent_object (scm_c_make_hash_table (1533));
86d31dfe
MV
829}
830
1ffa265b
MD
831void
832scm_init_modules ()
833{
a0599745 834#include "libguile/modules.x"
86d31dfe
MV
835 module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
836 SCM_UNDEFINED);
e841c3e0
KN
837 scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
838 scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
839 scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
55000e5f
MV
840
841 the_module = scm_permanent_object (scm_make_fluid ());
1ffa265b
MD
842}
843
86d31dfe 844static void
1ffa265b
MD
845scm_post_boot_init_modules ()
846{
86d31dfe
MV
847#define PERM(x) scm_permanent_object(x)
848
849 SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
904a077d 850 scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
d02b98e9
MV
851
852 resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
853 process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
854 process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
855 module_export_x_var = PERM (scm_c_lookup ("module-export!"));
856 the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
608860a5
LC
857 default_duplicate_binding_procedures_var =
858 PERM (scm_c_lookup ("default-duplicate-binding-procedures"));
d02b98e9 859
e3365c07 860 scm_module_system_booted_p = 1;
1ffa265b 861}
89e00824
ML
862
863/*
864 Local Variables:
865 c-file-style: "gnu"
866 End:
867*/