;;; This needs to be used recursively, in case a non-trivial user
;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another
;;; function using the same lock.
-(defvar *specializer-lock* (sb-thread::make-spinlock :name "Specializer lock"))
+(defvar *specializer-lock* (sb-thread:make-mutex :name "Specializer lock"))
(defmethod add-direct-method :around ((specializer specializer) method)
;; All the actions done under this lock are done in an order
;; that is safe to unwind at any point.
- (sb-thread::with-recursive-system-spinlock (*specializer-lock*)
+ (sb-thread::with-recursive-system-lock (*specializer-lock*)
(call-next-method)))
(defmethod remove-direct-method :around ((specializer specializer) method)
;; All the actions done under this lock are done in an order
;; that is safe to unwind at any point.
- (sb-thread::with-recursive-system-spinlock (*specializer-lock*)
+ (sb-thread::with-recursive-system-lock (*specializer-lock*)
(call-next-method)))
(defmethod add-direct-method ((specializer class) (method method))
;; we behave as if we got just first or just after -- it's just
;; for update that we need to lock.
(or (cdr cell)
- (sb-thread::with-spinlock (*specializer-lock*)
+ (sb-thread:with-mutex (*specializer-lock*)
(setf (cdr cell)
(let (collect)
(dolist (m (car cell))
(entry (gethash object (specializer-method-table specializer))))
(when entry
(or (cdr entry)
- (sb-thread::with-spinlock (*specializer-lock*)
+ (sb-thread:with-mutex (*specializer-lock*)
(setf (cdr entry)
(let (collect)
(dolist (m (car entry))
&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)
\f
(defun class-has-a-forward-referenced-superclass-p (class)
- (or (forward-referenced-class-p class)
+ (or (when (forward-referenced-class-p class)
+ class)
(some #'class-has-a-forward-referenced-superclass-p
(class-direct-superclasses class))))
(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)))))