source: branches/streams/abcl/src/org/armedbear/lisp/documentation.lisp

Last change on this file was 14454, checked in by rschlatte, 12 years ago

Move standard-generic-function slot accessors from Java to Lisp

  • incremented fasl version since set-generic-function-initial-methods, generic-function-documentation are gone
File size: 6.7 KB
Line 
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))
Note: See TracBrowser for help on using the repository browser.