/[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.14 by wlott, Fri Feb 14 23:45:32 1992 UTC revision 1.14.1.1 by wlott, Mon Feb 24 02:38:03 1992 UTC
# Line 43  Line 43 
43  (defstruct (handler  (defstruct (handler
44              (:print-function %print-handler)              (:print-function %print-handler)
45              (:constructor make-handler (direction descriptor function)))              (:constructor make-handler (direction descriptor function)))
46    (direction nil :type (member :input :output)) ; Either :input or :output    ;;
47    (descriptor 0 :type (mod 32)) ; File descriptor this handler is tied to.    ;; :Input if we are going to read from it, :Output if we are going to
48    active                      ; T iff this handler is running.    ;; write to it.
49    (function nil :type function) ; Function to call.    (direction nil :type (member :input :output))
50    bogus                       ; T if this descriptor is bogus.    ;;
51    )    ;; The file descriptor.
52      (descriptor 0 :type (mod #.unix:fd-setsize))
53      ;;
54      ;; Unused.
55      active
56      ;;
57      ;; The function to invoke when there is activity on this descriptor.
58      (function nil :type function)
59      ;;
60      ;; Gets set to NIL when we get an error on the descriptor.  Used to prevent
61      ;; requisive errors.
62      (bogus nil :type (member t nil)))
63    
64  (defun %print-handler (handler stream depth)  (defun %print-handler (handler stream depth)
65    (declare (ignore depth))    (declare (ignore depth))
# Line 183  Line 194 
194    
195  ;;;; Serve-all-events, serve-event, and friends.  ;;;; Serve-all-events, serve-event, and friends.
196    
 (declaim (start-block serve-event serve-all-events))  
   
197  (defvar *display-event-handlers* nil  (defvar *display-event-handlers* nil
198    "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
199     SYSTEM:SERVE-EVENT notices input on a display connection.  Do not modify     SYSTEM:SERVE-EVENT notices input on a display connection.  Do not modify
# Line 239  Line 248 
248              (error "Event-listen was true, but handler didn't handle: ~%~S"              (error "Event-listen was true, but handler didn't handle: ~%~S"
249                     d/h)))                     d/h)))
250          (return-from serve-event t))))          (return-from serve-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))))  
   
   
 ;;; CALC-MASKS -- Internal.  
 ;;;  
 ;;; Return the correct masks to use for UNIX-SELECT.  The four return values  
 ;;; are: fd count, read mask, write mask, and exception mask.  The exception  
 ;;; mask is currently unused.  
 ;;;  
 (defun calc-masks ()  
   (let ((count 0)  
         (read-mask 0)  
         (write-mask 0)  
         (except-mask 0))  
     (declare (type index count)  
              (type (unsigned-byte 32) read-mask write-mask except-mask))  
     (dolist (handler *descriptor-handlers*)  
       (unless (or (handler-active handler)  
                   (handler-bogus handler))  
         (let ((fd (handler-descriptor handler)))  
           (ecase (handler-direction handler)  
             (:input  
              (setf read-mask  
                    (logior read-mask  
                            (the (unsigned-byte 32) (ash 1 fd)))))  
             (:output  
              (setf write-mask  
                    (logior write-mask  
                            (the (unsigned-byte 32) (ash 1 fd))))))  
           (when (> fd count)  
             (setf count fd)))))  
     (values (1+ count)  
             read-mask  
             write-mask  
             except-mask)))  
   
 ;;; WAIT-FOR-EVENT -- internal  
 ;;;  
 ;;;   Wait for something to happen.  
 ;;;  
 (defun wait-for-event (&optional timeout)  
   "Wait for an something to show up on one of the file descriptors or a message  
   interupt to fire. Timeout is in seconds."  
251    (multiple-value-bind    (multiple-value-bind
252        (timeout-sec timeout-usec)        (timeout-sec timeout-usec)
253        (typecase timeout        (typecase timeout
254          (integer (values timeout 0))          (integer (values timeout 0))
255          (null (values nil 0))          (null (values nil 0))
256          (t          (t
257           (multiple-value-bind (q r)           (multiple-value-bind
258                                (truncate (coerce timeout 'single-float))               (q r)
259                 (truncate (coerce timeout 'single-float))
260             (declare (type index q) (single-float r))             (declare (type index q) (single-float r))
261             (values q (truncate (* r 1f6))))))             (values q (truncate (* r 1f6))))))
262      (declare (type index timeout-usec)      (declare (type (integer 0 (1000000)) timeout-usec)
263               (type (or index null) timeout-sec))               (type (or index null) timeout-sec))
264      (multiple-value-bind (count read-mask write-mask except-mask)      (let ((max-fd -1))
265                           (calc-masks)        (declare (type (integer -1 #.unix:fd-setsize) max-fd))
266        ;; Do the select.        (alien:with-alien ((read-fds (alien:struct unix:fd-set))
267        (unix:unix-select count read-mask write-mask except-mask                           (write-fds (alien:struct unix:fd-set)))
268                          timeout-sec timeout-usec))))          ;; Compute the masks.
269            (unix:fd-zero read-fds)
270            (unix:fd-zero write-fds)
271            (dolist (handler *descriptor-handlers*)
272              (unless (or (handler-active handler)
273                          (handler-bogus handler))
274                (let ((fd (handler-descriptor handler)))
275                  (ecase (handler-direction handler)
276                    (:input
277                     (unix:fd-set fd read-fds))
278                    (:output
279                     (unix:fd-set fd write-fds)))
280                  (when (> fd max-fd)
281                    (setf max-fd fd)))))
282            ;; Next, wait for something to happen.
283            (multiple-value-bind
284                (count errno)
285                (unix:unix-fast-select (1+ max-fd)
286                                       (alien:addr read-fds)
287                                       (alien:addr write-fds)
288                                       nil timeout-sec timeout-usec)
289              (cond (count
290                     (unless (zerop count)
291                       ;; Check the descriptors.
292                       (let ((result nil))
293                         (dolist (handler *descriptor-handlers*)
294                           (unless (handler-bogus handler)
295                             (when (ecase (handler-direction handler)
296                                     (:input
297                                      (unix:fd-isset (handler-descriptor handler)
298                                                     read-fds))
299                                     (:output
300                                      (unix:fd-isset (handler-descriptor handler)
301                                                     write-fds)))
302                               (funcall (handler-function handler)
303                                        (handler-descriptor handler))
304                               (setf result t))))
305                       result)))
306                    ((eql errno unix:eintr)
307                     ;; We did an interrupt.
308                     t)
309                    (t
310                     ;; One of the file descriptors is bad.
311                     (handler-descriptors-error)
312                     nil)))))))

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.14.1.1

  ViewVC Help
Powered by ViewVC 1.1.5