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

Diff of /mcclim/input.lisp

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

revision 1.18 by adejneka, Fri Aug 2 11:59:09 2002 UTC revision 1.19 by brian, Thu Oct 31 12:58:14 2002 UTC
# Line 32  Line 32 
32           :documentation "Head pointer of event queue.")           :documentation "Head pointer of event queue.")
33     (tail :initform nil     (tail :initform nil
34           :accessor event-queue-tail           :accessor event-queue-tail
35           :documentation "Tail pointer of event queue.") ))           :documentation "Tail pointer of event queue.")
36       ; experimental extension for scheduled event insersion
37       (schedule-time
38             :initform nil
39             :accessor event-schedule-time
40             :documentation "The next time an event should be scheduled.")
41       (schedule
42             :initform nil
43             :accessor event-queue-schedule
44             :documentation "Time ordered queue of events to schedule.")))
45    
46  (defmethod event-queue-read-no-hang ((eq standard-event-queue))  (defmethod event-queue-read-no-hang ((eq standard-event-queue))
47    "Reads one event from the queue, if there is no event just return NIL."    "Reads one event from the queue, if there is no event just return NIL."
48    (with-lock-held ((event-queue-lock eq))    (with-lock-held ((event-queue-lock eq))
49        (check-schedule eq)
50      (let ((res (pop (event-queue-head eq))))      (let ((res (pop (event-queue-head eq))))
51        (when (null (event-queue-head eq))        (when (null (event-queue-head eq))
52          (setf (event-queue-tail eq) nil))          (setf (event-queue-tail eq) nil))
# Line 45  Line 55 
55  (defmethod event-queue-read ((eq standard-event-queue))  (defmethod event-queue-read ((eq standard-event-queue))
56    "Reads one event from the queue, if there is no event, hang until here is one."    "Reads one event from the queue, if there is no event, hang until here is one."
57    (loop    (loop
58          (check-schedule eq)
59        (let ((res (event-queue-read-no-hang eq)))        (let ((res (event-queue-read-no-hang eq)))
60          (when res          (when res
61            (return res))            (return res))
62          (if *multiprocessing-p*          ; is there an event waiting to be scheduled?
63              (process-wait  "Waiting for event"          (with-slots (schedule-time) eq
64                             (lambda ()            (let* ((now    (now))
65                               (not (null (event-queue-head eq)))))                   (timeout (when schedule-time (- schedule-time now))))
66              (process-wait  "Waiting for event"              (if timeout
67                             (lambda ()                  (if *multiprocessing-p*
68                               (loop for port in climi::*all-ports*                      (process-wait-with-timeout "Waiting for event"
69                                  ; this is dubious                                     timeout
70                                  do (process-next-event port))                                     (lambda ()
71                               (not (null (event-queue-head eq)))))))))                                       (not (null (event-queue-head eq)))))
72                        (process-wait-with-timeout "Waiting for event"
73                                       timeout
74                                       (lambda ()
75                                         (loop for port in climi::*all-ports*
76                                            ; this is dubious
77                                            do (process-next-event port))
78                                         (not (null (event-queue-head eq))))))
79                    ; no timeout
80                    (if *multiprocessing-p*
81                        (process-wait  "Waiting for event"
82                                       (lambda ()
83                                         (not (null (event-queue-head eq)))))
84                        (process-wait  "Waiting for event"
85                                       (lambda ()
86                                         (loop for port in climi::*all-ports*
87                                            ; this is dubious
88                                            do (process-next-event port))
89                                         (not (null (event-queue-head eq))))))))))))
90    
91  (defmethod event-queue-read-with-timeout ((eq standard-event-queue)  (defmethod event-queue-read-with-timeout ((eq standard-event-queue)
92                                            timeout wait-function)                                            timeout wait-function)
93    (loop    (loop
94          (check-schedule eq)
95        (let ((res (event-queue-read-no-hang eq)))        (let ((res (event-queue-read-no-hang eq)))
96          (when res          (when res
97            (return res))            (return res))
# Line 175  Line 205 
205    
206  (defmethod event-queue-peek ((eq standard-event-queue))  (defmethod event-queue-peek ((eq standard-event-queue))
207    (with-lock-held ((event-queue-lock eq))    (with-lock-held ((event-queue-lock eq))
208        (check-schedule eq)
209      (first (event-queue-head eq))))      (first (event-queue-head eq))))
210    
211  (defmethod event-queue-peek-if (predicate (eq standard-event-queue))  (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
# Line 185  Line 216 
216      (find-if predicate (event-queue-head eq))))      (find-if predicate (event-queue-head eq))))
217    
218  (defmethod event-queue-listen ((eq standard-event-queue))  (defmethod event-queue-listen ((eq standard-event-queue))
219      (check-schedule eq)
220    (not (null (event-queue-head eq))))    (not (null (event-queue-head eq))))
221    
222  (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)  (defun now ()
223    (or (not (null (event-queue-peek eq)))    (/ (get-internal-real-time)
224        (flet ((pred ()       internal-time-units-per-second))
                (not (null (event-queue-head eq)))))  
         (if timeout  
             (process-wait-with-timeout "Listening for event" timeout #'pred)  
             (progn  
               (process-wait "Listening for event" #'pred)  
               t)))))  
225    
226    (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
227      (check-schedule eq)
228      (with-slots (schedule-time) eq
229        (flet ((pred ()
230                 (not (null (event-queue-head eq)))))
231          (cond
232            (timeout
233             (loop as    timeout-time = (+ now timeout)
234                   with  now = (now)
235                   do    (when (pred)
236                           (return t))
237                   do    (when (>= now timeout-time)
238                           (return nil))
239                   do    (let ((timeout (if schedule-time
240                                            (min (- schedule-time now)
241                                                 (- timeout-time now))
242                                            (- timeout-time now))))
243                           (process-wait-with-timeout "Listening for event" timeout #'pred))
244                   do    (check-schedule eq)))
245            (schedule-time
246             (loop do (when (pred)
247                        (return t))
248                   do (process-wait-with-timeout "Listening for event"
249                              (- schedule-time (now)) #'pred)
250                   do (check-schedule eq)))
251            (t
252              (or (pred)
253                  (progn
254                    (process-wait "Listening for event" #'pred)
255                    t)))))))
256    
257    (defmethod check-schedule ((eq standard-event-queue))
258      ; see if it's time to inject a scheduled event into the queue.
259      (with-slots (schedule-time schedule) eq
260        (when (and schedule-time
261                   (> (now) schedule-time))
262          (let* ((event (pop schedule))
263                 (sheet (pop schedule)))
264            (setf schedule-time (pop schedule))
265            (dispatch-event sheet event))
266          t)))
267    
268    ; ugh. FIXME when I work - build a priority queue or something
269    (defmethod event-queue-schedule ((eq standard-event-queue) sheet event delay)
270      (with-slots (schedule-time schedule) eq
271        (let ((when (+ (now) delay)))
272          (if schedule
273              (cond
274                ((< when schedule-time)
275                 (push schedule-time schedule)
276                 (push sheet schedule)
277                 (push event schedule)
278                 (setf schedule-time when))
279                (t
280    ; (format *debug-io* "queue = ~A~%" schedule)
281                 (do* ((prev  (cdr schedule)  (cdddr prev))
282                       (point (cddr schedule) (cdddr point))
283                       (time  (car point)))
284                      ((or (null point)
285                           (< when time))
286                       (setf (cdr prev)
287                             (cons when (cons event (cons sheet (cdr prev)))))))))
288              (progn
289                (setf schedule-time when)
290                (push sheet schedule)
291                (push event schedule))))))
292    
293  ;; STANDARD-SHEET-INPUT-MIXIN  ;; STANDARD-SHEET-INPUT-MIXIN
294    
# Line 226  Line 318 
318  (defmethod queue-event ((sheet standard-sheet-input-mixin) event)  (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
319    (with-slots (queue) sheet    (with-slots (queue) sheet
320      (event-queue-append queue event)))      (event-queue-append queue event)))
321    
322    (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
323      (with-slots (queue) sheet
324        (event-queue-schedule queue sheet event delay)))
325    
326  (defmethod handle-event ((sheet standard-sheet-input-mixin) event)  (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
327    ;; Standard practice is to ignore events    ;; Standard practice is to ignore events
# Line 302  Line 398 
398    (declare (ignore event))    (declare (ignore event))
399    (error 'sheet-is-mute-for-input))    (error 'sheet-is-mute-for-input))
400    
401    (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
402      (declare (ignore event delay))
403      (error 'sheet-is-mute-for-input))
404    
405  (defmethod handle-event ((sheet sheet-mute-input-mixin) event)  (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
406    (declare (ignore event))    (declare (ignore event))
407    (error 'sheet-is-mute-for-input))    (error 'sheet-is-mute-for-input))
# Line 355  Line 455 
455  (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)  (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
456    (queue-event (delegate-sheet-delegate sheet) event))    (queue-event (delegate-sheet-delegate sheet) event))
457    
458    (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
459      (schedule-event (delegate-sheet-delegate sheet) event delay))
460    
461  (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)  (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
462    (handle-event (delegate-sheet-delegate sheet) event))    (handle-event (delegate-sheet-delegate sheet) event))
463    

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

  ViewVC Help
Powered by ViewVC 1.1.5