diff --git a/pcl/combin.lisp b/pcl/combin.lisp index f432d682a4cb94e1735e5d924edc5cb6eaec7ba6..e8ffe66fb602277daf11a762ebe967acba5812bc 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.9 1999/05/30 23:13:54 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.10 2001/04/25 21:44:51 pmai Exp $") ;;; (in-package :pcl) @@ -311,38 +311,56 @@ (primary ()) (after ()) (around ())) - (dolist (m applicable-methods) - (let ((qualifiers (if (listp m) - (early-method-qualifiers m) - (method-qualifiers m)))) - (cond ((member ':before qualifiers) (push m before)) - ((member ':after qualifiers) (push m after)) - ((member ':around qualifiers) (push m around)) - (t - (push m primary))))) + (flet ((lose (method why) + (invalid-method-error + method + "The method ~S ~A.~%~ + Standard method combination requires all methods to have one~%~ + of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~ + have no qualifier at all." + method why))) + (dolist (m applicable-methods) + (let ((qualifiers (if (listp m) + (early-method-qualifiers m) + (method-qualifiers m)))) + (cond + ((null qualifiers) (push m primary)) + ((cdr qualifiers) + (lose m "has more than one qualifier")) + ((eq (car qualifiers) :around) + (push m around)) + ((eq (car qualifiers) :before) + (push m before)) + ((eq (car qualifiers) :after) + (push m after)) + (t + (lose m "has an illegal qualifier")))))) (setq before (reverse before) after (reverse after) primary (reverse primary) around (reverse around)) (cond ((null primary) - `(error "No primary method for the generic function ~S." ',generic-function)) + `(error "No primary method for the generic function ~S." + ',generic-function)) ((and (null before) (null after) (null around)) ;; - ;; By returning a single call-method `form' here we enable an important - ;; implementation-specific optimization. + ;; By returning a single call-method `form' here we enable an + ;; important implementation-specific optimization. ;; `(call-method ,(first primary) ,(rest primary))) (t (let ((main-effective-method (if (or before after) `(multiple-value-prog1 - (progn ,(make-call-methods before) - (call-method ,(first primary) ,(rest primary))) + (progn + ,(make-call-methods before) + (call-method ,(first primary) ,(rest primary))) ,(make-call-methods (reverse after))) `(call-method ,(first primary) ,(rest primary))))) (if around `(call-method ,(first around) - (,@(rest around) (make-method ,main-effective-method))) + (,@(rest around) + (make-method ,main-effective-method))) main-effective-method)))))) ;;; @@ -378,6 +396,8 @@ DEFINE-METHOD-COMBINATION or a method on the generic~%~ function COMPUTE-EFFECTIVE-METHOD)."))) +;This definition appears in defcombin.lisp. +; ;(defmethod compute-effective-method :around ;issue with magic ; ((generic-function generic-function) ;generic functions ; (method-combination method-combination) diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 09e916033cda719f290462f970b814f13441637d..c89fbe6c3836fab36ddd141ed6968f57d340b93a 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.10 1999/05/30 23:13:55 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.11 2001/04/25 21:44:51 pmai Exp $") ;;; (in-package :pcl) @@ -42,6 +42,29 @@ (expand-long-defcombin form) (expand-short-defcombin form))) + +;;; +;;; Implementation of INVALID-METHOD-ERROR and METHOD-COMBINATION-ERROR +;;; +;;; See combin.lisp for rest of the implementation. This method is +;;; defined here because compute-effective-method is still a function +;;; in combin.lisp. +;;; +(defmethod compute-effective-method :around + ((generic-function generic-function) + (method-combination method-combination) + applicable-methods) + (declare (ignore applicable-methods)) + (flet ((real-invalid-method-error (method format-string &rest args) + (declare (ignore method)) + (apply #'error format-string args)) + (real-method-combination-error (format-string &rest args) + (apply #'error format-string args))) + (let ((*invalid-method-error* #'real-invalid-method-error) + (*method-combination-error* #'real-method-combination-error)) + (call-next-method)))) + + ;;; ;;; STANDARD method combination