libguile/modules.c

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