mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-20 11:32:35 -08:00
ECL's discriminating function protocol now relies on COMPUTE-APPLICABLE-METHODS-USING-CLASSES
This commit is contained in:
Juan Jose Garcia Ripoll
parent
deb1c7a086
commit
5e9b643f57
6 changed files with 121 additions and 48 deletions
|
|
@ -66,6 +66,11 @@ ECL 12.2.2:
|
|||
|
||||
- Implemented COMPUTE-DISCRIMINATING-FUNCTION.
|
||||
|
||||
- ECL's discriminating functions use COMPUTE-APPLICABLE-METHODS-USING-CLASSES
|
||||
on those classes in which the user may redefine or extend the
|
||||
method. Elsewhere, ECL relies on the internal equivalent of
|
||||
COMPUTE-APPLICABLE-METHODS, which _always_ memoizes results.
|
||||
|
||||
;;; Local Variables: ***
|
||||
;;; mode:text ***
|
||||
;;; fill-column:79 ***
|
||||
|
|
|
|||
|
|
@ -58,6 +58,7 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
|
|||
case t_instance:
|
||||
switch (fun->instance.isgf) {
|
||||
case ECL_STANDARD_DISPATCH:
|
||||
case ECL_RESTRICTED_DISPATCH:
|
||||
return _ecl_standard_dispatch(frame, fun);
|
||||
case ECL_USER_DISPATCH:
|
||||
fun = fun->instance.slots[fun->instance.length - 1];
|
||||
|
|
|
|||
96
src/c/gfun.d
96
src/c/gfun.d
|
|
@ -81,6 +81,9 @@ clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
|
|||
if (function_or_t == Ct) {
|
||||
x->instance.isgf = ECL_STANDARD_DISPATCH;
|
||||
x->instance.entry = generic_function_dispatch_vararg;
|
||||
} else if (function_or_t == @'standard-generic-function') {
|
||||
x->instance.isgf = ECL_RESTRICTED_DISPATCH;
|
||||
x->instance.entry = generic_function_dispatch_vararg;
|
||||
} else if (function_or_t == Cnil) {
|
||||
x->instance.isgf = ECL_NOT_FUNCALLABLE;
|
||||
x->instance.entry = FEnot_funcallable_vararg;
|
||||
|
|
@ -137,24 +140,77 @@ fill_spec_vector(cl_object vector, cl_object frame, cl_object gf)
|
|||
}
|
||||
|
||||
static cl_object
|
||||
compute_applicable_method(cl_object frame, cl_object gf)
|
||||
frame_to_list(cl_object frame)
|
||||
{
|
||||
/* method not cached */
|
||||
cl_object methods, arglist, func;
|
||||
cl_object *p;
|
||||
cl_object arglist, *p;
|
||||
for (p = frame->frame.base + frame->frame.size, arglist = Cnil;
|
||||
p != frame->frame.base; ) {
|
||||
arglist = CONS(*(--p), arglist);
|
||||
}
|
||||
methods = _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist);
|
||||
if (methods == Cnil) {
|
||||
func = _ecl_funcall3(@'no-applicable-method', gf, arglist);
|
||||
frame->frame.base[0] = OBJNULL;
|
||||
return func;
|
||||
} else {
|
||||
return _ecl_funcall4(@'clos::std-compute-effective-method', gf,
|
||||
GFUN_COMB(gf), methods);
|
||||
return arglist;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
frame_to_classes(cl_object frame)
|
||||
{
|
||||
cl_object arglist, *p;
|
||||
for (p = frame->frame.base + frame->frame.size, arglist = Cnil;
|
||||
p != frame->frame.base; ) {
|
||||
arglist = CONS(cl_class_of(*(--p)), arglist);
|
||||
}
|
||||
return arglist;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
generic_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf)
|
||||
{
|
||||
/* method not cached */
|
||||
cl_object memoize;
|
||||
cl_object methods = _ecl_funcall3(@'clos::compute-applicable-methods-using-classes',
|
||||
gf, frame_to_classes(frame));
|
||||
if (Null(memoize = env->values[1])) {
|
||||
cl_object arglist = frame_to_list(frame);
|
||||
methods = _ecl_funcall3(@'compute-applicable-methods',
|
||||
gf, arglist);
|
||||
if (methods == Cnil) {
|
||||
cl_object func = _ecl_funcall3(@'no-applicable-method',
|
||||
gf, arglist);
|
||||
frame->frame.base[0] = OBJNULL;
|
||||
env->values[1] = Cnil;
|
||||
return func;
|
||||
}
|
||||
}
|
||||
methods = _ecl_funcall4(@'clos::std-compute-effective-method', gf,
|
||||
GFUN_COMB(gf), methods);
|
||||
env->values[1] = Ct;
|
||||
return methods;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
restricted_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf)
|
||||
{
|
||||
/* method not cached */
|
||||
cl_object arglist = frame_to_list(frame);
|
||||
cl_object methods = _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist);
|
||||
if (methods == Cnil) {
|
||||
cl_object func = _ecl_funcall3(@'no-applicable-method', gf, arglist);
|
||||
frame->frame.base[0] = OBJNULL;
|
||||
env->values[1] = Cnil;
|
||||
return func;
|
||||
}
|
||||
methods = _ecl_funcall4(@'clos::std-compute-effective-method', gf,
|
||||
GFUN_COMB(gf), methods);
|
||||
env->values[1] = Ct;
|
||||
return methods;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf)
|
||||
{
|
||||
if (gf->instance.isgf == ECL_RESTRICTED_DISPATCH)
|
||||
return restricted_compute_applicable_method(env, frame, gf);
|
||||
else
|
||||
return generic_compute_applicable_method(env, frame, gf);
|
||||
}
|
||||
|
||||
cl_object
|
||||
|
|
@ -179,7 +235,7 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
|
|||
|
||||
vector = fill_spec_vector(cache->keys, frame, gf);
|
||||
if (vector == OBJNULL) {
|
||||
func = compute_applicable_method(frame, gf);
|
||||
func = compute_applicable_method(env, frame, gf);
|
||||
} else {
|
||||
ecl_cache_record_ptr e = ecl_search_cache(cache);
|
||||
if (e->key != OBJNULL) {
|
||||
|
|
@ -189,13 +245,15 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
|
|||
* compute the applicable methods. We must save
|
||||
* the keys and recompute the cache location if
|
||||
* it was filled. */
|
||||
cl_object keys = cl_copy_seq(vector);
|
||||
func = compute_applicable_method(frame, gf);
|
||||
if (e->key != OBJNULL) {
|
||||
e = ecl_search_cache(cache);
|
||||
func = compute_applicable_method(env, frame, gf);
|
||||
if (env->values[1] != Cnil) {
|
||||
cl_object keys = cl_copy_seq(vector);
|
||||
if (e->key != OBJNULL) {
|
||||
e = ecl_search_cache(cache);
|
||||
}
|
||||
e->key = keys;
|
||||
e->value = func;
|
||||
}
|
||||
e->key = keys;
|
||||
e->value = func;
|
||||
}
|
||||
}
|
||||
func = _ecl_funcall3(func, frame, Cnil);
|
||||
|
|
|
|||
|
|
@ -504,6 +504,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
|
|||
case t_instance:
|
||||
switch (reg0->instance.isgf) {
|
||||
case ECL_STANDARD_DISPATCH:
|
||||
case ECL_RESTRICTED_DISPATCH:
|
||||
reg0 = _ecl_standard_dispatch(frame, reg0);
|
||||
break;
|
||||
case ECL_USER_DISPATCH:
|
||||
|
|
|
|||
|
|
@ -226,8 +226,6 @@
|
|||
((typep x 'specializer) x)
|
||||
((find-class x nil))
|
||||
(t
|
||||
(print name)
|
||||
(print specializers)
|
||||
(error "In method definition for ~A, found an invalid specializer ~A" name specializers))))
|
||||
specializers))
|
||||
(method (make-method (generic-function-method-class gf)
|
||||
|
|
@ -268,6 +266,14 @@
|
|||
(setf (fdefinition name) gfun)
|
||||
gfun)))
|
||||
|
||||
(defun default-dispatch (generic-function)
|
||||
(cond ((null *clos-booted*)
|
||||
'standard-generic-function)
|
||||
((eq (class-id (class-of generic-function))
|
||||
'standard-generic-function)
|
||||
'standard-generic-function)
|
||||
(t)))
|
||||
|
||||
(defun compute-discriminating-function (generic-function)
|
||||
(values #'(lambda (&rest args)
|
||||
(multiple-value-bind (method-list ok)
|
||||
|
|
@ -288,30 +294,31 @@
|
|||
t))
|
||||
|
||||
(defun set-generic-function-dispatch (gfun)
|
||||
(let ((gf-type
|
||||
(loop named gf-type
|
||||
with common-class = nil
|
||||
for method in (generic-function-methods gfun)
|
||||
for class = (si::instance-class method)
|
||||
for specializers = (method-specializers method)
|
||||
do (cond ((null common-class)
|
||||
(setf common-class class))
|
||||
((not (eq common-class class))
|
||||
(return-from gf-type t)))
|
||||
do (loop for spec in specializers
|
||||
unless (or (eq spec +the-t-class+)
|
||||
(and (si::instancep spec)
|
||||
(eq (si::instance-class spec)
|
||||
+the-standard-class+)))
|
||||
do (return-from gf-type t))
|
||||
finally (cond ((null class)
|
||||
(return-from gf-type t))
|
||||
((eq class (find-class 'standard-reader-method nil))
|
||||
(return-from gf-type 'standard-reader-method))
|
||||
((eq class (find-class 'standard-writer-method nil))
|
||||
(return-from gf-type 'standard-writer-method))
|
||||
(t
|
||||
(return-from gf-type t))))))
|
||||
(let* ((base (default-dispatch gfun))
|
||||
(gf-type
|
||||
(loop named gf-type
|
||||
with common-class = nil
|
||||
for method in (generic-function-methods gfun)
|
||||
for class = (si::instance-class method)
|
||||
for specializers = (method-specializers method)
|
||||
do (cond ((null common-class)
|
||||
(setf common-class class))
|
||||
((not (eq common-class class))
|
||||
(return-from gf-type base)))
|
||||
do (loop for spec in specializers
|
||||
unless (or (eq spec +the-t-class+)
|
||||
(and (si::instancep spec)
|
||||
(eq (si::instance-class spec)
|
||||
+the-standard-class+)))
|
||||
do (return-from gf-type base))
|
||||
finally (cond ((null class)
|
||||
(return-from gf-type base))
|
||||
((eq class (find-class 'standard-reader-method nil))
|
||||
(return-from gf-type 'standard-reader-method))
|
||||
((eq class (find-class 'standard-writer-method nil))
|
||||
(return-from gf-type 'standard-writer-method))
|
||||
(t
|
||||
(return-from gf-type base))))))
|
||||
(when (and *clos-booted* (eq gf-type t))
|
||||
(multiple-value-bind (function optimize)
|
||||
(compute-discriminating-function gfun)
|
||||
|
|
|
|||
|
|
@ -977,9 +977,10 @@ struct ecl_condition_variable {
|
|||
#define ECL_INSTANCEP(x) ((IMMEDIATE(x)==0) && ((x)->d.t==t_instance))
|
||||
#define ECL_NOT_FUNCALLABLE 0
|
||||
#define ECL_STANDARD_DISPATCH 1
|
||||
#define ECL_READER_DISPATCH 2
|
||||
#define ECL_WRITER_DISPATCH 3
|
||||
#define ECL_USER_DISPATCH 4
|
||||
#define ECL_RESTRICTED_DISPATCH 2
|
||||
#define ECL_READER_DISPATCH 3
|
||||
#define ECL_WRITER_DISPATCH 4
|
||||
#define ECL_USER_DISPATCH 5
|
||||
|
||||
struct ecl_instance { /* instance header */
|
||||
HEADER1(isgf);
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue