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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13.1.1 by wlott, Tue Jan 28 07:57:51 1992 UTC revision 1.31 by rtoy, Tue Apr 20 17:57:45 2010 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; 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.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 19  Line 17 
17    
18  (in-package "SYSTEM")  (in-package "SYSTEM")
19    
20    (intl:textdomain "cmucl")
21    
22  (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor  (export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor
23            serve-event serve-all-events wait-until-fd-usable))            serve-event serve-all-events wait-until-fd-usable
24              make-object-set object-set-operation *xwindow-table*
25              map-xwindow add-xwindow-object remove-xwindow-object))
26    
27  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
28    
# Line 30  Line 32 
32    
33    
34    
35  ;;;; MACH Message receiving noise.  ;;;; Object set stuff.
36    
37    ;;;
38    ;;;    Hashtable from ports to objects.  Each entry is a cons (object . set).
39    ;;;
40    ;(defvar *port-table* (make-hash-table :test #'eql))
41    
42    ;;; Hashtable from windows to objects.  Each entry is a cons (object . set).
43    ;;;
44    (defvar *xwindow-table* (make-hash-table :test #'eql))
45    
46    
47    (defstruct (object-set
48                (:constructor make-object-set
49                              (name &optional
50                                    (default-handler #'default-default-handler)))
51                (:print-function
52                 (lambda (s stream d)
53                   (declare (ignore d))
54                   (format stream "#<Object Set ~S>" (object-set-name s)))))
55      name                                  ; Name, for descriptive purposes.
56      (table (make-hash-table :test #'eq))  ; Message-ID or xevent-type --> handler fun.
57      default-handler)
58    
59  (defvar *in-server* NIL  (setf (documentation 'make-object-set 'function)
60    "*In-server* is set to T when the SIGMSG interrupt has been enabled        (intl:gettext "Make an object set for use by a RPC/xevent server.  Name is for
61    in Server.")        descriptive purposes only."))
62    
63    ;;; Default-Default-Handler  --  Internal
64    ;;;
65    ;;;    If no such operation defined, signal an error.
66    ;;;
67    (defun default-default-handler (object)
68      (error (intl:gettext "You lose, object: ~S") object))
69    
70    
71    ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
72    ;;; object set mapped to by a xwindow or port in *xwindow-table* or
73    ;;; *port-table*.
74    ;;;
75    (macrolet ((defmapper (name table)
76                  `(defun ,(intern (concatenate 'simple-string
77                                                "MAP-" (symbol-name name)))
78                          (,name)
79                     ,(format nil "Return as multiple values the object and ~
80                                   object-set mapped to by ~A."
81                              (string-downcase (symbol-name name)))
82                     (let ((temp (gethash ,name ,table)))
83                       (if temp
84                           (values (car temp) (cdr temp))
85                           (values nil nil))))))
86      ;(defmapper port *port-table*)
87      (defmapper xwindow *xwindow-table*))
88    
89    
90    ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
91    ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
92    ;;;
93    (macrolet ((def-add-object (name table)
94                  `(defun ,(intern (concatenate 'simple-string
95                                                "ADD-" (symbol-name name)
96                                                "-OBJECT"))
97                          (,name object object-set)
98                     ,(format nil "Add a new ~A/object/object-set association."
99                              (string-downcase (symbol-name name)))
100                     (check-type object-set object-set)
101                     (setf (gethash ,name ,table) (cons object object-set))
102                     object)))
103      ;(def-add-object port *port-table*)
104      (def-add-object xwindow *xwindow-table*))
105    
106    
107    ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
108    ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
109    ;;;
110    (macrolet ((def-remove-object (name table)
111                  `(defun ,(intern (concatenate 'simple-string
112                                                "REMOVE-" (symbol-name name)
113                                                "-OBJECT"))
114                          (,name)
115                     ,(format nil
116                              "Remove ~A and its associated object/object-set pair."
117                              (string-downcase (symbol-name name)))
118                     (remhash ,name ,table))))
119      ;(def-remove-object port *port-table*)
120      (def-remove-object xwindow *xwindow-table*))
121    
122    
123    ;;; Object-Set-Operation  --  Public
124    ;;;
125    ;;;    Look up the handler function for a given message ID.
126    ;;;
127    (defun object-set-operation (object-set message-id)
128      "Return the handler function in Object-Set for the operation specified by
129       Message-ID, if none, NIL is returned."
130      (check-type object-set object-set)
131      (check-type message-id fixnum)
132      (values (gethash message-id (object-set-table object-set))))
133    
134    ;;; %Set-Object-Set-Operation  --  Internal
135    ;;;
136    ;;;    The setf inverse for Object-Set-Operation.
137    ;;;
138    (defun %set-object-set-operation (object-set message-id new-value)
139      (check-type object-set object-set)
140      (check-type message-id fixnum)
141      (setf (gethash message-id (object-set-table object-set)) new-value))
142    ;;;
143    (defsetf object-set-operation %set-object-set-operation
144      "Sets the handler function for an object set operation.")
145    
146    
147    
# Line 43  Line 150 
150  (defstruct (handler  (defstruct (handler
151              (:print-function %print-handler)              (:print-function %print-handler)
152              (:constructor make-handler (direction descriptor function)))              (:constructor make-handler (direction descriptor function)))
153    (direction nil :type (member :input :output)) ; Either :input or :output    ;; Reading or writing...
154    (descriptor 0 :type (mod 32)) ; File descriptor this handler is tied to.    (direction nil :type (member :input :output))
155      ;;
156      ;; File descriptor this handler is tied to.
157      (descriptor 0 :type (mod #.unix:fd-setsize))
158    
159    active                      ; T iff this handler is running.    active                      ; T iff this handler is running.
160    (function nil :type function) ; Function to call.    (function nil :type function) ; Function to call.
161    bogus                       ; T if this descriptor is bogus.    bogus                       ; T if this descriptor is bogus.
# Line 52  Line 163 
163    
164  (defun %print-handler (handler stream depth)  (defun %print-handler (handler stream depth)
165    (declare (ignore depth))    (declare (ignore depth))
166    (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>"    (format stream (intl:gettext "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>")
167            (handler-direction handler)            (handler-direction handler)
168            (handler-bogus handler)            (handler-bogus handler)
169            (handler-descriptor handler)            (handler-descriptor handler)
# Line 61  Line 172 
172  (defvar *descriptor-handlers* nil  (defvar *descriptor-handlers* nil
173    "List of all the currently active handlers for file descriptors")    "List of all the currently active handlers for file descriptors")
174    
   
175  ;;; ADD-FD-HANDLER -- public  ;;; ADD-FD-HANDLER -- public
176  ;;;  ;;;
177  ;;;   Add a new handler to *descriptor-handlers*.  ;;;   Add a new handler to *descriptor-handlers*.
# Line 72  Line 182 
182    SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."    SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
183    (assert (member direction '(:input :output))    (assert (member direction '(:input :output))
184            (direction)            (direction)
185            "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)            (intl:gettext "Invalid direction ~S, must be either :INPUT or :OUTPUT") direction)
186    (let ((handler (make-handler direction fd function)))    (let ((handler (make-handler direction fd function)))
187      (push handler *descriptor-handlers*)      (push handler *descriptor-handlers*)
188      handler))      handler))
# Line 92  Line 202 
202  ;;;   Search *descriptor-handlers* for any reference to fd, and nuke 'em.  ;;;   Search *descriptor-handlers* for any reference to fd, and nuke 'em.
203  ;;;  ;;;
204  (defun invalidate-descriptor (fd)  (defun invalidate-descriptor (fd)
205    "Remove any handers refering to fd. This should only be used when attempting    "Remove any handers refering to FD. This should only be used when attempting
206    to recover from a detected inconsistancy."    to recover from a detected inconsistency."
207    (setf *descriptor-handlers*    (setf *descriptor-handlers*
208          (delete fd *descriptor-handlers*          (delete fd *descriptor-handlers*
209                  :key #'handler-descriptor)))                  :key #'handler-descriptor)))
# Line 115  Line 225 
225           (when ,handler           (when ,handler
226             (remove-fd-handler ,handler))))))             (remove-fd-handler ,handler))))))
227    
 ;;; WAIT-UNTIL-FD-USABLE -- Public.  
 ;;;  
 ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is  
 ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will  
 ;;; timeout at the correct time irrespective of how many events are handled in  
 ;;; the meantime.  
 ;;;  
 (defun wait-until-fd-usable (fd direction &optional timeout)  
   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or  
   :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving  
   up."  
   (declare (type (or index null) timeout))  
   (let (usable)  
     (multiple-value-bind  
         (stop-sec stop-usec)  
         (if timeout  
             (multiple-value-bind (okay sec usec)  
                                  (unix:unix-gettimeofday)  
               (declare (ignore okay))  
               (values (the (unsigned-byte 32) (+ sec timeout))  
                       usec))  
             (values 0 0))  
       (declare (type (unsigned-byte 32) stop-sec stop-usec))  
       (with-fd-handler (fd direction #'(lambda (fd)  
                                          (declare (ignore fd))  
                                          (setf usable t)))  
         (loop  
           (serve-event timeout)  
   
           (when usable  
             (return t))  
   
           (when timeout  
             (multiple-value-bind (okay sec usec)  
                                  (unix:unix-gettimeofday)  
               (declare (ignore okay))  
               (when (or (> sec stop-sec)  
                         (and (= sec stop-sec) (>= usec stop-usec)))  
                 (return nil))  
               (setq timeout (- stop-sec sec)))))))))  
   
228    
229  ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.  ;;; HANDLER-DESCRIPTORS-ERROR -- Internal.
230  ;;;  ;;;
# Line 169  Line 238 
238                    (unix:unix-fstat (handler-descriptor handler)))                    (unix:unix-fstat (handler-descriptor handler)))
239          (setf (handler-bogus handler) t)          (setf (handler-bogus handler) t)
240          (push handler bogus-handlers)))          (push handler bogus-handlers)))
241      (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."      ;; TRANSLATORS:  This needs more work.
242        (restart-case (error (intl:ngettext "~S ~[have~;has a~:;have~] bad file descriptor."
243                                            "~S ~[have~;has a~:;have~] bad file descriptors."
244                                            (length bogus-handlers))
245                           bogus-handlers (length bogus-handlers))                           bogus-handlers (length bogus-handlers))
246        (remove-them () :report "Remove bogus handlers."        (remove-them ()
247            :report (lambda (stream)
248                      (write-string (intl:gettext "Remove bogus handlers.") stream))
249         (setf *descriptor-handlers*         (setf *descriptor-handlers*
250               (delete-if #'handler-bogus *descriptor-handlers*)))               (delete-if #'handler-bogus *descriptor-handlers*)))
251        (retry-them () :report "Retry bogus handlers."        (retry-them ()
252            :report (lambda (stream)
253                      (write-string (intl:gettext "Retry bogus handlers.") stream))
254         (dolist (handler bogus-handlers)         (dolist (handler bogus-handlers)
255           (setf (handler-bogus handler) nil)))           (setf (handler-bogus handler) nil)))
256        (continue () :report "Go on, leaving handlers marked as bogus."))))        (continue ()
257            :report (lambda (stream)
258                      (write-string (intl:gettext "Go on, leaving handlers marked as bogus.") stream))))))
259    
260    
261    
262  ;;;; Serve-all-events, serve-event, and friends.  ;;;; Serve-all-events, serve-event, and friends.
263    
264  (declaim (start-block serve-event serve-all-events))  (declaim (start-block wait-until-fd-usable serve-event serve-all-events))
265    
266    ;;; DECODE-TIMEOUT  --  Internal
267    ;;;
268    ;;;    Break a real timeout into seconds and microseconds.
269    ;;;
270    (defun decode-timeout (timeout)
271      (declare (values (or index null) index))
272      (typecase timeout
273        (integer (values timeout 0))
274        (null (values nil 0))
275        (real
276         (multiple-value-bind (q r)
277                              (truncate (coerce timeout 'single-float))
278           (declare (type index q) (single-float r))
279           (values q (the (values index t) (truncate (* r 1f6))))))
280        (t
281         (error (intl:gettext "Timeout is not a real number or NIL: ~S") timeout))))
282    
283    
284    ;;; WAIT-UNTIL-FD-USABLE -- Public.
285    ;;;
286    ;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
287    ;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
288    ;;; timeout at the correct time irrespective of how many events are handled in
289    ;;; the meantime.
290    ;;;
291    (defun wait-until-fd-usable (fd direction &optional timeout)
292      "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
293      :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
294      up."
295      (declare (type (or real null) timeout))
296      (let (usable)
297        (multiple-value-bind (to-sec to-usec)
298                             (decode-timeout timeout)
299          (declare (type (or index null) to-sec to-usec))
300          (multiple-value-bind
301              (stop-sec stop-usec)
302              (if to-sec
303                  (multiple-value-bind (okay start-sec start-usec)
304                                       (unix:unix-gettimeofday)
305                    (declare (ignore okay))
306                    (let ((usec (+ to-usec start-usec))
307                          (sec (+ to-sec start-sec)))
308                      (declare (type (unsigned-byte 31) usec sec))
309                      (if (>= usec 1000000)
310                          (values (1+ sec) (- usec 1000000))
311                          (values sec usec))))
312                  (values 0 0))
313            (declare (type (unsigned-byte 31) stop-sec stop-usec))
314            (with-fd-handler (fd direction #'(lambda (fd)
315                                               (declare (ignore fd))
316                                               (setf usable t)))
317              (loop
318                (sub-serve-event to-sec to-usec)
319    
320                (when usable
321                  (return t))
322    
323                (when timeout
324                  (multiple-value-bind (okay sec usec)
325                                       (unix:unix-gettimeofday)
326                    (declare (ignore okay))
327                    (when (or (> sec stop-sec)
328                              (and (= sec stop-sec) (>= usec stop-usec)))
329                      (return nil))
330                    (setq to-sec (- stop-sec sec))
331                    (cond ((> usec stop-usec)
332                           (decf to-sec)
333                           (setq to-usec (- (+ stop-usec 1000000) usec)))
334                          (t
335                           (setq to-usec (- stop-usec usec))))))))))))
336    
337    
338  (defvar *display-event-handlers* nil  (defvar *display-event-handlers* nil
339    "This is an alist mapping displays to user functions to be called when    "This is an alist mapping displays to user functions to be called when
# Line 216  Line 366 
366    function.  If timeout is specified, server will wait the specified time (in    function.  If timeout is specified, server will wait the specified time (in
367    seconds) and then return, otherwise it will wait until something happens.    seconds) and then return, otherwise it will wait until something happens.
368    Server returns T if something happened and NIL otherwise."    Server returns T if something happened and NIL otherwise."
369    ;; First, check any X displays for any pending events.    (multiple-value-bind (to-sec to-usec)
370    #+clx                         (decode-timeout timeout)
371        (sub-serve-event to-sec to-usec)))
372    
373    
374    ;;; Check for any X displays with pending events.
375    ;;;
376    (defun handle-queued-clx-event ()
377    (dolist (d/h *display-event-handlers*)    (dolist (d/h *display-event-handlers*)
378      (let* ((d (car d/h))      (let* ((d (car d/h))
379             (disp-fd (fd-stream-fd (xlib::display-input-stream d))))             (disp-fd (fd-stream-fd (xlib::display-input-stream d))))
# Line 236  Line 392 
392                                    (flush-display-events d))))                                    (flush-display-events d))))
393            (unless (funcall (cdr d/h) d)            (unless (funcall (cdr d/h) d)
394              (disable-clx-event-handling d)              (disable-clx-event-handling d)
395              (error "Event-listen was true, but handler didn't handle: ~%~S"              (error (intl:gettext "Event-listen was true, but handler didn't handle: ~%~S")
396                     d/h)))                     d/h)))
397          (return-from serve-event t))))          (return-from handle-queued-clx-event t)))))
   ;; Next, wait for something to happen.  
   (multiple-value-bind  
       (value readable writeable)  
       (wait-for-event timeout)  
     (declare (type (unsigned-byte 32) readable writeable))  
     ;; Now see what it was (if anything)  
     (cond ((fixnump value)  
            (unless (zerop value)  
              ;; Check the descriptors.  
              (let ((result nil))  
                (dolist (handler *descriptor-handlers*)  
                  (when (logbitp (handler-descriptor handler)  
                                 (ecase (handler-direction handler)  
                                   (:input readable)  
                                   (:output writeable)))  
                    (unwind-protect  
                        (progn  
                          ;; Doesn't work -- ACK  
                          ;(setf (handler-active handler) t)  
                          (funcall (handler-function handler)  
                                   (handler-descriptor handler)))  
                      (setf (handler-active handler) nil))  
                    (macrolet ((frob (var)  
                                 `(setf ,var  
                                        (logand (32bit-logical-not  
                                                 (ash 1  
                                                      (handler-descriptor  
                                                       handler)))  
                                                ,var))))  
                      (ecase (handler-direction handler)  
                        (:input (frob readable))  
                        (:output (frob writeable))))  
                    (setf result t)))  
                result)))  
           ((eql readable unix:eintr)  
            ;; We did an interrupt.  
            t)  
           (t  
            ;; One of the file descriptors is bad.  
            (handler-descriptors-error)  
            nil))))  
398    
399    
400    ;;; These macros are chunks of code from SUB-SERVE-EVENT.  They randomly
401    ;;; reference the READ-FDS and WRITE-FDS Alien variables (which would be consed
402    ;;; if passed as function arguments.)
403    ;;;
404    (eval-when (compile eval)
405    
406  ;;; CALC-MASKS -- Internal.  ;;; CALC-MASKS -- Internal.
407  ;;;  ;;;
408  ;;; Return the correct masks to use for UNIX-SELECT.  The four return values  ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
409  ;;; are: fd count, read mask, write mask, and exception mask.  The exception  ;;; count.
410  ;;; mask is currently unused.  ;;;
411  ;;;  ;;; Ideally we would mask out descriptors whose handler is already
412  (defun calc-masks ()  ;;; active, since handler functions may not be reentrant.
413    (let ((count 0)  ;;; Unfortunately, this would not be compatible with the way that
414          (read-mask 0)  ;;; Hemlock's slave lisp mechanism interacts with the WIRE facility:
415          (write-mask 0)  ;;; requests sent to the slave lisp may require a call to the master
416          (except-mask 0))  ;;; lisp over the same wire.
417      (declare (type index count)  (defmacro calc-masks ()
418               (type (unsigned-byte 32) read-mask write-mask except-mask))    '(progn
419      (dolist (handler *descriptor-handlers*)       (unix:fd-zero read-fds)
420        (unless (or (handler-active handler)       (unix:fd-zero write-fds)
421                    (handler-bogus handler))       (let ((count 0))
422          (let ((fd (handler-descriptor handler)))         (declare (type index count))
423            (ecase (handler-direction handler)         (dolist (handler *descriptor-handlers*)
424              (:input           (unless (or ; (handler-active handler)
425               (setf read-mask                       (handler-bogus handler))
426                     (logior read-mask             (let ((fd (handler-descriptor handler)))
427                             (the (unsigned-byte 32) (ash 1 fd)))))               (ecase (handler-direction handler)
428              (:output                 (:input (unix:fd-set fd read-fds))
429               (setf write-mask                 (:output (unix:fd-set fd write-fds)))
430                     (logior write-mask               (when (> fd count)
431                             (the (unsigned-byte 32) (ash 1 fd))))))                 (setf count fd)))))
432            (when (> fd count)         (1+ count))))
433              (setf count fd)))))  
434      (values (1+ count)  
435              read-mask  ;;; Call file descriptor handlers according to the readable and writable masks
436              write-mask  ;;; returned by select.
437              except-mask)))  ;;;
438    (defmacro call-fd-handler ()
439  ;;; WAIT-FOR-EVENT -- internal    '(let ((result nil))
440  ;;;       (dolist (handler *descriptor-handlers*)
441  ;;;   Wait for something to happen.         (let ((desc (handler-descriptor handler)))
442  ;;;           (when (ecase (handler-direction handler)
443  (defun wait-for-event (&optional timeout)                   (:input (unix:fd-isset desc read-fds))
444    "Wait for an something to show up on one of the file descriptors or a message                   (:output (unix:fd-isset desc write-fds)))
445    interupt to fire. Timeout is in seconds."             (unwind-protect
446    (multiple-value-bind                 (progn
447        (timeout-sec timeout-usec)                   (setf (handler-active handler) t)
448        (typecase timeout                   (funcall (handler-function handler) desc))
449          (integer (values timeout 0))               (setf (handler-active handler) nil))
450          (null (values nil 0))             (ecase (handler-direction handler)
451          (t               (:input (unix:fd-clr desc read-fds))
452           (multiple-value-bind (q r)               (:output (unix:fd-clr desc write-fds)))
453                                (truncate (coerce timeout 'single-float))             (setf result t))))
454             (declare (type index q) (single-float r))      result))
455             (values q (truncate (* r 1f6))))))  
456      (declare (type index timeout-usec)  ); eval-when (compile eval)
457               (type (or index null) timeout-sec))  
458      (multiple-value-bind (count read-mask write-mask except-mask)  ;;; When a *periodic-polling-function* is defined the server will not
459                           (calc-masks)  ;;; block for more than the maximum event timeout and will call the
460        ;; Do the select.  ;;; polling function if it does time out. One important use of this
461        (unix:unix-select count read-mask write-mask except-mask  ;;; is to periodically call process-yield.
462                          timeout-sec timeout-usec))))  ;;;
463    (declaim (type (or null function) *periodic-polling-function*))
464    (defvar *periodic-polling-function*
465      #-mp nil #+mp #'mp:process-yield)
466    (declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
467    (defvar *max-event-to-sec* 1)
468    (defvar *max-event-to-usec* 0)
469    
470    ;;; SUB-SERVE-EVENT  --  Internal
471    ;;;
472    ;;;    Takes timeout broken into seconds and microseconds.
473    ;;;
474    (defun sub-serve-event (to-sec to-usec)
475      (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
476    
477      (when (handle-queued-clx-event) (return-from sub-serve-event t))
478    
479      (let ((call-polling-fn nil))
480        (when (and *periodic-polling-function*
481                   ;; Enforce a maximum timeout.
482                   (or (null to-sec)
483                       (> to-sec *max-event-to-sec*)
484                       (and (= to-sec *max-event-to-sec*)
485                            (> to-usec *max-event-to-usec*))))
486          (setf to-sec *max-event-to-sec*)
487          (setf to-usec *max-event-to-usec*)
488          (setf call-polling-fn t))
489    
490        ;; Next, wait for something to happen.
491        (alien:with-alien ((read-fds (alien:struct unix:fd-set))
492                           (write-fds (alien:struct unix:fd-set)))
493          (let ((count (calc-masks)))
494            (multiple-value-bind
495                  (value err)
496                (unix:unix-fast-select
497                 count
498                 (alien:addr read-fds) (alien:addr write-fds)
499                 nil to-sec to-usec)
500    
501              ;; Now see what it was (if anything)
502              (cond (value
503                     (cond ((zerop value)
504                            ;; Timed out.
505                            (when call-polling-fn
506                              (funcall *periodic-polling-function*)))
507                           (t
508                            (call-fd-handler))))
509                    ((eql err unix:eintr)
510                     ;; We did an interrupt.
511                     t)
512                    (t
513                     ;; One of the file descriptors is bad.
514                     (handler-descriptors-error)
515                     nil)))))))
516    

Legend:
Removed from v.1.13.1.1  
changed lines
  Added in v.1.31

  ViewVC Help
Powered by ViewVC 1.1.5