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

Contents of /src/clx/excldep.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide 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 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 ram 1.2 (in-package :xlib)
17 ram 1.1
18 ram 1.2 (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 ram 1.1 (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 ram 1.2 '(#-(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 ram 1.1
99     ;; This (if (and ...) t nil) stuff has a purpose -- it lets the old
100     ;; sun4 compiler opencode the `and'.
101    
102 ram 1.2 #-(version>= 4 1 devel 16)
103 ram 1.1 (defun card8p (x)
104     (declare (optimize (speed 3) (safety 0))
105     (fixnum x))
106 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 8) x) (>= x 0))
107 ram 1.1 t
108     nil))
109    
110 ram 1.2 #-(version>= 4 1 devel 16)
111 ram 1.1 (defun card16p (x)
112     (declare (optimize (speed 3) (safety 0))
113     (fixnum x))
114 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 16) x) (>= x 0))
115 ram 1.1 t
116     nil))
117    
118 ram 1.2 #-(version>= 4 1 devel 16)
119 ram 1.1 (defun card29p (x)
120     (declare (optimize (speed 3) (safety 0)))
121 ram 1.2 (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
122     (and (excl:bignump x) (> #.(expt 2 29) (the bignum x))
123 ram 1.1 (>= (the bignum x) 0)))
124     t
125     nil))
126    
127 ram 1.2 #-(version>= 4 1 devel 16)
128 ram 1.1 (defun card32p (x)
129     (declare (optimize (speed 3) (safety 0)))
130 ram 1.2 (if (or (and (excl:fixnump x) (>= (the fixnum x) 0))
131     (and (excl:bignump x) (> #.(expt 2 32) (the bignum x))
132 ram 1.1 (>= (the bignum x) 0)))
133     t
134     nil))
135    
136 ram 1.2 #-(version>= 4 1 devel 16)
137 ram 1.1 (defun int8p (x)
138     (declare (optimize (speed 3) (safety 0))
139     (fixnum x))
140 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 7) x) (>= x #.(expt -2 7)))
141 ram 1.1 t
142     nil))
143    
144 ram 1.2 #-(version>= 4 1 devel 16)
145 ram 1.1 (defun int16p (x)
146     (declare (optimize (speed 3) (safety 0))
147     (fixnum x))
148 ram 1.2 (if (and (excl:fixnump x) (> #.(expt 2 15) x) (>= x #.(expt -2 15)))
149 ram 1.1 t
150     nil))
151    
152 ram 1.2 #-(version>= 4 1 devel 16)
153 ram 1.1 (defun int32p (x)
154     (declare (optimize (speed 3) (safety 0)))
155 ram 1.2 (if (or (excl:fixnump x)
156     (and (excl:bignump x) (> #.(expt 2 31) (the bignum x))
157 ram 1.1 (>= (the bignum x) #.(expt -2 31))))
158     t
159     nil))
160    
161 ram 1.2 ;; 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 ram 1.1
177 ram 1.2 (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 ram 1.1
184 ram 1.2
185 ram 1.1 ;; 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 ram 1.2 (excl:if* errcode
191 ram 1.1 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 ram 1.2 (excl:if* errcode
213 ram 1.1 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 ram 1.2 (eval-when (compile load eval)
256     (unless (find-package :patch)
257     (make-package :patch :use '(:lisp :excl))))
258 ram 1.1
259 ram 1.2 (in-package :patch)
260    
261 ram 1.1 (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 ram 1.2 excl::cl-generation-number
269 ram 1.1 (< 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 ram 1.2 (unless (excl:fixnump secs) (setq secs most-positive-fixnum))
301 ram 1.1 (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 ram 1.2 (excl:if* (eq ret 'with-timeout-internal)
323 ram 1.1 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 ram 1.2 (excl:if* (null (process-lock-locker lock))
337 ram 1.1 then (setf (process-lock-locker lock) lock-value)
338 ram 1.2 else (excl:if* timeout
339     then (excl:if* (or (eq 0 timeout) ;for speed
340     (zerop timeout))
341 ram 1.1 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 ram 1.2 (excl:if* (apply function args)
406 ram 1.1 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 ram 1.2 (let ((fd (excl:if* (excl:fixnump stream-or-fd) then stream-or-fd
430 ram 1.1 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 ram 1.2 (excl:if* timeout
440 ram 1.1 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 ram 1.2 (excl:if* timeout
446 ram 1.1 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