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

Contents of /src/clx/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.2 - (show annotations) (vendor branch)
Wed May 15 15:44:52 1991 UTC (22 years, 11 months ago) by ram
Changes since 1.1.1.1: +11 -1 lines
.../systems-work/clx/input.lisp, 25-May-90 15:08:42, Edit by Chiles.
  Modified EVENT-LISTEN according to Chris Lindblad's patch to make it
  correctly count how many events are pending when called from within
  an EVENT-CASE branch.

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

  ViewVC Help
Powered by ViewVC 1.1.5