scm_wta_* procedures replace SCM_WTA_* macros

* libguile/__scm.h: Move all the SCM_WTA and SCM_GASSERT macros out of
  here.  Also remove the scm_call_generic declarations.
* libguile/deprecated.h (SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1):
  (SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_N): Deprecate.  See below for
  their replacements.
  (SCM_GASSERT0, SCM_GASSERT1, SCM_GASSERT2, SCM_GASSERTn): Deprecate
  these too.
  (SCM_WTA_DISPATCH_1_SUBR): Deprecate this strange thing.
  (scm_call_generic_0, scm_call_generic_1, scm_call_generic_2):
  (scm_call_generic_3, scm_apply_generic): Remove, indicating their
  replacements.

* libguile/print.c (iprin1):
* libguile/eq.c (scm_equal_p): Use scm_call_2 instead of
  scm_call_generic_2.

* libguile/goops.h:
* libguile/goops.c: Remove scm_{call,apply}_generic definitions.
  (scm_wta_dispatch_0, scm_wta_dispatch_1, scm_wta_dispatch_2):
  (scm_wta_dispatch_n): New procedures, replacing the SCM_WTA macros.

* libguile/numbers.c (scm_lcm):
* libguile/procs.c (scm_setter): Remove uses of SCM_GASSERT.

* libguile/numbers.c (scm_lcm):
* libguile/procs.c (scm_setter):
* libguile/vectors.c: Use the procedural scm_wta routines instead of the
  SCM_WTA macros.

libguile/__scm.h

@@ -398,67 +398,6 @@ typedef long SCM_STACKITEM;
 
 
 
-/*
- * SCM_WTA_DISPATCH
- */
-
-/* Dirk:FIXME:: In all of the SCM_WTA_DISPATCH_* macros it is assumed that
- * 'gf' is zero if uninitialized.  It would be cleaner if some valid SCM value
- * like SCM_BOOL_F or SCM_UNDEFINED was chosen.
- */
-
-SCM_API SCM scm_call_generic_0 (SCM gf);
-
-#define SCM_WTA_DISPATCH_0(gf, subr)			        \
-  return (SCM_UNPACK (gf)					\
-	  ? scm_call_generic_0 ((gf))				\
-	  : (scm_error_num_args_subr ((subr)), SCM_UNSPECIFIED))
-#define SCM_GASSERT0(cond, gf, subr)		\
-  if (SCM_UNLIKELY(!(cond)))		\
-    SCM_WTA_DISPATCH_0((gf), (subr))
-
-SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
-
-#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr)			\
-  return (SCM_UNPACK (gf)					\
-	  ? scm_call_generic_1 ((gf), (a1))			\
-	  : (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED))
-
-/* This form is for dispatching a subroutine.  */
-#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos)				\
-  return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr)))			\
-	  ? scm_call_generic_1 ((*SCM_SUBR_GENERIC (subr)), (a1))	\
-	  : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
-
-#define SCM_GASSERT1(cond, gf, a1, pos, subr)		\
-  if (SCM_UNLIKELY (!(cond)))			\
-    SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))
-
-SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
-
-#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr)			\
-  return (SCM_UNPACK (gf)						\
-	  ? scm_call_generic_2 ((gf), (a1), (a2))			\
-	  : (scm_wrong_type_arg ((subr), (pos),				\
-				 (pos) == SCM_ARG1 ? (a1) : (a2)),	\
-	     SCM_UNSPECIFIED))
-#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr)	\
-  if (SCM_UNLIKELY (!(cond)))			\
-    SCM_WTA_DISPATCH_2((gf), (a1), (a2), (pos), (subr))
-
-SCM_API SCM scm_apply_generic (SCM gf, SCM args);
-
-#define SCM_WTA_DISPATCH_n(gf, args, pos, subr)				  \
-  return (SCM_UNPACK (gf)						  \
-	  ? scm_apply_generic ((gf), (args))				  \
-	  : (scm_wrong_type_arg ((subr), (pos),				  \
-				 scm_list_ref ((args),			  \
-					       scm_from_int ((pos) - 1))), \
-	     SCM_UNSPECIFIED))
-#define SCM_GASSERTn(cond, gf, args, pos, subr)		\
-  if (SCM_UNLIKELY (!(cond)))			\
-    SCM_WTA_DISPATCH_n((gf), (args), (pos), (subr))
-
 #ifndef SCM_MAGIC_SNARFER
 /* Let these macros pass through if
    we are snarfing;  thus we can tell the

libguile/deprecated.h

@@ -42,6 +42,38 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
                                               void *guard_data);
 
 
+/* Deprecated 15-05-2011 because it's better to be explicit with the
+   `return'.  Code is more readable that way.  */
+#define SCM_WTA_DISPATCH_0(gf, subr)			        \
+  return scm_wta_dispatch_0 ((gf), (subr))
+#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr)			\
+  return scm_wta_dispatch_1 ((gf), (a1), (pos), (subr))
+#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr)          \
+  return scm_wta_dispatch_2 ((gf), (a1), (a2), (pos), (subr))
+#define SCM_WTA_DISPATCH_N(gf, args, pos, subr)			\
+  return scm_wta_dispatch_n ((gf), (args), (pos), (subr))
+
+/* Deprecated 15-05-2011 because this idiom is not very readable.  */
+#define SCM_GASSERT0(cond, gf, subr)            \
+  if (SCM_UNLIKELY (!(cond)))                   \
+    return scm_wta_dispatch_0 ((gf), (subr))
+#define SCM_GASSERT1(cond, gf, a1, pos, subr)           \
+  if (SCM_UNLIKELY (!(cond)))                           \
+    return scm_wta_dispatch_1 ((gf), (a1), (pos), (subr))
+#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr)	\
+  if (SCM_UNLIKELY (!(cond)))                           \
+    return scm_wta_dispatch_2 ((gf), (a1), (a2), (pos), (subr))
+#define SCM_GASSERTn(cond, gf, args, pos, subr)         \
+  if (SCM_UNLIKELY (!(cond)))                           \
+    return scm_wta_dispatch_n ((gf), (args), (pos), (subr))
+
+/* Deprecated 15-05-2011 because this is a one-off macro that does
+   strange things.  */
+#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos)				\
+  return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr)))			\
+	  ? scm_call_1 ((*SCM_SUBR_GENERIC (subr)), (a1))               \
+	  : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
+
 #define SCM_LIST0 SCM_EOL
 #define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
 #define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)
