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

Contents of /src/clx/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5