Ignore:
Timestamp:
Oct 9, 2009, 6:07:50 PM (10 years ago)
Author:
gz
Message:

fixes for slots with non-standard allocation (r12760,r12761,r12762,r12765, r12905)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/describe.lisp

    r12949 r12950  
    522522(defun standard-object-compute-line-count (i) 
    523523  (let* ((object (ccl::maybe-update-obsolete-instance (inspector-object i)))
    524          (class (class-of object)))
    525     (multiple-value-bind (instance-slots class-slots) (ccl::extract-instance-and-class-slotds (ccl::class-slots class))
     524         (class (class-of object))
     525         (all-slots (ccl::class-slots class)))
     526    (multiple-value-bind (instance-slots class-slots other-slots) (ccl::extract-instance-class-and-other-slotds all-slots)
    526527      (let* ((ninstance-slots (length instance-slots))
    527              (nclass-slots (length class-slots)))
     528             (nclass-slots (length class-slots))
     529             (nother-slots (length other-slots)))
    528530        (+ 2                                ; class, wrapper
    529531           (if (eql 0 ninstance-slots)
     
    533535             0
    534536             (1+ nclass-slots))
    535            (if (eql 0 (+ nclass-slots ninstance-slots))
     537           (if (eql 0 nother-slots)
     538             0
     539             (1+ nother-slots))
     540           (if (eql 0 (+ nclass-slots ninstance-slots nother-slots))
    536541             1
    537542             0))))))
     
    563568; [Class slots:
    564569;  slots...]
     570; [Other slots:
     571;  slots...]
     572
    565573(defun standard-object-line-n (i n)
    566574  (let* ((instance (inspector-object i))
    567575         (class (class-of instance))
     576         (all-slots (class-slots class))
    568577         (wrapper (or (ccl::standard-object-p instance)
    569578                      (if (typep instance 'ccl::funcallable-standard-object)
     
    574583        (values class "Class: " :normal)
    575584        (values wrapper "Wrapper: " :static))
    576       (let* ((slotds (ccl::extract-instance-effective-slotds class))
    577              (instance-count (length slotds))
    578              (shared-start (+ instance-start instance-count
    579                               (if (eql 0 instance-count) 0 1))))
    580         (if (< n shared-start)
    581           (if (eql n instance-start)
    582             (values nil "Instance slots" :comment)
    583             (let ((slot-name (slot-definition-name
    584                               (elt slotds (- n instance-start 1)))))
    585               (values (slot-value-or-unbound instance slot-name)
    586                       slot-name
    587                       :colon)))
    588           (let* ((slotds (ccl::extract-class-effective-slotds class))
    589                  (shared-count (length slotds))
    590                  (shared-end (+ shared-start shared-count
    591                                 (if (eql shared-count 0) 0 1))))
    592             (if (< n shared-end)
    593               (if (eql n shared-start)
    594                 (values nil "Class slots" :comment)
    595                 (let ((slot-name (slot-definition-name
    596                                   (elt slotds (- n shared-start 1)))))
    597                   (values (slot-value-or-unbound instance slot-name)
    598                            slot-name
    599                            :colon)))
    600               (if (and (eql 0 instance-count) (eql 0 shared-count) (eql n shared-end))
    601                 (values nil "No Slots" :comment)
    602                 (line-n-out-of-range i n)))))))))
     585      (multiple-value-bind (instance-slotds class-slotds other-slotds)
     586          (ccl::extract-instance-class-and-other-slotds all-slots)
     587        (let* ((instance-count (length instance-slotds))
     588               (shared-start (+ instance-start instance-count
     589                                (if (eql 0 instance-count) 0 1))))
     590          (if (< n shared-start)
     591            (if (eql n instance-start)
     592              (values nil "Instance slots" :comment)
     593              (let ((slot-name (slot-definition-name
     594                                (elt instance-slotds (- n instance-start 1)))))
     595                (values (slot-value-or-unbound instance slot-name)
     596                        slot-name
     597                        :colon)))
     598            (let* ((shared-count (length class-slotds))
     599                   (shared-end (+ shared-start shared-count
     600                                  (if (eql shared-count 0) 0 1))))
     601              (if (< n shared-end)
     602                (if (eql n shared-start)
     603                  (values nil "Class slots" :comment)
     604                  (let ((slot-name (slot-definition-name
     605                                    (elt class-slotds (- n shared-start 1)))))
     606                    (values (slot-value-or-unbound instance slot-name)
     607                            slot-name
     608                            :colon)))
     609                (let* ((other-start shared-end)
     610                       (other-end (+ other-start (if other-slotds (1+ (length other-slotds)) 0))))
     611                  (if (< n other-end)
     612                    (if (eql n other-start)
     613                      (values nil "Other slots" :comment)
     614                      (let ((slot-name (slot-definition-name
     615                                        (elt other-slotds (- n other-start 1)))))
     616                        (values (slot-value-or-unbound instance slot-name)
     617                                slot-name
     618                                :colon)))
     619                    (if (and (eql 0 instance-count) (eql 0 shared-count) (null other-slotds) (eql n other-end))
     620                      (values nil "No Slots" :comment)
     621                      (line-n-out-of-range i n))))))))))))
    603622
    604623(defmethod (setf line-n) (value (i standard-object-inspector) n)
Note: See TracChangeset for help on using the changeset viewer.