libguile/modules.c

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