Changeset 12950


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)

Location:
branches/working-0711/ccl
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-0/X86/x86-clos.lisp

    r11069 r12950  
    7575  (movq (@ 'class (% fn)) (% arg_x))
    7676  (set-nargs 3)
    77   (jmp (@ '%maybe-std-std-value-using-class (% fn)))
     77  (jmp (@ '%maybe-std-slot-value-using-class (% fn)))
    7878  @missing                              ; (%slot-id-ref-missing instance id)
    7979  (set-nargs 2)
     
    9696  (movq (@ 'class (% fn)) (% arg_x))
    9797  (set-nargs 3)
    98   (jmp (@ '%maybe-std-std-value-using-class (% fn)))
     98  (jmp (@ '%maybe-std-slot-value-using-class (% fn)))
    9999  @missing                              ; (%slot-id-ref-missing instance id)
    100100  (set-nargs 2)
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r12588 r12950  
    27432743           (eq *standard-effective-slot-definition-class-wrapper*
    27442744               (instance.class-wrapper slotd))
    2745            (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2745           (eq *standard-class-wrapper* (instance.class-wrapper class))
     2746           (let* ((allocation (standard-effective-slot-definition.location slotd)))
     2747             (or (eq allocation :instance) (eq allocation :class))))
    27462748    (%std-slot-vector-value (instance-slots instance) slotd)
    27472749    (if (= (the fixnum (typecode instance)) target::subtag-struct)
     
    27882790           (eq *standard-effective-slot-definition-class-wrapper*
    27892791               (instance.class-wrapper slotd))
    2790            (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2792           (eq *standard-class-wrapper* (instance.class-wrapper class))
     2793           (let* ((allocation (standard-effective-slot-definition.allocation slotd)))
     2794             (or (eq allocation :instance) (eq allocation :class))))
    27912795    ;; Not safe to use instance.slots here, since the instance is not
    27922796    ;; definitely of type SUBTAG-INSTANCE.  (Anyway, INSTANCE-SLOTS
     
    29042908           (eq *standard-effective-slot-definition-class-wrapper*
    29052909               (instance.class-wrapper slotd))
    2906            (eq *standard-class-wrapper* (instance.class-wrapper class)))
     2910           (eq *standard-class-wrapper* (instance.class-wrapper class))
     2911           (let* ((allocation (standard-slot-definition.allocation slotd)))
     2912             (or (eq allocation :class)
     2913                 (eq allocation :instance))))
    29072914    (%std-slot-vector-boundp (instance-slots instance) slotd)
    29082915    (slot-boundp-using-class class instance slotd)))
  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r12202 r12950  
    4040  (extract-slotds-with-allocation :class (%class-slots class)))
    4141
    42 (defun extract-instance-and-class-slotds (slotds)
     42(defun extract-instance-class-and-other-slotds (slotds)
    4343  (collect ((instance-slots)
    44             (shared-slots))
    45     (dolist (s slotds (values (instance-slots) (shared-slots)))
    46       (if (eq (%slot-definition-allocation s) :class)
    47         (shared-slots s)
    48         (instance-slots s)))))
    49 
    50 
    51 
    52 (defun direct-instance-and-class-slotds (class)
    53   (extract-instance-and-class-slotds (%class-direct-slots class)))
    54 
    55 (defun effective-instance-and-class-slotds (class)
    56   (extract-instance-and-class-slotds (%class-slots class)))
     44            (shared-slots)
     45            (other-slots))
     46    (dolist (s slotds (values (instance-slots) (shared-slots) (other-slots)))
     47      (case (%slot-definition-allocation s)
     48        (:instance (instance-slots s))
     49        (:class (shared-slots s))
     50        (t (other-slots s))))))
     51
    5752
    5853(defun %early-shared-initialize (instance slot-names initargs)
     
    153148(defmethod compile-time-class-p ((class class)) nil)
    154149
    155 (defmethod direct-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
    156   (unless (member allocation '(:instance :class))
    157     (report-bad-arg allocation '(member (:instance :class))))
     150(defmethod direct-slot-definition-class ((class std-class) &key  &allow-other-keys)
    158151  *standard-direct-slot-definition-class*)
    159152
    160 (defmethod effective-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
    161   (unless (member allocation '(:instance :class))
    162     (report-bad-arg allocation '(member (:instance :class))))
     153(defmethod effective-slot-definition-class ((class std-class) &key  &allow-other-keys)
    163154  *standard-effective-slot-definition-class*)
    164155
     
    252243(defmethod compute-slots :around ((class std-class))
    253244  (let* ((cpl (%class.cpl class)))
    254     (multiple-value-bind (instance-slots class-slots)
    255         (extract-instance-and-class-slotds (call-next-method))
     245    (multiple-value-bind (instance-slots class-slots other-slots)
     246        (extract-instance-class-and-other-slotds (call-next-method))
    256247      (setq instance-slots (sort-effective-instance-slotds instance-slots class cpl))
    257248      (do* ((loc 1 (1+ loc))
     
    266257                                 :class-slots)
    267258                     :test #'eq)))
    268       (append instance-slots class-slots))))
     259      (append instance-slots class-slots other-slots))))
    269260
    270261(defmethod compute-slots :around ((class structure-class))
  • 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.