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.")