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

Contents of /src/clx/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11.14.1 - (show annotations)
Wed Jun 17 15:46:26 2009 UTC (4 years, 10 months ago) by rtoy
Branch: portable-clx-branch
CVS Tags: portable-clx-import-2009-06-16
Changes since 1.11: +7 -3 lines
Import portable clx version from Christophe Rhodes darcs repository as
of 2009-06-16.

This is an exact copy of the code.  It is intended updates of
portable-clx go on the portable-clx-branch and should be merged to the
main branch as needed.  This should make it easier to do any
CMUCL-specific changes that aren't in portable-clx.

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

  ViewVC Help
Powered by ViewVC 1.1.5