libguile/modules.c

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