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

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

diff --git a/libguile/objects.c b/libguile/objects.c
index 7c64ce6..158aa74 100644 (file)
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -48,6 +48,7 @@
 #include "_scm.h"
 
 #include "struct.h"
+#include "procprop.h"
 
 #include "objects.h"
 \f
@@ -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"
 }