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