testing class-allocation of slots

(defclass a ()
  (slot1
   slot2))

(defclass b ()
  (slot1
   slot2))

(defclass c (a b)
  (slot2))

(defclass d (c)
  (slot2))

(defun my-info ()
(let* ((*print-pretty* nil)
       (mystream (or (frame-standard-output *application-frame*) *standard-output*))
       (instance-a (make-instance 'a))
       (instance-b (make-instance 'b))
       (instance-c (make-instance 'c))
       (instance-d (make-instance 'd))
       (class-of-a (slot-value (class-of instance-a) 'sb-pcl::name))
       (class-of-b (slot-value (class-of instance-b) 'sb-pcl::name))
       (class-of-c (slot-value (class-of instance-c) 'sb-pcl::name))
       (class-of-d (slot-value (class-of instance-d) 'sb-pcl::name))
       (slots-in-a (with-slots (sb-pcl::slots) (class-of instance-a) sb-pcl::slots))
       (slots-in-b (with-slots (sb-pcl::slots) (class-of instance-b) sb-pcl::slots))
       (slots-in-c (with-slots (sb-pcl::slots) (class-of instance-c) sb-pcl::slots))
       (slots-in-d (with-slots (sb-pcl::slots) (class-of instance-d) sb-pcl::slots))
       (first-from-a (slot-value (slot-value (first slots-in-a) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (first-from-b (slot-value (slot-value (first slots-in-b) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (first-from-c (slot-value (slot-value (first slots-in-c) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (first-from-d (slot-value (slot-value (first slots-in-d) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (second-from-a (slot-value (slot-value (second slots-in-a) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (second-from-b (slot-value (slot-value (second slots-in-b) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (second-from-c (slot-value (slot-value (second slots-in-c) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (second-from-d (slot-value (slot-value (second slots-in-d) 'sb-pcl::allocation-class) 'sb-pcl::name))
       (cpl-a (mapcar (lambda (obj) (slot-value obj 'sb-pcl::name))
              (sb-pcl::class-precedence-list (class-of instance-a))))
       (cpl-b (mapcar (lambda (obj) (slot-value obj 'sb-pcl::name))
              (sb-pcl::class-precedence-list (class-of instance-b))))
       (cpl-c (mapcar (lambda (obj) (slot-value obj 'sb-pcl::name))
              (sb-pcl::class-precedence-list (class-of instance-c))))
       (cpl-d (mapcar (lambda (obj) (slot-value obj 'sb-pcl::name))
              (sb-pcl::class-precedence-list (class-of instance-d)))))

(format mystream "~%Instance: ~a" instance-a)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (first slots-in-a) first-from-a)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (second slots-in-a) second-from-a)
(format mystream "~%class-precedence-list for Instance ~a of Class ~a:~% ~a~%"
    instance-a class-of-a cpl-a)

(format mystream "~%Instance: ~a" instance-b)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (first slots-in-b) first-from-b)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (second slots-in-b) second-from-b)
(format mystream "~%class-precedence-list for Instance ~a of Class ~a:~% ~a~%"
    instance-b class-of-b cpl-b)

(format mystream "~%Instance: ~a" instance-c)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (first slots-in-c) first-from-c)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (second slots-in-c) second-from-c)
(format mystream "~%class-precedence-list for Instance ~a of Class ~a:~% ~a~%"
    instance-c class-of-c cpl-c)

(format mystream "~%Instance: ~a" instance-d)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (first slots-in-d) first-from-d)
(format mystream "~%Slot Allocation for Slot ~a is from: ~a"
    (second slots-in-d) second-from-d)
(format mystream "~%class-precedence-list for Instance ~a of Class ~a:~% ~a~%"
    instance-d class-of-d cpl-d)))