Changeset 12950

Timestamp:

Oct 9, 2009, 11:07:50 AM (15 years ago)

Author:

gz

Message:

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

Location:

branches/working-0711/ccl

Files:

• level-0/X86/x86-clos.lisp (modified) (2 diffs)
• level-1/l1-clos-boot.lisp (modified) (3 diffs)
• level-1/l1-clos.lisp (modified) (4 diffs)
• lib/describe.lisp (modified) (4 diffs)

branches/working-0711/ccl/level-0/X86/x86-clos.lisp

@@ -75 +75 @@
   (movq (@ 'class (% fn)) (% arg_x))
   (set-nargs 3)
-  (jmp (@ '%maybe-std-std-value-using-class (% fn)))
+  (jmp (@ '%maybe-std-slot-value-using-class (% fn)))
   @missing                              ; (%slot-id-ref-missing instance id)
   (set-nargs 2)
@@ -96 +96 @@
   (movq (@ 'class (% fn)) (% arg_x))
   (set-nargs 3)
-  (jmp (@ '%maybe-std-std-value-using-class (% fn)))
+  (jmp (@ '%maybe-std-slot-value-using-class (% fn)))
   @missing                              ; (%slot-id-ref-missing instance id)
   (set-nargs 2)

branches/working-0711/ccl/level-1/l1-clos-boot.lisp

@@ -2743 +2743 @@
            (eq *standard-effective-slot-definition-class-wrapper*
                (instance.class-wrapper slotd))
-           (eq *standard-class-wrapper* (instance.class-wrapper class)))
+           (eq *standard-class-wrapper* (instance.class-wrapper class))
+           (let* ((allocation (standard-effective-slot-definition.location slotd)))
+             (or (eq allocation :instance) (eq allocation :class))))
     (%std-slot-vector-value (instance-slots instance) slotd)
     (if (= (the fixnum (typecode instance)) target::subtag-struct)
@@ -2788 +2790 @@
            (eq *standard-effective-slot-definition-class-wrapper*
                (instance.class-wrapper slotd))
-           (eq *standard-class-wrapper* (instance.class-wrapper class)))
+           (eq *standard-class-wrapper* (instance.class-wrapper class))
+           (let* ((allocation (standard-effective-slot-definition.allocation slotd)))
+             (or (eq allocation :instance) (eq allocation :class))))
     ;; Not safe to use instance.slots here, since the instance is not
     ;; definitely of type SUBTAG-INSTANCE.  (Anyway, INSTANCE-SLOTS
@@ -2904 +2908 @@
            (eq *standard-effective-slot-definition-class-wrapper*
                (instance.class-wrapper slotd))
-           (eq *standard-class-wrapper* (instance.class-wrapper class)))
+           (eq *standard-class-wrapper* (instance.class-wrapper class))
+           (let* ((allocation (standard-slot-definition.allocation slotd)))
+             (or (eq allocation :class)
+                 (eq allocation :instance))))
     (%std-slot-vector-boundp (instance-slots instance) slotd)
     (slot-boundp-using-class class instance slotd)))

branches/working-0711/ccl/level-1/l1-clos.lisp

@@ -40 +40 @@
   (extract-slotds-with-allocation :class (%class-slots class)))
 
-(defun extract-instance-and-class-slotds (slotds)
+(defun extract-instance-class-and-other-slotds (slotds)
   (collect ((instance-slots)
-            (shared-slots))
-    (dolist (s slotds (values (instance-slots) (shared-slots)))
-      (if (eq (%slot-definition-allocation s) :class)
-        (shared-slots s)
-        (instance-slots s)))))
-
-
-
-(defun direct-instance-and-class-slotds (class)
-  (extract-instance-and-class-slotds (%class-direct-slots class)))
-
-(defun effective-instance-and-class-slotds (class)
-  (extract-instance-and-class-slotds (%class-slots class)))
+            (shared-slots)
+            (other-slots))
+    (dolist (s slotds (values (instance-slots) (shared-slots) (other-slots)))
+      (case (%slot-definition-allocation s)
+        (:instance (instance-slots s))
+        (:class (shared-slots s))
+        (t (other-slots s))))))
+
 
 (defun %early-shared-initialize (instance slot-names initargs)
@@ -153 +148 @@
 (defmethod compile-time-class-p ((class class)) nil)
 
-(defmethod direct-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
-  (unless (member allocation '(:instance :class))
-    (report-bad-arg allocation '(member (:instance :class))))
+(defmethod direct-slot-definition-class ((class std-class) &key  &allow-other-keys)
   *standard-direct-slot-definition-class*)
 
-(defmethod effective-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
-  (unless (member allocation '(:instance :class))
-    (report-bad-arg allocation '(member (:instance :class))))
+(defmethod effective-slot-definition-class ((class std-class) &key  &allow-other-keys)
   *standard-effective-slot-definition-class*)
 
@@ -252 +243 @@
 (defmethod compute-slots :around ((class std-class))
   (let* ((cpl (%class.cpl class)))
-    (multiple-value-bind (instance-slots class-slots)
-        (extract-instance-and-class-slotds (call-next-method))
+    (multiple-value-bind (instance-slots class-slots other-slots)
+        (extract-instance-class-and-other-slotds (call-next-method))
       (setq instance-slots (sort-effective-instance-slotds instance-slots class cpl))
       (do* ((loc 1 (1+ loc))
@@ -266 +257 @@
                                  :class-slots)
                      :test #'eq)))
-      (append instance-slots class-slots))))
+      (append instance-slots class-slots other-slots))))
 
 (defmethod compute-slots :around ((class structure-class))

branches/working-0711/ccl/lib/describe.lisp

@@ -522 +522 @@
 (defun standard-object-compute-line-count (i)  
   (let* ((object (ccl::maybe-update-obsolete-instance (inspector-object i)))
-         (class (class-of object)))
-    (multiple-value-bind (instance-slots class-slots) (ccl::extract-instance-and-class-slotds (ccl::class-slots class))
+         (class (class-of object))
+         (all-slots (ccl::class-slots class)))
+    (multiple-value-bind (instance-slots class-slots other-slots) (ccl::extract-instance-class-and-other-slotds all-slots)
       (let* ((ninstance-slots (length instance-slots))
-             (nclass-slots (length class-slots)))
+             (nclass-slots (length class-slots))
+             (nother-slots (length other-slots)))
         (+ 2                                ; class, wrapper
            (if (eql 0 ninstance-slots)
@@ -533 +535 @@
              0
              (1+ nclass-slots))
-           (if (eql 0 (+ nclass-slots ninstance-slots))
+           (if (eql 0 nother-slots)
+             0
+             (1+ nother-slots))
+           (if (eql 0 (+ nclass-slots ninstance-slots nother-slots))
              1
              0))))))
@@ -563 +568 @@
 ; [Class slots:
 ;  slots...]
+; [Other slots:
+;  slots...]
+
 (defun standard-object-line-n (i n)
   (let* ((instance (inspector-object i))
          (class (class-of instance))
+         (all-slots (class-slots class))
          (wrapper (or (ccl::standard-object-p instance)
                       (if (typep instance 'ccl::funcallable-standard-object)
@@ -574 +583 @@
         (values class "Class: " :normal)
         (values wrapper "Wrapper: " :static))
-      (let* ((slotds (ccl::extract-instance-effective-slotds class))
-             (instance-count (length slotds))
-             (shared-start (+ instance-start instance-count
-                              (if (eql 0 instance-count) 0 1))))
-        (if (< n shared-start)
-          (if (eql n instance-start)
-            (values nil "Instance slots" :comment)
-            (let ((slot-name (slot-definition-name
-                              (elt slotds (- n instance-start 1)))))
-              (values (slot-value-or-unbound instance slot-name)
-                      slot-name
-                      :colon)))
-          (let* ((slotds (ccl::extract-class-effective-slotds class))
-                 (shared-count (length slotds))
-                 (shared-end (+ shared-start shared-count
-                                (if (eql shared-count 0) 0 1))))
-            (if (< n shared-end)
-              (if (eql n shared-start)
-                (values nil "Class slots" :comment)
-                (let ((slot-name (slot-definition-name 
-                                  (elt slotds (- n shared-start 1)))))
-                  (values (slot-value-or-unbound instance slot-name)
-                           slot-name
-                           :colon)))
-              (if (and (eql 0 instance-count) (eql 0 shared-count) (eql n shared-end))
-                (values nil "No Slots" :comment)
-                (line-n-out-of-range i n)))))))))
+      (multiple-value-bind (instance-slotds class-slotds other-slotds)
+          (ccl::extract-instance-class-and-other-slotds all-slots)
+        (let* ((instance-count (length instance-slotds))
+               (shared-start (+ instance-start instance-count
+                                (if (eql 0 instance-count) 0 1))))
+          (if (< n shared-start)
+            (if (eql n instance-start)
+              (values nil "Instance slots" :comment)
+              (let ((slot-name (slot-definition-name
+                                (elt instance-slotds (- n instance-start 1)))))
+                (values (slot-value-or-unbound instance slot-name)
+                        slot-name
+                        :colon)))
+            (let* ((shared-count (length class-slotds))
+                   (shared-end (+ shared-start shared-count
+                                  (if (eql shared-count 0) 0 1))))
+              (if (< n shared-end)
+                (if (eql n shared-start)
+                  (values nil "Class slots" :comment)
+                  (let ((slot-name (slot-definition-name 
+                                    (elt class-slotds (- n shared-start 1)))))
+                    (values (slot-value-or-unbound instance slot-name)
+                            slot-name
+                            :colon)))
+                (let* ((other-start shared-end)
+                       (other-end (+ other-start (if other-slotds (1+ (length other-slotds)) 0))))
+                  (if (< n other-end)
+                    (if (eql n other-start)
+                      (values nil "Other slots" :comment)
+                      (let ((slot-name (slot-definition-name 
+                                        (elt other-slotds (- n other-start 1)))))
+                        (values (slot-value-or-unbound instance slot-name)
+                                slot-name
+                                :colon)))
+                    (if (and (eql 0 instance-count) (eql 0 shared-count) (null other-slotds) (eql n other-end))
+                      (values nil "No Slots" :comment)
+                      (line-n-out-of-range i n))))))))))))
 
 (defmethod (setf line-n) (value (i standard-object-inspector) n)