mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-16 06:12:25 -08:00
Code Issues Projects Releases Packages Wiki Activity

COMPUTE-APPLICABLE-METHODS and CLOS:COMPUTE-EFFECTIVE-METHOD are now generic functions

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-04-21 09:12:45 +02:00
parent efda16f3d2
commit ec6553ce88
7 changed files with 59 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/CHANGELOG
View file

@ -28,6 +28,9 @@ ECL 12.2.2:
- Implemented CLOS:COMPUTE-APPLICABLE-METHODS-USING-CLASSES.
- COMPUTE-APPLICABLE-METHODS and CLOS:COMPUTE-EFFECTIVE-METHOD are now
generic functions.
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:79 ***

4
src/c/gfun.d
View file

@ -146,13 +146,13 @@ compute_applicable_method(cl_object frame, cl_object gf)
p != frame->frame.base; ) {
arglist = CONS(*(--p), arglist);
}
methods = _ecl_funcall3(@'compute-applicable-methods', gf, 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::compute-effective-method', gf,
return _ecl_funcall4(@'clos::std-compute-effective-method', gf,
GFUN_COMB(gf), methods);
}
}

3
src/c/symbols_list.h
View file

@ -1729,6 +1729,9 @@ cl_symbols[] = {
{CLOS_ "STANDARD-READER-METHOD", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "STANDARD-SLOT-DEFINITION", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "STANDARD-WRITER-METHOD", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "STD-COMPUTE-APPLICABLE-METHODS", CLOS_ORDINARY, NULL, 2, OBJNULL},
{CLOS_ "STD-COMPUTE-APPLICABLE-METHODS-USING-CLASSES", CLOS_ORDINARY, NULL, 2, OBJNULL},
{CLOS_ "STD-COMPUTE-EFFECTIVE-METHOD", CLOS_ORDINARY, NULL, 3, OBJNULL},
{CLOS_ "UPDATE-DEPENDENT", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "VALIDATE-SUPERCLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "WRITER-METHOD-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},

3
src/c/symbols_list2.h
View file

@ -1729,6 +1729,9 @@ cl_symbols[] = {
{CLOS_ "STANDARD-READER-METHOD",NULL},
{CLOS_ "STANDARD-SLOT-DEFINITION",NULL},
{CLOS_ "STANDARD-WRITER-METHOD",NULL},
{CLOS_ "STD-COMPUTE-APPLICABLE-METHODS",NULL},
{CLOS_ "STD-COMPUTE-APPLICABLE-METHODS-USING-CLASSES",NULL},
{CLOS_ "STD-COMPUTE-EFFECTIVE-METHOD",NULL},
{CLOS_ "UPDATE-DEPENDENT",NULL},
{CLOS_ "VALIDATE-SUPERCLASS",NULL},
{CLOS_ "WRITER-METHOD-CLASS",NULL},

2
src/clos/combin.lsp
View file

@ -306,7 +306,7 @@
;;; COMPUTE-EFFECTIVE-METHOD
;;;
(defun compute-effective-method (gf method-combination applicable-methods)
(defun std-compute-effective-method (gf method-combination applicable-methods)
(let* ((method-combination-name (car method-combination))
(method-combination-args (cdr method-combination)))
(if (eq method-combination-name 'STANDARD)

41
src/clos/fixup.lsp
View file

@ -226,25 +226,34 @@ their lambda lists ~A and ~A are not congruent."
(map-dependents gf #'(lambda (dep) (update-dependents gf dep 'remove-method method)))
gf)
;;; COMPUTE-APPLICABLE-METHODS is used by the core in various places,
;;; including instance initialization. This means we cannot just redefine it.
;;; Instead, we create an auxiliary function and move definitions from one to
;;; the other.
#+(or)
(defgeneric aux-compute-applicable-methods (gf args)
(:method ((gf standard-generic-function) args)
(std-compute-applicable-methods gf args)))
(install-method
'aux-compute-applicable-methods
'nil
'(standard-generic-function t)
'(gf args)
'nil
'nil
#'(ext:lambda-block compute-applicable-methods (gf args)
(std-compute-applicable-methods gf args)))
(setf (fdefinition 'compute-applicable-methods) #'aux-compute-applicable-methods)
(defgeneric compute-applicable-methods-using-classes (gf classes)
(:method ((gf standard-generic-function) classes)
(sort-applicable-methods gf (applicable-method-list-with-classes gf classes)
classes)))
(std-compute-applicable-methods-using-classes gf classes)))
(defgeneric compute-effective-method (gf method-combination applicable-methods)
(:method ((gf standard-generic-function) method-combination applicable-methods)
(std-compute-effective-method gf method-combination applicable-methods)))
(defun applicable-method-list-with-classes (gf classes)
(declare (optimize (safety 0) (speed 3))
(si::c-local))
(flet ((applicable-method-p (method classes)
(loop for spec in (method-specializers method)
for class in classes
always (cond ((null spec))
((listp spec)
;; EQL specializer
(si::of-class-p (second spec) class))
((si::subclassp class spec))))))
(loop for method in (generic-function-methods gf)
when (applicable-method-p method classes)
collect method)))
;;; ----------------------------------------------------------------------
;;; Error messages

23
src/clos/kernel.lsp
View file

@ -285,10 +285,12 @@
;;; version does not check _any_ of the arguments but it is
;;; nevertheless exported by the ANSI specification!
;;;
(defun compute-applicable-methods (gf args)
(defun std-compute-applicable-methods (gf args)
(declare (optimize (safety 0) (speed 3)))
(sort-applicable-methods gf (applicable-method-list gf args) args))
(setf (fdefinition 'compute-applicable-methods) #'std-compute-applicable-methods)
(defun applicable-method-list (gf args)
(declare (optimize (safety 0) (speed 3))
(si::c-local))
@ -304,6 +306,25 @@
when (applicable-method-p method args)
collect method)))
(defun std-compute-applicable-methods-using-classes (gf args)
(declare (optimize (safety 0) (speed 3)))
(sort-applicable-methods gf (applicable-method-list gf args) args))
(defun applicable-method-list-with-classes (gf classes)
(declare (optimize (safety 0) (speed 3))
(si::c-local))
(flet ((applicable-method-p (method classes)
(loop for spec in (method-specializers method)
for class in classes
always (cond ((null spec))
((listp spec)
;; EQL specializer
(si::of-class-p (second spec) class))
((si::subclassp class spec))))))
(loop for method in (generic-function-methods gf)
when (applicable-method-p method classes)
collect method)))
(defun sort-applicable-methods (gf applicable-list args)
(declare (optimize (safety 0) (speed 3)))
(let ((f (generic-function-a-p-o-function gf))