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