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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Sun Nov 10 15:56:11 2002 UTC (11 years, 5 months ago) by gilbert
Branch: MAIN
Changes since 1.19: +4 -1 lines
Mike McDonald wrote in message <200211050453.gA54r1J32523@saturn.mikemac.com>:
    In ACL:

    ;;; Compiling file ./input.lisp
    5007120 bytes have been tenured, next gc will be global.
    See the documentation for variable EXCL:*GLOBAL-GC-BEHAVIOR* for more information.
    ;;; Writing fasl file /home/mikemac/src/Lisp/McCLIM/input.fasl
    ;;; Fasl write complete
    ;     Loading product for module: "input".
    ; Fast loading /home/mikemac/src/Lisp/McCLIM/input.fasl
    Error: Attempt to add the method
           #<STANDARD-METHOD EVENT-QUEUE-SCHEDULE
             (STANDARD-EVENT-QUEUE T T T) @ #x20931b5a>
           to the generic function
           #<STANDARD-GENERIC-FUNCTION EVENT-QUEUE-SCHEDULE> but the method
           has more required arguments than the generic function.
      [condition type: PROGRAM-ERROR]

STANDARD-EVENT-QUEUE had a slot accessor defined by the name
EVENT-QUEUE-SCHEDULE which is now removed and so this error should now
be fixed.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 gilbert 1.5 ;;; (c) copyright 2002 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
5 mikemac 1.1
6     ;;; This library is free software; you can redistribute it and/or
7     ;;; modify it under the terms of the GNU Library General Public
8     ;;; License as published by the Free Software Foundation; either
9     ;;; version 2 of the License, or (at your option) any later version.
10     ;;;
11     ;;; This library is distributed in the hope that it will be useful,
12     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14     ;;; Library General Public License for more details.
15     ;;;
16     ;;; You should have received a copy of the GNU Library General Public
17     ;;; License along with this library; if not, write to the
18     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19     ;;; Boston, MA 02111-1307 USA.
20    
21     (in-package :CLIM-INTERNALS)
22    
23     ;;; Input Protocol Classes
24    
25 gilbert 1.5 ;; Event queues
26    
27     (defclass standard-event-queue ()
28     ((lock :initform (make-lock "event queue")
29     :reader event-queue-lock)
30     (head :initform nil
31     :accessor event-queue-head
32     :documentation "Head pointer of event queue.")
33     (tail :initform nil
34     :accessor event-queue-tail
35 brian 1.19 :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 gilbert 1.20 ;; :accessor event-queue-schedule
44     ;; this accessor conflicts with the method below.
45     ;; noted by mikemac. I recommend renaming the slot.
46     ;; --GB 2002-11-10
47 brian 1.19 :documentation "Time ordered queue of events to schedule.")))
48 gilbert 1.5
49     (defmethod event-queue-read-no-hang ((eq standard-event-queue))
50     "Reads one event from the queue, if there is no event just return NIL."
51     (with-lock-held ((event-queue-lock eq))
52 brian 1.19 (check-schedule eq)
53 gilbert 1.5 (let ((res (pop (event-queue-head eq))))
54     (when (null (event-queue-head eq))
55     (setf (event-queue-tail eq) nil))
56     res)))
57    
58     (defmethod event-queue-read ((eq standard-event-queue))
59     "Reads one event from the queue, if there is no event, hang until here is one."
60     (loop
61 brian 1.19 (check-schedule eq)
62 gilbert 1.5 (let ((res (event-queue-read-no-hang eq)))
63     (when res
64     (return res))
65 brian 1.19 ; is there an event waiting to be scheduled?
66     (with-slots (schedule-time) eq
67     (let* ((now (now))
68     (timeout (when schedule-time (- schedule-time now))))
69     (if timeout
70     (if *multiprocessing-p*
71     (process-wait-with-timeout "Waiting for event"
72     timeout
73     (lambda ()
74     (not (null (event-queue-head eq)))))
75     (process-wait-with-timeout "Waiting for event"
76     timeout
77     (lambda ()
78     (loop for port in climi::*all-ports*
79     ; this is dubious
80     do (process-next-event port))
81     (not (null (event-queue-head eq))))))
82     ; no timeout
83     (if *multiprocessing-p*
84     (process-wait "Waiting for event"
85     (lambda ()
86     (not (null (event-queue-head eq)))))
87     (process-wait "Waiting for event"
88     (lambda ()
89     (loop for port in climi::*all-ports*
90     ; this is dubious
91     do (process-next-event port))
92     (not (null (event-queue-head eq))))))))))))
93 gilbert 1.5
94 gilbert 1.13 (defmethod event-queue-read-with-timeout ((eq standard-event-queue)
95     timeout wait-function)
96     (loop
97 brian 1.19 (check-schedule eq)
98 gilbert 1.13 (let ((res (event-queue-read-no-hang eq)))
99     (when res
100     (return res))
101     (if *multiprocessing-p*
102     (process-wait-with-timeout "Waiting for event"
103     timeout
104     (lambda ()
105     (or
106     (not (null (event-queue-head eq)))
107     (funcall wait-function))))
108     (process-wait-with-timeout "Waiting for event"
109     timeout
110     (lambda ()
111     (loop for port in climi::*all-ports*
112     ;; this is dubious
113     do (process-next-event port))
114     (or
115     (not (null (event-queue-head eq)))
116     (funcall wait-function))))))))
117    
118 gilbert 1.5 (defmethod event-queue-append ((eq standard-event-queue) item)
119 gilbert 1.15 "Append the item at the end of the queue. Does event compression."
120 gilbert 1.5 (with-lock-held ((event-queue-lock eq))
121 gilbert 1.15 (cond
122     ;; Motion Event Compression
123     ;;
124     ;; . find the (at most one) motion event
125     ;; . delete it
126     ;; . append item to queue
127     ;;
128     ;; But leave enter/exit events.
129     ;;
130     ((and (typep item 'pointer-motion-event)
131     (not (typep item 'pointer-boundary-event)))
132     (let ((sheet (event-sheet item)))
133     (labels ((fun (xs)
134     (cond ((null xs)
135     (setf (event-queue-tail eq) (cons item nil)) )
136     ((and (typep (car xs) 'pointer-motion-event)
137     (not (typep (car xs) 'pointer-boundary-event))
138     (eq (event-sheet (car xs)) sheet))
139     ;; delete this
140     (fun (cdr xs)))
141     (t
142     (setf (cdr xs) (fun (cdr xs)))
143     xs))))
144     (setf (event-queue-head eq) (fun (event-queue-head eq))))))
145     ;;
146     ;; Repaint event compression
147     ;;
148     ((typep item 'window-repaint-event)
149     (let ((region (window-event-native-region item))
150     (sheet (event-sheet item))
151     (did-something-p nil))
152     (labels ((fun (xs)
153     (cond ((null xs)
154     ;; We reached the queue's tail: Append the new event, construct a new
155     ;; one if necessary.
156     (when did-something-p
157     (setf item
158     (make-instance 'window-repaint-event
159     :timestamp (event-timestamp item)
160     :sheet (event-sheet item)
161     :region region)))
162     (setf (event-queue-tail eq) (cons item nil)) )
163     ;;
164     ((and (typep (car xs) 'window-repaint-event)
165     (eq (event-sheet (car xs)) sheet))
166     ;; This is a repaint event for the same sheet, delete it and combine
167     ;; its region into the new event.
168     (setf region
169     (region-union region (window-event-native-region (car xs))))
170     ;; Here is an alternative, which just takes the bounding rectangle.
171     ;; NOTE: When doing this also take care that the new region really
172     ;; is cleared.
173     ;; (setf region
174     ;; (let ((old-region (window-event-native-region (car xs))))
175     ;; (make-rectangle*
176     ;; (min (bounding-rectangle-min-x region)
177     ;; (bounding-rectangle-min-x old-region))
178     ;; (min (bounding-rectangle-min-y region)
179     ;; (bounding-rectangle-min-y old-region))
180     ;; (max (bounding-rectangle-max-x region)
181     ;; (bounding-rectangle-max-x old-region))
182     ;; (max (bounding-rectangle-max-y region)
183     ;; (bounding-rectangle-max-y old-region)))))
184     (setf did-something-p t)
185     (fun (cdr xs)))
186     ;;
187     (t
188     (setf (cdr xs) (fun (cdr xs)))
189     xs))))
190     (setf (event-queue-head eq) (fun (event-queue-head eq))))))
191     ;; Regular events are just appended:
192     (t
193     (cond ((null (event-queue-tail eq))
194     (setf (event-queue-head eq) (cons item nil)
195     (event-queue-tail eq) (event-queue-head eq)))
196     (t
197     (setf (event-queue-tail eq)
198     (setf (cdr (event-queue-tail eq)) (cons item nil)))))))))
199 gilbert 1.5
200     (defmethod event-queue-prepend ((eq standard-event-queue) item)
201     "Prepend the item to the beginning of the queue."
202     (with-lock-held ((event-queue-lock eq))
203     (cond ((null (event-queue-tail eq))
204     (setf (event-queue-head eq) (cons item nil)
205     (event-queue-tail eq) (event-queue-head eq)))
206     (t
207     (push item (event-queue-head eq))))))
208    
209 mikemac 1.7 (defmethod event-queue-peek ((eq standard-event-queue))
210     (with-lock-held ((event-queue-lock eq))
211 brian 1.19 (check-schedule eq)
212 mikemac 1.7 (first (event-queue-head eq))))
213    
214 gilbert 1.5 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
215 gilbert 1.15 "Goes thru the whole event queue and returns the first event, which
216 gilbert 1.5 satisfies 'predicate' and leaves the event in the queue.
217     Returns NIL, if there is no such event."
218     (with-lock-held ((event-queue-lock eq))
219     (find-if predicate (event-queue-head eq))))
220    
221     (defmethod event-queue-listen ((eq standard-event-queue))
222 brian 1.19 (check-schedule eq)
223 gilbert 1.5 (not (null (event-queue-head eq))))
224    
225 brian 1.19 (defun now ()
226     (/ (get-internal-real-time)
227     internal-time-units-per-second))
228    
229 moore 1.8 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
230 brian 1.19 (check-schedule eq)
231     (with-slots (schedule-time) eq
232     (flet ((pred ()
233     (not (null (event-queue-head eq)))))
234     (cond
235     (timeout
236     (loop as timeout-time = (+ now timeout)
237     with now = (now)
238     do (when (pred)
239     (return t))
240     do (when (>= now timeout-time)
241     (return nil))
242     do (let ((timeout (if schedule-time
243     (min (- schedule-time now)
244     (- timeout-time now))
245     (- timeout-time now))))
246     (process-wait-with-timeout "Listening for event" timeout #'pred))
247     do (check-schedule eq)))
248     (schedule-time
249     (loop do (when (pred)
250     (return t))
251     do (process-wait-with-timeout "Listening for event"
252     (- schedule-time (now)) #'pred)
253     do (check-schedule eq)))
254     (t
255     (or (pred)
256     (progn
257     (process-wait "Listening for event" #'pred)
258     t)))))))
259    
260     (defmethod check-schedule ((eq standard-event-queue))
261     ; see if it's time to inject a scheduled event into the queue.
262     (with-slots (schedule-time schedule) eq
263     (when (and schedule-time
264     (> (now) schedule-time))
265     (let* ((event (pop schedule))
266     (sheet (pop schedule)))
267     (setf schedule-time (pop schedule))
268     (dispatch-event sheet event))
269     t)))
270    
271     ; ugh. FIXME when I work - build a priority queue or something
272     (defmethod event-queue-schedule ((eq standard-event-queue) sheet event delay)
273     (with-slots (schedule-time schedule) eq
274     (let ((when (+ (now) delay)))
275     (if schedule
276     (cond
277     ((< when schedule-time)
278     (push schedule-time schedule)
279     (push sheet schedule)
280     (push event schedule)
281     (setf schedule-time when))
282     (t
283     ; (format *debug-io* "queue = ~A~%" schedule)
284     (do* ((prev (cdr schedule) (cdddr prev))
285     (point (cddr schedule) (cdddr point))
286     (time (car point)))
287     ((or (null point)
288     (< when time))
289     (setf (cdr prev)
290     (cons when (cons event (cons sheet (cdr prev)))))))))
291     (progn
292     (setf schedule-time when)
293     (push sheet schedule)
294     (push event schedule))))))
295 moore 1.8
296 gilbert 1.5 ;; STANDARD-SHEET-INPUT-MIXIN
297    
298 mikemac 1.1 (defclass standard-sheet-input-mixin ()
299 mikemac 1.7 ((queue :initform (make-instance 'standard-event-queue)
300 moore 1.14 :reader sheet-event-queue
301     :initarg :input-buffer)
302 mikemac 1.1 (port :initform nil
303     :initarg :port
304 moore 1.14 :reader port)))
305 mikemac 1.1
306 mikemac 1.7 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
307     (sheet-event-queue stream))
308    
309 moore 1.14 (defmethod (setf stream-input-buffer) (new-val
310     (stream standard-sheet-input-mixin))
311     (setf (slot-value stream 'queue) new-val))
312    
313 mikemac 1.7 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
314     ; (if (typep event 'device-event)
315     ; (queue-event sheet event)
316     ; (handle-event sheet event)))
317    
318 mikemac 1.1 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
319 moore 1.9 (queue-event sheet event))
320 mikemac 1.1
321     (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
322     (with-slots (queue) sheet
323 gilbert 1.5 (event-queue-append queue event)))
324 brian 1.19
325     (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
326     (with-slots (queue) sheet
327     (event-queue-schedule queue sheet event delay)))
328 mikemac 1.1
329     (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
330 moore 1.14 ;; Standard practice is to ignore events
331 mikemac 1.1 (declare (ignore event))
332     nil)
333    
334     (defmethod event-read ((sheet standard-sheet-input-mixin))
335     (with-slots (queue) sheet
336 gilbert 1.5 (event-queue-read queue)))
337 boninfan 1.3
338     (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
339     &key (timeout nil) (wait-function nil))
340 gilbert 1.5 ;; This one is not in the spec ;-( --GB
341 boninfan 1.3 (with-slots (queue) sheet
342 gilbert 1.13 (event-queue-read-with-timeout queue timeout wait-function)))
343 mikemac 1.1
344     (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
345     (with-slots (queue) sheet
346 gilbert 1.5 (event-queue-read-no-hang queue)))
347 mikemac 1.1
348     (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
349     (with-slots (queue) sheet
350     (if event-type
351 gilbert 1.5 (event-queue-peek-if (lambda (x)
352     (typep x event-type))
353     queue)
354     (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
355     queue))))
356 mikemac 1.1
357     (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
358     (with-slots (queue) sheet
359 gilbert 1.5 (event-queue-prepend queue event)))
360 mikemac 1.1
361     (defmethod event-listen ((sheet standard-sheet-input-mixin))
362     (with-slots (queue) sheet
363 gilbert 1.5 (event-queue-listen queue)))
364    
365     ;;;;
366 mikemac 1.1
367 moore 1.14 ;;; Support for callers that want to set an event queue for every pane.
368    
369     (defclass no-event-queue-mixin ()
370     ())
371    
372     (defmethod initialize-instance :after ((obj no-event-queue-mixin)
373     &key input-buffer)
374     (declare (ignore input-buffer))
375     nil)
376    
377     (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
378     new-val)
379    
380     (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
381 moore 1.9 ())
382 mikemac 1.1
383     (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
384     (handle-event sheet event))
385    
386 moore 1.11 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
387     (declare (ignore event))
388     nil)
389    
390 mikemac 1.1 (define-condition sheet-is-mute-for-input (error)
391 moore 1.14 ())
392 mikemac 1.1
393 moore 1.14 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
394     ())
395 mikemac 1.1
396 rouanet 1.4 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
397 mikemac 1.1 (declare (ignore event))
398     (error 'sheet-is-mute-for-input))
399    
400 rouanet 1.4 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
401 mikemac 1.1 (declare (ignore event))
402     (error 'sheet-is-mute-for-input))
403    
404 brian 1.19 (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
405     (declare (ignore event delay))
406     (error 'sheet-is-mute-for-input))
407    
408 rouanet 1.4 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
409 mikemac 1.1 (declare (ignore event))
410     (error 'sheet-is-mute-for-input))
411    
412 rouanet 1.4 (defmethod event-read ((sheet sheet-mute-input-mixin))
413 mikemac 1.1 (error 'sheet-is-mute-for-input))
414    
415 rouanet 1.4 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
416 boninfan 1.3 &key (timeout nil) (wait-function nil))
417     (declare (ignore timeout wait-function))
418     (error 'sheet-is-mute-for-input))
419    
420 rouanet 1.4 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
421 mikemac 1.1 (error 'sheet-is-mute-for-input))
422    
423 rouanet 1.4 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
424 mikemac 1.1 (declare (ignore event-type))
425     (error 'sheet-is-mute-for-input))
426    
427 rouanet 1.4 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
428 mikemac 1.1 (declare (ignore event))
429     (error 'sheet-is-mute-for-input))
430    
431 rouanet 1.4 (defmethod event-listen ((sheet sheet-mute-input-mixin))
432 mikemac 1.1 (error 'sheet-is-mute-for-input))
433    
434 gilbert 1.5 ;;;;
435    
436 mikemac 1.1 (defclass delegate-sheet-input-mixin ()
437     ((delegate :initform nil
438     :initarg :delegate
439 gilbert 1.5 :accessor delegate-sheet-delegate) ))
440 moore 1.14
441     ;;; Don't know if this event queue stuff is completely right, or if it matters
442     ;;; much...
443    
444     (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
445     &key input-buffer)
446     (declare (ignore input-buffer)))
447    
448     (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
449     (sheet-event-queue (delegate-sheet-delegate stream)))
450    
451     (defmethod (setf stream-input-buffer) (new-val
452     (stream delegate-sheet-input-mixin))
453     (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
454 mikemac 1.1
455     (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
456     (dispatch-event (delegate-sheet-delegate sheet) event))
457    
458     (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
459     (queue-event (delegate-sheet-delegate sheet) event))
460 brian 1.19
461     (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
462     (schedule-event (delegate-sheet-delegate sheet) event delay))
463 mikemac 1.1
464     (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
465     (handle-event (delegate-sheet-delegate sheet) event))
466    
467     (defmethod event-read ((sheet delegate-sheet-input-mixin))
468     (event-read (delegate-sheet-delegate sheet)))
469 boninfan 1.3
470     (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
471     &key (timeout nil) (wait-function nil))
472     (event-read-with-timeout (delegate-sheet-delegate sheet)
473     :timeout timeout :wait-function wait-function))
474 mikemac 1.1
475     (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
476     (event-read-no-hang (delegate-sheet-delegate sheet)))
477    
478     (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
479     (event-peek (delegate-sheet-delegate sheet) event-type))
480    
481     (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
482     (event-unread (delegate-sheet-delegate sheet) event))
483    
484     (defmethod event-listen ((sheet delegate-sheet-input-mixin))
485     (event-listen (delegate-sheet-delegate sheet)))
486 moore 1.9
487     ;;; Class actually used by panes.
488    
489     (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
490     ())

  ViewVC Help
Powered by ViewVC 1.1.5