libguile/modules.c

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