libguile/modules.c

   1 /* Copyright (C) 1998,2000,2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 \f
  44
  45 #include <stdarg.h>
  46
  47 #include "libguile/_scm.h"
  48
  49 #include "libguile/eval.h"
  50 #include "libguile/smob.h"
  51 #include "libguile/procprop.h"
  52 #include "libguile/vectors.h"
  53 #include "libguile/hashtab.h"
  54 #include "libguile/struct.h"
  55 #include "libguile/variable.h"
  56 #include "libguile/fluids.h"
  57 #include "libguile/deprecation.h"
  58
  59 #include "libguile/modules.h"
  60
  61 int scm_module_system_booted_p = 0;
  62
  63 scm_t_bits scm_module_tag;
  64
  65 static SCM the_module;
  66
  67 SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
  68             (),
  69             "Return the current module.")
  70 #define FUNC_NAME s_scm_current_module
  71 {
  72   return scm_fluid_ref (the_module);
  73 }
  74 #undef FUNC_NAME
  75
  76 static void scm_post_boot_init_modules (void);
  77
  78 SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
  79             (SCM module),
  80             "Set the current module to @var{module} and return\n"
  81             "the previous current module.")
  82 #define FUNC_NAME s_scm_set_current_module
  83 {
  84   SCM old;
  85
  86   if (!scm_module_system_booted_p)
  87     scm_post_boot_init_modules ();
  88
  89   SCM_VALIDATE_MODULE (SCM_ARG1, module);
  90
  91   old = scm_current_module ();
  92   scm_fluid_set_x (the_module, module);
  93
  94   return old;
  95 }
  96 #undef FUNC_NAME
  97
  98 SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
  99             (),
 100             "Return a specifier for the environment that contains\n"
 101             "implementation--defined bindings, typically a superset of those\n"
 102             "listed in the report.  The intent is that this procedure will\n"
 103             "return the environment in which the implementation would\n"
 104             "evaluate expressions dynamically typed by the user.")
 105 #define FUNC_NAME s_scm_interaction_environment
 106 {
 107   return scm_current_module ();
 108 }
 109 #undef FUNC_NAME
 110
 111 SCM
 112 scm_c_call_with_current_module (SCM module,
 113                                 SCM (*func)(void *), void *data)
 114 {
 115   return scm_c_with_fluid (the_module, module, func, data);
 116 }
 117
 118 static SCM
 119 convert_module_name (const char *name)
 120 {
 121   SCM list = SCM_EOL;
 122   SCM *tail = &list;
 123
 124   const char *ptr;
 125   while (*name)
 126     {
 127       while (*name == ' ')
 128         name++;
 129       ptr = name;
 130       while (*ptr && *ptr != ' ')
 131         ptr++;
 132       if (ptr > name)
 133         {
 134           *tail = scm_cons (scm_mem2symbol (name, ptr-name), SCM_EOL);
 135           tail = SCM_CDRLOC (*tail);
 136         }
 137       name = ptr;
 138     }
 139
 140   return list;
 141 }
 142
 143 static SCM process_define_module_var;
 144 static SCM process_use_modules_var;
 145 static SCM resolve_module_var;
 146
 147 SCM
 148 scm_c_resolve_module (const char *name)
 149 {
 150   return scm_resolve_module (convert_module_name (name));
 151 }
 152
 153 SCM
 154 scm_resolve_module (SCM name)
 155 {
 156   return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
 157 }
 158
 159 SCM
 160 scm_c_define_module (const char *name,
 161                      void (*init)(void *), void *data)
 162 {
 163   SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
 164                            scm_list_1 (convert_module_name (name)));
 165   if (init)
 166     scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
 167   return module;
 168 }
 169
 170 void
 171 scm_c_use_module (const char *name)
 172 {
 173   scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
 174               scm_list_1 (scm_list_1 (convert_module_name (name))));
 175 }
 176
 177 static SCM module_export_x_var;
 178
 179
 180
 181 /*
 182   @code{scm_c_export}(@var{name-list})
 183
 184   @code{scm_c_export} exports the named bindings from the current
 185   module, making them visible to users of the module. This function
 186   takes a list of string arguments, terminated by NULL, e.g.
 187
 188   @example
 189     scm_c_export ("add-double-record", "bamboozle-money", NULL);
 190   @end example
 191 */
 192
 193 void
 194 scm_c_export (const char *name, ...)
 195 {
 196   if (name)
 197     {
 198       va_list ap;
 199       SCM names = scm_cons (scm_str2symbol (name), SCM_EOL);
 200       SCM *tail = SCM_CDRLOC (names);
 201       va_start (ap, name);
 202       while (1)
 203         {
 204           const char *n = va_arg (ap, const char *);
 205           if (n == NULL)
 206             break;
 207           *tail = scm_cons (scm_str2symbol (n), SCM_EOL);
 208           tail = SCM_CDRLOC (*tail);
 209         }
 210       va_end (ap);
 211       scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
 212                   scm_current_module (), names);
 213     }
 214 }
 215
 216 /* Environments */
 217
 218 SCM
 219 scm_top_level_env (SCM thunk)
 220 {
 221   if (SCM_IMP (thunk))
 222     return SCM_EOL;
 223   else
 224     return scm_cons (thunk, SCM_EOL);
 225 }
 226
 227 SCM
 228 scm_env_top_level (SCM env)
 229 {
 230   while (SCM_NIMP (env))
 231     {
 232       if (!SCM_CONSP (SCM_CAR (env))
 233           && SCM_NFALSEP (scm_procedure_p (SCM_CAR (env))))
 234         return SCM_CAR (env);
 235       env = SCM_CDR (env);
 236     }
 237   return SCM_BOOL_F;
 238 }
 239
 240 SCM_SYMBOL (sym_module, "module");
 241
 242 static SCM the_root_module_var;
 243
 244 static SCM
 245 the_root_module ()
 246 {
 247   if (scm_module_system_booted_p)
 248     return SCM_VARIABLE_REF (the_root_module_var);
 249   else
 250     return SCM_BOOL_F;
 251 }
 252
 253 SCM
 254 scm_lookup_closure_module (SCM proc)
 255 {
 256   if (SCM_FALSEP (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 (mod == SCM_BOOL_F)
 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_NFALSEP(b) && \
 292    (!SCM_VARIABLEP(b) || !SCM_UNBNDP (SCM_VARIABLE_REF (b))))
 293
 294   /* 1. Check module obarray */
 295   SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 296   if (SCM_BOUND_THING_P (b))
 297     return b;
 298   {
 299     SCM binder = SCM_MODULE_BINDER (module);
 300     if (SCM_NFALSEP (binder))
 301       /* 2. Custom binder */
 302       {
 303         b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
 304         if (SCM_BOUND_THING_P (b))
 305           return b;
 306       }
 307   }
 308   {
 309     /* 3. Search the use list */
 310     SCM uses = SCM_MODULE_USES (module);
 311     while (SCM_CONSP (uses))
 312       {
 313         b = module_variable (SCM_CAR (uses), sym);
 314         if (SCM_BOUND_THING_P (b))
 315           return b;
 316         uses = SCM_CDR (uses);
 317       }
 318     return SCM_BOOL_F;
 319   }
 320 #undef SCM_BOUND_THING_P
 321 }
 322
 323 scm_t_bits scm_tc16_eval_closure;
 324
 325 #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
 326 #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
 327   (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
 328
 329 /* NOTE: This function may be called by a smob application
 330    or from another C function directly. */
 331 SCM
 332 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
 333 {
 334   SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
 335   if (SCM_NFALSEP (definep))
 336     {
 337       if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
 338         return SCM_BOOL_F;
 339       return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
 340                          module, sym);
 341     }
 342   else
 343     return module_variable (module, sym);
 344 }
 345
 346 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
 347             (SCM module),
 348             "Return an eval closure for the module @var{module}.")
 349 #define FUNC_NAME s_scm_standard_eval_closure
 350 {
 351   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
 352 }
 353 #undef FUNC_NAME
 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 (module == SCM_BOOL_F)
 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 (module == SCM_BOOL_F)
 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_sym2var
 404  *
 405  * looks up the variable bound to SYM according to PROC.  PROC should be
 406  * a `eval closure' of some module.
 407  *
 408  * When no binding exists, and DEFINEP is true, create a new binding
 409  * with a initial value of SCM_UNDEFINED.  Return `#f' when DEFINEP as
 410  * false and no binding exists.
 411  *
 412  * When PROC is `#f', it is ignored and the binding is searched for in
 413  * the scm_pre_modules_obarray (a `eq' hash table).
 414  */
 415
 416 SCM scm_pre_modules_obarray;
 417
 418 SCM
 419 scm_sym2var (SCM sym, SCM proc, SCM definep)
 420 #define FUNC_NAME "scm_sym2var"
 421 {
 422   SCM var;
 423
 424   if (SCM_NIMP (proc))
 425     {
 426       if (SCM_EVAL_CLOSURE_P (proc))
 427         {
 428           /* Bypass evaluator in the standard case. */
 429           var = scm_eval_closure_lookup (proc, sym, definep);
 430         }
 431       else
 432         var = scm_call_2 (proc, sym, definep);
 433     }
 434   else
 435     {
 436       SCM handle;
 437
 438       if (definep == SCM_BOOL_F)
 439         var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
 440       else
 441         {
 442           handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
 443                                               sym, SCM_BOOL_F);
 444           var = SCM_CDR (handle);
 445           if (var == SCM_BOOL_F)
 446             {
 447               var = scm_make_variable (SCM_UNDEFINED);
 448               SCM_SETCDR (handle, var);
 449             }
 450         }
 451     }
 452
 453   if (var != SCM_BOOL_F && !SCM_VARIABLEP (var))
 454     SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
 455
 456   return var;
 457 }
 458 #undef FUNC_NAME
 459
 460 SCM
 461 scm_c_module_lookup (SCM module, const char *name)
 462 {
 463   return scm_module_lookup (module, scm_str2symbol (name));
 464 }
 465
 466 SCM
 467 scm_module_lookup (SCM module, SCM sym)
 468 #define FUNC_NAME "module-lookup"
 469 {
 470   SCM var;
 471   SCM_VALIDATE_MODULE (1, module);
 472
 473   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
 474   if (SCM_FALSEP (var))
 475     SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
 476   return var;
 477 }
 478 #undef FUNC_NAME
 479
 480 SCM
 481 scm_c_lookup (const char *name)
 482 {
 483   return scm_lookup (scm_str2symbol (name));
 484 }
 485
 486 SCM
 487 scm_lookup (SCM sym)
 488 {
 489   SCM var =
 490     scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
 491   if (SCM_FALSEP (var))
 492     scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
 493   return var;
 494 }
 495
 496 SCM
 497 scm_c_module_define (SCM module, const char *name, SCM value)
 498 {
 499   return scm_module_define (module, scm_str2symbol (name), value);
 500 }
 501
 502 SCM
 503 scm_module_define (SCM module, SCM sym, SCM value)
 504 #define FUNC_NAME "module-define"
 505 {
 506   SCM var;
 507   SCM_VALIDATE_MODULE (1, module);
 508
 509   var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
 510   SCM_VARIABLE_SET (var, value);
 511   return var;
 512 }
 513 #undef FUNC_NAME
 514
 515 SCM
 516 scm_c_define (const char *name, SCM value)
 517 {
 518   return scm_define (scm_str2symbol (name), value);
 519 }
 520
 521 SCM
 522 scm_define (SCM sym, SCM value)
 523 {
 524   SCM var =
 525     scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
 526   SCM_VARIABLE_SET (var, value);
 527   return var;
 528 }
 529
 530 SCM
 531 scm_module_reverse_lookup (SCM module, SCM variable)
 532 #define FUNC_NAME "module-reverse-lookup"
 533 {
 534   SCM obarray;
 535   long i, n;
 536
 537   if (module == SCM_BOOL_F)
 538     obarray = scm_pre_modules_obarray;
 539   else
 540     {
 541       SCM_VALIDATE_MODULE (1, module);
 542       obarray = SCM_MODULE_OBARRAY (module);
 543     }
 544
 545   /* XXX - We do not use scm_hash_fold here to avoid searching the
 546      whole obarray.  We should have a scm_hash_find procedure. */
 547
 548   n = SCM_VECTOR_LENGTH (obarray);
 549   for (i = 0; i < n; ++i)
 550     {
 551       SCM ls = SCM_VELTS (obarray)[i], handle;
 552       while (!SCM_NULLP (ls))
 553         {
 554           handle = SCM_CAR (ls);
 555           if (SCM_CDR (handle) == variable)
 556             return SCM_CAR (handle);
 557           ls = SCM_CDR (ls);
 558         }
 559     }
 560
 561   /* Try the `uses' list.
 562    */
 563   {
 564     SCM uses = SCM_MODULE_USES (module);
 565     while (SCM_CONSP (uses))
 566       {
 567         SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
 568         if (sym != SCM_BOOL_F)
 569           return sym;
 570         uses = SCM_CDR (uses);
 571       }
 572   }
 573
 574   return SCM_BOOL_F;
 575 }
 576 #undef FUNC_NAME
 577
 578 SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
 579             (),
 580             "Return the obarray that is used for all new bindings before "
 581             "the module system is booted.  The first call to "
 582             "@code{set-current-module} will boot the module system.")
 583 #define FUNC_NAME s_scm_get_pre_modules_obarray
 584 {
 585   return scm_pre_modules_obarray;
 586 }
 587 #undef FUNC_NAME
 588
 589 SCM_SYMBOL (scm_sym_system_module, "system-module");
 590
 591 SCM
 592 scm_system_module_env_p (SCM env)
 593 {
 594   SCM proc = scm_env_top_level (env);
 595   if (SCM_FALSEP (proc))
 596     return SCM_BOOL_T;
 597   return ((SCM_NFALSEP (scm_procedure_property (proc,
 598                                                 scm_sym_system_module)))
 599           ? SCM_BOOL_T
 600           : SCM_BOOL_F);
 601 }
 602
 603 void
 604 scm_modules_prehistory ()
 605 {
 606   scm_pre_modules_obarray
 607     = scm_permanent_object (scm_c_make_hash_table (2001));
 608 }
 609
 610 void
 611 scm_init_modules ()
 612 {
 613 #ifndef SCM_MAGIC_SNARFER
 614 #include "libguile/modules.x"
 615 #endif
 616   module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
 617                                             SCM_UNDEFINED);
 618   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 619   scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
 620   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 621
 622   the_module = scm_permanent_object (scm_make_fluid ());
 623 }
 624
 625 static void
 626 scm_post_boot_init_modules ()
 627 {
 628 #define PERM(x) scm_permanent_object(x)
 629
 630   SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
 631   scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
 632
 633   resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
 634   process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
 635   process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
 636   module_export_x_var = PERM (scm_c_lookup ("module-export!"));
 637   the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
 638
 639   scm_module_system_booted_p = 1;
 640 }
 641
 642 /*
 643   Local Variables:
 644   c-file-style: "gnu"
 645   End:
 646 */