guile18/libguile/modules.c

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