1 ;;;; implementation of CL:DOCUMENTATION
3 ;;;; This software is part of the SBCL system. See the README file for
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.
9 (in-package "SB-C") ; FIXME: not the best package for FDOCUMENTATION
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
)
17 (symbol (values (info :variable
:documentation x
)))))
18 ;; FUNCTION is not used at the momemnt, just here for symmetry.
22 ((and (legal-fun-name-p x
) (fboundp x
))
23 (%fun-doc
(or (and (symbolp x
) (macro-function x
))
28 ((eq (info :type
:kind x
) :instance
)
29 (values (info :type
:documentation x
)))
30 ((info :typed-structure
:info x
)
31 (values (info :typed-structure
:documentation x
)))))))
34 (structure-class (values (info :type
:documentation
(class-name x
))))
35 (t (and (typep x
'symbol
) (values (info :type
:documentation x
))))))
36 (setf (values (info :setf
:documentation x
)))
39 (function (%fun-doc x
))
40 (package (package-doc-string x
))
41 (structure-class (values (info :type
:documentation
(class-name x
))))
43 (random-documentation x doc-type
))))
45 (when (typep x
'(or symbol cons
))
46 (random-documentation x doc-type
)))))
51 (if (typep x
'generic-function
)
52 (slot-value x
'%documentation
)
55 (defun (setf fun-doc
) (new-value x
)
56 (if (typep x
'generic-function
)
57 (setf (slot-value x
'%documentation
) new-value
)
58 (setf (%fun-doc x
) new-value
)))
60 ;;; FIXME: There's already fun-name in code/describe.lisp, but it's
61 ;;; loaded after PCL, so it cannot be used, because we set
62 ;;; some documentation at the end of this file.
64 (if (typep x
'generic-function
)
65 (sb-pcl:generic-function-name x
)
68 (defun real-function-name (name)
69 ;; Resolve the actual name of the function named by NAME
70 ;; e.g. (setf (name-function 'x) #'car)
71 ;; (real-function-name 'x) => CAR
72 (cond ((not (fboundp name
))
75 (special-operator-p name
))
76 (%fun-name
(fdefinition name
)))
78 (macro-function name
))
79 (let ((name (%fun-name
(macro-function name
))))
81 (eq (car name
) 'macro-function
)
84 (fun-name (fdefinition name
)))))
86 (defun ignore-nil-doc (type)
87 (style-warn "Ignoring doc-type ~a for ~a."
90 (defun set-function-name-documentation (name documentation
)
92 (ignore-nil-doc 'function
))
93 ((not (legal-fun-name-p name
))
95 ((not (equal (real-function-name name
) name
))
96 (setf (random-documentation name
'function
) documentation
))
98 (setf (fun-doc (or (and (symbolp name
)
99 (macro-function name
))
106 (defun maybe-add-deprecation-note (namespace name documentation
)
107 (unless (member namespace
'(function variable type
))
108 (return-from maybe-add-deprecation-note documentation
))
109 (binding* (((state since replacements
)
110 (deprecated-thing-p namespace name
))
112 (with-output-to-string (stream)
113 (sb-impl::print-deprecation-message
114 namespace name
(first since
) (second since
)
115 replacements stream
)))))
117 ((and documentation note
)
119 'string note
#.
(format nil
"~2%") documentation
))
123 (defmethod documentation :around
((x t
) (doc-type t
))
124 (let ((namespace (cond
127 ((eq doc-type
'compiler-macro
)
131 ((eq doc-type
'structure
)
142 (documentation (call-next-method)))
143 (maybe-add-deprecation-note namespace name documentation
)))
145 ;;; functions, macros, and special forms
147 (flet ((maybe-function-documentation (name)
149 ((not (legal-fun-name-p name
)))
150 ((random-documentation name
'function
))
151 ;; Nothing under the name, check the function object.
154 ((and (symbolp name
) (special-operator-p name
))
156 ((and (symbolp name
) (macro-function name
)))
157 ((fdefinition name
))))))))
159 (defmethod documentation ((x function
) (doc-type (eql 't
)))
162 (defmethod documentation ((x function
) (doc-type (eql 'function
)))
165 (defmethod documentation ((x list
) (doc-type (eql 'compiler-macro
)))
166 (awhen (compiler-macro-function x
)
167 (documentation it t
)))
169 (defmethod documentation ((x list
) (doc-type (eql 'function
)))
170 (maybe-function-documentation x
))
172 (defmethod documentation ((x symbol
) (doc-type (eql 'function
)))
173 (maybe-function-documentation x
))
175 (defmethod documentation ((x symbol
) (doc-type (eql 'compiler-macro
)))
176 (awhen (compiler-macro-function x
)
177 (documentation it t
)))
179 (defmethod documentation ((x symbol
) (doc-type (eql 'setf
)))
180 (fdocumentation x
'setf
)))
182 (defmethod documentation ((x symbol
) (doc-type (eql 'optimize
)))
183 (random-documentation x
'optimize
))
185 (defmethod (setf documentation
) (new-value (x function
) (doc-type (eql 't
)))
186 (setf (fun-doc x
) new-value
))
188 (defmethod (setf documentation
) (new-value (x function
) (doc-type (eql 'function
)))
189 (setf (fun-doc x
) new-value
))
191 (defmethod (setf documentation
) (new-value (x list
) (doc-type (eql 'function
)))
192 (set-function-name-documentation x new-value
))
194 (defmethod (setf documentation
) (new-value (x list
) (doc-type (eql 'compiler-macro
)))
195 (awhen (compiler-macro-function x
)
196 (setf (documentation it t
) new-value
)))
198 (defmethod (setf documentation
) (new-value (x symbol
) (doc-type (eql 'function
)))
199 (set-function-name-documentation x new-value
))
201 (defmethod (setf documentation
) (new-value (x symbol
) (doc-type (eql 'compiler-macro
)))
203 (awhen (compiler-macro-function x
)
204 (setf (documentation it t
) new-value
)))
206 (ignore-nil-doc 'compiler-macro
)
209 (defmethod (setf documentation
) (new-value (x symbol
) (doc-type (eql 'setf
)))
211 (setf (fdocumentation x
'setf
) new-value
))
213 (ignore-nil-doc 'setf
)
216 ;;; method combinations
217 (defmethod documentation ((x method-combination
) (doc-type (eql 't
)))
218 (slot-value x
'%documentation
))
220 (defmethod documentation
221 ((x method-combination
) (doc-type (eql 'method-combination
)))
222 (slot-value x
'%documentation
))
224 (defmethod documentation ((x symbol
) (doc-type (eql 'method-combination
)))
225 (random-documentation x
'method-combination
))
227 (defmethod (setf documentation
)
228 (new-value (x method-combination
) (doc-type (eql 't
)))
229 (setf (slot-value x
'%documentation
) new-value
))
231 (defmethod (setf documentation
)
232 (new-value (x method-combination
) (doc-type (eql 'method-combination
)))
233 (setf (slot-value x
'%documentation
) new-value
))
235 (defmethod (setf documentation
)
236 (new-value (x symbol
) (doc-type (eql 'method-combination
)))
238 (setf (random-documentation x
'method-combination
) new-value
))
240 (ignore-nil-doc 'method-combination
)
244 (defmethod documentation ((x standard-method
) (doc-type (eql 't
)))
245 (slot-value x
'%documentation
))
247 (defmethod (setf documentation
)
248 (new-value (x standard-method
) (doc-type (eql 't
)))
249 (setf (slot-value x
'%documentation
) new-value
))
253 ;;; KLUDGE: It's nasty having things like this accessor
254 ;;; (PACKAGE-DOC-STRING) floating around out in this mostly-unrelated
255 ;;; source file. Perhaps it would be better to support WARM-INIT-FORMS
256 ;;; by analogy with the existing !COLD-INIT-FORMS and have them be
257 ;;; EVAL'ed after basic warm load is done? That way things like this
258 ;;; could be defined alongside the other code which does low-level
259 ;;; hacking of packages.. -- WHN 19991203
261 (defmethod documentation ((x package
) (doc-type (eql 't
)))
262 (package-doc-string x
))
264 (defmethod (setf documentation
) (new-value (x package
) (doc-type (eql 't
)))
265 (setf (package-doc-string x
) new-value
))
267 ;;; types, classes, and structure names
268 (defmethod documentation ((x structure-class
) (doc-type (eql 't
)))
269 (fdocumentation (class-name x
) 'type
))
271 (defmethod documentation ((x structure-class
) (doc-type (eql 'type
)))
272 (fdocumentation (class-name x
) 'type
))
274 (defmethod documentation ((x class
) (doc-type (eql 't
)))
275 (slot-value x
'%documentation
))
277 (defmethod documentation ((x class
) (doc-type (eql 'type
))) ; TODO setf
278 (slot-value x
'%documentation
))
280 (defmethod (setf documentation
) (new-value
283 (setf (slot-value x
'%documentation
) new-value
))
285 (defmethod (setf documentation
) (new-value
287 (doc-type (eql 'type
)))
288 (setf (slot-value x
'%documentation
) new-value
))
290 ;;; although the CLHS doesn't mention this, it is reasonable to assume
291 ;;; that parallel treatment of condition-class was intended (if
292 ;;; condition-class is in fact not implemented as a standard-class or
293 ;;; structure-class).
294 (defmethod documentation ((x condition-class
) (doc-type (eql 't
)))
295 (fdocumentation (class-name x
) 'type
))
297 (defmethod documentation ((x condition-class
) (doc-type (eql 'type
)))
298 (fdocumentation (class-name x
) 'type
))
300 (defmethod documentation ((x symbol
) (doc-type (eql 'type
)))
301 (or (fdocumentation x
'type
)
302 (awhen (find-class x nil
)
303 (slot-value it
'%documentation
))))
305 (defmethod documentation ((x symbol
) (doc-type (eql 'structure
)))
306 (fdocumentation x
'structure
))
308 (defmethod (setf documentation
) (new-value
311 (setf (fdocumentation (class-name x
) 'type
) new-value
))
313 (defmethod (setf documentation
) (new-value
315 (doc-type (eql 'type
)))
316 (setf (fdocumentation (class-name x
) 'type
) new-value
))
318 (defmethod (setf documentation
) (new-value
321 (setf (fdocumentation (class-name x
) 'type
) new-value
))
323 (defmethod (setf documentation
) (new-value
325 (doc-type (eql 'type
)))
326 (setf (fdocumentation (class-name x
) 'type
) new-value
))
328 (defmethod (setf documentation
) (new-value (x symbol
) (doc-type (eql 'type
)))
329 (if (or (structure-type-p x
) (condition-type-p x
))
330 (setf (fdocumentation x
'type
) new-value
)
331 (let ((class (find-class x nil
)))
333 (setf (slot-value class
'%documentation
) new-value
)
334 (setf (fdocumentation x
'type
) new-value
)))))
336 (defmethod (setf documentation
) (new-value
338 (doc-type (eql 'structure
)))
340 (setf (fdocumentation x
'structure
) new-value
))
342 (ignore-nil-doc 'structure
)
346 (defmethod documentation ((x symbol
) (doc-type (eql 'variable
)))
347 (fdocumentation x
'variable
))
349 (defmethod (setf documentation
) (new-value
351 (doc-type (eql 'variable
)))
353 (setf (fdocumentation x
'variable
) new-value
))
355 (ignore-nil-doc 'variable
)
358 ;;; default if DOC-TYPE doesn't match one of the specified types
359 (defmethod documentation (object doc-type
)
360 (warn "unsupported DOCUMENTATION: doc-type ~S for object of type ~S"
365 ;;; default if DOC-TYPE doesn't match one of the specified types
366 (defmethod (setf documentation
) (new-value object doc-type
)
367 ;; CMU CL made this an error, but since ANSI says that even for supported
368 ;; doc types an implementation is permitted to discard docs at any time
369 ;; for any reason, this feels to me more like a warning. -- WHN 19991214
370 (warn "discarding unsupported DOCUMENTATION: doc-type ~S for object of type ~S"
375 ;;; extra-standard methods, for getting at slot documentation
376 (defmethod documentation ((slotd standard-slot-definition
) (doc-type (eql 't
)))
377 (declare (ignore doc-type
))
378 (slot-value slotd
'%documentation
))
380 (defmethod (setf documentation
)
381 (new-value (slotd standard-slot-definition
) (doc-type (eql 't
)))
382 (declare (ignore doc-type
))
383 (setf (slot-value slotd
'%documentation
) new-value
))
385 ;;; Now that we have created the machinery for setting documentation, we can
386 ;;; set the documentation for the machinery for setting documentation.
388 (setf (documentation 'documentation
'function
)
389 "Return the documentation string of Doc-Type for X, or NIL if none
390 exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, SETF, and T.
392 Function documentation is stored separately for function names and objects:
393 DEFUN, LAMBDA, &co create function objects with the specified documentation
396 \(SETF (DOCUMENTATION NAME 'FUNCTION) STRING)
398 sets the documentation string stored under the specified name, and
400 \(SETF (DOCUMENTATION FUNC T) STRING)
402 sets the documentation string stored in the function object.
404 \(DOCUMENTATION NAME 'FUNCTION)
406 returns the documentation stored under the function name if any, and
407 falls back on the documentation in the function object if necessary.")