Commit | Line | Data |
---|---|---|
4a655e50 | 1 | /* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc. |
608860a5 | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
1ffa265b | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
6e8d25a6 | 18 | |
6e8d25a6 | 19 | |
1ffa265b | 20 | \f |
dbb605f5 LC |
21 | #ifdef HAVE_CONFIG_H |
22 | # include <config.h> | |
23 | #endif | |
1ffa265b | 24 | |
d02b98e9 MV |
25 | #include <stdarg.h> |
26 | ||
a0599745 | 27 | #include "libguile/_scm.h" |
1ffa265b | 28 | |
a0599745 | 29 | #include "libguile/eval.h" |
fb43bf74 | 30 | #include "libguile/smob.h" |
a0599745 | 31 | #include "libguile/procprop.h" |
152abe96 MD |
32 | #include "libguile/vectors.h" |
33 | #include "libguile/hashtab.h" | |
34 | #include "libguile/struct.h" | |
35 | #include "libguile/variable.h" | |
7f763132 | 36 | #include "libguile/fluids.h" |
d02b98e9 | 37 | #include "libguile/deprecation.h" |
1ffa265b | 38 | |
a0599745 | 39 | #include "libguile/modules.h" |
1ffa265b | 40 | |
86d31dfe | 41 | int scm_module_system_booted_p = 0; |
e3365c07 | 42 | |
92c2555f | 43 | scm_t_bits scm_module_tag; |
e3365c07 | 44 | |
1c1a0823 | 45 | /* The current module, a fluid. */ |
1ffa265b MD |
46 | static SCM the_module; |
47 | ||
1c1a0823 AW |
48 | /* Most of the module system is implemented in Scheme. These bindings from |
49 | boot-9 are needed to provide the Scheme interface. */ | |
3ac8359a | 50 | static SCM the_root_module_var; |
1c1a0823 | 51 | static SCM module_make_local_var_x_var; |
57ced5b9 | 52 | static SCM define_module_star_var; |
993dae86 AW |
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; | |
58 | ||
ef8e9356 AW |
59 | /* The #:ensure keyword. */ |
60 | static SCM k_ensure; | |
61 | ||
3ac8359a | 62 | |
7ab42fa2 AW |
63 | static SCM unbound_variable (const char *func, SCM sym) |
64 | { | |
4a655e50 | 65 | scm_error (scm_from_latin1_symbol ("unbound-variable"), func, |
7ab42fa2 AW |
66 | "Unbound variable: ~S", scm_list_1 (sym), SCM_BOOL_F); |
67 | } | |
68 | ||
f39fc3b3 AW |
69 | SCM |
70 | scm_the_root_module (void) | |
3ac8359a NJ |
71 | { |
72 | if (scm_module_system_booted_p) | |
73 | return SCM_VARIABLE_REF (the_root_module_var); | |
74 | else | |
75 | return SCM_BOOL_F; | |
76 | } | |
77 | ||
55000e5f MV |
78 | SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0, |
79 | (), | |
80 | "Return the current module.") | |
81 | #define FUNC_NAME s_scm_current_module | |
1ffa265b | 82 | { |
3ac8359a NJ |
83 | SCM curr = scm_fluid_ref (the_module); |
84 | ||
f39fc3b3 | 85 | return scm_is_true (curr) ? curr : scm_the_root_module (); |
1ffa265b | 86 | } |
55000e5f | 87 | #undef FUNC_NAME |
1ffa265b | 88 | |
86d31dfe | 89 | static void scm_post_boot_init_modules (void); |
1ffa265b | 90 | |
55000e5f MV |
91 | SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0, |
92 | (SCM module), | |
9401323e | 93 | "Set the current module to @var{module} and return\n" |
55000e5f MV |
94 | "the previous current module.") |
95 | #define FUNC_NAME s_scm_set_current_module | |
1ffa265b | 96 | { |
55000e5f MV |
97 | SCM old; |
98 | ||
86d31dfe MV |
99 | if (!scm_module_system_booted_p) |
100 | scm_post_boot_init_modules (); | |
101 | ||
102 | SCM_VALIDATE_MODULE (SCM_ARG1, module); | |
55000e5f MV |
103 | |
104 | old = scm_current_module (); | |
105 | scm_fluid_set_x (the_module, module); | |
106 | ||
1ffa265b MD |
107 | return old; |
108 | } | |
55000e5f | 109 | #undef FUNC_NAME |
1ffa265b | 110 | |
e3365c07 MD |
111 | SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0, |
112 | (), | |
1e6808ea MG |
113 | "Return a specifier for the environment that contains\n" |
114 | "implementation--defined bindings, typically a superset of those\n" | |
115 | "listed in the report. The intent is that this procedure will\n" | |
116 | "return the environment in which the implementation would\n" | |
117 | "evaluate expressions dynamically typed by the user.") | |
e3365c07 MD |
118 | #define FUNC_NAME s_scm_interaction_environment |
119 | { | |
aa767bc5 | 120 | return scm_current_module (); |
e3365c07 MD |
121 | } |
122 | #undef FUNC_NAME | |
123 | ||
1ffa265b | 124 | SCM |
d02b98e9 MV |
125 | scm_c_call_with_current_module (SCM module, |
126 | SCM (*func)(void *), void *data) | |
1ffa265b | 127 | { |
d02b98e9 | 128 | return scm_c_with_fluid (the_module, module, func, data); |
1ffa265b MD |
129 | } |
130 | ||
cb1cfc42 | 131 | void |
661ae7ab | 132 | scm_dynwind_current_module (SCM module) |
cb1cfc42 | 133 | { |
661ae7ab | 134 | scm_dynwind_fluid (the_module, module); |
cb1cfc42 | 135 | } |
06e80f59 HWN |
136 | |
137 | /* | |
138 | convert "A B C" to scheme list (A B C) | |
139 | */ | |
d02b98e9 MV |
140 | static SCM |
141 | convert_module_name (const char *name) | |
281004cc | 142 | { |
d02b98e9 MV |
143 | SCM list = SCM_EOL; |
144 | SCM *tail = &list; | |
281004cc | 145 | |
d02b98e9 MV |
146 | const char *ptr; |
147 | while (*name) | |
148 | { | |
149 | while (*name == ' ') | |
150 | name++; | |
151 | ptr = name; | |
152 | while (*ptr && *ptr != ' ') | |
153 | ptr++; | |
154 | if (ptr > name) | |
155 | { | |
cc95e00a MV |
156 | SCM sym = scm_from_locale_symboln (name, ptr-name); |
157 | *tail = scm_cons (sym, SCM_EOL); | |
d02b98e9 MV |
158 | tail = SCM_CDRLOC (*tail); |
159 | } | |
160 | name = ptr; | |
161 | } | |
162 | ||
163 | return list; | |
1ffa265b MD |
164 | } |
165 | ||
9e57344b | 166 | SCM |
d02b98e9 | 167 | scm_c_resolve_module (const char *name) |
9e57344b | 168 | { |
d02b98e9 | 169 | return scm_resolve_module (convert_module_name (name)); |
9e57344b MV |
170 | } |
171 | ||
55000e5f | 172 | SCM |
d02b98e9 | 173 | scm_resolve_module (SCM name) |
55000e5f | 174 | { |
fdc28395 | 175 | return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name); |
55000e5f MV |
176 | } |
177 | ||
178 | SCM | |
d02b98e9 MV |
179 | scm_c_define_module (const char *name, |
180 | void (*init)(void *), void *data) | |
55000e5f | 181 | { |
57ced5b9 AW |
182 | SCM module = scm_call_1 (SCM_VARIABLE_REF (define_module_star_var), |
183 | convert_module_name (name)); | |
d02b98e9 MV |
184 | if (init) |
185 | scm_c_call_with_current_module (module, (SCM (*)(void*))init, data); | |
186 | return module; | |
55000e5f MV |
187 | } |
188 | ||
d02b98e9 MV |
189 | void |
190 | scm_c_use_module (const char *name) | |
90184345 | 191 | { |
fdc28395 | 192 | scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var), |
b64f4200 | 193 | scm_list_1 (scm_list_1 (convert_module_name (name)))); |
90184345 MD |
194 | } |
195 | ||
608860a5 LC |
196 | SCM |
197 | scm_module_export (SCM module, SCM namelist) | |
06e80f59 | 198 | { |
8c330007 MD |
199 | return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var), |
200 | module, namelist); | |
06e80f59 HWN |
201 | } |
202 | ||
eb880cef MV |
203 | |
204 | /* | |
205 | @code{scm_c_export}(@var{name-list}) | |
206 | ||
207 | @code{scm_c_export} exports the named bindings from the current | |
208 | module, making them visible to users of the module. This function | |
209 | takes a list of string arguments, terminated by NULL, e.g. | |
210 | ||
211 | @example | |
212 | scm_c_export ("add-double-record", "bamboozle-money", NULL); | |
213 | @end example | |
214 | */ | |
d02b98e9 MV |
215 | void |
216 | scm_c_export (const char *name, ...) | |
281004cc | 217 | { |
eb880cef | 218 | if (name) |
d02b98e9 | 219 | { |
eb880cef | 220 | va_list ap; |
cc95e00a | 221 | SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL); |
eb880cef MV |
222 | SCM *tail = SCM_CDRLOC (names); |
223 | va_start (ap, name); | |
224 | while (1) | |
225 | { | |
226 | const char *n = va_arg (ap, const char *); | |
227 | if (n == NULL) | |
228 | break; | |
cc95e00a | 229 | *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL); |
eb880cef MV |
230 | tail = SCM_CDRLOC (*tail); |
231 | } | |
232 | va_end (ap); | |
608860a5 | 233 | scm_module_export (scm_current_module (), names); |
d02b98e9 | 234 | } |
281004cc MD |
235 | } |
236 | ||
06e80f59 | 237 | |
e3365c07 | 238 | /* Environments */ |
d164a5af | 239 | |
86d31dfe MV |
240 | SCM_SYMBOL (sym_module, "module"); |
241 | ||
242 | SCM | |
243 | scm_lookup_closure_module (SCM proc) | |
244 | { | |
7888309b | 245 | if (scm_is_false (proc)) |
f39fc3b3 | 246 | return scm_the_root_module (); |
86d31dfe MV |
247 | else if (SCM_EVAL_CLOSURE_P (proc)) |
248 | return SCM_PACK (SCM_SMOB_DATA (proc)); | |
249 | else | |
250 | { | |
490cf750 LC |
251 | SCM mod; |
252 | ||
31ac29b6 AW |
253 | /* FIXME: The `module' property is no longer set on eval closures, as it |
254 | introduced a circular reference that precludes garbage collection of | |
255 | modules with the current weak hash table semantics (see | |
256 | http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and | |
257 | http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465 | |
258 | for details). Since it doesn't appear to be used (only in this | |
259 | function, which has 1 caller), we no longer extend | |
260 | `set-module-eval-closure!' to set the `module' property. */ | |
490cf750 LC |
261 | abort (); |
262 | ||
263 | mod = scm_procedure_property (proc, sym_module); | |
7888309b | 264 | if (scm_is_false (mod)) |
f39fc3b3 | 265 | mod = scm_the_root_module (); |
86d31dfe MV |
266 | return mod; |
267 | } | |
268 | } | |
269 | ||
152abe96 MD |
270 | /* |
271 | * C level implementation of the standard eval closure | |
272 | * | |
dd18d312 NJ |
273 | * This increases loading speed substantially. The code may be |
274 | * replaced by something based on environments.[ch], in a future | |
275 | * release. | |
152abe96 MD |
276 | */ |
277 | ||
608860a5 LC |
278 | /* Return the list of default duplicate binding handlers (procedures). */ |
279 | static inline SCM | |
280 | default_duplicate_binding_handlers (void) | |
281 | { | |
282 | SCM get_handlers; | |
283 | ||
284 | get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var); | |
285 | ||
286 | return (scm_call_0 (get_handlers)); | |
287 | } | |
288 | ||
289 | /* Resolve the import of SYM in MODULE, where SYM is currently provided by | |
290 | both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the | |
291 | duplicate binding handlers or `#f'. */ | |
292 | static inline SCM | |
293 | resolve_duplicate_binding (SCM module, SCM sym, | |
294 | SCM iface1, SCM var1, | |
295 | SCM iface2, SCM var2) | |
296 | { | |
319dd089 AW |
297 | SCM args[8]; |
298 | SCM handlers; | |
608860a5 LC |
299 | SCM result = SCM_BOOL_F; |
300 | ||
319dd089 AW |
301 | if (scm_is_eq (var1, var2)) |
302 | return var1; | |
303 | ||
304 | args[0] = module; | |
305 | args[1] = sym; | |
306 | args[2] = iface1; | |
307 | args[3] = SCM_VARIABLE_REF (var1); | |
308 | if (SCM_UNBNDP (args[3])) | |
309 | args[3] = SCM_BOOL_F; | |
310 | args[4] = iface2; | |
311 | args[5] = SCM_VARIABLE_REF (var2); | |
312 | if (SCM_UNBNDP (args[5])) | |
313 | args[5] = SCM_BOOL_F; | |
314 | args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F); | |
315 | args[7] = SCM_BOOL_F; | |
316 | ||
317 | handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); | |
318 | if (scm_is_false (handlers)) | |
319 | handlers = default_duplicate_binding_handlers (); | |
320 | ||
321 | for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers)) | |
608860a5 | 322 | { |
319dd089 AW |
323 | if (scm_is_true (args[6])) |
324 | { | |
325 | args[7] = SCM_VARIABLE_REF (args[6]); | |
326 | if (SCM_UNBNDP (args[7])) | |
327 | args[7] = SCM_BOOL_F; | |
328 | } | |
329 | ||
330 | result = scm_call_n (SCM_CAR (handlers), args, 8); | |
331 | ||
332 | if (scm_is_true (result)) | |
333 | return result; | |
608860a5 | 334 | } |
608860a5 | 335 | |
319dd089 | 336 | return SCM_BOOL_F; |
608860a5 LC |
337 | } |
338 | ||
e8065fe4 AW |
339 | /* No lock is needed for access to this variable, as there are no |
340 | threads before modules are booted. */ | |
73dea589 AW |
341 | SCM scm_pre_modules_obarray; |
342 | ||
608860a5 LC |
343 | /* Lookup SYM as an imported variable of MODULE. */ |
344 | static inline SCM | |
345 | module_imported_variable (SCM module, SCM sym) | |
346 | { | |
347 | #define SCM_BOUND_THING_P scm_is_true | |
348 | register SCM var, imports; | |
349 | ||
350 | /* Search cached imported bindings. */ | |
351 | imports = SCM_MODULE_IMPORT_OBARRAY (module); | |
352 | var = scm_hashq_ref (imports, sym, SCM_UNDEFINED); | |
353 | if (SCM_BOUND_THING_P (var)) | |
354 | return var; | |
355 | ||
356 | { | |
357 | /* Search the use list for yet uncached imported bindings, possibly | |
358 | resolving duplicates as needed and caching the result in the import | |
359 | obarray. */ | |
360 | SCM uses; | |
361 | SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F; | |
362 | ||
363 | for (uses = SCM_MODULE_USES (module); | |
364 | scm_is_pair (uses); | |
365 | uses = SCM_CDR (uses)) | |
366 | { | |
367 | SCM iface; | |
368 | ||
369 | iface = SCM_CAR (uses); | |
370 | var = scm_module_variable (iface, sym); | |
371 | ||
372 | if (SCM_BOUND_THING_P (var)) | |
373 | { | |
374 | if (SCM_BOUND_THING_P (found_var)) | |
375 | { | |
376 | /* SYM is a duplicate binding (imported more than once) so we | |
377 | need to resolve it. */ | |
319dd089 AW |
378 | found_var = resolve_duplicate_binding (module, sym, |
379 | found_iface, found_var, | |
380 | iface, var); | |
381 | ||
382 | /* Note that it could be that FOUND_VAR doesn't belong | |
383 | either to FOUND_IFACE or to IFACE, if it was created | |
384 | by merge-generics. The right thing to do there would | |
385 | be to treat the import obarray as the iface, but the | |
386 | import obarray isn't actually a module. Oh well. */ | |
608860a5 LC |
387 | if (scm_is_eq (found_var, var)) |
388 | found_iface = iface; | |
389 | } | |
390 | else | |
391 | /* Keep track of the variable we found and check for other | |
392 | occurences of SYM in the use list. */ | |
393 | found_var = var, found_iface = iface; | |
394 | } | |
395 | } | |
396 | ||
397 | if (SCM_BOUND_THING_P (found_var)) | |
398 | { | |
399 | /* Save the lookup result for future reference. */ | |
400 | (void) scm_hashq_set_x (imports, sym, found_var); | |
401 | return found_var; | |
402 | } | |
403 | } | |
404 | ||
405 | return SCM_BOOL_F; | |
406 | #undef SCM_BOUND_THING_P | |
407 | } | |
408 | ||
409 | SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0, | |
410 | (SCM module, SCM sym), | |
411 | "Return the variable bound to @var{sym} in @var{module}. Return " | |
412 | "@code{#f} is @var{sym} is not bound locally in @var{module}.") | |
413 | #define FUNC_NAME s_scm_module_local_variable | |
152abe96 | 414 | { |
dc187f33 | 415 | #define SCM_BOUND_THING_P(b) \ |
7888309b | 416 | (scm_is_true (b)) |
dc187f33 | 417 | |
608860a5 LC |
418 | register SCM b; |
419 | ||
608860a5 LC |
420 | if (scm_module_system_booted_p) |
421 | SCM_VALIDATE_MODULE (1, module); | |
422 | ||
423 | SCM_VALIDATE_SYMBOL (2, sym); | |
424 | ||
165a7596 AW |
425 | if (scm_is_false (module)) |
426 | return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED); | |
608860a5 | 427 | |
152abe96 | 428 | /* 1. Check module obarray */ |
608860a5 | 429 | b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); |
dc187f33 | 430 | if (SCM_BOUND_THING_P (b)) |
152abe96 | 431 | return b; |
608860a5 | 432 | |
3be87279 AW |
433 | /* At this point we should just be able to return #f, but there is the |
434 | possibility that a custom binder establishes a mapping for this | |
435 | variable. | |
436 | ||
437 | However a custom binder should be called only if there is no | |
438 | imported binding with the name SYM. So here instead of the order: | |
439 | ||
440 | 2. Search imported bindings. In order to be consistent with | |
441 | `module-variable', the binder gets called only when no | |
442 | imported binding matches SYM. | |
443 | ||
444 | 3. Query the custom binder. | |
445 | ||
446 | we first check if there is a binder at all, and if not, just return | |
447 | #f directly. | |
448 | */ | |
608860a5 | 449 | |
152abe96 | 450 | { |
e3365c07 | 451 | SCM binder = SCM_MODULE_BINDER (module); |
608860a5 | 452 | |
7888309b | 453 | if (scm_is_true (binder)) |
152abe96 | 454 | { |
3be87279 AW |
455 | /* 2. */ |
456 | b = module_imported_variable (module, sym); | |
457 | if (SCM_BOUND_THING_P (b)) | |
458 | return SCM_BOOL_F; | |
459 | ||
460 | /* 3. */ | |
fdc28395 | 461 | b = scm_call_3 (binder, module, sym, SCM_BOOL_F); |
dc187f33 | 462 | if (SCM_BOUND_THING_P (b)) |
152abe96 MD |
463 | return b; |
464 | } | |
465 | } | |
608860a5 LC |
466 | |
467 | return SCM_BOOL_F; | |
468 | ||
469 | #undef SCM_BOUND_THING_P | |
470 | } | |
471 | #undef FUNC_NAME | |
472 | ||
473 | SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0, | |
474 | (SCM module, SCM sym), | |
475 | "Return the variable bound to @var{sym} in @var{module}. This " | |
476 | "may be both a local variable or an imported variable. Return " | |
477 | "@code{#f} is @var{sym} is not bound in @var{module}.") | |
478 | #define FUNC_NAME s_scm_module_variable | |
479 | { | |
480 | #define SCM_BOUND_THING_P(b) \ | |
481 | (scm_is_true (b)) | |
482 | ||
483 | register SCM var; | |
484 | ||
485 | if (scm_module_system_booted_p) | |
486 | SCM_VALIDATE_MODULE (1, module); | |
487 | ||
488 | SCM_VALIDATE_SYMBOL (2, sym); | |
489 | ||
73dea589 AW |
490 | if (scm_is_false (module)) |
491 | return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED); | |
492 | ||
608860a5 LC |
493 | /* 1. Check module obarray */ |
494 | var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); | |
495 | if (SCM_BOUND_THING_P (var)) | |
496 | return var; | |
497 | ||
498 | /* 2. Search among the imported variables. */ | |
499 | var = module_imported_variable (module, sym); | |
500 | if (SCM_BOUND_THING_P (var)) | |
501 | return var; | |
502 | ||
152abe96 | 503 | { |
608860a5 LC |
504 | /* 3. Query the custom binder. */ |
505 | SCM binder; | |
506 | ||
507 | binder = SCM_MODULE_BINDER (module); | |
508 | if (scm_is_true (binder)) | |
152abe96 | 509 | { |
608860a5 LC |
510 | var = scm_call_3 (binder, module, sym, SCM_BOOL_F); |
511 | if (SCM_BOUND_THING_P (var)) | |
512 | return var; | |
152abe96 | 513 | } |
152abe96 | 514 | } |
608860a5 LC |
515 | |
516 | return SCM_BOOL_F; | |
517 | ||
dc187f33 | 518 | #undef SCM_BOUND_THING_P |
152abe96 | 519 | } |
608860a5 | 520 | #undef FUNC_NAME |
152abe96 | 521 | |
92c2555f | 522 | scm_t_bits scm_tc16_eval_closure; |
152abe96 | 523 | |
34dfef51 | 524 | #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0) |
86d31dfe | 525 | #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \ |
34dfef51 | 526 | (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE) |
86d31dfe | 527 | |
fb43bf74 KN |
528 | /* NOTE: This function may be called by a smob application |
529 | or from another C function directly. */ | |
530 | SCM | |
531 | scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep) | |
152abe96 | 532 | { |
fb43bf74 | 533 | SCM module = SCM_PACK (SCM_SMOB_DATA (eclo)); |
7888309b | 534 | if (scm_is_true (definep)) |
86d31dfe MV |
535 | { |
536 | if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo)) | |
537 | return SCM_BOOL_F; | |
fdc28395 KN |
538 | return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var), |
539 | module, sym); | |
86d31dfe | 540 | } |
152abe96 | 541 | else |
608860a5 | 542 | return scm_module_variable (module, sym); |
152abe96 MD |
543 | } |
544 | ||
545 | SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0, | |
546 | (SCM module), | |
84526793 | 547 | "Return an eval closure for the module @var{module}.") |
152abe96 MD |
548 | #define FUNC_NAME s_scm_standard_eval_closure |
549 | { | |
e841c3e0 | 550 | SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module)); |
152abe96 MD |
551 | } |
552 | #undef FUNC_NAME | |
553 | ||
e4da0740 | 554 | |
86d31dfe MV |
555 | SCM_DEFINE (scm_standard_interface_eval_closure, |
556 | "standard-interface-eval-closure", 1, 0, 0, | |
557 | (SCM module), | |
558 | "Return a interface eval closure for the module @var{module}. " | |
559 | "Such a closure does not allow new bindings to be added.") | |
560 | #define FUNC_NAME s_scm_standard_interface_eval_closure | |
561 | { | |
34dfef51 | 562 | SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | (SCM_F_EVAL_CLOSURE_INTERFACE<<16), |
86d31dfe MV |
563 | SCM_UNPACK (module)); |
564 | } | |
565 | #undef FUNC_NAME | |
566 | ||
daedb492 AW |
567 | SCM_DEFINE (scm_eval_closure_module, |
568 | "eval-closure-module", 1, 0, 0, | |
569 | (SCM eval_closure), | |
570 | "Return the module associated with this eval closure.") | |
571 | /* the idea is that eval closures are really not the way to do things, they're | |
572 | superfluous given our module system. this function lets mmacros migrate away | |
573 | from eval closures. */ | |
574 | #define FUNC_NAME s_scm_eval_closure_module | |
575 | { | |
576 | SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P, | |
577 | "eval-closure"); | |
578 | return SCM_SMOB_OBJECT (eval_closure); | |
579 | } | |
580 | #undef FUNC_NAME | |
581 | ||
d02b98e9 MV |
582 | SCM |
583 | scm_module_lookup_closure (SCM module) | |
584 | { | |
7888309b | 585 | if (scm_is_false (module)) |
d02b98e9 MV |
586 | return SCM_BOOL_F; |
587 | else | |
588 | return SCM_MODULE_EVAL_CLOSURE (module); | |
589 | } | |
590 | ||
591 | SCM | |
592 | scm_current_module_lookup_closure () | |
593 | { | |
594 | if (scm_module_system_booted_p) | |
595 | return scm_module_lookup_closure (scm_current_module ()); | |
596 | else | |
597 | return SCM_BOOL_F; | |
598 | } | |
599 | ||
4f692ace | 600 | SCM_SYMBOL (sym_macroexpand, "macroexpand"); |
b7e6589f | 601 | |
5f161164 AW |
602 | SCM_DEFINE (scm_module_transformer, "module-transformer", 1, 0, 0, |
603 | (SCM module), | |
604 | "Returns the syntax expander for the given module.") | |
605 | #define FUNC_NAME s_scm_module_transformer | |
d02b98e9 | 606 | { |
b7e6589f | 607 | if (SCM_UNLIKELY (scm_is_false (module))) |
4f692ace AW |
608 | { |
609 | SCM v = scm_hashq_ref (scm_pre_modules_obarray, | |
610 | sym_macroexpand, | |
b7e6589f AW |
611 | SCM_BOOL_F); |
612 | if (scm_is_false (v)) | |
4f692ace AW |
613 | SCM_MISC_ERROR ("no module, and `macroexpand' unbound", SCM_EOL); |
614 | return SCM_VARIABLE_REF (v); | |
b7e6589f | 615 | } |
d02b98e9 | 616 | else |
5f161164 AW |
617 | { |
618 | SCM_VALIDATE_MODULE (SCM_ARG1, module); | |
619 | return SCM_MODULE_TRANSFORMER (module); | |
620 | } | |
d02b98e9 | 621 | } |
5f161164 | 622 | #undef FUNC_NAME |
d02b98e9 MV |
623 | |
624 | SCM | |
625 | scm_current_module_transformer () | |
626 | { | |
b7e6589f | 627 | return scm_module_transformer (scm_current_module ()); |
d02b98e9 MV |
628 | } |
629 | ||
109c2c9f MD |
630 | SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, |
631 | (SCM module, SCM sym), | |
608860a5 LC |
632 | "Return the module or interface from which @var{sym} is imported " |
633 | "in @var{module}. If @var{sym} is not imported (i.e., it is not " | |
634 | "defined in @var{module} or it is a module-local binding instead " | |
635 | "of an imported one), then @code{#f} is returned.") | |
109c2c9f MD |
636 | #define FUNC_NAME s_scm_module_import_interface |
637 | { | |
608860a5 LC |
638 | SCM var, result = SCM_BOOL_F; |
639 | ||
640 | SCM_VALIDATE_MODULE (1, module); | |
641 | SCM_VALIDATE_SYMBOL (2, sym); | |
642 | ||
643 | var = scm_module_variable (module, sym); | |
644 | if (scm_is_true (var)) | |
109c2c9f | 645 | { |
608860a5 LC |
646 | /* Look for the module that provides VAR. */ |
647 | SCM local_var; | |
648 | ||
649 | local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, | |
650 | SCM_UNDEFINED); | |
651 | if (scm_is_eq (local_var, var)) | |
652 | result = module; | |
653 | else | |
654 | { | |
655 | /* Look for VAR among the used modules. */ | |
656 | SCM uses, imported_var; | |
657 | ||
658 | for (uses = SCM_MODULE_USES (module); | |
659 | scm_is_pair (uses) && scm_is_false (result); | |
660 | uses = SCM_CDR (uses)) | |
661 | { | |
662 | imported_var = scm_module_variable (SCM_CAR (uses), sym); | |
663 | if (scm_is_eq (imported_var, var)) | |
664 | result = SCM_CAR (uses); | |
665 | } | |
666 | } | |
109c2c9f | 667 | } |
608860a5 LC |
668 | |
669 | return result; | |
109c2c9f MD |
670 | } |
671 | #undef FUNC_NAME | |
672 | ||
993dae86 AW |
673 | SCM |
674 | scm_module_public_interface (SCM module) | |
dc68fdb9 | 675 | { |
993dae86 | 676 | return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var), module); |
dc68fdb9 | 677 | } |
dc68fdb9 | 678 | |
86d31dfe MV |
679 | /* scm_sym2var |
680 | * | |
681 | * looks up the variable bound to SYM according to PROC. PROC should be | |
682 | * a `eval closure' of some module. | |
683 | * | |
684 | * When no binding exists, and DEFINEP is true, create a new binding | |
685 | * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as | |
686 | * false and no binding exists. | |
687 | * | |
688 | * When PROC is `#f', it is ignored and the binding is searched for in | |
689 | * the scm_pre_modules_obarray (a `eq' hash table). | |
690 | */ | |
691 | ||
86d31dfe MV |
692 | SCM |
693 | scm_sym2var (SCM sym, SCM proc, SCM definep) | |
694 | #define FUNC_NAME "scm_sym2var" | |
695 | { | |
696 | SCM var; | |
697 | ||
698 | if (SCM_NIMP (proc)) | |
699 | { | |
700 | if (SCM_EVAL_CLOSURE_P (proc)) | |
701 | { | |
702 | /* Bypass evaluator in the standard case. */ | |
703 | var = scm_eval_closure_lookup (proc, sym, definep); | |
704 | } | |
705 | else | |
fdc28395 | 706 | var = scm_call_2 (proc, sym, definep); |
86d31dfe MV |
707 | } |
708 | else | |
709 | { | |
710 | SCM handle; | |
711 | ||
7888309b | 712 | if (scm_is_false (definep)) |
86d31dfe MV |
713 | var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F); |
714 | else | |
715 | { | |
716 | handle = scm_hashq_create_handle_x (scm_pre_modules_obarray, | |
717 | sym, SCM_BOOL_F); | |
718 | var = SCM_CDR (handle); | |
7888309b | 719 | if (scm_is_false (var)) |
86d31dfe MV |
720 | { |
721 | var = scm_make_variable (SCM_UNDEFINED); | |
86d31dfe MV |
722 | SCM_SETCDR (handle, var); |
723 | } | |
724 | } | |
725 | } | |
726 | ||
7888309b | 727 | if (scm_is_true (var) && !SCM_VARIABLEP (var)) |
1afff620 | 728 | SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym)); |
86d31dfe MV |
729 | |
730 | return var; | |
731 | } | |
732 | #undef FUNC_NAME | |
733 | ||
734 | SCM | |
735 | scm_c_module_lookup (SCM module, const char *name) | |
736 | { | |
cc95e00a | 737 | return scm_module_lookup (module, scm_from_locale_symbol (name)); |
86d31dfe MV |
738 | } |
739 | ||
740 | SCM | |
741 | scm_module_lookup (SCM module, SCM sym) | |
742 | #define FUNC_NAME "module-lookup" | |
743 | { | |
744 | SCM var; | |
745 | SCM_VALIDATE_MODULE (1, module); | |
746 | ||
747 | var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); | |
7888309b | 748 | if (scm_is_false (var)) |
7ab42fa2 | 749 | unbound_variable (FUNC_NAME, sym); |
86d31dfe MV |
750 | return var; |
751 | } | |
752 | #undef FUNC_NAME | |
753 | ||
754 | SCM | |
755 | scm_c_lookup (const char *name) | |
756 | { | |
cc95e00a | 757 | return scm_lookup (scm_from_locale_symbol (name)); |
86d31dfe MV |
758 | } |
759 | ||
760 | SCM | |
761 | scm_lookup (SCM sym) | |
762 | { | |
763 | SCM var = | |
764 | scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); | |
7888309b | 765 | if (scm_is_false (var)) |
7ab42fa2 | 766 | unbound_variable (NULL, sym); |
86d31dfe MV |
767 | return var; |
768 | } | |
769 | ||
ef8e9356 AW |
770 | SCM |
771 | scm_public_variable (SCM module_name, SCM name) | |
772 | { | |
773 | SCM mod, iface; | |
774 | ||
775 | mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name, | |
776 | k_ensure, SCM_BOOL_F); | |
777 | ||
778 | if (scm_is_false (mod)) | |
779 | scm_misc_error ("public-lookup", "Module named ~s does not exist", | |
780 | scm_list_1 (module_name)); | |
781 | ||
782 | iface = scm_module_public_interface (mod); | |
783 | ||
784 | if (scm_is_false (iface)) | |
785 | scm_misc_error ("public-lookup", "Module ~s has no public interface", | |
786 | scm_list_1 (mod)); | |
787 | ||
788 | return scm_module_variable (iface, name); | |
789 | } | |
790 | ||
791 | SCM | |
792 | scm_private_variable (SCM module_name, SCM name) | |
793 | { | |
794 | SCM mod; | |
795 | ||
796 | mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name, | |
797 | k_ensure, SCM_BOOL_F); | |
798 | ||
799 | if (scm_is_false (mod)) | |
800 | scm_misc_error ("private-lookup", "Module named ~s does not exist", | |
801 | scm_list_1 (module_name)); | |
802 | ||
803 | return scm_module_variable (mod, name); | |
804 | } | |
805 | ||
806 | SCM | |
807 | scm_c_public_variable (const char *module_name, const char *name) | |
808 | { | |
809 | return scm_public_variable (convert_module_name (module_name), | |
810 | scm_from_locale_symbol (name)); | |
811 | } | |
812 | ||
813 | SCM | |
814 | scm_c_private_variable (const char *module_name, const char *name) | |
815 | { | |
816 | return scm_private_variable (convert_module_name (module_name), | |
817 | scm_from_locale_symbol (name)); | |
818 | } | |
819 | ||
820 | SCM | |
821 | scm_public_lookup (SCM module_name, SCM name) | |
822 | { | |
823 | SCM var; | |
824 | ||
825 | var = scm_public_variable (module_name, name); | |
826 | ||
827 | if (scm_is_false (var)) | |
828 | scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s", | |
829 | scm_list_2 (name, module_name)); | |
830 | ||
831 | return var; | |
832 | } | |
833 | ||
834 | SCM | |
835 | scm_private_lookup (SCM module_name, SCM name) | |
836 | { | |
837 | SCM var; | |
838 | ||
839 | var = scm_private_variable (module_name, name); | |
840 | ||
841 | if (scm_is_false (var)) | |
842 | scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s", | |
843 | scm_list_2 (name, module_name)); | |
844 | ||
845 | return var; | |
846 | } | |
847 | ||
848 | SCM | |
849 | scm_c_public_lookup (const char *module_name, const char *name) | |
850 | { | |
851 | return scm_public_lookup (convert_module_name (module_name), | |
852 | scm_from_locale_symbol (name)); | |
853 | } | |
854 | ||
855 | SCM | |
856 | scm_c_private_lookup (const char *module_name, const char *name) | |
857 | { | |
858 | return scm_private_lookup (convert_module_name (module_name), | |
859 | scm_from_locale_symbol (name)); | |
860 | } | |
861 | ||
862 | SCM | |
863 | scm_public_ref (SCM module_name, SCM name) | |
864 | { | |
865 | return scm_variable_ref (scm_public_lookup (module_name, name)); | |
866 | } | |
867 | ||
868 | SCM | |
869 | scm_private_ref (SCM module_name, SCM name) | |
870 | { | |
871 | return scm_variable_ref (scm_private_lookup (module_name, name)); | |
872 | } | |
873 | ||
874 | SCM | |
875 | scm_c_public_ref (const char *module_name, const char *name) | |
876 | { | |
877 | return scm_public_ref (convert_module_name (module_name), | |
878 | scm_from_locale_symbol (name)); | |
879 | } | |
880 | ||
881 | SCM | |
882 | scm_c_private_ref (const char *module_name, const char *name) | |
883 | { | |
884 | return scm_private_ref (convert_module_name (module_name), | |
885 | scm_from_locale_symbol (name)); | |
886 | } | |
887 | ||
86d31dfe MV |
888 | SCM |
889 | scm_c_module_define (SCM module, const char *name, SCM value) | |
890 | { | |
cc95e00a | 891 | return scm_module_define (module, scm_from_locale_symbol (name), value); |
86d31dfe MV |
892 | } |
893 | ||
894 | SCM | |
895 | scm_module_define (SCM module, SCM sym, SCM value) | |
896 | #define FUNC_NAME "module-define" | |
897 | { | |
898 | SCM var; | |
899 | SCM_VALIDATE_MODULE (1, module); | |
900 | ||
901 | var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T); | |
902 | SCM_VARIABLE_SET (var, value); | |
903 | return var; | |
904 | } | |
905 | #undef FUNC_NAME | |
906 | ||
907 | SCM | |
908 | scm_c_define (const char *name, SCM value) | |
909 | { | |
cc95e00a | 910 | return scm_define (scm_from_locale_symbol (name), value); |
86d31dfe MV |
911 | } |
912 | ||
c7a2a803 AW |
913 | SCM_DEFINE (scm_define, "define!", 2, 0, 0, |
914 | (SCM sym, SCM value), | |
915 | "Define @var{sym} to be @var{value} in the current module." | |
916 | "Returns the variable itself. Note that this is a procedure, " | |
917 | "not a macro.") | |
918 | #define FUNC_NAME s_scm_define | |
86d31dfe | 919 | { |
c7a2a803 AW |
920 | SCM var; |
921 | SCM_VALIDATE_SYMBOL (SCM_ARG1, sym); | |
922 | var = scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T); | |
86d31dfe MV |
923 | SCM_VARIABLE_SET (var, value); |
924 | return var; | |
925 | } | |
c7a2a803 | 926 | #undef FUNC_NAME |
86d31dfe | 927 | |
608860a5 LC |
928 | SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0, |
929 | (SCM module, SCM variable), | |
930 | "Return the symbol under which @var{variable} is bound in " | |
931 | "@var{module} or @var{#f} if @var{variable} is not visible " | |
932 | "from @var{module}. If @var{module} is @code{#f}, then the " | |
933 | "pre-module obarray is used.") | |
934 | #define FUNC_NAME s_scm_module_reverse_lookup | |
86d31dfe MV |
935 | { |
936 | SCM obarray; | |
c014a02e | 937 | long i, n; |
86d31dfe | 938 | |
7888309b | 939 | if (scm_is_false (module)) |
86d31dfe MV |
940 | obarray = scm_pre_modules_obarray; |
941 | else | |
942 | { | |
943 | SCM_VALIDATE_MODULE (1, module); | |
944 | obarray = SCM_MODULE_OBARRAY (module); | |
945 | } | |
946 | ||
1606312f LC |
947 | SCM_VALIDATE_VARIABLE (SCM_ARG2, variable); |
948 | ||
6dc1cd1e MV |
949 | if (!SCM_HASHTABLE_P (obarray)) |
950 | return SCM_BOOL_F; | |
951 | ||
86d31dfe MV |
952 | /* XXX - We do not use scm_hash_fold here to avoid searching the |
953 | whole obarray. We should have a scm_hash_find procedure. */ | |
954 | ||
c35738c1 | 955 | n = SCM_HASHTABLE_N_BUCKETS (obarray); |
86d31dfe MV |
956 | for (i = 0; i < n; ++i) |
957 | { | |
4057a3e0 | 958 | SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle; |
d2e53ed6 | 959 | while (!scm_is_null (ls)) |
86d31dfe MV |
960 | { |
961 | handle = SCM_CAR (ls); | |
741e83fc | 962 | |
b2b33168 | 963 | if (SCM_UNPACK (SCM_CAR (handle)) == 0) |
741e83fc LC |
964 | { |
965 | /* FIXME: We hit a weak pair whose car has become unreachable. | |
966 | We should remove the pair in question or something. */ | |
967 | } | |
968 | else | |
969 | { | |
d223c3fc | 970 | if (scm_is_eq (SCM_CDR (handle), variable)) |
741e83fc LC |
971 | return SCM_CAR (handle); |
972 | } | |
973 | ||
86d31dfe MV |
974 | ls = SCM_CDR (ls); |
975 | } | |
976 | } | |
977 | ||
1606312f LC |
978 | if (!scm_is_false (module)) |
979 | { | |
980 | /* Try the `uses' list. */ | |
981 | SCM uses = SCM_MODULE_USES (module); | |
982 | while (scm_is_pair (uses)) | |
983 | { | |
984 | SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable); | |
985 | if (scm_is_true (sym)) | |
986 | return sym; | |
987 | uses = SCM_CDR (uses); | |
988 | } | |
989 | } | |
86d31dfe MV |
990 | |
991 | return SCM_BOOL_F; | |
992 | } | |
993 | #undef FUNC_NAME | |
994 | ||
995 | SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0, | |
996 | (), | |
997 | "Return the obarray that is used for all new bindings before " | |
998 | "the module system is booted. The first call to " | |
999 | "@code{set-current-module} will boot the module system.") | |
1000 | #define FUNC_NAME s_scm_get_pre_modules_obarray | |
1001 | { | |
1002 | return scm_pre_modules_obarray; | |
1003 | } | |
1004 | #undef FUNC_NAME | |
1005 | ||
d02b98e9 MV |
1006 | SCM_SYMBOL (scm_sym_system_module, "system-module"); |
1007 | ||
86d31dfe MV |
1008 | void |
1009 | scm_modules_prehistory () | |
1010 | { | |
f39448c5 | 1011 | scm_pre_modules_obarray = scm_c_make_hash_table (1533); |
86d31dfe MV |
1012 | } |
1013 | ||
1ffa265b MD |
1014 | void |
1015 | scm_init_modules () | |
1016 | { | |
a0599745 | 1017 | #include "libguile/modules.x" |
86d31dfe MV |
1018 | module_make_local_var_x_var = scm_c_define ("module-make-local-var!", |
1019 | SCM_UNDEFINED); | |
e841c3e0 | 1020 | scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0); |
e841c3e0 | 1021 | scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0); |
55000e5f | 1022 | |
f39448c5 | 1023 | the_module = scm_make_fluid (); |
1ffa265b MD |
1024 | } |
1025 | ||
86d31dfe | 1026 | static void |
1ffa265b MD |
1027 | scm_post_boot_init_modules () |
1028 | { | |
86d31dfe | 1029 | SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type")); |
904a077d | 1030 | scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct); |
d02b98e9 | 1031 | |
f39448c5 | 1032 | resolve_module_var = scm_c_lookup ("resolve-module"); |
57ced5b9 | 1033 | define_module_star_var = scm_c_lookup ("define-module*"); |
f39448c5 AW |
1034 | process_use_modules_var = scm_c_lookup ("process-use-modules"); |
1035 | module_export_x_var = scm_c_lookup ("module-export!"); | |
1036 | the_root_module_var = scm_c_lookup ("the-root-module"); | |
1037 | default_duplicate_binding_procedures_var = | |
1038 | scm_c_lookup ("default-duplicate-binding-procedures"); | |
993dae86 | 1039 | module_public_interface_var = scm_c_lookup ("module-public-interface"); |
ef8e9356 | 1040 | k_ensure = scm_from_locale_keyword ("ensure"); |
d02b98e9 | 1041 | |
e3365c07 | 1042 | scm_module_system_booted_p = 1; |
1ffa265b | 1043 | } |
89e00824 ML |
1044 | |
1045 | /* | |
1046 | Local Variables: | |
1047 | c-file-style: "gnu" | |
1048 | End: | |
1049 | */ |