1
;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
5
;;; Copyright (c) 1987, 1988, 1989 Franz Inc, Berkeley, Ca.
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.
12
;;; Franz Incorporated provides this software "as is" without
13
;;; express or implied warranty.
17
(ext:file-comment "$Id: excldep.lisp,v 1.4 2007/08/21 15:49:28 fgilham Exp $")
21
(eval-when (compile load eval)
23
(require :process) ; Needed even if scheduler is not
24
; running. (Must be able to make
32
#-(or little-endian big-endian)
33
(eval-when (eval compile load)
35
(if (not (eq 0 (sys::memref x
36
#.(sys::mdparam 'comp::md-lvector-data0-norm)
38
(pushnew :little-endian *features*)
39
(pushnew :big-endian *features*))))
42
(defmacro correct-case (string)
43
;; This macro converts the given string to the
44
;; current preferred case, or leaves it alone in a case-sensitive mode.
46
`(let ((,str ,string))
47
(case excl::*current-case-mode*
48
(:case-insensitive-lower
49
(string-downcase ,str))
50
(:case-insensitive-upper
52
((:case-sensitive-lower :case-sensitive-upper)
56
(defconstant type-pred-alist
57
'(#-(version>= 4 1 devel 16)
59
#-(version>= 4 1 devel 16)
61
#-(version>= 4 1 devel 16)
63
#-(version>= 4 1 devel 16)
65
#-(version>= 4 1 devel 16)
67
#-(version>= 4 1 devel 16)
69
#-(version>= 4 1 devel 16)
71
#-(version>= 4 1 devel 16)
73
#-(version>= 4 1 devel 16)
75
#-(version>= 4 1 devel 16)
77
#-(version>= 4 1 devel 16)
78
(resource-id . card29p)
79
#-(version>= 4 1 devel 16)
83
(bitmap-format . bitmap-format-p)
84
(pixmap-format . pixmap-format-p)
86
(drawable . drawable-p)
89
(visual-info . visual-info-p)
90
(colormap . colormap-p)
92
(gcontext . gcontext-p)
96
(image-xy . image-xy-p)
98
(wm-hints . wm-hints-p)
99
(wm-size-hints . wm-size-hints-p)
102
;; This (if (and ...) t nil) stuff has a purpose -- it lets the old
103
;; sun4 compiler opencode the `and'.
105
#-(version>= 4 1 devel 16)
107
(declare (optimize (speed 3) (safety 0))
109
(if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
113
#-(version>= 4 1 devel 16)
115
(declare (optimize (speed 3) (safety 0))
117
(if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
121
#-(version>= 4 1 devel 16)
123
(declare (optimize (speed 3) (safety 0)))
124
(if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
125
(and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
126
(>= (the bignum x) 0)))
130
#-(version>= 4 1 devel 16)
132
(declare (optimize (speed 3) (safety 0)))
133
(if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
134
(and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
135
(>= (the bignum x) 0)))
139
#-(version>= 4 1 devel 16)
141
(declare (optimize (speed 3) (safety 0))
143
(if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
147
#-(version>= 4 1 devel 16)
149
(declare (optimize (speed 3) (safety 0))
151
(if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
155
#-(version>= 4 1 devel 16)
157
(declare (optimize (speed 3) (safety 0)))
158
(if (or (excl:fixnump x)
159
(and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
160
(>= (the bignum x) #.(expt -2 31))))
164
;; This one can be handled better by knowing a little about what we're
165
;; testing for. Plus this version can handle (single-float pi), which
166
;; is otherwise larger than pi!
168
(declare (optimize (speed 3) (safety 0)))
169
(if (or (and (excl::fixnump x) (>= (the fixnum x) #.(truncate (* -2 pi)))
170
(<= (the fixnum x) #.(truncate (* 2 pi))))
171
(and (excl::single-float-p x)
172
(>= (the single-float x) #.(float (* -2 pi) 0.0s0))
173
(<= (the single-float x) #.(float (* 2 pi) 0.0s0)))
174
(and (excl::double-float-p x)
175
(>= (the double-float x) #.(float (* -2 pi) 0.0d0))
176
(<= (the double-float x) #.(float (* 2 pi) 0.0d0))))
180
(eval-when (load eval)
181
#+(version>= 4 1 devel 16)
182
(mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt)))
184
#-(version>= 4 1 devel 16)
185
(nconc excl::type-pred-alist type-pred-alist))
188
;; Return t if there is a character available for reading or on error,
189
;; otherwise return nil.
193
#-(or (version>= 4 2) mswindows)
194
(defun fd-char-avail-p (fd)
195
(multiple-value-bind (available-p errcode)
196
(comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
201
#+(and (version>= 4 2) (not mswindows))
202
(defun fd-char-avail-p (fd)
203
(excl::filesys-character-available-p fd))
206
(defun fd-char-avail-p (socket-stream)
207
(listen socket-stream))
211
(defun fd-char-avail-p (socket-stream)
212
(excl::read-no-hang-p socket-stream))
214
(defmacro with-interrupt-checking-on (&body body)
215
`(locally (declare (optimize (safety 1)))
218
;; Read from the given fd into 'vector', which has element type card8.
219
;; Start storing at index 'start-index' and read exactly 'length' bytes.
220
;; Return t if an error or eof occurred, nil otherwise.
221
(defun fd-read-bytes (fd vector start-index length)
222
;; Read from the given stream fd into 'vector', which has element type card8.
223
;; Start storing at index 'start-index' and read exactly 'length' bytes.
224
;; Return t if an error or eof occurred, nil otherwise.
225
(declare (fixnum next-index start-index length))
226
(with-interrupt-checking-on
227
(let ((end-index (+ start-index length)))
229
(let ((next-index (excl:read-vector vector fd
232
(excl:if* (eq next-index start-index)
233
then ; end of file before was all filled up
235
elseif (eq next-index end-index)
236
then ; we're all done
238
else (setq start-index next-index)))))))
241
;; special patch for CLX (various process fixes)
244
(eval-when (compile load eval)
245
(unless (find-package :patch)
246
(make-package :patch :use '(:lisp :excl))))
250
(defvar *patches* nil)
253
(eval-when (compile eval load)
254
(when (and (= excl::cl-major-version-number 3)
255
(or (= excl::cl-minor-version-number 0)
256
(and (= excl::cl-minor-version-number 1)
257
excl::cl-generation-number
258
(< excl::cl-generation-number 9))))
259
(push :clx-r4-process-patches *features*)))
261
#+clx-r4-process-patches
262
(push (cons 1000.2 "special patch for CLX (various process fixes)")
268
#+clx-r4-process-patches
269
(export 'wait-for-input-available)
272
#+clx-r4-process-patches
273
(defun with-timeout-event (seconds fnc args)
274
(unless *scheduler-stack-group* (start-scheduler)) ;[spr670]
275
(let ((clock-event (make-clock-event)))
276
(when (<= seconds 0) (setq seconds 0))
277
(multiple-value-bind (secs msecs) (truncate seconds)
278
;; secs is now a nonegative integer, and msecs is either fixnum zero
279
;; or else something interesting.
281
(setq msecs (truncate (* 1000.0 msecs))))
282
;; Now msecs is also a nonnegative fixnum.
283
(multiple-value-bind (now mnow) (excl::cl-internal-real-time)
286
(when (>= msecs 1000)
289
(unless (excl:fixnump secs) (setq secs most-positive-fixnum))
290
(setf (clock-event-secs clock-event) secs
291
(clock-event-msecs clock-event) msecs
292
(clock-event-function clock-event) fnc
293
(clock-event-args clock-event) args)))
297
#+clx-r4-process-patches
298
(defmacro with-timeout ((seconds &body timeout-body) &body body)
299
`(let* ((clock-event (with-timeout-event ,seconds
301
(cons *current-process*
302
'(with-timeout-internal))))
303
(excl::*without-interrupts* t)
306
;; Warning: Branch tensioner better not reorder this code!
307
(setq ret (catch 'with-timeout-internal
308
(add-to-clock-queue clock-event)
309
(let ((excl::*without-interrupts* nil))
310
(multiple-value-list (progn ,@body)))))
311
(excl:if* (eq ret 'with-timeout-internal)
312
then (let ((excl::*without-interrupts* nil))
313
(setq ret (multiple-value-list (progn ,@timeout-body))))
314
else (remove-from-clock-queue clock-event)))
318
#+clx-r4-process-patches
319
(defun process-lock (lock &optional (lock-value *current-process*)
320
(whostate "Lock") timeout)
321
(declare (optimize (speed 3)))
322
(unless (process-lock-p lock)
323
(error "First argument to PROCESS-LOCK must be a process-lock: ~s" lock))
325
(excl:if* (null (process-lock-locker lock))
326
then (setf (process-lock-locker lock) lock-value)
327
else (excl:if* timeout
328
then (excl:if* (or (eq 0 timeout) ;for speed
331
else (with-timeout (timeout)
332
(process-lock-1 lock lock-value whostate)))
333
else (process-lock-1 lock lock-value whostate)))))
336
#+clx-r4-process-patches
337
(defun process-lock-1 (lock lock-value whostate)
338
(declare (type process-lock lock)
339
(optimize (speed 3)))
340
(let ((process *current-process*))
341
(declare (type process process))
344
"PROCESS-LOCK may not be called on the scheduler's stack group."))
345
(loop (unless (process-lock-locker lock)
346
(return (setf (process-lock-locker lock) lock-value)))
347
(push process (process-lock-waiting lock))
348
(let ((saved-whostate (process-whostate process)))
350
(progn (setf (process-whostate process) whostate)
351
(process-add-arrest-reason process lock))
352
(setf (process-whostate process) saved-whostate))))))
355
#+clx-r4-process-patches
356
(defun process-wait (whostate function &rest args)
357
(declare (optimize (speed 3)))
358
;; Run the wait function once here both for efficiency and as a
359
;; first line check for errors in the function.
360
(unless (apply function args)
361
(process-wait-1 whostate function args)))
364
#+clx-r4-process-patches
365
(defun process-wait-1 (whostate function args)
366
(declare (optimize (speed 3)))
367
(let ((process *current-process*))
368
(declare (type process process))
371
"Process-wait may not be called within the scheduler's stack group."))
372
(let ((saved-whostate (process-whostate process)))
374
(without-scheduling-internal
376
(setf (process-whostate process) whostate
377
(process-wait-function process) function
378
(process-wait-args process) args)
379
(chain-rem-q process)
380
(chain-ins-q process *waiting-processes*))
381
(process-resume-scheduler nil))
382
(setf (process-whostate process) saved-whostate
383
(process-wait-function process) nil
384
(process-wait-args process) nil)))))
387
#+clx-r4-process-patches
388
(defun process-wait-with-timeout (whostate seconds function &rest args)
389
;; Now returns T upon completion, NIL upon timeout. -- 6Jun89 smh
390
;; [spr1135] [rfe939] Timeout won't throw out of interrupt level code.
392
;; Run the wait function once here both for efficiency and as a
393
;; first line check for errors in the function.
394
(excl:if* (apply function args)
396
else (let ((ret (list nil)))
399
(with-timeout-event seconds #'identity '(nil))))
400
(add-to-clock-queue clock-event)
401
(process-wait-1 whostate
402
#'(lambda (clock-event function args ret)
403
(or (null (chain-next clock-event))
404
(and (apply function args)
405
(setf (car ret) 't))))
406
(list clock-event function args ret))))
411
;; Returns nil on timeout, otherwise t.
413
#+clx-r4-process-patches
414
(defun wait-for-input-available
415
(stream-or-fd &key (wait-function #'listen)
416
(whostate "waiting for input")
418
(let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd
419
elseif (streamp stream-or-fd)
420
then (excl::stream-input-fn stream-or-fd)
421
else (error "wait-for-input-available expects a stream or file descriptor: ~s" stream-or-fd))))
422
;; At this point fd could be nil, since stream-input-fn returns nil for
423
;; streams that are output only, or for certain special purpose streams.
429
then (mp::process-wait-with-timeout
430
whostate timeout wait-function stream-or-fd)
431
else (mp::process-wait whostate wait-function stream-or-fd)
433
(mp::mpunwatchfor fd))
435
then (mp::process-wait-with-timeout
436
whostate timeout wait-function stream-or-fd)
437
else (mp::process-wait whostate wait-function stream-or-fd)
added
removed
src/clx/excldep.lisp
