Allow user defined dispatch functions in funcallable objects (Inspired from B. Spilsbury)

src/c/eval.d

@@ -88,8 +88,6 @@ cl_apply_from_stack(cl_index narg, cl_object x)
 				     fun->cclosure.env, cl_env.stack_top - narg);
 #ifdef CLOS
 	case t_instance:
-		if (!fun->instance.isgf)
-			goto ERROR;
 		fun = compute_method(narg, fun, cl_env.stack_top - narg);
 		if (fun == NULL)
 			return VALUES(0);
@@ -149,8 +147,6 @@ link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_va_lis
 		break;
 #ifdef CLOS
 	case t_instance: {
-		if (!fun->instance.isgf)
-			goto ERROR;
 		fun = compute_method(narg, fun, cl_env.stack + sp);
 		pLK = NULL;
 		if (fun == NULL) {
@@ -225,8 +221,6 @@ si_unlink_symbol(cl_object s)
 		break;
 #ifdef CLOS
 	case t_instance:
-		if (!fun->instance.isgf)
-			goto ERROR;
 		fun = compute_method(narg, fun, cl_env.stack + sp);
 		if (fun == NULL) {
 			out = VALUES(0);

src/c/gfun.d

@@ -12,23 +12,50 @@
     See file '../Copyright' for full details.
 */
 
+#include <string.h>
 #include <ecl/ecl.h>
 #include <ecl/internal.h>
 
-cl_object
-si_set_funcallable(cl_object instance, cl_object flag)
+static void
+reshape_instance(cl_object x, int delta)
 {
-	if (type_of(instance) != t_instance)
-		FEwrong_type_argument(@'ext::instance', instance);
-	instance->instance.isgf = !Null(flag);
-	@(return instance)
+	cl_fixnum size = x->instance.length + delta;
+	cl_object aux = ecl_allocate_instance(CLASS_OF(x), size);
+	memcpy(aux->instance.slots, x->instance.slots,
+	       (delta < 0 ? aux->instance.length : x->instance.length) *
+	       sizeof(cl_object));
+	x->instance = aux->instance;
 }
 
 cl_object
-si_generic_function_p(cl_object instance)
+clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
 {
-	@(return (((type_of(instance) != t_instance) &&
-		   (instance->instance.isgf))? Ct : Cnil))
+	if (type_of(x) != t_instance)
+		FEwrong_type_argument(@'ext::instance', x);
+	if (x->instance.isgf == ECL_USER_DISPATCH) {
+		reshape_instance(x, -1);
+		x->instance.isgf = ECL_NOT_FUNCALLABLE;
+	}
+	if (function_or_t == Ct)
+	{
+		x->instance.isgf = ECL_STANDARD_DISPATCH;
+	} else if (function_or_t == Cnil) {
+		x->instance.isgf = ECL_NOT_FUNCALLABLE;
+	} else if (Null(cl_functionp(function_or_t))) {
+		FEwrong_type_argument(@'function', function_or_t);
+	} else {
+		reshape_instance(x, +1);
+		x->instance.slots[x->instance.length - 1] = function_or_t;
+		x->instance.isgf = ECL_USER_DISPATCH;
+	}
+	@(return x)
+}
+
+cl_object
+si_generic_function_p(cl_object x)
+{
+	@(return (((type_of(x) != t_instance) &&
+		   (x->instance.isgf))? Ct : Cnil))
 }
 
 /*
@@ -92,22 +119,14 @@ set_meth_hash(cl_object *keys, int argno, cl_object hashtable, cl_object value)
 	e->value = value;
 }
 
-cl_object
-compute_method(cl_narg narg, cl_object gf, cl_object *args)
+static cl_object
+standard_dispatch(cl_narg narg, cl_object gf, cl_object *args)
 {
-	cl_object func;
 	int i, spec_no;
 	struct ecl_hashtable_entry *e;
 	cl_object spec_how_list = GFUN_SPEC(gf);
 	cl_object table = GFUN_HASH(gf);
-#ifdef __GNUC__
-	cl_object argtype[narg]; /* __GNUC__ */
-#else
-#define ARGTYPE_MAX 64
-	cl_object argtype[ARGTYPE_MAX];
-	if (narg > ARGTYPE_MAX)
-	  FEerror("compute_method: Too many arguments, limited to ~A.", 1, MAKE_FIXNUM(ARGTYPE_MAX));
-#endif
+	cl_object argtype[LAMBDA_PARAMETERS_LIMIT];
 
 	for (spec_no = 0; spec_how_list != Cnil;) {
 		cl_object spec_how = CAR(spec_how_list);
@@ -125,28 +144,42 @@ compute_method(cl_narg narg, cl_object gf, cl_object *args)
 
 	e = get_meth_hash(argtype, spec_no, table);
 
-	if (e->key == OBJNULL) {
+	if (e->key != OBJNULL) {
+		return e->value;
+	} else {
 		/* method not cached */
-		cl_object methods, arglist;
+		cl_object methods, arglist, func;
 		for (i = narg, arglist = Cnil; i-- > 0; ) {
 			arglist = CONS(args[i], arglist);
 		}
+		
 		methods = funcall(3, @'compute-applicable-methods', gf,
 				  arglist);
 		if (methods == Cnil) {
-			VALUES(0) = funcall(3, @'no-applicable-method', gf,
-					    arglist);
-			return NULL;
+			func = funcall(3, @'no-applicable-method', gf,
+				       arglist);
+			args[0] = 0;
+			return func;
 		}
 		func = funcall(4, @'clos::compute-effective-method', gf,
 			       GFUN_COMB(gf), methods);
 		/* update cache */
 		set_meth_hash(argtype, spec_no, table, func);
-	} else {
-		/* method is already cached */
-		func = e->value;
+		return func;
+	}
+}
+
+cl_object
+compute_method(cl_narg narg, cl_object gf, cl_object *args)
+{
+	switch (gf->instance.isgf) {
+	case ECL_STANDARD_DISPATCH:
+		return standard_dispatch(narg, gf, args);
+	case ECL_USER_DISPATCH:
+		return gf->instance.slots[gf->instance.length - 1];
+	default:
+		FEinvalid_function(gf);
 	}
-	return func;
 }
 
 cl_object

src/c/interpreter.d

@@ -393,8 +393,6 @@ interpret_funcall(cl_narg narg, cl_object fun) {
 	}
 #ifdef CLOS
 	case t_instance:
-		if (!fun->instance.isgf)
-			goto ERROR;
 		fun = compute_method(narg, fun, args);
 		if (fun == NULL) {
 			x = VALUES(0);

src/c/symbols_list.h

@@ -1212,7 +1212,6 @@ cl_symbols[] = {
 {SYS_ "INSTANCE-CLASS-SET", SI_ORDINARY, si_instance_class_set, 2, OBJNULL},
 {SYS_ "INSTANCEP", SI_ORDINARY, si_instancep, 1, OBJNULL},
 {SYS_ "SET-COMPILED-FUNCTION-NAME", SI_ORDINARY, si_set_compiled_function_name, 2, OBJNULL},
-{SYS_ "SET-FUNCALLABLE", SI_ORDINARY, si_set_funcallable, 2, OBJNULL},
 {SYS_ "SL-BOUNDP", SI_ORDINARY, si_sl_boundp, 1, OBJNULL},
 {SYS_ "SL-MAKUNBOUND", SI_ORDINARY, si_sl_makunbound, 2, OBJNULL},
 {SYS_ "SUBCLASSP", SI_ORDINARY, NULL, -1, OBJNULL},
@@ -1558,7 +1557,6 @@ cl_symbols[] = {
 {CLOS_ "FINALIZE-INHERITANCE", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "FIND-METHOD-COMBINATION", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "FORWARD-REFERENCED-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
-{CLOS_ "FUNCALLABLE-", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "FUNCALLABLE-STANDARD-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "FUNCALLABLE-STANDARD-INSTANCE-ACCESS", CLOS_ORDINARY, si_instance_ref, 2, OBJNULL},
 {CLOS_ "FUNCALLABLE-STANDARD-OBJECT", CLOS_ORDINARY, NULL, -1, OBJNULL},
@@ -1581,7 +1579,7 @@ cl_symbols[] = {
 {CLOS_ "REMOVE-DEPENDENT", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "REMOVE-DIRECT-METHOD", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "REMOVE-DIRECT-SUBCLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
-{CLOS_ "SET-FUNCALLABLE-INSTANCE-FUNCTION", CLOS_ORDINARY, NULL, -1, OBJNULL},
+{CLOS_ "SET-FUNCALLABLE-INSTANCE-FUNCTION", CLOS_ORDINARY, clos_set_funcallable_instance_function, 2, OBJNULL},
 {CLOS_ "SLOT-BOUNDP-USING-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "SLOT-DEFINITION", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "SLOT-DEFINITION-ALLOCATION", CLOS_ORDINARY, NULL, -1, OBJNULL},

src/c/symbols_list2.h

@@ -1212,7 +1212,6 @@ cl_symbols[] = {
 {SYS_ "INSTANCE-CLASS-SET","si_instance_class_set"},
 {SYS_ "INSTANCEP","si_instancep"},
 {SYS_ "SET-COMPILED-FUNCTION-NAME","si_set_compiled_function_name"},
-{SYS_ "SET-FUNCALLABLE","si_set_funcallable"},
 {SYS_ "SL-BOUNDP","si_sl_boundp"},
 {SYS_ "SL-MAKUNBOUND","si_sl_makunbound"},
 {SYS_ "SUBCLASSP",NULL},
@@ -1558,7 +1557,6 @@ cl_symbols[] = {
 {CLOS_ "FINALIZE-INHERITANCE",NULL},
 {CLOS_ "FIND-METHOD-COMBINATION",NULL},
 {CLOS_ "FORWARD-REFERENCED-CLASS",NULL},
-{CLOS_ "FUNCALLABLE-",NULL},
 {CLOS_ "FUNCALLABLE-STANDARD-CLASS",NULL},
 {CLOS_ "FUNCALLABLE-STANDARD-INSTANCE-ACCESS","si_instance_ref"},
 {CLOS_ "FUNCALLABLE-STANDARD-OBJECT",NULL},
@@ -1581,7 +1579,7 @@ cl_symbols[] = {
 {CLOS_ "REMOVE-DEPENDENT",NULL},
 {CLOS_ "REMOVE-DIRECT-METHOD",NULL},
 {CLOS_ "REMOVE-DIRECT-SUBCLASS",NULL},
-{CLOS_ "SET-FUNCALLABLE-INSTANCE-FUNCTION",NULL},
+{CLOS_ "SET-FUNCALLABLE-INSTANCE-FUNCTION","clos_set_funcallable_instance_function"},
 {CLOS_ "SLOT-BOUNDP-USING-CLASS",NULL},
 {CLOS_ "SLOT-DEFINITION",NULL},
 {CLOS_ "SLOT-DEFINITION-ALLOCATION",NULL},

src/clos/generic.lsp

@@ -221,9 +221,9 @@
   (remf args :delete-methods)
   (unless (classp method-class)
     (setf args (list* :method-class (find-class method-class) args)))
-  (si::set-funcallable (apply #'make-instance generic-function-class
-			      :name name args)
-		       t))
+  (set-funcallable-instance-function
+   (apply #'make-instance generic-function-class :name name args)
+   t))
 
 (defun ensure-generic-function (name &rest args &key &allow-other-keys)
   (let ((gfun nil)

src/clos/kernel.lsp

@@ -221,7 +221,7 @@
 	(when l-l-p
 	  (setf (generic-function-argument-precedence-order gfun)
 		(rest (si::process-lambda-list lambda-list t))))
-	(si::set-funcallable gfun t)
+	(set-funcallable-instance-function gfun t)
 	(setf (fdefinition name) gfun)
 	gfun)))
 
@@ -370,4 +370,4 @@
     (clrhash (generic-function-method-hash gf)))))
 
 (defun print-object (object stream)
-  (print-unreadable-object (object stream)))
+  (print-unreadable-object (object stream)))

src/h/external.h

@@ -608,7 +608,7 @@ extern void ecl_register_root(cl_object *p);
 /* gfun.c */
 
 #ifdef CLOS
-extern cl_object si_set_funcallable(cl_object instance, cl_object flag);
+extern cl_object clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t);
 extern cl_object si_generic_function_p(cl_object instance);
 extern cl_object si_set_compiled_function_name(cl_object keylist, cl_object table);
 

src/h/object.h

@@ -476,6 +476,9 @@ struct ecl_lock {
 #define CLASS_INFERIORS(x)	(x)->instance.slots[2]
 #define CLASS_SLOTS(x)		(x)->instance.slots[3]
 #define CLASS_CPL(x)		(x)->instance.slots[4]
+#define ECL_NOT_FUNCALLABLE	0
+#define ECL_STANDARD_DISPATCH	1
+#define ECL_USER_DISPATCH	2
 
 struct ecl_instance {		/*  instance header  */
 	HEADER1(isgf);