From 49fb08f4434ab97562f5ced0982ddfea9e76c476 Mon Sep 17 00:00:00 2001 From: jgarcia Date: Sat, 20 May 2006 22:12:36 +0000 Subject: [PATCH] Allow user defined dispatch functions in funcallable objects (Inspired from B. Spilsbury) --- src/c/eval.d | 6 --- src/c/gfun.d | 91 +++++++++++++++++++++++++++++-------------- src/c/interpreter.d | 2 - src/c/symbols_list.h | 4 +- src/c/symbols_list2.h | 4 +- src/clos/generic.lsp | 6 +-- src/clos/kernel.lsp | 4 +- src/h/external.h | 2 +- src/h/object.h | 3 ++ 9 files changed, 73 insertions(+), 49 deletions(-) diff --git a/src/c/eval.d b/src/c/eval.d index 90a1fa1f4..533d16a76 100644 --- a/src/c/eval.d +++ b/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); diff --git a/src/c/gfun.d b/src/c/gfun.d index 31853287e..c2e120709 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -12,23 +12,50 @@ See file '../Copyright' for full details. */ +#include #include #include -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 diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 3760957a4..0289cac9b 100644 --- a/src/c/interpreter.d +++ b/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); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index a0caf1f83..4a84f5410 100644 --- a/src/c/symbols_list.h +++ b/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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index a2af4b6df..d35e4d3a2 100644 --- a/src/c/symbols_list2.h +++ b/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}, diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index b70759613..138ef3961 100644 --- a/src/clos/generic.lsp +++ b/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) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 792d6b4ca..bff1685b4 100644 --- a/src/clos/kernel.lsp +++ b/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))) \ No newline at end of file + (print-unreadable-object (object stream))) diff --git a/src/h/external.h b/src/h/external.h index d8b9a7abb..2ed009e84 100644 --- a/src/h/external.h +++ b/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); diff --git a/src/h/object.h b/src/h/object.h index 54b9eaffc..e4c0028c1 100644 --- a/src/h/object.h +++ b/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);