&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (slot-value class 'name))))
- (with-slots (wrapper %class-precedence-list cpl-available-p
- prototype (direct-supers direct-superclasses))
+ (with-slots (wrapper
+ %class-precedence-list cpl-available-p finalized-p
+ prototype (direct-supers direct-superclasses)
+ plist)
class
(setf (slot-value class 'direct-slots)
(mapcar (lambda (pl) (make-direct-slotd class pl))
- direct-slots))
- (setf (slot-value class 'finalized-p) t)
- (setf (classoid-pcl-class classoid) class)
- (setq direct-supers direct-superclasses)
- (setq wrapper (classoid-layout classoid))
- (setq %class-precedence-list (compute-class-precedence-list class))
- (setq cpl-available-p t)
+ direct-slots)
+ finalized-p t
+ (classoid-pcl-class classoid) class
+ direct-supers direct-superclasses
+ wrapper (classoid-layout classoid)
+ %class-precedence-list (compute-class-precedence-list class)
+ cpl-available-p t
+ (getf plist 'direct-default-initargs)
+ (sb-kernel::condition-classoid-direct-default-initargs classoid))
(add-direct-subclasses class direct-superclasses)
(let ((slots (compute-slots class)))
(setf (slot-value class 'slots) slots)
(eq (class-of o) (class-of n)))
(return nil)))))))
+(defun style-warn-about-duplicate-slots (class)
+ (do* ((slots (slot-value class 'slots) (cdr slots))
+ (dupes nil))
+ ((null slots)
+ (when dupes
+ (style-warn
+ "~@<slot names with the same SYMBOL-NAME but ~
+ different SYMBOL-PACKAGE (possible package problem) ~
+ for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
+ class dupes)))
+ (let* ((slot-name (slot-definition-name (car slots)))
+ (oslots (and (not (eq (symbol-package slot-name)
+ *pcl-package*))
+ (remove-if
+ (lambda (slot-name-2)
+ (or (eq (symbol-package slot-name-2)
+ *pcl-package*)
+ (string/= slot-name slot-name-2)))
+ (cdr slots)
+ :key #'slot-definition-name))))
+ (when oslots
+ (pushnew (cons slot-name
+ (mapcar #'slot-definition-name oslots))
+ dupes
+ :test #'string= :key #'car)))))
+
(defun %update-slots (class eslotds)
(multiple-value-bind (instance-slots class-slots custom-slots)
(classify-slotds eslotds)
(wrapper-slot-table nwrapper) (make-slot-table class eslotds)
(wrapper-length nwrapper) nslots
(slot-value class 'wrapper) nwrapper)
- (do* ((slots (slot-value class 'slots) (cdr slots))
- (dupes nil))
- ((null slots)
- (when dupes
- (style-warn
- "~@<slot names with the same SYMBOL-NAME but ~
- different SYMBOL-PACKAGE (possible package problem) ~
- for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
- class dupes)))
- (let* ((slot (car slots))
- (oslots (remove (slot-definition-name slot) (cdr slots)
- :test #'string/=
- :key #'slot-definition-name)))
- (when oslots
- (pushnew (cons (slot-definition-name slot)
- (mapcar #'slot-definition-name oslots))
- dupes
- :test #'string= :key #'car))))
+ (style-warn-about-duplicate-slots class)
(setf (slot-value class 'finalized-p) t)
(unless (eq owrapper nwrapper)
(maybe-update-standard-slot-locations class)))))