/[cmucl]/src/code/misc.lisp
ViewVC logotype

Contents of /src/code/misc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44 - (show annotations)
Tue May 31 13:18:37 2011 UTC (2 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, HEAD
Changes since 1.43: +7 -1 lines
Add :CMUCL to *FEATURES*.

(Even though I (rtoy) should know better, I still find myself writing
:cmucl instead of :cmu in feature tests.)
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: /tiger/var/lib/cvsroots/cmucl/src/code/misc.lisp,v 1.44 2011/05/31 13:18:37 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Environment query functions, documentation and dribble.
13 ;;;
14 ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
15 ;;; Scott Fahlman, Dan Aronson, and Steve Handerson did stuff here, too.
16 ;;;
17 (in-package "LISP")
18 (intl:textdomain "cmucl")
19
20 (export '(documentation *features* variable room
21 lisp-implementation-type lisp-implementation-version machine-type
22 machine-version machine-instance software-type software-version
23 short-site-name long-site-name dribble compiler-macro))
24
25 (in-package "SYSTEM")
26 (export '(*software-type* *short-site-name* *long-site-name*))
27
28 (in-package "EXT")
29 (export 'featurep)
30
31 (in-package "LISP")
32
33 ;;; cobbled from stuff in describe.lisp.
34 (defun function-doc (x)
35 (let ((name
36 (case (kernel:get-type x)
37 (#.vm:closure-header-type
38 (kernel:%function-name (%closure-function x)))
39 ((#.vm:function-header-type #.vm:closure-function-header-type)
40 (kernel:%function-name x))
41 (#.vm:funcallable-instance-header-type
42 (typecase x
43 (kernel:byte-function
44 (c::byte-function-name x))
45 (kernel:byte-closure
46 (c::byte-function-name (byte-closure-function x)))
47 (eval:interpreted-function
48 (multiple-value-bind
49 (exp closure-p dname)
50 (eval:interpreted-function-lambda-expression x)
51 (declare (ignore exp closure-p))
52 dname))
53 (t ;; funcallable-instance
54 (kernel:%function-name
55 (kernel:funcallable-instance-function x))))))))
56 (when (and name (typep name '(or symbol cons)))
57 (values (info function documentation name)))))
58
59 (defun documentation (x doc-type)
60 "Returns the documentation string of Doc-Type for X, or NIL if
61 none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
62 SETF, and T."
63 (flet (;; CMUCL random-documentation.
64 (try-cmucl-random-doc (x doc-type)
65 (declare (symbol doc-type))
66 (cdr (assoc doc-type
67 (values (info random-documentation stuff x))))))
68 (case doc-type
69 (variable
70 (typecase x
71 (symbol (values (info variable documentation x)))))
72 (function
73 (typecase x
74 (symbol (values (info function documentation x)))
75 (function (function-doc x))
76 (list ;; Must be '(setf symbol)
77 (values (info function documentation (cadr x))))))
78 (structure
79 (typecase x
80 (symbol (when (eq (info type kind x) :instance)
81 (values (info type documentation x))))))
82 (type
83 (typecase x
84 (kernel::structure-class (values (info type documentation (%class-name x))))
85 (t (and (typep x 'symbol) (values (info type documentation x))))))
86 (setf (info setf documentation x))
87 ((t)
88 (typecase x
89 (function (function-doc x))
90 (package (package-doc-string x))
91 (kernel::structure-class (values (info type documentation (%class-name x))))
92 (symbol (try-cmucl-random-doc x doc-type))))
93 (t
94 (typecase x
95 (symbol (try-cmucl-random-doc x doc-type)))))))
96
97 (defun (setf documentation) (string name doc-type)
98 #-no-docstrings
99 (case doc-type
100 (variable
101 #+nil
102 (when string
103 (%primitive print "Set variable text domain")
104 (%primitive print (symbol-name name))
105 (%primitive print intl::*default-domain*))
106 (setf (info variable textdomain name) intl::*default-domain*)
107 (setf (info variable documentation name) string))
108 (function
109 #+nil
110 (when intl::*default-domain*
111 (%primitive print "Set function text domain")
112 (%primitive print (symbol-name name))
113 (%primitive print intl::*default-domain*))
114 (setf (info function textdomain name) intl::*default-domain*)
115 (setf (info function documentation name) string))
116 (structure
117 (unless (eq (info type kind name) :instance)
118 (error (intl:gettext "~S is not the name of a structure type.") name))
119 (setf (info type textdomain name) intl::*default-domain*)
120 (setf (info type documentation name) string))
121 (type
122 (setf (info type textdomain name) intl::*default-domain*)
123 (setf (info type documentation name) string))
124 (setf
125 (setf (info setf textdomain name) intl::*default-domain*)
126 (setf (info setf documentation name) string))
127 (t
128 (let ((pair (assoc doc-type (info random-documentation stuff name))))
129 (if pair
130 (setf (cdr pair) string)
131 (push (cons doc-type string)
132 (info random-documentation stuff name))))))
133 string)
134
135
136 #+nil
137 (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
138 "Holds a list of symbols that describe features provided by the
139 implementation.")
140
141 ;;; Register various Lisp features
142 #+i486
143 (sys:register-lisp-runtime-feature :i486)
144
145 #+pentium
146 (sys:register-lisp-runtime-feature :pentium)
147
148 #+sparc-v7
149 (sys:register-lisp-runtime-feature :sparc-v7)
150
151 #+sparc-v8
152 (sys:register-lisp-runtime-feature :sparc-v8)
153
154 #+sparc-v9
155 (sys:register-lisp-runtime-feature :sparc-v9)
156
157 #+complex-fp-vops
158 (sys:register-lisp-feature :complex-fp-vops)
159
160 #+unicode
161 (sys:register-lisp-runtime-feature :unicode)
162
163 #+cmu
164 (sys:register-lisp-feature :cmu)
165
166 #+(or cmu cmucl)
167 (sys:register-lisp-feature :cmucl)
168
169 (defun featurep (x)
170 "If X is an atom, see if it is present in *FEATURES*. Also
171 handle arbitrary combinations of atoms using NOT, AND, OR."
172 (if (consp x)
173 (case (car x)
174 ((:not not) (not (featurep (cadr x))))
175 ((:and and) (every #'featurep (cdr x)))
176 ((:or or) (some #'featurep (cdr x)))
177 (t
178 (error (intl:gettext "Unknown operator in feature expression: ~S.") x)))
179 (not (null (memq x *features*)))))
180
181
182 ;;; Other Environment Inquiries.
183
184 (defun lisp-implementation-type ()
185 "Returns a string describing the implementation type."
186 "CMU Common Lisp")
187
188 (defun lisp-implementation-version ()
189 "Returns a string describing the implementation version."
190 (format nil "~A (~X~A)" *lisp-implementation-version* c:byte-fasl-file-version
191 #+unicode _" Unicode" #-unicode ""))
192
193 (defun machine-instance ()
194 "Returns a string giving the name of the local machine."
195 (unix:unix-gethostname))
196
197 (defvar *software-type* "Unix"
198 "The value of SOFTWARE-TYPE. Set in FOO-os.lisp.")
199
200 (defun software-type ()
201 "Returns a string describing the supporting software."
202 *software-type*)
203
204 (defvar *short-site-name* (intl:gettext "Unknown")
205 "The value of SHORT-SITE-NAME. Set in library:site-init.lisp.")
206
207 (defun short-site-name ()
208 "Returns a string with the abbreviated site name."
209 *short-site-name*)
210
211 (defvar *long-site-name* (intl:gettext "Site name not initialized")
212 "The value of LONG-SITE-NAME. Set in library:site-init.lisp.")
213
214 (defun long-site-name ()
215 "Returns a string with the long form of the site name."
216 *long-site-name*)
217
218
219 ;;;; Dribble stuff:
220
221 ;;; Each time we start dribbling to a new stream, we put it in
222 ;;; *dribble-stream*, and push a list of *dribble-stream*, *standard-input*,
223 ;;; *standard-output* and *error-output* in *previous-streams*.
224 ;;; *standard-output* and *error-output* is changed to a broadcast stream that
225 ;;; broadcasts to *dribble-stream* and to the old values of the variables.
226 ;;; *standard-input* is changed to an echo stream that echos input from the old
227 ;;; value of standard input to *dribble-stream*.
228 ;;;
229 ;;; When dribble is called with no arguments, *dribble-stream* is closed,
230 ;;; and the values of *dribble-stream*, *standard-input*, and
231 ;;; *standard-output* are poped from *previous-streams*.
232
233 (defvar *previous-streams* nil)
234 (defvar *dribble-stream* nil)
235
236 (defun dribble (&optional pathname &key (if-exists :append))
237 "With a file name as an argument, dribble opens the file and
238 sends a record of further I/O to that file. Without an
239 argument, it closes the dribble file, and quits logging."
240 (cond (pathname
241 (let* ((new-dribble-stream
242 (open pathname :direction :output :if-exists if-exists
243 :if-does-not-exist :create))
244 (new-standard-output
245 (make-broadcast-stream *standard-output* new-dribble-stream))
246 (new-error-output
247 (make-broadcast-stream *error-output* new-dribble-stream))
248 (new-standard-input
249 (make-echo-stream *standard-input* new-dribble-stream)))
250 (push (list *dribble-stream* *standard-input* *standard-output*
251 *error-output*)
252 *previous-streams*)
253 (setf *dribble-stream* new-dribble-stream)
254 (setf *standard-input* new-standard-input)
255 (setf *standard-output* new-standard-output)
256 (setf *error-output* new-error-output)))
257 ((null *dribble-stream*)
258 (error (intl:gettext "Not currently dribbling.")))
259 (t
260 (let ((old-streams (pop *previous-streams*)))
261 (close *dribble-stream*)
262 (setf *dribble-stream* (first old-streams))
263 (setf *standard-input* (second old-streams))
264 (setf *standard-output* (third old-streams))
265 (setf *error-output* (fourth old-streams)))))
266 (values))
267
268 (defun ed (&optional x)
269 "Default implementation of ed. This does nothing. If hemlock is
270 loaded, ed can be used to edit a file"
271 (declare (ignorable x))
272 (values))

  ViewVC Help
Powered by ViewVC 1.1.5