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

Contents of /src/clx/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5