From ec6553ce88b3bc27fa0e5fc41a4b22bb7717eb58 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sat, 21 Apr 2012 09:12:45 +0200 Subject: [PATCH] COMPUTE-APPLICABLE-METHODS and CLOS:COMPUTE-EFFECTIVE-METHOD are now generic functions --- src/CHANGELOG | 3 +++ src/c/gfun.d | 4 ++-- src/c/symbols_list.h | 3 +++ src/c/symbols_list2.h | 3 +++ src/clos/combin.lsp | 2 +- src/clos/fixup.lsp | 41 +++++++++++++++++++++++++---------------- src/clos/kernel.lsp | 23 ++++++++++++++++++++++- 7 files changed, 59 insertions(+), 20 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 26cb63b3a..dc3286dd2 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -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 *** diff --git a/src/c/gfun.d b/src/c/gfun.d index 8b3c98adf..a33b95738 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -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); } } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index db3f1c261..a4088e4ac 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 77415fbe1..3db302db1 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -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}, diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index a7135707d..aa6f7b4f5 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -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) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 9ad294a34..96186338c 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -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 diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 705186bb8..9fd67cc8a 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -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))