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_selected_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_select_module (SCM module)
  90 {
  91   SCM old = scm_selected_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             "This procedure returns a specifier for the environment that contains\n"
  99             "implementation-defined bindings, typically a superset of those listed in\n"
 100             "the report.  The intent is that this procedure will return the\n"
 101             "environment in which the implementation would evaluate expressions\n"
 102             "dynamically typed by the user.")
 103 #define FUNC_NAME s_scm_interaction_environment
 104 {
 105   return scm_selected_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 static SCM resolve_module;
 148
 149 SCM
 150 scm_resolve_module (SCM name)
 151 {
 152   return scm_apply (SCM_CDR (resolve_module), SCM_LIST1 (name), SCM_EOL);
 153 }
 154
 155 static SCM try_module_autoload;
 156
 157 SCM
 158 scm_load_scheme_module (SCM name)
 159 {
 160   return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL);
 161 }
 162
 163 /* Environments */
 164
 165 SCM
 166 scm_top_level_env (SCM thunk)
 167 {
 168   if (SCM_IMP (thunk))
 169     return SCM_EOL;
 170   else
 171     return scm_cons (thunk, SCM_EOL);
 172 }
 173
 174 SCM
 175 scm_env_top_level (SCM env)
 176 {
 177   while (SCM_NIMP (env))
 178     {
 179       if (!SCM_CONSP (SCM_CAR (env))
 180           && SCM_NFALSEP (scm_procedure_p (SCM_CAR (env))))
 181         return SCM_CAR (env);
 182       env = SCM_CDR (env);
 183     }
 184   return SCM_BOOL_F;
 185 }
 186
 187
 188 SCM_SYMBOL (scm_sym_system_module, "system-module");
 189
 190 SCM
 191 scm_system_module_env_p (SCM env)
 192 {
 193   SCM proc = scm_env_top_level (env);
 194   if (SCM_FALSEP (proc))
 195     proc = root_module_lookup_closure;
 196   return ((SCM_NFALSEP (scm_procedure_property (proc,
 197                                                 scm_sym_system_module)))
 198           ? SCM_BOOL_T
 199           : SCM_BOOL_F);
 200 }
 201
 202 /*
 203  * C level implementation of the standard eval closure
 204  *
 205  * This increases loading speed substantially.
 206  * The code will be replaced by the low-level environments in next release.
 207  */
 208
 209 static SCM module_make_local_var_x;
 210
 211 static SCM
 212 module_variable (SCM module, SCM sym)
 213 {
 214   /* 1. Check module obarray */
 215   SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 216   if (SCM_VARIABLEP (b))
 217     return b;
 218   {
 219     SCM binder = SCM_MODULE_BINDER (module);
 220     if (SCM_NFALSEP (binder))
 221       /* 2. Custom binder */
 222       {
 223         b = scm_apply (binder,
 224                        SCM_LIST3 (module, sym, SCM_BOOL_F),
 225                        SCM_EOL);
 226         if (SCM_NFALSEP (b))
 227           return b;
 228       }
 229   }
 230   {
 231     /* 3. Search the use list */
 232     SCM uses = SCM_MODULE_USES (module);
 233     while (SCM_CONSP (uses))
 234       {
 235         b = module_variable (SCM_CAR (uses), sym);
 236         if (SCM_NFALSEP (b))
 237           return b;
 238         uses = SCM_CDR (uses);
 239       }
 240     return SCM_BOOL_F;
 241   }
 242 }
 243
 244 scm_bits_t scm_tc16_eval_closure;
 245
 246 /* NOTE: This function may be called by a smob application
 247    or from another C function directly. */
 248 SCM
 249 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
 250 {
 251   SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
 252   if (SCM_NFALSEP (definep))
 253     return scm_apply (SCM_CDR (module_make_local_var_x),
 254                       SCM_LIST2 (module, sym),
 255                       SCM_EOL);
 256   else
 257     return module_variable (module, sym);
 258 }
 259
 260 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
 261             (SCM module),
 262             "")
 263 #define FUNC_NAME s_scm_standard_eval_closure
 264 {
 265   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
 266 }
 267 #undef FUNC_NAME
 268
 269 void
 270 scm_init_modules ()
 271 {
 272 #ifndef SCM_MAGIC_SNARFER
 273 #include "libguile/modules.x"
 274 #endif
 275   module_make_local_var_x = scm_sysintern ("module-make-local-var!",
 276                                            SCM_UNDEFINED);
 277   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 278   scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
 279   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 280 }
 281
 282 void
 283 scm_post_boot_init_modules ()
 284 {
 285   scm_module_tag = (SCM_CELL_WORD_1 (SCM_CDR (scm_intern0 ("module-type")))
 286                     + scm_tc3_cons_gloc);
 287   the_root_module = scm_intern0 ("the-root-module");
 288   the_module = scm_intern0 ("the-module");
 289   set_current_module = scm_intern0 ("set-current-module");
 290   module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app,
 291                                                    scm_sym_modules));
 292   make_modules_in = scm_intern0 ("make-modules-in");
 293   beautify_user_module_x = scm_intern0 ("beautify-user-module!");
 294   root_module_lookup_closure = scm_permanent_object
 295     (scm_module_lookup_closure (SCM_CDR (the_root_module)));
 296   resolve_module = scm_intern0 ("resolve-module");
 297   try_module_autoload = scm_intern0 ("try-module-autoload");
 298   scm_module_system_booted_p = 1;
 299 }
 300
 301 /*
 302   Local Variables:
 303   c-file-style: "gnu"
 304   End:
 305 */