* objects.c (scm_set_object_procedure_x): New procedure: Use this

to set the dispatch procedure of an operator or entity object.

libguile/objects.c

@@ -48,6 +48,7 @@
 #include "_scm.h"
 
 #include "struct.h"
+#include "procprop.h"
 
 #include "objects.h"
 
@@ -55,6 +56,155 @@
 SCM scm_metaclass_standard;
 SCM scm_metaclass_operator;
 
+SCM_PROC (s_set_object_procedure_x, "set-object-procedure!", 1, 0, 1, scm_set_object_procedure_x);
+
+SCM
+scm_set_object_procedure_x (SCM obj, SCM procs)
+{
+  SCM proc[4], *pp, p, setp, arity;
+  int i, a, r;
+  SCM_ASSERT (SCM_NIMP (obj) && SCM_STRUCTP (obj)
+	      && ((SCM_CLASS_FLAGS (obj) | SCM_CLASSF_OPERATOR)
+		  || SCM_I_ENTITYP (obj)),
+	      obj,
+	      SCM_ARG1,
+	      s_set_object_procedure_x);
+  for (i = 0; i < 4; ++i)
+    proc[i] = SCM_BOOL_F;
+  i = 0;
+  while (SCM_NIMP (procs))
+    {
+      if (i == 4)
+	scm_wrong_num_args (scm_makfrom0str (s_set_object_procedure_x));
+      p = SCM_CAR (procs);
+      setp = 0;
+      SCM_ASSERT (SCM_NIMP (p), p, SCM_ARG2 + i, s_set_object_procedure_x);
+      if (SCM_CLOSUREP (p))
+	{
+	  arity = scm_procedure_property (p, scm_sym_arity);
+	  a = SCM_INUM (SCM_CAR (arity));
+	  /* Closures have zero optional args */
+	  r = SCM_NFALSEP (SCM_CADDR (arity));
+	  if (a == 1 || (a <= 1 && r))
+	    {
+	      if (SCM_NFALSEP (proc[0]))
+		goto ambiguous;
+	      proc[0] = setp = p;
+	    }
+	  if (a == 2 || (a <= 2 && r))
+	    {
+	      if (SCM_NFALSEP (proc[1]))
+		goto ambiguous;
+	      proc[1] = setp = p;
+	    }
+	  if (a == 3 || (a <= 3 && r))
+	    {
+	      if (SCM_NFALSEP (proc[2]))
+		goto ambiguous;
+	      proc[2] = setp = p;
+	    }
+	  if (a <= 4 && r)
+	    {
+	      if (SCM_NFALSEP (proc[3]))
+		goto ambiguous;
+	      proc[3] = setp = p;
+	    }
+	}
+      else if (SCM_TYP7 (p) == scm_tc7_subr_1)
+	{
+	  if (SCM_NFALSEP (proc[0]))
+	    goto ambiguous;
+	  proc[0] = setp = p;
+	}
+      else if (SCM_TYP7 (p) == scm_tc7_subr_2)
+	{
+	  if (SCM_NFALSEP (proc[1]))
+	    goto ambiguous;
+	  proc[1] = setp = p;
+	}
+      else if (SCM_TYP7 (p) == scm_tc7_subr_3)
+	{
+	  if (SCM_NFALSEP (proc[2]))
+	    goto ambiguous;
+	  proc[2] = setp = p;
+	}
+      else if (SCM_TYP7 (p) == scm_tc7_lsubr_2)
+	{
+	  if (SCM_NFALSEP (proc[3]))
+	    {
+	    ambiguous:
+	      SCM_ASSERT (0, p, "Ambiguous procedure arities",
+			  s_set_object_procedure_x);
+	    }
+	  proc[3] = setp = p;
+	}
+      SCM_ASSERT (setp, p, SCM_ARG2 + i, s_set_object_procedure_x);
+      ++i;
+      procs = SCM_CDR (procs);
+    }
+  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;
+}
+
+static SCM
+make_class_object (SCM meta,
+		   SCM pl,
+		   SCM layout,
+		   unsigned long flags,
+		   char* subr)
+{
+  SCM c;
+  SCM_ASSERT (SCM_NIMP (meta) && SCM_STRUCTP (meta), meta, SCM_ARG1, subr);
+  SCM_ASSERT (SCM_NIMP (layout) && SCM_STRINGP (layout),
+	      layout,
+	      SCM_ARG2,
+	      subr);
+  layout = scm_make_struct_layout (scm_string_append (SCM_LIST2 (pl, layout)));
+  c = scm_make_struct (meta,
+		       SCM_INUM0,
+		       SCM_LIST4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
+  SCM_SET_CLASS_FLAGS (c, flags);
+  return c;
+}
+
+SCM_PROC (s_make_class_object, "make-class-object", 2, 0, 0, scm_make_class_object);
+
+SCM
+scm_make_class_object (SCM metaclass, SCM layout)
+{
+  unsigned long flags = 0;
+  if (metaclass == scm_metaclass_operator)
+    flags = SCM_CLASSF_OPERATOR;
+  return make_class_object (metaclass,
+			    scm_nullstr,
+			    layout,
+			    flags,
+			    s_make_class_object);
+}
+
+SCM_PROC (s_make_subclass_object, "make-subclass-object", 2, 0, 0, scm_make_subclass_object);
+
+SCM
+scm_make_subclass_object (SCM class, SCM layout)
+{
+  SCM pl;
+  SCM_ASSERT (SCM_NIMP (class) && SCM_STRUCTP (class),
+	      class,
+	      SCM_ARG1,
+	      s_make_subclass_object);
+  pl = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
+  pl = scm_makfromstr (SCM_CHARS (pl), (scm_sizet) SCM_LENGTH (pl), 0);
+  return make_class_object (scm_metaclass_standard,
+			    pl,
+			    layout,
+			    SCM_CLASS_FLAGS (class),
+			    s_make_subclass_object);
+}
+
 void
 scm_init_objects ()
 {
@@ -79,4 +229,6 @@ scm_init_objects ()
   scm_metaclass_operator = ot;
   SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
   scm_sysintern ("<entity-class>", et);
+
+#include "objects.x"
 }