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