/[cmucl]/src/clx/excldep.lisp
ViewVC logotype

Contents of /src/clx/excldep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Thu Nov 7 16:57:52 1991 UTC (22 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a, RELEASE_18b
Branch point for: RELENG_18
Changes since 1.1: +109 -174 lines
CLX R5 changes.
1 ;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
2 ;;;
3 ;;; CLX -- excldep.cl
4 ;;;
5 ;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca.
6 ;;;
7 ;;; Permission is granted to any individual or institution to use, copy,
8 ;;; modify, and distribute this software, provided that this complete
9 ;;; copyright and permission notice is maintained, intact, in all copies and
10 ;;; supporting documentation.
11 ;;;
12 ;;; Franz Incorporated provides this software "as is" without
13 ;;; express or implied warranty.
14 ;;;
15
16 (in-package :xlib)
17
18 (eval-when (compile load eval)
19 (require :foreign)
20 (require :process) ; Needed even if scheduler is not
21 ; running. (Must be able to make
22 ; a process-lock.)
23 )
24
25 (eval-when (load)
26 (provide :clx))
27
28
29 #-(or little-endian big-endian)
30 (eval-when (eval compile load)
31 (let ((x '#(1)))
32 (if (not (eq 0 (sys::memref x
33 #.(comp::mdparam 'comp::md-svector-data0-adj)
34 0 :unsigned-byte)))
35 (pushnew :little-endian *features*)
36 (pushnew :big-endian *features*))))
37
38
39 (defmacro correct-case (string)
40 ;; This macro converts the given string to the
41 ;; current preferred case, or leaves it alone in a case-sensitive mode.
42 (let ((str (gensym)))
43 `(let ((,str ,string))
44 (case excl::*current-case-mode*
45 (:case-insensitive-lower
46 (string-downcase ,str))
47 (:case-insensitive-upper
48 (string-upcase ,str))
49 ((:case-sensitive-lower :case-sensitive-upper)
50 ,str)))))
51
52
53 (defconstant type-pred-alist
54 '(#-(version>= 4 1 devel 16)
55 (card8 . card8p)
56 #-(version>= 4 1 devel 16)
57 (card16 . card16p)
58 #-(version>= 4 1 devel 16)
59 (card29 . card29p)
60 #-(version>= 4 1 devel 16)
61 (card32 . card32p)
62 #-(version>= 4 1 devel 16)
63 (int8 . int8p)
64 #-(version>= 4 1 devel 16)
65 (int16 . int16p)
66 #-(version>= 4 1 devel 16)
67 (int32 . int32p)
68 #-(version>= 4 1 devel 16)
69 (mask16 . card16p)
70 #-(version>= 4 1 devel 16)
71 (mask32 . card32p)
72 #-(version>= 4 1 devel 16)
73 (pixel . card32p)
74 #-(version>= 4 1 devel 16)
75 (resource-id . card29p)
76 #-(version>= 4 1 devel 16)
77 (keysym . card32p)
78 (angle . anglep)
79 (color . color-p)
80 (bitmap-format . bitmap-format-p)
81 (pixmap-format . pixmap-format-p)
82 (display . display-p)
83 (drawable . drawable-p)
84 (window . window-p)
85 (pixmap . pixmap-p)
86 (visual-info . visual-info-p)
87 (colormap . colormap-p)
88 (cursor . cursor-p)
89 (gcontext . gcontext-p)
90 (screen . screen-p)
91 (font . font-p)
92 (image-x . image-x-p)
93 (image-xy . image-xy-p)
94 (image-z . image-z-p)
95 (wm-hints . wm-hints-p)
96 (wm-size-hints . wm-size-hints-p)
97 ))
98
99 ;; This (if (and ...) t nil) stuff has a purpose -- it lets the old
100 ;; sun4 compiler opencode the `and'.
101
102 #-(version>= 4 1 devel 16)
103 (defun card8p (x)
104 (declare (optimize (speed 3) (safety 0))
105 (fixnum x))
106 (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
107 t
108 nil))
109
110 #-(version>= 4 1 devel 16)
111 (defun card16p (x)
112 (declare (optimize (speed 3) (safety 0))
113 (fixnum x))
114 (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
115 t
116 nil))
117
118 #-(version>= 4 1 devel 16)
119 (defun card29p (x)
120 (declare (optimize (speed 3) (safety 0)))
121 (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
122 (and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
123 (>= (the bignum x) 0)))
124 t
125 nil))
126
127 #-(version>= 4 1 devel 16)
128 (defun card32p (x)
129 (declare (optimize (speed 3) (safety 0)))
130 (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
131 (and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
132 (>= (the bignum x) 0)))
133 t
134 nil))
135
136 #-(version>= 4 1 devel 16)
137 (defun int8p (x)
138 (declare (optimize (speed 3) (safety 0))
139 (fixnum x))
140 (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
141 t
142 nil))
143
144 #-(version>= 4 1 devel 16)
145 (defun int16p (x)
146 (declare (optimize (speed 3) (safety 0))
147 (fixnum x))
148 (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
149 t
150 nil))
151
152 #-(version>= 4 1 devel 16)
153 (defun int32p (x)
154 (declare (optimize (speed 3) (safety 0)))
155 (if (or (excl:fixnump x)
156 (and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
157 (>= (the bignum x) #.(expt -2 31))))
158 t
159 nil))
160
161 ;; This one can be handled better by knowing a little about what we're
162 ;; testing for. Plus this version can handle (single-float pi), which
163 ;; is otherwise larger than pi!
164 (defun anglep (x)
165 (declare (optimize (speed 3) (safety 0)))
166 (if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi)))
167 (<= (the fixnum x) #.(truncate (* 2 pi))))
168 (and (excl::single-float-p x)
169 (>= (the single-float x) #.(float (* -2 pi) 0.0s0))
170 (<= (the single-float x) #.(float (* 2 pi) 0.0s0)))
171 (and (excl::double-float-p x)
172 (>= (the double-float x) #.(float (* -2 pi) 0.0d0))
173 (<= (the double-float x) #.(float (* 2 pi) 0.0d0))))
174 t
175 nil))
176
177 (eval-when (load eval)
178 #+(version>= 4 1 devel 16)
179 (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt)))
180 type-pred-alist)
181 #-(version>= 4 1 devel 16)
182 (nconc excl::type-pred-alist type-pred-alist))
183
184
185 ;; Return t if there is a character available for reading or on error,
186 ;; otherwise return nil.
187 (defun fd-char-avail-p (fd)
188 (multiple-value-bind (available-p errcode)
189 (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
190 (excl:if* errcode
191 then t
192 else available-p)))
193
194 (defmacro with-interrupt-checking-on (&body body)
195 `(locally (declare (optimize (safety 1)))
196 ,@body))
197
198 ;; Read from the given fd into 'vector', which has element type card8.
199 ;; Start storing at index 'start-index' and read exactly 'length' bytes.
200 ;; Return t if an error or eof occurred, nil otherwise.
201 (defun fd-read-bytes (fd vector start-index length)
202 (declare (fixnum fd start-index length)
203 (type (simple-array (unsigned-byte 8) (*)) vector))
204 (with-interrupt-checking-on
205 (do ((rest length))
206 ((eq 0 rest) nil)
207 (declare (fixnum rest))
208 (multiple-value-bind (numread errcode)
209 (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector
210 start-index rest)
211 (declare (fixnum numread))
212 (excl:if* errcode
213 then (if (not (eq errcode
214 excl::*error-code-interrupted-system-call*))
215 (return t))
216 elseif (eq 0 numread)
217 then (return t)
218 else (decf rest numread)
219 (incf start-index numread))))))
220
221
222 (when (plusp (ff:get-entry-points
223 (make-array 1 :initial-contents
224 (list (ff:convert-to-lang "fd_wait_for_input")))
225 (make-array 1 :element-type '(unsigned-byte 32))))
226 (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input"))
227 (load "excldep.o"))
228
229 (when (plusp (ff:get-entry-points
230 (make-array 1 :initial-contents
231 (list (ff:convert-to-lang "connect_to_server")))
232 (make-array 1 :element-type '(unsigned-byte 32))))
233 (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c))
234 (load "socket.o"))
235
236 (ff:defforeign-list `((connect-to-server
237 :entry-point
238 ,(ff:convert-to-lang "connect_to_server")
239 :return-type :fixnum
240 :arg-checking nil
241 :arguments (string fixnum))
242 (fd-wait-for-input
243 :entry-point ,(ff:convert-to-lang "fd_wait_for_input")
244 :return-type :fixnum
245 :arg-checking nil
246 :call-direct t
247 :callback nil
248 :allow-other-keys t
249 :arguments (fixnum fixnum))))
250
251
252 ;; special patch for CLX (various process fixes)
253 ;; patch1000.2
254
255 (eval-when (compile load eval)
256 (unless (find-package :patch)
257 (make-package :patch :use '(:lisp :excl))))
258
259 (in-package :patch)
260
261 (defvar *patches* nil)
262
263 #+allegro
264 (eval-when (compile eval load)
265 (when (and (= excl::cl-major-version-number 3)
266 (or (= excl::cl-minor-version-number 0)
267 (and (= excl::cl-minor-version-number 1)
268 excl::cl-generation-number
269 (< excl::cl-generation-number 9))))
270 (push :clx-r4-process-patches *features*)))
271
272 #+clx-r4-process-patches
273 (push (cons 1000.2 "special patch for CLX (various process fixes)")
274 *patches*)
275
276
277 (in-package :mp)
278
279 #+clx-r4-process-patches
280 (export 'wait-for-input-available)
281
282
283 #+clx-r4-process-patches
284 (defun with-timeout-event (seconds fnc args)
285 (unless *scheduler-stack-group* (start-scheduler)) ;[spr670]
286 (let ((clock-event (make-clock-event)))
287 (when (<= seconds 0) (setq seconds 0))
288 (multiple-value-bind (secs msecs) (truncate seconds)
289 ;; secs is now a nonegative integer, and msecs is either fixnum zero
290 ;; or else something interesting.
291 (unless (eq 0 msecs)
292 (setq msecs (truncate (* 1000.0 msecs))))
293 ;; Now msecs is also a nonnegative fixnum.
294 (multiple-value-bind (now mnow) (excl::cl-internal-real-time)
295 (incf secs now)
296 (incf msecs mnow)
297 (when (>= msecs 1000)
298 (decf msecs 1000)
299 (incf secs))
300 (unless (excl:fixnump secs) (setq secs most-positive-fixnum))
301 (setf (clock-event-secs clock-event) secs
302 (clock-event-msecs clock-event) msecs
303 (clock-event-function clock-event) fnc
304 (clock-event-args clock-event) args)))
305 clock-event))
306
307
308 #+clx-r4-process-patches
309 (defmacro with-timeout ((seconds &body timeout-body) &body body)
310 `(let* ((clock-event (with-timeout-event ,seconds
311 #'process-interrupt
312 (cons *current-process*
313 '(with-timeout-internal))))
314 (excl::*without-interrupts* t)
315 ret)
316 (unwind-protect
317 ;; Warning: Branch tensioner better not reorder this code!
318 (setq ret (catch 'with-timeout-internal
319 (add-to-clock-queue clock-event)
320 (let ((excl::*without-interrupts* nil))
321 (multiple-value-list (progn ,@body)))))
322 (excl:if* (eq ret 'with-timeout-internal)
323 then (let ((excl::*without-interrupts* nil))
324 (setq ret (multiple-value-list (progn ,@timeout-body))))
325 else (remove-from-clock-queue clock-event)))
326 (values-list ret)))
327
328
329 #+clx-r4-process-patches
330 (defun process-lock (lock &optional (lock-value *current-process*)
331 (whostate "Lock") timeout)
332 (declare (optimize (speed 3)))
333 (unless (process-lock-p lock)
334 (error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock))
335 (without-interrupts
336 (excl:if* (null (process-lock-locker lock))
337 then (setf (process-lock-locker lock) lock-value)
338 else (excl:if* timeout
339 then (excl:if* (or (eq 0 timeout) ;for speed
340 (zerop timeout))
341 then nil
342 else (with-timeout (timeout)
343 (process-lock-1 lock lock-value whostate)))
344 else (process-lock-1 lock lock-value whostate)))))
345
346
347 #+clx-r4-process-patches
348 (defun process-lock-1 (lock lock-value whostate)
349 (declare (type process-lock lock)
350 (optimize (speed 3)))
351 (let ((process *current-process*))
352 (declare (type process process))
353 (unless process
354 (error
355 "PROCESS-LOCK may not be called on the scheduler's stack group."))
356 (loop (unless (process-lock-locker lock)
357 (return (setf (process-lock-locker lock) lock-value)))
358 (push process (process-lock-waiting lock))
359 (let ((saved-whostate (process-whostate process)))
360 (unwind-protect
361 (progn (setf (process-whostate process) whostate)
362 (process-add-arrest-reason process lock))
363 (setf (process-whostate process) saved-whostate))))))
364
365
366 #+clx-r4-process-patches
367 (defun process-wait (whostate function &rest args)
368 (declare (optimize (speed 3)))
369 ;; Run the wait function once here both for efficiency and as a
370 ;; first line check for errors in the function.
371 (unless (apply function args)
372 (process-wait-1 whostate function args)))
373
374
375 #+clx-r4-process-patches
376 (defun process-wait-1 (whostate function args)
377 (declare (optimize (speed 3)))
378 (let ((process *current-process*))
379 (declare (type process process))
380 (unless process
381 (error
382 "Process-wait may not be called within the scheduler's stack group."))
383 (let ((saved-whostate (process-whostate process)))
384 (unwind-protect
385 (without-scheduling-internal
386 (without-interrupts
387 (setf (process-whostate process) whostate
388 (process-wait-function process) function
389 (process-wait-args process) args)
390 (chain-rem-q process)
391 (chain-ins-q process *waiting-processes*))
392 (process-resume-scheduler nil))
393 (setf (process-whostate process) saved-whostate
394 (process-wait-function process) nil
395 (process-wait-args process) nil)))))
396
397
398 #+clx-r4-process-patches
399 (defun process-wait-with-timeout (whostate seconds function &rest args)
400 ;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh
401 ;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code.
402 ;; -- 28Feb90 smh
403 ;; Run the wait function once here both for efficiency and as a
404 ;; first line check for errors in the function.
405 (excl:if* (apply function args)
406 then t
407 else (let ((ret (list nil)))
408 (without-interrupts
409 (let ((clock-event
410 (with-timeout-event seconds #'identity '(nil))))
411 (add-to-clock-queue clock-event)
412 (process-wait-1 whostate
413 #'(lambda (clock-event function args ret)
414 (or (null (chain-next clock-event))
415 (and (apply function args)
416 (setf (car ret) 't))))
417 (list clock-event function args ret))))
418 (car ret))))
419
420
421 ;;
422 ;; Returns nil on timeout, otherwise t.
423 ;;
424 #+clx-r4-process-patches
425 (defun wait-for-input-available
426 (stream-or-fd &key (wait-function #'listen)
427 (whostate "waiting for input")
428 timeout)
429 (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd
430 elseif (streamp stream-or-fd)
431 then (excl::stream-input-fn stream-or-fd)
432 else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd))))
433 ;; At this point fd could be nil, since stream-input-fn returns nil for
434 ;; streams that are output only, or for certain special purpose streams.
435 (if fd
436 (unwind-protect
437 (progn
438 (mp::mpwatchfor fd)
439 (excl:if* timeout
440 then (mp::process-wait-with-timeout
441 whostate timeout wait-function stream-or-fd)
442 else (mp::process-wait whostate wait-function stream-or-fd)
443 t))
444 (mp::mpunwatchfor fd))
445 (excl:if* timeout
446 then (mp::process-wait-with-timeout
447 whostate timeout wait-function stream-or-fd)
448 else (mp::process-wait whostate wait-function stream-or-fd)
449 t))))

  ViewVC Help
Powered by ViewVC 1.1.5