Redefinition of classes having existing instances

[harrisr@turing.cs.rpi.EDU (Richard Harris)]

Redefinition of classes having existing instances can make 
the old instances unusable because of two bugs.  Here are
test cases and fixes for both bugs.

  --------------
  Richard Harris

-----------------------------------------------
;1. Fix a bug in invalidate-wrapper: when the state is obsolete,
;   the state of every previous wrapper must be changed to obsolete.
;   [added the form (when (eq state 'obsolete) ...).]

;Test
(defclass c1 () ())
(defclass c1a () ())
(defclass c3 (c1) ((a :initform 'one))))
(defmethod test ((v c3)) (slot-value v 'a))
(print (test (setq z1 (make-instance 'c3)))) ; => ONE
(defclass c3 (c1a) ((a :initform 'one))))
(defclass c2 () ((b :initform 'two)))
(defclass c3 (c2) ((a :initform 'one)))
(print (test (setq z2 (make-instance 'c3)))) ; => ONE
(defclass c2 () ((b :initform 'two))) 
(print (test z2))                            ; => TWO
(print (test z1))                            ; error

 - - - - - - - - - - - - 
;cache.lisp
(defun invalidate-wrapper (owrapper state nwrapper)
  (ecase state
    ((flush obsolete)
     (let ((new-previous ()))
       ;;
       ;; First off, a previous call to invalidate-wrapper may have recorded
       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
       ;; be invalid, it no longer makes sense to update to it.
       ;;
       ;; We go back and change the previously invalidated wrappers so that
       ;; they will now update directly to nwrapper.  This corresponds to a
       ;; kind of transitivity of wrapper updates.
       ;; 
       (dolist (previous (gethash owrapper *previous-nwrappers*))
	 (when (eq state 'obsolete)          ; obsolete must override flush
	   (setf (car previous) 'obsolete))
	 (setf (cadr previous) nwrapper)
	 (push previous new-previous))
       
       (iterate ((type (list-elements wrapper-layout))
		 (i (interval :from 0)))
	 (when (eq type 'number) (setf (wrapper-ref owrapper i) 0)))
       (push (setf (wrapper-state owrapper) (list state nwrapper))
	     new-previous)
       
       (setf (gethash owrapper *previous-nwrappers*) ()
	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
-----------------------------------------------

;2. The code generated by add-pv-binding (called by defmethod) is not 
    prepared to handle cache misses caused by invalid wrappers, but 
    discriminating functions which call protect-cache-miss-code do not 
    always call check-wrapper-validity.

;Test

(defclass c1 () ())
(defclass c2 () ((b :initform 'two)))
(defclass c3 (c2) ((a :initform 'one)))

(defvar *list1*)
(setq *list1* (list (make-instance 'c3) (make-instance 'c3)))
(defvar *list2*)
(setq *list2* (list (make-instance 'c3) (make-instance 'c3)))

(defclass c3 (c1) ((a :initform 'one))))
(defclass c3 (c2) ((a :initform 'one)))

(defmethod test-list ((v c3) &rest list)
  (if list
      (cons (slot-value v 'a) (apply #'test-list list))
      (list (slot-value v 'a))))

(pcl::invalidate-discriminating-function #'test-list)

(print (apply #'test-list *list1*)) ; => (TWO TWO)
(print (apply #'test-list *list2*)) ; => (TWO TWO); (ONE TWO) if invalidate-wrapper is fixed

 - - - - - - - - - - - - 
;methods.lisp
(defmacro protect-cache-miss-code (gf args &body body)
  (let ((wrappers (gensym)) (invalidp (gensym)) (function (gensym)) (appl (gensym)))
    (once-only (gf args)
      `(if (memq ,gf *invalid-dfuns-on-stack*)
	   (multiple-value-bind (,wrappers ,invalidp ,function ,appl)
	       (cache-miss-values ,gf ,args)
             (declare (ignore ,wrappers ,invalidp))
	     (if (null ,appl)
		 (no-applicable-method ,gf ,args) ; or maybe (apply #'no-applicable-method ,gf ,args)
		 (apply ,function ,args)))
	   (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))
	     ,@body)))))
-----------------------------------------------