libguile/modules.c

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