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 (sb-int:file-comment
  10   "$Header$")
  11
  12 (in-package "SB-PCL")
  13
  14 ;;; Note some cases are handled by the documentation methods in
  15 ;;; std-class.lisp.
  16 ;;; FIXME: Those should probably be moved into this file too.
  17
  18 ;;; FIXME: Lots of bare calls to INFO here could be handled
  19 ;;; more cleanly by calling the FDOCUMENTATION function instead.
  20
  21 ;;; FIXME: Neither SBCL nor Debian CMU CL 2.4.17 handles
  22 ;;;   (DEFUN FOO ())
  23 ;;;   (SETF (DOCUMENTATION #'FOO 'FUNCTION) "testing")
  24 ;;; They fail with
  25 ;;;   Can't change the documentation of #<interpreted function FOO {900BF51}>.
  26 ;;; The coverage of the DOCUMENTATION methods ought to be systematically
  27 ;;; compared to the ANSI specification of DOCUMENTATION.
  28
  29 ;;; functions, macros, and special forms
  30 (defmethod documentation ((x function) (doc-type (eql 't)))
  31   (sb-impl::function-doc x))
  32
  33 (defmethod documentation ((x function) (doc-type (eql 'function)))
  34   (sb-impl::function-doc x))
  35
  36 (defmethod documentation ((x list) (doc-type (eql 'function)))
  37   ;; FIXME: could test harder to see whether it's a SETF function name,
  38   ;; then call WARN
  39   (when (eq (first x) 'setf)    ; Give up if not a setf function name.
  40     (or (values (sb-int:info :setf :documentation (second x)))
  41         ;; Try the pcl function documentation.
  42         (and (fboundp x) (documentation (fdefinition x) 't)))))
  43
  44 (defmethod documentation ((x symbol) (doc-type (eql 'function)))
  45   (or (values (sb-int:info :function :documentation x))
  46       ;; Try the pcl function documentation.
  47       (and (fboundp x) (documentation (fdefinition x) 't))))
  48
  49 (defmethod documentation ((x symbol) (doc-type (eql 'setf)))
  50   (values (sb-int:info :setf :documentation x)))
  51
  52 (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
  53   (setf (sb-int:info :setf :documentation (cadr x)) new-value))
  54
  55 (defmethod (setf documentation) (new-value
  56                                  (x symbol)
  57                                  (doc-type (eql 'function)))
  58   (setf (sb-int:info :function :documentation x) new-value))
  59
  60 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
  61   (setf (sb-int:info :setf :documentation x) new-value))
  62
  63 ;;; packages
  64 (defmethod documentation ((x package) (doc-type (eql 't)))
  65   (sb-impl::package-doc-string x))
  66
  67 (defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
  68   (setf (sb-impl::package-doc-string x) new-value))
  69 ;;; KLUDGE: It's nasty having things like this accessor floating around
  70 ;;; out in this mostly-unrelated source file. Perhaps it would be
  71 ;;; better to support WARM-INIT-FORMS by analogy with the existing
  72 ;;; !COLD-INIT-FORMS and have them be EVAL'ed after basic warm load is
  73 ;;; done? That way things like this could be defined alongside the
  74 ;;; other code which does low-level hacking of packages.. -- WHN 19991203
  75
  76 ;;; types, classes, and structure names
  77 (defmethod documentation ((x cl:structure-class) (doc-type (eql 't)))
  78   (values (sb-int:info :type :documentation (cl:class-name x))))
  79
  80 (defmethod documentation ((x structure-class) (doc-type (eql 't)))
  81   (values (sb-int:info :type :documentation (class-name x))))
  82
  83 (defmethod documentation ((x cl:standard-class) (doc-type (eql 't)))
  84   (or (values (sb-int:info :type :documentation (cl:class-name x)))
  85       (let ((pcl-class (sb-kernel:class-pcl-class x)))
  86         (and pcl-class (plist-value pcl-class 'documentation)))))
  87
  88 (defmethod documentation ((x cl:structure-class) (doc-type (eql 'type)))
  89   (values (sb-int:info :type :documentation (cl:class-name x))))
  90
  91 (defmethod documentation ((x structure-class) (doc-type (eql 'type)))
  92   (values (sb-int:info :type :documentation (class-name x))))
  93
  94 (defmethod documentation ((x cl:standard-class) (doc-type (eql 'type)))
  95   (or (values (sb-int:info :type :documentation (cl:class-name x)))
  96       (let ((pcl-class (sb-kernel:class-pcl-class x)))
  97         (and pcl-class (plist-value pcl-class 'documentation)))))
  98
  99 (defmethod documentation ((x symbol) (doc-type (eql 'type)))
 100   (or (values (sb-int:info :type :documentation x))
 101       (let ((class (find-class x nil)))
 102         (when class
 103           (plist-value class 'documentation)))))
 104
 105 (defmethod documentation ((x symbol) (doc-type (eql 'structure)))
 106   (when (eq (sb-int:info :type :kind x) :instance)
 107     (values (sb-int:info :type :documentation x))))
 108
 109 (defmethod (setf documentation) (new-value
 110                                  (x cl:structure-class)
 111                                  (doc-type (eql 't)))
 112   (setf (sb-int:info :type :documentation (cl:class-name x)) new-value))
 113
 114 (defmethod (setf documentation) (new-value
 115                                  (x structure-class)
 116                                  (doc-type (eql 't)))
 117   (setf (sb-int:info :type :documentation (class-name x)) new-value))
 118
 119 (defmethod (setf documentation) (new-value
 120                                  (x cl:structure-class)
 121                                  (doc-type (eql 'type)))
 122   (setf (sb-int:info :type :documentation (cl:class-name x)) new-value))
 123
 124 (defmethod (setf documentation) (new-value
 125                                  (x structure-class)
 126                                  (doc-type (eql 'type)))
 127   (setf (sb-int:info :type :documentation (class-name x)) new-value))
 128
 129 (defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
 130   (if (structure-type-p x)      ; Catch structures first.
 131       (setf (sb-int:info :type :documentation x) new-value)
 132       (let ((class (find-class x nil)))
 133         (if class
 134             (setf (plist-value class 'documentation) new-value)
 135             (setf (sb-int:info :type :documentation x) new-value)))))
 136
 137 (defmethod (setf documentation) (new-value
 138                                  (x symbol)
 139                                  (doc-type (eql 'structure)))
 140   (unless (eq (sb-int:info :type :kind x) :instance)
 141     (error "~S is not the name of a structure type." x))
 142   (setf (sb-int:info :type :documentation x) new-value))
 143
 144 ;;; variables
 145 (defmethod documentation ((x symbol) (doc-type (eql 'variable)))
 146   (values (sb-int:info :variable :documentation x)))
 147
 148 (defmethod (setf documentation) (new-value
 149                                  (x symbol)
 150                                  (doc-type (eql 'variable)))
 151   (setf (sb-int:info :variable :documentation x) new-value))
 152
 153 ;;; miscellaneous documentation. Compiler-macro documentation is stored
 154 ;;; as random-documentation and handled here.
 155 (defmethod documentation ((x symbol) (doc-type symbol))
 156   (cdr (assoc doc-type
 157               (values (sb-int:info :random-documentation :stuff x)))))
 158
 159 (defmethod (setf documentation) (new-value (x symbol) (doc-type symbol))
 160   (let ((pair (assoc doc-type (sb-int:info :random-documentation :stuff x))))
 161     (if pair
 162         (setf (cdr pair) new-value)
 163         (push (cons doc-type new-value)
 164               (sb-int:info :random-documentation :stuff x))))
 165   new-value)
 166
 167 ;;; FIXME: The ((X SYMBOL) (DOC-TYPE SYMBOL)) method and its setf method should
 168 ;;; have parallel versions which accept LIST-valued X arguments (for function
 169 ;;; names in the (SETF FOO) style).
 170
 171 ;;; Now that we have created the machinery for setting documentation, we can
 172 ;;; set the documentation for the machinery for setting documentation.
 173 #+sb-doc
 174 (setf (documentation 'documentation 'function)
 175       "Return the documentation string of Doc-Type for X, or NIL if
 176   none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
 177   SETF, and T.")