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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon Feb 11 21:34:23 2002 UTC (12 years, 2 months ago) by gilbert
Branch: MAIN
Changes since 1.4: +80 -20 lines
Implemented an input queue class.

This still needs work for single threaded Lisps.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2002 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
5
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 ;; 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 :documentation "Tail pointer of event queue.") ))
36
37 (defmethod event-queue-read-no-hang ((eq standard-event-queue))
38 "Reads one event from the queue, if there is no event just return NIL."
39 (with-lock-held ((event-queue-lock eq))
40 (let ((res (pop (event-queue-head eq))))
41 (when (null (event-queue-head eq))
42 (setf (event-queue-tail eq) nil))
43 res)))
44
45 (defmethod event-queue-read ((eq standard-event-queue))
46 "Reads one event from the queue, if there is no event, hang until here is one."
47 (loop
48 (let ((res (event-queue-read-no-hang eq)))
49 (when res
50 (return res))
51 (process-wait "Waiting for event"
52 (lambda ()
53 (not (null (event-queue-head eq))))))))
54
55 (defmethod event-queue-append ((eq standard-event-queue) item)
56 "Append the item at the end of the queue."
57 (with-lock-held ((event-queue-lock eq))
58 (cond ((null (event-queue-tail eq))
59 (setf (event-queue-head eq) (cons item nil)
60 (event-queue-tail eq) (event-queue-head eq)))
61 (t
62 (setf (event-queue-tail eq)
63 (setf (cdr (event-queue-tail eq)) (cons item nil)))))))
64
65 (defmethod event-queue-prepend ((eq standard-event-queue) item)
66 "Prepend the item to the beginning of the queue."
67 (with-lock-held ((event-queue-lock eq))
68 (cond ((null (event-queue-tail eq))
69 (setf (event-queue-head eq) (cons item nil)
70 (event-queue-tail eq) (event-queue-head eq)))
71 (t
72 (push item (event-queue-head eq))))))
73
74 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
75 "Goes thru the whole event queue an returns the first event, which
76 satisfies 'predicate' and leaves the event in the queue.
77 Returns NIL, if there is no such event."
78 (with-lock-held ((event-queue-lock eq))
79 (find-if predicate (event-queue-head eq))))
80
81 (defmethod event-queue-listen ((eq standard-event-queue))
82 (not (null (event-queue-head eq))))
83
84 ;; STANDARD-SHEET-INPUT-MIXIN
85
86 (defclass standard-sheet-input-mixin ()
87 ((queue :initform (make-instance 'standard-event-queue))
88 (port :initform nil
89 :initarg :port
90 :reader port)
91 ))
92
93 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
94 (if (typep event 'device-event)
95 (queue-event sheet event)
96 (handle-event sheet event)))
97
98 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
99 (with-slots (queue) sheet
100 (event-queue-append queue event)))
101
102 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
103 ;; Standard practice is too ignore events
104 (declare (ignore event))
105 nil)
106
107 (defmethod event-read ((sheet standard-sheet-input-mixin))
108 (with-slots (queue) sheet
109 (event-queue-read queue)))
110
111 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
112 &key (timeout nil) (wait-function nil))
113 ;; This one is not in the spec ;-( --GB
114 (with-slots (queue) sheet
115 (event-queue-read queue)))
116
117 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
118 (with-slots (queue) sheet
119 (event-queue-read-no-hang queue)))
120
121 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
122 (with-slots (queue) sheet
123 (if event-type
124 (event-queue-peek-if (lambda (x)
125 (typep x event-type))
126 queue)
127 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
128 queue))))
129
130 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
131 (with-slots (queue) sheet
132 (event-queue-prepend queue event)))
133
134 (defmethod event-listen ((sheet standard-sheet-input-mixin))
135 (with-slots (queue) sheet
136 (event-queue-listen queue)))
137
138 ;;;;
139
140 (defclass immediate-sheet-input-mixin (standard-sheet-input-mixin)
141 (
142 ))
143
144 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
145 (handle-event sheet event))
146
147 (define-condition sheet-is-mute-for-input (error)
148 (
149 ))
150
151 (defclass sheet-mute-input-mixin ()
152 (
153 ))
154
155 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
156 (declare (ignore event))
157 (error 'sheet-is-mute-for-input))
158
159 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
160 (declare (ignore event))
161 (error 'sheet-is-mute-for-input))
162
163 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
164 (declare (ignore event))
165 (error 'sheet-is-mute-for-input))
166
167 (defmethod event-read ((sheet sheet-mute-input-mixin))
168 (error 'sheet-is-mute-for-input))
169
170 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
171 &key (timeout nil) (wait-function nil))
172 (declare (ignore timeout wait-function))
173 (error 'sheet-is-mute-for-input))
174
175 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
176 (error 'sheet-is-mute-for-input))
177
178 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
179 (declare (ignore event-type))
180 (error 'sheet-is-mute-for-input))
181
182 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
183 (declare (ignore event))
184 (error 'sheet-is-mute-for-input))
185
186 (defmethod event-listen ((sheet sheet-mute-input-mixin))
187 (error 'sheet-is-mute-for-input))
188
189 ;;;;
190
191 (defclass delegate-sheet-input-mixin ()
192 ((delegate :initform nil
193 :initarg :delegate
194 :accessor delegate-sheet-delegate) ))
195
196 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
197 (dispatch-event (delegate-sheet-delegate sheet) event))
198
199 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
200 (queue-event (delegate-sheet-delegate sheet) event))
201
202 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
203 (handle-event (delegate-sheet-delegate sheet) event))
204
205 (defmethod event-read ((sheet delegate-sheet-input-mixin))
206 (event-read (delegate-sheet-delegate sheet)))
207
208 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
209 &key (timeout nil) (wait-function nil))
210 (event-read-with-timeout (delegate-sheet-delegate sheet)
211 :timeout timeout :wait-function wait-function))
212
213 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
214 (event-read-no-hang (delegate-sheet-delegate sheet)))
215
216 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
217 (event-peek (delegate-sheet-delegate sheet) event-type))
218
219 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
220 (event-unread (delegate-sheet-delegate sheet) event))
221
222 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
223 (event-listen (delegate-sheet-delegate sheet)))
224

  ViewVC Help
Powered by ViewVC 1.1.5