@@ -73,6 +105,11 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
 #define scm_array scm_array__GONE__REPLACE_WITH__scm_t_array
 #define scm_array_dim scm_array_dim__GONE__REPLACE_WITH__scm_t_array_dim
 #define scm_async_click scm_async_click__GONE__REPLACE_WITH__scm_async_tick
+#define scm_call_generic_0 scm_call_generic_0__GONE__REPLACE_WITH__scm_call_0
+#define scm_call_generic_1 scm_call_generic_1__GONE__REPLACE_WITH__scm_call_1
+#define scm_call_generic_2 scm_call_generic_2__GONE__REPLACE_WITH__scm_call_2
+#define scm_call_generic_3 scm_call_generic_3__GONE__REPLACE_WITH__scm_call_3
+#define scm_apply_generic scm_apply_generic__GONE__REPLACE_WITH__scm_apply_0
 #define scm_fport scm_fport__GONE__REPLACE_WITH__scm_t_fport
 #define scm_listify scm_listify__GONE__REPLACE_WITH__scm_list_n
 #define scm_option scm_option__GONE__REPLACE_WITH__scm_t_option

libguile/eq.c

@@ -365,7 +365,7 @@ scm_equal_p (SCM x, SCM y)
   
  generic_equal:
   if (SCM_UNPACK (g_scm_i_equal_p))
-    return scm_call_generic_2 (g_scm_i_equal_p, x, y);
+    return scm_call_2 (g_scm_i_equal_p, x, y);
   else
     return SCM_BOOL_F;
 }

libguile/goops.c

@@ -1667,36 +1667,6 @@ SCM_KEYWORD (k_name, "name");
 SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
 
 
-SCM
-scm_apply_generic (SCM gf, SCM args)
-{
-  return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL);
-}
-
-SCM
-scm_call_generic_0 (SCM gf)
-{
-  return scm_call_0 (SCM_STRUCT_PROCEDURE (gf));
-}
-
-SCM
-scm_call_generic_1 (SCM gf, SCM a1)
-{
-  return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1);
-}
-
-SCM
-scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
-{
-  return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2);
-}
-
-SCM
-scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
-{
-  return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
-}
-
 SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
 static SCM
 make_dispatch_procedure (SCM gf)
