libguile/modules.c

   1 /* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012 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   if (scm_module_system_booted_p)
  84     return scm_fluid_ref (the_module);
  85   else
  86     return SCM_BOOL_F;
  87 }
  88 #undef FUNC_NAME
  89
  90 static void scm_post_boot_init_modules (void);
  91
  92 SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
  93             (SCM module),
  94             "Set the current module to @var{module} and return\n"
  95             "the previous current module.")
  96 #define FUNC_NAME s_scm_set_current_module
  97 {
  98   SCM old;
  99
 100   if (!scm_module_system_booted_p)
 101     scm_post_boot_init_modules ();
 102
 103   SCM_VALIDATE_MODULE (SCM_ARG1, module);
 104
 105   old = scm_current_module ();
 106   scm_fluid_set_x (the_module, module);
 107
 108   return old;
 109 }
 110 #undef FUNC_NAME
 111
 112 SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
 113             (),
 114             "Return a specifier for the environment that contains\n"
 115             "implementation--defined bindings, typically a superset of those\n"
 116             "listed in the report.  The intent is that this procedure will\n"
 117             "return the environment in which the implementation would\n"
 118             "evaluate expressions dynamically typed by the user.")
 119 #define FUNC_NAME s_scm_interaction_environment
 120 {
 121   return scm_current_module ();
 122 }
 123 #undef FUNC_NAME
 124
 125 SCM
 126 scm_c_call_with_current_module (SCM module,
 127                                 SCM (*func)(void *), void *data)
 128 {
 129   return scm_c_with_fluid (the_module, module, func, data);
 130 }
 131
 132 void
 133 scm_dynwind_current_module (SCM module)
 134 {
 135   scm_dynwind_fluid (the_module, module);
 136 }
 137
 138 /*
 139   convert "A B C" to scheme list (A B C)
 140  */
 141 static SCM
 142 convert_module_name (const char *name)
 143 {
 144   SCM list = SCM_EOL;
 145   SCM *tail = &list;
 146
 147   const char *ptr;
 148   while (*name)
 149     {
 150       while (*name == ' ')
 151         name++;
 152       ptr = name;
 153       while (*ptr && *ptr != ' ')
 154         ptr++;
 155       if (ptr > name)
 156         {
 157           SCM sym = scm_from_locale_symboln (name, ptr-name);
 158           *tail = scm_cons (sym, SCM_EOL);
 159           tail = SCM_CDRLOC (*tail);
 160         }
 161       name = ptr;
 162     }
 163
 164   return list;
 165 }
 166
 167 SCM
 168 scm_c_resolve_module (const char *name)
 169 {
 170   return scm_resolve_module (convert_module_name (name));
 171 }
 172
 173 SCM
 174 scm_resolve_module (SCM name)
 175 {
 176   return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
 177 }
 178
 179 SCM
 180 scm_c_define_module (const char *name,
 181                      void (*init)(void *), void *data)
 182 {
 183   SCM module = scm_call_1 (SCM_VARIABLE_REF (define_module_star_var),
 184                            convert_module_name (name));
 185   if (init)
 186     scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
 187   return module;
 188 }
 189
 190 void
 191 scm_c_use_module (const char *name)
 192 {
 193   scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
 194               scm_list_1 (scm_list_1 (convert_module_name (name))));
 195 }
 196
 197 SCM
 198 scm_module_export (SCM module, SCM namelist)
 199 {
 200   return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
 201                      module, namelist);
 202 }
 203
 204
 205 /*
 206   @code{scm_c_export}(@var{name-list})
 207
 208   @code{scm_c_export} exports the named bindings from the current
 209   module, making them visible to users of the module. This function
 210   takes a list of string arguments, terminated by NULL, e.g.
 211
 212   @example
 213     scm_c_export ("add-double-record", "bamboozle-money", NULL);
 214   @end example
 215 */
 216 void
 217 scm_c_export (const char *name, ...)
 218 {
 219   if (name)
 220     {
 221       va_list ap;
 222       SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
 223       SCM *tail = SCM_CDRLOC (names);
 224       va_start (ap, name);
 225       while (1)
 226         {
 227           const char *n = va_arg (ap, const char *);
 228           if (n == NULL)
 229             break;
 230           *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
 231           tail = SCM_CDRLOC (*tail);
 232         }
 233       va_end (ap);
 234       scm_module_export (scm_current_module (), names);
 235     }
 236 }
 237
 238
 239 /*
 240  * C level implementation of the standard eval closure
 241  *
 242  * This increases loading speed substantially.  The code may be
 243  * replaced by something based on environments.[ch], in a future
 244  * release.
 245  */
 246
 247 /* Return the list of default duplicate binding handlers (procedures).  */
 248 static inline SCM
 249 default_duplicate_binding_handlers (void)
 250 {
 251   SCM get_handlers;
 252
 253   get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var);
 254
 255   return (scm_call_0 (get_handlers));
 256 }
 257
 258 /* Resolve the import of SYM in MODULE, where SYM is currently provided by
 259    both IFACE1 as VAR1 and IFACE2 as VAR2.  Return the variable chosen by the
 260    duplicate binding handlers or `#f'.  */
 261 static inline SCM
 262 resolve_duplicate_binding (SCM module, SCM sym,
 263                            SCM iface1, SCM var1,
 264                            SCM iface2, SCM var2)
 265 {
 266   SCM args[8];
 267   SCM handlers;
 268   SCM result = SCM_BOOL_F;
 269
 270   if (scm_is_eq (var1, var2))
 271     return var1;
 272
 273   args[0] = module;
 274   args[1] = sym;
 275   args[2] = iface1;
 276   args[3] = SCM_VARIABLE_REF (var1);
 277   if (SCM_UNBNDP (args[3]))
 278     args[3] = SCM_BOOL_F;
 279   args[4] = iface2;
 280   args[5] = SCM_VARIABLE_REF (var2);
 281   if (SCM_UNBNDP (args[5]))
 282     args[5] = SCM_BOOL_F;
 283   args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F);
 284   args[7] = SCM_BOOL_F;
 285
 286   handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
 287   if (scm_is_false (handlers))
 288     handlers = default_duplicate_binding_handlers ();
 289
 290   for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers))
 291     {
 292       if (scm_is_true (args[6]))
 293         {
 294           args[7] = SCM_VARIABLE_REF (args[6]);
 295           if (SCM_UNBNDP (args[7]))
 296             args[7] = SCM_BOOL_F;
 297         }
 298
 299       result = scm_call_n (SCM_CAR (handlers), args, 8);
 300
 301       if (scm_is_true (result))
 302         return result;
 303     }
 304
 305   return SCM_BOOL_F;
 306 }
 307
 308 /* No lock is needed for access to this variable, as there are no
 309    threads before modules are booted.  */
 310 SCM scm_pre_modules_obarray;
 311
 312 /* Lookup SYM as an imported variable of MODULE.  */
 313 static inline SCM
 314 module_imported_variable (SCM module, SCM sym)
 315 {
 316 #define SCM_BOUND_THING_P scm_is_true
 317   register SCM var, imports;
 318
 319   /* Search cached imported bindings.  */
 320   imports = SCM_MODULE_IMPORT_OBARRAY (module);
 321   var = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
 322   if (SCM_BOUND_THING_P (var))
 323     return var;
 324
 325   {
 326     /* Search the use list for yet uncached imported bindings, possibly
 327        resolving duplicates as needed and caching the result in the import
 328        obarray.  */
 329     SCM uses;
 330     SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F;
 331
 332     for (uses = SCM_MODULE_USES (module);
 333          scm_is_pair (uses);
 334          uses = SCM_CDR (uses))
 335       {
 336         SCM iface;
 337
 338         iface = SCM_CAR (uses);
 339         var = scm_module_variable (iface, sym);
 340
 341         if (SCM_BOUND_THING_P (var))
 342           {
 343             if (SCM_BOUND_THING_P (found_var))
 344               {
 345                 /* SYM is a duplicate binding (imported more than once) so we
 346                    need to resolve it.  */
 347                 found_var = resolve_duplicate_binding (module, sym,
 348                                                        found_iface, found_var,
 349                                                        iface, var);
 350
 351                 /* Note that it could be that FOUND_VAR doesn't belong
 352                    either to FOUND_IFACE or to IFACE, if it was created
 353                    by merge-generics.  The right thing to do there would
 354                    be to treat the import obarray as the iface, but the
 355                    import obarray isn't actually a module.  Oh well.  */
 356                 if (scm_is_eq (found_var, var))
 357                   found_iface = iface;
 358               }
 359             else
 360               /* Keep track of the variable we found and check for other
 361                  occurences of SYM in the use list.  */
 362               found_var = var, found_iface = iface;
 363           }
 364       }
 365
 366     if (SCM_BOUND_THING_P (found_var))
 367       {
 368         /* Save the lookup result for future reference.  */
 369         (void) scm_hashq_set_x (imports, sym, found_var);
 370         return found_var;
 371       }
 372   }
 373
 374   return SCM_BOOL_F;
 375 #undef SCM_BOUND_THING_P
 376 }
 377
 378 SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
 379             (SCM module, SCM sym),
 380             "Return the variable bound to @var{sym} in @var{module}.  Return "
 381             "@code{#f} is @var{sym} is not bound locally in @var{module}.")
 382 #define FUNC_NAME s_scm_module_local_variable
 383 {
 384 #define SCM_BOUND_THING_P(b) \
 385   (scm_is_true (b))
 386
 387   register SCM b;
 388
 389   if (scm_module_system_booted_p)
 390     SCM_VALIDATE_MODULE (1, module);
 391
 392   SCM_VALIDATE_SYMBOL (2, sym);
 393
 394   if (scm_is_false (module))
 395     return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
 396
 397   /* 1. Check module obarray */
 398   b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 399   if (SCM_BOUND_THING_P (b))
 400     return b;
 401
 402   /* At this point we should just be able to return #f, but there is the
 403      possibility that a custom binder establishes a mapping for this
 404      variable.
 405
 406      However a custom binder should be called only if there is no
 407      imported binding with the name SYM. So here instead of the order:
 408
 409        2. Search imported bindings.  In order to be consistent with
 410           `module-variable', the binder gets called only when no
 411           imported binding matches SYM.
 412
 413        3. Query the custom binder.
 414
 415      we first check if there is a binder at all, and if not, just return
 416      #f directly.
 417   */
 418
 419   {
 420     SCM binder = SCM_MODULE_BINDER (module);
 421
 422     if (scm_is_true (binder))
 423       {
 424         /* 2. */
 425         b = module_imported_variable (module, sym);
 426         if (SCM_BOUND_THING_P (b))
 427           return SCM_BOOL_F;
 428
 429         /* 3. */
 430         b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
 431         if (SCM_BOUND_THING_P (b))
 432           return b;
 433       }
 434   }
 435
 436   return SCM_BOOL_F;
 437
 438 #undef SCM_BOUND_THING_P
 439 }
 440 #undef FUNC_NAME
 441
 442 SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
 443             (SCM module, SCM sym),
 444             "Return the variable bound to @var{sym} in @var{module}.  This "
 445             "may be both a local variable or an imported variable.  Return "
 446             "@code{#f} is @var{sym} is not bound in @var{module}.")
 447 #define FUNC_NAME s_scm_module_variable
 448 {
 449 #define SCM_BOUND_THING_P(b) \
 450   (scm_is_true (b))
 451
 452   register SCM var;
 453
 454   if (scm_module_system_booted_p)
 455     SCM_VALIDATE_MODULE (1, module);
 456
 457   SCM_VALIDATE_SYMBOL (2, sym);
 458
 459   if (scm_is_false (module))
 460     return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
 461
 462   /* 1. Check module obarray */
 463   var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 464   if (SCM_BOUND_THING_P (var))
 465     return var;
 466
 467   /* 2. Search among the imported variables.  */
 468   var = module_imported_variable (module, sym);
 469   if (SCM_BOUND_THING_P (var))
 470     return var;
 471
 472   {
 473     /* 3. Query the custom binder.  */
 474     SCM binder;
 475
 476     binder = SCM_MODULE_BINDER (module);
 477     if (scm_is_true (binder))
 478       {
 479         var = scm_call_3 (binder, module, sym, SCM_BOOL_F);
 480         if (SCM_BOUND_THING_P (var))
 481           return var;
 482       }
 483   }
 484
 485   return SCM_BOOL_F;
 486
 487 #undef SCM_BOUND_THING_P
 488 }
 489 #undef FUNC_NAME
 490
 491 SCM
 492 scm_module_ensure_local_variable (SCM module, SCM sym)
 493 #define FUNC_NAME "module-ensure-local-variable"
 494 {
 495   if (SCM_LIKELY (scm_module_system_booted_p))
 496     {
 497       SCM_VALIDATE_MODULE (1, module);
 498       SCM_VALIDATE_SYMBOL (2, sym);
 499
 500       return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
 501                          module, sym);
 502     }
 503
 504   {
 505     SCM handle, var;
 506
 507     handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
 508                                         sym, SCM_BOOL_F);
 509     var = SCM_CDR (handle);
 510
 511     if (scm_is_false (var))
 512       {
 513         var = scm_make_variable (SCM_UNDEFINED);
 514         SCM_SETCDR (handle, var);
 515       }
 516
 517     return var;
 518   }
 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_SYMBOL (sym_macroexpand, "macroexpand");
 583
 584 SCM_DEFINE (scm_module_transformer, "module-transformer", 1, 0, 0,
 585             (SCM module),
 586             "Returns the syntax expander for the given module.")
 587 #define FUNC_NAME s_scm_module_transformer
 588 {
 589   if (SCM_UNLIKELY (scm_is_false (module)))
 590     {
 591       SCM v = scm_hashq_ref (scm_pre_modules_obarray,
 592                              sym_macroexpand,
 593                              SCM_BOOL_F);
 594       if (scm_is_false (v))
 595         SCM_MISC_ERROR ("no module, and `macroexpand' unbound", SCM_EOL);
 596       return SCM_VARIABLE_REF (v);
 597     }
 598   else
 599     {
 600       SCM_VALIDATE_MODULE (SCM_ARG1, module);
 601       return SCM_MODULE_TRANSFORMER (module);
 602     }
 603 }
 604 #undef FUNC_NAME
 605
 606 SCM
 607 scm_current_module_transformer ()
 608 {
 609   return scm_module_transformer (scm_current_module ());
 610 }
 611
 612 SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
 613             (SCM module, SCM sym),
 614             "Return the module or interface from which @var{sym} is imported "
 615             "in @var{module}.  If @var{sym} is not imported (i.e., it is not "
 616             "defined in @var{module} or it is a module-local binding instead "
 617             "of an imported one), then @code{#f} is returned.")
 618 #define FUNC_NAME s_scm_module_import_interface
 619 {
 620   SCM var, result = SCM_BOOL_F;
 621
 622   SCM_VALIDATE_MODULE (1, module);
 623   SCM_VALIDATE_SYMBOL (2, sym);
 624
 625   var = scm_module_variable (module, sym);
 626   if (scm_is_true (var))
 627     {
 628       /* Look for the module that provides VAR.  */
 629       SCM local_var;
 630
 631       local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
 632                                  SCM_UNDEFINED);
 633       if (scm_is_eq (local_var, var))
 634         result = module;
 635       else
 636         {
 637           /* Look for VAR among the used modules.  */
 638           SCM uses, imported_var;
 639
 640           for (uses = SCM_MODULE_USES (module);
 641                scm_is_pair (uses) && scm_is_false (result);
 642                uses = SCM_CDR (uses))
 643             {
 644               imported_var = scm_module_variable (SCM_CAR (uses), sym);
 645               if (scm_is_eq (imported_var, var))
 646                 result = SCM_CAR (uses);
 647             }
 648         }
 649     }
 650
 651   return result;
 652 }
 653 #undef FUNC_NAME
 654
 655 SCM
 656 scm_module_public_interface (SCM module)
 657 {
 658   return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var), module);
 659 }
 660
 661 SCM
 662 scm_c_module_lookup (SCM module, const char *name)
 663 {
 664   return scm_module_lookup (module, scm_from_locale_symbol (name));
 665 }
 666
 667 SCM
 668 scm_module_lookup (SCM module, SCM sym)
 669 #define FUNC_NAME "module-lookup"
 670 {
 671   SCM var;
 672   var = scm_module_variable (module, sym);
 673   if (scm_is_false (var))
 674     unbound_variable (FUNC_NAME, sym);
 675   return var;
 676 }
 677 #undef FUNC_NAME
 678
 679 SCM
 680 scm_c_lookup (const char *name)
 681 {
 682   return scm_lookup (scm_from_locale_symbol (name));
 683 }
 684
 685 SCM
 686 scm_lookup (SCM sym)
 687 {
 688   return scm_module_lookup (scm_current_module (), sym);
 689 }
 690
 691 SCM
 692 scm_public_variable (SCM module_name, SCM name)
 693 {
 694   SCM mod, iface;
 695
 696   mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
 697                     k_ensure, SCM_BOOL_F);
 698
 699   if (scm_is_false (mod))
 700     scm_misc_error ("public-lookup", "Module named ~s does not exist",
 701                     scm_list_1 (module_name));
 702
 703   iface = scm_module_public_interface (mod);
 704
 705   if (scm_is_false (iface))
 706     scm_misc_error ("public-lookup", "Module ~s has no public interface",
 707                     scm_list_1 (mod));
 708
 709   return scm_module_variable (iface, name);
 710 }
 711
 712 SCM
 713 scm_private_variable (SCM module_name, SCM name)
 714 {
 715   SCM mod;
 716
 717   mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
 718                     k_ensure, SCM_BOOL_F);
 719
 720   if (scm_is_false (mod))
 721     scm_misc_error ("private-lookup", "Module named ~s does not exist",
 722                     scm_list_1 (module_name));
 723
 724   return scm_module_variable (mod, name);
 725 }
 726
 727 SCM
 728 scm_c_public_variable (const char *module_name, const char *name)
 729 {
 730   return scm_public_variable (convert_module_name (module_name),
 731                               scm_from_locale_symbol (name));
 732 }
 733
 734 SCM
 735 scm_c_private_variable (const char *module_name, const char *name)
 736 {
 737   return scm_private_variable (convert_module_name (module_name),
 738                                scm_from_locale_symbol (name));
 739 }
 740
 741 SCM
 742 scm_public_lookup (SCM module_name, SCM name)
 743 {
 744   SCM var;
 745
 746   var = scm_public_variable (module_name, name);
 747
 748   if (scm_is_false (var))
 749     scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s",
 750                     scm_list_2 (name, module_name));
 751
 752   return var;
 753 }
 754
 755 SCM
 756 scm_private_lookup (SCM module_name, SCM name)
 757 {
 758   SCM var;
 759
 760   var = scm_private_variable (module_name, name);
 761
 762   if (scm_is_false (var))
 763     scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s",
 764                     scm_list_2 (name, module_name));
 765
 766   return var;
 767 }
 768
 769 SCM
 770 scm_c_public_lookup (const char *module_name, const char *name)
 771 {
 772   return scm_public_lookup (convert_module_name (module_name),
 773                             scm_from_locale_symbol (name));
 774 }
 775
 776 SCM
 777 scm_c_private_lookup (const char *module_name, const char *name)
 778 {
 779   return scm_private_lookup (convert_module_name (module_name),
 780                              scm_from_locale_symbol (name));
 781 }
 782
 783 SCM
 784 scm_public_ref (SCM module_name, SCM name)
 785 {
 786   return scm_variable_ref (scm_public_lookup (module_name, name));
 787 }
 788
 789 SCM
 790 scm_private_ref (SCM module_name, SCM name)
 791 {
 792   return scm_variable_ref (scm_private_lookup (module_name, name));
 793 }
 794
 795 SCM
 796 scm_c_public_ref (const char *module_name, const char *name)
 797 {
 798   return scm_public_ref (convert_module_name (module_name),
 799                          scm_from_locale_symbol (name));
 800 }
 801
 802 SCM
 803 scm_c_private_ref (const char *module_name, const char *name)
 804 {
 805   return scm_private_ref (convert_module_name (module_name),
 806                           scm_from_locale_symbol (name));
 807 }
 808
 809 SCM
 810 scm_c_module_define (SCM module, const char *name, SCM value)
 811 {
 812   return scm_module_define (module, scm_from_locale_symbol (name), value);
 813 }
 814
 815 SCM
 816 scm_module_define (SCM module, SCM sym, SCM value)
 817 #define FUNC_NAME "module-define"
 818 {
 819   SCM var;
 820
 821   var = scm_module_ensure_local_variable (module, sym);
 822   SCM_VARIABLE_SET (var, value);
 823
 824   return var;
 825 }
 826 #undef FUNC_NAME
 827
 828 SCM
 829 scm_c_define (const char *name, SCM value)
 830 {
 831   return scm_define (scm_from_locale_symbol (name), value);
 832 }
 833
 834 SCM_DEFINE (scm_define, "define!", 2, 0, 0,
 835             (SCM sym, SCM value),
 836             "Define @var{sym} to be @var{value} in the current module."
 837             "Returns the variable itself. Note that this is a procedure, "
 838             "not a macro.")
 839 #define FUNC_NAME s_scm_define
 840 {
 841   SCM_VALIDATE_SYMBOL (SCM_ARG1, sym);
 842
 843   return scm_module_define (scm_current_module (), sym, value);
 844 }
 845 #undef FUNC_NAME
 846
 847 SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
 848             (SCM module, SCM variable),
 849             "Return the symbol under which @var{variable} is bound in "
 850             "@var{module} or @var{#f} if @var{variable} is not visible "
 851             "from @var{module}.  If @var{module} is @code{#f}, then the "
 852             "pre-module obarray is used.")
 853 #define FUNC_NAME s_scm_module_reverse_lookup
 854 {
 855   SCM obarray;
 856   long i, n;
 857
 858   if (scm_is_false (module))
 859     obarray = scm_pre_modules_obarray;
 860   else
 861     {
 862       SCM_VALIDATE_MODULE (1, module);
 863       obarray = SCM_MODULE_OBARRAY (module);
 864     }
 865
 866   SCM_VALIDATE_VARIABLE (SCM_ARG2, variable);
 867
 868   if (!SCM_HASHTABLE_P (obarray))
 869       return SCM_BOOL_F;
 870
 871   /* XXX - We do not use scm_hash_fold here to avoid searching the
 872      whole obarray.  We should have a scm_hash_find procedure. */
 873
 874   n = SCM_HASHTABLE_N_BUCKETS (obarray);
 875   for (i = 0; i < n; ++i)
 876     {
 877       SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
 878       while (!scm_is_null (ls))
 879         {
 880           handle = SCM_CAR (ls);
 881
 882           if (SCM_UNPACK (SCM_CAR (handle)) == 0)
 883             {
 884               /* FIXME: We hit a weak pair whose car has become unreachable.
 885                  We should remove the pair in question or something.  */
 886             }
 887           else
 888             {
 889               if (scm_is_eq (SCM_CDR (handle), variable))
 890                 return SCM_CAR (handle);
 891             }
 892
 893           ls = SCM_CDR (ls);
 894         }
 895     }
 896
 897   if (!scm_is_false (module))
 898     {
 899       /* Try the `uses' list.  */
 900       SCM uses = SCM_MODULE_USES (module);
 901       while (scm_is_pair (uses))
 902         {
 903           SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
 904           if (scm_is_true (sym))
 905             return sym;
 906           uses = SCM_CDR (uses);
 907         }
 908     }
 909
 910   return SCM_BOOL_F;
 911 }
 912 #undef FUNC_NAME
 913
 914 SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
 915             (),
 916             "Return the obarray that is used for all new bindings before "
 917             "the module system is booted.  The first call to "
 918             "@code{set-current-module} will boot the module system.")
 919 #define FUNC_NAME s_scm_get_pre_modules_obarray
 920 {
 921   return scm_pre_modules_obarray;
 922 }
 923 #undef FUNC_NAME
 924
 925 SCM_SYMBOL (scm_sym_system_module, "system-module");
 926
 927 void
 928 scm_modules_prehistory ()
 929 {
 930   scm_pre_modules_obarray = scm_c_make_hash_table (1533);
 931 }
 932
 933 void
 934 scm_init_modules ()
 935 {
 936 #include "libguile/modules.x"
 937   module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
 938                                             SCM_UNDEFINED);
 939   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 940   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 941
 942   the_module = scm_make_fluid ();
 943 }
 944
 945 static void
 946 scm_post_boot_init_modules ()
 947 {
 948   SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
 949   scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
 950
 951   resolve_module_var = scm_c_lookup ("resolve-module");
 952   define_module_star_var = scm_c_lookup ("define-module*");
 953   process_use_modules_var = scm_c_lookup ("process-use-modules");
 954   module_export_x_var = scm_c_lookup ("module-export!");
 955   the_root_module_var = scm_c_lookup ("the-root-module");
 956   default_duplicate_binding_procedures_var =
 957     scm_c_lookup ("default-duplicate-binding-procedures");
 958   module_public_interface_var = scm_c_lookup ("module-public-interface");
 959   k_ensure = scm_from_locale_keyword ("ensure");
 960
 961   scm_module_system_booted_p = 1;
 962 }
 963
 964 /*
 965   Local Variables:
 966   c-file-style: "gnu"
 967   End:
 968 */