- (if (typep (first direct-slotds) 'direct-virtual-slot-definition)
- (let ((initargs ()))
- (let ((getter (most-specific-slot-value direct-slotds 'getter)))
- (unless (eq getter *unbound-marker*)
- (setf (getf initargs :getter) getter)))
- (let ((setter (most-specific-slot-value direct-slotds 'setter)))
- (unless (eq setter *unbound-marker*)
- (setf (getf initargs :setter) setter)))
- (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
- (unless (eq unbound *unbound-marker*)
- (setf (getf initargs :unbound) unbound)))
- (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
- (unless (eq boundp *unbound-marker*)
- (setf (getf initargs :boundp) boundp)))
- (nconc initargs (call-next-method)))
- (call-next-method)))
+ (typecase (first direct-slotds)
+ (direct-virtual-slot-definition
+ (let ((initargs ()))
+ (let ((getter (most-specific-slot-value direct-slotds 'getter)))
+ (unless (eq getter *unbound-marker*)
+ (setf (getf initargs :getter) getter)))
+ (let ((setter (most-specific-slot-value direct-slotds 'setter)))
+ (unless (eq setter *unbound-marker*)
+ (setf (getf initargs :setter) setter)))
+ (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
+ (unless (eq unbound *unbound-marker*)
+ (setf (getf initargs :unbound) unbound)))
+ (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
+ (unless (eq boundp *unbound-marker*)
+ (setf (getf initargs :boundp) boundp)))
+ ;; Need this to prevent type expansion in SBCL >= 0.9.8
+ (let ((type (most-specific-slot-value direct-slotds 'type)))
+ (unless (eq type *unbound-marker*)
+ (setf (getf initargs :type) type)))
+ (nconc initargs (call-next-method))))
+ (direct-special-slot-definition
+ (append '(:special t) (call-next-method)))
+ (t (call-next-method))))