- (labels ((slot-missing-fun (slot-name type)
- (let* ((method-type (ecase type
- (slot-value 'reader-method)
- (setf 'writer-method)
- (slot-boundp 'boundp-method)))
- (initargs
- (copy-tree
- (ecase type
- (slot-value
- (make-method-function
- (lambda (obj)
- (values
- (slot-missing (class-of obj) obj slot-name
- 'slot-value)))))
- (slot-boundp
- (make-method-function
- (lambda (obj)
- (not (not
- (slot-missing (class-of obj) obj slot-name
- 'slot-boundp))))))
- (setf
- (make-method-function
- (lambda (val obj)
- (slot-missing (class-of obj) obj slot-name
- 'setf val)
- val)))))))
- (setf (getf (getf initargs :plist) :slot-name-lists)
- (list (list nil slot-name)))
- (setf (getf (getf initargs :plist) :pv-table-symbol)
- (gensym))
- (list* :method-spec (list method-type 'slot-object slot-name)
- initargs)))
- (add-slot-missing-method (gf slot-name type)
- (multiple-value-bind (class lambda-list specializers)
- (ecase type
- (slot-value
- (values 'standard-reader-method
- '(object)
- (list *the-class-slot-object*)))
- (slot-boundp
- (values 'standard-boundp-method
- '(object)
- (list *the-class-slot-object*)))
- (setf
- (values 'standard-writer-method
- '(new-value object)
- (list *the-class-t* *the-class-slot-object*))))
- (add-method gf (make-a-method class
- ()
- lambda-list
- specializers
- (slot-missing-fun slot-name type)
- "generated slot-missing method"
- slot-name)))))
- (unless (fboundp fun-name)
- (let ((gf (ensure-generic-function
- fun-name
- :lambda-list (ecase type
- ((reader boundp) '(object))
- (writer '(new-value object))))))