libguile/modules.c

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