-(defmacro asv-funcall (sym slot-name type &rest args)
- (declare (ignore type))
- `(if (fboundp ',sym)
- (,sym ,@args)
- (no-slot ',sym ',slot-name)))
-
-(defun no-slot (sym slot-name)
- (error "No class has a slot named ~S (~S has no function binding)."
- slot-name sym))
+(defun ensure-accessor (type fun-name slot-name)
+ (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)
+ (slot-missing (class-of obj) obj slot-name
+ 'slot-value))))
+ (slot-boundp
+ (make-method-function
+ (lambda (obj)
+ (slot-missing (class-of obj) obj slot-name
+ 'slot-boundp))))
+ (setf
+ (make-method-function
+ (lambda (val obj)
+ (declare (ignore val))
+ (slot-missing (class-of obj) obj slot-name
+ 'setf))))))))
+ (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)))
+ (ecase type
+ (reader (add-slot-missing-method gf slot-name 'slot-value))
+ (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
+ (writer (add-slot-missing-method gf slot-name 'setf)))
+ (setf (plist-value gf 'slot-missing-method) t))
+ t)))