Index: /branches/working-0711/ccl/level-0/X86/x86-clos.lisp =================================================================== --- /branches/working-0711/ccl/level-0/X86/x86-clos.lisp (revision 12949) +++ /branches/working-0711/ccl/level-0/X86/x86-clos.lisp (revision 12950) @@ -75,5 +75,5 @@ (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,5 +96,5 @@ (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) Index: /branches/working-0711/ccl/level-1/l1-clos-boot.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-clos-boot.lisp (revision 12949) +++ /branches/working-0711/ccl/level-1/l1-clos-boot.lisp (revision 12950) @@ -2743,5 +2743,7 @@ (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,5 +2790,7 @@ (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,5 +2908,8 @@ (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))) Index: /branches/working-0711/ccl/level-1/l1-clos.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-clos.lisp (revision 12949) +++ /branches/working-0711/ccl/level-1/l1-clos.lisp (revision 12950) @@ -40,19 +40,14 @@ (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,12 +148,8 @@ (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,6 +243,6 @@ (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,5 +257,5 @@ :class-slots) :test #'eq))) - (append instance-slots class-slots)))) + (append instance-slots class-slots other-slots)))) (defmethod compute-slots :around ((class structure-class)) Index: /branches/working-0711/ccl/lib/describe.lisp =================================================================== --- /branches/working-0711/ccl/lib/describe.lisp (revision 12949) +++ /branches/working-0711/ccl/lib/describe.lisp (revision 12950) @@ -522,8 +522,10 @@ (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,5 +535,8 @@ 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,7 +568,11 @@ ; [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,31 +583,41 @@ (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)