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 SCM scm_module_type;
  64
  65 static SCM the_root_module;
  66 static SCM root_module_lookup_closure;
  67
  68 SCM
  69 scm_the_root_module ()
  70 {
  71   return SCM_CDR (the_root_module);
  72 }
  73
  74 static SCM the_module;
  75
  76 SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
  77             (),
  78             "Return the current module.")
  79 #define FUNC_NAME s_scm_current_module
  80 {
  81   return scm_fluid_ref (the_module);
  82 }
  83 #undef FUNC_NAME
  84
  85 #define SCM_VALIDATE_STRUCT_TYPE(pos, v, type) \
  86   do { \
  87     SCM_ASSERT (SCM_NIMP (v) && SCM_NFALSEP (SCM_STRUCTP (v)) \
  88                 && SCM_STRUCT_VTABLE (v) == (type), \
  89                 v, pos, FUNC_NAME); \
  90   } while (0)
  91
  92 SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
  93             (SCM module),
  94             "Set the current module to @var{module} and return"
  95             "the previous current module.")
  96 #define FUNC_NAME s_scm_set_current_module
  97 {
  98   SCM old;
  99
 100   /* XXX - we can not validate our argument when the module system
 101            hasn't been booted yet since we don't know the type.  This
 102            should be fixed when we have a cleaner way of booting
 103            Guile.
 104   */
 105   if (scm_module_system_booted_p)
 106     SCM_VALIDATE_STRUCT_TYPE (SCM_ARG1, module, scm_module_type);
 107
 108   old = scm_current_module ();
 109   scm_fluid_set_x (the_module, module);
 110
 111 #if SCM_DEBUG_DEPRECATED == 0
 112   scm_fluid_set_x (SCM_CDR (scm_top_level_lookup_closure_var),
 113                    scm_current_module_lookup_closure ());
 114   scm_fluid_set_x (SCM_CDR (scm_system_transformer),
 115                    scm_current_module_transformer ());
 116 #endif
 117
 118   return old;
 119 }
 120 #undef FUNC_NAME
 121
 122 SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
 123             (),
 124             "Return a specifier for the environment that contains\n"
 125             "implementation--defined bindings, typically a superset of those\n"
 126             "listed in the report.  The intent is that this procedure will\n"
 127             "return the environment in which the implementation would\n"
 128             "evaluate expressions dynamically typed by the user.")
 129 #define FUNC_NAME s_scm_interaction_environment
 130 {
 131   return scm_current_module ();
 132 }
 133 #undef FUNC_NAME
 134
 135 SCM_SYMBOL (scm_sym_app, "app");
 136 SCM_SYMBOL (scm_sym_modules, "modules");
 137 static SCM module_prefix;
 138
 139 static SCM
 140 scm_module_full_name (SCM name)
 141 {
 142   if (SCM_EQ_P (SCM_CAR (name), scm_sym_app))
 143     return name;
 144   else
 145     return scm_append (SCM_LIST2 (module_prefix, name));
 146 }
 147
 148 static SCM make_modules_in;
 149 static SCM beautify_user_module_x;
 150
 151 SCM
 152 scm_make_module (SCM name)
 153 {
 154   return scm_apply (SCM_CDR (make_modules_in),
 155                     SCM_LIST2 (scm_the_root_module (),
 156                                scm_module_full_name (name)),
 157                     SCM_EOL);
 158 }
 159
 160 SCM
 161 scm_ensure_user_module (SCM module)
 162 {
 163   scm_apply (SCM_CDR (beautify_user_module_x), SCM_LIST1 (module), SCM_EOL);
 164   return SCM_UNSPECIFIED;
 165 }
 166
 167 SCM
 168 scm_module_lookup_closure (SCM module)
 169 {
 170   return SCM_MODULE_EVAL_CLOSURE (module);
 171 }
 172
 173 SCM
 174 scm_current_module_lookup_closure ()
 175 {
 176   if (scm_module_system_booted_p)
 177     return scm_module_lookup_closure (scm_current_module ());
 178   else
 179     return SCM_BOOL_F;
 180 }
 181
 182 SCM
 183 scm_module_transformer (SCM module)
 184 {
 185   return SCM_MODULE_TRANSFORMER (module);
 186 }
 187
 188 SCM
 189 scm_current_module_transformer ()
 190 {
 191   if (scm_module_system_booted_p)
 192     return scm_module_transformer (scm_current_module ());
 193   else
 194     return SCM_BOOL_F;
 195 }
 196
 197 static SCM resolve_module;
 198
 199 SCM
 200 scm_resolve_module (SCM name)
 201 {
 202   return scm_apply (SCM_CDR (resolve_module), SCM_LIST1 (name), SCM_EOL);
 203 }
 204
 205 static SCM try_module_autoload;
 206
 207 SCM
 208 scm_load_scheme_module (SCM name)
 209 {
 210   return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL);
 211 }
 212
 213 /* Environments */
 214
 215 SCM
 216 scm_top_level_env (SCM thunk)
 217 {
 218   if (SCM_IMP (thunk))
 219     return SCM_EOL;
 220   else
 221     return scm_cons (thunk, SCM_EOL);
 222 }
 223
 224 SCM
 225 scm_env_top_level (SCM env)
 226 {
 227   while (SCM_NIMP (env))
 228     {
 229       if (!SCM_CONSP (SCM_CAR (env))
 230           && SCM_NFALSEP (scm_procedure_p (SCM_CAR (env))))
 231         return SCM_CAR (env);
 232       env = SCM_CDR (env);
 233     }
 234   return SCM_BOOL_F;
 235 }
 236
 237
 238 SCM_SYMBOL (scm_sym_system_module, "system-module");
 239
 240 SCM
 241 scm_system_module_env_p (SCM env)
 242 {
 243   SCM proc = scm_env_top_level (env);
 244   if (SCM_FALSEP (proc))
 245     proc = root_module_lookup_closure;
 246   return ((SCM_NFALSEP (scm_procedure_property (proc,
 247                                                 scm_sym_system_module)))
 248           ? SCM_BOOL_T
 249           : SCM_BOOL_F);
 250 }
 251
 252 /*
 253  * C level implementation of the standard eval closure
 254  *
 255  * This increases loading speed substantially.
 256  * The code will be replaced by the low-level environments in next release.
 257  */
 258
 259 static SCM module_make_local_var_x;
 260
 261 static SCM
 262 module_variable (SCM module, SCM sym)
 263 {
 264   /* 1. Check module obarray */
 265   SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
 266   if (SCM_VARIABLEP (b))
 267     return b;
 268   {
 269     SCM binder = SCM_MODULE_BINDER (module);
 270     if (SCM_NFALSEP (binder))
 271       /* 2. Custom binder */
 272       {
 273         b = scm_apply (binder,
 274                        SCM_LIST3 (module, sym, SCM_BOOL_F),
 275                        SCM_EOL);
 276         if (SCM_NFALSEP (b))
 277           return b;
 278       }
 279   }
 280   {
 281     /* 3. Search the use list */
 282     SCM uses = SCM_MODULE_USES (module);
 283     while (SCM_CONSP (uses))
 284       {
 285         b = module_variable (SCM_CAR (uses), sym);
 286         if (SCM_NFALSEP (b))
 287           return b;
 288         uses = SCM_CDR (uses);
 289       }
 290     return SCM_BOOL_F;
 291   }
 292 }
 293
 294 scm_bits_t scm_tc16_eval_closure;
 295
 296 /* NOTE: This function may be called by a smob application
 297    or from another C function directly. */
 298 SCM
 299 scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
 300 {
 301   SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
 302   if (SCM_NFALSEP (definep))
 303     return scm_apply (SCM_CDR (module_make_local_var_x),
 304                       SCM_LIST2 (module, sym),
 305                       SCM_EOL);
 306   else
 307     return module_variable (module, sym);
 308 }
 309
 310 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
 311             (SCM module),
 312             "Return an eval closure for the module @var{module}.")
 313 #define FUNC_NAME s_scm_standard_eval_closure
 314 {
 315   SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
 316 }
 317 #undef FUNC_NAME
 318
 319 void
 320 scm_init_modules ()
 321 {
 322 #ifndef SCM_MAGIC_SNARFER
 323 #include "libguile/modules.x"
 324 #endif
 325   module_make_local_var_x = scm_sysintern ("module-make-local-var!",
 326                                            SCM_UNDEFINED);
 327   scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
 328   scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
 329   scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
 330
 331   the_module = scm_permanent_object (scm_make_fluid ());
 332 }
 333
 334 void
 335 scm_post_boot_init_modules ()
 336 {
 337   scm_module_type =
 338     scm_permanent_object (SCM_CDR (scm_intern0 ("module-type")));
 339   scm_module_tag = (SCM_CELL_WORD_1 (scm_module_type) + scm_tc3_cons_gloc);
 340   module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app,
 341                                                    scm_sym_modules));
 342   make_modules_in = scm_intern0 ("make-modules-in");
 343   beautify_user_module_x = scm_intern0 ("beautify-user-module!");
 344   the_root_module = scm_intern0 ("the-root-module");
 345   root_module_lookup_closure = scm_permanent_object
 346     (scm_module_lookup_closure (SCM_CDR (the_root_module)));
 347   resolve_module = scm_intern0 ("resolve-module");
 348   try_module_autoload = scm_intern0 ("try-module-autoload");
 349   scm_module_system_booted_p = 1;
 350 }
 351
 352 /*
 353   Local Variables:
 354   c-file-style: "gnu"
 355   End:
 356 */