@@ -1840,6 +1810,47 @@ setup_extended_primitive_generics ()
     }
 }
 
+/* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
+ * assumed that 'gf' is zero if uninitialized.  It would be cleaner if
+ * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
+ */
+
+SCM
+scm_wta_dispatch_0 (SCM gf, const char *subr)
+{
+  if (!SCM_UNPACK (gf))
+    scm_error_num_args_subr (subr);
+
+  return scm_call_0 (gf);
+}
+
+SCM
+scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr)
+{
+  if (!SCM_UNPACK (gf))
+    scm_wrong_type_arg (subr, pos, a1);
+
+  return scm_call_1 (gf, a1);
+}
+
+SCM
+scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr)
+{
+  if (!SCM_UNPACK (gf))
+    scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
+
+  return scm_call_2 (gf, a1, a2);
+}
+
+SCM
+scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
+{
+  if (!SCM_UNPACK (gf))
+    scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos)));
+
+  return scm_apply_0 (gf, args);
+}
+
 /******************************************************************************
  *
  * Protocol for calling a generic fumction

libguile/goops.h

@@ -299,13 +299,14 @@ SCM_API SCM scm_make (SCM args);
 SCM_API SCM scm_find_method (SCM args);
 SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs);
 SCM_API void scm_change_object_class (SCM, SCM, SCM);
-/* The following are declared in __scm.h
+
-SCM_API SCM scm_call_generic_0 (SCM gf);
+/* These procedures are for dispatching to a generic when a primitive
-SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
+   fails to apply.  They raise a wrong-type-arg error if the primitive's
-SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
+   generic has not been initialized yet.  */
-SCM_API SCM scm_apply_generic (SCM gf, SCM args);
+SCM_API SCM scm_wta_dispatch_0 (SCM gf, const char *subr);
-*/
+SCM_API SCM scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr);
-SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
+SCM_API SCM scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr);
+SCM_API SCM scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr);
 
 SCM_INTERNAL SCM scm_i_define_class_for_vtable (SCM vtable);
 

libguile/print.c

@@ -529,7 +529,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 		  goto print_struct;
 		pwps = scm_i_port_with_print_state (port, pstate->handle);
 		pstate->revealed = 1;
-		scm_call_generic_2 (print, exp, pwps);
+		scm_call_2 (print, exp, pwps);
 	      }
 	    else
 	      {

libguile/procs.c

@@ -146,14 +146,15 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
                        "applicable struct with a setter.")
 #define FUNC_NAME s_scm_setter
 {
-  SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+  if (SCM_UNLIKELY (!SCM_STRUCTP (proc)))
+    return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
   if (SCM_STRUCT_SETTER_P (proc))
     return SCM_STRUCT_SETTER (proc);
   if (SCM_PUREGENERICP (proc)
       && SCM_IS_A_P (proc, scm_class_generic_with_setter))
     /* FIXME: might not be an accessor */
     return SCM_GENERIC_SETTER (proc);
-  SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+  return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
   return SCM_BOOL_F; /* not reached */
 }
 #undef FUNC_NAME

libguile/vectors.c

@@ -123,7 +123,7 @@ scm_vector_length (SCM v)
       return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
     }
   else
-    SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL);
+    return scm_wta_dispatch_1 (g_vector_length, v, 1, "vector-length");
 }
 
 size_t
@@ -241,7 +241,8 @@ scm_c_vector_ref (SCM v, size_t k)
       scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
     }
   else
-    SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
+    return scm_wta_dispatch_2 (g_vector_ref, v, scm_from_size_t (k), 2,
+                               "vector-ref");
 }
 
 SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
@@ -307,8 +308,10 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
   else
     {
       if (SCM_UNPACK (g_vector_set_x))
-	scm_apply_generic (g_vector_set_x,
+	scm_wta_dispatch_n (g_vector_set_x,
-			   scm_list_3 (v, scm_from_size_t (k), obj));
+                            scm_list_3 (v, scm_from_size_t (k), obj),
+                            0,
+                            "vector-set!");
       else
 	scm_wrong_type_arg_msg (NULL, 0, v, "vector");
     }