-(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition))
- (if (slot-boundp slotd 'getter)
- (slot-value slotd 'getter)
- #'(lambda (object)
- (error 'unreadable-slot :name (slot-definition-name slotd) :instance object))))
+(defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
+ (if (not (slot-readable-p slotd))
+ #'(lambda (object)
+ (error 'unreadable-slot :name (slot-definition-name slotd) :instance object))
+ (let ((reader-function (call-next-method)))
+ (cond
+ ;; Don't create wrapper to signal unbound value
+ ((not signal-unbound-p) reader-function)
+
+ ;; An explicit boundp function has been supplied
+ ((slot-boundp slotd 'boundp)
+ (let ((unbound-value (slot-value slotd 'boundp)))
+ #'(lambda (object)
+ (let ((value (funcall reader-function object)))
+ (if (eq value unbound-value)
+ (slot-unbound (class-of object) object (slot-definition-name slotd))
+ value)))))
+
+ ;; A type unbound value exists
+ ((let ((unbound-method (find-applicable-type-method 'unbound-value
+ (slot-definition-type slotd) nil)))
+ (when unbound-method
+ (let ((unbound-value (funcall unbound-method (slot-definition-type slotd))))
+ #'(lambda (object)
+ (let ((value (funcall reader-function object)))
+ (if (eq value unbound-value)
+ (slot-unbound (class-of object) object (slot-definition-name slotd))
+ value)))))))
+
+ ((let ((boundp-function (compute-slot-boundp-function slotd)))
+ #'(lambda (object)
+ (if (funcall boundp-function object)
+ (funcall reader-function object)
+ (slot-unbound (class-of object) object (slot-definition-name slotd))))))))))
+
+(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
+ (declare (ignore signal-unbound-p))
+ (let ((getter (slot-value slotd 'getter)))
+ #-sbcl getter
+ #+sbcl
+ (etypecase getter
+ (symbol #'(lambda (object) (funcall getter object)))
+ (function getter))))