/[cmucl]/src/clx/input.lisp
ViewVC logotype

Contents of /src/clx/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.11: +8 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; This file contains definitions for the DISPLAY object for Common-Lisp X windows version 11
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20
21 ;;;
22 ;;; Change history:
23 ;;;
24 ;;; Date Author Description
25 ;;; -------------------------------------------------------------------------------------
26 ;;; 12/10/87 LGO Created
27
28 #+cmu
29 (ext:file-comment "$Id: input.lisp,v 1.12 2009/06/17 18:22:46 rtoy Rel $")
30
31 (in-package :xlib)
32
33 ;; Event Resource
34 (defvar *event-free-list* nil) ;; List of unused (processed) events
35
36 (eval-when (:compile-toplevel :load-toplevel :execute)
37 ;; Maximum number of events supported (the X11 alpha release only has 34)
38 (defconstant +max-events+ 64)
39 (defvar *event-key-vector* (make-array +max-events+ :initial-element nil)
40 "Vector of event keys - See define-event"))
41
42 (defvar *event-macro-vector* (make-array +max-events+ :initial-element nil)
43 "Vector of event handler functions - See declare-event")
44 (defvar *event-handler-vector* (make-array +max-events+ :initial-element nil)
45 "Vector of event handler functions - See declare-event")
46 (defvar *event-send-vector* (make-array +max-events+ :initial-element nil)
47 "Vector of event sending functions - See declare-event")
48
49 (defun allocate-event ()
50 (or (threaded-atomic-pop *event-free-list* reply-next reply-buffer)
51 (make-reply-buffer +replysize+)))
52
53 (defun deallocate-event (reply-buffer)
54 (declare (type reply-buffer reply-buffer))
55 (setf (reply-size reply-buffer) +replysize+)
56 (threaded-atomic-push reply-buffer *event-free-list* reply-next reply-buffer))
57
58 ;; Extensions are handled as follows:
59 ;; DEFINITION: Use DEFINE-EXTENSION
60 ;;
61 ;; CODE: Use EXTENSION-CODE to get the X11 opcode for an extension.
62 ;; This looks up the code on the display-extension-alist.
63 ;;
64 ;; EVENTS: Use DECLARE-EVENT to define events. This calls ALLOCATE-EXTENSION-EVENT-CODE
65 ;; at LOAD time to define an internal event-code number
66 ;; (stored in the 'event-code property of the event-name)
67 ;; used to index the following vectors:
68 ;; *event-key-vector* Used for getting the event-key
69 ;; *event-macro-vector* Used for getting the event-parameter getting macros
70 ;;
71 ;; The GET-INTERNAL-EVENT-CODE function can be called at runtime to convert
72 ;; a server event-code into an internal event-code used to index the following
73 ;; vectors:
74 ;; *event-handler-vector* Used for getting the event-handler function
75 ;; *event-send-vector* Used for getting the event-sending function
76 ;;
77 ;; The GET-EXTERNAL-EVENT-CODE function can be called at runtime to convert
78 ;; internal event-codes to external (server) codes.
79 ;;
80 ;; ERRORS: Use DEFINE-ERROR to define new error decodings.
81 ;;
82
83
84 ;; Any event-code greater than 34 is for an extension
85 (defparameter *first-extension-event-code* 35)
86
87 (defvar *extensions* nil) ;; alist of (extension-name-symbol events errors)
88
89 (defmacro define-extension (name &key events errors)
90 ;; Define extension NAME with EVENTS and ERRORS.
91 ;; Note: The case of NAME is important.
92 ;; To define the request, Use:
93 ;; (with-buffer-request (display (extension-opcode ,name)) ,@body)
94 ;; See the REQUESTS file for lots of examples.
95 ;; To define event handlers, use declare-event.
96 ;; To define error handlers, use declare-error and define-condition.
97 (declare (type stringable name)
98 (type list events errors))
99 (let ((name-symbol (kintern name)) ;; Intern name in the keyword package
100 (event-list (mapcar #'canonicalize-event-name events)))
101 `(eval-when (:compile-toplevel :load-toplevel :execute)
102 (setq *extensions* (cons (list ',name-symbol ',event-list ',errors)
103 (delete ',name-symbol *extensions* :key #'car))))))
104
105 (eval-when (:compile-toplevel :load-toplevel :execute)
106 (defun canonicalize-event-name (event)
107 ;; Returns the event name keyword given an event name stringable
108 (declare (type stringable event))
109 (declare (clx-values event-key))
110 (kintern event)))
111
112 (defun extension-event-key-p (key)
113 (dolist (extension *extensions* nil)
114 (when (member key (second extension))
115 (return t))))
116
117 (eval-when (:compile-toplevel :load-toplevel :execute)
118 (defun allocate-extension-event-code (name)
119 ;; Allocate an event-code for an extension. This is executed at
120 ;; COMPILE and LOAD time from DECLARE-EVENT. The event-code is
121 ;; used at compile-time by macros to index the following vectors:
122 ;; *EVENT-KEY-VECTOR* *EVENT-MACRO-VECTOR* *EVENT-HANDLER-VECTOR*
123 ;; *EVENT-SEND-VECTOR*
124 (let ((event-code (get name 'event-code)))
125 (declare (type (or null card8) event-code))
126 (unless event-code
127 ;; First ensure the name is for a declared extension
128 (unless (extension-event-key-p name)
129 (x-type-error name 'event-key))
130 (setq event-code (position nil *event-key-vector*
131 :start *first-extension-event-code*))
132 (setf (svref *event-key-vector* event-code) name)
133 (setf (get name 'event-code) event-code))
134 event-code)))
135
136 (defun get-internal-event-code (display code)
137 ;; Given an X11 event-code, return the internal event-code.
138 ;; The internal event-code is used for indexing into the following vectors:
139 ;; *event-key-vector* *event-handler-vector* *event-send-vector*
140 ;; Returns NIL when the event-code is for an extension that isn't handled.
141 (declare (type display display)
142 (type card8 code))
143 (declare (clx-values (or null card8)))
144 (setq code (logand #x7f code))
145 (if (< code *first-extension-event-code*)
146 code
147 (let* ((code-offset (- code *first-extension-event-code*))
148 (event-extensions (display-event-extensions display))
149 (code (if (< code-offset (length event-extensions))
150 (aref event-extensions code-offset)
151 0)))
152 (declare (type card8 code-offset code))
153 (when (zerop code)
154 (x-cerror "Ignore the event"
155 'unimplemented-event :event-code code :display display))
156 code)))
157
158 (defun get-external-event-code (display event)
159 ;; Given an X11 event name, return the event-code
160 (declare (type display display)
161 (type event-key event))
162 (declare (clx-values card8))
163 (let ((code (get-event-code event)))
164 (declare (type (or null card8) code))
165 (when (>= code *first-extension-event-code*)
166 (setq code (+ *first-extension-event-code*
167 (or (position code (display-event-extensions display))
168 (x-error 'undefined-event :display display :event-name event)))))
169 code))
170
171 (defmacro extension-opcode (display name)
172 ;; Returns the major opcode for extension NAME.
173 ;; This is a macro to enable NAME to be interned for fast run-time
174 ;; retrieval.
175 ;; Note: The case of NAME is important.
176 (let ((name-symbol (kintern name))) ;; Intern name in the keyword package
177 `(or (second (assoc ',name-symbol (display-extension-alist ,display)))
178 (x-error 'absent-extension :name ',name-symbol :display ,display))))
179
180 (defun initialize-extensions (display)
181 ;; Initialize extensions for DISPLAY
182 (let ((event-extensions (make-array 16 :element-type 'card8 :initial-element 0))
183 (extension-alist nil))
184 (declare (type vector event-extensions)
185 (type list extension-alist))
186 (dolist (extension *extensions*)
187 (let ((name (first extension))
188 (events (second extension)))
189 (declare (type keyword name)
190 (type list events))
191 (multiple-value-bind (major-opcode first-event first-error)
192 (query-extension display name)
193 (declare (type (or null card8) major-opcode first-event first-error))
194 (when (and major-opcode (plusp major-opcode))
195 (push (list name major-opcode first-event first-error)
196 extension-alist)
197 (when (plusp first-event) ;; When there are extension events
198 ;; Grow extension vector when needed
199 (let ((max-event (- (+ first-event (length events))
200 *first-extension-event-code*)))
201 (declare (type card8 max-event))
202 (when (>= max-event (length event-extensions))
203 (let ((new-extensions (make-array (+ max-event 16) :element-type 'card8
204 :initial-element 0)))
205 (declare (type vector new-extensions))
206 (replace new-extensions event-extensions)
207 (setq event-extensions new-extensions))))
208 (dolist (event events)
209 (declare (type symbol event))
210 (setf (aref event-extensions (- first-event *first-extension-event-code*))
211 (get-event-code event))
212 (incf first-event)))))))
213 (setf (display-event-extensions display) event-extensions)
214 (setf (display-extension-alist display) extension-alist)))
215
216 ;;
217 ;; Reply handlers
218 ;;
219
220 (defvar *pending-command-free-list* nil)
221
222 (defun start-pending-command (display)
223 (declare (type display display))
224 (let ((pending-command (or (threaded-atomic-pop *pending-command-free-list*
225 pending-command-next pending-command)
226 (make-pending-command))))
227 (declare (type pending-command pending-command))
228 (setf (pending-command-reply-buffer pending-command) nil)
229 (setf (pending-command-process pending-command) (current-process))
230 (setf (pending-command-sequence pending-command)
231 (ldb (byte 16 0) (1+ (buffer-request-number display))))
232 ;; Add the pending command to the end of the threaded list of pending
233 ;; commands for the display.
234 (with-event-queue-internal (display)
235 (threaded-nconc pending-command (display-pending-commands display)
236 pending-command-next pending-command))
237 pending-command))
238
239 (defun stop-pending-command (display pending-command)
240 (declare (type display display)
241 (type pending-command pending-command))
242 (with-event-queue-internal (display)
243 ;; Remove the pending command from the threaded list of pending commands
244 ;; for the display.
245 (threaded-delete pending-command (display-pending-commands display)
246 pending-command-next pending-command)
247 ;; Deallocate any reply buffers in this pending command
248 (loop
249 (let ((reply-buffer
250 (threaded-pop (pending-command-reply-buffer pending-command)
251 reply-next reply-buffer)))
252 (declare (type (or null reply-buffer) reply-buffer))
253 (if reply-buffer
254 (deallocate-reply-buffer reply-buffer)
255 (return nil)))))
256 ;; Clear pointers to help the Garbage Collector
257 (setf (pending-command-process pending-command) nil)
258 ;; Deallocate this pending-command
259 (threaded-atomic-push pending-command *pending-command-free-list*
260 pending-command-next pending-command)
261 nil)
262
263 ;;;
264
265 (defvar *reply-buffer-free-lists* (make-array 32 :initial-element nil))
266
267 (defun allocate-reply-buffer (size)
268 (declare (type array-index size))
269 (if (index<= size +replysize+)
270 (allocate-event)
271 (let ((index (integer-length (index1- size))))
272 (declare (type array-index index))
273 (or (threaded-atomic-pop (svref *reply-buffer-free-lists* index)
274 reply-next reply-buffer)
275 (make-reply-buffer (index-ash 1 index))))))
276
277 (defun deallocate-reply-buffer (reply-buffer)
278 (declare (type reply-buffer reply-buffer))
279 (let ((size (reply-size reply-buffer)))
280 (declare (type array-index size))
281 (if (index<= size +replysize+)
282 (deallocate-event reply-buffer)
283 (let ((index (integer-length (index1- size))))
284 (declare (type array-index index))
285 (threaded-atomic-push reply-buffer (svref *reply-buffer-free-lists* index)
286 reply-next reply-buffer)))))
287
288 ;;;
289
290 (defun read-error-input (display sequence reply-buffer token)
291 (declare (type display display)
292 (type reply-buffer reply-buffer)
293 (type card16 sequence))
294 (tagbody
295 start
296 (with-event-queue-internal (display)
297 (let ((command
298 ;; Find any pending command with this sequence number.
299 (threaded-dolist (pending-command (display-pending-commands display)
300 pending-command-next pending-command)
301 (when (= (pending-command-sequence pending-command) sequence)
302 (return pending-command)))))
303 (declare (type (or null pending-command) command))
304 (cond ((not (null command))
305 ;; Give this reply to the pending command
306 (threaded-nconc reply-buffer (pending-command-reply-buffer command)
307 reply-next reply-buffer)
308 (process-wakeup (pending-command-process command)))
309 ((member :immediately (display-report-asynchronous-errors display))
310 ;; No pending command and we should report the error immediately
311 (go report-error))
312 (t
313 ;; No pending command found, count this as an asynchronous error
314 (threaded-nconc reply-buffer (display-asynchronous-errors display)
315 reply-next reply-buffer)))))
316 (return-from read-error-input nil)
317 report-error
318 (note-input-complete display token)
319 (apply #'report-error display
320 (prog1 (make-error display reply-buffer t)
321 (deallocate-event reply-buffer)))))
322
323 (defun read-reply-input (display sequence length reply-buffer)
324 (declare (type display display)
325 (type (or null reply-buffer) reply-buffer)
326 (type card16 sequence)
327 (type array-index length))
328 (unwind-protect
329 (progn
330 (when (index< +replysize+ length)
331 (let ((repbuf nil))
332 (declare (type (or null reply-buffer) repbuf))
333 (unwind-protect
334 (progn
335 (setq repbuf (allocate-reply-buffer length))
336 (buffer-replace (reply-ibuf8 repbuf) (reply-ibuf8 reply-buffer)
337 0 +replysize+)
338 (deallocate-event (shiftf reply-buffer repbuf nil)))
339 (when repbuf
340 (deallocate-reply-buffer repbuf))))
341 (when (buffer-input display (reply-ibuf8 reply-buffer) +replysize+ length)
342 (return-from read-reply-input t))
343 (setf (reply-data-size reply-buffer) length))
344 (with-event-queue-internal (display)
345 ;; Find any pending command with this sequence number.
346 (let ((command
347 (threaded-dolist (pending-command (display-pending-commands display)
348 pending-command-next pending-command)
349 (when (= (pending-command-sequence pending-command) sequence)
350 (return pending-command)))))
351 (declare (type (or null pending-command) command))
352 (when command
353 ;; Give this reply to the pending command
354 (threaded-nconc (shiftf reply-buffer nil)
355 (pending-command-reply-buffer command)
356 reply-next reply-buffer)
357 (process-wakeup (pending-command-process command)))))
358 nil)
359 (when reply-buffer
360 (deallocate-reply-buffer reply-buffer))))
361
362 (defun read-event-input (display code reply-buffer)
363 (declare (type display display)
364 (type card8 code)
365 (type reply-buffer reply-buffer))
366 ;; Push the event in the input buffer on the display's event queue
367 (setf (event-code reply-buffer)
368 (get-internal-event-code display code))
369 (enqueue-event reply-buffer display)
370 nil)
371
372 (defun note-input-complete (display token)
373 (declare (type display display))
374 (when (eq (display-input-in-progress display) token)
375 ;; Indicate that input is no longer in progress
376 (setf (display-input-in-progress display) nil)
377 ;; Let the event process get the first chance to do input
378 (let ((process (display-event-process display)))
379 (when (not (null process))
380 (process-wakeup process)))
381 ;; Then give processes waiting for command responses a chance
382 (unless (display-input-in-progress display)
383 (with-event-queue-internal (display)
384 (threaded-dolist (command (display-pending-commands display)
385 pending-command-next pending-command)
386 (process-wakeup (pending-command-process command)))))))
387
388 (defun read-input (display timeout force-output-p predicate &rest predicate-args)
389 (declare (type display display)
390 (type (or null number) timeout)
391 (type generalized-boolean force-output-p)
392 (dynamic-extent predicate-args))
393 (declare (type function predicate)
394 #+clx-ansi-common-lisp
395 (dynamic-extent predicate)
396 #+(and lispm (not clx-ansi-common-lisp))
397 (sys:downward-funarg predicate))
398 (let ((reply-buffer nil)
399 (token (or (current-process) (cons nil nil))))
400 (declare (type (or null reply-buffer) reply-buffer))
401 (unwind-protect
402 (tagbody
403 loop
404 (when (display-dead display)
405 (x-error 'closed-display :display display))
406 (when (apply predicate predicate-args)
407 (return-from read-input nil))
408 ;; Check and see if we have to force output
409 (when (and force-output-p
410 (or (and (not (eq (display-input-in-progress display) token))
411 (not (conditional-store
412 (display-input-in-progress display) nil token)))
413 (null (buffer-listen display))))
414 (go force-output))
415 ;; Ensure that only one process is reading input.
416 (unless (or (eq (display-input-in-progress display) token)
417 (conditional-store (display-input-in-progress display) nil token))
418 (if (eql timeout 0)
419 (return-from read-input :timeout)
420 (apply #'process-block "CLX Input Lock"
421 #'(lambda (display predicate &rest predicate-args)
422 (declare (type display display)
423 (dynamic-extent predicate-args)
424 (type function predicate)
425 #+clx-ansi-common-lisp
426 (dynamic-extent predicate)
427 #+(and lispm (not clx-ansi-common-lisp))
428 (sys:downward-funarg predicate))
429 (or (apply predicate predicate-args)
430 (null (display-input-in-progress display))
431 (not (null (display-dead display)))))
432 display predicate predicate-args))
433 (go loop))
434 ;; Now start gobbling.
435 (setq reply-buffer (allocate-event))
436 (with-buffer-input (reply-buffer :sizes (8 16 32))
437 (let ((type 0))
438 (declare (type card8 type))
439 ;; Wait for input before we disallow aborts.
440 (unless (eql timeout 0)
441 (let ((eof-p (buffer-input-wait display timeout)))
442 (when eof-p (return-from read-input eof-p))))
443 (without-aborts
444 (let ((eof-p (buffer-input display buffer-bbuf 0 +replysize+
445 (if force-output-p 0 timeout))))
446 (when eof-p
447 (when (eq eof-p :timeout)
448 (if force-output-p
449 (go force-output)
450 (return-from read-input :timeout)))
451 (setf (display-dead display) t)
452 (return-from read-input eof-p)))
453 (setf (reply-data-size reply-buffer) +replysize+)
454 (when (= (the card8 (setq type (read-card8 0))) 1)
455 ;; Normal replies can be longer than +replysize+, so we
456 ;; have to handle them while aborts are still disallowed.
457 (let ((value
458 (read-reply-input
459 display (read-card16 2)
460 (index+ +replysize+ (index* (read-card32 4) 4))
461 (shiftf reply-buffer nil))))
462 (when value
463 (return-from read-input value))
464 (go loop))))
465 (if (zerop type)
466 (read-error-input
467 display (read-card16 2) (shiftf reply-buffer nil) token)
468 (read-event-input
469 display (read-card8 0) (shiftf reply-buffer nil)))))
470 (go loop)
471 force-output
472 (note-input-complete display token)
473 (display-force-output display)
474 (setq force-output-p nil)
475 (go loop))
476 (when (not (null reply-buffer))
477 (deallocate-reply-buffer reply-buffer))
478 (note-input-complete display token))))
479
480 (defun report-asynchronous-errors (display mode)
481 (when (and (display-asynchronous-errors display)
482 (member mode (display-report-asynchronous-errors display)))
483 (let ((aborted t))
484 (unwind-protect
485 (loop
486 (let ((error
487 (with-event-queue-internal (display)
488 (threaded-pop (display-asynchronous-errors display)
489 reply-next reply-buffer))))
490 (declare (type (or null reply-buffer) error))
491 (if error
492 (apply #'report-error display
493 (prog1 (make-error display error t)
494 (deallocate-event error)))
495 (return (setq aborted nil)))))
496 ;; If we get aborted out of this, deallocate all outstanding asynchronous
497 ;; errors.
498 (when aborted
499 (with-event-queue-internal (display)
500 (loop
501 (let ((reply-buffer
502 (threaded-pop (display-asynchronous-errors display)
503 reply-next reply-buffer)))
504 (declare (type (or null reply-buffer) reply-buffer))
505 (if reply-buffer
506 (deallocate-event reply-buffer)
507 (return nil))))))))))
508
509 (defun wait-for-event (display timeout force-output-p)
510 (declare (type display display)
511 (type (or null number) timeout)
512 (type generalized-boolean force-output-p))
513 (let ((event-process-p (not (eql timeout 0))))
514 (declare (type generalized-boolean event-process-p))
515 (unwind-protect
516 (loop
517 (when event-process-p
518 (conditional-store (display-event-process display) nil (current-process)))
519 (let ((eof (read-input
520 display timeout force-output-p
521 #'(lambda (display)
522 (declare (type display display))
523 (or (not (null (display-new-events display)))
524 (and (display-asynchronous-errors display)
525 (member :before-event-handling
526 (display-report-asynchronous-errors display))
527 t)))
528 display)))
529 (when eof (return eof)))
530 ;; Report asynchronous errors here if the user wants us to.
531 (when event-process-p
532 (report-asynchronous-errors display :before-event-handling))
533 (when (not (null (display-new-events display)))
534 (return nil)))
535 (when (and event-process-p
536 (eq (display-event-process display) (current-process)))
537 (setf (display-event-process display) nil)))))
538
539 (defun read-reply (display pending-command)
540 (declare (type display display)
541 (type pending-command pending-command))
542 (loop
543 (when (read-input display nil nil
544 #'(lambda (pending-command)
545 (declare (type pending-command pending-command))
546 (not (null (pending-command-reply-buffer pending-command))))
547 pending-command)
548 (x-error 'closed-display :display display))
549 (let ((reply-buffer
550 (with-event-queue-internal (display)
551 (threaded-pop (pending-command-reply-buffer pending-command)
552 reply-next reply-buffer))))
553 (declare (type reply-buffer reply-buffer))
554 ;; Check for error.
555 (with-buffer-input (reply-buffer)
556 (ecase (read-card8 0)
557 (0 (apply #'report-error display
558 (prog1 (make-error display reply-buffer nil)
559 (deallocate-reply-buffer reply-buffer))))
560 (1 (return reply-buffer)))))))
561
562 ;;;
563
564 (defun event-listen (display &optional (timeout 0))
565 (declare (type display display)
566 (type (or null number) timeout)
567 (clx-values number-of-events-queued eof-or-timeout))
568 ;; Returns the number of events queued locally, if any, else nil. Hangs
569 ;; waiting for events, forever if timeout is nil, else for the specified
570 ;; number of seconds.
571 (let* ((current-event-symbol (car (display-current-event-symbol display)))
572 (current-event (and (boundp current-event-symbol)
573 (symbol-value current-event-symbol)))
574 (queue (if current-event
575 (reply-next (the reply-buffer current-event))
576 (display-event-queue-head display))))
577 (declare (type symbol current-event-symbol)
578 (type (or null reply-buffer) current-event queue))
579 (if queue
580 (values
581 (with-event-queue-internal (display :timeout timeout)
582 (threaded-length queue reply-next reply-buffer))
583 nil)
584 (with-event-queue (display :timeout timeout :inline t)
585 (let ((eof-or-timeout (wait-for-event display timeout nil)))
586 (if eof-or-timeout
587 (values nil eof-or-timeout)
588 (values
589 (with-event-queue-internal (display :timeout timeout)
590 (threaded-length (display-new-events display)
591 reply-next reply-buffer))
592 nil)))))))
593
594 (defun queue-event (display event-key &rest args &key append-p send-event-p &allow-other-keys)
595 ;; The event is put at the head of the queue if append-p is nil, else the tail.
596 ;; Additional arguments depend on event-key, and are as specified above with
597 ;; declare-event, except that both resource-ids and resource objects are accepted
598 ;; in the event components.
599 (declare (type display display)
600 (type event-key event-key)
601 (type generalized-boolean append-p send-event-p)
602 (dynamic-extent args))
603 (unless (get event-key 'event-code)
604 (x-type-error event-key 'event-key))
605 (let* ((event (allocate-event))
606 (buffer (reply-ibuf8 event))
607 (event-code (get event-key 'event-code)))
608 (declare (type reply-buffer event)
609 (type buffer-bytes buffer)
610 (type (or null card8) event-code))
611 (unless event-code (x-type-error event-key 'event-key))
612 (setf (event-code event) event-code)
613 (with-display (display)
614 (apply (svref *event-send-vector* event-code) display args)
615 (buffer-replace buffer
616 (display-obuf8 display)
617 0
618 +replysize+
619 (index+ 12 (buffer-boffset display)))
620 (setf (aref buffer 0) (if send-event-p (logior event-code #x80) event-code)
621 (aref buffer 2) 0
622 (aref buffer 3) 0))
623 (with-event-queue (display)
624 (if append-p
625 (enqueue-event event display)
626 (with-event-queue-internal (display)
627 (threaded-requeue event
628 (display-event-queue-head display)
629 (display-event-queue-tail display)
630 reply-next reply-buffer))))))
631
632 (defun enqueue-event (new-event display)
633 (declare (type reply-buffer new-event)
634 (type display display))
635 ;; Place EVENT at the end of the event queue for DISPLAY
636 (let* ((event-code (event-code new-event))
637 (event-key (and (index< event-code (length *event-key-vector*))
638 (svref *event-key-vector* event-code))))
639 (declare (type array-index event-code)
640 (type (or null keyword) event-key))
641 (if (null event-key)
642 (unwind-protect
643 (cerror "Ignore this event" "No handler for ~s event" event-key)
644 (deallocate-event new-event))
645 (with-event-queue-internal (display)
646 (threaded-enqueue new-event
647 (display-event-queue-head display)
648 (display-event-queue-tail display)
649 reply-next reply-buffer)
650 (unless (display-new-events display)
651 (setf (display-new-events display) new-event))))))
652
653
654 (defmacro define-event (name code)
655 `(eval-when (:compile-toplevel :load-toplevel :execute)
656 (setf (svref *event-key-vector* ,code) ',name)
657 (setf (get ',name 'event-code) ,code)))
658
659 ;; Event names. Used in "type" field in XEvent structures. Not to be
660 ;; confused with event masks above. They start from 2 because 0 and 1
661 ;; are reserved in the protocol for errors and replies. */
662
663 (define-event :key-press 2)
664 (define-event :key-release 3)
665 (define-event :button-press 4)
666 (define-event :button-release 5)
667 (define-event :motion-notify 6)
668 (define-event :enter-notify 7)
669 (define-event :leave-notify 8)
670 (define-event :focus-in 9)
671 (define-event :focus-out 10)
672 (define-event :keymap-notify 11)
673 (define-event :exposure 12)
674 (define-event :graphics-exposure 13)
675 (define-event :no-exposure 14)
676 (define-event :visibility-notify 15)
677 (define-event :create-notify 16)
678 (define-event :destroy-notify 17)
679 (define-event :unmap-notify 18)
680 (define-event :map-notify 19)
681 (define-event :map-request 20)
682 (define-event :reparent-notify 21)
683 (define-event :configure-notify 22)
684 (define-event :configure-request 23)
685 (define-event :gravity-notify 24)
686 (define-event :resize-request 25)
687 (define-event :circulate-notify 26)
688 (define-event :circulate-request 27)
689 (define-event :property-notify 28)
690 (define-event :selection-clear 29)
691 (define-event :selection-request 30)
692 (define-event :selection-notify 31)
693 (define-event :colormap-notify 32)
694 (define-event :client-message 33)
695 (define-event :mapping-notify 34)
696
697
698 (defmacro declare-event (event-codes &body declares &environment env)
699 ;; Used to indicate the keyword arguments for handler functions in
700 ;; process-event and event-case.
701 ;; Generates the functions used in SEND-EVENT.
702 ;; A compiler warning is printed when all of EVENT-CODES are not
703 ;; defined by a preceding DEFINE-EXTENSION.
704 ;; The body is a list of declarations, each of which has the form:
705 ;; (type . items) Where type is a data-type, and items is a list of
706 ;; symbol names. The item order corresponds to the order of fields
707 ;; in the event sent by the server. An item may be a list of items.
708 ;; In this case, each item is aliased to the same event field.
709 ;; This is used to give all events an EVENT-WINDOW item.
710 ;; See the INPUT file for lots of examples.
711 (declare (type (or keyword list) event-codes)
712 (type (alist (field-type symbol) (field-names list))
713 declares))
714 (when (atom event-codes) (setq event-codes (list event-codes)))
715 (setq event-codes (mapcar #'canonicalize-event-name event-codes))
716 (let* ((keywords nil)
717 (name (first event-codes))
718 (get-macro (xintern name '-event-get-macro))
719 (get-function (xintern name '-event-get))
720 (put-function (xintern name '-event-put)))
721 (multiple-value-bind (get-code get-index get-sizes)
722 (get-put-items
723 2 declares nil
724 #'(lambda (type index item args)
725 (flet ((event-get (type index item args)
726 (unless (member type '(pad8 pad16))
727 `(,(kintern item)
728 (,(getify type) ,index ,@args)))))
729 (if (atom item)
730 (event-get type index item args)
731 (mapcan #'(lambda (item)
732 (event-get type index item args))
733 item)))))
734 (declare (ignore get-index))
735 (multiple-value-bind (put-code put-index put-sizes)
736 (get-put-items
737 2 declares t
738 #'(lambda (type index item args)
739 (unless (member type '(pad8 pad16))
740 (if (atom item)
741 (progn
742 (push item keywords)
743 `((,(putify type) ,index ,item ,@args)))
744 (let ((names (mapcar #'(lambda (name) (kintern name))
745 item)))
746 (setq keywords (append item keywords))
747 `((,(putify type) ,index
748 (check-consistency ',names ,@item) ,@args)))))))
749 (declare (ignore put-index))
750 `(within-definition (,name declare-event)
751 (defun ,get-macro (display event-key variable)
752 ;; Note: we take pains to macroexpand the get-code here to enable application
753 ;; code to be compiled without having the CLX macros file loaded.
754 `(let ((%buffer ,display))
755 (declare (ignorable %buffer))
756 ,(getf `(:display (the display ,display)
757 :event-key (the keyword ,event-key)
758 :event-code (the card8 (logand #x7f (read-card8 0)))
759 :send-event-p (logbitp 7 (read-card8 0))
760 ,@',(mapcar #'(lambda (form)
761 (clx-macroexpand form env))
762 get-code))
763 variable)))
764
765 (defun ,get-function (display event handler)
766 (declare (type display display)
767 (type reply-buffer event))
768 (declare (type function handler)
769 #+clx-ansi-common-lisp
770 (dynamic-extent handler)
771 #+(and lispm (not clx-ansi-common-lisp))
772 (sys:downward-funarg handler))
773 (reading-event (event :display display :sizes (8 16 ,@get-sizes))
774 (funcall handler
775 :display display
776 :event-key (svref *event-key-vector* (event-code event))
777 :event-code (logand #x7f (card8-get 0))
778 :send-event-p (logbitp 7 (card8-get 0))
779 ,@get-code)))
780
781 (defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
782 &allow-other-keys)
783 (declare (type display display))
784 ,(when (member 'sequence keywords)
785 `(unless sequence (setq sequence (display-request-number display))))
786 (with-buffer-output (display :sizes ,put-sizes
787 :index (index+ (buffer-boffset display) 12))
788 ,@put-code))
789
790 ,@(mapcar #'(lambda (name)
791 (allocate-extension-event-code name)
792 `(let ((event-code (or (get ',name 'event-code)
793 (allocate-extension-event-code ',name))))
794 (setf (svref *event-macro-vector* event-code)
795 (function ,get-macro))
796 (setf (svref *event-handler-vector* event-code)
797 (function ,get-function))
798 (setf (svref *event-send-vector* event-code)
799 (function ,put-function))))
800 event-codes)
801 ',name)))))
802
803 (defun check-consistency (names &rest args)
804 ;; Ensure all args are nil or have the same value.
805 ;; Returns the consistent non-nil value.
806 (let ((value (car args)))
807 (dolist (arg (cdr args))
808 (if value
809 (when (and arg (not (eq arg value)))
810 (x-error 'inconsistent-parameters
811 :parameters (mapcan #'list names args)))
812 (setq value arg)))
813 value))
814
815 (declare-event (:key-press :key-release :button-press :button-release)
816 ;; for key-press and key-release, code is the keycode
817 ;; for button-press and button-release, code is the button number
818 (data code)
819 (card16 sequence)
820 ((or null card32) time)
821 (window root (window event-window))
822 ((or null window) child)
823 (int16 root-x root-y x y)
824 (card16 state)
825 (boolean same-screen-p)
826 )
827
828 (declare-event :motion-notify
829 ((data boolean) hint-p)
830 (card16 sequence)
831 ((or null card32) time)
832 (window root (window event-window))
833 ((or null window) child)
834 (int16 root-x root-y x y)
835 (card16 state)
836 (boolean same-screen-p))
837
838 (declare-event (:enter-notify :leave-notify)
839 ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
840 (card16 sequence)
841 ((or null card32) time)
842 (window root (window event-window))
843 ((or null window) child)
844 (int16 root-x root-y x y)
845 (card16 state)
846 ((member8 :normal :grab :ungrab) mode)
847 ((bit 0) focus-p)
848 ((bit 1) same-screen-p))
849
850 (declare-event (:focus-in :focus-out)
851 ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
852 :pointer :pointer-root :none))
853 kind)
854 (card16 sequence)
855 (window (window event-window))
856 ((member8 :normal :while-grabbed :grab :ungrab) mode))
857
858 (declare-event :keymap-notify
859 ((bit-vector256 0) keymap))
860
861 (declare-event :exposure
862 (card16 sequence)
863 (window (window event-window))
864 (card16 x y width height count))
865
866 (declare-event :graphics-exposure
867 (card16 sequence)
868 (drawable (drawable event-window))
869 (card16 x y width height)
870 (card16 minor) ;; Minor opcode
871 (card16 count)
872 (card8 major))
873
874 (declare-event :no-exposure
875 (card16 sequence)
876 (drawable (drawable event-window))
877 (card16 minor)
878 (card8 major))
879
880 (declare-event :visibility-notify
881 (card16 sequence)
882 (window (window event-window))
883 ((member8 :unobscured :partially-obscured :fully-obscured) state))
884
885 (declare-event :create-notify
886 (card16 sequence)
887 (window (parent event-window) window)
888 (int16 x y)
889 (card16 width height border-width)
890 (boolean override-redirect-p))
891
892 (declare-event :destroy-notify
893 (card16 sequence)
894 (window event-window window))
895
896 (declare-event :unmap-notify
897 (card16 sequence)
898 (window event-window window)
899 (boolean configure-p))
900
901 (declare-event :map-notify
902 (card16 sequence)
903 (window event-window window)
904 (boolean override-redirect-p))
905
906 (declare-event :map-request
907 (card16 sequence)
908 (window (parent event-window) window))
909
910 (declare-event :reparent-notify
911 (card16 sequence)
912 (window event-window window parent)
913 (int16 x y)
914 (boolean override-redirect-p))
915
916 (declare-event :configure-notify
917 (card16 sequence)
918 (window event-window window)
919 ((or null window) above-sibling)
920 (int16 x y)
921 (card16 width height border-width)
922 (boolean override-redirect-p))
923
924 (declare-event :configure-request
925 ((data (member8 :above :below :top-if :bottom-if :opposite)) stack-mode)
926 (card16 sequence)
927 (window (parent event-window) window)
928 ((or null window) above-sibling)
929 (int16 x y)
930 (card16 width height border-width value-mask))
931
932 (declare-event :gravity-notify
933 (card16 sequence)
934 (window event-window window)
935 (int16 x y))
936
937 (declare-event :resize-request
938 (card16 sequence)
939 (window (window event-window))
940 (card16 width height))
941
942 (declare-event :circulate-notify
943 (card16 sequence)
944 (window event-window window parent)
945 ((member8 :top :bottom) place))
946
947 (declare-event :circulate-request
948 (card16 sequence)
949 (window (parent event-window) window)
950 (pad16 1 2)
951 ((member8 :top :bottom) place))
952
953 (declare-event :property-notify
954 (card16 sequence)
955 (window (window event-window))
956 (keyword atom) ;; keyword
957 ((or null card32) time)
958 ((member8 :new-value :deleted) state))
959
960 (declare-event :selection-clear
961 (card16 sequence)
962 ((or null card32) time)
963 (window (window event-window))
964 (keyword selection) ;; keyword
965 )
966
967 (declare-event :selection-request
968 (card16 sequence)
969 ((or null card32) time)
970 (window (window event-window) requestor)
971 (keyword selection target)
972 ((or null keyword) property)
973 )
974
975 (declare-event :selection-notify
976 (card16 sequence)
977 ((or null card32) time)
978 (window (window event-window))
979 (keyword selection target)
980 ((or null keyword) property)
981 )
982
983 (declare-event :colormap-notify
984 (card16 sequence)
985 (window (window event-window))
986 ((or null colormap) colormap)
987 (boolean new-p installed-p))
988
989 (declare-event :client-message
990 (data format)
991 (card16 sequence)
992 (window (window event-window))
993 (keyword type)
994 ((client-message-sequence format) data))
995
996 (declare-event :mapping-notify
997 (card16 sequence)
998 ((member8 :modifier :keyboard :pointer) request)
999 (card8 start) ;; first key-code
1000 (card8 count))
1001
1002
1003 ;;
1004 ;; EVENT-LOOP
1005 ;;
1006
1007 (defun event-loop-setup (display)
1008 (declare (type display display)
1009 (clx-values progv-vars progv-vals
1010 current-event-symbol current-event-discarded-p-symbol))
1011 (let* ((progv-vars (display-current-event-symbol display))
1012 (current-event-symbol (first progv-vars))
1013 (current-event-discarded-p-symbol (second progv-vars)))
1014 (declare (type list progv-vars)
1015 (type symbol current-event-symbol current-event-discarded-p-symbol))
1016 (values
1017 progv-vars
1018 (list (if (boundp current-event-symbol)
1019 ;; The current event is already bound, so bind it to the next
1020 ;; event.
1021 (let ((event (symbol-value current-event-symbol)))
1022 (declare (type (or null reply-buffer) event))
1023 (and event (reply-next (the reply-buffer event))))
1024 ;; The current event isn't bound, so bind it to the head of the
1025 ;; event queue.
1026 (display-event-queue-head display))
1027 nil)
1028 current-event-symbol
1029 current-event-discarded-p-symbol)))
1030
1031 (defun event-loop-step-before (display timeout force-output-p current-event-symbol)
1032 (declare (type display display)
1033 (type (or null number) timeout)
1034 (type generalized-boolean force-output-p)
1035 (type symbol current-event-symbol)
1036 (clx-values event eof-or-timeout))
1037 (unless (symbol-value current-event-symbol)
1038 (let ((eof-or-timeout (wait-for-event display timeout force-output-p)))
1039 (when eof-or-timeout
1040 (return-from event-loop-step-before (values nil eof-or-timeout))))
1041 (setf (symbol-value current-event-symbol) (display-new-events display)))
1042 (let ((event (symbol-value current-event-symbol)))
1043 (declare (type reply-buffer event))
1044 (with-event-queue-internal (display)
1045 (when (eq event (display-new-events display))
1046 (setf (display-new-events display) (reply-next event))))
1047 (values event nil)))
1048
1049 (defun dequeue-event (display event)
1050 (declare (type display display)
1051 (type reply-buffer event)
1052 (clx-values next))
1053 ;; Remove the current event from the event queue
1054 (with-event-queue-internal (display)
1055 (let ((next (reply-next event))
1056 (head (display-event-queue-head display)))
1057 (declare (type (or null reply-buffer) next head))
1058 (when (eq event (display-new-events display))
1059 (setf (display-new-events display) next))
1060 (cond ((eq event head)
1061 (threaded-dequeue (display-event-queue-head display)
1062 (display-event-queue-tail display)
1063 reply-next reply-buffer))
1064 ((null head)
1065 (setq next nil))
1066 (t
1067 (do* ((previous head current)
1068 (current (reply-next previous) (reply-next previous)))
1069 ((or (null current) (eq event current))
1070 (when (eq event current)
1071 (when (eq current (display-event-queue-tail display))
1072 (setf (display-event-queue-tail display) previous))
1073 (setf (reply-next previous) next)))
1074 (declare (type reply-buffer previous)
1075 (type (or null reply-buffer) current)))))
1076 next)))
1077
1078 (defun event-loop-step-after
1079 (display event discard-p current-event-symbol current-event-discarded-p-symbol
1080 &optional aborted)
1081 (declare (type display display)
1082 (type reply-buffer event)
1083 (type generalized-boolean discard-p aborted)
1084 (type symbol current-event-symbol current-event-discarded-p-symbol))
1085 (when (and discard-p
1086 (not aborted)
1087 (not (symbol-value current-event-discarded-p-symbol)))
1088 (discard-current-event display))
1089 (let ((next (reply-next event)))
1090 (declare (type (or null reply-buffer) next))
1091 (when (symbol-value current-event-discarded-p-symbol)
1092 (setf (symbol-value current-event-discarded-p-symbol) nil)
1093 (setq next (dequeue-event display event))
1094 (deallocate-event event))
1095 (setf (symbol-value current-event-symbol) next)))
1096
1097 (defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
1098 ;; Bind EVENT to the events for DISPLAY.
1099 ;; This is the "GUTS" of process-event and event-case.
1100 `(let ((.display. ,display)
1101 (.timeout. ,timeout)
1102 (.force-output-p. ,force-output-p)
1103 (.discard-p. ,discard-p))
1104 (declare (type display .display.)
1105 (type (or null number) .timeout.)
1106 (type generalized-boolean .force-output-p. .discard-p.))
1107 (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.)))
1108 (multiple-value-bind (.progv-vars. .progv-vals.
1109 .current-event-symbol. .current-event-discarded-p-symbol.)
1110 (event-loop-setup .display.)
1111 (declare (type list .progv-vars. .progv-vals.)
1112 (type symbol .current-event-symbol. .current-event-discarded-p-symbol.))
1113 (progv .progv-vars. .progv-vals.
1114 (loop
1115 (multiple-value-bind (.event. .eof-or-timeout.)
1116 (event-loop-step-before
1117 .display. .timeout. .force-output-p.
1118 .current-event-symbol.)
1119 (declare (type (or null reply-buffer) .event.))
1120 (when (null .event.) (return (values nil .eof-or-timeout.)))
1121 (let ((.aborted. t))
1122 (unwind-protect
1123 (progn
1124 (let ((,event .event.))
1125 (declare (type reply-buffer ,event))
1126 ,@body)
1127 (setq .aborted. nil))
1128 (event-loop-step-after
1129 .display. .event. .discard-p.
1130 .current-event-symbol. .current-event-discarded-p-symbol.
1131 .aborted.))))))))))
1132
1133 (defun discard-current-event (display)
1134 ;; Discard the current event for DISPLAY.
1135 ;; Returns NIL when the event queue is empty, else T.
1136 ;; To ensure events aren't ignored, application code should only call
1137 ;; this when throwing out of event-case or process-next-event, or from
1138 ;; inside even-case, event-cond or process-event when :peek-p is T and
1139 ;; :discard-p is NIL.
1140 (declare (type display display)
1141 (clx-values generalized-boolean))
1142 (let* ((symbols (display-current-event-symbol display))
1143 (event
1144 (let ((current-event-symbol (first symbols)))
1145 (declare (type symbol current-event-symbol))
1146 (when (boundp current-event-symbol)
1147 (symbol-value current-event-symbol)))))
1148 (declare (type list symbols)
1149 (type (or null reply-buffer) event))
1150 (unless (null event)
1151 ;; Set the discarded-p flag
1152 (let ((current-event-discarded-p-symbol (second symbols)))
1153 (declare (type symbol current-event-discarded-p-symbol))
1154 (when (boundp current-event-discarded-p-symbol)
1155 (setf (symbol-value current-event-discarded-p-symbol) t)))
1156 ;; Return whether the event queue is empty
1157 (not (null (reply-next (the reply-buffer event)))))))
1158
1159 ;;
1160 ;; PROCESS-EVENT
1161 ;;
1162 (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
1163 ;; If force-output-p is true, first invokes display-force-output. Invokes handler
1164 ;; on each queued event until handler returns non-nil, and that returned object is
1165 ;; then returned by process-event. If peek-p is true, then the event is not
1166 ;; removed from the queue. If discard-p is true, then events for which handler
1167 ;; returns nil are removed from the queue, otherwise they are left in place. Hangs
1168 ;; until non-nil is generated for some event, or for the specified timeout (in
1169 ;; seconds, if given); however, it is acceptable for an implementation to wait only
1170 ;; once on network data, and therefore timeout prematurely. Returns nil on
1171 ;; timeout. If handler is a sequence, it is expected to contain handler functions
1172 ;; specific to each event class; the event code is used to index the sequence,
1173 ;; fetching the appropriate handler. Handler is called with raw resource-ids, not
1174 ;; with resource objects. The arguments to the handler are described using declare-event.
1175 ;;
1176 ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
1177 ;; from the queue (it is left in place), NIL means the event is removed.
1178
1179 (declare (type display display)
1180 (type (or null number) timeout)
1181 (type generalized-boolean peek-p discard-p force-output-p))
1182 (declare (type t handler)
1183 #+clx-ansi-common-lisp
1184 (dynamic-extent handler)
1185 #+(and lispm (not clx-ansi-common-lisp))
1186 (sys:downward-funarg #+Genera * #-Genera handler))
1187 (event-loop (display event timeout force-output-p discard-p)
1188 (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
1189 (event-decoder (and (index< event-code (length *event-handler-vector*))
1190 (svref *event-handler-vector* event-code))))
1191 (declare (type array-index event-code)
1192 (type (or null function) event-decoder))
1193 (if event-decoder
1194 (let ((event-handler (if (functionp handler)
1195 handler
1196 (and (type? handler 'sequence)
1197 (< event-code (length handler))
1198 (elt handler event-code)))))
1199 (if event-handler
1200 (let ((result (funcall event-decoder display event event-handler)))
1201 (when result
1202 (unless peek-p
1203 (discard-current-event display))
1204 (return result)))
1205 (cerror "Ignore this event"
1206 "No handler for ~s event"
1207 (svref *event-key-vector* event-code))))
1208 (cerror "Ignore this event"
1209 "Server Error: event with unknown event code ~d received."
1210 event-code)))))
1211
1212 (defun make-event-handlers (&key (type 'array) default)
1213 (declare (type t type) ;Sequence type specifier
1214 (type (or null function) default)
1215 (clx-values sequence)) ;Default handler for initial content
1216 ;; Makes a handler sequence suitable for process-event
1217 (make-sequence type +max-events+ :initial-element default))
1218
1219 (defun event-handler (handlers event-key)
1220 (declare (type sequence handlers)
1221 (type event-key event-key)
1222 (clx-values function))
1223 ;; Accessor for a handler sequence
1224 (elt handlers (position event-key *event-key-vector* :test #'eq)))
1225
1226 (defun set-event-handler (handlers event-key handler)
1227 (declare (type sequence handlers)
1228 (type event-key event-key)
1229 (type function handler)
1230 (clx-values handler))
1231 (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler))
1232
1233 (defsetf event-handler set-event-handler)
1234
1235 ;;
1236 ;; EVENT-CASE
1237 ;;
1238
1239 (defmacro event-case ((&rest args) &body clauses)
1240 ;; If force-output-p is true, first invokes display-force-output. Executes the
1241 ;; matching clause for each queued event until a clause returns non-nil, and that
1242 ;; returned object is then returned by event-case. If peek-p is true, then the
1243 ;; event is not removed from the queue. If discard-p is true, then events for
1244 ;; which the clause returns nil are removed from the queue, otherwise they are left
1245 ;; in place. Hangs until non-nil is generated for some event, or for the specified
1246 ;; timeout (in seconds, if given); however, it is acceptable for an implementation
1247 ;; to wait only once on network data, and therefore timeout prematurely. Returns
1248 ;; nil on timeout. In each clause, event-or-events is an event-key or a list of
1249 ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
1250 ;; (but only in the last clause). The keys are not evaluated, and it is an error
1251 ;; for the same key to appear in more than one clause. Args is the list of event
1252 ;; components of interest; corresponding values (if any) are bound to variables
1253 ;; with these names (i.e., the args are variable names, not keywords, the keywords
1254 ;; are derived from the variable names). An arg can also be a (keyword var) form,
1255 ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is
1256 ;; equivalent to having one that returns nil.
1257 (declare (arglist (display &key timeout peek-p discard-p (force-output-p t))
1258 (event-or-events ((&rest args) |...|) &body body) |...|))
1259 ;; Event-case is just event-cond with the whole body in the test-form
1260 `(event-cond ,args
1261 ,@(mapcar
1262 #'(lambda (clause)
1263 `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
1264 clauses)))
1265
1266 ;;
1267 ;; EVENT-COND
1268 ;;
1269
1270 (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
1271 &body clauses)
1272 ;; The clauses of event-cond are of the form:
1273 ;; (event-or-events binding-list test-form . body-forms)
1274 ;;
1275 ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they
1276 ;; need not be typed as keywords) or the symbol t
1277 ;; or otherwise (but only in the last clause). If
1278 ;; no t/otherwise clause appears, it is equivalent
1279 ;; to having one that returns nil. The keys are
1280 ;; not evaluated, and it is an error for the same
1281 ;; key to appear in more than one clause.
1282 ;;
1283 ;; BINDING-LIST The list of event components of interest.
1284 ;; corresponding values (if any) are bound to
1285 ;; variables with these names (i.e., the binding-list
1286 ;; has variable names, not keywords, the keywords are
1287 ;; derived from the variable names). An arg can also
1288 ;; be a (keyword var) form, as for keyword args in a
1289 ;; lambda list.
1290 ;;
1291 ;; The matching TEST-FORM for each queued event is executed until a
1292 ;; clause's test-form returns non-nil. Then the BODY-FORMS are
1293 ;; evaluated, returning the (possibly multiple) values of the last
1294 ;; form from event-cond. If there are no body-forms then, if the
1295 ;; test-form is non-nil, the value of the test-form is returned as a
1296 ;; single value.
1297 ;;
1298 ;; Options:
1299 ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no
1300 ;; input is pending.
1301 ;;
1302 ;; PEEK-P When true, then the event is not removed from the queue.
1303 ;;
1304 ;; DISCARD-P When true, then events for which the clause returns nil
1305 ;; are removed from the queue, otherwise they are left in place.
1306 ;;
1307 ;; TIMEOUT If NIL, hang until non-nil is generated for some event's
1308 ;; test-form. Otherwise return NIL after TIMEOUT seconds have
1309 ;; elapsed.
1310 ;;
1311 (declare (arglist (display &key timeout peek-p discard-p force-output-p)
1312 (event-or-events (&rest args) test-form &body body) |...|))
1313 (let ((event (gensym))
1314 (disp (gensym))
1315 (peek (gensym)))
1316 `(let ((,disp ,display)
1317 (,peek ,peek-p))
1318 (declare (type display ,disp))
1319 (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
1320 (event-dispatch (,disp ,event ,peek) ,@clauses)))))
1321
1322 (defun get-event-code (event)
1323 ;; Returns the event code given an event-key
1324 (declare (type event-key event))
1325 (declare (clx-values card8))
1326 (or (get event 'event-code)
1327 (x-type-error event 'event-key)))
1328
1329 (defun universal-event-get-macro (display event-key variable)
1330 (getf
1331 `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
1332 (the card8 (logand 127 (read-card8 0))) :send-event-p
1333 (logbitp 7 (read-card8 0)))
1334 variable))
1335
1336 (defmacro event-dispatch ((display event peek-p) &body clauses)
1337 ;; Helper macro for event-case
1338 ;; CLAUSES are of the form:
1339 ;; (event-or-events binding-list test-form . body-forms)
1340 (let ((event-key (gensym))
1341 (all-events (make-array +max-events+ :element-type 'bit :initial-element 0)))
1342 `(reading-event (,event)
1343 (let ((,event-key (svref *event-key-vector* (event-code ,event))))
1344 (case ,event-key
1345 ,@(mapcar
1346 #'(lambda (clause) ; Translate event-cond clause to case clause
1347 (let* ((events (first clause))
1348 (arglist (second clause))
1349 (test-form (third clause))
1350 (body-forms (cdddr clause)))
1351 (flet ((event-clause (display peek-p first-form rest-of-forms)
1352 (if rest-of-forms
1353 `(when ,first-form
1354 (unless ,peek-p (discard-current-event ,display))
1355 (return (progn ,@rest-of-forms)))
1356 ;; No body forms, return the result of the test form
1357 (let ((result (gensym)))
1358 `(let ((,result ,first-form))
1359 (when ,result
1360 (unless ,peek-p (discard-current-event ,display))
1361 (return ,result)))))))
1362
1363 (if (member events '(otherwise t))
1364 ;; code for OTHERWISE clause.
1365 ;; Find all events NOT used by other clauses
1366 (let ((keys (do ((i 0 (1+ i))
1367 (key nil)
1368 (result nil))
1369 ((>= i +max-events+) result)
1370 (setq key (svref *event-key-vector* i))
1371 (when (and key (zerop (aref all-events i)))
1372 (push key result)))))
1373 `(otherwise
1374 (binding-event-values
1375 (,display ,event-key ,(or keys :universal) ,@arglist)
1376 ,(event-clause display peek-p test-form body-forms))))
1377
1378 ;; Code for normal clauses
1379 (let (true-events) ;; canonicalize event-names
1380 (if (consp events)
1381 (progn
1382 (setq true-events (mapcar #'canonicalize-event-name events))
1383 (dolist (event true-events)
1384 (setf (aref all-events (get-event-code event)) 1)))
1385 (setf true-events (canonicalize-event-name events)
1386 (aref all-events (get-event-code true-events)) 1))
1387 `(,true-events
1388 (binding-event-values
1389 (,display ,event-key ,true-events ,@arglist)
1390 ,(event-clause display peek-p test-form body-forms))))))))
1391 clauses))))))
1392
1393 (defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
1394 ;; Execute BODY with the variables in VALUE-LIST bound to components of the
1395 ;; EVENT-KEYS events.
1396 (unless (consp event-keys) (setq event-keys (list event-keys)))
1397 (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
1398 (var-symbol (var) (if (consp var) (second var) var)))
1399 ;; VARS is an alist of:
1400 ;; (component-key ((event-key event-key ...) . extraction-code)
1401 ;; ((event-key event-key ...) . extraction-code) ...)
1402 ;; There should probably be accessor macros for this, instead of things like cdadr.
1403 (let ((vars (mapcar #'list value-list))
1404 (multiple-p nil))
1405 ;; Fill in the VARS alist with event-keys and extraction-code
1406 (do ((keys event-keys (cdr keys))
1407 (temp nil))
1408 ((endp keys))
1409 (let* ((key (car keys))
1410 (binder (case key
1411 (:universal #'universal-event-get-macro)
1412 (otherwise (svref *event-macro-vector* (get-event-code key))))))
1413 (dolist (var vars)
1414 (let ((code (funcall binder display event-key (var-key (car var)))))
1415 (unless code (warn "~a isn't a component of the ~s event"
1416 (var-key (car var)) key))
1417 (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
1418 (push key (caar temp))
1419 (push `((,key) . ,code) (cdr var)))))))
1420 ;; Bind all the values
1421 `(let ,(mapcar #'(lambda (var)
1422 (if (cddr var) ;; if more than one binding form
1423 (progn (setq multiple-p t)
1424 (var-symbol (car var)))
1425 (list (var-symbol (car var)) (cdadr var))))
1426 vars)
1427 ;; When some values come from different places, generate code to set them
1428 ,(when multiple-p
1429 `(case ,event-key
1430 ,@(do ((keys event-keys (cdr keys))
1431 (clauses nil) ;; alist of (event-keys bindings)
1432 (clause nil nil)
1433 (temp))
1434 ((endp keys)
1435 (dolist (clause clauses)
1436 (unless (cdar clause) ;; Atomize single element lists
1437 (setf (car clause) (caar clause))))
1438 clauses)
1439 ;; Gather up all the bindings associated with (car keys)
1440 (dolist (var vars)
1441 (when (cddr var) ;; when more than one binding form
1442 (dolist (events (cdr var))
1443 (when (member (car keys) (car events))
1444 ;; Optimize for event-window being the same as some other binding
1445 (if (setq temp (member (cdr events) clause
1446 :key #'caddr
1447 :test #'equal))
1448 (setq clause
1449 (nconc clause `((setq ,(car var) ,(second (car temp))))))
1450 (push `(setq ,(car var) ,(cdr events)) clause))))))
1451 ;; Merge bindings for (car keys) with other bindings
1452 (when clause
1453 (if (setq temp (member clause clauses :key #'cdr :test #'equal))
1454 (push (car keys) (caar temp))
1455 (push `((,(car keys)) . ,clause) clauses))))))
1456 ,@body))))
1457
1458
1459 ;;;-----------------------------------------------------------------------------
1460 ;;; Error Handling
1461 ;;;-----------------------------------------------------------------------------
1462
1463 (eval-when (:compile-toplevel :load-toplevel :execute)
1464 (defparameter
1465 *xerror-vector*
1466 '#(unknown-error
1467 request-error ; 1 bad request code
1468 value-error ; 2 integer parameter out of range
1469 window-error ; 3 parameter not a Window
1470 pixmap-error ; 4 parameter not a Pixmap
1471 atom-error ; 5 parameter not an Atom
1472 cursor-error ; 6 parameter not a Cursor
1473 font-error ; 7 parameter not a Font
1474 match-error ; 8 parameter mismatch
1475 drawable-error ; 9 parameter not a Pixmap or Window
1476 access-error ; 10 attempt to access private resource"
1477 alloc-error ; 11 insufficient resources
1478 colormap-error ; 12 no such colormap
1479 gcontext-error ; 13 parameter not a GContext
1480 id-choice-error ; 14 invalid resource ID for this connection
1481 name-error ; 15 font or color name does not exist
1482 length-error ; 16 request length incorrect;
1483 ; internal Xlib error
1484 implementation-error ; 17 server is defective
1485 ))
1486 )
1487
1488 (defun make-error (display event asynchronous)
1489 (declare (type display display)
1490 (type reply-buffer event)
1491 (type generalized-boolean asynchronous))
1492 (reading-event (event)
1493 (let* ((error-code (read-card8 1))
1494 (error-key (get-error-key display error-code))
1495 (error-decode-function (get error-key 'error-decode-function))
1496 (params (funcall error-decode-function display event)))
1497 (list* error-code error-key
1498 :asynchronous asynchronous :current-sequence (display-request-number display)
1499 params))))
1500
1501 (defun report-error (display error-code error-key &rest params)
1502 (declare (type display display)
1503 (dynamic-extent params))
1504 ;; All errors (synchronous and asynchronous) are processed by calling
1505 ;; an error handler in the display. The handler is called with the display
1506 ;; as the first argument and the error-key as its second argument. If handler is
1507 ;; an array it is expected to contain handler functions specific to
1508 ;; each error; the error code is used to index the array, fetching the
1509 ;; appropriate handler. Any results returned by the handler are ignored;;
1510 ;; it is assumed the handler either takes care of the error completely,
1511 ;; or else signals. For all core errors, additional keyword/value argument
1512 ;; pairs are:
1513 ;; :major integer
1514 ;; :minor integer
1515 ;; :sequence integer
1516 ;; :current-sequence integer
1517 ;; :asynchronous (member t nil)
1518 ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
1519 ;; errors another pair is:
1520 ;; :resource-id integer
1521 ;; For :atom errors, another pair is:
1522 ;; :atom-id integer
1523 ;; For :value errors, another pair is:
1524 ;; :value integer
1525 (let* ((handler (display-error-handler display))
1526 (handler-function
1527 (if (type? handler 'sequence)
1528 (elt handler error-code)
1529 handler)))
1530 (apply handler-function display error-key params)))
1531
1532 (defun request-name (code &optional display)
1533 (if (< code (length *request-names*))
1534 (svref *request-names* code)
1535 (dolist (extension (and display (display-extension-alist display)) "unknown")
1536 (when (= code (second extension))
1537 (return (first extension))))))
1538
1539 #-(or clx-ansi-common-lisp excl lcl3.0 CMU)
1540 (define-condition request-error (x-error)
1541 ((display :reader request-error-display)
1542 (error-key :reader request-error-error-key)
1543 (major :reader request-error-major)
1544 (minor :reader request-error-minor)
1545 (sequence :reader request-error-sequence)
1546 (current-sequence :reader request-error-current-sequence)
1547 (asynchronous :reader request-error-asynchronous))
1548 (:report report-request-error))
1549
1550 (defun report-request-error (condition stream)
1551 (let ((error-key (request-error-error-key condition))
1552 (asynchronous (request-error-asynchronous condition))
1553 (major (request-error-major condition))
1554 (minor (request-error-minor condition))
1555 (sequence (request-error-sequence condition))
1556 (current-sequence (request-error-current-sequence condition)))
1557 (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
1558 asynchronous error-key (= sequence current-sequence)
1559 sequence current-sequence major minor
1560 (request-name major (request-error-display condition)))))
1561
1562 ;; Since the :report arg is evaluated as (function report-request-error) the
1563 ;; define-condition must come after the function definition.
1564 #+(or clx-ansi-common-lisp excl lcl3.0 CMU)
1565 (define-condition request-error (x-error)
1566 ((display :reader request-error-display :initarg :display)
1567 (error-key :reader request-error-error-key :initarg :error-key)
1568 (major :reader request-error-major :initarg :major)
1569 (minor :reader request-error-minor :initarg :minor)
1570 (sequence :reader request-error-sequence :initarg :sequence)
1571 (current-sequence :reader request-error-current-sequence :initarg :current-sequence)
1572 (asynchronous :reader request-error-asynchronous :initarg :asynchronous))
1573 (:report report-request-error))
1574
1575 (define-condition resource-error (request-error)
1576 ((resource-id :reader resource-error-resource-id :initarg :resource-id))
1577 (:report
1578 (lambda (condition stream)
1579 (report-request-error condition stream)
1580 (format stream " ID #x~x" (resource-error-resource-id condition)))))
1581
1582 (define-condition unknown-error (request-error)
1583 ((error-code :reader unknown-error-error-code :initarg :error-code))
1584 (:report
1585 (lambda (condition stream)
1586 (report-request-error condition stream)
1587 (format stream " Error Code ~d." (unknown-error-error-code condition)))))
1588
1589 (define-condition access-error (request-error) ())
1590
1591 (define-condition alloc-error (request-error) ())
1592
1593 (define-condition atom-error (request-error)
1594 ((atom-id :reader atom-error-atom-id :initarg :atom-id))
1595 (:report
1596 (lambda (condition stream)
1597 (report-request-error condition stream)
1598 (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))
1599
1600 (define-condition colormap-error (resource-error) ())
1601
1602 (define-condition cursor-error (resource-error) ())
1603
1604 (define-condition drawable-error (resource-error) ())
1605
1606 (define-condition font-error (resource-error) ())
1607
1608 (define-condition gcontext-error (resource-error) ())
1609
1610 (define-condition id-choice-error (resource-error) ())
1611
1612 (define-condition illegal-request-error (request-error) ())
1613
1614 (define-condition length-error (request-error) ())
1615
1616 (define-condition match-error (request-error) ())
1617
1618 (define-condition name-error (request-error) ())
1619
1620 (define-condition pixmap-error (resource-error) ())
1621
1622 (define-condition value-error (request-error)
1623 ((value :reader value-error-value :initarg :value))
1624 (:report
1625 (lambda (condition stream)
1626 (report-request-error condition stream)
1627 (format stream " Value ~d." (value-error-value condition)))))
1628
1629 (define-condition window-error (resource-error)())
1630
1631 (define-condition implementation-error (request-error) ())
1632
1633 ;;-----------------------------------------------------------------------------
1634 ;; Internal error conditions signaled by CLX
1635
1636 (define-condition x-type-error (type-error x-error)
1637 ((type-string :reader x-type-error-type-string :initarg :type-string))
1638 (:report
1639 (lambda (condition stream)
1640 (format stream "~s isn't a ~a"
1641 (type-error-datum condition)
1642 (or (x-type-error-type-string condition)
1643 (type-error-expected-type condition))))))
1644
1645 (define-condition closed-display (x-error)
1646 ((display :reader closed-display-display :initarg :display))
1647 (:report
1648 (lambda (condition stream)
1649 (format stream "Attempt to use closed display ~s"
1650 (closed-display-display condition)))))
1651
1652 (define-condition lookup-error (x-error)
1653 ((id :reader lookup-error-id :initarg :id)
1654 (display :reader lookup-error-display :initarg :display)
1655 (type :reader lookup-error-type :initarg :type)
1656 (object :reader lookup-error-object :initarg :object))
1657 (:report
1658 (lambda (condition stream)
1659 (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
1660 (lookup-error-id condition)
1661 (lookup-error-display condition)
1662 (lookup-error-type condition)
1663 (lookup-error-object condition)))))
1664
1665 (define-condition connection-failure (x-error)
1666 ((major-version :reader connection-failure-major-version :initarg :major-version)
1667 (minor-version :reader connection-failure-minor-version :initarg :minor-version)
1668 (host :reader connection-failure-host :initarg :host)
1669 (display :reader connection-failure-display :initarg :display)
1670 (reason :reader connection-failure-reason :initarg :reason))
1671 (:report
1672 (lambda (condition stream)
1673 (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
1674 (connection-failure-major-version condition)
1675 (connection-failure-minor-version condition)
1676 (connection-failure-host condition)
1677 (connection-failure-display condition)
1678 (connection-failure-reason condition)))))
1679
1680 (define-condition reply-length-error (x-error)
1681 ((reply-length :reader reply-length-error-reply-length :initarg :reply-length)
1682 (expected-length :reader reply-length-error-expected-length :initarg :expected-length)
1683 (display :reader reply-length-error-display :initarg :display))
1684 (:report
1685 (lambda (condition stream)
1686 (format stream "Reply length was ~d when ~d words were expected for display ~s"
1687 (reply-length-error-reply-length condition)
1688 (reply-length-error-expected-length condition)
1689 (reply-length-error-display condition)))))
1690
1691 (define-condition reply-timeout (x-error)
1692 ((timeout :reader reply-timeout-timeout :initarg :timeout)
1693 (display :reader reply-timeout-display :initarg :display))
1694 (:report
1695 (lambda (condition stream)
1696 (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
1697 (reply-timeout-timeout condition)
1698 (reply-timeout-display condition)))))
1699
1700 (define-condition sequence-error (x-error)
1701 ((display :reader sequence-error-display :initarg :display)
1702 (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence)
1703 (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence))
1704 (:report
1705 (lambda (condition stream)
1706 (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d"
1707 (sequence-error-display condition)
1708 (sequence-error-req-sequence condition)
1709 (sequence-error-msg-sequence condition)))))
1710
1711 (define-condition unexpected-reply (x-error)
1712 ((display :reader unexpected-reply-display :initarg :display)
1713 (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence)
1714 (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence)
1715 (length :reader unexpected-reply-length :initarg :length))
1716 (:report
1717 (lambda (condition stream)
1718 (format stream "Display ~s received a server reply when none was expected.~@
1719 Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
1720 (unexpected-reply-display condition)
1721 (unexpected-reply-req-sequence condition)
1722 (unexpected-reply-msg-sequence condition)
1723 (unexpected-reply-length condition)))))
1724
1725 (define-condition missing-parameter (x-error)
1726 ((parameter :reader missing-parameter-parameter :initarg :parameter))
1727 (:report
1728 (lambda (condition stream)
1729 (let ((parm (missing-parameter-parameter condition)))
1730 (if (consp parm)
1731 (format stream "One or more of the required parameters ~a is missing."
1732 parm)
1733 (format stream "Required parameter ~a is missing or null." parm))))))
1734
1735 ;; This can be signalled anywhere a pseudo font access fails.
1736 (define-condition invalid-font (x-error)
1737 ((font :reader invalid-font-font :initarg :font))
1738 (:report
1739 (lambda (condition stream)
1740 (format stream "Can't access font ~s" (invalid-font-font condition)))))
1741
1742 (define-condition device-busy (x-error)
1743 ((display :reader device-busy-display :initarg :display))
1744 (:report
1745 (lambda (condition stream)
1746 (format stream "Device busy for display ~s"
1747 (device-busy-display condition)))))
1748
1749 (define-condition unimplemented-event (x-error)
1750 ((display :reader unimplemented-event-display :initarg :display)
1751 (event-code :reader unimplemented-event-event-code :initarg :event-code))
1752 (:report
1753 (lambda (condition stream)
1754 (format stream "Event code ~d not implemented for display ~s"
1755 (unimplemented-event-event-code condition)
1756 (unimplemented-event-display condition)))))
1757
1758 (define-condition undefined-event (x-error)
1759 ((display :reader undefined-event-display :initarg :display)
1760 (event-name :reader undefined-event-event-name :initarg :event-name))
1761 (:report
1762 (lambda (condition stream)
1763 (format stream "Event code ~d undefined for display ~s"
1764 (undefined-event-event-name condition)
1765 (undefined-event-display condition)))))
1766
1767 (define-condition absent-extension (x-error)
1768 ((name :reader absent-extension-name :initarg :name)
1769 (display :reader absent-extension-display :initarg :display))
1770 (:report
1771 (lambda (condition stream)
1772 (format stream "Extension ~a isn't defined for display ~s"
1773 (absent-extension-name condition)
1774 (absent-extension-display condition)))))
1775
1776 (define-condition inconsistent-parameters (x-error)
1777 ((parameters :reader inconsistent-parameters-parameters :initarg :parameters))
1778 (:report
1779 (lambda (condition stream)
1780 (format stream "inconsistent-parameters:~{ ~s~}"
1781 (inconsistent-parameters-parameters condition)))))
1782
1783 (define-condition resource-ids-exhausted (x-error)
1784 ()
1785 (:report
1786 (lambda (condition stream)
1787 (declare (ignore condition))
1788 (format stream "All X resource IDs are in use."))))
1789
1790 (defun get-error-key (display error-code)
1791 (declare (type display display)
1792 (type array-index error-code))
1793 ;; Return the error-key associated with error-code
1794 (if (< error-code (length *xerror-vector*))
1795 (svref *xerror-vector* error-code)
1796 ;; Search the extensions for the error
1797 (dolist (entry (display-extension-alist display) 'unknown-error)
1798 (let* ((event-name (first entry))
1799 (first-error (fourth entry))
1800 (errors (third (assoc event-name *extensions*))))
1801 (declare (type keyword event-name)
1802 (type array-index first-error)
1803 (type list errors))
1804 (when (and errors
1805 (index<= first-error error-code
1806 (index+ first-error (index- (length errors) 1))))
1807 (return (nth (index- error-code first-error) errors)))))))
1808
1809 (defmacro define-error (error-key function)
1810 ;; Associate a function with ERROR-KEY which will be called with
1811 ;; parameters DISPLAY and REPLY-BUFFER and
1812 ;; returns a plist of keyword/value pairs which will be passed on
1813 ;; to the error handler. A compiler warning is printed when
1814 ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION.
1815 ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
1816 ;; macros for getting error fields. See DECODE-CORE-ERROR for
1817 ;; an example.
1818 (declare (type symbol error-key)
1819 (type (or symbol list) function))
1820 ;; First ensure the name is for a declared extension
1821 (unless (or (find error-key *xerror-vector*)
1822 (dolist (extension *extensions*)
1823 (when (member error-key (third extension))
1824 (return t))))
1825 (x-type-error error-key 'error-key))
1826 `(setf (get ',error-key 'error-decode-function) (function ,function)))
1827
1828 ;; All core errors use this, so we make it available to extensions.
1829 (defun decode-core-error (display event &optional arg)
1830 ;; All core errors have the following keyword/argument pairs:
1831 ;; :major integer
1832 ;; :minor integer
1833 ;; :sequence integer
1834 ;; In addition, many have an additional argument that comes from the
1835 ;; same place in the event, but is named differently. When the ARG
1836 ;; argument is specified, the keyword ARG with card32 value starting
1837 ;; at byte 4 of the event is returned with the other keyword/argument
1838 ;; pairs.
1839 (declare (type display display)
1840 (type reply-buffer event)
1841 (type (or null keyword) arg))
1842 (declare (clx-values keyword/arg-plist))
1843 display
1844 (reading-event (event)
1845 (let* ((sequence (read-card16 2))
1846 (minor-code (read-card16 8))
1847 (major-code (read-card8 10))
1848 (result (list :major major-code
1849 :minor minor-code
1850 :sequence sequence)))
1851 (when arg
1852 (setq result (list* arg (read-card32 4) result)))
1853 result)))
1854
1855 (defun decode-resource-error (display event)
1856 (decode-core-error display event :resource-id))
1857
1858 (define-error unknown-error
1859 (lambda (display event)
1860 (list* :error-code (aref (reply-ibuf8 event) 1)
1861 (decode-core-error display event))))
1862
1863 (define-error request-error decode-core-error) ; 1 bad request code
1864
1865 (define-error value-error ; 2 integer parameter out of range
1866 (lambda (display event)
1867 (decode-core-error display event :value)))
1868
1869 (define-error window-error decode-resource-error) ; 3 parameter not a Window
1870
1871 (define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap
1872
1873 (define-error atom-error ; 5 parameter not an Atom
1874 (lambda (display event)
1875 (decode-core-error display event :atom-id)))
1876
1877 (define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor
1878
1879 (define-error font-error decode-resource-error) ; 7 parameter not a Font
1880
1881 (define-error match-error decode-core-error) ; 8 parameter mismatch
1882
1883 (define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window
1884
1885 (define-error access-error decode-core-error) ; 10 attempt to access private resource"
1886
1887 (define-error alloc-error decode-core-error) ; 11 insufficient resources
1888
1889 (define-error colormap-error decode-resource-error) ; 12 no such colormap
1890
1891 (define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext
1892
1893 (define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection
1894
1895 (define-error name-error decode-core-error) ; 15 font or color name does not exist
1896
1897 (define-error length-error decode-core-error) ; 16 request length incorrect;
1898 ; internal Xlib error
1899
1900 (define-error implementation-error decode-core-error) ; 17 server is defective

  ViewVC Help
Powered by ViewVC 1.1.5