/[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.19 by ram, Mon Dec 14 14:39:44 1992 UTC revision 1.19.1.1 by ram, Tue Feb 23 16:29:46 1993 UTC
# Line 150  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 168  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 249  Line 252 
252    
253  ;;;; Serve-all-events, serve-event, and friends.  ;;;; Serve-all-events, serve-event, and friends.
254    
255  (declaim (start-block wait-until-fd-usable start-block serve-event  (declaim (start-block wait-until-fd-usable serve-event serve-all-events))
                       serve-all-events))  
256    
257  ;;; DECODE-TIMEOUT  --  Internal  ;;; DECODE-TIMEOUT  --  Internal
258  ;;;  ;;;
# Line 362  Line 364 
364    
365  ;;; Check for any X displays with pending events.  ;;; Check for any X displays with pending events.
366  ;;;  ;;;
367    #+clx
368  (defun handle-queued-clx-event ()  (defun handle-queued-clx-event ()
369    (dolist (d/h *display-event-handlers*)    (dolist (d/h *display-event-handlers*)
370      (let* ((d (car d/h))      (let* ((d (car d/h))
# Line 386  Line 389 
389          (return-from handle-queued-clx-event t)))))          (return-from handle-queued-clx-event t)))))
390    
391    
392    ;;; These macros are chunks of code from SUB-SERVE-EVENT.  They randomly
393    ;;; reference the READ-FDS and WRITE-FDS Alien variables (which wold be consed
394    ;;; if passed as function arguments.)
395    ;;;
396    (eval-when (compile eval)
397    
398    ;;; CALC-MASKS -- Internal.
399    ;;;
400    ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
401    ;;; count.
402    ;;;
403    (defmacro calc-masks ()
404      '(progn
405         (unix:fd-zero read-fds)
406         (unix:fd-zero write-fds)
407         (let ((count 0))
408           (declare (type index count))
409           (dolist (handler *descriptor-handlers*)
410             (unless (or (handler-active handler)
411                         (handler-bogus handler))
412               (let ((fd (handler-descriptor handler)))
413                 (ecase (handler-direction handler)
414                   (:input (unix:fd-set fd read-fds))
415                   (:output (unix:fd-set fd write-fds)))
416                 (when (> fd count)
417                   (setf count fd)))))
418           (1+ count))))
419    
420    
421  ;;; Call file descriptor handlers according to the readable and writable masks  ;;; Call file descriptor handlers according to the readable and writable masks
422  ;;; returned by select.  ;;; returned by select.
423  ;;;  ;;;
424  (defun call-fd-handler (readable writeable)  (defmacro call-fd-handler ()
425    (let ((result nil))    '(let ((result nil))
426      (dolist (handler *descriptor-handlers*)       (dolist (handler *descriptor-handlers*)
427        (when (logbitp (handler-descriptor handler)         (let ((desc (handler-descriptor handler)))
428                       (ecase (handler-direction handler)           (when (ecase (handler-direction handler)
429                         (:input readable)                   (:input (unix:fd-isset desc read-fds))
430                         (:output writeable)))                   (:output (unix:fd-isset desc write-fds)))
431          (unwind-protect             (unwind-protect
432              (progn                 (progn
433                ;; Doesn't work -- ACK                   ;; Doesn't work -- ACK
434                ;(setf (handler-active handler) t)                   ;(setf (handler-active handler) t)
435                (funcall (handler-function handler)                   (funcall (handler-function handler) desc))
436                         (handler-descriptor handler)))               (setf (handler-active handler) nil))
437            (setf (handler-active handler) nil))             (ecase (handler-direction handler)
438          (macrolet ((frob (var)               (:input (unix:fd-clr desc read-fds))
439                       `(setf ,var               (:output (unix:fd-clr desc write-fds)))
440                              (logand (32bit-logical-not             (setf result t)))
441                                       (ash 1         result)))
442                                            (handler-descriptor  
443                                             handler)))  ); eval-when (compile eval)
                                     ,var))))  
           (ecase (handler-direction handler)  
             (:input (frob readable))  
             (:output (frob writeable))))  
         (setf result t)))  
     result))  
444    
445    
446  ;;; SUB-SERVE-EVENT  --  Internal  ;;; SUB-SERVE-EVENT  --  Internal
# Line 422  Line 448 
448  ;;;    Takes timeout broken into seconds and microseconds.  ;;;    Takes timeout broken into seconds and microseconds.
449  ;;;  ;;;
450  (defun sub-serve-event (to-sec to-usec)  (defun sub-serve-event (to-sec to-usec)
451    (when (handle-queued-clx-event)    #+clx
452      (return-from sub-serve-event t))    (when (handle-queued-clx-event) (return-from sub-serve-event t))
453    
454    ;; Next, wait for something to happen.    ;; Next, wait for something to happen.
455    (multiple-value-bind    (alien:with-alien ((read-fds (alien:struct unix:fd-set))
456        (value readable writeable)                       (write-fds (alien:struct unix:fd-set)))
457        (multiple-value-bind (count read-mask write-mask except-mask)      (let ((count (calc-masks)))
458                             (calc-masks)        (multiple-value-bind
459          ;; Do the select.            (value err)
460          (unix:unix-select count read-mask write-mask except-mask            (unix:unix-fast-select
461                            to-sec to-usec))             count
462      (declare (type (unsigned-byte 32) readable)             (alien:addr read-fds) (alien:addr write-fds)
463               (type (or (unsigned-byte 32) null) writeable))             nil to-sec to-usec)
464      ;; Now see what it was (if anything)  
465      (cond ((fixnump value)          ;; Now see what it was (if anything)
466             (unless (zerop value)          (cond (value
467               (call-fd-handler readable writeable)))                 (unless (zerop value) (call-fd-handler)))
468            ((eql readable unix:eintr)                ((eql err unix:eintr)
469             ;; We did an interrupt.                 ;; We did an interrupt.
470             t)                 t)
471            (t                (t
472             ;; One of the file descriptors is bad.                 ;; One of the file descriptors is bad.
473             (handler-descriptors-error)                 (handler-descriptors-error)
474             nil))))                 nil))))))
   
475    
 ;;; 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)))  

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.19.1.1

  ViewVC Help
Powered by ViewVC 1.1.5