change-class-internal bug

[kanderso@WILMA.BBN.COM]

;;; -*- Package: PCL -*-

Bug using SLOT-VALUE of an instance of class obsolete-class.
You get into infinte  recursion as i've indicated in the code below.
Basically CHANGE-CLASS-INTERNAL cannot use the normal ALL-SLOTS mechanism
because that winds up using SLOT-VALUE again.  I remeber this in the old PCL
we must have patched it locally.

k

(defun slot-value (object slot-name)
  (SLOT-VALUE-USING-CLASS (CLASS-OF OBJECT) OBJECT SLOT-NAME))	; <-

(defmethod slot-value-using-class ((class obsolete-class)
				   object
				   slot-name
				   &optional dont-call-slot-missing-p
					     default)
  (CHANGE-CLASS OBJECT				                ; <-
		(CADR (SLOT-VALUE CLASS 'CLASS-PRECEDENCE-LIST)))
  (slot-value-using-class
    (class-of object) object slot-name dont-call-slot-missing-p default))

(defun change-class (object new-class)
  (or (classp new-class)
      (setq new-class (class-named new-class)))
  (let ((new-object (make-instance new-class)))
    ;; Call change-class-internal so that a user-defined method
    ;; (or the default method) can copy the information from the
    ;; old instance to the dummy instance of the new class.
    (CHANGE-CLASS-INTERNAL OBJECT NEW-OBJECT)			; <-
    ;; Now that the dummy new-object has the right information,
    ;; move all that stuff into the old-instance.
    (setf (iwmc-class-class-wrapper object)
	  (wrapper-of new-class))
    (setf (iwmc-class-static-slots object)
	  (iwmc-class-static-slots new-object))
    (setf (iwmc-class-dynamic-slots object)
	  (iwmc-class-dynamic-slots new-object))
    object))

(defmethod change-class-internal ((old object) (new object))
  (let ((all-slots (ALL-SLOTS OLD)))				; <-
    (iterate ((name in all-slots by cddr)
              (value in (cdr all-slots) by cddr))
      (put-slot-always new name value))))

(defun all-slots (object)
  (ALL-SLOTS-USING-CLASS (CLASS-OF OBJECT) OBJECT))		; <-

(defmethod all-slots-using-class ((class standard-class) object)
  (append (iterate ((slotd in (class-instance-slots class)))
	    (collect (slotd-name slotd))		
	    (collect (SLOT-VALUE OBJECT (SLOTD-NAME SLOTD))))	; <- OOPS!
	  (iwmc-class-dynamic-slots object)))