libguile/modules.c

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