From: Christophe Rhodes Date: Tue, 26 Aug 2003 17:46:57 +0000 (+0000) Subject: 0.8.3.5: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c7de1989d006e0b3a4f26143b7a81c9bdb754101;p=sbcl.git 0.8.3.5: DOCUMENTATION fixes: ... make generic function documentation findable; ... systematize DOCUMENTATION support, by having one method per specified method, so adding support for STANDARD-METHODs and for METHOD-COMBINATIONs ... refactor :RANDOM-DOCUMENTATION :STUFF stuff into an auxiliary pair of functions, and use them in COMPILER-MACRO and METHOD-COMBINATION methods; ... also set documentation in LOAD-{SHORT,LONG}-METHOD-COMBINATION (there's still some leftover refactoring to be done, and maybe a systematic test suite to be written...) --- diff --git a/NEWS b/NEWS index f88e62a..33c0c57 100644 --- a/NEWS +++ b/NEWS @@ -2003,8 +2003,13 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: changes in sbcl-0.8.4 relative to sbcl-0.8.3: * fixed compiler performance when processing loops with a step >1; - * optimization: restored some effective method precomputation - (turned off by an ANSI fix in sbcl-0.8.3); the amount of + * bug fix: DOCUMENTATION now retrieves generic function + documentation. Also, DOCUMENTATION and (SETF DOCUMENTATION) + support has been systematized, and now supports the methods + specified by ANSI, along with a default method and a method for + slot documentation. (reported by Nathan Froyd) + * optimization: restored some effective method precomputation in + CLOS (turned off by an ANSI fix in sbcl-0.8.3); the amount of precomputation is now tunable. planned incompatible changes in 0.8.x: diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index cbc6f9c..7085d1f 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -78,3 +78,16 @@ (symbolp slot) (symbolp class)) (values t slot))))) + +(defun sb-pcl::random-documentation (name type) + (cdr (assoc type (info :random-documentation :stuff name)))) + +(defun sb-pcl::set-random-documentation (name type new-value) + (let ((pair (assoc type (info :random-documentation :stuff name)))) + (if pair + (setf (cdr pair) new-value) + (push (cons type new-value) + (info :random-documentation :stuff name)))) + new-value) + +(defsetf sb-pcl::random-documentation sb-pcl::set-random-documentation) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 8b034ce..6163057 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -99,6 +99,7 @@ (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) + (setf (random-documentation type 'method-combination) doc) type)) (defun short-combine-methods (type options operator ioa method doc) @@ -256,6 +257,7 @@ (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) + (setf (random-documentation type 'method-combination) doc) type)) (defmethod compute-effective-method ((generic-function generic-function) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 89177ba..84811bd 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -418,10 +418,6 @@ :accessor object-plist)) (:metaclass std-class)) -(defclass documentation-mixin (plist-mixin) - () - (:metaclass std-class)) - (defclass dependent-update-mixin (plist-mixin) () (:metaclass std-class)) @@ -429,8 +425,7 @@ ;;; The class CLASS is a specified basic class. It is the common ;;; superclass of any kind of class. That is, any class that can be a ;;; metaclass must have the class CLASS in its class precedence list. -(defclass class (documentation-mixin - dependent-update-mixin +(defclass class (dependent-update-mixin definition-source-mixin specializer) ((name @@ -454,6 +449,9 @@ (predicate-name :initform nil :reader class-predicate-name) + (documentation + :initform nil + :initarg :documentation) (finalized-p :initform nil :reader class-finalized-p))) @@ -581,7 +579,7 @@ :initarg :type :accessor slot-definition-type) (documentation - :initform "" + :initform nil :initarg :documentation) (class :initform nil @@ -686,11 +684,9 @@ :initform nil :initarg :fast-function ;no writer :reader method-fast-function) -;;; (documentation -;;; :initform nil -;;; :initarg :documentation -;;; :reader method-documentation) - )) + (documentation + :initform nil + :initarg :documentation))) (defclass standard-accessor-method (standard-method) ((slot-name :initform nil @@ -708,9 +704,11 @@ (defclass generic-function (dependent-update-mixin definition-source-mixin - documentation-mixin funcallable-standard-object) - (;; We need to make a distinction between the methods initially set + ((documentation + :initform nil + :initarg :documentation) + ;; We need to make a distinction between the methods initially set ;; up by :METHOD options to DEFGENERIC and the ones set up later by ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on ;; an already-DEFGENERICed function clears the methods set by the @@ -755,16 +753,17 @@ (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) -(defclass method-combination (standard-object) ()) +(defclass method-combination (standard-object) + ((documentation + :reader method-combination-documentation + :initform nil + :initarg :documentation))) (defclass standard-method-combination (definition-source-mixin - method-combination) + method-combination) ((type :reader method-combination-type :initarg :type) - (documentation - :reader method-combination-documentation - :initarg :documentation) (options :reader method-combination-options :initarg :options))) diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index 9c562b3..b728992 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -8,65 +8,122 @@ (in-package "SB-PCL") -;;; Note some cases are handled by the documentation methods in -;;; std-class.lisp. -;;; FIXME: Those should probably be moved into this file too. - ;;; FIXME: Lots of bare calls to INFO here could be handled ;;; more cleanly by calling the FDOCUMENTATION function instead. -;;; FIXME: Neither SBCL nor Debian CMU CL 2.4.17 handles -;;; (DEFUN FOO ()) -;;; (SETF (DOCUMENTATION #'FOO 'FUNCTION) "testing") -;;; They fail with -;;; Can't change the documentation of #. -;;; The coverage of the DOCUMENTATION methods ought to be systematically -;;; compared to the ANSI specification of DOCUMENTATION. - ;;; functions, macros, and special forms (defmethod documentation ((x function) (doc-type (eql 't))) - (%fun-doc x)) + (if (typep x 'generic-function) + (slot-value x 'documentation) + (%fun-doc x))) (defmethod documentation ((x function) (doc-type (eql 'function))) - (%fun-doc x)) + (if (typep x 'generic-function) + (slot-value x 'documentation) + (%fun-doc x))) (defmethod documentation ((x list) (doc-type (eql 'function))) (and (legal-fun-name-p x) (fboundp x) (documentation (fdefinition x) t))) +(defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) + (random-documentation x 'compiler-macro)) + (defmethod documentation ((x symbol) (doc-type (eql 'function))) (or (values (info :function :documentation x)) ;; Try the pcl function documentation. (and (fboundp x) (documentation (fdefinition x) t)))) +(defmethod documentation ((x symbol) (doc-type (eql 'compiler-macro))) + (random-documentation x 'compiler-macro)) + (defmethod documentation ((x symbol) (doc-type (eql 'setf))) (values (info :setf :documentation x))) +(defmethod (setf documentation) (new-value (x function) (doc-type (eql 't))) + (if (typep x 'generic-function) + (setf (slot-value x 'documentation) new-value) + (let ((name (%fun-name x))) + (when (and name (typep name '(or symbol cons))) + (setf (info :function :documentation name) new-value)))) + new-value) + +(defmethod (setf documentation) + (new-value (x function) (doc-type (eql 'function))) + (if (typep x 'generic-function) + (setf (slot-value x 'documentation) new-value) + (let ((name (%fun-name x))) + (when (and name (typep name '(or symbol cons))) + (setf (info :function :documentation name) new-value)))) + new-value) + (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) (setf (info :function :documentation x) new-value)) +(defmethod (setf documentation) + (new-value (x list) (doc-type (eql 'compiler-macro))) + (setf (random-documentation x 'compiler-macro) new-value)) + (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function))) (setf (info :function :documentation x) new-value)) +(defmethod (setf documentation) + (new-value (x symbol) (doc-type (eql 'compiler-macro))) + (setf (random-documentation x 'compiler-macro) new-value)) + (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf))) (setf (info :setf :documentation x) new-value)) - + +;;; method combinations +(defmethod documentation ((x method-combination) (doc-type (eql 't))) + (slot-value x 'documentation)) + +(defmethod documentation + ((x method-combination) (doc-type (eql 'method-combination))) + (slot-value x 'documentation)) + +(defmethod documentation ((x symbol) (doc-type (eql 'method-combination))) + (random-documentation x 'method-combination)) + +(defmethod (setf documentation) + (new-value (x method-combination) (doc-type (eql 't))) + (setf (slot-value x 'documentation) new-value)) + +(defmethod (setf documentation) + (new-value (x method-combination) (doc-type (eql 'method-combination))) + (setf (slot-value x 'documentation) new-value)) + +(defmethod (setf documentation) + (new-value (x symbol) (doc-type (eql 'method-combination))) + (setf (random-documentation x 'method-combination) new-value)) + +;;; methods +(defmethod documentation ((method standard-method) (doc-type (eql 't))) + (slot-value slotd 'documentation)) + +(defmethod (setf documentation) + (new-value (method standard-method) (doc-type (eql 't))) + (setf (slot-value method 'documentation) new-value)) + ;;; packages + +;;; KLUDGE: It's nasty having things like this accessor +;;; (PACKAGE-DOC-STRING) floating around out in this mostly-unrelated +;;; source file. Perhaps it would be better to support WARM-INIT-FORMS +;;; by analogy with the existing !COLD-INIT-FORMS and have them be +;;; EVAL'ed after basic warm load is done? That way things like this +;;; could be defined alongside the other code which does low-level +;;; hacking of packages.. -- WHN 19991203 + (defmethod documentation ((x package) (doc-type (eql 't))) (package-doc-string x)) (defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) (setf (package-doc-string x) new-value)) -;;; KLUDGE: It's nasty having things like this accessor floating around -;;; out in this mostly-unrelated source file. Perhaps it would be -;;; better to support WARM-INIT-FORMS by analogy with the existing -;;; !COLD-INIT-FORMS and have them be EVAL'ed after basic warm load is -;;; done? That way things like this could be defined alongside the -;;; other code which does low-level hacking of packages.. -- WHN 19991203 - + ;;; types, classes, and structure names (defmethod documentation ((x structure-class) (doc-type (eql 't))) (values (info :type :documentation (class-name x)))) @@ -74,11 +131,17 @@ (defmethod documentation ((x structure-class) (doc-type (eql 'type))) (values (info :type :documentation (class-name x)))) +(defmethod documentation ((x standard-class) (doc-type (eql 't))) + (slot-value x 'documentation)) + +(defmethod documentation ((x standard-class) (doc-type (eql 'type))) + (slot-value x 'documentation)) + (defmethod documentation ((x symbol) (doc-type (eql 'type))) (or (values (info :type :documentation x)) (let ((class (find-class x nil))) (when class - (plist-value class 'documentation))))) + (slot-value class 'documentation))))) (defmethod documentation ((x symbol) (doc-type (eql 'structure))) (when (eq (info :type :kind x) :instance) @@ -94,12 +157,22 @@ (doc-type (eql 'type))) (setf (info :type :documentation (class-name x)) new-value)) +(defmethod (setf documentation) (new-value + (x standard-class) + (doc-type (eql 't))) + (setf (slot-value x 'documentation) new-value)) + +(defmethod (setf documentation) (new-value + (x standard-class) + (doc-type (eql 'type))) + (setf (slot-value x 'documentation) new-value)) + (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) (if (or (structure-type-p x) (condition-type-p x)) (setf (info :type :documentation x) new-value) (let ((class (find-class x nil))) (if class - (setf (plist-value class 'documentation) new-value) + (setf (slot-value class 'documentation) new-value) (setf (info :type :documentation x) new-value))))) (defmethod (setf documentation) (new-value @@ -108,7 +181,7 @@ (unless (eq (info :type :kind x) :instance) (error "~S is not the name of a structure type." x)) (setf (info :type :documentation x) new-value)) - + ;;; variables (defmethod documentation ((x symbol) (doc-type (eql 'variable))) (values (info :variable :documentation x))) @@ -117,25 +190,34 @@ (x symbol) (doc-type (eql 'variable))) (setf (info :variable :documentation x) new-value)) - -;;; miscellaneous documentation. Compiler-macro documentation is stored -;;; as random-documentation and handled here. -(defmethod documentation ((x symbol) (doc-type symbol)) - (cdr (assoc doc-type - (values (info :random-documentation :stuff x))))) - -(defmethod (setf documentation) (new-value (x symbol) (doc-type symbol)) - (let ((pair (assoc doc-type (info :random-documentation :stuff x)))) - (if pair - (setf (cdr pair) new-value) - (push (cons doc-type new-value) - (info :random-documentation :stuff x)))) + +;;; default if DOC-TYPE doesn't match one of the specified types +(defmethod documentation (object doc-type) + (warn "unsupported DOCUMENTATION: type ~S for object ~S" + doc-type + (type-of object)) + nil) + +;;; default if DOC-TYPE doesn't match one of the specified types +(defmethod (setf documentation) (new-value object doc-type) + ;; CMU CL made this an error, but since ANSI says that even for supported + ;; doc types an implementation is permitted to discard docs at any time + ;; for any reason, this feels to me more like a warning. -- WHN 19991214 + (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S" + doc-type + (type-of object)) new-value) -;;; FIXME: The ((X SYMBOL) (DOC-TYPE SYMBOL)) method and its setf method should -;;; have parallel versions which accept LIST-valued X arguments (for function -;;; names in the (SETF FOO) style). +;;; extra-standard methods, for getting at slot documentation +(defmethod documentation ((slotd standard-slot-definition) (doc-type (eql 't))) + (declare (ignore doc-type)) + (slot-value slotd 'documentation)) +(defmethod (setf documentation) + (new-value (slotd standard-slot-definition) (doc-type (eql 't))) + (declare (ignore doc-type)) + (setf (slot-value slotd 'documentation) new-value)) + ;;; Now that we have created the machinery for setting documentation, we can ;;; set the documentation for the machinery for setting documentation. #+sb-doc diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index f894c21..7b64b5a 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -118,50 +118,6 @@ (defmethod slot-definition-allocation ((slotd structure-slot-definition)) :instance) -(defmethod shared-initialize :after ((object documentation-mixin) - slot-names - &key (documentation nil documentation-p)) - (declare (ignore slot-names)) - (when documentation-p - (setf (plist-value object 'documentation) documentation))) - -;;; default if DOC-TYPE doesn't match one of the specified types -(defmethod documentation (object doc-type) - (warn "unsupported DOCUMENTATION: type ~S for object ~S" - doc-type - (type-of object)) - nil) - -;;; default if DOC-TYPE doesn't match one of the specified types -(defmethod (setf documentation) (new-value object doc-type) - ;; CMU CL made this an error, but since ANSI says that even for supported - ;; doc types an implementation is permitted to discard docs at any time - ;; for any reason, this feels to me more like a warning. -- WHN 19991214 - (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S" - doc-type - (type-of object)) - new-value) - -(defmethod documentation ((object documentation-mixin) doc-type) - (declare (ignore doc-type)) - (plist-value object 'documentation)) - -(defmethod (setf documentation) (new-value - (object documentation-mixin) - doc-type) - (declare (ignore doc-type)) - (setf (plist-value object 'documentation) new-value)) - -(defmethod documentation ((slotd standard-slot-definition) doc-type) - (declare (ignore doc-type)) - (slot-value slotd 'documentation)) - -(defmethod (setf documentation) (new-value - (slotd standard-slot-definition) - doc-type) - (declare (ignore doc-type)) - (setf (slot-value slotd 'documentation) new-value)) - ;;;; various class accessors that are a little more complicated than can be ;;;; done with automatically generated reader methods diff --git a/version.lisp-expr b/version.lisp-expr index 5187c7a..0fe153f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; with something arbitrary in the fourth field, is used for CVS ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS -"0.8.3.4" +"0.8.3.5"