/[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.22.2.2 by dtc, Thu Jul 6 06:18:49 2000 UTC revision 1.31 by rtoy, Tue Apr 20 17:57:45 2010 UTC
# Line 17  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*            make-object-set object-set-operation *xwindow-table*
# Line 55  Line 57 
57    default-handler)    default-handler)
58    
59  (setf (documentation 'make-object-set 'function)  (setf (documentation 'make-object-set 'function)
60        "Make an object set for use by a RPC/xevent server.  Name is for        (intl:gettext "Make an object set for use by a RPC/xevent server.  Name is for
61        descriptive purposes only.")        descriptive purposes only."))
62    
63  ;;; Default-Default-Handler  --  Internal  ;;; Default-Default-Handler  --  Internal
64  ;;;  ;;;
65  ;;;    If no such operation defined, signal an error.  ;;;    If no such operation defined, signal an error.
66  ;;;  ;;;
67  (defun default-default-handler (object)  (defun default-default-handler (object)
68    (error "You lose, object: ~S" object))    (error (intl:gettext "You lose, object: ~S") object))
69    
70    
71  ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and  ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
# Line 161  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 180  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 200  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 236  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    
# Line 267  Line 278 
278         (declare (type index q) (single-float r))         (declare (type index q) (single-float r))
279         (values q (the (values index t) (truncate (* r 1f6))))))         (values q (the (values index t) (truncate (* r 1f6))))))
280      (t      (t
281       (error "Timeout is not a real number or NIL: ~S" timeout))))       (error (intl:gettext "Timeout is not a real number or NIL: ~S") timeout))))
282    
283    
284  ;;; WAIT-UNTIL-FD-USABLE -- Public.  ;;; WAIT-UNTIL-FD-USABLE -- Public.
# Line 381  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 handle-queued-clx-event t)))))          (return-from handle-queued-clx-event t)))))
398    
399    
400  ;;; These macros are chunks of code from SUB-SERVE-EVENT.  They randomly  ;;; These macros are chunks of code from SUB-SERVE-EVENT.  They randomly
401  ;;; reference the READ-FDS and WRITE-FDS Alien variables (which wold be consed  ;;; reference the READ-FDS and WRITE-FDS Alien variables (which would be consed
402  ;;; if passed as function arguments.)  ;;; if passed as function arguments.)
403  ;;;  ;;;
404  (eval-when (compile eval)  (eval-when (compile eval)
# Line 397  Line 408 
408  ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor  ;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
409  ;;; count.  ;;; count.
410  ;;;  ;;;
411    ;;; Ideally we would mask out descriptors whose handler is already
412    ;;; active, since handler functions may not be reentrant.
413    ;;; Unfortunately, this would not be compatible with the way that
414    ;;; Hemlock's slave lisp mechanism interacts with the WIRE facility:
415    ;;; requests sent to the slave lisp may require a call to the master
416    ;;; lisp over the same wire.
417  (defmacro calc-masks ()  (defmacro calc-masks ()
418    '(progn    '(progn
419       (unix:fd-zero read-fds)       (unix:fd-zero read-fds)
# Line 404  Line 421 
421       (let ((count 0))       (let ((count 0))
422         (declare (type index count))         (declare (type index count))
423         (dolist (handler *descriptor-handlers*)         (dolist (handler *descriptor-handlers*)
424           (unless (or (handler-active handler)           (unless (or ; (handler-active handler)
425                       (handler-bogus handler))                       (handler-bogus handler))
426             (let ((fd (handler-descriptor handler)))             (let ((fd (handler-descriptor handler)))
427               (ecase (handler-direction handler)               (ecase (handler-direction handler)
# Line 427  Line 444 
444                   (:output (unix:fd-isset desc write-fds)))                   (:output (unix:fd-isset desc write-fds)))
445             (unwind-protect             (unwind-protect
446                 (progn                 (progn
447                   ;; Doesn't work -- ACK                   (setf (handler-active handler) t)
                  ;(setf (handler-active handler) t)  
448                   (funcall (handler-function handler) desc))                   (funcall (handler-function handler) desc))
449               (setf (handler-active handler) nil))               (setf (handler-active handler) nil))
450             (ecase (handler-direction handler)             (ecase (handler-direction handler)
451               (:input (unix:fd-clr desc read-fds))               (:input (unix:fd-clr desc read-fds))
452               (:output (unix:fd-clr desc write-fds)))               (:output (unix:fd-clr desc write-fds)))
453             (setf result t)))             (setf result t))))
454         result)))      result))
455    
456  ); eval-when (compile eval)  ); eval-when (compile eval)
457    
458  ;;; When a *periodic-polling-function* is defined the server will not  ;;; When a *periodic-polling-function* is defined the server will not
459  ;;; block for more than the maximum event timeout and will call the  ;;; block for more than the maximum event timeout and will call the
460  ;;; polling function if it does times out. One important use of this  ;;; polling function if it does time out. One important use of this
461  ;;; is to periodically call process-yield.  ;;; is to periodically call process-yield.
462  ;;;  ;;;
463  (declaim (type (or null function) *periodic-polling-function*))  (declaim (type (or null function) *periodic-polling-function*))

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

  ViewVC Help
Powered by ViewVC 1.1.5