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