Skip to content
Snippets Groups Projects
Commit f6fc0c85 authored by pmai's avatar pmai
Browse files

o Fixed the implementation of INVALID-METHOD-ERROR and METHOD-COMBINATION-ERROR

  by fixing bootstrapping problems with the disabled around method of
  COMPUTE-EFFECTIVE-METHOD, and reinstating it.
o Added stricter error checking for standard method combination.
parent cbd10aa8
No related branches found
No related tags found
No related merge requests found
......@@ -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)
......
......@@ -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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment