Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / pcl / documentation.lisp
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-PCL")
10
11 (defun fun-doc (x)
12   (if (typep x 'generic-function)
13       (slot-value x '%documentation)
14       (%fun-doc x)))
15
16 (defun (setf fun-doc) (new-value x)
17   (if (typep x 'generic-function)
18       (setf (slot-value x '%documentation) new-value)
19       (setf (%fun-doc x) new-value)))
20
21 ;;; FIXME: There's already fun-name in code/describe.lisp, but it's
22 ;;; loaded after PCL, so it cannot be used, because we set
23 ;;; some documentation at the end of this file.
24 (defun fun-name (x)
25   (if (typep x 'generic-function)
26       (sb-pcl:generic-function-name x)
27       (%fun-name x)))
28
29 (defun real-function-name (name)
30   ;; Resolve the actual name of the function named by NAME
31   ;; e.g. (setf (name-function 'x) #'car)
32   ;; (real-function-name 'x) => CAR
33   (cond ((not (fboundp name))
34          nil)
35         ((and (symbolp name)
36               (special-operator-p name))
37          (%fun-name (fdefinition name)))
38         ((and (symbolp name)
39               (macro-function name))
40          (let ((name (%fun-name (macro-function name))))
41            (and (consp name)
42                 (eq (car name) 'macro-function)
43                 (cadr name))))
44         (t
45          (fun-name (fdefinition name)))))
46
47 (defun ignore-nil-doc (type)
48   (style-warn "Ignoring documentation of type ~a for ~a."
49               type nil))
50
51 (defun set-function-name-documentation (name documentation)
52   (cond ((not name)
53          (ignore-nil-doc 'function))
54         ((not (legal-fun-name-p name))
55          nil)
56         ((not (equal (real-function-name name) name))
57          (setf (random-documentation name 'function) documentation))
58         (t
59          (setf (fun-doc (or (and (symbolp name)
60                                  (macro-function name))
61                             (fdefinition name)))
62                documentation)))
63   documentation)
64
65 ;;; functions, macros, and special forms
66 (defmethod documentation ((x function) (doc-type (eql 't)))
67   (fun-doc x))
68
69 (defmethod documentation ((x function) (doc-type (eql 'function)))
70   (fun-doc x))
71
72 (defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
73   (awhen (compiler-macro-function x)
74     (documentation it t)))
75
76 (defmethod documentation ((x list) (doc-type (eql 'function)))
77   (when (legal-fun-name-p x)
78     (or (random-documentation x 'function)
79         (when (fboundp x)
80           (fun-doc (fdefinition x))))))
81
82 (defmethod documentation ((x symbol) (doc-type (eql 'function)))
83   (when (legal-fun-name-p x)
84     (or (random-documentation x 'function)
85         ;; Nothing under the name, check the function object.
86         (when (fboundp x)
87           (fun-doc (if (special-operator-p x)
88                        (fdefinition x)
89                        (or (macro-function x)
90                            (fdefinition x))))))))
91
92 (defmethod documentation ((x symbol) (doc-type (eql 'compiler-macro)))
93   (awhen (compiler-macro-function x)
94     (documentation it t)))
95
96 (defmethod documentation ((x symbol) (doc-type (eql 'setf)))
97   (fdocumentation x 'setf))
98
99 (defmethod documentation ((x symbol) (doc-type (eql 'optimize)))
100   (random-documentation x 'optimize))
101
102 (defmethod (setf documentation) (new-value (x function) (doc-type (eql 't)))
103   (setf (fun-doc x) new-value))
104
105 (defmethod (setf documentation) (new-value (x function) (doc-type (eql 'function)))
106   (setf (fun-doc x) new-value))
107
108 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
109   (set-function-name-documentation x new-value))
110
111 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
112   (awhen (compiler-macro-function x)
113     (setf (documentation it t) new-value)))
114
115 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
116   (set-function-name-documentation x new-value))
117
118 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'compiler-macro)))
119   (cond (x
120          (awhen (compiler-macro-function x)
121            (setf (documentation it t) new-value)))
122         (t
123          (ignore-nil-doc 'compiler-macro)
124          new-value)))
125
126 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
127   (cond (x
128          (setf (fdocumentation x 'setf) new-value))
129         (t
130          (ignore-nil-doc 'setf)
131          new-value)))
132 \f
133 ;;; method combinations
134 (defmethod documentation ((x method-combination) (doc-type (eql 't)))
135   (slot-value x '%documentation))
136
137 (defmethod documentation
138     ((x method-combination) (doc-type (eql 'method-combination)))
139   (slot-value x '%documentation))
140
141 (defmethod documentation ((x symbol) (doc-type (eql 'method-combination)))
142   (random-documentation x 'method-combination))
143
144 (defmethod (setf documentation)
145     (new-value (x method-combination) (doc-type (eql 't)))
146   (setf (slot-value x '%documentation) new-value))
147
148 (defmethod (setf documentation)
149     (new-value (x method-combination) (doc-type (eql 'method-combination)))
150   (setf (slot-value x '%documentation) new-value))
151
152 (defmethod (setf documentation)
153     (new-value (x symbol) (doc-type (eql 'method-combination)))
154   (cond (x
155          (setf (random-documentation x 'method-combination) new-value))
156         (t
157          (ignore-nil-doc 'method-combination)
158          new-value)))
159 \f
160 ;;; methods
161 (defmethod documentation ((x standard-method) (doc-type (eql 't)))
162   (slot-value x '%documentation))
163
164 (defmethod (setf documentation)
165     (new-value (x standard-method) (doc-type (eql 't)))
166   (setf (slot-value x '%documentation) new-value))
167 \f
168 ;;; packages
169
170 ;;; KLUDGE: It's nasty having things like this accessor
171 ;;; (PACKAGE-DOC-STRING) floating around out in this mostly-unrelated
172 ;;; source file. Perhaps it would be better to support WARM-INIT-FORMS
173 ;;; by analogy with the existing !COLD-INIT-FORMS and have them be
174 ;;; EVAL'ed after basic warm load is done? That way things like this
175 ;;; could be defined alongside the other code which does low-level
176 ;;; hacking of packages.. -- WHN 19991203
177
178 (defmethod documentation ((x package) (doc-type (eql 't)))
179   (package-doc-string x))
180
181 (defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
182   (setf (package-doc-string x) new-value))
183 \f
184 ;;; types, classes, and structure names
185 (defmethod documentation ((x structure-class) (doc-type (eql 't)))
186   (fdocumentation (class-name x) 'type))
187
188 (defmethod documentation ((x structure-class) (doc-type (eql 'type)))
189   (fdocumentation (class-name x) 'type))
190
191 (defmethod documentation ((x standard-class) (doc-type (eql 't)))
192   (slot-value x '%documentation))
193
194 (defmethod documentation ((x standard-class) (doc-type (eql 'type)))
195   (slot-value x '%documentation))
196
197 ;;; although the CLHS doesn't mention this, it is reasonable to assume
198 ;;; that parallel treatment of condition-class was intended (if
199 ;;; condition-class is in fact not implemented as a standard-class or
200 ;;; structure-class).
201 (defmethod documentation ((x condition-class) (doc-type (eql 't)))
202   (fdocumentation (class-name x) 'type))
203
204 (defmethod documentation ((x condition-class) (doc-type (eql 'type)))
205   (fdocumentation (class-name x) 'type))
206
207 (defmethod documentation ((x symbol) (doc-type (eql 'type)))
208   (or (fdocumentation x 'type)
209       (let ((class (find-class x nil)))
210         (when class
211           (slot-value class '%documentation)))))
212
213 (defmethod documentation ((x symbol) (doc-type (eql 'structure)))
214   (fdocumentation x 'structure))
215
216 (defmethod (setf documentation) (new-value
217                                  (x structure-class)
218                                  (doc-type (eql 't)))
219   (setf (fdocumentation (class-name x) 'type) new-value))
220
221 (defmethod (setf documentation) (new-value
222                                  (x structure-class)
223                                  (doc-type (eql 'type)))
224   (setf (fdocumentation (class-name x) 'type) new-value))
225
226 (defmethod (setf documentation) (new-value
227                                  (x standard-class)
228                                  (doc-type (eql 't)))
229   (setf (slot-value x '%documentation) new-value))
230
231 (defmethod (setf documentation) (new-value
232                                  (x standard-class)
233                                  (doc-type (eql 'type)))
234   (setf (slot-value x '%documentation) new-value))
235
236 (defmethod (setf documentation) (new-value
237                                  (x condition-class)
238                                  (doc-type (eql 't)))
239   (setf (fdocumentation (class-name x) 'type) new-value))
240
241 (defmethod (setf documentation) (new-value
242                                  (x condition-class)
243                                  (doc-type (eql 'type)))
244   (setf (fdocumentation (class-name x) 'type) new-value))
245
246 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
247   (if (or (structure-type-p x) (condition-type-p x))
248       (setf (fdocumentation x 'type) new-value)
249       (let ((class (find-class x nil)))
250         (if class
251             (setf (slot-value class '%documentation) new-value)
252             (setf (fdocumentation x 'type) new-value)))))
253
254 (defmethod (setf documentation) (new-value
255                                  (x symbol)
256                                  (doc-type (eql 'structure)))
257   (cond (x
258          (setf (fdocumentation x 'structure) new-value))
259         (t
260          (ignore-nil-doc 'structure)
261          new-value)))
262 \f
263 ;;; variables
264 (defmethod documentation ((x symbol) (doc-type (eql 'variable)))
265   (fdocumentation x 'variable))
266
267 (defmethod (setf documentation) (new-value
268                                  (x symbol)
269                                  (doc-type (eql 'variable)))
270   (cond (x
271          (setf (fdocumentation x 'variable) new-value))
272         (t
273          (ignore-nil-doc 'variable)
274          new-value)))
275 \f
276 ;;; default if DOC-TYPE doesn't match one of the specified types
277 (defmethod documentation (object doc-type)
278   (warn "unsupported DOCUMENTATION: type ~S for object of type ~S"
279         doc-type
280         (type-of object))
281   nil)
282
283 ;;; default if DOC-TYPE doesn't match one of the specified types
284 (defmethod (setf documentation) (new-value object doc-type)
285   ;; CMU CL made this an error, but since ANSI says that even for supported
286   ;; doc types an implementation is permitted to discard docs at any time
287   ;; for any reason, this feels to me more like a warning. -- WHN 19991214
288   (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S"
289         doc-type
290         (type-of object))
291   new-value)
292
293 ;;; extra-standard methods, for getting at slot documentation
294 (defmethod documentation ((slotd standard-slot-definition) (doc-type (eql 't)))
295   (declare (ignore doc-type))
296   (slot-value slotd '%documentation))
297
298 (defmethod (setf documentation)
299     (new-value (slotd standard-slot-definition) (doc-type (eql 't)))
300   (declare (ignore doc-type))
301   (setf (slot-value slotd '%documentation) new-value))
302 \f
303 ;;; Now that we have created the machinery for setting documentation, we can
304 ;;; set the documentation for the machinery for setting documentation.
305 #+sb-doc
306 (setf (documentation 'documentation 'function)
307       "Return the documentation string of Doc-Type for X, or NIL if none
308 exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, SETF, and T.
309
310 Function documentation is stored separately for function names and objects:
311 DEFUN, LAMBDA, &co create function objects with the specified documentation
312 strings.
313
314  \(SETF (DOCUMENTATION NAME 'FUNCTION) STRING)
315
316 sets the documentation string stored under the specified name, and
317
318  \(SETF (DOCUMENTATION FUNC T) STRING)
319
320 sets the documentation string stored in the function object.
321
322  \(DOCUMENTATION NAME 'FUNCTION)
323
324 returns the documentation stored under the function name if any, and
325 falls back on the documentation in the function object if necessary.")