#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 <stdio.h>
+#include <string.h>
+
#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 ()
{
* 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
-void scm_i_init_deprecated (void);
+typedef long long long_long;
+typedef unsigned long long ulong_long;
-#endif
-
-#endif /* SCM_DEPRECATED_H */
+#define scm_sizet size_t
-#if 0
-/* TODO */
+SCM_API SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
-long_long
-ulong_long
-scm_sizet
-SCM_WNA
-SCM_OUTOFRANGE
-SCM_NALLOC
+#define SCM_WNA 8
+#define SCM_OUTOFRANGE 10
+#define SCM_NALLOC 11
-SCM_HUP_SIGNAL
-SCM_INT_SIGNAL
-SCM_FPE_SIGNAL
- SCM_BUS_SIGNAL
+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);
-SCM_SEGV_SIGNAL
-SCM_ALRM_SIGNAL
-SCM_GC_SIGNAL
-SCM_TICK_SIGNAL
+void scm_i_init_deprecated (void);
-SCM_SIG_ORD
-SCM_ORD_SIG
-SCM_NUM_SIGS
+#endif
-scm_register_module_xxx
-scm_registered_modules
+#endif /* SCM_DEPRECATED_H */
-scm_clear_registered_modules
-scm_wta
+#if 0
+/* TODO */
scm_eval_3
scm_eval2
HCoop / bpt / guile.git / commitdiff