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