1 /* Copyright (C) 1998,2000,2001,2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
2 *
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.
7 *
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.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16 */
17
18
19
20 #ifdef HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include <stdarg.h>
25
26 #include "libguile/_scm.h"
27
28 #include "libguile/eval.h"
29 #include "libguile/smob.h"
30 #include "libguile/procprop.h"
31 #include "libguile/vectors.h"
32 #include "libguile/hashtab.h"
33 #include "libguile/struct.h"
34 #include "libguile/variable.h"
35 #include "libguile/fluids.h"
36 #include "libguile/deprecation.h"
37
38 #include "libguile/modules.h"
39
40 int scm_module_system_booted_p = 0;
41
42 scm_t_bits scm_module_tag;
43
44 static SCM the_module;
45
46 static SCM the_root_module_var;
47
48 static SCM
the_root_module()49 the_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
57 SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
58 (),
59 "Return the current module.")
60 #define FUNC_NAME s_scm_current_module
61 {
62 SCM curr = scm_fluid_ref (the_module);
63
64 return scm_is_true (curr) ? curr : the_root_module ();
65 }
66 #undef FUNC_NAME
67
68 static void scm_post_boot_init_modules (void);
69
70 SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
71 (SCM module),
72 "Set the current module to @var{module} and return\n"
73 "the previous current module.")
74 #define FUNC_NAME s_scm_set_current_module
75 {
76 SCM old;
77
78 if (!scm_module_system_booted_p)
79 scm_post_boot_init_modules ();
80
81 SCM_VALIDATE_MODULE (SCM_ARG1, module);
82
83 old = scm_current_module ();
84 scm_fluid_set_x (the_module, module);
85
86 return old;
87 }
88 #undef FUNC_NAME
89
90 SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
91 (),
92 "Return a specifier for the environment that contains\n"
93 "implementation--defined bindings, typically a superset of those\n"
94 "listed in the report. The intent is that this procedure will\n"
95 "return the environment in which the implementation would\n"
96 "evaluate expressions dynamically typed by the user.")
97 #define FUNC_NAME s_scm_interaction_environment
98 {
99 return scm_current_module ();
100 }
101 #undef FUNC_NAME
102
103 SCM
scm_c_call_with_current_module(SCM module,SCM (* func)(void *),void * data)104 scm_c_call_with_current_module (SCM module,
105 SCM (*func)(void *), void *data)
106 {
107 return scm_c_with_fluid (the_module, module, func, data);
108 }
109
110 void
scm_dynwind_current_module(SCM module)111 scm_dynwind_current_module (SCM module)
112 {
113 scm_dynwind_fluid (the_module, module);
114 }
115
116 /*
117 convert "A B C" to scheme list (A B C)
118 */
119 static SCM
convert_module_name(const char * name)120 convert_module_name (const char *name)
121 {
122 SCM list = SCM_EOL;
123 SCM *tail = &list;
124
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 {
135 SCM sym = scm_from_locale_symboln (name, ptr-name);
136 *tail = scm_cons (sym, SCM_EOL);
137 tail = SCM_CDRLOC (*tail);
138 }
139 name = ptr;
140 }
141
142 return list;
143 }
144
145 static SCM process_define_module_var;
146 static SCM process_use_modules_var;
147 static SCM resolve_module_var;
148
149 SCM
scm_c_resolve_module(const char * name)150 scm_c_resolve_module (const char *name)
151 {
152 return scm_resolve_module (convert_module_name (name));
153 }
154
155 SCM
scm_resolve_module(SCM name)156 scm_resolve_module (SCM name)
157 {
158 return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
159 }
160
161 SCM
scm_c_define_module(const char * name,void (* init)(void *),void * data)162 scm_c_define_module (const char *name,
163 void (*init)(void *), void *data)
164 {
165 SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
166 scm_list_1 (convert_module_name (name)));
167 if (init)
168 scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
169 return module;
170 }
171
172 void
scm_c_use_module(const char * name)173 scm_c_use_module (const char *name)
174 {
175 scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
176 scm_list_1 (scm_list_1 (convert_module_name (name))));
177 }
178
179 static SCM module_export_x_var;
180
181
182 /*
183 TODO: should export this function? --hwn.
184 */
185 static SCM
scm_export(SCM module,SCM namelist)186 scm_export (SCM module, SCM namelist)
187 {
188 return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
189 module, namelist);
190 }
191
192
193 /*
194 @code{scm_c_export}(@var{name-list})
195
196 @code{scm_c_export} exports the named bindings from the current
197 module, making them visible to users of the module. This function
198 takes a list of string arguments, terminated by NULL, e.g.
199
200 @example
201 scm_c_export ("add-double-record", "bamboozle-money", NULL);
202 @end example
203 */
204 void
scm_c_export(const char * name,...)205 scm_c_export (const char *name, ...)
206 {
207 if (name)
208 {
209 va_list ap;
210 SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
211 SCM *tail = SCM_CDRLOC (names);
212 va_start (ap, name);
213 while (1)
214 {
215 const char *n = va_arg (ap, const char *);
216 if (n == NULL)
217 break;
218 *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
219 tail = SCM_CDRLOC (*tail);
220 }
221 va_end (ap);
222 scm_export (scm_current_module(), names);
223 }
224 }
225
226
227 /* Environments */
228
229 SCM
scm_top_level_env(SCM thunk)230 scm_top_level_env (SCM thunk)
231 {
232 if (SCM_IMP (thunk))
233 return SCM_EOL;
234 else
235 return scm_cons (thunk, SCM_EOL);
236 }
237
238 SCM
scm_env_top_level(SCM env)239 scm_env_top_level (SCM env)
240 {
241 while (scm_is_pair (env))
242 {
243 SCM car_env = SCM_CAR (env);
244 if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
245 return car_env;
246 env = SCM_CDR (env);
247 }
248 return SCM_BOOL_F;
249 }
250
251 SCM_SYMBOL (sym_module, "module");
252
253 SCM
scm_lookup_closure_module(SCM proc)254 scm_lookup_closure_module (SCM proc)
255 {
256 if (scm_is_false (proc))
257 return the_root_module ();
258 else if (SCM_EVAL_CLOSURE_P (proc))
259 return SCM_PACK (SCM_SMOB_DATA (proc));
260 else
261 {
262 SCM mod = scm_procedure_property (proc, sym_module);
263 if (scm_is_false (mod))
264 mod = the_root_module ();
265 return mod;
266 }
267 }
268
269 SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
270 (SCM env),
271 "Return the module of @var{ENV}, a lexical environment.")
272 #define FUNC_NAME s_scm_env_module
273 {
274 return scm_lookup_closure_module (scm_env_top_level (env));
275 }
276 #undef FUNC_NAME
277
278 /*
279 * C level implementation of the standard eval closure
280 *
281 * This increases loading speed substantially.
282 * The code will be replaced by the low-level environments in next release.
283 */
284
285 static SCM module_make_local_var_x_var;
286
287 static SCM
module_variable(SCM module,SCM sym)288 module_variable (SCM module, SCM sym)
289 {
290 #define SCM_BOUND_THING_P(b) \
291 (scm_is_true (b))
292
293 /* 1. Check module obarray */
294 SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
295 if (SCM_BOUND_THING_P (b))
296 return b;
297 {
298 SCM binder = SCM_MODULE_BINDER (module);
299 if (scm_is_true (binder))
300 /* 2. Custom binder */
301 {
302 b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
303 if (SCM_BOUND_THING_P (b))
304 return b;
305 }
306 }
307 {
308 /* 3. Search the use list */
309 SCM uses = SCM_MODULE_USES (module);
310 while (scm_is_pair (uses))
311 {
312 b = module_variable (SCM_CAR (uses), sym);
313 if (SCM_BOUND_THING_P (b))
314 return b;
315 uses = SCM_CDR (uses);
316 }
317 return SCM_BOOL_F;
318 }
319 #undef SCM_BOUND_THING_P
320 }
321
322 scm_t_bits scm_tc16_eval_closure;
323
324 #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
325 #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
326 (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
327
328 /* NOTE: This function may be called by a smob application
329 or from another C function directly. */
330 SCM
scm_eval_closure_lookup(SCM eclo,SCM sym,SCM definep)331 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
332 {
333 SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
334 if (scm_is_true (definep))
335 {
336 if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
337 return SCM_BOOL_F;
338 return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
339 module, sym);
340 }
341 else
342 return module_variable (module, sym);
343 }
344
345 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
346 (SCM module),
347 "Return an eval closure for the module @var{module}.")
348 #define FUNC_NAME s_scm_standard_eval_closure
349 {
350 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
351 }
352 #undef FUNC_NAME
353
354
355 SCM_DEFINE (scm_standard_interface_eval_closure,
356 "standard-interface-eval-closure", 1, 0, 0,
357 (SCM module),
358 "Return a interface eval closure for the module @var{module}. "
359 "Such a closure does not allow new bindings to be added.")
360 #define FUNC_NAME s_scm_standard_interface_eval_closure
361 {
362 SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
363 SCM_UNPACK (module));
364 }
365 #undef FUNC_NAME
366
367 SCM
scm_module_lookup_closure(SCM module)368 scm_module_lookup_closure (SCM module)
369 {
370 if (scm_is_false (module))
371 return SCM_BOOL_F;
372 else
373 return SCM_MODULE_EVAL_CLOSURE (module);
374 }
375
376 SCM
scm_current_module_lookup_closure()377 scm_current_module_lookup_closure ()
378 {
379 if (scm_module_system_booted_p)
380 return scm_module_lookup_closure (scm_current_module ());
381 else
382 return SCM_BOOL_F;
383 }
384
385 SCM
scm_module_transformer(SCM module)386 scm_module_transformer (SCM module)
387 {
388 if (scm_is_false (module))
389 return SCM_BOOL_F;
390 else
391 return SCM_MODULE_TRANSFORMER (module);
392 }
393
394 SCM
scm_current_module_transformer()395 scm_current_module_transformer ()
396 {
397 if (scm_module_system_booted_p)
398 return scm_module_transformer (scm_current_module ());
399 else
400 return SCM_BOOL_F;
401 }
402
403 SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
404 (SCM module, SCM sym),
405 "")
406 #define FUNC_NAME s_scm_module_import_interface
407 {
408 #define SCM_BOUND_THING_P(b) (scm_is_true (b))
409 SCM uses;
410 SCM_VALIDATE_MODULE (SCM_ARG1, module);
411 /* Search the use list */
412 uses = SCM_MODULE_USES (module);
413 while (scm_is_pair (uses))
414 {
415 SCM _interface = SCM_CAR (uses);
416 /* 1. Check module obarray */
417 SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
418 if (SCM_BOUND_THING_P (b))
419 return _interface;
420 {
421 SCM binder = SCM_MODULE_BINDER (_interface);
422 if (scm_is_true (binder))
423 /* 2. Custom binder */
424 {
425 b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
426 if (SCM_BOUND_THING_P (b))
427 return _interface;
428 }
429 }
430 /* 3. Search use list recursively. */
431 _interface = scm_module_import_interface (_interface, sym);
432 if (scm_is_true (_interface))
433 return _interface;
434 uses = SCM_CDR (uses);
435 }
436 return SCM_BOOL_F;
437 }
438 #undef FUNC_NAME
439
440 /* scm_sym2var
441 *
442 * looks up the variable bound to SYM according to PROC. PROC should be
443 * a `eval closure' of some module.
444 *
445 * When no binding exists, and DEFINEP is true, create a new binding
446 * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
447 * false and no binding exists.
448 *
449 * When PROC is `#f', it is ignored and the binding is searched for in
450 * the scm_pre_modules_obarray (a `eq' hash table).
451 */
452
453 SCM scm_pre_modules_obarray;
454
455 SCM
scm_sym2var(SCM sym,SCM proc,SCM definep)456 scm_sym2var (SCM sym, SCM proc, SCM definep)
457 #define FUNC_NAME "scm_sym2var"
458 {
459 SCM var;
460
461 if (SCM_NIMP (proc))
462 {
463 if (SCM_EVAL_CLOSURE_P (proc))
464 {
465 /* Bypass evaluator in the standard case. */
466 var = scm_eval_closure_lookup (proc, sym, definep);
467 }
468 else
469 var = scm_call_2 (proc, sym, definep);
470 }
471 else
472 {
473 SCM handle;
474
475 if (scm_is_false (definep))
476 var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
477 else
478 {
479 handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
480 sym, SCM_BOOL_F);
481 var = SCM_CDR (handle);
482 if (scm_is_false (var))
483 {
484 var = scm_make_variable (SCM_UNDEFINED);
485 SCM_SETCDR (handle, var);
486 }
487 }
488 }
489
490 if (scm_is_true (var) && !SCM_VARIABLEP (var))
491 SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
492
493 return var;
494 }
495 #undef FUNC_NAME
496
497 SCM
scm_c_module_lookup(SCM module,const char * name)498 scm_c_module_lookup (SCM module, const char *name)
499 {
500 return scm_module_lookup (module, scm_from_locale_symbol (name));
501 }
502
503 SCM
scm_module_lookup(SCM module,SCM sym)504 scm_module_lookup (SCM module, SCM sym)
505 #define FUNC_NAME "module-lookup"
506 {
507 SCM var;
508 SCM_VALIDATE_MODULE (1, module);
509
510 var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
511 if (scm_is_false (var))
512 SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
513 return var;
514 }
515 #undef FUNC_NAME
516
517 SCM
scm_c_lookup(const char * name)518 scm_c_lookup (const char *name)
519 {
520 return scm_lookup (scm_from_locale_symbol (name));
521 }
522
523 SCM
scm_lookup(SCM sym)524 scm_lookup (SCM sym)
525 {
526 SCM var =
527 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
528 if (scm_is_false (var))
529 scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
530 return var;
531 }
532
533 SCM
scm_c_module_define(SCM module,const char * name,SCM value)534 scm_c_module_define (SCM module, const char *name, SCM value)
535 {
536 return scm_module_define (module, scm_from_locale_symbol (name), value);
537 }
538
539 SCM
scm_module_define(SCM module,SCM sym,SCM value)540 scm_module_define (SCM module, SCM sym, SCM value)
541 #define FUNC_NAME "module-define"
542 {
543 SCM var;
544 SCM_VALIDATE_MODULE (1, module);
545
546 var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
547 SCM_VARIABLE_SET (var, value);
548 return var;
549 }
550 #undef FUNC_NAME
551
552 SCM
scm_c_define(const char * name,SCM value)553 scm_c_define (const char *name, SCM value)
554 {
555 return scm_define (scm_from_locale_symbol (name), value);
556 }
557
558 SCM
scm_define(SCM sym,SCM value)559 scm_define (SCM sym, SCM value)
560 {
561 SCM var =
562 scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
563 SCM_VARIABLE_SET (var, value);
564 return var;
565 }
566
567 SCM
scm_module_reverse_lookup(SCM module,SCM variable)568 scm_module_reverse_lookup (SCM module, SCM variable)
569 #define FUNC_NAME "module-reverse-lookup"
570 {
571 SCM obarray;
572 long i, n;
573
574 if (scm_is_false (module))
575 obarray = scm_pre_modules_obarray;
576 else
577 {
578 SCM_VALIDATE_MODULE (1, module);
579 obarray = SCM_MODULE_OBARRAY (module);
580 }
581
582 if (!SCM_HASHTABLE_P (obarray))
583 return SCM_BOOL_F;
584
585 /* XXX - We do not use scm_hash_fold here to avoid searching the
586 whole obarray. We should have a scm_hash_find procedure. */
587
588 n = SCM_HASHTABLE_N_BUCKETS (obarray);
589 for (i = 0; i < n; ++i)
590 {
591 SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
592 while (!scm_is_null (ls))
593 {
594 handle = SCM_CAR (ls);
595 if (SCM_CDR (handle) == variable)
596 return SCM_CAR (handle);
597 ls = SCM_CDR (ls);
598 }
599 }
600
601 /* Try the `uses' list.
602 */
603 {
604 SCM uses = SCM_MODULE_USES (module);
605 while (scm_is_pair (uses))
606 {
607 SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
608 if (scm_is_true (sym))
609 return sym;
610 uses = SCM_CDR (uses);
611 }
612 }
613
614 return SCM_BOOL_F;
615 }
616 #undef FUNC_NAME
617
618 SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
619 (),
620 "Return the obarray that is used for all new bindings before "
621 "the module system is booted. The first call to "
622 "@code{set-current-module} will boot the module system.")
623 #define FUNC_NAME s_scm_get_pre_modules_obarray
624 {
625 return scm_pre_modules_obarray;
626 }
627 #undef FUNC_NAME
628
629 SCM_SYMBOL (scm_sym_system_module, "system-module");
630
631 SCM
scm_system_module_env_p(SCM env)632 scm_system_module_env_p (SCM env)
633 {
634 SCM proc = scm_env_top_level (env);
635 if (scm_is_false (proc))
636 return SCM_BOOL_T;
637 return ((scm_is_true (scm_procedure_property (proc,
638 scm_sym_system_module)))
639 ? SCM_BOOL_T
640 : SCM_BOOL_F);
641 }
642
643 void
scm_modules_prehistory()644 scm_modules_prehistory ()
645 {
646 scm_pre_modules_obarray
647 = scm_permanent_object (scm_c_make_hash_table (1533));
648 }
649
650 void
scm_init_modules()651 scm_init_modules ()
652 {
653 #include "libguile/modules.x"
654 module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
655 SCM_UNDEFINED);
656 scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
657 scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
658 scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
659
660 the_module = scm_permanent_object (scm_make_fluid ());
661 }
662
663 static void
scm_post_boot_init_modules()664 scm_post_boot_init_modules ()
665 {
666 #define PERM(x) scm_permanent_object(x)
667
668 SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
669 scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
670
671 resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
672 process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
673 process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
674 module_export_x_var = PERM (scm_c_lookup ("module-export!"));
675 the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
676
677 scm_module_system_booted_p = 1;
678 }
679
680 /*
681 Local Variables:
682 c-file-style: "gnu"
683 End:
684 */
685