More deprecated stuff.

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 <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 ()
 {

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