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 ;;; functions, macros, and special forms
  22 (defmethod documentation ((x function) (doc-type (eql 't)))
  23   (fun-doc x))
  24
  25 (defmethod documentation ((x function) (doc-type (eql 'function)))
  26   (fun-doc x))
  27
  28 (defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
  29   (awhen (compiler-macro-function x)
  30     (documentation it t)))
  31
  32 (defmethod documentation ((x list) (doc-type (eql 'function)))
  33   (when (legal-fun-name-p x)
  34     (or (random-documentation x 'function)
  35         (when (fboundp x)
  36           (fun-doc (fdefinition x))))))
  37
  38 (defmethod documentation ((x symbol) (doc-type (eql 'function)))
  39   (when (legal-fun-name-p x)
  40     (or (random-documentation x 'function)
  41         ;; Nothing under the name, check the function object.
  42         (when (fboundp x)
  43           (fun-doc (or (macro-function x) (fdefinition x)))))))
  44
  45 (defmethod documentation ((x symbol) (doc-type (eql 'compiler-macro)))
  46   (awhen (compiler-macro-function x)
  47     (documentation it t)))
  48
  49 (defmethod documentation ((x symbol) (doc-type (eql 'setf)))
  50   (fdocumentation x 'setf))
  51
  52 (defmethod documentation ((x symbol) (doc-type (eql 'optimize)))
  53   (random-documentation x 'optimize))
  54
  55 (defmethod (setf documentation) (new-value (x function) (doc-type (eql 't)))
  56   (setf (fun-doc x) new-value))
  57
  58 (defmethod (setf documentation) (new-value (x function) (doc-type (eql 'function)))
  59   (setf (fun-doc x) new-value))
  60
  61 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
  62   (when (legal-fun-name-p x)
  63     (setf (random-documentation x 'function) new-value)))
  64
  65 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
  66   (awhen (compiler-macro-function x)
  67     (setf (documentation it t) new-value)))
  68
  69 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
  70   (when (legal-fun-name-p x)
  71     (setf (random-documentation x 'function) new-value)))
  72
  73 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'compiler-macro)))
  74   (awhen (compiler-macro-function x)
  75     (setf (documentation it t) new-value)))
  76
  77 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
  78   (setf (fdocumentation x 'setf) 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   (fdocumentation (class-name x) 'type))
 130
 131 (defmethod documentation ((x structure-class) (doc-type (eql 'type)))
 132   (fdocumentation (class-name x) 'type))
 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 ;;; although the CLHS doesn't mention this, it is reasonable to assume
 141 ;;; that parallel treatment of condition-class was intended (if
 142 ;;; condition-class is in fact not implemented as a standard-class or
 143 ;;; structure-class).
 144 (defmethod documentation ((x condition-class) (doc-type (eql 't)))
 145   (fdocumentation (class-name x) 'type))
 146
 147 (defmethod documentation ((x condition-class) (doc-type (eql 'type)))
 148   (fdocumentation (class-name x) 'type))
 149
 150 (defmethod documentation ((x symbol) (doc-type (eql 'type)))
 151   (or (fdocumentation x 'type)
 152       (let ((class (find-class x nil)))
 153         (when class
 154           (slot-value class '%documentation)))))
 155
 156 (defmethod documentation ((x symbol) (doc-type (eql 'structure)))
 157   (fdocumentation x 'structure))
 158
 159 (defmethod (setf documentation) (new-value
 160                                  (x structure-class)
 161                                  (doc-type (eql 't)))
 162   (setf (fdocumentation (class-name x) 'type) new-value))
 163
 164 (defmethod (setf documentation) (new-value
 165                                  (x structure-class)
 166                                  (doc-type (eql 'type)))
 167   (setf (fdocumentation (class-name x) 'type) new-value))
 168
 169 (defmethod (setf documentation) (new-value
 170                                  (x standard-class)
 171                                  (doc-type (eql 't)))
 172   (setf (slot-value x '%documentation) new-value))
 173
 174 (defmethod (setf documentation) (new-value
 175                                  (x standard-class)
 176                                  (doc-type (eql 'type)))
 177   (setf (slot-value x '%documentation) new-value))
 178
 179 (defmethod (setf documentation) (new-value
 180                                  (x condition-class)
 181                                  (doc-type (eql 't)))
 182   (setf (fdocumentation (class-name x) 'type) new-value))
 183
 184 (defmethod (setf documentation) (new-value
 185                                  (x condition-class)
 186                                  (doc-type (eql 'type)))
 187   (setf (fdocumentation (class-name x) 'type) new-value))
 188
 189 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
 190   (if (or (structure-type-p x) (condition-type-p x))
 191       (setf (fdocumentation x 'type) new-value)
 192       (let ((class (find-class x nil)))
 193         (if class
 194             (setf (slot-value class '%documentation) new-value)
 195             (setf (fdocumentation x 'type) new-value)))))
 196
 197 (defmethod (setf documentation) (new-value
 198                                  (x symbol)
 199                                  (doc-type (eql 'structure)))
 200   (setf (fdocumentation x 'structure) new-value))
 201 \f
 202 ;;; variables
 203 (defmethod documentation ((x symbol) (doc-type (eql 'variable)))
 204   (fdocumentation x 'variable))
 205
 206 (defmethod (setf documentation) (new-value
 207                                  (x symbol)
 208                                  (doc-type (eql 'variable)))
 209   (setf (fdocumentation x 'variable) new-value))
 210 \f
 211 ;;; default if DOC-TYPE doesn't match one of the specified types
 212 (defmethod documentation (object doc-type)
 213   (warn "unsupported DOCUMENTATION: type ~S for object of type ~S"
 214         doc-type
 215         (type-of object))
 216   nil)
 217
 218 ;;; default if DOC-TYPE doesn't match one of the specified types
 219 (defmethod (setf documentation) (new-value object doc-type)
 220   ;; CMU CL made this an error, but since ANSI says that even for supported
 221   ;; doc types an implementation is permitted to discard docs at any time
 222   ;; for any reason, this feels to me more like a warning. -- WHN 19991214
 223   (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S"
 224         doc-type
 225         (type-of object))
 226   new-value)
 227
 228 ;;; extra-standard methods, for getting at slot documentation
 229 (defmethod documentation ((slotd standard-slot-definition) (doc-type (eql 't)))
 230   (declare (ignore doc-type))
 231   (slot-value slotd '%documentation))
 232
 233 (defmethod (setf documentation)
 234     (new-value (slotd standard-slot-definition) (doc-type (eql 't)))
 235   (declare (ignore doc-type))
 236   (setf (slot-value slotd '%documentation) new-value))
 237 \f
 238 ;;; Now that we have created the machinery for setting documentation, we can
 239 ;;; set the documentation for the machinery for setting documentation.
 240 #+sb-doc
 241 (setf (documentation 'documentation 'function)
 242       "Return the documentation string of Doc-Type for X, or NIL if none
 243 exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, SETF, and T.
 244
 245 Function documentation is stored separately for function names and objects:
 246 DEFUN, LAMBDA, &co create function objects with the specified documentation
 247 strings.
 248
 249  \(SETF (DOCUMENTATION NAME 'FUNCTION) STRING)
 250
 251 sets the documentation string stored under the specified name, and
 252
 253  \(SETF (DOCUMENTATION FUNC T) STRING)
 254
 255 sets the documentation string stored in the function object.
 256
 257  \(DOCUMENTATION NAME 'FUNCTION)
 258
 259 returns the documentation stored under the function name if any, and
 260 falls back on the documentation in the function object if necessary.")