* objects.h, objects.c (scm_apply_generic_env): Added (used by

apply).
(scm_operator_p): Added.
(scm_sym_atdispatch): Added.
(scm_set_object_procedure_x): Modified to handle the new style
generic functions.
(scm_object_procedures): New debugging procedure.

libguile/objects.c

@@ -70,6 +70,8 @@ SCM scm_class_unknown;
 SCM *scm_port_class = 0;
 SCM *scm_smob_class = 0;
 
+SCM scm_apply_generic_env;
+
 SCM (*scm_make_extended_class) (char *type_name);
 void (*scm_make_port_classes) (int ptobnum, char *type_name);
 void (*scm_change_object_class) (SCM, SCM, SCM);
@@ -215,22 +217,39 @@ scm_entity_p (SCM obj)
 	  : SCM_BOOL_F);
 }
 
+SCM_PROC (s_operator_p, "operator?", 1, 0, 0, scm_operator_p);
+
+SCM
+scm_operator_p (SCM obj)
+{
+  return (SCM_NIMP (obj)
+	  && SCM_STRUCTP (obj)
+	  && SCM_I_OPERATORP (obj)
+	  && !SCM_I_ENTITYP (obj)
+	  ? SCM_BOOL_T
+	  : SCM_BOOL_F);
+}
+
 SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 1, 0, 1, scm_set_object_procedure_x);
 
+SCM_SYMBOL (scm_sym_atdispatch, "@dispatch");
+
 SCM
 scm_set_object_procedure_x (SCM obj, SCM procs)
 {
   SCM proc[4], *pp, p, setp, arity;
-  int i, a, r;
+  int i, a, r, c = 0;
   SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
-	      && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
+	      && (SCM_I_ENTITYP (obj)
-		  || SCM_I_ENTITYP (obj)),
+		  || (SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)),
 	      obj,
 	      SCM_ARG1,
 	      s_set_object_procedure_x);
   for (i = 0; i < 4; ++i)
     proc[i] = SCM_BOOL_F;
   i = 0;
+  if (SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
+    c = 1;
   while (SCM_NIMP (procs))
     {
       if (i == 4)
@@ -238,6 +257,23 @@ scm_set_object_procedure_x (SCM obj, SCM procs)
       p = SCM_CAR (procs);
       setp = 0;
       SCM_ASSERT (SCM_NIMP (p), p, SCM_ARG2 + i, s_set_object_procedure_x);
+      if (c != 0)
+	{
+	  if ((SCM_CAR (p) == scm_sym_atdispatch
+	       || SCM_CAR (p) == SCM_IM_DISPATCH)
+	      && c < 4)
+	    {
+	      proc[c++] = setp = p;
+	      goto next;
+	    }
+	  else
+	    SCM_ASSERT (SCM_TYP7 (p) == scm_tc7_subr_1
+			|| (SCM_CLOSUREP (p)
+			    && (SCM_INUM (SCM_CAR (scm_procedure_property
+						   (p, scm_sym_arity)))
+				== 1)),
+			p, SCM_ARG2 + i, s_set_object_procedure_x);
+	}
       if (SCM_CLOSUREP (p))
 	{
 	  arity = scm_procedure_property (p, scm_sym_arity);
@@ -298,17 +334,45 @@ scm_set_object_procedure_x (SCM obj, SCM procs)
 	  proc[3] = setp = p;
 	}
       SCM_ASSERT (setp, p, SCM_ARG2 + i, s_set_object_procedure_x);
+    next:
       ++i;
       procs = SCM_CDR (procs);
     }
+  /* Fill the rest of the method cache slots
+     if a cache has been supplied earlier. */
+  if (c != 0)
+    for (; c < 4; ++c)
+      proc[c] = proc[c - 1];
+  
   pp = (SCM_I_ENTITYP (obj)
 	? &SCM_ENTITY_PROC_0 (obj)
 	: &SCM_OPERATOR_CLASS (obj)->proc0);
   for (i = 0; i < 4; ++i)
     *pp++ = proc[i];
+  
   return SCM_UNSPECIFIED;
 }
 
+#ifdef GUILE_DEBUG
+SCM_PROC (s_object_procedures, "object-procedures", 1, 0, 0, scm_object_procedures);
+
+SCM
+scm_object_procedures (SCM obj)
+{
+  SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj) && SCM_I_OPERATORP (obj),
+	      obj, SCM_ARG1, s_object_procedures);
+  return (SCM_I_ENTITYP (obj)
+	  ? SCM_LIST4 (SCM_ENTITY_PROC_0 (obj),
+		       SCM_ENTITY_PROC_1 (obj),
+		       SCM_ENTITY_PROC_2 (obj),
+		       SCM_ENTITY_PROC_3 (obj))
+	  : SCM_LIST4 (SCM_OPERATOR_PROC_0 (obj),
+		       SCM_OPERATOR_PROC_1 (obj),
+		       SCM_OPERATOR_PROC_2 (obj),
+		       SCM_OPERATOR_PROC_3 (obj)));
+}
+#endif /* GUILE_DEBUG */
+
 /* The following procedures are not a part of Goops but a minimal
  * object system built upon structs.  They are here for those who
  * want to implement their own object system.

libguile/objects.h

@@ -175,12 +175,13 @@ struct scm_metaclass_operator {
  */
 
 /* Internal representation of Goops objects. */
-#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
+#define SCM_CLASSF_PURE_GENERIC (0x010 << 20)
-#define SCM_CLASSF_GOOPS       (0x100 << 20)
+#define SCM_CLASSF_GOOPS_VALID  (0x080 << 20)
-#define scm_si_redefined        9
+#define SCM_CLASSF_GOOPS        (0x100 << 20)
-#define scm_si_hashsets        10
+#define scm_si_redefined         9
-#define SCM_CLASS_OF(x)        SCM_STRUCT_VTABLE (x)
+#define scm_si_hashsets         10
-#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
+#define SCM_CLASS_OF(x)         SCM_STRUCT_VTABLE (x)
+#define SCM_OBJ_CLASS_REDEF(x)  (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
 
 typedef struct scm_effective_slot_definition {
   SCM name;
@@ -209,15 +210,23 @@ extern SCM scm_class_unknown;
 extern SCM *scm_port_class;
 extern SCM *scm_smob_class;
 
+extern SCM scm_apply_generic_env;
+
 /* Plugin Goops functions. */
 extern SCM (*scm_make_extended_class) (char *type_name);
 extern void (*scm_make_port_classes) (int ptobnum, char *type_name);
 extern void (*scm_change_object_class) (SCM, SCM, SCM);
 extern void (*scm_memoize_method) (SCM x, SCM args);
 
+extern SCM scm_sym_atdispatch;
+
 extern SCM scm_class_of (SCM obj);
 extern SCM scm_entity_p (SCM obj);
+extern SCM scm_operator_p (SCM obj);
 extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
+#ifdef GUILE_DEBUG
+extern SCM scm_object_procedures (SCM obj);
+#endif
 extern SCM scm_make_class_object (SCM metaclass, SCM layout);
 extern SCM scm_make_subclass_object (SCM c, SCM layout);