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_FALSEP (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_FALSEP (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_FALSEP (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_FALSEP(b) && \
 281    (!SCM_VARIABLEP(b) || !SCM_UNBNDP (SCM_VARIABLE_REF (b))))
 282
 283   /* 1. Check module obarray */
 284   SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 285   if (SCM_BOUND_THING_P (b))
 286     return b;
 287   {
 288     SCM binder = SCM_MODULE_BINDER (module);
 289     if (!SCM_FALSEP (binder))
 290       /* 2. Custom binder */
 291       {
 292         b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
 293         if (SCM_BOUND_THING_P (b))
 294           return b;
 295       }
 296   }
 297   {
 298     /* 3. Search the use list */
 299     SCM uses = SCM_MODULE_USES (module);
 300     while (SCM_CONSP (uses))
 301       {
 302         b = module_variable (SCM_CAR (uses), sym);
 303         if (SCM_BOUND_THING_P (b))
 304           return b;
 305         uses = SCM_CDR (uses);
 306       }
 307     return SCM_BOOL_F;
 308   }
 309 #undef SCM_BOUND_THING_P
 310 }
 311
 312 scm_t_bits scm_tc16_eval_closure;
 313
 314 #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
 315 #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
 316   (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
 317
 318 /* NOTE: This function may be called by a smob application
 319    or from another C function directly. */
 320 SCM
 321 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
 322 {
 323   SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
 324   if (!SCM_FALSEP (definep))
 325     {
 326       if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
 327         return SCM_BOOL_F;
 328       return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
 329                          module, sym);
 330     }
 331   else
 332     return module_variable (module, sym);
 333 }
 334
 335 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
 336             (SCM module),
 337             "Return an eval closure for the module @var{module}.")
 338 #define FUNC_NAME s_scm_standard_eval_closure
 339 {
 340   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
 341 }
 342 #undef FUNC_NAME
 343
 344 SCM_DEFINE (scm_standard_interface_eval_closure,
 345             "standard-interface-eval-closure", 1, 0, 0,
 346             (SCM module),
 347             "Return a interface eval closure for the module @var{module}. "
 348             "Such a closure does not allow new bindings to be added.")
 349 #define FUNC_NAME s_scm_standard_interface_eval_closure
 350 {
 351   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
 352                       SCM_UNPACK (module));
 353 }
 354 #undef FUNC_NAME
 355
 356 SCM
 357 scm_module_lookup_closure (SCM module)
 358 {
 359   if (SCM_FALSEP (module))
 360     return SCM_BOOL_F;
 361   else
 362     return SCM_MODULE_EVAL_CLOSURE (module);
 363 }
 364
 365 SCM
 366 scm_current_module_lookup_closure ()
 367 {
 368   if (scm_module_system_booted_p)
 369     return scm_module_lookup_closure (scm_current_module ());
 370   else
 371     return SCM_BOOL_F;
 372 }
 373
 374 SCM
 375 scm_module_transformer (SCM module)
 376 {
 377   if (SCM_FALSEP (module))
 378     return SCM_BOOL_F;
 379   else
 380     return SCM_MODULE_TRANSFORMER (module);
 381 }
 382
 383 SCM
 384 scm_current_module_transformer ()
 385 {
 386   if (scm_module_system_booted_p)
 387     return scm_module_transformer (scm_current_module ());
 388   else
 389     return SCM_BOOL_F;
 390 }
 391
 392 SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
 393             (SCM module, SCM sym),
 394             "")
 395 #define FUNC_NAME s_scm_module_import_interface
 396 {
 397 #define SCM_BOUND_THING_P(b) (!SCM_FALSEP (b))
 398   SCM uses;
 399   SCM_VALIDATE_MODULE (SCM_ARG1, module);
 400   /* Search the use list */
 401   uses = SCM_MODULE_USES (module);
 402   while (SCM_CONSP (uses))
 403     {
 404       SCM _interface = SCM_CAR (uses);
 405       /* 1. Check module obarray */
 406       SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
 407       if (SCM_BOUND_THING_P (b))
 408         return _interface;
 409       {
 410         SCM binder = SCM_MODULE_BINDER (_interface);
 411         if (!SCM_FALSEP (binder))
 412           /* 2. Custom binder */
 413           {
 414             b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
 415             if (SCM_BOUND_THING_P (b))
 416               return _interface;
 417           }
 418       }
 419       /* 3. Search use list recursively. */
 420       _interface = scm_module_import_interface (_interface, sym);
 421       if (!SCM_FALSEP (_interface))
 422         return _interface;
 423       uses = SCM_CDR (uses);
 424     }
 425   return SCM_BOOL_F;
 426 }
 427 #undef FUNC_NAME
 428
 429 /* scm_sym2var
 430  *
 431  * looks up the variable bound to SYM according to PROC.  PROC should be
 432  * a `eval closure' of some module.
 433  *
 434  * When no binding exists, and DEFINEP is true, create a new binding
 435  * with a initial value of SCM_UNDEFINED.  Return `#f' when DEFINEP as
 436  * false and no binding exists.
 437  *
 438  * When PROC is `#f', it is ignored and the binding is searched for in
 439  * the scm_pre_modules_obarray (a `eq' hash table).
 440  */
 441
 442 SCM scm_pre_modules_obarray;
 443
 444 SCM
 445 scm_sym2var (SCM sym, SCM proc, SCM definep)
 446 #define FUNC_NAME "scm_sym2var"
 447 {
 448   SCM var;
 449
 450   if (SCM_NIMP (proc))
 451     {
 452       if (SCM_EVAL_CLOSURE_P (proc))
 453         {
 454           /* Bypass evaluator in the standard case. */
 455           var = scm_eval_closure_lookup (proc, sym, definep);
 456         }
 457       else
 458         var = scm_call_2 (proc, sym, definep);
 459     }
 460   else
 461     {
 462       SCM handle;
 463
 464       if (SCM_FALSEP (definep))
 465         var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
 466       else
 467         {
 468           handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
 469                                               sym, SCM_BOOL_F);
 470           var = SCM_CDR (handle);
 471           if (SCM_FALSEP (var))
 472             {
 473               var = scm_make_variable (SCM_UNDEFINED);
 474               SCM_SETCDR (handle, var);
 475             }
 476         }
 477     }
 478
 479   if (!SCM_FALSEP (var) && !SCM_VARIABLEP (var))
 480     SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
 481
 482   return var;
 483 }
 484 #undef FUNC_NAME
 485
 486 SCM
 487 scm_c_module_lookup (SCM module, const char *name)
 488 {
 489   return scm_module_lookup (module, scm_str2symbol (name));
 490 }
 491
 492 SCM
 493 scm_module_lookup (SCM module, SCM sym)
 494 #define FUNC_NAME "module-lookup"
 495 {
 496   SCM var;
 497   SCM_VALIDATE_MODULE (1, module);
 498
 499   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
 500   if (SCM_FALSEP (var))
 501     SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
 502   return var;
 503 }
 504 #undef FUNC_NAME
 505
 506 SCM
 507 scm_c_lookup (const char *name)
 508 {
 509   return scm_lookup (scm_str2symbol (name));
 510 }
 511
 512 SCM
 513 scm_lookup (SCM sym)
 514 {
 515   SCM var =
 516     scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
 517   if (SCM_FALSEP (var))
 518     scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
 519   return var;
 520 }
 521
 522 SCM
 523 scm_c_module_define (SCM module, const char *name, SCM value)
 524 {
 525   return scm_module_define (module, scm_str2symbol (name), value);
 526 }
 527
 528 SCM
 529 scm_module_define (SCM module, SCM sym, SCM value)
 530 #define FUNC_NAME "module-define"
 531 {
 532   SCM var;
 533   SCM_VALIDATE_MODULE (1, module);
 534
 535   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
 536   SCM_VARIABLE_SET (var, value);
 537   return var;
 538 }
 539 #undef FUNC_NAME
 540
 541 SCM
 542 scm_c_define (const char *name, SCM value)
 543 {
 544   return scm_define (scm_str2symbol (name), value);
 545 }
 546
 547 SCM
 548 scm_define (SCM sym, SCM value)
 549 {
 550   SCM var =
 551     scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
 552   SCM_VARIABLE_SET (var, value);
 553   return var;
 554 }
 555
 556 SCM
 557 scm_module_reverse_lookup (SCM module, SCM variable)
 558 #define FUNC_NAME "module-reverse-lookup"
 559 {
 560   SCM obarray;
 561   long i, n;
 562
 563   if (SCM_FALSEP (module))
 564     obarray = scm_pre_modules_obarray;
 565   else
 566     {
 567       SCM_VALIDATE_MODULE (1, module);
 568       obarray = SCM_MODULE_OBARRAY (module);
 569     }
 570
 571   /* XXX - We do not use scm_hash_fold here to avoid searching the
 572      whole obarray.  We should have a scm_hash_find procedure. */
 573
 574   n = SCM_HASHTABLE_N_BUCKETS (obarray);
 575   for (i = 0; i < n; ++i)
 576     {
 577       SCM ls = SCM_HASHTABLE_BUCKETS (obarray)[i], handle;
 578       while (!SCM_NULLP (ls))
 579         {
 580           handle = SCM_CAR (ls);
 581           if (SCM_CDR (handle) == variable)
 582             return SCM_CAR (handle);
 583           ls = SCM_CDR (ls);
 584         }
 585     }
 586
 587   /* Try the `uses' list.
 588    */
 589   {
 590     SCM uses = SCM_MODULE_USES (module);
 591     while (SCM_CONSP (uses))
 592       {
 593         SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
 594         if (!SCM_FALSEP (sym))
 595           return sym;
 596         uses = SCM_CDR (uses);
 597       }
 598   }
 599
 600   return SCM_BOOL_F;
 601 }
 602 #undef FUNC_NAME
 603
 604 SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
 605             (),
 606             "Return the obarray that is used for all new bindings before "
 607             "the module system is booted.  The first call to "
 608             "@code{set-current-module} will boot the module system.")
 609 #define FUNC_NAME s_scm_get_pre_modules_obarray
 610 {
 611   return scm_pre_modules_obarray;
 612 }
 613 #undef FUNC_NAME
 614
 615 SCM_SYMBOL (scm_sym_system_module, "system-module");
 616
 617 SCM
 618 scm_system_module_env_p (SCM env)
 619 {
 620   SCM proc = scm_env_top_level (env);
 621   if (SCM_FALSEP (proc))
 622     return SCM_BOOL_T;
 623   return ((!SCM_FALSEP (scm_procedure_property (proc,
 624                                                 scm_sym_system_module)))
 625           ? SCM_BOOL_T
 626           : SCM_BOOL_F);
 627 }
 628
 629 void
 630 scm_modules_prehistory ()
 631 {
 632   scm_pre_modules_obarray
 633     = scm_permanent_object (scm_c_make_hash_table (1533));
 634 }
 635
 636 void
 637 scm_init_modules ()
 638 {
 639 #include "libguile/modules.x"
 640   module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
 641                                             SCM_UNDEFINED);
 642   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 643   scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
 644   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 645
 646   the_module = scm_permanent_object (scm_make_fluid ());
 647 }
 648
 649 static void
 650 scm_post_boot_init_modules ()
 651 {
 652 #define PERM(x) scm_permanent_object(x)
 653
 654   SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
 655   scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
 656
 657   resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
 658   process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
 659   process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
 660   module_export_x_var = PERM (scm_c_lookup ("module-export!"));
 661   the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
 662
 663   scm_module_system_booted_p = 1;
 664 }
 665
 666 /*
 667   Local Variables:
 668   c-file-style: "gnu"
 669   End:
 670 */