libguile/modules.c

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