From: Juho Snellman Date: Mon, 15 Jan 2007 23:23:14 +0000 (+0000) Subject: 1.0.1.29: Documentation strings for autogenerated accessors X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a782418abea0bdb5d59d7d0cca9592459fe90832;p=sbcl.git 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 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -371,12 +371,6 @@ ;;;; 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 @@ ;;;; 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 --- 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)))))) (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 --- 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 --- 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"