-(defmacro slot-symbol (slot-name type)
- `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
- (or (get ,slot-name ',(ecase type
- (reader 'reader-symbol)
- (writer 'writer-symbol)
- (boundp 'boundp-symbol)))
- (intern (format nil "~A ~A slot ~A"
- (package-name (symbol-package ,slot-name))
- (symbol-name ,slot-name)
- ,(symbol-name type))
- *slot-accessor-name-package*))
- (progn
- (error "Non-symbol and non-interned symbol slot name accessors~
- are not yet implemented.")
- ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
- )))
-
-(defun slot-reader-symbol (slot-name)
- (slot-symbol slot-name reader))
-
-(defun slot-writer-symbol (slot-name)
- (slot-symbol slot-name writer))
-
-(defun slot-boundp-symbol (slot-name)
- (slot-symbol slot-name boundp))
-
-(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)))