|
|
1
|
+;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
|
|
|
2
|
+;;;
|
|
|
3
|
+;;; **********************************************************************
|
|
|
4
|
+;;; This code was written as part of the CMU Common Lisp project at
|
|
|
5
|
+;;; Carnegie Mellon University, and has been placed in the public domain.
|
|
|
6
|
+;;;
|
|
|
7
|
+(ext:file-comment
|
|
|
8
|
+ "$Header: src/code/misc.lisp $")
|
|
|
9
|
+;;;
|
|
|
10
|
+;;; **********************************************************************
|
|
|
11
|
+;;;
|
|
|
12
|
+;;; Documentation functions. Needed by pclcom.lisp
|
|
|
13
|
+(in-package "LISP")
|
|
|
14
|
+(intl:textdomain "cmucl")
|
|
|
15
|
+
|
|
|
16
|
+(export '(documentation))
|
|
|
17
|
+
|
|
|
18
|
+;;; cobbled from stuff in describe.lisp.
|
|
|
19
|
+(defun function-doc (x)
|
|
|
20
|
+ (let ((name
|
|
|
21
|
+ (case (kernel:get-type x)
|
|
|
22
|
+ (#.vm:closure-header-type
|
|
|
23
|
+ (kernel:%function-name (%closure-function x)))
|
|
|
24
|
+ ((#.vm:function-header-type #.vm:closure-function-header-type)
|
|
|
25
|
+ (kernel:%function-name x))
|
|
|
26
|
+ (#.vm:funcallable-instance-header-type
|
|
|
27
|
+ (typecase x
|
|
|
28
|
+ (kernel:byte-function
|
|
|
29
|
+ (c::byte-function-name x))
|
|
|
30
|
+ (kernel:byte-closure
|
|
|
31
|
+ (c::byte-function-name (byte-closure-function x)))
|
|
|
32
|
+ (eval:interpreted-function
|
|
|
33
|
+ (multiple-value-bind
|
|
|
34
|
+ (exp closure-p dname)
|
|
|
35
|
+ (eval:interpreted-function-lambda-expression x)
|
|
|
36
|
+ (declare (ignore exp closure-p))
|
|
|
37
|
+ dname))
|
|
|
38
|
+ (t ;; funcallable-instance
|
|
|
39
|
+ (kernel:%function-name
|
|
|
40
|
+ (kernel:funcallable-instance-function x))))))))
|
|
|
41
|
+ (when (and name (typep name '(or symbol cons)))
|
|
|
42
|
+ (values (info function documentation name)))))
|
|
|
43
|
+
|
|
|
44
|
+(defun documentation (x doc-type)
|
|
|
45
|
+ "Returns the documentation string of Doc-Type for X, or NIL if
|
|
|
46
|
+ none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
|
|
|
47
|
+ SETF, and T."
|
|
|
48
|
+ (flet (;; CMUCL random-documentation.
|
|
|
49
|
+ (try-cmucl-random-doc (x doc-type)
|
|
|
50
|
+ (declare (symbol doc-type))
|
|
|
51
|
+ (cdr (assoc doc-type
|
|
|
52
|
+ (values (info random-documentation stuff x))))))
|
|
|
53
|
+ (case doc-type
|
|
|
54
|
+ (variable
|
|
|
55
|
+ (typecase x
|
|
|
56
|
+ (symbol (values (info variable documentation x)))))
|
|
|
57
|
+ (function
|
|
|
58
|
+ (typecase x
|
|
|
59
|
+ (symbol (values (info function documentation x)))
|
|
|
60
|
+ (function (function-doc x))
|
|
|
61
|
+ (list ;; Must be '(setf symbol)
|
|
|
62
|
+ (values (info function documentation (cadr x))))))
|
|
|
63
|
+ (structure
|
|
|
64
|
+ (typecase x
|
|
|
65
|
+ (symbol (when (eq (info type kind x) :instance)
|
|
|
66
|
+ (values (info type documentation x))))))
|
|
|
67
|
+ (type
|
|
|
68
|
+ (typecase x
|
|
|
69
|
+ (kernel::structure-class (values (info type documentation (%class-name x))))
|
|
|
70
|
+ (t (and (typep x 'symbol) (values (info type documentation x))))))
|
|
|
71
|
+ (setf (info setf documentation x))
|
|
|
72
|
+ ((t)
|
|
|
73
|
+ (typecase x
|
|
|
74
|
+ (function (function-doc x))
|
|
|
75
|
+ (package (package-doc-string x))
|
|
|
76
|
+ (kernel::structure-class (values (info type documentation (%class-name x))))
|
|
|
77
|
+ (symbol (try-cmucl-random-doc x doc-type))))
|
|
|
78
|
+ (t
|
|
|
79
|
+ (typecase x
|
|
|
80
|
+ (symbol (try-cmucl-random-doc x doc-type)))))))
|
|
|
81
|
+
|
|
|
82
|
+(defun (setf documentation) (string name doc-type)
|
|
|
83
|
+ #-no-docstrings
|
|
|
84
|
+ (case doc-type
|
|
|
85
|
+ (variable
|
|
|
86
|
+ #+nil
|
|
|
87
|
+ (when string
|
|
|
88
|
+ (%primitive print "Set variable text domain")
|
|
|
89
|
+ (%primitive print (symbol-name name))
|
|
|
90
|
+ (%primitive print intl::*default-domain*))
|
|
|
91
|
+ (setf (info variable textdomain name) intl::*default-domain*)
|
|
|
92
|
+ (setf (info variable documentation name) string))
|
|
|
93
|
+ (function
|
|
|
94
|
+ #+nil
|
|
|
95
|
+ (when intl::*default-domain*
|
|
|
96
|
+ (%primitive print "Set function text domain")
|
|
|
97
|
+ (%primitive print (symbol-name name))
|
|
|
98
|
+ (%primitive print intl::*default-domain*))
|
|
|
99
|
+ (setf (info function textdomain name) intl::*default-domain*)
|
|
|
100
|
+ (setf (info function documentation name) string))
|
|
|
101
|
+ (structure
|
|
|
102
|
+ (unless (eq (info type kind name) :instance)
|
|
|
103
|
+ (error (intl:gettext "~S is not the name of a structure type.") name))
|
|
|
104
|
+ (setf (info type textdomain name) intl::*default-domain*)
|
|
|
105
|
+ (setf (info type documentation name) string))
|
|
|
106
|
+ (type
|
|
|
107
|
+ (setf (info type textdomain name) intl::*default-domain*)
|
|
|
108
|
+ (setf (info type documentation name) string))
|
|
|
109
|
+ (setf
|
|
|
110
|
+ (setf (info setf textdomain name) intl::*default-domain*)
|
|
|
111
|
+ (setf (info setf documentation name) string))
|
|
|
112
|
+ (t
|
|
|
113
|
+ (let ((pair (assoc doc-type (info random-documentation stuff name))))
|
|
|
114
|
+ (if pair
|
|
|
115
|
+ (setf (cdr pair) string)
|
|
|
116
|
+ (push (cons doc-type string)
|
|
|
117
|
+ (info random-documentation stuff name))))))
|
|
|
118
|
+ string)
|
|
|
119
|
+ |