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/procprop.h"
  51 #include "libguile/vectors.h"
  52 #include "libguile/hashtab.h"
  53 #include "libguile/struct.h"
  54 #include "libguile/variable.h"
  55
  56 #include "libguile/modules.h"
  57
  58 static SCM the_root_module;
  59 static SCM root_module_lookup_closure;
  60
  61 SCM
  62 scm_the_root_module ()
  63 {
  64   return SCM_CDR (the_root_module);
  65 }
  66
  67 static SCM the_module;
  68
  69 SCM
  70 scm_selected_module ()
  71 {
  72   return SCM_CDR (the_module);
  73 }
  74
  75 static SCM set_current_module;
  76
  77 SCM
  78 scm_select_module (SCM module)
  79 {
  80   SCM old = scm_selected_module ();
  81   scm_apply (SCM_CDR (set_current_module), SCM_LIST1 (module), SCM_EOL);
  82   return old;
  83 }
  84
  85 SCM_SYMBOL (scm_sym_app, "app");
  86 SCM_SYMBOL (scm_sym_modules, "modules");
  87 static SCM module_prefix;
  88
  89 static SCM
  90 scm_module_full_name (SCM name)
  91 {
  92   if (SCM_EQ_P (SCM_CAR (name), scm_sym_app))
  93     return name;
  94   else
  95     return scm_append (SCM_LIST2 (module_prefix, name));
  96 }
  97
  98 static SCM make_modules_in;
  99 static SCM beautify_user_module_x;
 100
 101 SCM
 102 scm_make_module (SCM name)
 103 {
 104   return scm_apply (SCM_CDR (make_modules_in),
 105                     SCM_LIST2 (scm_the_root_module (),
 106                                scm_module_full_name (name)),
 107                     SCM_EOL);
 108 }
 109
 110 SCM
 111 scm_ensure_user_module (SCM module)
 112 {
 113   scm_apply (SCM_CDR (beautify_user_module_x), SCM_LIST1 (module), SCM_EOL);
 114   return SCM_UNSPECIFIED;
 115 }
 116
 117 static SCM module_eval_closure;
 118
 119 SCM
 120 scm_module_lookup_closure (SCM module)
 121 {
 122   return scm_apply (SCM_CDR (module_eval_closure),
 123                     SCM_LIST1 (module),
 124                     SCM_EOL);
 125 }
 126
 127 static SCM resolve_module;
 128
 129 SCM
 130 scm_resolve_module (SCM name)
 131 {
 132   return scm_apply (SCM_CDR (resolve_module), SCM_LIST1 (name), SCM_EOL);
 133 }
 134
 135 static SCM try_module_autoload;
 136
 137 SCM
 138 scm_load_scheme_module (SCM name)
 139 {
 140   return scm_apply (SCM_CDR (try_module_autoload), SCM_LIST1 (name), SCM_EOL);
 141 }
 142
 143 /* Environments
 144  */
 145
 146 SCM
 147 scm_top_level_env (SCM thunk)
 148 {
 149   if (SCM_IMP (thunk))
 150     return SCM_EOL;
 151   else
 152     return scm_cons (thunk, SCM_EOL);
 153 }
 154
 155 SCM
 156 scm_env_top_level (SCM env)
 157 {
 158   while (SCM_NIMP (env))
 159     {
 160       if (!SCM_CONSP (SCM_CAR (env))
 161           && SCM_NFALSEP (scm_procedure_p (SCM_CAR (env))))
 162         return SCM_CAR (env);
 163       env = SCM_CDR (env);
 164     }
 165   return SCM_BOOL_F;
 166 }
 167
 168
 169 SCM_SYMBOL (scm_sym_system_module, "system-module");
 170
 171 SCM
 172 scm_system_module_env_p (SCM env)
 173 {
 174   SCM proc = scm_env_top_level (env);
 175   if (SCM_FALSEP (proc))
 176     proc = root_module_lookup_closure;
 177   return ((SCM_NFALSEP (scm_procedure_property (proc,
 178                                                 scm_sym_system_module)))
 179           ? SCM_BOOL_T
 180           : SCM_BOOL_F);
 181 }
 182
 183 /*
 184  * C level implementation of the standard eval closure
 185  *
 186  * This increases loading speed substantially.
 187  * The code will be replaced by the low-level environments in next release.
 188  */
 189
 190 #define OBARRAY(module) (SCM_STRUCT_DATA (module) [0])
 191 #define USES(module) (SCM_STRUCT_DATA (module) [1])
 192 #define BINDER(module) (SCM_STRUCT_DATA (module) [2])
 193
 194 static SCM module_make_local_var_x;
 195
 196 static SCM
 197 module_variable (SCM module, SCM sym)
 198 {
 199   /* 1. Check module obarray */
 200   SCM b = scm_hashq_ref (OBARRAY (module), sym, SCM_UNDEFINED);
 201   if (SCM_VARIABLEP (b))
 202     return b;
 203   {
 204     SCM binder = BINDER (module);
 205     if (SCM_NFALSEP (binder))
 206       /* 2. Custom binder */
 207       {
 208         b = scm_apply (binder,
 209                        SCM_LIST3 (module, sym, SCM_BOOL_F),
 210                        SCM_EOL);
 211         if (SCM_NFALSEP (b))
 212           return b;
 213       }
 214   }
 215   {
 216     /* 3. Search the use list */
 217     SCM uses = USES (module);
 218     while (SCM_CONSP (uses))
 219       {
 220         b = module_variable (SCM_CAR (uses), sym);
 221         if (SCM_NFALSEP (b))
 222           return b;
 223         uses = SCM_CDR (uses);
 224       }
 225     return SCM_BOOL_F;
 226   }
 227 }
 228
 229 static SCM f_eval_closure;
 230
 231 static SCM
 232 eval_closure (SCM cclo, SCM sym, SCM definep)
 233 {
 234   SCM module = SCM_VELTS (cclo) [1];
 235   if (SCM_NFALSEP (definep))
 236     return scm_apply (SCM_CDR (module_make_local_var_x),
 237                       SCM_LIST2 (module, sym),
 238                       SCM_EOL);
 239   else
 240     return module_variable (module, sym);
 241 }
 242
 243 SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
 244             (SCM module),
 245             "")
 246 #define FUNC_NAME s_scm_standard_eval_closure
 247 {
 248   SCM cclo = scm_makcclo (f_eval_closure, SCM_MAKINUM (2));
 249   SCM_VELTS (cclo) [1] = module;
 250   return cclo;
 251 }
 252 #undef FUNC_NAME
 253
 254 void
 255 scm_init_modules ()
 256 {
 257 #include "libguile/modules.x"
 258   module_make_local_var_x = scm_sysintern ("module-make-local-var!",
 259                                            SCM_UNDEFINED);
 260   f_eval_closure = scm_make_subr_opt ("eval-closure",
 261                                       scm_tc7_subr_3,
 262                                       eval_closure,
 263                                       0);
 264 }
 265
 266 void
 267 scm_post_boot_init_modules ()
 268 {
 269   the_root_module = scm_intern0 ("the-root-module");
 270   the_module = scm_intern0 ("the-module");
 271   set_current_module = scm_intern0 ("set-current-module");
 272   module_prefix = scm_permanent_object (SCM_LIST2 (scm_sym_app,
 273                                                    scm_sym_modules));
 274   make_modules_in = scm_intern0 ("make-modules-in");
 275   beautify_user_module_x = scm_intern0 ("beautify-user-module!");
 276   module_eval_closure = scm_intern0 ("module-eval-closure");
 277   root_module_lookup_closure = scm_permanent_object
 278     (scm_module_lookup_closure (SCM_CDR (the_root_module)));
 279   resolve_module = scm_intern0 ("resolve-module");
 280   try_module_autoload = scm_intern0 ("try-module-autoload");
 281 }
 282
 283 /*
 284   Local Variables:
 285   c-file-style: "gnu"
 286   End:
 287 */