1;;;; implementation of CL:DOCUMENTATION 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5 6;;;; This software is in the public domain and is provided with absolutely no 7;;;; warranty. See the COPYING and CREDITS files for more information. 8 9(in-package "SB-C") ; FIXME: not the best package for FDOCUMENTATION 10 11;;; FDOCUMENTATION refers to STRUCTURE-CLASS which has only a skeletal 12;;; representation during cross-compilation. Better to define this late. 13(defun fdocumentation (x doc-type) 14 (case doc-type 15 (variable 16 (typecase x 17 (symbol (values (info :variable :documentation x))))) 18 (function 19 ;; Unused 20 (error "FUNCTION doc-type is not supported.")) 21 (structure 22 (typecase x 23 (symbol (cond 24 ((eq (info :type :kind x) :instance) 25 (values (info :type :documentation x))) 26 ((info :typed-structure :info x) 27 (values (info :typed-structure :documentation x))))))) 28 (type 29 (typecase x 30 (structure-class (values (info :type :documentation (class-name x)))) 31 (t (and (typep x 'symbol) (values (info :type :documentation x)))))) 32 (setf (values (info :setf :documentation x))) 33 ((t) 34 (typecase x 35 (function (%fun-doc x)) 36 (package (package-doc-string x)) 37 (structure-class (values (info :type :documentation (class-name x)))) 38 ((or symbol cons) 39 (random-documentation x doc-type)))) 40 (t 41 (when (typep x '(or symbol cons)) 42 (random-documentation x doc-type))))) 43 44(in-package "SB-PCL") 45 46(defun fun-doc (x) 47 (if (typep x 'generic-function) 48 (slot-value x '%documentation) 49 (%fun-doc x))) 50 51(defun (setf fun-doc) (new-value x) 52 (if (typep x 'generic-function) 53 (setf (slot-value x '%documentation) new-value) 54 (setf (%fun-doc x) new-value))) 55 56(defun set-function-name-documentation (name documentation) 57 (aver name) 58 (cond ((not (legal-fun-name-p name)) 59 nil) 60 ((not (equal (sb-c::real-function-name name) name)) 61 (setf (random-documentation name 'function) documentation)) 62 (t 63 (setf (fun-doc (or (and (symbolp name) 64 (macro-function name)) 65 (fdefinition name))) 66 documentation))) 67 documentation) 68 69;;; Generic behavior 70 71(defmethod (setf documentation) :around (new-value (x (eql nil)) doc-type) 72 (style-warn "Ignoring doc-type ~a for ~a." doc-type nil) 73 new-value) 74 75;;; default if DOC-TYPE doesn't match one of the specified types 76(defmethod documentation (object doc-type) 77 (warn "unsupported DOCUMENTATION: doc-type ~S for object of type ~S" 78 doc-type (type-of object)) 79 nil) 80 81;;; default if DOC-TYPE doesn't match one of the specified types 82(defmethod (setf documentation) (new-value object doc-type) 83 ;; CMU CL made this an error, but since ANSI says that even for supported 84 ;; doc types an implementation is permitted to discard docs at any time 85 ;; for any reason, this feels to me more like a warning. -- WHN 19991214 86 (warn "discarding unsupported DOCUMENTATION: doc-type ~S for object of type ~S" 87 doc-type (type-of object)) 88 new-value) 89 90;;; Deprecation note 91 92(defun maybe-add-deprecation-note (namespace name documentation) 93 (unless (member namespace '(function variable type)) 94 (return-from maybe-add-deprecation-note documentation)) 95 (binding* (((state since replacements) 96 (deprecated-thing-p namespace name)) 97 (note (when state 98 (with-simple-output-to-string (stream) 99 (sb-impl::print-deprecation-message 100 namespace name (first since) (second since) 101 replacements stream))))) 102 (cond 103 ((and documentation note) 104 (concatenate 105 'string note #.(format nil "~2%") documentation)) 106 (documentation) 107 (note)))) 108 109(defmethod documentation :around ((x t) (doc-type t)) 110 (let ((namespace (cond 111 ((typep x 'function) 112 'function) 113 ((eq doc-type 'compiler-macro) 114 'function) 115 ((typep x 'class) 116 'type) 117 ((eq doc-type 'structure) 118 'type) 119 (t 120 doc-type))) 121 (name (cond 122 ((typep x 'function) 123 (%fun-name x)) 124 ((typep x 'class) 125 (class-name x)) 126 (t 127 x))) 128 (documentation (call-next-method))) 129 (maybe-add-deprecation-note namespace name documentation))) 130 131;;; functions, macros, and special forms 132 133(flet ((maybe-function-documentation (name) 134 (cond 135 ((not (legal-fun-name-p name))) 136 ((random-documentation name 'function)) 137 ;; Nothing under the name, check the function object. 138 ((fboundp name) 139 (fun-doc (cond 140 ((and (symbolp name) (special-operator-p name)) 141 (fdefinition name)) 142 ((and (symbolp name) (macro-function name))) 143 ((fdefinition name)))))))) 144 145 (defmethod documentation ((x function) (doc-type (eql 't))) 146 (fun-doc x)) 147 148 (defmethod documentation ((x function) (doc-type (eql 'function))) 149 (fun-doc x)) 150 151 (defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) 152 (awhen (compiler-macro-function x) 153 (documentation it t))) 154 155 (defmethod documentation ((x list) (doc-type (eql 'function))) 156 (maybe-function-documentation x)) 157 158 (defmethod documentation ((x symbol) (doc-type (eql 'function))) 159 (maybe-function-documentation x)) 160 161 (defmethod documentation ((x symbol) (doc-type (eql 'compiler-macro))) 162 (awhen (compiler-macro-function x) 163 (documentation it t))) 164 165 (defmethod documentation ((x symbol) (doc-type (eql 'setf))) 166 (fdocumentation x 'setf))) 167 168(defmethod documentation ((x symbol) (doc-type (eql 'optimize))) 169 (random-documentation x 'optimize)) 170 171(defmethod (setf documentation) (new-value (x function) (doc-type (eql 't))) 172 (setf (fun-doc x) new-value)) 173 174(defmethod (setf documentation) (new-value (x function) (doc-type (eql 'function))) 175 (setf (fun-doc x) new-value)) 176 177(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) 178 (set-function-name-documentation x new-value)) 179 180(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro))) 181 (awhen (compiler-macro-function x) 182 (setf (documentation it t) new-value))) 183 184(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function))) 185 (set-function-name-documentation x new-value)) 186 187(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'compiler-macro))) 188 (awhen (compiler-macro-function x) 189 (setf (documentation it t) new-value))) 190 191(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf))) 192 (setf (fdocumentation x 'setf) new-value)) 193 194;;; method combinations 195(defmethod documentation ((x method-combination) (doc-type (eql 't))) 196 (slot-value x '%documentation)) 197 198(defmethod documentation 199 ((x method-combination) (doc-type (eql 'method-combination))) 200 (slot-value x '%documentation)) 201 202(defmethod documentation ((x symbol) (doc-type (eql 'method-combination))) 203 (random-documentation x 'method-combination)) 204 205(defmethod (setf documentation) 206 (new-value (x method-combination) (doc-type (eql 't))) 207 (setf (slot-value x '%documentation) new-value)) 208 209(defmethod (setf documentation) 210 (new-value (x method-combination) (doc-type (eql 'method-combination))) 211 (setf (slot-value x '%documentation) new-value)) 212 213(defmethod (setf documentation) 214 (new-value (x symbol) (doc-type (eql 'method-combination))) 215 (setf (random-documentation x 'method-combination) new-value)) 216 217;;; methods 218(defmethod documentation ((x standard-method) (doc-type (eql 't))) 219 (slot-value x '%documentation)) 220 221(defmethod (setf documentation) 222 (new-value (x standard-method) (doc-type (eql 't))) 223 (setf (slot-value x '%documentation) new-value)) 224 225;;; packages 226 227;;; KLUDGE: It's nasty having things like this accessor 228;;; (PACKAGE-DOC-STRING) floating around out in this mostly-unrelated 229;;; source file. Perhaps it would be better to support WARM-INIT-FORMS 230;;; by analogy with the existing !COLD-INIT-FORMS and have them be 231;;; EVAL'ed after basic warm load is done? That way things like this 232;;; could be defined alongside the other code which does low-level 233;;; hacking of packages.. -- WHN 19991203 234 235(defmethod documentation ((x package) (doc-type (eql 't))) 236 (package-doc-string x)) 237 238(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) 239 (setf (package-doc-string x) new-value)) 240 241;;; types, classes, and structure names 242 243(macrolet 244 ((define-type-documentation-methods (specializer get-form set-form) 245 `(progn 246 (defmethod documentation ((x ,specializer) (doc-type (eql 't))) 247 ,get-form) 248 249 (defmethod documentation ((x ,specializer) (doc-type (eql 'type))) 250 (documentation x t)) 251 252 (defmethod (setf documentation) (new-value 253 (x ,specializer) 254 (doc-type (eql 't))) 255 ,set-form) 256 257 (defmethod (setf documentation) (new-value 258 (x ,specializer) 259 (doc-type (eql 'type))) 260 (setf (documentation x 't) new-value)))) 261 (define-type-documentation-lookup-methods (doc-type) 262 `(progn 263 (defmethod documentation ((x symbol) (doc-type (eql ',doc-type))) 264 (acond 265 ((find-class x nil) 266 (documentation it t)) 267 (t 268 (fdocumentation x ',doc-type)))) 269 270 (defmethod (setf documentation) (new-value 271 (x symbol) 272 (doc-type (eql ',doc-type))) 273 (acond 274 ((find-class x nil) 275 (setf (documentation it t) new-value)) 276 (t 277 (setf (fdocumentation x ',doc-type) new-value))))))) 278 279 (define-type-documentation-methods structure-class 280 (fdocumentation (class-name x) 'type) 281 (setf (fdocumentation (class-name x) 'type) new-value)) 282 283 (define-type-documentation-methods class 284 (slot-value x '%documentation) 285 (setf (slot-value x '%documentation) new-value)) 286 287 ;; although the CLHS doesn't mention this, it is reasonable to 288 ;; assume that parallel treatment of condition-class was intended 289 ;; (if condition-class is in fact not implemented as a 290 ;; standard-class or structure-class). 291 (define-type-documentation-methods condition-class 292 (fdocumentation (class-name x) 'type) 293 (setf (fdocumentation (class-name x) 'type) new-value)) 294 295 (define-type-documentation-lookup-methods type) 296 (define-type-documentation-lookup-methods structure)) 297 298 299;;; variables 300(defmethod documentation ((x symbol) (doc-type (eql 'variable))) 301 (fdocumentation x 'variable)) 302 303(defmethod (setf documentation) (new-value 304 (x symbol) 305 (doc-type (eql 'variable))) 306 (setf (fdocumentation x 'variable) new-value)) 307 308;;; extra-standard methods, for getting at slot documentation 309(defmethod documentation ((slotd standard-slot-definition) (doc-type (eql 't))) 310 (declare (ignore doc-type)) 311 (slot-value slotd '%documentation)) 312 313(defmethod (setf documentation) 314 (new-value (slotd standard-slot-definition) (doc-type (eql 't))) 315 (declare (ignore doc-type)) 316 (setf (slot-value slotd '%documentation) new-value)) 317 318;;; Now that we have created the machinery for setting documentation, we can 319;;; set the documentation for the machinery for setting documentation. 320#+sb-doc 321(setf (documentation 'documentation 'function) 322 "Return the documentation string of Doc-Type for X, or NIL if none 323exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, SETF, and T. 324 325Function documentation is stored separately for function names and objects: 326DEFUN, LAMBDA, &co create function objects with the specified documentation 327strings. 328 329 \(SETF (DOCUMENTATION NAME 'FUNCTION) STRING) 330 331sets the documentation string stored under the specified name, and 332 333 \(SETF (DOCUMENTATION FUNC T) STRING) 334 335sets the documentation string stored in the function object. 336 337 \(DOCUMENTATION NAME 'FUNCTION) 338 339returns the documentation stored under the function name if any, and 340falls back on the documentation in the function object if necessary.") 341