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