[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

CPL and method-update bug (& fix?)



We've noticed the following bug in Cinco-de-Mayo PCL:

(defclass class-a () ())
(defmethod meth-1 ((x class-a)) (print 'class-a))
;; ^- recomputes combination points
(defclass b-mixin () ())
(defmethod meth-1 :after ((x b-mixin)) (print 'b-mixin))
(meth-1 (make-instance 'class-a))		;compute-c-p
;; ^- recomputes combination points
(defclass a-and-b (b-mixin class-a) ())
;; ^- doesn't recompute combination points
(meth-1 (make-instance 'a-and-b))	
;; ^- doesn't recompute combination points, and blows up with
;; "no applicable primary method" error.

Below is a fix for the problem - probably not the *right* one, but it
does seem to make things work:

(defmethod update-method-inheritance ((class standard-class) old-cpl new-cpl)
  (unless (or ;(null old-cpl)		; mthome@bbn - for new ones, too
	      (equal old-cpl new-cpl))
    (let* ((shared-tail (shared-tail old-cpl new-cpl))
	   (old (butlast old-cpl (length shared-tail)))
	   (new (butlast new-cpl (length shared-tail)))
	   (seen-gfs ()))
      (labels ((consider-gf (gf)
		 (unless (memq gf seen-gfs)
		   (push gf seen-gfs)
		   (when (check-method-precedences gf)
		     (update gf))))		 
	       (check-method-precedences (gf)
		 (block check-method-precedences
		   (let* ((specializers
			    (delete-duplicates
			      (apply #'append
				     (mapcar #'method-type-specifiers
					     (generic-function-methods gf)))))
			  (old-precedence
			    (gathering1 (collecting)
			      (dolist (o old)
				(when (memq o specializers) (gather1 o))))))
		     (dolist (n new)
		       (when (memq n specializers)
			 (unless (eq n (pop old-precedence))
			   (return-from check-method-precedences t)))))))
	       (update (gf)
		 (invalidate-generic-function gf)))
	(dolist (o old)
	  (dolist (dm (class-direct-methods o))
	    (consider-gf (method-generic-function dm))))
	(dolist (n new)
	  (unless (memq n old)
	    (dolist (dm (class-direct-methods n))
	      (consider-gf (method-generic-function dm)))))))))