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