(defun ensure-class-values (class initargs)
(let (metaclass metaclassp reversed-plist)
(doplist (key val) initargs
- (cond ((eq key :metaclass)
- (setf metaclass val
- metaclassp key))
- (t
- (when (eq key :direct-superclasses)
- (setf val (mapcar #'fix-super val)))
- (setf reversed-plist (list* val key reversed-plist)))))
+ (cond ((eq key :metaclass)
+ (setf metaclass val
+ metaclassp key))
+ (t
+ (when (eq key :direct-superclasses)
+ (setf val (mapcar #'fix-super val)))
+ (setf reversed-plist (list* val key reversed-plist)))))
(values (cond (metaclassp
- (find-class metaclass))
+ (if (classp metaclass)
+ metaclass
+ (find-class metaclass)))
((or (null class) (forward-referenced-class-p class))
*the-class-standard-class*)
(t
(defun make-defstruct-allocation-function (class)
(let ((dd (get-structure-dd (class-name class))))
(lambda ()
- (let ((instance (%make-instance (dd-length dd)))
- (raw-index (dd-raw-index dd)))
- (setf (%instance-layout instance)
- (sb-kernel::compiler-layout-or-lose (dd-name dd)))
- (when raw-index
- (setf (%instance-ref instance raw-index)
- (make-array (dd-raw-length dd)
- :element-type '(unsigned-byte 32))))
- instance))))
+ (sb-kernel::%make-instance-with-layout
+ (sb-kernel::compiler-layout-or-lose (dd-name dd))))))
(defmethod shared-initialize :after
((class structure-class)
(defun fix-slot-accessors (class dslotds add/remove)
(flet ((fix (gfspec name r/w)
- (let ((gf (if (fboundp gfspec)
- (without-package-locks
- (ensure-generic-function gfspec))
- (ensure-generic-function
- gfspec :lambda-list (case r/w
- (r '(object))
- (w '(new-value object)))))))
- (case r/w
- (r (if (eq add/remove 'add)
- (add-reader-method class gf name)
- (remove-reader-method class gf)))
- (w (if (eq add/remove 'add)
- (add-writer-method class gf name)
- (remove-writer-method class gf)))))))
+ (let ((gf (cond ((eq add/remove 'add)
+ (if (fboundp gfspec)
+ (without-package-locks
+ (ensure-generic-function gfspec))
+ (ensure-generic-function
+ gfspec :lambda-list (case r/w
+ (r '(object))
+ (w '(new-value object))))))
+ ((generic-function-p (and (fboundp gfspec)
+ (fdefinition gfspec)))
+ (without-package-locks
+ (ensure-generic-function gfspec))))))
+ (when gf
+ (case r/w
+ (r (if (eq add/remove 'add)
+ (add-reader-method class gf name)
+ (remove-reader-method class gf)))
+ (w (if (eq add/remove 'add)
+ (add-writer-method class gf name)
+ (remove-writer-method class gf))))))))
(dolist (dslotd dslotds)
(let ((slot-name (slot-definition-name dslotd)))
(dolist (r (slot-definition-readers dslotd))