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