Changeset 12765


Ignore:
Timestamp:
Sep 4, 2009, 11:07:14 PM (10 years ago)
Author:
gb
Message:

Use the new (internal) function to partition slots into
:instance,:class, and other :allocation values when describing
standard instances. (Probably overkill.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/describe.lisp

    r12756 r12765  
    477477(defun standard-object-compute-line-count (i) 
    478478  (let* ((object (ccl::maybe-update-obsolete-instance (inspector-object i)))
    479          (class (class-of object)))
    480     (multiple-value-bind (instance-slots class-slots) (ccl::extract-instance-and-class-slotds (ccl::class-slots class))
     479         (class (class-of object))
     480         (all-slots (ccl::class-slots class)))
     481    (multiple-value-bind (instance-slots class-slots other-slots) (ccl::extract-instance-class-and-other-slotds all-slots)
    481482      (let* ((ninstance-slots (length instance-slots))
    482              (nclass-slots (length class-slots)))
     483             (nclass-slots (length class-slots))
     484             (nother-slots (length other-slots)))
    483485        (+ 2                                ; class, wrapper
    484486           (if (eql 0 ninstance-slots)
     
    488490             0
    489491             (1+ nclass-slots))
    490            (if (eql 0 (+ nclass-slots ninstance-slots))
     492           (if (eql 0 nother-slots)
     493             0
     494             (1+ nother-slots))
     495           (if (eql 0 (+ nclass-slots ninstance-slots nother-slots))
    491496             1
    492497             0))))))
     
    518523; [Class slots:
    519524;  slots...]
     525; [Other slots:
     526;  slots...]
     527
    520528(defun standard-object-line-n (i n)
    521529  (let* ((instance (inspector-object i))
    522530         (class (class-of instance))
     531         (all-slots (class-slots class))
    523532         (wrapper (or (ccl::standard-object-p instance)
    524533                      (if (typep instance 'ccl::funcallable-standard-object)
     
    529538        (values class "Class: " :normal)
    530539        (values wrapper "Wrapper: " :static))
    531       (let* ((slotds (ccl::extract-instance-effective-slotds class))
    532              (instance-count (length slotds))
    533              (shared-start (+ instance-start instance-count
    534                               (if (eql 0 instance-count) 0 1))))
    535         (if (< n shared-start)
    536           (if (eql n instance-start)
    537             (values nil "Instance slots" :comment)
    538             (let ((slot-name (slot-definition-name
    539                               (elt slotds (- n instance-start 1)))))
    540               (values (slot-value-or-unbound instance slot-name)
    541                       slot-name
    542                       :colon)))
    543           (let* ((slotds (ccl::extract-class-effective-slotds class))
    544                  (shared-count (length slotds))
    545                  (shared-end (+ shared-start shared-count
    546                                 (if (eql shared-count 0) 0 1))))
    547             (if (< n shared-end)
    548               (if (eql n shared-start)
    549                 (values nil "Class slots" :comment)
    550                 (let ((slot-name (slot-definition-name
    551                                   (elt slotds (- n shared-start 1)))))
    552                   (values (slot-value-or-unbound instance slot-name)
    553                            slot-name
    554                            :colon)))
    555               (if (and (eql 0 instance-count) (eql 0 shared-count) (eql n shared-end))
    556                 (values nil "No Slots" :comment)
    557                 (line-n-out-of-range i n)))))))))
     540      (multiple-value-bind (instance-slotds class-slotds other-slotds)
     541          (ccl::extract-instance-class-and-other-slotds all-slots)
     542        (let* ((instance-count (length instance-slotds))
     543               (shared-start (+ instance-start instance-count
     544                                (if (eql 0 instance-count) 0 1))))
     545          (if (< n shared-start)
     546            (if (eql n instance-start)
     547              (values nil "Instance slots" :comment)
     548              (let ((slot-name (slot-definition-name
     549                                (elt instance-slotds (- n instance-start 1)))))
     550                (values (slot-value-or-unbound instance slot-name)
     551                        slot-name
     552                        :colon)))
     553            (let* ((shared-count (length class-slotds))
     554                   (shared-end (+ shared-start shared-count
     555                                  (if (eql shared-count 0) 0 1))))
     556              (if (< n shared-end)
     557                (if (eql n shared-start)
     558                  (values nil "Class slots" :comment)
     559                  (let ((slot-name (slot-definition-name
     560                                    (elt class-slotds (- n shared-start 1)))))
     561                    (values (slot-value-or-unbound instance slot-name)
     562                            slot-name
     563                            :colon)))
     564                (let* ((other-start shared-end)
     565                       (other-end (+ other-start (if other-slotds (1+ (length other-slotds)) 0))))
     566                  (if (< n other-end)
     567                    (if (eql n other-start)
     568                      (values nil "Other slots" :comment)
     569                      (let ((slot-name (slot-definition-name
     570                                        (elt other-slotds (- n other-start 1)))))
     571                        (values (slot-value-or-unbound instance slot-name)
     572                                slot-name
     573                                :colon)))
     574                    (if (and (eql 0 instance-count) (eql 0 shared-count) (null other-slotds) (eql n other-end))
     575                      (values nil "No Slots" :comment)
     576                      (line-n-out-of-range i n))))))))))))
    558577
    559578(defmethod (setf line-n) (value (i standard-object-inspector) n)
Note: See TracChangeset for help on using the changeset viewer.