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., 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           SCM sym = scm_from_locale_symboln (name, ptr-name);
 115           *tail = scm_cons (sym, SCM_EOL);
 116           tail = SCM_CDRLOC (*tail);
 117         }
 118       name = ptr;
 119     }
 120
 121   return list;
 122 }
 123
 124 static SCM process_define_module_var;
 125 static SCM process_use_modules_var;
 126 static SCM resolve_module_var;
 127
 128 SCM
 129 scm_c_resolve_module (const char *name)
 130 {
 131   return scm_resolve_module (convert_module_name (name));
 132 }
 133
 134 SCM
 135 scm_resolve_module (SCM name)
 136 {
 137   return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
 138 }
 139
 140 SCM
 141 scm_c_define_module (const char *name,
 142                      void (*init)(void *), void *data)
 143 {
 144   SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
 145                            scm_list_1 (convert_module_name (name)));
 146   if (init)
 147     scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
 148   return module;
 149 }
 150
 151 void
 152 scm_c_use_module (const char *name)
 153 {
 154   scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
 155               scm_list_1 (scm_list_1 (convert_module_name (name))));
 156 }
 157
 158 static SCM module_export_x_var;
 159
 160
 161 /*
 162   TODO: should export this function? --hwn.
 163  */
 164 static SCM
 165 scm_export (SCM module, SCM namelist)
 166 {
 167   return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
 168                      module, namelist);
 169 }
 170
 171
 172 /*
 173   @code{scm_c_export}(@var{name-list})
 174
 175   @code{scm_c_export} exports the named bindings from the current
 176   module, making them visible to users of the module. This function
 177   takes a list of string arguments, terminated by NULL, e.g.
 178
 179   @example
 180     scm_c_export ("add-double-record", "bamboozle-money", NULL);
 181   @end example
 182 */
 183 void
 184 scm_c_export (const char *name, ...)
 185 {
 186   if (name)
 187     {
 188       va_list ap;
 189       SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
 190       SCM *tail = SCM_CDRLOC (names);
 191       va_start (ap, name);
 192       while (1)
 193         {
 194           const char *n = va_arg (ap, const char *);
 195           if (n == NULL)
 196             break;
 197           *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
 198           tail = SCM_CDRLOC (*tail);
 199         }
 200       va_end (ap);
 201       scm_export (scm_current_module(), names);
 202     }
 203 }
 204
 205
 206 /* Environments */
 207
 208 SCM
 209 scm_top_level_env (SCM thunk)
 210 {
 211   if (SCM_IMP (thunk))
 212     return SCM_EOL;
 213   else
 214     return scm_cons (thunk, SCM_EOL);
 215 }
 216
 217 SCM
 218 scm_env_top_level (SCM env)
 219 {
 220   while (SCM_CONSP (env))
 221     {
 222       SCM car_env = SCM_CAR (env);
 223       if (!SCM_CONSP (car_env) && scm_is_true (scm_procedure_p (car_env)))
 224         return car_env;
 225       env = SCM_CDR (env);
 226     }
 227   return SCM_BOOL_F;
 228 }
 229
 230 SCM_SYMBOL (sym_module, "module");
 231
 232 static SCM the_root_module_var;
 233
 234 static SCM
 235 the_root_module ()
 236 {
 237   if (scm_module_system_booted_p)
 238     return SCM_VARIABLE_REF (the_root_module_var);
 239   else
 240     return SCM_BOOL_F;
 241 }
 242
 243 SCM
 244 scm_lookup_closure_module (SCM proc)
 245 {
 246   if (scm_is_false (proc))
 247     return the_root_module ();
 248   else if (SCM_EVAL_CLOSURE_P (proc))
 249     return SCM_PACK (SCM_SMOB_DATA (proc));
 250   else
 251     {
 252       SCM mod = scm_procedure_property (proc, sym_module);
 253       if (scm_is_false (mod))
 254         mod = the_root_module ();
 255       return mod;
 256     }
 257 }
 258
 259 SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
 260             (SCM env),
 261             "Return the module of @var{ENV}, a lexical environment.")
 262 #define FUNC_NAME s_scm_env_module
 263 {
 264   return scm_lookup_closure_module (scm_env_top_level (env));
 265 }
 266 #undef FUNC_NAME
 267
 268 /*
 269  * C level implementation of the standard eval closure
 270  *
 271  * This increases loading speed substantially.
 272  * The code will be replaced by the low-level environments in next release.
 273  */
 274
 275 static SCM module_make_local_var_x_var;
 276
 277 static SCM
 278 module_variable (SCM module, SCM sym)
 279 {
 280 #define SCM_BOUND_THING_P(b) \
 281   (scm_is_true (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_is_true (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_is_true (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_is_false (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_is_false (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_is_true (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_is_true (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_is_true (_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_is_false (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_is_false (var))
 472             {
 473               var = scm_make_variable (SCM_UNDEFINED);
 474               SCM_SETCDR (handle, var);
 475             }
 476         }
 477     }
 478
 479   if (scm_is_true (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_from_locale_symbol (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_is_false (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_from_locale_symbol (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_is_false (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_from_locale_symbol (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_from_locale_symbol (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_is_false (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   if (!SCM_HASHTABLE_P (obarray))
 572       return SCM_BOOL_F;
 573
 574   /* XXX - We do not use scm_hash_fold here to avoid searching the
 575      whole obarray.  We should have a scm_hash_find procedure. */
 576
 577   n = SCM_HASHTABLE_N_BUCKETS (obarray);
 578   for (i = 0; i < n; ++i)
 579     {
 580       SCM ls = SCM_HASHTABLE_BUCKETS (obarray)[i], handle;
 581       while (!SCM_NULLP (ls))
 582         {
 583           handle = SCM_CAR (ls);
 584           if (SCM_CDR (handle) == variable)
 585             return SCM_CAR (handle);
 586           ls = SCM_CDR (ls);
 587         }
 588     }
 589
 590   /* Try the `uses' list.
 591    */
 592   {
 593     SCM uses = SCM_MODULE_USES (module);
 594     while (SCM_CONSP (uses))
 595       {
 596         SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
 597         if (scm_is_true (sym))
 598           return sym;
 599         uses = SCM_CDR (uses);
 600       }
 601   }
 602
 603   return SCM_BOOL_F;
 604 }
 605 #undef FUNC_NAME
 606
 607 SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
 608             (),
 609             "Return the obarray that is used for all new bindings before "
 610             "the module system is booted.  The first call to "
 611             "@code{set-current-module} will boot the module system.")
 612 #define FUNC_NAME s_scm_get_pre_modules_obarray
 613 {
 614   return scm_pre_modules_obarray;
 615 }
 616 #undef FUNC_NAME
 617
 618 SCM_SYMBOL (scm_sym_system_module, "system-module");
 619
 620 SCM
 621 scm_system_module_env_p (SCM env)
 622 {
 623   SCM proc = scm_env_top_level (env);
 624   if (scm_is_false (proc))
 625     return SCM_BOOL_T;
 626   return ((scm_is_true (scm_procedure_property (proc,
 627                                                 scm_sym_system_module)))
 628           ? SCM_BOOL_T
 629           : SCM_BOOL_F);
 630 }
 631
 632 void
 633 scm_modules_prehistory ()
 634 {
 635   scm_pre_modules_obarray
 636     = scm_permanent_object (scm_c_make_hash_table (1533));
 637 }
 638
 639 void
 640 scm_init_modules ()
 641 {
 642 #include "libguile/modules.x"
 643   module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
 644                                             SCM_UNDEFINED);
 645   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 646   scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
 647   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 648
 649   the_module = scm_permanent_object (scm_make_fluid ());
 650 }
 651
 652 static void
 653 scm_post_boot_init_modules ()
 654 {
 655 #define PERM(x) scm_permanent_object(x)
 656
 657   SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
 658   scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
 659
 660   resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
 661   process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
 662   process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
 663   module_export_x_var = PERM (scm_c_lookup ("module-export!"));
 664   the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
 665
 666   scm_module_system_booted_p = 1;
 667 }
 668
 669 /*
 670   Local Variables:
 671   c-file-style: "gnu"
 672   End:
 673 */