0.9.5.58:
[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 ;;; FIXME: Lots of bare calls to INFO here could be handled
12 ;;; more cleanly by calling the FDOCUMENTATION function instead.
13
14 ;;; functions, macros, and special forms
15 (defmethod documentation ((x function) (doc-type (eql 't)))
16   (if (typep x 'generic-function)
17       (slot-value x 'documentation)
18       (%fun-doc x)))
19
20 (defmethod documentation ((x function) (doc-type (eql 'function)))
21   (if (typep x 'generic-function)
22       (slot-value x 'documentation)
23       (%fun-doc x)))
24
25 (defmethod documentation ((x list) (doc-type (eql 'function)))
26   (and (legal-fun-name-p x)
27        (fboundp x)
28        (documentation (fdefinition x) t)))
29
30 (defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
31   (random-documentation x 'compiler-macro))
32
33 (defmethod documentation ((x symbol) (doc-type (eql 'function)))
34   (or (values (info :function :documentation x))
35       ;; Try the pcl function documentation.
36       (and (fboundp x) (documentation (fdefinition x) t))))
37
38 (defmethod documentation ((x symbol) (doc-type (eql 'compiler-macro)))
39   (random-documentation x 'compiler-macro))
40
41 (defmethod documentation ((x symbol) (doc-type (eql 'setf)))
42   (values (info :setf :documentation x)))
43
44 (defmethod (setf documentation) (new-value (x function) (doc-type (eql 't)))
45   (if (typep x 'generic-function)
46       (setf (slot-value x 'documentation) new-value)
47       (let ((name (%fun-name x)))
48         (when (and name (typep name '(or symbol cons)))
49           (setf (info :function :documentation name) new-value))))
50   new-value)
51
52 (defmethod (setf documentation)
53     (new-value (x function) (doc-type (eql 'function)))
54   (if (typep x 'generic-function)
55       (setf (slot-value x 'documentation) new-value)
56       (let ((name (%fun-name x)))
57         (when (and name (typep name '(or symbol cons)))
58           (setf (info :function :documentation name) new-value))))
59   new-value)
60
61 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
62   (setf (info :function :documentation x) new-value))
63
64 (defmethod (setf documentation)
65     (new-value (x list) (doc-type (eql 'compiler-macro)))
66   (setf (random-documentation x 'compiler-macro) new-value))
67
68 (defmethod (setf documentation) (new-value
69                                  (x symbol)
70                                  (doc-type (eql 'function)))
71   (setf (info :function :documentation x) new-value))
72
73 (defmethod (setf documentation)
74     (new-value (x symbol) (doc-type (eql 'compiler-macro)))
75   (setf (random-documentation x 'compiler-macro) new-value))
76
77 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
78   (setf (info :setf :documentation x) new-value))
79 \f
80 ;;; method combinations
81 (defmethod documentation ((x method-combination) (doc-type (eql 't)))
82   (slot-value x 'documentation))
83
84 (defmethod documentation
85     ((x method-combination) (doc-type (eql 'method-combination)))
86   (slot-value x 'documentation))
87
88 (defmethod documentation ((x symbol) (doc-type (eql 'method-combination)))
89   (random-documentation x 'method-combination))
90
91 (defmethod (setf documentation)
92     (new-value (x method-combination) (doc-type (eql 't)))
93   (setf (slot-value x 'documentation) new-value))
94
95 (defmethod (setf documentation)
96     (new-value (x method-combination) (doc-type (eql 'method-combination)))
97   (setf (slot-value x 'documentation) new-value))
98
99 (defmethod (setf documentation)
100     (new-value (x symbol) (doc-type (eql 'method-combination)))
101   (setf (random-documentation x 'method-combination) new-value))
102 \f
103 ;;; methods
104 (defmethod documentation ((x standard-method) (doc-type (eql 't)))
105   (slot-value x 'documentation))
106
107 (defmethod (setf documentation)
108     (new-value (x standard-method) (doc-type (eql 't)))
109   (setf (slot-value x 'documentation) new-value))
110 \f
111 ;;; packages
112
113 ;;; KLUDGE: It's nasty having things like this accessor
114 ;;; (PACKAGE-DOC-STRING) floating around out in this mostly-unrelated
115 ;;; source file. Perhaps it would be better to support WARM-INIT-FORMS
116 ;;; by analogy with the existing !COLD-INIT-FORMS and have them be
117 ;;; EVAL'ed after basic warm load is done? That way things like this
118 ;;; could be defined alongside the other code which does low-level
119 ;;; hacking of packages.. -- WHN 19991203
120
121 (defmethod documentation ((x package) (doc-type (eql 't)))
122   (package-doc-string x))
123
124 (defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
125   (setf (package-doc-string x) new-value))
126 \f
127 ;;; types, classes, and structure names
128 (defmethod documentation ((x structure-class) (doc-type (eql 't)))
129   (values (info :type :documentation (class-name x))))
130
131 (defmethod documentation ((x structure-class) (doc-type (eql 'type)))
132   (values (info :type :documentation (class-name x))))
133
134 (defmethod documentation ((x standard-class) (doc-type (eql 't)))
135   (slot-value x 'documentation))
136
137 (defmethod documentation ((x standard-class) (doc-type (eql 'type)))
138   (slot-value x 'documentation))
139
140 (defmethod documentation ((x symbol) (doc-type (eql 'type)))
141   (or (values (info :type :documentation x))
142       (let ((class (find-class x nil)))
143         (when class
144           (slot-value class 'documentation)))))
145
146 (defmethod documentation ((x symbol) (doc-type (eql 'structure)))
147   (cond ((eq (info :type :kind x) :instance)
148          (values (info :type :documentation x)))
149         ((info :typed-structure :info x)
150          (values (info :typed-structure :documentation x)))
151         (t
152          (error "~S is not the name of a structure type." x))))
153
154 (defmethod (setf documentation) (new-value
155                                  (x structure-class)
156                                  (doc-type (eql 't)))
157   (setf (info :type :documentation (class-name x)) new-value))
158
159 (defmethod (setf documentation) (new-value
160                                  (x structure-class)
161                                  (doc-type (eql 'type)))
162   (setf (info :type :documentation (class-name x)) new-value))
163
164 (defmethod (setf documentation) (new-value
165                                  (x standard-class)
166                                  (doc-type (eql 't)))
167   (setf (slot-value x 'documentation) new-value))
168
169 (defmethod (setf documentation) (new-value
170                                  (x standard-class)
171                                  (doc-type (eql 'type)))
172   (setf (slot-value x 'documentation) new-value))
173
174 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
175   (if (or (structure-type-p x) (condition-type-p x))
176       (setf (info :type :documentation x) new-value)
177       (let ((class (find-class x nil)))
178         (if class
179             (setf (slot-value class 'documentation) new-value)
180             (setf (info :type :documentation x) new-value)))))
181
182 (defmethod (setf documentation) (new-value
183                                  (x symbol)
184                                  (doc-type (eql 'structure)))
185   (cond ((eq (info :type :kind x) :instance)
186          (setf (info :type :documentation x) new-value))
187         ((info :typed-structure :info x)
188          (setf (info :typed-structure :documentation x) new-value))
189         (t
190          (error "~S is not the name of a structure type." x))))
191
192 \f
193 ;;; variables
194 (defmethod documentation ((x symbol) (doc-type (eql 'variable)))
195   (values (info :variable :documentation x)))
196
197 (defmethod (setf documentation) (new-value
198                                  (x symbol)
199                                  (doc-type (eql 'variable)))
200   (setf (info :variable :documentation x) new-value))
201 \f
202 ;;; default if DOC-TYPE doesn't match one of the specified types
203 (defmethod documentation (object doc-type)
204   (warn "unsupported DOCUMENTATION: type ~S for object ~S"
205         doc-type
206         (type-of object))
207   nil)
208
209 ;;; default if DOC-TYPE doesn't match one of the specified types
210 (defmethod (setf documentation) (new-value object doc-type)
211   ;; CMU CL made this an error, but since ANSI says that even for supported
212   ;; doc types an implementation is permitted to discard docs at any time
213   ;; for any reason, this feels to me more like a warning. -- WHN 19991214
214   (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S"
215         doc-type
216         (type-of object))
217   new-value)
218
219 ;;; extra-standard methods, for getting at slot documentation
220 (defmethod documentation ((slotd standard-slot-definition) (doc-type (eql 't)))
221   (declare (ignore doc-type))
222   (slot-value slotd 'documentation))
223
224 (defmethod (setf documentation)
225     (new-value (slotd standard-slot-definition) (doc-type (eql 't)))
226   (declare (ignore doc-type))
227   (setf (slot-value slotd 'documentation) new-value))
228 \f
229 ;;; Now that we have created the machinery for setting documentation, we can
230 ;;; set the documentation for the machinery for setting documentation.
231 #+sb-doc
232 (setf (documentation 'documentation 'function)
233       "Return the documentation string of Doc-Type for X, or NIL if
234   none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
235   SETF, and T.")