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 (if (special-operator-p x)
  44                        (fdefinition x)
  45                        (or (macro-function x)
  46                            (fdefinition x))))))))
  47
  48 (defmethod documentation ((x symbol) (doc-type (eql 'compiler-macro)))
  49   (awhen (compiler-macro-function x)
  50     (documentation it t)))
  51
  52 (defmethod documentation ((x symbol) (doc-type (eql 'setf)))
  53   (fdocumentation x 'setf))
  54
  55 (defmethod documentation ((x symbol) (doc-type (eql 'optimize)))
  56   (random-documentation x 'optimize))
  57
  58 (defmethod (setf documentation) (new-value (x function) (doc-type (eql 't)))
  59   (setf (fun-doc x) new-value))
  60
  61 (defmethod (setf documentation) (new-value (x function) (doc-type (eql 'function)))
  62   (setf (fun-doc x) new-value))
  63
  64 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
  65   (when (legal-fun-name-p x)
  66     (setf (random-documentation x 'function) new-value)))
  67
  68 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
  69   (awhen (compiler-macro-function x)
  70     (setf (documentation it t) new-value)))
  71
  72 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
  73   (when (legal-fun-name-p x)
  74     (setf (random-documentation x 'function) new-value)))
  75
  76 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'compiler-macro)))
  77   (awhen (compiler-macro-function x)
  78     (setf (documentation it t) new-value)))
  79
  80 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
  81   (setf (fdocumentation x 'setf) new-value))
  82 \f
  83 ;;; method combinations
  84 (defmethod documentation ((x method-combination) (doc-type (eql 't)))
  85   (slot-value x '%documentation))
  86
  87 (defmethod documentation
  88     ((x method-combination) (doc-type (eql 'method-combination)))
  89   (slot-value x '%documentation))
  90
  91 (defmethod documentation ((x symbol) (doc-type (eql 'method-combination)))
  92   (random-documentation x 'method-combination))
  93
  94 (defmethod (setf documentation)
  95     (new-value (x method-combination) (doc-type (eql 't)))
  96   (setf (slot-value x '%documentation) new-value))
  97
  98 (defmethod (setf documentation)
  99     (new-value (x method-combination) (doc-type (eql 'method-combination)))
 100   (setf (slot-value x '%documentation) new-value))
 101
 102 (defmethod (setf documentation)
 103     (new-value (x symbol) (doc-type (eql 'method-combination)))
 104   (setf (random-documentation x 'method-combination) new-value))
 105 \f
 106 ;;; methods
 107 (defmethod documentation ((x standard-method) (doc-type (eql 't)))
 108   (slot-value x '%documentation))
 109
 110 (defmethod (setf documentation)
 111     (new-value (x standard-method) (doc-type (eql 't)))
 112   (setf (slot-value x '%documentation) new-value))
 113 \f
 114 ;;; packages
 115
 116 ;;; KLUDGE: It's nasty having things like this accessor
 117 ;;; (PACKAGE-DOC-STRING) floating around out in this mostly-unrelated
 118 ;;; source file. Perhaps it would be better to support WARM-INIT-FORMS
 119 ;;; by analogy with the existing !COLD-INIT-FORMS and have them be
 120 ;;; EVAL'ed after basic warm load is done? That way things like this
 121 ;;; could be defined alongside the other code which does low-level
 122 ;;; hacking of packages.. -- WHN 19991203
 123
 124 (defmethod documentation ((x package) (doc-type (eql 't)))
 125   (package-doc-string x))
 126
 127 (defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
 128   (setf (package-doc-string x) new-value))
 129 \f
 130 ;;; types, classes, and structure names
 131 (defmethod documentation ((x structure-class) (doc-type (eql 't)))
 132   (fdocumentation (class-name x) 'type))
 133
 134 (defmethod documentation ((x structure-class) (doc-type (eql 'type)))
 135   (fdocumentation (class-name x) 'type))
 136
 137 (defmethod documentation ((x standard-class) (doc-type (eql 't)))
 138   (slot-value x '%documentation))
 139
 140 (defmethod documentation ((x standard-class) (doc-type (eql 'type)))
 141   (slot-value x '%documentation))
 142
 143 ;;; although the CLHS doesn't mention this, it is reasonable to assume
 144 ;;; that parallel treatment of condition-class was intended (if
 145 ;;; condition-class is in fact not implemented as a standard-class or
 146 ;;; structure-class).
 147 (defmethod documentation ((x condition-class) (doc-type (eql 't)))
 148   (fdocumentation (class-name x) 'type))
 149
 150 (defmethod documentation ((x condition-class) (doc-type (eql 'type)))
 151   (fdocumentation (class-name x) 'type))
 152
 153 (defmethod documentation ((x symbol) (doc-type (eql 'type)))
 154   (or (fdocumentation x 'type)
 155       (let ((class (find-class x nil)))
 156         (when class
 157           (slot-value class '%documentation)))))
 158
 159 (defmethod documentation ((x symbol) (doc-type (eql 'structure)))
 160   (fdocumentation x 'structure))
 161
 162 (defmethod (setf documentation) (new-value
 163                                  (x structure-class)
 164                                  (doc-type (eql 't)))
 165   (setf (fdocumentation (class-name x) 'type) new-value))
 166
 167 (defmethod (setf documentation) (new-value
 168                                  (x structure-class)
 169                                  (doc-type (eql 'type)))
 170   (setf (fdocumentation (class-name x) 'type) new-value))
 171
 172 (defmethod (setf documentation) (new-value
 173                                  (x standard-class)
 174                                  (doc-type (eql 't)))
 175   (setf (slot-value x '%documentation) new-value))
 176
 177 (defmethod (setf documentation) (new-value
 178                                  (x standard-class)
 179                                  (doc-type (eql 'type)))
 180   (setf (slot-value x '%documentation) new-value))
 181
 182 (defmethod (setf documentation) (new-value
 183                                  (x condition-class)
 184                                  (doc-type (eql 't)))
 185   (setf (fdocumentation (class-name x) 'type) new-value))
 186
 187 (defmethod (setf documentation) (new-value
 188                                  (x condition-class)
 189                                  (doc-type (eql 'type)))
 190   (setf (fdocumentation (class-name x) 'type) new-value))
 191
 192 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
 193   (if (or (structure-type-p x) (condition-type-p x))
 194       (setf (fdocumentation x 'type) new-value)
 195       (let ((class (find-class x nil)))
 196         (if class
 197             (setf (slot-value class '%documentation) new-value)
 198             (setf (fdocumentation x 'type) new-value)))))
 199
 200 (defmethod (setf documentation) (new-value
 201                                  (x symbol)
 202                                  (doc-type (eql 'structure)))
 203   (setf (fdocumentation x 'structure) new-value))
 204 \f
 205 ;;; variables
 206 (defmethod documentation ((x symbol) (doc-type (eql 'variable)))
 207   (fdocumentation x 'variable))
 208
 209 (defmethod (setf documentation) (new-value
 210                                  (x symbol)
 211                                  (doc-type (eql 'variable)))
 212   (setf (fdocumentation x 'variable) new-value))
 213 \f
 214 ;;; default if DOC-TYPE doesn't match one of the specified types
 215 (defmethod documentation (object doc-type)
 216   (warn "unsupported DOCUMENTATION: type ~S for object of type ~S"
 217         doc-type
 218         (type-of object))
 219   nil)
 220
 221 ;;; default if DOC-TYPE doesn't match one of the specified types
 222 (defmethod (setf documentation) (new-value object doc-type)
 223   ;; CMU CL made this an error, but since ANSI says that even for supported
 224   ;; doc types an implementation is permitted to discard docs at any time
 225   ;; for any reason, this feels to me more like a warning. -- WHN 19991214
 226   (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S"
 227         doc-type
 228         (type-of object))
 229   new-value)
 230
 231 ;;; extra-standard methods, for getting at slot documentation
 232 (defmethod documentation ((slotd standard-slot-definition) (doc-type (eql 't)))
 233   (declare (ignore doc-type))
 234   (slot-value slotd '%documentation))
 235
 236 (defmethod (setf documentation)
 237     (new-value (slotd standard-slot-definition) (doc-type (eql 't)))
 238   (declare (ignore doc-type))
 239   (setf (slot-value slotd '%documentation) new-value))
 240 \f
 241 ;;; Now that we have created the machinery for setting documentation, we can
 242 ;;; set the documentation for the machinery for setting documentation.
 243 #+sb-doc
 244 (setf (documentation 'documentation 'function)
 245       "Return the documentation string of Doc-Type for X, or NIL if none
 246 exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, SETF, and T.
 247
 248 Function documentation is stored separately for function names and objects:
 249 DEFUN, LAMBDA, &co create function objects with the specified documentation
 250 strings.
 251
 252  \(SETF (DOCUMENTATION NAME 'FUNCTION) STRING)
 253
 254 sets the documentation string stored under the specified name, and
 255
 256  \(SETF (DOCUMENTATION FUNC T) STRING)
 257
 258 sets the documentation string stored in the function object.
 259
 260  \(DOCUMENTATION NAME 'FUNCTION)
 261
 262 returns the documentation stored under the function name if any, and
 263 falls back on the documentation in the function object if necessary.")