/[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.27 - (hide annotations)
Thu Apr 8 14:00:03 2004 UTC (10 years ago) by emarsden
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, sse2-base, sse2-packed-base, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, unicode-utf16-sync-2008-12, release-19c-base, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, snapshot-2004-12, snapshot-2004-11, unicode-snapshot-2009-05, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, snapshot-2008-04, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, snapshot-2005-12, snapshot-2005-01, unicode-utf16-string-support, release-19c-pre1, release-19e-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, snapshot-2005-09, snapshot-2005-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, RELEASE-19F-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, double-double-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, unicode-utf16-extfmt-branch
Changes since 1.26: +8 -2 lines
Revert to old behaviour for SERVE-EVENT and reentry of handler functions.
Don't mask out file descriptors whose handlers are active from the set of
descriptors that we check for activity.

The possibility for reentry of handler functions is required by Hemlock's
slave lisp mechansism, which uses SERVE-EVENT via the WIRE facility.
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     ;;;
7     (ext:file-comment
8 emarsden 1.27 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/serve-event.lisp,v 1.27 2004/04/08 14:00:03 emarsden Exp $")
9 ram 1.7 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; SYSTEM:SERVE-EVENT, now in it's own file.
13     ;;;
14     ;;; Re-written by William Lott, July 1989 - January 1990.
15     ;;;
16     ;;; **********************************************************************
17    
18     (in-package "SYSTEM")
19    
20     (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
21 wlott 1.15 serve-event serve-all-events wait-until-fd-usable
22     make-object-set object-set-operation *xwindow-table*
23     map-xwindow add-xwindow-object remove-xwindow-object))
24 ram 1.1
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 wlott 1.15 ;;;; Object set stuff.
34 ram 1.1
35 wlott 1.15 ;;;
36     ;;; Hashtable from ports to objects. Each entry is a cons (object . set).
37     ;;;
38     ;(defvar *port-table* (make-hash-table :test #'eql))
39    
40     ;;; Hashtable from windows to objects. Each entry is a cons (object . set).
41     ;;;
42     (defvar *xwindow-table* (make-hash-table :test #'eql))
43    
44    
45     (defstruct (object-set
46     (:constructor make-object-set
47     (name &optional
48     (default-handler #'default-default-handler)))
49     (:print-function
50     (lambda (s stream d)
51     (declare (ignore d))
52     (format stream "#<Object Set ~S>" (object-set-name s)))))
53     name ; Name, for descriptive purposes.
54     (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun.
55     default-handler)
56    
57     (setf (documentation 'make-object-set 'function)
58     "Make an object set for use by a RPC/xevent server. Name is for
59     descriptive purposes only.")
60    
61     ;;; Default-Default-Handler -- Internal
62     ;;;
63     ;;; If no such operation defined, signal an error.
64     ;;;
65     (defun default-default-handler (object)
66     (error "You lose, object: ~S" object))
67    
68    
69     ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
70     ;;; object set mapped to by a xwindow or port in *xwindow-table* or
71     ;;; *port-table*.
72     ;;;
73     (macrolet ((defmapper (name table)
74     `(defun ,(intern (concatenate 'simple-string
75     "MAP-" (symbol-name name)))
76     (,name)
77     ,(format nil "Return as multiple values the object and ~
78     object-set mapped to by ~A."
79     (string-downcase (symbol-name name)))
80     (let ((temp (gethash ,name ,table)))
81     (if temp
82     (values (car temp) (cdr temp))
83     (values nil nil))))))
84     ;(defmapper port *port-table*)
85     (defmapper xwindow *xwindow-table*))
86    
87    
88     ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
89     ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
90     ;;;
91     (macrolet ((def-add-object (name table)
92     `(defun ,(intern (concatenate 'simple-string
93     "ADD-" (symbol-name name)
94     "-OBJECT"))
95     (,name object object-set)
96     ,(format nil "Add a new ~A/object/object-set association."
97     (string-downcase (symbol-name name)))
98     (check-type object-set object-set)
99     (setf (gethash ,name ,table) (cons object object-set))
100     object)))
101     ;(def-add-object port *port-table*)
102     (def-add-object xwindow *xwindow-table*))
103    
104    
105     ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
106     ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
107     ;;;
108     (macrolet ((def-remove-object (name table)
109     `(defun ,(intern (concatenate 'simple-string
110     "REMOVE-" (symbol-name name)
111     "-OBJECT"))
112     (,name)
113     ,(format nil
114     "Remove ~A and its associated object/object-set pair."
115     (string-downcase (symbol-name name)))
116     (remhash ,name ,table))))
117     ;(def-remove-object port *port-table*)
118     (def-remove-object xwindow *xwindow-table*))
119    
120    
121     ;;; Object-Set-Operation -- Public
122     ;;;
123     ;;; Look up the handler function for a given message ID.
124     ;;;
125     (defun object-set-operation (object-set message-id)
126     "Return the handler function in Object-Set for the operation specified by
127     Message-ID, if none, NIL is returned."
128     (check-type object-set object-set)
129     (check-type message-id fixnum)
130     (values (gethash message-id (object-set-table object-set))))
131    
132     ;;; %Set-Object-Set-Operation -- Internal
133     ;;;
134     ;;; The setf inverse for Object-Set-Operation.
135     ;;;
136     (defun %set-object-set-operation (object-set message-id new-value)
137     (check-type object-set object-set)
138     (check-type message-id fixnum)
139     (setf (gethash message-id (object-set-table object-set)) new-value))
140     ;;;
141     (defsetf object-set-operation %set-object-set-operation
142     "Sets the handler function for an object set operation.")
143 ram 1.1
144 wlott 1.3
145 ram 1.1
146     ;;;; File descriptor IO noise.
147    
148     (defstruct (handler
149     (:print-function %print-handler)
150     (:constructor make-handler (direction descriptor function)))
151 ram 1.20 ;; Reading or writing...
152     (direction nil :type (member :input :output))
153     ;;
154     ;; File descriptor this handler is tied to.
155     (descriptor 0 :type (mod #.unix:fd-setsize))
156    
157 ram 1.1 active ; T iff this handler is running.
158 ram 1.8 (function nil :type function) ; Function to call.
159 ram 1.1 bogus ; T if this descriptor is bogus.
160     )
161    
162     (defun %print-handler (handler stream depth)
163     (declare (ignore depth))
164     (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"
165     (handler-direction handler)
166     (handler-bogus handler)
167     (handler-descriptor handler)
168     (handler-function handler)))
169    
170     (defvar *descriptor-handlers* nil
171     "List of all the currently active handlers for file descriptors")
172    
173     ;;; ADD-FD-HANDLER -- public
174     ;;;
175     ;;; Add a new handler to *descriptor-handlers*.
176     ;;;
177     (defun add-fd-handler (fd direction function)
178     "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
179     either :INPUT or :OUTPUT. The value returned should be passed to
180     SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
181     (assert (member direction '(:input :output))
182     (direction)
183     "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
184     (let ((handler (make-handler direction fd function)))
185     (push handler *descriptor-handlers*)
186     handler))
187    
188     ;;; REMOVE-FD-HANDLER -- public
189     ;;;
190     ;;; Remove an old handler from *descriptor-handlers*.
191     ;;;
192     (defun remove-fd-handler (handler)
193     "Removes HANDLER from the list of active handlers."
194     (setf *descriptor-handlers*
195     (delete handler *descriptor-handlers*
196     :test #'eq)))
197    
198     ;;; INVALIDATE-DESCRIPTOR -- public
199     ;;;
200     ;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
201     ;;;
202     (defun invalidate-descriptor (fd)
203 emarsden 1.26 "Remove any handers refering to FD. This should only be used when attempting
204     to recover from a detected inconsistency."
205 ram 1.1 (setf *descriptor-handlers*
206     (delete fd *descriptor-handlers*
207     :key #'handler-descriptor)))
208    
209     ;;; WITH-FD-HANDLER -- Public.
210     ;;;
211     ;;; Add the handler to *descriptor-handlers* for the duration of BODY.
212     ;;;
213     (defmacro with-fd-handler ((fd direction function) &rest body)
214     "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
215     DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
216     use, and FUNCTION is the function to call whenever FD is usable."
217     (let ((handler (gensym)))
218     `(let (,handler)
219     (unwind-protect
220     (progn
221     (setf ,handler (add-fd-handler ,fd ,direction ,function))
222     ,@body)
223     (when ,handler
224     (remove-fd-handler ,handler))))))
225    
226    
227     ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
228     ;;;
229     ;;; First, get a list and mark bad file descriptors. Then signal an error
230     ;;; offering a few restarts.
231     ;;;
232     (defun handler-descriptors-error ()
233     (let ((bogus-handlers nil))
234     (dolist (handler *descriptor-handlers*)
235     (unless (or (handler-bogus handler)
236 wlott 1.14 (unix:unix-fstat (handler-descriptor handler)))
237 ram 1.1 (setf (handler-bogus handler) t)
238     (push handler bogus-handlers)))
239     (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
240     bogus-handlers (length bogus-handlers))
241     (remove-them () :report "Remove bogus handlers."
242     (setf *descriptor-handlers*
243     (delete-if #'handler-bogus *descriptor-handlers*)))
244     (retry-them () :report "Retry bogus handlers."
245     (dolist (handler bogus-handlers)
246     (setf (handler-bogus handler) nil)))
247     (continue () :report "Go on, leaving handlers marked as bogus."))))
248    
249    
250    
251     ;;;; Serve-all-events, serve-event, and friends.
252    
253 ram 1.20 (declaim (start-block wait-until-fd-usable serve-event serve-all-events))
254 ram 1.8
255 ram 1.16 ;;; DECODE-TIMEOUT -- Internal
256     ;;;
257     ;;; Break a real timeout into seconds and microseconds.
258     ;;;
259     (defun decode-timeout (timeout)
260     (declare (values (or index null) index))
261     (typecase timeout
262     (integer (values timeout 0))
263     (null (values nil 0))
264     (real
265     (multiple-value-bind (q r)
266     (truncate (coerce timeout 'single-float))
267     (declare (type index q) (single-float r))
268 dtc 1.25 (values q (the (values index t) (truncate (* r 1f6))))))
269 ram 1.16 (t
270     (error "Timeout is not a real number or NIL: ~S" timeout))))
271    
272    
273     ;;; WAIT-UNTIL-FD-USABLE -- Public.
274     ;;;
275     ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
276     ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
277     ;;; timeout at the correct time irrespective of how many events are handled in
278     ;;; the meantime.
279     ;;;
280     (defun wait-until-fd-usable (fd direction &optional timeout)
281     "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
282     :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
283     up."
284     (declare (type (or real null) timeout))
285     (let (usable)
286     (multiple-value-bind (to-sec to-usec)
287     (decode-timeout timeout)
288     (declare (type (or index null) to-sec to-usec))
289     (multiple-value-bind
290     (stop-sec stop-usec)
291     (if to-sec
292     (multiple-value-bind (okay start-sec start-usec)
293     (unix:unix-gettimeofday)
294     (declare (ignore okay))
295     (let ((usec (+ to-usec start-usec))
296     (sec (+ to-sec start-sec)))
297     (declare (type (unsigned-byte 31) usec sec))
298     (if (>= usec 1000000)
299     (values (1+ sec) (- usec 1000000))
300     (values sec usec))))
301     (values 0 0))
302     (declare (type (unsigned-byte 31) stop-sec stop-usec))
303     (with-fd-handler (fd direction #'(lambda (fd)
304     (declare (ignore fd))
305     (setf usable t)))
306     (loop
307     (sub-serve-event to-sec to-usec)
308    
309     (when usable
310     (return t))
311    
312     (when timeout
313     (multiple-value-bind (okay sec usec)
314     (unix:unix-gettimeofday)
315     (declare (ignore okay))
316     (when (or (> sec stop-sec)
317     (and (= sec stop-sec) (>= usec stop-usec)))
318     (return nil))
319     (setq to-sec (- stop-sec sec))
320 ram 1.17 (cond ((> usec stop-usec)
321     (decf to-sec)
322     (setq to-usec (- (+ stop-usec 1000000) usec)))
323     (t
324     (setq to-usec (- stop-usec usec))))))))))))
325 ram 1.16
326    
327 ram 1.2 (defvar *display-event-handlers* nil
328     "This is an alist mapping displays to user functions to be called when
329     SYSTEM:SERVE-EVENT notices input on a display connection. Do not modify
330     this directly; use EXT:ENABLE-CLX-EVENT-HANDLING. A given display
331     should be represented here only once.")
332    
333 ram 1.1 ;;; SERVE-ALL-EVENTS -- public
334     ;;;
335     ;;; Wait for up to timeout seconds for an event to happen. Make sure all
336     ;;; pending events are processed before returning.
337     ;;;
338     (defun serve-all-events (&optional timeout)
339     "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
340     SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
341     0 until all events have been served. SERVE-ALL-EVENTS returns T if
342     SERVE-EVENT did something and NIL if not."
343     (do ((res nil)
344     (sval (serve-event timeout) (serve-event 0)))
345     ((null sval) res)
346     (setq res t)))
347    
348 ram 1.2
349 ram 1.1 ;;; SERVE-EVENT -- public
350     ;;;
351     ;;; Serve a single event.
352     ;;;
353     (defun serve-event (&optional timeout)
354     "Receive on all ports and Xevents and dispatch to the appropriate handler
355     function. If timeout is specified, server will wait the specified time (in
356     seconds) and then return, otherwise it will wait until something happens.
357     Server returns T if something happened and NIL otherwise."
358 ram 1.16 (multiple-value-bind (to-sec to-usec)
359     (decode-timeout timeout)
360     (sub-serve-event to-sec to-usec)))
361    
362    
363     ;;; Check for any X displays with pending events.
364     ;;;
365     (defun handle-queued-clx-event ()
366 ram 1.2 (dolist (d/h *display-event-handlers*)
367 ram 1.11 (let* ((d (car d/h))
368     (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
369 ram 1.9 (declare (inline member))
370     ;;
371     ;; If in the *descriptor-handlers*, then we are already waiting for input
372     ;; on that display, and we don't want to do it recursively.
373 ram 1.11 (when (and (dolist (hand *descriptor-handlers* t)
374     (when (and (eql (handler-descriptor hand) disp-fd)
375     (not (eq (handler-function hand)
376     #'ext::call-display-event-handler)))
377     (return nil)))
378 ram 1.9 (xlib::event-listen d))
379 ram 1.1 (handler-bind ((error #'(lambda (condx)
380     (declare (ignore condx))
381     (flush-display-events d))))
382 ram 1.12 (unless (funcall (cdr d/h) d)
383 ram 1.13 (disable-clx-event-handling d)
384 ram 1.12 (error "Event-listen was true, but handler didn't handle: ~%~S"
385     d/h)))
386 ram 1.16 (return-from handle-queued-clx-event t)))))
387    
388    
389 ram 1.20 ;;; These macros are chunks of code from SUB-SERVE-EVENT. They randomly
390     ;;; reference the READ-FDS and WRITE-FDS Alien variables (which wold be consed
391     ;;; if passed as function arguments.)
392     ;;;
393     (eval-when (compile eval)
394    
395     ;;; CALC-MASKS -- Internal.
396     ;;;
397     ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
398     ;;; count.
399     ;;;
400 emarsden 1.27 ;;; Ideally we would mask out descriptors whose handler is already
401     ;;; active, since handler functions may not be reentrant.
402     ;;; Unfortunately, this would not be compatible with the way that
403     ;;; Hemlock's slave lisp mechanism interacts with the WIRE facility:
404     ;;; requests sent to the slave lisp may require a call to the master
405     ;;; lisp over the same wire.
406 ram 1.20 (defmacro calc-masks ()
407     '(progn
408     (unix:fd-zero read-fds)
409     (unix:fd-zero write-fds)
410     (let ((count 0))
411     (declare (type index count))
412     (dolist (handler *descriptor-handlers*)
413 emarsden 1.27 (unless (or ; (handler-active handler)
414 ram 1.20 (handler-bogus handler))
415     (let ((fd (handler-descriptor handler)))
416     (ecase (handler-direction handler)
417     (:input (unix:fd-set fd read-fds))
418     (:output (unix:fd-set fd write-fds)))
419     (when (> fd count)
420     (setf count fd)))))
421     (1+ count))))
422    
423    
424 ram 1.16 ;;; Call file descriptor handlers according to the readable and writable masks
425     ;;; returned by select.
426     ;;;
427 ram 1.20 (defmacro call-fd-handler ()
428     '(let ((result nil))
429     (dolist (handler *descriptor-handlers*)
430     (let ((desc (handler-descriptor handler)))
431     (when (ecase (handler-direction handler)
432     (:input (unix:fd-isset desc read-fds))
433     (:output (unix:fd-isset desc write-fds)))
434     (unwind-protect
435     (progn
436 emarsden 1.26 (setf (handler-active handler) t)
437 ram 1.20 (funcall (handler-function handler) desc))
438     (setf (handler-active handler) nil))
439     (ecase (handler-direction handler)
440     (:input (unix:fd-clr desc read-fds))
441     (:output (unix:fd-clr desc write-fds)))
442 emarsden 1.26 (setf result t))))
443     result))
444 ram 1.16
445 ram 1.20 ); eval-when (compile eval)
446 ram 1.16
447 dtc 1.23 ;;; When a *periodic-polling-function* is defined the server will not
448     ;;; block for more than the maximum event timeout and will call the
449     ;;; polling function if it does times out. One important use of this
450     ;;; is to periodically call process-yield.
451     ;;;
452     (declaim (type (or null function) *periodic-polling-function*))
453     (defvar *periodic-polling-function*
454     #-mp nil #+mp #'mp:process-yield)
455     (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
456     (defvar *max-event-to-sec* 1)
457     (defvar *max-event-to-usec* 0)
458 ram 1.20
459 ram 1.16 ;;; SUB-SERVE-EVENT -- Internal
460     ;;;
461     ;;; Takes timeout broken into seconds and microseconds.
462     ;;;
463     (defun sub-serve-event (to-sec to-usec)
464 dtc 1.23 (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
465    
466 ram 1.20 (when (handle-queued-clx-event) (return-from sub-serve-event t))
467 dtc 1.23
468     (let ((call-polling-fn nil))
469     (when (and *periodic-polling-function*
470     ;; Enforce a maximum timeout.
471     (or (null to-sec)
472     (> to-sec *max-event-to-sec*)
473     (and (= to-sec *max-event-to-sec*)
474     (> to-usec *max-event-to-usec*))))
475     (setf to-sec *max-event-to-sec*)
476     (setf to-usec *max-event-to-usec*)
477     (setf call-polling-fn t))
478    
479     ;; Next, wait for something to happen.
480     (alien:with-alien ((read-fds (alien:struct unix:fd-set))
481     (write-fds (alien:struct unix:fd-set)))
482     (let ((count (calc-masks)))
483     (multiple-value-bind
484     (value err)
485     (unix:unix-fast-select
486     count
487     (alien:addr read-fds) (alien:addr write-fds)
488     nil to-sec to-usec)
489 ram 1.20
490 dtc 1.23 ;; Now see what it was (if anything)
491     (cond (value
492     (cond ((zerop value)
493     ;; Timed out.
494     (when call-polling-fn
495     (funcall *periodic-polling-function*)))
496     (t
497     (call-fd-handler))))
498     ((eql err unix:eintr)
499     ;; We did an interrupt.
500     t)
501     (t
502     ;; One of the file descriptors is bad.
503     (handler-descriptors-error)
504     nil)))))))
505 ram 1.1

  ViewVC Help
Powered by ViewVC 1.1.5