libguile/modules.c

   1 /*      Copyright (C) 1998, 2000 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 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  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
  58 #include "libguile/modules.h"
  59
  60 SCM scm_module_system_booted_p = 0;
  61
  62 SCM scm_module_tag;
  63
  64 static SCM the_root_module;
  65 static SCM root_module_lookup_closure;
  66
  67 SCM
  68 scm_the_root_module ()
  69 {
  70   return SCM_CDR (the_root_module);
  71 }
  72
  73 static SCM the_module;
  74
  75 SCM
  76 scm_current_module ()
  77 {
  78   return scm_fluid_ref (SCM_CDR (the_module));
  79 }
  80
  81 static SCM set_current_module;
  82
  83 /* This is the module selected during loading of code.  Currently,
  84  * this is the same as (interaction-environment), but need not be in
  85  * the future.
  86  */
  87
  88 SCM
  89 scm_set_current_module (SCM module)
  90 {
  91   SCM old = scm_current_module ();
  92   scm_apply (SCM_CDR (set_current_module), SCM_LIST1 (module), SCM_EOL);
  93   return old;
  94 }
  95
  96 SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
  97             (),
  98             "Return a specifier for the environment that contains\n"
  99             "implementation--defined bindings, typically a superset of those\n"
 100             "listed in the report.  The intent is that this procedure will\n"
 101             "return the environment in which the implementation would\n"
 102             "evaluate expressions dynamically typed by the user.")
 103 #define FUNC_NAME s_scm_interaction_environment
 104 {
 105   return scm_current_module ();
 106 }
 107 #undef FUNC_NAME
 108
 109 SCM_SYMBOL (scm_sym_app, "app");
 110 SCM_SYMBOL (scm_sym_modules, "modules");
 111 static SCM module_prefix;
 112
 113 static SCM
 114 scm_module_full_name (SCM name)
 115 {
 116   if (SCM_EQ_P (SCM_CAR (name), scm_sym_app))
 117     return name;
 118   else
 119     return scm_append (SCM_LIST2 (module_prefix, name));
 120 }
 121
 122 static SCM make_modules_in;
 123 static SCM beautify_user_module_x;
 124
 125 SCM
 126 scm_make_module (SCM name)
 127 {
 128   return scm_apply (SCM_CDR (make_modules_in),
 129                     SCM_LIST2 (scm_the_root_module (),
 130                                scm_module_full_name (name)),
 131                     SCM_EOL);
 132 }
 133
 134 SCM
 135 scm_ensure_user_module (SCM module)
 136 {
 137   scm_apply (SCM_CDR (beautify_user_module_x), SCM_LIST1 (module), SCM_EOL);
 138   return SCM_UNSPECIFIED;
 139 }
 140
 141 SCM
 142 scm_module_lookup_closure (SCM module)
 143 {
 144   return SCM_MODULE_EVAL_CLOSURE (module);
 145 }
 146
 147 SCM
 148 scm_current_module_lookup_closure ()
 149 {
 150   if (scm_module_system_booted_p)
 151     return scm_module_lookup_closure (scm_current_module ());
 152   else
 153     return SCM_BOOL_F;
 154 }
 155
 156 static SCM resolve_module;
 157
 158 SCM
 159 scm_resolve_module (SCM name)
 160 {
 161   return scm_apply (SCM_CDR (resolve_module), SCM_LIST1 (name), SCM_EOL);
 162 }
 163
 164 static SCM try_module_autoload;
 165
 166 SCM
 167 scm_load_scheme_module (SCM name)
 168 {
 169   return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL);
 170 }
 171
 172 /* Environments */
 173
 174 SCM
 175 scm_top_level_env (SCM thunk)
 176 {
 177   if (SCM_IMP (thunk))
 178     return SCM_EOL;
 179   else
 180     return scm_cons (thunk, SCM_EOL);
 181 }
 182
 183 SCM
 184 scm_env_top_level (SCM env)
 185 {
 186   while (SCM_NIMP (env))
 187     {
 188       if (!SCM_CONSP (SCM_CAR (env))
 189           && SCM_NFALSEP (scm_procedure_p (SCM_CAR (env))))
 190         return SCM_CAR (env);
 191       env = SCM_CDR (env);
 192     }
 193   return SCM_BOOL_F;
 194 }
 195
 196
 197 SCM_SYMBOL (scm_sym_system_module, "system-module");
 198
 199 SCM
 200 scm_system_module_env_p (SCM env)
 201 {
 202   SCM proc = scm_env_top_level (env);
 203   if (SCM_FALSEP (proc))
 204     proc = root_module_lookup_closure;
 205   return ((SCM_NFALSEP (scm_procedure_property (proc,
 206                                                 scm_sym_system_module)))
 207           ? SCM_BOOL_T
 208           : SCM_BOOL_F);
 209 }
 210
 211 /*
 212  * C level implementation of the standard eval closure
 213  *
 214  * This increases loading speed substantially.
 215  * The code will be replaced by the low-level environments in next release.
 216  */
 217
 218 static SCM module_make_local_var_x;
 219
 220 static SCM
 221 module_variable (SCM module, SCM sym)
 222 {
 223   /* 1. Check module obarray */
 224   SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 225   if (SCM_VARIABLEP (b))
 226     return b;
 227   {
 228     SCM binder = SCM_MODULE_BINDER (module);
 229     if (SCM_NFALSEP (binder))
 230       /* 2. Custom binder */
 231       {
 232         b = scm_apply (binder,
 233                        SCM_LIST3 (module, sym, SCM_BOOL_F),
 234                        SCM_EOL);
 235         if (SCM_NFALSEP (b))
 236           return b;
 237       }
 238   }
 239   {
 240     /* 3. Search the use list */
 241     SCM uses = SCM_MODULE_USES (module);
 242     while (SCM_CONSP (uses))
 243       {
 244         b = module_variable (SCM_CAR (uses), sym);
 245         if (SCM_NFALSEP (b))
 246           return b;
 247         uses = SCM_CDR (uses);
 248       }
 249     return SCM_BOOL_F;
 250   }
 251 }
 252
 253 scm_bits_t scm_tc16_eval_closure;
 254
 255 /* NOTE: This function may be called by a smob application
 256    or from another C function directly. */
 257 SCM
 258 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
 259 {
 260   SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
 261   if (SCM_NFALSEP (definep))
 262     return scm_apply (SCM_CDR (module_make_local_var_x),
 263                       SCM_LIST2 (module, sym),
 264                       SCM_EOL);
 265   else
 266     return module_variable (module, sym);
 267 }
 268
 269 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
 270             (SCM module),
 271             "Return an eval closure for the module @var{module}.")
 272 #define FUNC_NAME s_scm_standard_eval_closure
 273 {
 274   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
 275 }
 276 #undef FUNC_NAME
 277
 278 void
 279 scm_init_modules ()
 280 {
 281 #ifndef SCM_MAGIC_SNARFER
 282 #include "libguile/modules.x"
 283 #endif
 284   module_make_local_var_x = scm_sysintern ("module-make-local-var!",
 285                                            SCM_UNDEFINED);
 286   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 287   scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
 288   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 289 }
 290
 291 void
 292 scm_post_boot_init_modules ()
 293 {
 294   scm_module_tag = (SCM_CELL_WORD_1 (SCM_CDR (scm_intern0 ("module-type")))
 295                     + scm_tc3_cons_gloc);
 296   the_root_module = scm_intern0 ("the-root-module");
 297   the_module = scm_intern0 ("the-module");
 298   set_current_module = scm_intern0 ("set-current-module");
 299   module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app,
 300                                                    scm_sym_modules));
 301   make_modules_in = scm_intern0 ("make-modules-in");
 302   beautify_user_module_x = scm_intern0 ("beautify-user-module!");
 303   root_module_lookup_closure = scm_permanent_object
 304     (scm_module_lookup_closure (SCM_CDR (the_root_module)));
 305   resolve_module = scm_intern0 ("resolve-module");
 306   try_module_autoload = scm_intern0 ("try-module-autoload");
 307   scm_module_system_booted_p = 1;
 308 }
 309
 310 /*
 311   Local Variables:
 312   c-file-style: "gnu"
 313   End:
 314 */