libguile/modules.c

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