mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

* modules.h, modules.c: Moved around a lot of code so that

Browse source 
deprecated features appear at the bottom.
(root_module_lookup_closure, scm_sym_app, scm_sym_modules,
module_prefix, make_modules_in_var, beautify_user_module_x_var,
scm_the_root_module, scm_make_module, scm_ensure_user_module,
scm_load_scheme_module): Deprecated.
(scm_system_module_env_p): Return SCM_BOOL_T directly for
environments corresponding to the root module.
(convert_module_name, scm_c_resolve_module,
scm_c_call_with_current_module, scm_c_define_module,
scm_c_use_module, scm_c_export): New.
(the_root_module): New static variant of scm_the_root_module.  Use
it everywhere instead of scm_the_root_module.
This commit is contained in:
Marius Vollmer 2001-05-19 01:22:12 +00:00
parent 143e090215
commit d02b98e960
2 changed files with 257 additions and 122 deletions
Download patch file Download diff file Expand all files Collapse all files

318
libguile/modules.c
View file

@ -44,6 +44,8 @@
#include <stdarg.h>
#include "libguile/_scm.h" #include "libguile/_scm.h"
#include "libguile/eval.h" #include "libguile/eval.h"
@ -54,6 +56,7 @@
#include "libguile/struct.h" #include "libguile/struct.h"
#include "libguile/variable.h" #include "libguile/variable.h"
#include "libguile/fluids.h" #include "libguile/fluids.h"
#include "libguile/deprecation.h"
#include "libguile/modules.h" #include "libguile/modules.h"
@ -61,18 +64,6 @@ int scm_module_system_booted_p = 0;
SCM scm_module_tag; SCM scm_module_tag;
static SCM the_root_module_var;
static SCM root_module_lookup_closure;
SCM
scm_the_root_module ()
{
if (scm_module_system_booted_p)
return SCM_VARIABLE_REF (the_root_module_var);
else
return SCM_BOOL_F;
}
static SCM the_module; static SCM the_module;
SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0, SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
@ -126,77 +117,48 @@ SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_SYMBOL (scm_sym_app, "app"); SCM
SCM_SYMBOL (scm_sym_modules, "modules"); scm_c_call_with_current_module (SCM module,
static SCM module_prefix; SCM (*func)(void *), void *data)
{
return scm_c_with_fluid (the_module, module, func, data);
}
static SCM static SCM
scm_module_full_name (SCM name) convert_module_name (const char *name)
{ {
if (SCM_EQ_P (SCM_CAR (name), scm_sym_app)) SCM list = SCM_EOL;
return name; SCM *tail = &list;
else
return scm_append (SCM_LIST2 (module_prefix, name)); const char *ptr;
while (*name)
{
while (*name == ' ')
name++;
ptr = name;
while (*ptr && *ptr != ' ')
ptr++;
if (ptr > name)
{
*tail = scm_cons (scm_mem2symbol (name, ptr-name), SCM_EOL);
tail = SCM_CDRLOC (*tail);
}
name = ptr;
} }
static SCM make_modules_in_var; return list;
static SCM beautify_user_module_x_var;
SCM
scm_make_module (SCM name)
{
return scm_apply (SCM_VARIABLE_REF (make_modules_in_var),
SCM_LIST2 (scm_the_root_module (),
scm_module_full_name (name)),
SCM_EOL);
}
SCM
scm_ensure_user_module (SCM module)
{
scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var),
SCM_LIST1 (module), SCM_EOL);
return SCM_UNSPECIFIED;
}
SCM
scm_module_lookup_closure (SCM module)
{
if (module == SCM_BOOL_F)
return SCM_BOOL_F;
else
return SCM_MODULE_EVAL_CLOSURE (module);
}
SCM
scm_current_module_lookup_closure ()
{
if (scm_module_system_booted_p)
return scm_module_lookup_closure (scm_current_module ());
else
return SCM_BOOL_F;
}
SCM
scm_module_transformer (SCM module)
{
if (module == SCM_BOOL_F)
return SCM_BOOL_F;
else
return SCM_MODULE_TRANSFORMER (module);
}
SCM
scm_current_module_transformer ()
{
if (scm_module_system_booted_p)
return scm_module_transformer (scm_current_module ());
else
return SCM_BOOL_F;
} }
static SCM process_define_module_var;
static SCM process_use_modules_var;
static SCM resolve_module_var; static SCM resolve_module_var;
SCM
scm_c_resolve_module (const char *name)
{
return scm_resolve_module (convert_module_name (name));
}
SCM SCM
scm_resolve_module (SCM name) scm_resolve_module (SCM name)
{ {
@ -204,13 +166,47 @@ scm_resolve_module (SCM name)
SCM_LIST1 (name), SCM_EOL); SCM_LIST1 (name), SCM_EOL);
} }
static SCM try_module_autoload_var;
SCM SCM
scm_load_scheme_module (SCM name) scm_c_define_module (const char *name,
void (*init)(void *), void *data)
{ {
return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var), SCM module = scm_apply (SCM_VARIABLE_REF (process_define_module_var),
SCM_LIST1 (name), SCM_EOL); SCM_LIST1 (SCM_LIST1 (convert_module_name (name))),
SCM_EOL);
if (init)
scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
return module;
}
void
scm_c_use_module (const char *name)
{
scm_apply (SCM_VARIABLE_REF (process_use_modules_var),
SCM_LIST1 (SCM_LIST1 (convert_module_name (name))),
SCM_EOL);
}
static SCM module_export_x_var;
void
scm_c_export (const char *name, ...)
{
va_list ap;
SCM names = scm_cons (scm_str2symbol (name), SCM_EOL);
SCM *tail = SCM_CDRLOC (names);
va_start (ap, name);
while (1)
{
const char *n = va_arg (ap, const char *);
if (n == NULL)
break;
*tail = scm_cons (scm_str2symbol (n), SCM_EOL);
tail = SCM_CDRLOC (*tail);
}
scm_apply (SCM_VARIABLE_REF (module_export_x_var),
SCM_LIST2 (scm_current_module (),
names),
SCM_EOL);
} }
/* Environments */ /* Environments */
@ -239,18 +235,29 @@ scm_env_top_level (SCM env)
SCM_SYMBOL (sym_module, "module"); SCM_SYMBOL (sym_module, "module");
static SCM the_root_module_var;
static SCM
the_root_module ()
{
if (scm_module_system_booted_p)
return SCM_VARIABLE_REF (the_root_module_var);
else
return SCM_BOOL_F;
}
SCM SCM
scm_lookup_closure_module (SCM proc) scm_lookup_closure_module (SCM proc)
{ {
if (SCM_FALSEP (proc)) if (SCM_FALSEP (proc))
return scm_the_root_module (); return the_root_module ();
else if (SCM_EVAL_CLOSURE_P (proc)) else if (SCM_EVAL_CLOSURE_P (proc))
return SCM_PACK (SCM_SMOB_DATA (proc)); return SCM_PACK (SCM_SMOB_DATA (proc));
else else
{ {
SCM mod = scm_procedure_property (proc, sym_module); SCM mod = scm_procedure_property (proc, sym_module);
if (mod == SCM_BOOL_F) if (mod == SCM_BOOL_F)
mod = scm_the_root_module (); mod = the_root_module ();
return mod; return mod;
} }
} }
@ -261,21 +268,6 @@ scm_env_module (SCM env)
return scm_lookup_closure_module (scm_env_top_level (env)); return scm_lookup_closure_module (scm_env_top_level (env));
} }
SCM_SYMBOL (scm_sym_system_module, "system-module");
SCM
scm_system_module_env_p (SCM env)
{
SCM proc = scm_env_top_level (env);
if (SCM_FALSEP (proc))
proc = root_module_lookup_closure;
return ((SCM_NFALSEP (scm_procedure_property (proc,
scm_sym_system_module)))
? SCM_BOOL_T
: SCM_BOOL_F);
}
/* /*
* C level implementation of the standard eval closure * C level implementation of the standard eval closure
* *
@ -363,6 +355,42 @@ SCM_DEFINE (scm_standard_interface_eval_closure,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM
scm_module_lookup_closure (SCM module)
{
if (module == SCM_BOOL_F)
return SCM_BOOL_F;
else
return SCM_MODULE_EVAL_CLOSURE (module);
}
SCM
scm_current_module_lookup_closure ()
{
if (scm_module_system_booted_p)
return scm_module_lookup_closure (scm_current_module ());
else
return SCM_BOOL_F;
}
SCM
scm_module_transformer (SCM module)
{
if (module == SCM_BOOL_F)
return SCM_BOOL_F;
else
return SCM_MODULE_TRANSFORMER (module);
}
SCM
scm_current_module_transformer ()
{
if (scm_module_system_booted_p)
return scm_module_transformer (scm_current_module ());
else
return SCM_BOOL_F;
}
/* scm_sym2var /* scm_sym2var
* *
* looks up the variable bound to SYM according to PROC. PROC should be * looks up the variable bound to SYM according to PROC. PROC should be
@ -552,6 +580,32 @@ SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
#if SCM_DEBUG_DEPRECATED == 0
static SCM root_module_lookup_closure;
SCM_SYMBOL (scm_sym_app, "app");
SCM_SYMBOL (scm_sym_modules, "modules");
static SCM module_prefix;
static SCM make_modules_in_var;
static SCM beautify_user_module_x_var;
static SCM try_module_autoload_var;
#endif
SCM_SYMBOL (scm_sym_system_module, "system-module");
SCM
scm_system_module_env_p (SCM env)
{
SCM proc = scm_env_top_level (env);
if (SCM_FALSEP (proc))
return SCM_BOOL_T;
return ((SCM_NFALSEP (scm_procedure_property (proc,
scm_sym_system_module)))
? SCM_BOOL_T
: SCM_BOOL_F);
}
void void
scm_modules_prehistory () scm_modules_prehistory ()
{ {
@ -581,17 +635,83 @@ scm_post_boot_init_modules ()
SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type")); SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc); scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_cons_gloc);
resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
module_export_x_var = PERM (scm_c_lookup ("module-export!"));
the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
#if SCM_DEBUG_DEPRECATED == 0
module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules)); module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules));
make_modules_in_var = PERM (scm_c_lookup ("make-modules-in")); make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
beautify_user_module_x_var = PERM (scm_c_lookup ("beautify-user-module!"));
the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
root_module_lookup_closure = root_module_lookup_closure =
PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var))); PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var)));
resolve_module_var = PERM (scm_c_lookup ("resolve-module")); beautify_user_module_x_var = PERM (scm_c_lookup ("beautify-user-module!"));
try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload")); try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
#endif
scm_module_system_booted_p = 1; scm_module_system_booted_p = 1;
} }
#if SCM_DEBUG_DEPRECATED == 0
SCM
scm_the_root_module ()
{
scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. "
"Use `scm_c_resolve_module (\"guile\") "
"instead.");
return the_root_module ();
}
static SCM
scm_module_full_name (SCM name)
{
if (SCM_EQ_P (SCM_CAR (name), scm_sym_app))
return name;
else
return scm_append (SCM_LIST2 (module_prefix, name));
}
SCM
scm_make_module (SCM name)
{
scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
"Use `scm_c_define_module instead.");
return scm_apply (SCM_VARIABLE_REF (make_modules_in_var),
SCM_LIST2 (scm_the_root_module (),
scm_module_full_name (name)),
SCM_EOL);
}
SCM
scm_ensure_user_module (SCM module)
{
scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
"Use `scm_c_define_module instead.");
scm_apply (SCM_VARIABLE_REF (beautify_user_module_x_var),
SCM_LIST1 (module), SCM_EOL);
return SCM_UNSPECIFIED;
}
SCM
scm_load_scheme_module (SCM name)
{
scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
"Use `scm_c_resolve_module instead.");
return scm_apply (SCM_VARIABLE_REF (try_module_autoload_var),
SCM_LIST1 (name), SCM_EOL);
}
#endif
/* /*
Local Variables: Local Variables:
c-file-style: "gnu" c-file-style: "gnu"

57
libguile/modules.h
View file

@ -50,6 +50,9 @@
extern int scm_module_system_booted_p;
extern SCM scm_module_tag;
#define SCM_MODULEP(OBJ) \ #define SCM_MODULEP(OBJ) \
(SCM_NIMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag) (SCM_NIMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag)
@ -82,31 +85,12 @@ extern scm_bits_t scm_tc16_eval_closure;
extern int scm_module_system_booted_p;
extern SCM scm_module_tag;
extern SCM scm_the_root_module (void);
extern SCM scm_current_module (void); extern SCM scm_current_module (void);
extern SCM scm_current_module_lookup_closure (void);
extern SCM scm_current_module_transformer (void);
extern SCM scm_interaction_environment (void); extern SCM scm_interaction_environment (void);
extern SCM scm_set_current_module (SCM module); extern SCM scm_set_current_module (SCM module);
extern SCM scm_make_module (SCM name);
extern SCM scm_ensure_user_module (SCM name);
extern SCM scm_module_lookup_closure (SCM module);
extern SCM scm_module_transformer (SCM module);
extern SCM scm_resolve_module (SCM name);
extern SCM scm_load_scheme_module (SCM name);
extern SCM scm_env_top_level (SCM env);
extern SCM scm_top_level_env (SCM thunk);
extern SCM scm_system_module_env_p (SCM env);
extern SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
extern SCM scm_standard_eval_closure (SCM module);
extern SCM scm_standard_interface_eval_closure (SCM module);
extern SCM scm_get_pre_modules_obarray (void);
extern SCM scm_lookup_closure_module (SCM proc); extern SCM scm_c_call_with_current_module (SCM module,
extern SCM scm_env_module (SCM env); SCM (*func)(void *), void *data);
extern SCM scm_c_lookup (const char *name); extern SCM scm_c_lookup (const char *name);
extern SCM scm_c_define (const char *name, SCM val); extern SCM scm_c_define (const char *name, SCM val);
@ -119,11 +103,42 @@ extern SCM scm_module_lookup (SCM module, SCM symbol);
extern SCM scm_module_define (SCM module, SCM symbol, SCM val); extern SCM scm_module_define (SCM module, SCM symbol, SCM val);
extern SCM scm_module_reverse_lookup (SCM module, SCM variable); extern SCM scm_module_reverse_lookup (SCM module, SCM variable);
extern SCM scm_c_resolve_module (const char *name);
extern SCM scm_resolve_module (SCM name);
extern SCM scm_c_define_module (const char *name,
void (*init)(void *), void *data);
extern void scm_c_use_module (const char *name);
extern void scm_c_export (const char *name, ...);
extern SCM scm_sym2var (SCM sym, SCM thunk, SCM definep); extern SCM scm_sym2var (SCM sym, SCM thunk, SCM definep);
extern SCM scm_module_lookup_closure (SCM module);
extern SCM scm_module_transformer (SCM module);
extern SCM scm_current_module_lookup_closure (void);
extern SCM scm_current_module_transformer (void);
extern SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
extern SCM scm_standard_eval_closure (SCM module);
extern SCM scm_standard_interface_eval_closure (SCM module);
extern SCM scm_get_pre_modules_obarray (void);
extern SCM scm_lookup_closure_module (SCM proc);
extern SCM scm_env_top_level (SCM env);
extern SCM scm_env_module (SCM env);
extern SCM scm_top_level_env (SCM thunk);
extern void scm_modules_prehistory (void); extern void scm_modules_prehistory (void);
extern void scm_init_modules (void); extern void scm_init_modules (void);
#if SCM_DEBUG_DEPRECATED == 0
extern SCM scm_the_root_module (void);
extern SCM scm_make_module (SCM name);
extern SCM scm_ensure_user_module (SCM name);
extern SCM scm_load_scheme_module (SCM name);
extern SCM scm_system_module_env_p (SCM env);
#endif
#endif /* MODULESH */ #endif /* MODULESH */
/* /*