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

Contents of /src/clx/excldep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.4: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ram 1.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 fgilham 1.4 #+cmu
17 rtoy 1.5 (ext:file-comment "$Id: excldep.lisp,v 1.5 2009/06/17 18:22:46 rtoy Rel $")
18 fgilham 1.4
19 ram 1.2 (in-package :xlib)
20 ram 1.1
21 ram 1.2 (eval-when (compile load eval)
22     (require :foreign)
23     (require :process) ; Needed even if scheduler is not
24     ; running. (Must be able to make
25     ; a process-lock.)
26     )
27    
28 ram 1.1 (eval-when (load)
29     (provide :clx))
30    
31    
32     #-(or little-endian big-endian)
33     (eval-when (eval compile load)
34     (let ((x '#(1)))
35     (if (not (eq 0 (sys::memref x
36 fgilham 1.4 #.(sys::mdparam 'comp::md-lvector-data0-norm)
37 ram 1.1 0 :unsigned-byte)))
38     (pushnew :little-endian *features*)
39     (pushnew :big-endian *features*))))
40    
41    
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.
45     (let ((str (gensym)))
46     `(let ((,str ,string))
47     (case excl::*current-case-mode*
48     (:case-insensitive-lower
49     (string-downcase ,str))
50     (:case-insensitive-upper
51     (string-upcase ,str))
52     ((:case-sensitive-lower :case-sensitive-upper)
53     ,str)))))
54    
55    
56     (defconstant type-pred-alist
57 ram 1.2 '(#-(version>= 4 1 devel 16)
58     (card8 . card8p)
59     #-(version>= 4 1 devel 16)
60     (card16 . card16p)
61     #-(version>= 4 1 devel 16)
62     (card29 . card29p)
63     #-(version>= 4 1 devel 16)
64     (card32 . card32p)
65     #-(version>= 4 1 devel 16)
66     (int8 . int8p)
67     #-(version>= 4 1 devel 16)
68     (int16 . int16p)
69     #-(version>= 4 1 devel 16)
70     (int32 . int32p)
71     #-(version>= 4 1 devel 16)
72     (mask16 . card16p)
73     #-(version>= 4 1 devel 16)
74     (mask32 . card32p)
75     #-(version>= 4 1 devel 16)
76     (pixel . card32p)
77     #-(version>= 4 1 devel 16)
78     (resource-id . card29p)
79     #-(version>= 4 1 devel 16)
80     (keysym . card32p)
81     (angle . anglep)
82     (color . color-p)
83     (bitmap-format . bitmap-format-p)
84     (pixmap-format . pixmap-format-p)
85     (display . display-p)
86     (drawable . drawable-p)
87     (window . window-p)
88     (pixmap . pixmap-p)
89     (visual-info . visual-info-p)
90     (colormap . colormap-p)
91     (cursor . cursor-p)
92     (gcontext . gcontext-p)
93     (screen . screen-p)
94     (font . font-p)
95     (image-x . image-x-p)
96     (image-xy . image-xy-p)
97     (image-z . image-z-p)
98     (wm-hints . wm-hints-p)
99     (wm-size-hints . wm-size-hints-p)
100     ))
101 ram 1.1
102     ;; This (if (and ...) t nil) stuff has a purpose -- it lets the old
103     ;; sun4 compiler opencode the `and'.
104    
105 ram 1.2 #-(version>= 4 1 devel 16)
106 ram 1.1 (defun card8p (x)
107     (declare (optimize (speed 3) (safety 0))
108     (fixnum x))
109 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
110 ram 1.1 t
111     nil))
112    
113 ram 1.2 #-(version>= 4 1 devel 16)
114 ram 1.1 (defun card16p (x)
115     (declare (optimize (speed 3) (safety 0))
116     (fixnum x))
117 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
118 ram 1.1 t
119     nil))
120    
121 ram 1.2 #-(version>= 4 1 devel 16)
122 ram 1.1 (defun card29p (x)
123     (declare (optimize (speed 3) (safety 0)))
124 ram 1.2 (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
125     (and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
126 ram 1.1 (>= (the bignum x) 0)))
127     t
128     nil))
129    
130 ram 1.2 #-(version>= 4 1 devel 16)
131 ram 1.1 (defun card32p (x)
132     (declare (optimize (speed 3) (safety 0)))
133 ram 1.2 (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
134     (and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
135 ram 1.1 (>= (the bignum x) 0)))
136     t
137     nil))
138    
139 ram 1.2 #-(version>= 4 1 devel 16)
140 ram 1.1 (defun int8p (x)
141     (declare (optimize (speed 3) (safety 0))
142     (fixnum x))
143 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
144 ram 1.1 t
145     nil))
146    
147 ram 1.2 #-(version>= 4 1 devel 16)
148 ram 1.1 (defun int16p (x)
149     (declare (optimize (speed 3) (safety 0))
150     (fixnum x))
151 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
152 ram 1.1 t
153     nil))
154    
155 ram 1.2 #-(version>= 4 1 devel 16)
156 ram 1.1 (defun int32p (x)
157     (declare (optimize (speed 3) (safety 0)))
158 ram 1.2 (if (or (excl:fixnump x)
159     (and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
160 ram 1.1 (>= (the bignum x) #.(expt -2 31))))
161     t
162     nil))
163    
164 ram 1.2 ;; 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!
167     (defun anglep (x)
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))))
177     t
178     nil))
179 ram 1.1
180 ram 1.2 (eval-when (load eval)
181     #+(version>= 4 1 devel 16)
182     (mapcar #'(lambda (elt) (excl:add-typep-transformer (car elt) (cdr elt)))
183     type-pred-alist)
184     #-(version>= 4 1 devel 16)
185     (nconc excl::type-pred-alist type-pred-alist))
186 ram 1.1
187 ram 1.2
188 ram 1.1 ;; Return t if there is a character available for reading or on error,
189     ;; otherwise return nil.
190 fgilham 1.4 #-(version>= 6 0)
191     (progn
192    
193     #-(or (version>= 4 2) mswindows)
194 ram 1.1 (defun fd-char-avail-p (fd)
195     (multiple-value-bind (available-p errcode)
196     (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
197 ram 1.2 (excl:if* errcode
198 ram 1.1 then t
199     else available-p)))
200    
201 fgilham 1.4 #+(and (version>= 4 2) (not mswindows))
202     (defun fd-char-avail-p (fd)
203     (excl::filesys-character-available-p fd))
204    
205     #+mswindows
206     (defun fd-char-avail-p (socket-stream)
207     (listen socket-stream))
208     )
209    
210     #+(version>= 6 0)
211     (defun fd-char-avail-p (socket-stream)
212     (excl::read-no-hang-p socket-stream))
213    
214 ram 1.1 (defmacro with-interrupt-checking-on (&body body)
215     `(locally (declare (optimize (safety 1)))
216     ,@body))
217    
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 fgilham 1.4 ;; 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 ram 1.1 (with-interrupt-checking-on
227 fgilham 1.4 (let ((end-index (+ start-index length)))
228     (loop
229     (let ((next-index (excl:read-vector vector fd
230     :start start-index
231     :end end-index)))
232     (excl:if* (eq next-index start-index)
233     then ; end of file before was all filled up
234     (return t)
235     elseif (eq next-index end-index)
236     then ; we're all done
237     (return nil)
238     else (setq start-index next-index)))))))
239 ram 1.1
240    
241     ;; special patch for CLX (various process fixes)
242     ;; patch1000.2
243    
244 ram 1.2 (eval-when (compile load eval)
245     (unless (find-package :patch)
246     (make-package :patch :use '(:lisp :excl))))
247 ram 1.1
248 ram 1.2 (in-package :patch)
249    
250 ram 1.1 (defvar *patches* nil)
251    
252     #+allegro
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 ram 1.2 excl::cl-generation-number
258 ram 1.1 (< excl::cl-generation-number 9))))
259     (push :clx-r4-process-patches *features*)))
260    
261     #+clx-r4-process-patches
262     (push (cons 1000.2 "special patch for CLX (various process fixes)")
263     *patches*)
264    
265    
266     (in-package :mp)
267    
268     #+clx-r4-process-patches
269     (export 'wait-for-input-available)
270    
271    
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.
280     (unless (eq 0 msecs)
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)
284     (incf secs now)
285     (incf msecs mnow)
286     (when (>= msecs 1000)
287     (decf msecs 1000)
288     (incf secs))
289 ram 1.2 (unless (excl:fixnump secs) (setq secs most-positive-fixnum))
290 ram 1.1 (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)))
294     clock-event))
295    
296    
297     #+clx-r4-process-patches
298     (defmacro with-timeout ((seconds &body timeout-body) &body body)
299     `(let* ((clock-event (with-timeout-event ,seconds
300     #'process-interrupt
301     (cons *current-process*
302     '(with-timeout-internal))))
303     (excl::*without-interrupts* t)
304     ret)
305     (unwind-protect
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 ram 1.2 (excl:if* (eq ret 'with-timeout-internal)
312 ram 1.1 then (let ((excl::*without-interrupts* nil))
313     (setq ret (multiple-value-list (progn ,@timeout-body))))
314     else (remove-from-clock-queue clock-event)))
315     (values-list ret)))
316    
317    
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))
324     (without-interrupts
325 ram 1.2 (excl:if* (null (process-lock-locker lock))
326 ram 1.1 then (setf (process-lock-locker lock) lock-value)
327 ram 1.2 else (excl:if* timeout
328     then (excl:if* (or (eq 0 timeout) ;for speed
329     (zerop timeout))
330 ram 1.1 then nil
331     else (with-timeout (timeout)
332     (process-lock-1 lock lock-value whostate)))
333     else (process-lock-1 lock lock-value whostate)))))
334    
335    
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))
342     (unless process
343     (error
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)))
349     (unwind-protect
350     (progn (setf (process-whostate process) whostate)
351     (process-add-arrest-reason process lock))
352     (setf (process-whostate process) saved-whostate))))))
353    
354    
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)))
362    
363    
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))
369     (unless process
370     (error
371     "Process-wait may not be called within the scheduler's stack group."))
372     (let ((saved-whostate (process-whostate process)))
373     (unwind-protect
374     (without-scheduling-internal
375     (without-interrupts
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)))))
385    
386    
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.
391     ;; -- 28Feb90 smh
392     ;; Run the wait function once here both for efficiency and as a
393     ;; first line check for errors in the function.
394 ram 1.2 (excl:if* (apply function args)
395 ram 1.1 then t
396     else (let ((ret (list nil)))
397     (without-interrupts
398     (let ((clock-event
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))))
407     (car ret))))
408    
409    
410     ;;
411     ;; Returns nil on timeout, otherwise t.
412     ;;
413     #+clx-r4-process-patches
414     (defun wait-for-input-available
415     (stream-or-fd &key (wait-function #'listen)
416     (whostate "waiting for input")
417     timeout)
418 ram 1.2 (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd
419 ram 1.1 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.
424     (if fd
425     (unwind-protect
426     (progn
427     (mp::mpwatchfor fd)
428 ram 1.2 (excl:if* timeout
429 ram 1.1 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)
432     t))
433     (mp::mpunwatchfor fd))
434 ram 1.2 (excl:if* timeout
435 ram 1.1 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)
438     t))))

  ViewVC Help
Powered by ViewVC 1.1.5