/[cmucl]/src/code/serve-event.lisp
ViewVC logotype

Contents of /src/code/serve-event.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13.1.1 - (hide annotations) (vendor branch)
Tue Jan 28 07:57:51 1992 UTC (22 years, 2 months ago) by wlott
Changes since 1.13: +6 -55 lines
New alien changes.
.,
1 ram 1.1 ;;; -*- Log: code.log; Package: LISP -*-
2    
3     ;;; **********************************************************************
4 ram 1.7 ;;; 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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.13.1.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/serve-event.lisp,v 1.13.1.1 1992/01/28 07:57:51 wlott Exp $")
11 ram 1.7 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; SYSTEM:SERVE-EVENT, now in it's own file.
15     ;;;
16     ;;; Re-written by William Lott, July 1989 - January 1990.
17     ;;;
18     ;;; **********************************************************************
19    
20     (in-package "SYSTEM")
21    
22     (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
23     serve-event serve-all-events wait-until-fd-usable))
24    
25 ram 1.2 (in-package "EXTENSIONS")
26    
27     (export '(*display-event-handlers*))
28    
29 ram 1.1 (in-package "LISP")
30    
31    
32    
33     ;;;; MACH Message receiving noise.
34    
35     (defvar *in-server* NIL
36     "*In-server* is set to T when the SIGMSG interrupt has been enabled
37     in Server.")
38    
39 wlott 1.3
40 ram 1.1
41     ;;;; File descriptor IO noise.
42    
43     (defstruct (handler
44     (:print-function %print-handler)
45     (:constructor make-handler (direction descriptor function)))
46 ram 1.8 (direction nil :type (member :input :output)) ; Either :input or :output
47     (descriptor 0 :type (mod 32)) ; File descriptor this handler is tied to.
48 ram 1.1 active ; T iff this handler is running.
49 ram 1.8 (function nil :type function) ; Function to call.
50 ram 1.1 bogus ; T if this descriptor is bogus.
51     )
52    
53     (defun %print-handler (handler stream depth)
54     (declare (ignore depth))
55     (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
56     (handler-direction handler)
57     (handler-bogus handler)
58     (handler-descriptor handler)
59     (handler-function handler)))
60    
61     (defvar *descriptor-handlers* nil
62     "List of all the currently active handlers for file descriptors")
63    
64    
65     ;;; ADD-FD-HANDLER -- public
66     ;;;
67     ;;; Add a new handler to *descriptor-handlers*.
68     ;;;
69     (defun add-fd-handler (fd direction function)
70     "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
71     either :INPUT or :OUTPUT. The value returned should be passed to
72     SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
73     (assert (member direction '(:input :output))
74     (direction)
75     "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
76     (let ((handler (make-handler direction fd function)))
77     (push handler *descriptor-handlers*)
78     handler))
79    
80     ;;; REMOVE-FD-HANDLER -- public
81     ;;;
82     ;;; Remove an old handler from *descriptor-handlers*.
83     ;;;
84     (defun remove-fd-handler (handler)
85     "Removes HANDLER from the list of active handlers."
86     (setf *descriptor-handlers*
87     (delete handler *descriptor-handlers*
88     :test #'eq)))
89    
90     ;;; INVALIDATE-DESCRIPTOR -- public
91     ;;;
92     ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
93     ;;;
94     (defun invalidate-descriptor (fd)
95     "Remove any handers refering to fd. This should only be used when attempting
96     to recover from a detected inconsistancy."
97     (setf *descriptor-handlers*
98     (delete fd *descriptor-handlers*
99     :key #'handler-descriptor)))
100    
101     ;;; WITH-FD-HANDLER -- Public.
102     ;;;
103     ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
104     ;;;
105     (defmacro with-fd-handler ((fd direction function) &rest body)
106     "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
107     DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
108     use, and FUNCTION is the function to call whenever FD is usable."
109     (let ((handler (gensym)))
110     `(let (,handler)
111     (unwind-protect
112     (progn
113     (setf ,handler (add-fd-handler ,fd ,direction ,function))
114     ,@body)
115     (when ,handler
116     (remove-fd-handler ,handler))))))
117    
118     ;;; WAIT-UNTIL-FD-USABLE -- Public.
119     ;;;
120     ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
121     ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
122     ;;; timeout at the correct time irrespective of how many events are handled in
123     ;;; the meantime.
124     ;;;
125     (defun wait-until-fd-usable (fd direction &optional timeout)
126     "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
127     :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
128     up."
129 ram 1.8 (declare (type (or index null) timeout))
130     (let (usable)
131     (multiple-value-bind
132     (stop-sec stop-usec)
133     (if timeout
134     (multiple-value-bind (okay sec usec)
135 wlott 1.13.1.1 (unix:unix-gettimeofday)
136 ram 1.8 (declare (ignore okay))
137     (values (the (unsigned-byte 32) (+ sec timeout))
138     usec))
139     (values 0 0))
140     (declare (type (unsigned-byte 32) stop-sec stop-usec))
141     (with-fd-handler (fd direction #'(lambda (fd)
142     (declare (ignore fd))
143     (setf usable t)))
144     (loop
145     (serve-event timeout)
146    
147     (when usable
148     (return t))
149    
150     (when timeout
151     (multiple-value-bind (okay sec usec)
152 wlott 1.13.1.1 (unix:unix-gettimeofday)
153 ram 1.8 (declare (ignore okay))
154     (when (or (> sec stop-sec)
155     (and (= sec stop-sec) (>= usec stop-usec)))
156     (return nil))
157     (setq timeout (- stop-sec sec)))))))))
158 ram 1.1
159    
160     ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
161     ;;;
162     ;;; First, get a list and mark bad file descriptors. Then signal an error
163     ;;; offering a few restarts.
164     ;;;
165     (defun handler-descriptors-error ()
166     (let ((bogus-handlers nil))
167     (dolist (handler *descriptor-handlers*)
168     (unless (or (handler-bogus handler)
169 wlott 1.13.1.1 (unix:unix-fstat (handler-descriptor handler)))
170 ram 1.1 (setf (handler-bogus handler) t)
171     (push handler bogus-handlers)))
172     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
173     bogus-handlers (length bogus-handlers))
174     (remove-them () :report "Remove bogus handlers."
175     (setf *descriptor-handlers*
176     (delete-if #'handler-bogus *descriptor-handlers*)))
177     (retry-them () :report "Retry bogus handlers."
178     (dolist (handler bogus-handlers)
179     (setf (handler-bogus handler) nil)))
180     (continue () :report "Go on, leaving handlers marked as bogus."))))
181    
182    
183    
184     ;;;; Serve-all-events, serve-event, and friends.
185    
186 ram 1.8 (declaim (start-block serve-event serve-all-events))
187    
188 ram 1.2 (defvar *display-event-handlers* nil
189     "This is an alist mapping displays to user functions to be called when
190     SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
191     this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
192     should be represented here only once.")
193    
194 ram 1.1 ;;; SERVE-ALL-EVENTS -- public
195     ;;;
196     ;;; Wait for up to timeout seconds for an event to happen. Make sure all
197     ;;; pending events are processed before returning.
198     ;;;
199     (defun serve-all-events (&optional timeout)
200     "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
201     SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
202     0 until all events have been served. SERVE-ALL-EVENTS returns T if
203     SERVE-EVENT did something and NIL if not."
204     (do ((res nil)
205     (sval (serve-event timeout) (serve-event 0)))
206     ((null sval) res)
207     (setq res t)))
208    
209 ram 1.2
210 ram 1.1 ;;; SERVE-EVENT -- public
211     ;;;
212     ;;; Serve a single event.
213     ;;;
214     (defun serve-event (&optional timeout)
215     "Receive on all ports and Xevents and dispatch to the appropriate handler
216     function. If timeout is specified, server will wait the specified time (in
217     seconds) and then return, otherwise it will wait until something happens.
218     Server returns T if something happened and NIL otherwise."
219     ;; First, check any X displays for any pending events.
220 ram 1.6 #+clx
221 ram 1.2 (dolist (d/h *display-event-handlers*)
222 ram 1.11 (let* ((d (car d/h))
223     (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
224 ram 1.9 (declare (inline member))
225     ;;
226     ;; If in the *descriptor-handlers*, then we are already waiting for input
227     ;; on that display, and we don't want to do it recursively.
228 ram 1.11 (when (and (dolist (hand *descriptor-handlers* t)
229     (when (and (eql (handler-descriptor hand) disp-fd)
230     (not (eq (handler-function hand)
231     #'ext::call-display-event-handler)))
232     (return nil)))
233 ram 1.9 (xlib::event-listen d))
234 ram 1.1 (handler-bind ((error #'(lambda (condx)
235     (declare (ignore condx))
236     (flush-display-events d))))
237 ram 1.12 (unless (funcall (cdr d/h) d)
238 ram 1.13 (disable-clx-event-handling d)
239 ram 1.12 (error "Event-listen was true, but handler didn't handle: ~%~S"
240     d/h)))
241 ram 1.1 (return-from serve-event t))))
242     ;; Next, wait for something to happen.
243     (multiple-value-bind
244     (value readable writeable)
245     (wait-for-event timeout)
246 ram 1.8 (declare (type (unsigned-byte 32) readable writeable))
247 ram 1.1 ;; Now see what it was (if anything)
248 ram 1.11 (cond ((fixnump value)
249 ram 1.1 (unless (zerop value)
250     ;; Check the descriptors.
251     (let ((result nil))
252     (dolist (handler *descriptor-handlers*)
253 ram 1.8 (when (logbitp (handler-descriptor handler)
254     (ecase (handler-direction handler)
255     (:input readable)
256     (:output writeable)))
257 ram 1.1 (unwind-protect
258     (progn
259     ;; Doesn't work -- ACK
260     ;(setf (handler-active handler) t)
261     (funcall (handler-function handler)
262     (handler-descriptor handler)))
263     (setf (handler-active handler) nil))
264     (macrolet ((frob (var)
265     `(setf ,var
266 ram 1.8 (logand (32bit-logical-not
267     (ash 1
268     (handler-descriptor
269     handler)))
270 ram 1.1 ,var))))
271 ram 1.5 (ecase (handler-direction handler)
272 ram 1.1 (:input (frob readable))
273     (:output (frob writeable))))
274     (setf result t)))
275     result)))
276 wlott 1.13.1.1 ((eql readable unix:eintr)
277 ram 1.1 ;; We did an interrupt.
278     t)
279     (t
280     ;; One of the file descriptors is bad.
281     (handler-descriptors-error)
282     nil))))
283    
284 ram 1.8
285     ;;; CALC-MASKS -- Internal.
286     ;;;
287     ;;; Return the correct masks to use for UNIX-SELECT. The four return values
288     ;;; are: fd count, read mask, write mask, and exception mask. The exception
289     ;;; mask is currently unused.
290     ;;;
291     (defun calc-masks ()
292     (let ((count 0)
293     (read-mask 0)
294     (write-mask 0)
295     (except-mask 0))
296     (declare (type index count)
297     (type (unsigned-byte 32) read-mask write-mask except-mask))
298     (dolist (handler *descriptor-handlers*)
299     (unless (or (handler-active handler)
300     (handler-bogus handler))
301     (let ((fd (handler-descriptor handler)))
302     (ecase (handler-direction handler)
303     (:input
304     (setf read-mask
305     (logior read-mask
306     (the (unsigned-byte 32) (ash 1 fd)))))
307     (:output
308     (setf write-mask
309     (logior write-mask
310     (the (unsigned-byte 32) (ash 1 fd))))))
311     (when (> fd count)
312     (setf count fd)))))
313     (values (1+ count)
314     read-mask
315     write-mask
316     except-mask)))
317    
318 ram 1.1 ;;; WAIT-FOR-EVENT -- internal
319     ;;;
320     ;;; Wait for something to happen.
321     ;;;
322     (defun wait-for-event (&optional timeout)
323     "Wait for an something to show up on one of the file descriptors or a message
324     interupt to fire. Timeout is in seconds."
325 ram 1.10 (multiple-value-bind
326     (timeout-sec timeout-usec)
327     (typecase timeout
328     (integer (values timeout 0))
329     (null (values nil 0))
330     (t
331     (multiple-value-bind (q r)
332     (truncate (coerce timeout 'single-float))
333     (declare (type index q) (single-float r))
334     (values q (truncate (* r 1f6))))))
335 ram 1.8 (declare (type index timeout-usec)
336     (type (or index null) timeout-sec))
337     (multiple-value-bind (count read-mask write-mask except-mask)
338     (calc-masks)
339     ;; Do the select.
340 wlott 1.13.1.1 (unix:unix-select count read-mask write-mask except-mask
341 ram 1.8 timeout-sec timeout-usec))))

  ViewVC Help
Powered by ViewVC 1.1.5