1.0.1.29: Documentation strings for autogenerated accessors

        When generating CLOS accessors, use the :documentation of the
        slot for the docstring of the method (Patch by Troels
        Henriksen)

diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp
index 516ed6f..e3379e2 100644 (file)
--- a/src/pcl/generic-functions.lisp
+++ b/src/pcl/generic-functions.lisp
@@ -371,12 +371,6 @@
 \f
 ;;;; 3 arguments
 
-(defgeneric add-boundp-method (class generic-function slot-name))
-
-(defgeneric add-reader-method (class generic-function slot-name))
-
-(defgeneric add-writer-method (class generic-function slot-name))
-
 (defgeneric (setf class-slot-value) (nv class slot-name))
 
 ;;; CMUCL comment (from Gerd Moellmann/Pierre Mai, 2002-10-19):
@@ -415,6 +409,12 @@
 \f
 ;;;; 4 arguments
 
+(defgeneric add-boundp-method (class generic-function slot-name slot-documentation))
+
+(defgeneric add-reader-method (class generic-function slot-name slot-documentation))
+
+(defgeneric add-writer-method (class generic-function slot-name slot-documentation))
+
 (defgeneric make-method-lambda (proto-generic-function
                                 proto-method
                                 lambda-expression

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index a602fe7..502fe7c 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -697,7 +697,7 @@
   (fix-slot-accessors class dslotds 'remove))
 
 (defun fix-slot-accessors (class dslotds add/remove)
-  (flet ((fix (gfspec name r/w)
+  (flet ((fix (gfspec name r/w doc)
            (let ((gf (cond ((eq add/remove 'add)
                             (or (find-generic-function gfspec nil)
                                 (ensure-generic-function
@@ -709,17 +709,18 @@
              (when gf
                (case r/w
                  (r (if (eq add/remove 'add)
-                        (add-reader-method class gf name)
+                        (add-reader-method class gf name doc)
                         (remove-reader-method class gf)))
                  (w (if (eq add/remove 'add)
-                        (add-writer-method class gf name)
+                        (add-writer-method class gf name doc)
                         (remove-writer-method class gf))))))))
     (dolist (dslotd dslotds)
-      (let ((slot-name (slot-definition-name dslotd)))
+      (let ((slot-name (slot-definition-name dslotd))
+            (slot-doc (%slot-definition-documentation dslotd)))
         (dolist (r (slot-definition-readers dslotd))
-          (fix r slot-name 'r))
+          (fix r slot-name 'r slot-doc))
         (dolist (w (slot-definition-writers dslotd))
-          (fix w slot-name 'w))))))
+          (fix w slot-name 'w slot-doc))))))
 \f
 (defun add-direct-subclasses (class supers)
   (dolist (super supers)
@@ -1110,14 +1111,14 @@
   (declare (ignore direct-slot initargs))
   (find-class 'standard-reader-method))
 
-(defmethod add-reader-method ((class slot-class) generic-function slot-name)
+(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation)
   (add-method generic-function
               (make-a-method 'standard-reader-method
                              ()
                              (list (or (class-name class) 'object))
                              (list class)
                              (make-reader-method-function class slot-name)
-                             "automatically generated reader method"
+                             (or slot-documentation "automatically generated reader method")
                              :slot-name slot-name
                              :object-class class
                              :method-class-function #'reader-method-class)))
@@ -1126,19 +1127,19 @@
   (declare (ignore direct-slot initargs))
   (find-class 'standard-writer-method))
 
-(defmethod add-writer-method ((class slot-class) generic-function slot-name)
+(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation)
   (add-method generic-function
               (make-a-method 'standard-writer-method
                              ()
                              (list 'new-value (or (class-name class) 'object))
                              (list *the-class-t* class)
                              (make-writer-method-function class slot-name)
-                             "automatically generated writer method"
+                             (or slot-documentation "automatically generated writer method")
                              :slot-name slot-name
                              :object-class class
                              :method-class-function #'writer-method-class)))
 
-(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation)
   (add-method generic-function
               (make-a-method (constantly (find-class 'standard-boundp-method))
                              class
@@ -1146,7 +1147,7 @@
                              (list (or (class-name class) 'object))
                              (list class)
                              (make-boundp-method-function class slot-name)
-                             "automatically generated boundp method"
+                             (or slot-documentation "automatically generated boundp method")
                              slot-name)))
 
 (defmethod remove-reader-method ((class slot-class) generic-function)

diff --git a/tests/clos-1.impure.lisp b/tests/clos-1.impure.lisp
index 09b66f0..dc00ae4 100644 (file)
--- a/tests/clos-1.impure.lisp
+++ b/tests/clos-1.impure.lisp
@@ -87,3 +87,17 @@
     (assert (raises-error? (funcall fun *foo*)))
     (assert (= 3 (b-of *foo*)))
     (assert (raises-error? (c-of *foo*)))))
+
+;; test that :documentation argument to slot specifiers are used as
+;; the docstrings of accessor methods.
+(defclass foo ()
+  ((a :reader a-of :documentation "docstring for A")
+   (b :writer set-b-of :documentation "docstring for B")
+   (c :accessor c :documentation  "docstring for C")))
+
+(flet ((doc (fun)
+         (documentation fun t)))
+  (assert (string= (doc (find-method #'a-of nil '((foo)))) "docstring for A"))
+  (assert (string= (doc (find-method #'set-b-of nil '(t (foo)))) "docstring for B"))
+  (assert (string= (doc (find-method #'c nil '((foo)))) "docstring for C"))
+  (assert (string= (doc (find-method #'(setf c) nil '(t (foo)))) "docstring for C")))

diff --git a/version.lisp-expr b/version.lisp-expr
index 50aa6da..cebbb42 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.1.28"
+"1.0.1.29"