Re: update-method-inheritance

[Gregor.pa@Xerox.COM]

    Date: Tue, 02 Aug 88 17:34:21 -0400
    From: kanderso@WILMA.BBN.COM

    Have you thought about my message on this at all?

    This seems to cause a lot on unncessary invailatation when a new class
    is defined (old-cpl is NIL).  In that case does anything really need
    to be invalidated?  If not, can't we at least make old-cpl contain the
    class T.  I'd like to be able to prove this theoretically to myself
    one way or another, but i figure you could come up with an obvious
    counter example, if there is one.

I have spent some time thinking about this.  The first thing I
discovered was that the code that was already in PCL was completely
wrong.  There were cases in which it did not update generic functions
that needed to be updated.  As you (and others) noticed, there were many
other cases where it updated too many generic functions.

At the end of this message is a patch for the 8/1/88 version of PCL
which I believe corrects all of these problems.  It should have the
performance characteristics you want, and shouldn't have any of the
previous bugs.  I haven't tested it, but I believe this patch can also
be loaded into the 7/20, and perhaps even into St. Patrick's Day PCL.

Please try this out and let me know if it works for you.  Unless some
problem arises, these changes will all be in the next release.

;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; Patch for 8/1/88 PCL to correct bug of invalidating all generic functions
;;; whenever a class is defined.
;;;
;;; This patch should be loaded into an already running PCL.
;;; 

(in-package 'pcl)

(defvar *the-class-object* (find-class 'object))

(defclass standard-class (class)
     ((name
        :initform nil
        :accessor class-name)
      (class-precedence-list
        :initform (list *the-class-object* *the-class-t*)
        :accessor class-precedence-list
        :accessor class-class-precedence-list)
      (local-supers
        :initform ()
        :accessor class-local-supers)
      (local-slots
        :initform ()
        :accessor class-local-slots)
      (direct-subclasses
        :initform ()
        :accessor class-direct-subclasses)
      (direct-methods
        :initform ()
;       :accessor class-direct-methods        ;This is defined by hand
                                              ;during bootstrapping.
        )
      (forward-referenced-supers
        :initform ()
        :accessor class-forward-referenced-supers)
      (no-of-instance-slots
        :initform 0
        :accessor class-no-of-instance-slots)
      (instance-slots
        :initform ())
      (non-instance-slots
        :initform ()
        :accessor class-non-instance-slots)
      (wrapper
        :initform nil
        :accessor class-wrapper)
      (direct-generic-functions
        :initform ()
        :accessor class-direct-generic-functions)
      (prototype
        :initform nil)
      (options
        :initform ()
        :accessor class-options)
      (constructors
        :initform ()
        :accessor class-constructors)
      (all-default-initargs
        :initform ()
        :accessor class-all-default-initargs)))

(defmethod update-method-inheritance ((class standard-class) old-cpl new-cpl)
  (let ((already-done ()))
    (unless (equal old-cpl new-cpl)
      (let ((shared-tail (shared-tail old-cpl new-cpl)))
        (dolist (old old-cpl)
          (unless (memq old shared-tail)
            (setq already-done
                  (update-method-inheritance-1 old already-done))))
        (dolist (new new-cpl)
          (unless (memq new old-cpl)
            (setq already-done
                  (update-method-inheritance-1 new already-done))))))))

(defun update-method-inheritance-1 (class already-done)
  (let ((methods (class-direct-methods class)))
    (dolist (method methods)
      (let ((gf (method-generic-function method)))
        (if (null gf)
            (error "A method still on a class, has no generic function?")
            (unless (memq gf already-done)
              (push gf already-done)
              (invalidate-generic-function gf)))))
    already-done))

(defun shared-tail (l1 l2)
  (let ((r2 (reverse l2)))
    (labels ((recur (t1)
               (cond ((null t1) ())
                     (t
                      (recur (cdr t1))
                      (cond ((null r2)
                             (return-from shared-tail (cdr t1)))
                            ((eq t1 l1)
                             (return-from shared-tail l1))
                            ((eq (car t1) (pop r2)))
                            (t
                             (return-from shared-tail (cdr t1))))))))
      (recur l1))))

-------