libguile/modules.c

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