/[mcclim]/mcclim/ports.lisp
ViewVC logotype

Diff of /mcclim/ports.lisp

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

revision 1.25 by mikemac, Thu Feb 28 21:00:10 2002 UTC revision 1.26 by moore, Tue Mar 12 21:05:06 2002 UTC
# Line 140  Line 140 
140      (incf event-count)))      (incf event-count)))
141    
142  (defmethod process-next-event ((port basic-port) &key wait-function timeout)  (defmethod process-next-event ((port basic-port) &key wait-function timeout)
143    (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))    (let ((event (get-next-event port
144                                   :wait-function wait-function
145                                   :timeout timeout)))
146      (cond      (cond
147       ((null event) nil)       ((null event) nil)
148       ((eq event :timeout) (values nil :timeout))       ((eq event :timeout) (values nil :timeout))
149    
150       (t       (t
151        (distribute-event port event)        (let* ((focus-sheet (port-keyboard-input-focus port))
152                 (sheet-frame (and focus-sheet (pane-frame focus-sheet))))
153            (if (and (typep event 'device-event)
154                     sheet-frame
155                     (frame-intercept-events sheet-frame))
156                (event-queue-append (frame-intercept-event-queue sheet-frame)
157                                    event)
158                (distribute-event port event)))
159        t))))        t))))
160    
161  (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout)  (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout
162                                              ((:event-count old-count) nil))
163    (declare (ignorable wait-function))    (declare (ignorable wait-function))
164    (if *multiprocessing-p*    (if *multiprocessing-p*
165        (with-slots (event-count) port        (with-slots (event-count) port
166          (let ((old-event-count event-count)          (let ((old-event-count (or old-count event-count))
167                (flag nil))                (flag nil))
168            (process-wait-with-timeout "Wait for event" timeout            (process-wait-with-timeout "Wait for event" timeout
169                                       #'(lambda ()                                       #'(lambda ()
170                                           (when (not (= old-event-count event-count))                                           (when (not (= old-event-count event-count))
171                                             (setq flag t))))                                             (setq flag t))))
172            (if flag            (if flag
173                t                event-count
174              (values nil :timeout))))              (values nil :timeout))))
175      (process-next-event port :wait-function wait-function :timeout timeout)))      (process-next-event port :wait-function wait-function :timeout timeout)))
176    

Legend:
Removed from v.1.25  
changed lines
  Added in v.1.26

  ViewVC Help
Powered by ViewVC 1.1.5