1;;; documentation.lisp 2;;; 3;;; Copyright (C) 2003-2007 Peter Graves 4;;; Copyright (C) 2010-2013 Mark Evenson 5;;; 6;;; This program is free software; you can redistribute it and/or 7;;; modify it under the terms of the GNU General Public License 8;;; as published by the Free Software Foundation; either version 2 9;;; of the License, or (at your option) any later version. 10;;; 11;;; This program is distributed in the hope that it will be useful, 12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14;;; GNU General Public License for more details. 15;;; 16;;; You should have received a copy of the GNU General Public License 17;;; along with this program; if not, write to the Free Software 18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 19;;; 20;;; As a special exception, the copyright holders of this library give you 21;;; permission to link this library with independent modules to produce an 22;;; executable, regardless of the license terms of these independent 23;;; modules, and to copy and distribute the resulting executable under 24;;; terms of your choice, provided that you also meet, for each linked 25;;; independent module, the terms and conditions of the license of that 26;;; module. An independent module is a module which is not derived from 27;;; or based on this library. If you modify this library, you may extend 28;;; this exception to your version of the library, but you are not 29;;; obligated to do so. If you do not wish to do so, delete this 30;;; exception statement from your version. 31 32 33(in-package #:mop) 34 35(require "CLOS") 36 37(defgeneric documentation (x doc-type) 38 (:method ((x symbol) doc-type) 39 (%documentation x doc-type)) 40 (:method ((x function) doc-type) 41 (%documentation x doc-type))) 42 43(defgeneric (setf documentation) (new-value x doc-type) 44 (:method (new-value (x symbol) doc-type) 45 (%set-documentation x doc-type new-value)) 46 (:method (new-value (x function) doc-type) 47 (%set-documentation x doc-type new-value))) 48 49 50;; FIXME This should be a weak hashtable! 51(defvar *list-documentation-hashtable* (make-hash-table :test #'equal)) 52 53(defmethod documentation ((x list) (doc-type (eql 'function))) 54 (let ((alist (gethash x *list-documentation-hashtable*))) 55 (and alist (cdr (assoc doc-type alist))))) 56 57(defmethod documentation ((x list) (doc-type (eql 'compiler-macro))) 58 (let ((alist (gethash x *list-documentation-hashtable*))) 59 (and alist (cdr (assoc doc-type alist))))) 60 61(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) 62 (let* ((alist (gethash x *list-documentation-hashtable*)) 63 (entry (and alist (assoc doc-type alist)))) 64 (cond 65 (entry (setf (cdr entry) new-value)) 66 (t (setf (gethash x *list-documentation-hashtable*) 67 (push (cons doc-type new-value) alist))))) 68 new-value) 69 70(defmethod (setf documentation) (new-value (x list) 71 (doc-type (eql 'compiler-macro))) 72 (let* ((alist (gethash x *list-documentation-hashtable*)) 73 (entry (and alist (assoc doc-type alist)))) 74 (cond 75 (entry (setf (cdr entry) new-value)) 76 (t (setf (gethash x *list-documentation-hashtable*) 77 (push (cons doc-type new-value) alist))))) 78 new-value) 79 80(defmethod documentation ((x class) (doc-type (eql 't))) 81 (class-documentation x)) 82 83(defmethod documentation ((x class) (doc-type (eql 'type))) 84 (class-documentation x)) 85 86(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't))) 87 (%set-class-documentation x new-value)) 88 89(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type))) 90 (%set-class-documentation x new-value)) 91 92(defmethod documentation ((x structure-class) (doc-type (eql 't))) 93 (%documentation x t)) 94 95(defmethod documentation ((x structure-class) (doc-type (eql 'type))) 96 (%documentation x t)) 97 98(defmethod (setf documentation) (new-value (x structure-class) 99 (doc-type (eql 't))) 100 (%set-documentation x t new-value)) 101 102(defmethod (setf documentation) (new-value (x structure-class) 103 (doc-type (eql 'type))) 104 (%set-documentation x t new-value)) 105 106(defmethod documentation ((x standard-generic-function) (doc-type (eql 't))) 107 (std-slot-value x 'sys::%documentation)) 108 109(defmethod (setf documentation) (new-value (x standard-generic-function) 110 (doc-type (eql 't))) 111 (setf (std-slot-value x 'sys::%documentation) new-value)) 112 113(defmethod documentation ((x standard-generic-function) 114 (doc-type (eql 'function))) 115 (std-slot-value x 'sys::%documentation)) 116 117(defmethod (setf documentation) (new-value (x standard-generic-function) 118 (doc-type (eql 'function))) 119 (setf (std-slot-value x 'sys::%documentation) new-value)) 120 121(defmethod documentation ((x standard-method) (doc-type (eql 't))) 122 (method-documentation x)) 123 124(defmethod (setf documentation) (new-value (x standard-method) 125 (doc-type (eql 't))) 126 (setf (method-documentation x) new-value)) 127 128(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't))) 129 (slot-definition-documentation x)) 130 131(defmethod (setf documentation) (new-value (x standard-slot-definition) 132 (doc-type (eql 't))) 133 (setf (slot-definition-documentation x) new-value)) 134 135(defmethod documentation ((x package) (doc-type (eql 't))) 136 (%documentation x doc-type)) 137 138(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't))) 139 (%set-documentation x doc-type new-value)) 140 141(defmethod documentation ((x symbol) (doc-type (eql 'function))) 142 (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) 143 (documentation (fdefinition x) doc-type) 144 (%documentation x doc-type))) 145 146(defmethod (setf documentation) (new-value (x symbol) 147 (doc-type (eql 'function))) 148 (if (and (fboundp x) (typep (fdefinition x) 'generic-function)) 149 (setf (documentation (fdefinition x) 'function) new-value) 150 (%set-documentation x 'function new-value))) 151 152(defmethod documentation ((x symbol) (doc-type (eql 'type))) 153 (let ((class (find-class x nil))) 154 (if class 155 (documentation class t) 156 (%documentation x 'type)))) 157 158(defmethod documentation ((x symbol) (doc-type (eql 'structure))) 159 (%documentation x 'structure)) 160 161(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type))) 162 (let ((class (find-class x nil))) 163 (if class 164 (setf (documentation class t) new-value) 165 (%set-documentation x 'type new-value)))) 166 167(defmethod (setf documentation) (new-value (x symbol) 168 (doc-type (eql 'structure))) 169 (%set-documentation x 'structure new-value)) 170