diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 9707342be..07dfe5c04 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -45,17 +45,163 @@ #include "libguile/_scm.h" #include "libguile/deprecated.h" +#include "libguile/deprecation.h" #include "libguile/snarf.h" #include "libguile/validate.h" #include "libguile/strings.h" #include "libguile/strop.h" +#include +#include + #if (SCM_ENABLE_DEPRECATED == 1) SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); +SCM +scm_wta (SCM arg, const char *pos, const char *s_subr) +{ + if (!s_subr || !*s_subr) + s_subr = NULL; + if ((~0x1fL) & (long) pos) + { + /* error string supplied. */ + scm_misc_error (s_subr, pos, scm_list_1 (arg)); + } + else + { + /* numerical error code. */ + scm_t_bits error = (scm_t_bits) pos; + + switch (error) + { + case SCM_ARGn: + scm_wrong_type_arg (s_subr, 0, arg); + case SCM_ARG1: + scm_wrong_type_arg (s_subr, 1, arg); + case SCM_ARG2: + scm_wrong_type_arg (s_subr, 2, arg); + case SCM_ARG3: + scm_wrong_type_arg (s_subr, 3, arg); + case SCM_ARG4: + scm_wrong_type_arg (s_subr, 4, arg); + case SCM_ARG5: + scm_wrong_type_arg (s_subr, 5, arg); + case SCM_ARG6: + scm_wrong_type_arg (s_subr, 6, arg); + case SCM_ARG7: + scm_wrong_type_arg (s_subr, 7, arg); + case SCM_WNA: + scm_wrong_num_args (arg); + case SCM_OUTOFRANGE: + scm_out_of_range (s_subr, arg); + case SCM_NALLOC: + scm_memory_error (s_subr); + default: + /* this shouldn't happen. */ + scm_misc_error (s_subr, "Unknown error", SCM_EOL); + } + } + return SCM_UNSPECIFIED; +} + +/* Module registry + */ + +/* We can't use SCM objects here. One should be able to call + SCM_REGISTER_MODULE from a C++ constructor for a static + object. This happens before main and thus before libguile is + initialized. */ + +struct moddata { + struct moddata *link; + char *module_name; + void *init_func; +}; + +static struct moddata *registered_mods = NULL; + +void +scm_register_module_xxx (char *module_name, void *init_func) +{ + struct moddata *md; + + scm_c_issue_deprecation_warning + ("`scm_register_module_xxx' is deprecated. Use extensions instead."); + + /* XXX - should we (and can we) DEFER_INTS here? */ + + for (md = registered_mods; md; md = md->link) + if (!strcmp (md->module_name, module_name)) + { + md->init_func = init_func; + return; + } + + md = (struct moddata *) malloc (sizeof (struct moddata)); + if (md == NULL) + { + fprintf (stderr, + "guile: can't register module (%s): not enough memory", + module_name); + return; + } + + md->module_name = module_name; + md->init_func = init_func; + md->link = registered_mods; + registered_mods = md; +} + +SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0, + (), + "Return a list of the object code modules that have been imported into\n" + "the current Guile process. Each element of the list is a pair whose\n" + "car is the name of the module, and whose cdr is the function handle\n" + "for that module's initializer function. The name is the string that\n" + "has been passed to scm_register_module_xxx.") +#define FUNC_NAME s_scm_registered_modules +{ + SCM res; + struct moddata *md; + + res = SCM_EOL; + for (md = registered_mods; md; md = md->link) + res = scm_cons (scm_cons (scm_makfrom0str (md->module_name), + scm_ulong2num ((unsigned long) md->init_func)), + res); + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, + (), + "Destroy the list of modules registered with the current Guile process.\n" + "The return value is unspecified. @strong{Warning:} this function does\n" + "not actually unlink or deallocate these modules, but only destroys the\n" + "records of which modules have been loaded. It should therefore be used\n" + "only by module bookkeeping operations.") +#define FUNC_NAME s_scm_clear_registered_modules +{ + struct moddata *md1, *md2; + + SCM_DEFER_INTS; + + for (md1 = registered_mods; md1; md1 = md2) + { + md2 = md1->link; + free (md1); + } + registered_mods = NULL; + + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index dc94f0a1e..e44560d12 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -47,14 +47,28 @@ * If you do not wish that, delete this exception notice. */ #include "libguile/__scm.h" +#include "libguile/strings.h" #if (SCM_ENABLE_DEPRECATED == 1) -#include "libguile/strings.h" - #define scm_substring_move_left_x scm_substring_move_x #define scm_substring_move_right_x scm_substring_move_x +typedef long long long_long; +typedef unsigned long long ulong_long; + +#define scm_sizet size_t + +SCM_API SCM scm_wta (SCM arg, const char *pos, const char *s_subr); + +#define SCM_WNA 8 +#define SCM_OUTOFRANGE 10 +#define SCM_NALLOC 11 + +SCM_API void scm_register_module_xxx (char *module_name, void *init_func); +SCM_API SCM scm_registered_modules (void); +SCM_API SCM scm_clear_registered_modules (void); + void scm_i_init_deprecated (void); #endif @@ -64,33 +78,6 @@ void scm_i_init_deprecated (void); #if 0 /* TODO */ -long_long -ulong_long -scm_sizet -SCM_WNA -SCM_OUTOFRANGE -SCM_NALLOC - -SCM_HUP_SIGNAL -SCM_INT_SIGNAL -SCM_FPE_SIGNAL - SCM_BUS_SIGNAL - -SCM_SEGV_SIGNAL -SCM_ALRM_SIGNAL -SCM_GC_SIGNAL -SCM_TICK_SIGNAL - -SCM_SIG_ORD -SCM_ORD_SIG -SCM_NUM_SIGS - -scm_register_module_xxx -scm_registered_modules - -scm_clear_registered_modules -scm_wta - scm_eval_3 scm_eval2