libguile/modules.c

   1 /* Copyright (C) 1998,2000,2001,2002, 2003, 2004 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
 166 /*
 167   TODO: should export this function? --hwn.
 168  */
 169 static SCM
 170 scm_export (SCM module, SCM namelist)
 171 {
 172   return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
 173                      module, namelist);
 174 }
 175
 176
 177 /*
 178   @code{scm_c_export}(@var{name-list})
 179
 180   @code{scm_c_export} exports the named bindings from the current
 181   module, making them visible to users of the module. This function
 182   takes a list of string arguments, terminated by NULL, e.g.
 183
 184   @example
 185     scm_c_export ("add-double-record", "bamboozle-money", NULL);
 186   @end example
 187 */
 188 void
 189 scm_c_export (const char *name, ...)
 190 {
 191   if (name)
 192     {
 193       va_list ap;
 194       SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
 195       SCM *tail = SCM_CDRLOC (names);
 196       va_start (ap, name);
 197       while (1)
 198         {
 199           const char *n = va_arg (ap, const char *);
 200           if (n == NULL)
 201             break;
 202           *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
 203           tail = SCM_CDRLOC (*tail);
 204         }
 205       va_end (ap);
 206       scm_export (scm_current_module(), names);
 207     }
 208 }
 209
 210
 211 /* Environments */
 212
 213 SCM
 214 scm_top_level_env (SCM thunk)
 215 {
 216   if (SCM_IMP (thunk))
 217     return SCM_EOL;
 218   else
 219     return scm_cons (thunk, SCM_EOL);
 220 }
 221
 222 SCM
 223 scm_env_top_level (SCM env)
 224 {
 225   while (scm_is_pair (env))
 226     {
 227       SCM car_env = SCM_CAR (env);
 228       if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
 229         return car_env;
 230       env = SCM_CDR (env);
 231     }
 232   return SCM_BOOL_F;
 233 }
 234
 235 SCM_SYMBOL (sym_module, "module");
 236
 237 static SCM the_root_module_var;
 238
 239 static SCM
 240 the_root_module ()
 241 {
 242   if (scm_module_system_booted_p)
 243     return SCM_VARIABLE_REF (the_root_module_var);
 244   else
 245     return SCM_BOOL_F;
 246 }
 247
 248 SCM
 249 scm_lookup_closure_module (SCM proc)
 250 {
 251   if (scm_is_false (proc))
 252     return the_root_module ();
 253   else if (SCM_EVAL_CLOSURE_P (proc))
 254     return SCM_PACK (SCM_SMOB_DATA (proc));
 255   else
 256     {
 257       SCM mod = scm_procedure_property (proc, sym_module);
 258       if (scm_is_false (mod))
 259         mod = the_root_module ();
 260       return mod;
 261     }
 262 }
 263
 264 SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
 265             (SCM env),
 266             "Return the module of @var{ENV}, a lexical environment.")
 267 #define FUNC_NAME s_scm_env_module
 268 {
 269   return scm_lookup_closure_module (scm_env_top_level (env));
 270 }
 271 #undef FUNC_NAME
 272
 273 /*
 274  * C level implementation of the standard eval closure
 275  *
 276  * This increases loading speed substantially.
 277  * The code will be replaced by the low-level environments in next release.
 278  */
 279
 280 static SCM module_make_local_var_x_var;
 281
 282 static SCM
 283 module_variable (SCM module, SCM sym)
 284 {
 285 #define SCM_BOUND_THING_P(b) \
 286   (scm_is_true (b))
 287
 288   /* 1. Check module obarray */
 289   SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 290   if (SCM_BOUND_THING_P (b))
 291     return b;
 292   {
 293     SCM binder = SCM_MODULE_BINDER (module);
 294     if (scm_is_true (binder))
 295       /* 2. Custom binder */
 296       {
 297         b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
 298         if (SCM_BOUND_THING_P (b))
 299           return b;
 300       }
 301   }
 302   {
 303     /* 3. Search the use list */
 304     SCM uses = SCM_MODULE_USES (module);
 305     while (scm_is_pair (uses))
 306       {
 307         b = module_variable (SCM_CAR (uses), sym);
 308         if (SCM_BOUND_THING_P (b))
 309           return b;
 310         uses = SCM_CDR (uses);
 311       }
 312     return SCM_BOOL_F;
 313   }
 314 #undef SCM_BOUND_THING_P
 315 }
 316
 317 scm_t_bits scm_tc16_eval_closure;
 318
 319 #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
 320 #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
 321   (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
 322
 323 /* NOTE: This function may be called by a smob application
 324    or from another C function directly. */
 325 SCM
 326 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
 327 {
 328   SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
 329   if (scm_is_true (definep))
 330     {
 331       if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
 332         return SCM_BOOL_F;
 333       return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
 334                          module, sym);
 335     }
 336   else
 337     return module_variable (module, sym);
 338 }
 339
 340 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
 341             (SCM module),
 342             "Return an eval closure for the module @var{module}.")
 343 #define FUNC_NAME s_scm_standard_eval_closure
 344 {
 345   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
 346 }
 347 #undef FUNC_NAME
 348
 349
 350 SCM_DEFINE (scm_standard_interface_eval_closure,
 351             "standard-interface-eval-closure", 1, 0, 0,
 352             (SCM module),
 353             "Return a interface eval closure for the module @var{module}. "
 354             "Such a closure does not allow new bindings to be added.")
 355 #define FUNC_NAME s_scm_standard_interface_eval_closure
 356 {
 357   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
 358                       SCM_UNPACK (module));
 359 }
 360 #undef FUNC_NAME
 361
 362 SCM
 363 scm_module_lookup_closure (SCM module)
 364 {
 365   if (scm_is_false (module))
 366     return SCM_BOOL_F;
 367   else
 368     return SCM_MODULE_EVAL_CLOSURE (module);
 369 }
 370
 371 SCM
 372 scm_current_module_lookup_closure ()
 373 {
 374   if (scm_module_system_booted_p)
 375     return scm_module_lookup_closure (scm_current_module ());
 376   else
 377     return SCM_BOOL_F;
 378 }
 379
 380 SCM
 381 scm_module_transformer (SCM module)
 382 {
 383   if (scm_is_false (module))
 384     return SCM_BOOL_F;
 385   else
 386     return SCM_MODULE_TRANSFORMER (module);
 387 }
 388
 389 SCM
 390 scm_current_module_transformer ()
 391 {
 392   if (scm_module_system_booted_p)
 393     return scm_module_transformer (scm_current_module ());
 394   else
 395     return SCM_BOOL_F;
 396 }
 397
 398 SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
 399             (SCM module, SCM sym),
 400             "")
 401 #define FUNC_NAME s_scm_module_import_interface
 402 {
 403 #define SCM_BOUND_THING_P(b) (scm_is_true (b))
 404   SCM uses;
 405   SCM_VALIDATE_MODULE (SCM_ARG1, module);
 406   /* Search the use list */
 407   uses = SCM_MODULE_USES (module);
 408   while (scm_is_pair (uses))
 409     {
 410       SCM _interface = SCM_CAR (uses);
 411       /* 1. Check module obarray */
 412       SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
 413       if (SCM_BOUND_THING_P (b))
 414         return _interface;
 415       {
 416         SCM binder = SCM_MODULE_BINDER (_interface);
 417         if (scm_is_true (binder))
 418           /* 2. Custom binder */
 419           {
 420             b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
 421             if (SCM_BOUND_THING_P (b))
 422               return _interface;
 423           }
 424       }
 425       /* 3. Search use list recursively. */
 426       _interface = scm_module_import_interface (_interface, sym);
 427       if (scm_is_true (_interface))
 428         return _interface;
 429       uses = SCM_CDR (uses);
 430     }
 431   return SCM_BOOL_F;
 432 }
 433 #undef FUNC_NAME
 434
 435 /* scm_sym2var
 436  *
 437  * looks up the variable bound to SYM according to PROC.  PROC should be
 438  * a `eval closure' of some module.
 439  *
 440  * When no binding exists, and DEFINEP is true, create a new binding
 441  * with a initial value of SCM_UNDEFINED.  Return `#f' when DEFINEP as
 442  * false and no binding exists.
 443  *
 444  * When PROC is `#f', it is ignored and the binding is searched for in
 445  * the scm_pre_modules_obarray (a `eq' hash table).
 446  */
 447
 448 SCM scm_pre_modules_obarray;
 449
 450 SCM
 451 scm_sym2var (SCM sym, SCM proc, SCM definep)
 452 #define FUNC_NAME "scm_sym2var"
 453 {
 454   SCM var;
 455
 456   if (SCM_NIMP (proc))
 457     {
 458       if (SCM_EVAL_CLOSURE_P (proc))
 459         {
 460           /* Bypass evaluator in the standard case. */
 461           var = scm_eval_closure_lookup (proc, sym, definep);
 462         }
 463       else
 464         var = scm_call_2 (proc, sym, definep);
 465     }
 466   else
 467     {
 468       SCM handle;
 469
 470       if (scm_is_false (definep))
 471         var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
 472       else
 473         {
 474           handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
 475                                               sym, SCM_BOOL_F);
 476           var = SCM_CDR (handle);
 477           if (scm_is_false (var))
 478             {
 479               var = scm_make_variable (SCM_UNDEFINED);
 480               SCM_SETCDR (handle, var);
 481             }
 482         }
 483     }
 484
 485   if (scm_is_true (var) && !SCM_VARIABLEP (var))
 486     SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
 487
 488   return var;
 489 }
 490 #undef FUNC_NAME
 491
 492 SCM
 493 scm_c_module_lookup (SCM module, const char *name)
 494 {
 495   return scm_module_lookup (module, scm_from_locale_symbol (name));
 496 }
 497
 498 SCM
 499 scm_module_lookup (SCM module, SCM sym)
 500 #define FUNC_NAME "module-lookup"
 501 {
 502   SCM var;
 503   SCM_VALIDATE_MODULE (1, module);
 504
 505   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
 506   if (scm_is_false (var))
 507     SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
 508   return var;
 509 }
 510 #undef FUNC_NAME
 511
 512 SCM
 513 scm_c_lookup (const char *name)
 514 {
 515   return scm_lookup (scm_from_locale_symbol (name));
 516 }
 517
 518 SCM
 519 scm_lookup (SCM sym)
 520 {
 521   SCM var =
 522     scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
 523   if (scm_is_false (var))
 524     scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
 525   return var;
 526 }
 527
 528 SCM
 529 scm_c_module_define (SCM module, const char *name, SCM value)
 530 {
 531   return scm_module_define (module, scm_from_locale_symbol (name), value);
 532 }
 533
 534 SCM
 535 scm_module_define (SCM module, SCM sym, SCM value)
 536 #define FUNC_NAME "module-define"
 537 {
 538   SCM var;
 539   SCM_VALIDATE_MODULE (1, module);
 540
 541   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
 542   SCM_VARIABLE_SET (var, value);
 543   return var;
 544 }
 545 #undef FUNC_NAME
 546
 547 SCM
 548 scm_c_define (const char *name, SCM value)
 549 {
 550   return scm_define (scm_from_locale_symbol (name), value);
 551 }
 552
 553 SCM
 554 scm_define (SCM sym, SCM value)
 555 {
 556   SCM var =
 557     scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
 558   SCM_VARIABLE_SET (var, value);
 559   return var;
 560 }
 561
 562 SCM
 563 scm_module_reverse_lookup (SCM module, SCM variable)
 564 #define FUNC_NAME "module-reverse-lookup"
 565 {
 566   SCM obarray;
 567   long i, n;
 568
 569   if (scm_is_false (module))
 570     obarray = scm_pre_modules_obarray;
 571   else
 572     {
 573       SCM_VALIDATE_MODULE (1, module);
 574       obarray = SCM_MODULE_OBARRAY (module);
 575     }
 576
 577   if (!SCM_HASHTABLE_P (obarray))
 578       return SCM_BOOL_F;
 579
 580   /* XXX - We do not use scm_hash_fold here to avoid searching the
 581      whole obarray.  We should have a scm_hash_find procedure. */
 582
 583   n = SCM_HASHTABLE_N_BUCKETS (obarray);
 584   for (i = 0; i < n; ++i)
 585     {
 586       SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
 587       while (!scm_is_null (ls))
 588         {
 589           handle = SCM_CAR (ls);
 590           if (SCM_CDR (handle) == variable)
 591             return SCM_CAR (handle);
 592           ls = SCM_CDR (ls);
 593         }
 594     }
 595
 596   /* Try the `uses' list.
 597    */
 598   {
 599     SCM uses = SCM_MODULE_USES (module);
 600     while (scm_is_pair (uses))
 601       {
 602         SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
 603         if (scm_is_true (sym))
 604           return sym;
 605         uses = SCM_CDR (uses);
 606       }
 607   }
 608
 609   return SCM_BOOL_F;
 610 }
 611 #undef FUNC_NAME
 612
 613 SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
 614             (),
 615             "Return the obarray that is used for all new bindings before "
 616             "the module system is booted.  The first call to "
 617             "@code{set-current-module} will boot the module system.")
 618 #define FUNC_NAME s_scm_get_pre_modules_obarray
 619 {
 620   return scm_pre_modules_obarray;
 621 }
 622 #undef FUNC_NAME
 623
 624 SCM_SYMBOL (scm_sym_system_module, "system-module");
 625
 626 SCM
 627 scm_system_module_env_p (SCM env)
 628 {
 629   SCM proc = scm_env_top_level (env);
 630   if (scm_is_false (proc))
 631     return SCM_BOOL_T;
 632   return ((scm_is_true (scm_procedure_property (proc,
 633                                                 scm_sym_system_module)))
 634           ? SCM_BOOL_T
 635           : SCM_BOOL_F);
 636 }
 637
 638 void
 639 scm_modules_prehistory ()
 640 {
 641   scm_pre_modules_obarray
 642     = scm_permanent_object (scm_c_make_hash_table (1533));
 643 }
 644
 645 void
 646 scm_init_modules ()
 647 {
 648 #include "libguile/modules.x"
 649   module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
 650                                             SCM_UNDEFINED);
 651   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 652   scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
 653   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 654
 655   the_module = scm_permanent_object (scm_make_fluid ());
 656 }
 657
 658 static void
 659 scm_post_boot_init_modules ()
 660 {
 661 #define PERM(x) scm_permanent_object(x)
 662
 663   SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
 664   scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
 665
 666   resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
 667   process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
 668   process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
 669   module_export_x_var = PERM (scm_c_lookup ("module-export!"));
 670   the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
 671
 672   scm_module_system_booted_p = 1;
 673 }
 674
 675 /*
 676   Local Variables:
 677   c-file-style: "gnu"
 678   End:
 679 */