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