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

Contents of /src/clx/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2.1.2 - (hide annotations) (vendor branch)
Sat Nov 9 14:53:38 1991 UTC (22 years, 5 months ago) by ram
Changes since 1.2.1.1: +3 -3 lines
Tweaked define-conditions not to be too CLOS-ish.
1 ram 1.2.1.1 ;;; -*- Mode: Lisp; Package: Xlib; Log: clx.log -*-
2 ram 1.1
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 (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 ram 1.2 (declare (values (or null card8)))
138 ram 1.1 (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 (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 ram 1.2 ;; Clear pointers to help the Garbage Collector
251     (setf (pending-command-process pending-command) nil)
252 ram 1.1 ;; 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 ram 1.2 #+clx-ansi-common-lisp
389     (dynamic-extent predicate)
390     #+(and lispm (not clx-ansi-common-lisp))
391     (sys:downward-funarg predicate))
392 ram 1.1 (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 ram 1.2 #+clx-ansi-common-lisp
420     (dynamic-extent predicate)
421     #+(and lispm (not clx-ansi-common-lisp))
422     (sys:downward-funarg predicate))
423 ram 1.1 (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     (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 ram 1.2 (queue (if current-event
569     (reply-next (the reply-buffer current-event))
570     (display-event-queue-head display))))
571 ram 1.1 (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 ram 1.2 (threaded-length queue reply-next reply-buffer))
577 ram 1.1 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 ram 1.2 (threaded-length (display-new-events display)
585 ram 1.1 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)
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     (subst display '%buffer
749     (getf `(:display (the display ,display)
750     :event-key (the keyword ,event-key)
751     :event-code (the card8 (logand #x7f (read-card8 0)))
752     :send-event-p (the boolean (logbitp 7 (read-card8 0)))
753     ,@',(mapcar #'macroexpand 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 ram 1.2 #+clx-ansi-common-lisp
761     (dynamic-extent handler)
762     #+(and lispm (not clx-ansi-common-lisp))
763     (sys:downward-funarg handler))
764 ram 1.1 (reading-event (event :display display :sizes (8 16 ,@get-sizes))
765     (funcall handler
766     :display display
767     :event-key (svref *event-key-vector* (event-code event))
768     :event-code (logand #x7f (card8-get 0))
769     :send-event-p (logbitp 7 (card8-get 0))
770     ,@get-code)))
771    
772     (defun ,put-function (display &key ,@(setq keywords (nreverse keywords))
773     &allow-other-keys)
774     (declare (type display display))
775     ,(when (member 'sequence keywords)
776     `(unless sequence (setq sequence (display-request-number display))))
777     (with-buffer-output (display :sizes ,put-sizes
778     :index (index+ (buffer-boffset display) 12))
779     ,@put-code))
780    
781     ,@(mapcar #'(lambda (name)
782     (allocate-extension-event-code name)
783     `(let ((event-code (or (get ',name 'event-code)
784     (allocate-extension-event-code ',name))))
785     (setf (svref *event-macro-vector* event-code)
786     (function ,get-macro))
787     (setf (svref *event-handler-vector* event-code)
788     (function ,get-function))
789     (setf (svref *event-send-vector* event-code)
790     (function ,put-function))))
791     event-codes)
792     ',name)))))
793    
794     (defun check-consistency (names &rest args)
795     ;; Ensure all args are nil or have the same value.
796     ;; Returns the consistent non-nil value.
797     (let ((value (car args)))
798     (dolist (arg (cdr args))
799     (if value
800     (when (and arg (not (eq arg value)))
801     (x-error 'inconsistent-parameters
802     :parameters (mapcan #'list names args)))
803     (setq value arg)))
804     value))
805    
806     (declare-event (:key-press :key-release :button-press :button-release)
807     ;; for key-press and key-release, code is the keycode
808     ;; for button-press and button-release, code is the button number
809     (data code)
810     (card16 sequence)
811 ram 1.2 ((or null card32) time)
812 ram 1.1 (window root (window event-window))
813     ((or null window) child)
814     (int16 root-x root-y x y)
815     (card16 state)
816     (boolean same-screen-p)
817     )
818    
819     (declare-event :motion-notify
820     ((data boolean) hint-p)
821     (card16 sequence)
822 ram 1.2 ((or null card32) time)
823 ram 1.1 (window root (window event-window))
824     ((or null window) child)
825     (int16 root-x root-y x y)
826     (card16 state)
827     (boolean same-screen-p))
828    
829     (declare-event (:enter-notify :leave-notify)
830     ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual)) kind)
831     (card16 sequence)
832 ram 1.2 ((or null card32) time)
833 ram 1.1 (window root (window event-window))
834     ((or null window) child)
835     (int16 root-x root-y x y)
836     (card16 state)
837     ((member8 :normal :grab :ungrab) mode)
838     ((bit 0) focus-p)
839     ((bit 1) same-screen-p))
840    
841     (declare-event (:focus-in :focus-out)
842     ((data (member8 :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
843     :pointer :pointer-root :none))
844     kind)
845     (card16 sequence)
846     (window (window event-window))
847     ((member8 :normal :while-grabbed :grab :ungrab) mode))
848    
849     (declare-event :keymap-notify
850     ((bit-vector256 0) keymap))
851    
852     (declare-event :exposure
853     (card16 sequence)
854     (window (window event-window))
855     (card16 x y width height count))
856    
857     (declare-event :graphics-exposure
858     (card16 sequence)
859     (drawable (drawable event-window))
860     (card16 x y width height)
861     (card16 minor) ;; Minor opcode
862     (card16 count)
863     (card8 major))
864    
865     (declare-event :no-exposure
866     (card16 sequence)
867     (drawable (drawable event-window))
868     (card16 minor)
869     (card8 major))
870    
871     (declare-event :visibility-notify
872     (card16 sequence)
873     (window (window event-window))
874     ((member8 :unobscured :partially-obscured :fully-obscured) state))
875    
876     (declare-event :create-notify
877     (card16 sequence)
878     (window (parent event-window) window)
879     (int16 x y)
880     (card16 width height border-width)
881     (boolean override-redirect-p))
882    
883     (declare-event :destroy-notify
884     (card16 sequence)
885     (window event-window window))
886    
887     (declare-event :unmap-notify
888     (card16 sequence)
889     (window event-window window)
890     (boolean configure-p))
891    
892     (declare-event :map-notify
893     (card16 sequence)
894     (window event-window window)
895     (boolean override-redirect-p))
896    
897     (declare-event :map-request
898     (card16 sequence)
899     (window (parent event-window) window))
900    
901     (declare-event :reparent-notify
902     (card16 sequence)
903     (window event-window window parent)
904     (int16 x y)
905     (boolean override-redirect-p))
906    
907     (declare-event :configure-notify
908     (card16 sequence)
909     (window event-window window)
910     ((or null window) above-sibling)
911     (int16 x y)
912     (card16 width height border-width)
913     (boolean override-redirect-p))
914    
915     (declare-event :configure-request
916     ((data (member :above :below :top-if :bottom-if :opposite)) stack-mode)
917     (card16 sequence)
918     (window (parent event-window) window)
919     ((or null window) above-sibling)
920     (int16 x y)
921     (card16 width height border-width value-mask))
922    
923     (declare-event :gravity-notify
924     (card16 sequence)
925     (window event-window window)
926     (int16 x y))
927    
928     (declare-event :resize-request
929     (card16 sequence)
930     (window (window event-window))
931     (card16 width height))
932    
933     (declare-event :circulate-notify
934     (card16 sequence)
935     (window event-window window parent)
936     ((member16 :top :bottom) place))
937    
938     (declare-event :circulate-request
939     (card16 sequence)
940     (window (parent event-window) window)
941     (pad16 1 2)
942     ((member16 :top :bottom) place))
943    
944     (declare-event :property-notify
945     (card16 sequence)
946     (window (window event-window))
947     (keyword atom) ;; keyword
948 ram 1.2 ((or null card32) time)
949 ram 1.1 ((member16 :new-value :deleted) state))
950    
951     (declare-event :selection-clear
952     (card16 sequence)
953 ram 1.2 ((or null card32) time)
954 ram 1.1 (window (window event-window))
955     (keyword selection) ;; keyword
956     )
957    
958     (declare-event :selection-request
959     (card16 sequence)
960 ram 1.2 ((or null card32) time)
961 ram 1.1 (window (window event-window) requestor)
962     (keyword selection target)
963     ((or null keyword) property)
964     )
965    
966     (declare-event :selection-notify
967     (card16 sequence)
968 ram 1.2 ((or null card32) time)
969 ram 1.1 (window (window event-window))
970     (keyword selection target)
971     ((or null keyword) property)
972     )
973    
974     (declare-event :colormap-notify
975     (card16 sequence)
976     (window (window event-window))
977     ((or null colormap) colormap)
978     (boolean new-p installed-p))
979    
980     (declare-event :client-message
981     (data format)
982     (card16 sequence)
983     (window (window event-window))
984     (keyword type)
985     ((client-message-sequence format) data))
986    
987     (declare-event :mapping-notify
988     (card16 sequence)
989     ((member8 :modifier :keyboard :pointer) request)
990     (card8 start) ;; first key-code
991     (card8 count))
992    
993    
994     ;;
995     ;; EVENT-LOOP
996     ;;
997    
998     (defun event-loop-setup (display)
999     (declare (type display display)
1000     (values progv-vars progv-vals
1001     current-event-symbol current-event-discarded-p-symbol))
1002     (let* ((progv-vars (display-current-event-symbol display))
1003     (current-event-symbol (first progv-vars))
1004     (current-event-discarded-p-symbol (second progv-vars)))
1005     (declare (type list progv-vars)
1006     (type symbol current-event-symbol current-event-discarded-p-symbol))
1007     (values
1008     progv-vars
1009     (list (if (boundp current-event-symbol)
1010     ;; The current event is already bound, so bind it to the next
1011     ;; event.
1012     (let ((event (symbol-value current-event-symbol)))
1013     (declare (type (or null reply-buffer) event))
1014     (and event (reply-next (the reply-buffer event))))
1015     ;; The current event isn't bound, so bind it to the head of the
1016     ;; event queue.
1017     (display-event-queue-head display))
1018     nil)
1019     current-event-symbol
1020     current-event-discarded-p-symbol)))
1021    
1022     (defun event-loop-step-before (display timeout force-output-p current-event-symbol)
1023     (declare (type display display)
1024     (type (or null number) timeout)
1025     (type boolean force-output-p)
1026     (type symbol current-event-symbol)
1027     (values event eof-or-timeout))
1028     (unless (symbol-value current-event-symbol)
1029     (let ((eof-or-timeout (wait-for-event display timeout force-output-p)))
1030     (when eof-or-timeout
1031     (return-from event-loop-step-before (values nil eof-or-timeout))))
1032     (setf (symbol-value current-event-symbol) (display-new-events display)))
1033     (let ((event (symbol-value current-event-symbol)))
1034     (declare (type reply-buffer event))
1035     (with-event-queue-internal (display)
1036     (when (eq event (display-new-events display))
1037     (setf (display-new-events display) (reply-next event))))
1038     (values event nil)))
1039    
1040     (defun dequeue-event (display event)
1041     (declare (type display display)
1042     (type reply-buffer event)
1043     (values next))
1044     ;; Remove the current event from the event queue
1045     (with-event-queue-internal (display)
1046     (let ((next (reply-next event))
1047     (head (display-event-queue-head display)))
1048     (declare (type (or null reply-buffer) next head))
1049     (when (eq event (display-new-events display))
1050     (setf (display-new-events display) next))
1051     (cond ((eq event head)
1052     (threaded-dequeue (display-event-queue-head display)
1053     (display-event-queue-tail display)
1054     reply-next reply-buffer))
1055     ((null head)
1056     (setq next nil))
1057     (t
1058     (do* ((previous head current)
1059     (current (reply-next previous) (reply-next previous)))
1060     ((or (null current) (eq event current))
1061     (when (eq event current)
1062     (when (eq current (display-event-queue-tail display))
1063     (setf (display-event-queue-tail display) previous))
1064     (setf (reply-next previous) next)))
1065     (declare (type reply-buffer previous)
1066     (type (or null reply-buffer) current)))))
1067     next)))
1068    
1069     (defun event-loop-step-after
1070     (display event discard-p current-event-symbol current-event-discarded-p-symbol
1071     &optional aborted)
1072     (declare (type display display)
1073     (type reply-buffer event)
1074     (type boolean discard-p aborted)
1075     (type symbol current-event-symbol current-event-discarded-p-symbol))
1076     (when (and discard-p
1077     (not aborted)
1078     (not (symbol-value current-event-discarded-p-symbol)))
1079     (discard-current-event display))
1080     (let ((next (reply-next event)))
1081     (declare (type (or null reply-buffer) next))
1082     (when (symbol-value current-event-discarded-p-symbol)
1083     (setf (symbol-value current-event-discarded-p-symbol) nil)
1084 ram 1.2 (setq next (dequeue-event display event))
1085 ram 1.1 (deallocate-event event))
1086     (setf (symbol-value current-event-symbol) next)))
1087    
1088     (defmacro event-loop ((display event timeout force-output-p discard-p) &body body)
1089     ;; Bind EVENT to the events for DISPLAY.
1090     ;; This is the "GUTS" of process-event and event-case.
1091 ram 1.2 `(let ((.display. ,display)
1092 ram 1.1 (.timeout. ,timeout)
1093     (.force-output-p. ,force-output-p)
1094     (.discard-p. ,discard-p))
1095     (declare (type display .display.)
1096     (type (or null number) .timeout.)
1097     (type boolean .force-output-p. .discard-p.))
1098     (with-event-queue (.display. ,@(and timeout `(:timeout .timeout.)))
1099     (multiple-value-bind (.progv-vars. .progv-vals.
1100     .current-event-symbol. .current-event-discarded-p-symbol.)
1101     (event-loop-setup .display.)
1102     (declare (type list .progv-vars. .progv-vals.)
1103     (type symbol .current-event-symbol. .current-event-discarded-p-symbol.))
1104     (progv .progv-vars. .progv-vals.
1105     (loop
1106     (multiple-value-bind (.event. .eof-or-timeout.)
1107     (event-loop-step-before
1108     .display. .timeout. .force-output-p.
1109     .current-event-symbol.)
1110     (declare (type (or null reply-buffer) .event.))
1111     (when (null .event.) (return (values nil .eof-or-timeout.)))
1112     (let ((.aborted. t))
1113     (unwind-protect
1114     (progn
1115     (let ((,event .event.))
1116     (declare (type reply-buffer ,event))
1117     ,@body)
1118     (setq .aborted. nil))
1119     (event-loop-step-after
1120     .display. .event. .discard-p.
1121     .current-event-symbol. .current-event-discarded-p-symbol.
1122     .aborted.))))))))))
1123    
1124     (defun discard-current-event (display)
1125     ;; Discard the current event for DISPLAY.
1126     ;; Returns NIL when the event queue is empty, else T.
1127     ;; To ensure events aren't ignored, application code should only call
1128     ;; this when throwing out of event-case or process-next-event, or from
1129     ;; inside even-case, event-cond or process-event when :peek-p is T and
1130     ;; :discard-p is NIL.
1131     (declare (type display display)
1132     (values boolean))
1133     (let* ((symbols (display-current-event-symbol display))
1134     (event
1135     (let ((current-event-symbol (first symbols)))
1136     (declare (type symbol current-event-symbol))
1137     (when (boundp current-event-symbol)
1138     (symbol-value current-event-symbol)))))
1139     (declare (type list symbols)
1140     (type (or null reply-buffer) event))
1141     (unless (null event)
1142     ;; Set the discarded-p flag
1143     (let ((current-event-discarded-p-symbol (second symbols)))
1144     (declare (type symbol current-event-discarded-p-symbol))
1145     (when (boundp current-event-discarded-p-symbol)
1146     (setf (symbol-value current-event-discarded-p-symbol) t)))
1147     ;; Return whether the event queue is empty
1148     (not (null (reply-next (the reply-buffer event)))))))
1149    
1150     ;;
1151     ;; PROCESS-EVENT
1152     ;;
1153     (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
1154     ;; If force-output-p is true, first invokes display-force-output. Invokes handler
1155     ;; on each queued event until handler returns non-nil, and that returned object is
1156     ;; then returned by process-event. If peek-p is true, then the event is not
1157     ;; removed from the queue. If discard-p is true, then events for which handler
1158     ;; returns nil are removed from the queue, otherwise they are left in place. Hangs
1159     ;; until non-nil is generated for some event, or for the specified timeout (in
1160     ;; seconds, if given); however, it is acceptable for an implementation to wait only
1161     ;; once on network data, and therefore timeout prematurely. Returns nil on
1162     ;; timeout. If handler is a sequence, it is expected to contain handler functions
1163     ;; specific to each event class; the event code is used to index the sequence,
1164     ;; fetching the appropriate handler. Handler is called with raw resource-ids, not
1165     ;; with resource objects. The arguments to the handler are described using declare-event.
1166     ;;
1167     ;; T for peek-p means the event (for which the handler returns non-nil) is not removed
1168     ;; from the queue (it is left in place), NIL means the event is removed.
1169    
1170     (declare (type display display)
1171     (type (or null number) timeout)
1172     (type boolean peek-p discard-p force-output-p))
1173     (declare (type t handler)
1174 ram 1.2 #+clx-ansi-common-lisp
1175     (dynamic-extent handler)
1176     #+(and lispm (not clx-ansi-common-lisp))
1177     (sys:downward-funarg #+Genera * #-Genera handler))
1178 ram 1.1 (event-loop (display event timeout force-output-p discard-p)
1179     (let* ((event-code (event-code event)) ;; Event decoder defined by DECLARE-EVENT
1180     (event-decoder (and (index< event-code (length *event-handler-vector*))
1181     (svref *event-handler-vector* event-code))))
1182     (declare (type array-index event-code)
1183     (type (or null function) event-decoder))
1184     (if event-decoder
1185     (let ((event-handler (if (functionp handler)
1186     handler
1187     (and (type? handler 'sequence)
1188     (< event-code (length handler))
1189     (elt handler event-code)))))
1190     (if event-handler
1191     (let ((result (funcall event-decoder display event event-handler)))
1192     (when result
1193     (unless peek-p
1194     (discard-current-event display))
1195     (return result)))
1196     (cerror "Ignore this event"
1197     "No handler for ~s event"
1198     (svref *event-key-vector* event-code))))
1199     (cerror "Ignore this event"
1200     "Server Error: event with unknown event code ~d received."
1201     event-code)))))
1202    
1203     (defun make-event-handlers (&key (type 'array) default)
1204     (declare (type t type) ;Sequence type specifier
1205     (type function default)
1206     (values sequence)) ;Default handler for initial content
1207     ;; Makes a handler sequence suitable for process-event
1208     (make-sequence type *max-events* :initial-element default))
1209    
1210     (defun event-handler (handlers event-key)
1211     (declare (type sequence handlers)
1212     (type event-key event-key)
1213     (values function))
1214     ;; Accessor for a handler sequence
1215     (elt handlers (position event-key *event-key-vector* :test #'eq)))
1216    
1217     (defun set-event-handler (handlers event-key handler)
1218     (declare (type sequence handlers)
1219     (type event-key event-key)
1220     (type function handler)
1221     (values handler))
1222     (setf (elt handlers (position event-key *event-key-vector* :test #'eq)) handler))
1223    
1224     (defsetf event-handler set-event-handler)
1225    
1226     ;;
1227     ;; EVENT-CASE
1228     ;;
1229    
1230     (defmacro event-case ((&rest args) &body clauses)
1231     ;; If force-output-p is true, first invokes display-force-output. Executes the
1232     ;; matching clause for each queued event until a clause returns non-nil, and that
1233     ;; returned object is then returned by event-case. If peek-p is true, then the
1234     ;; event is not removed from the queue. If discard-p is true, then events for
1235     ;; which the clause returns nil are removed from the queue, otherwise they are left
1236     ;; in place. Hangs until non-nil is generated for some event, or for the specified
1237     ;; timeout (in seconds, if given); however, it is acceptable for an implementation
1238     ;; to wait only once on network data, and therefore timeout prematurely. Returns
1239     ;; nil on timeout. In each clause, event-or-events is an event-key or a list of
1240     ;; event-keys (but they need not be typed as keywords) or the symbol t or otherwise
1241     ;; (but only in the last clause). The keys are not evaluated, and it is an error
1242     ;; for the same key to appear in more than one clause. Args is the list of event
1243     ;; components of interest; corresponding values (if any) are bound to variables
1244     ;; with these names (i.e., the args are variable names, not keywords, the keywords
1245     ;; are derived from the variable names). An arg can also be a (keyword var) form,
1246     ;; as for keyword args in a lambda lists. If no t/otherwise clause appears, it is
1247     ;; equivalent to having one that returns nil.
1248     (declare (arglist (display &key timeout peek-p discard-p (force-output-p t))
1249     (event-or-events ((&rest args) |...|) &body body) |...|))
1250     ;; Event-case is just event-cond with the whole body in the test-form
1251     `(event-cond ,args
1252     ,@(mapcar
1253     #'(lambda (clause)
1254     `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
1255     clauses)))
1256    
1257     ;;
1258     ;; EVENT-COND
1259     ;;
1260    
1261     (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
1262     &body clauses)
1263     ;; The clauses of event-cond are of the form:
1264     ;; (event-or-events binding-list test-form . body-forms)
1265     ;;
1266     ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they
1267     ;; need not be typed as keywords) or the symbol t
1268     ;; or otherwise (but only in the last clause). If
1269     ;; no t/otherwise clause appears, it is equivalent
1270     ;; to having one that returns nil. The keys are
1271     ;; not evaluated, and it is an error for the same
1272     ;; key to appear in more than one clause.
1273     ;;
1274     ;; BINDING-LIST The list of event components of interest.
1275     ;; corresponding values (if any) are bound to
1276     ;; variables with these names (i.e., the binding-list
1277     ;; has variable names, not keywords, the keywords are
1278     ;; derived from the variable names). An arg can also
1279     ;; be a (keyword var) form, as for keyword args in a
1280     ;; lambda list.
1281     ;;
1282     ;; The matching TEST-FORM for each queued event is executed until a
1283     ;; clause's test-form returns non-nil. Then the BODY-FORMS are
1284     ;; evaluated, returning the (possibly multiple) values of the last
1285     ;; form from event-cond. If there are no body-forms then, if the
1286     ;; test-form is non-nil, the value of the test-form is returned as a
1287     ;; single value.
1288     ;;
1289     ;; Options:
1290     ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no
1291     ;; input is pending.
1292     ;;
1293     ;; PEEK-P When true, then the event is not removed from the queue.
1294     ;;
1295     ;; DISCARD-P When true, then events for which the clause returns nil
1296     ;; are removed from the queue, otherwise they are left in place.
1297     ;;
1298     ;; TIMEOUT If NIL, hang until non-nil is generated for some event's
1299     ;; test-form. Otherwise return NIL after TIMEOUT seconds have
1300     ;; elapsed.
1301     ;;
1302     (declare (arglist (display &key timeout peek-p discard-p force-output-p)
1303     (event-or-events (&rest args) test-form &body body) |...|))
1304     (let ((event (gensym))
1305     (disp (gensym))
1306     (peek (gensym)))
1307     `(let ((,disp ,display)
1308     (,peek ,peek-p))
1309     (declare (type display ,disp))
1310     (event-loop (,disp ,event ,timeout ,force-output-p ,discard-p)
1311     (event-dispatch (,disp ,event ,peek) ,@clauses)))))
1312    
1313     (defun get-event-code (event)
1314     ;; Returns the event code given an event-key
1315     (declare (type event-key event))
1316     (declare (values card8))
1317     (or (get event 'event-code)
1318     (x-type-error event 'event-key)))
1319    
1320     (defun universal-event-get-macro (display event-key variable)
1321     (getf
1322     `(:display (the display ,display) :event-key (the keyword ,event-key) :event-code
1323     (the card8 (logand 127 (read-card8 0))) :send-event-p
1324     (the boolean (logbitp 7 (read-card8 0))))
1325     variable))
1326    
1327     (defmacro event-dispatch ((display event peek-p) &body clauses)
1328     ;; Helper macro for event-case
1329     ;; CLAUSES are of the form:
1330     ;; (event-or-events binding-list test-form . body-forms)
1331     (let ((event-key (gensym))
1332     (all-events (make-array *max-events* :element-type 'bit :initial-element 0)))
1333     `(reading-event (,event)
1334     (let ((,event-key (svref *event-key-vector* (event-code ,event))))
1335     (case ,event-key
1336     ,@(mapcar
1337     #'(lambda (clause) ; Translate event-cond clause to case clause
1338     (let* ((events (first clause))
1339     (arglist (second clause))
1340     (test-form (third clause))
1341     (body-forms (cdddr clause)))
1342     (flet ((event-clause (display peek-p first-form rest-of-forms)
1343     (if rest-of-forms
1344     `(when ,first-form
1345     (unless ,peek-p (discard-current-event ,display))
1346     (return (progn ,@rest-of-forms)))
1347     ;; No body forms, return the result of the test form
1348     (let ((result (gensym)))
1349     `(let ((,result ,first-form))
1350     (when ,result
1351     (unless ,peek-p (discard-current-event ,display))
1352     (return ,result)))))))
1353    
1354     (if (member events '(otherwise t))
1355     ;; code for OTHERWISE clause.
1356     ;; Find all events NOT used by other clauses
1357     (let ((keys (do ((i 0 (1+ i))
1358     (key nil)
1359     (result nil))
1360     ((>= i *max-events*) result)
1361     (setq key (svref *event-key-vector* i))
1362     (when (and key (zerop (aref all-events i)))
1363     (push key result)))))
1364     `(otherwise
1365     (binding-event-values
1366     (,display ,event-key ,(or keys :universal) ,@arglist)
1367     ,(event-clause display peek-p test-form body-forms))))
1368    
1369     ;; Code for normal clauses
1370     (let (true-events) ;; canonicalize event-names
1371     (if (consp events)
1372     (progn
1373     (setq true-events (mapcar #'canonicalize-event-name events))
1374     (dolist (event true-events)
1375     (setf (aref all-events (get-event-code event)) 1)))
1376     (setf true-events (canonicalize-event-name events)
1377     (aref all-events (get-event-code true-events)) 1))
1378     `(,true-events
1379     (binding-event-values
1380     (,display ,event-key ,true-events ,@arglist)
1381     ,(event-clause display peek-p test-form body-forms))))))))
1382     clauses))))))
1383    
1384     (defmacro binding-event-values ((display event-key event-keys &rest value-list) &body body)
1385     ;; Execute BODY with the variables in VALUE-LIST bound to components of the
1386     ;; EVENT-KEYS events.
1387     (unless (consp event-keys) (setq event-keys (list event-keys)))
1388     (flet ((var-key (var) (kintern (if (consp var) (first var) var)))
1389     (var-symbol (var) (if (consp var) (second var) var)))
1390     ;; VARS is an alist of:
1391     ;; (component-key ((event-key event-key ...) . extraction-code)
1392     ;; ((event-key event-key ...) . extraction-code) ...)
1393     ;; There should probably be accessor macros for this, instead of things like cdadr.
1394     (let ((vars (mapcar #'(lambda (var) (list var)) value-list))
1395     (multiple-p nil))
1396     ;; Fill in the VARS alist with event-keys and extraction-code
1397     (do ((keys event-keys (cdr keys))
1398     (temp nil))
1399     ((endp keys))
1400     (let* ((key (car keys))
1401     (binder (case key
1402     (:universal #'universal-event-get-macro)
1403     (otherwise (svref *event-macro-vector* (get-event-code key))))))
1404     (dolist (var vars)
1405     (let ((code (funcall binder display event-key (var-key (car var)))))
1406     (unless code (warn "~a isn't a component of the ~s event"
1407     (var-key (car var)) key))
1408     (if (setq temp (member code (cdr var) :key #'cdr :test #'equal))
1409     (push key (caar temp))
1410     (push `((,key) . ,code) (cdr var)))))))
1411     ;; Bind all the values
1412     `(let ,(mapcar #'(lambda (var)
1413     (if (cddr var) ;; if more than one binding form
1414     (progn (setq multiple-p t)
1415     (var-symbol (car var)))
1416     (list (var-symbol (car var)) (cdadr var))))
1417     vars)
1418     ;; When some values come from different places, generate code to set them
1419     ,(when multiple-p
1420     `(case ,event-key
1421     ,@(do ((keys event-keys (cdr keys))
1422     (clauses nil) ;; alist of (event-keys bindings)
1423     (clause nil nil)
1424     (temp))
1425     ((endp keys)
1426     (dolist (clause clauses)
1427     (unless (cdar clause) ;; Atomize single element lists
1428     (setf (car clause) (caar clause))))
1429     clauses)
1430     ;; Gather up all the bindings associated with (car keys)
1431     (dolist (var vars)
1432     (when (cddr var) ;; when more than one binding form
1433     (dolist (events (cdr var))
1434     (when (member (car keys) (car events))
1435     ;; Optimize for event-window being the same as some other binding
1436     (if (setq temp (member (cdr events) clause
1437     :key #'caddr
1438     :test #'equal))
1439     (setq clause
1440     (nconc clause `((setq ,(car var) ,(second (car temp))))))
1441     (push `(setq ,(car var) ,(cdr events)) clause))))))
1442     ;; Merge bindings for (car keys) with other bindings
1443     (when clause
1444     (if (setq temp (member clause clauses :key #'cdr :test #'equal))
1445     (push (car keys) (caar temp))
1446     (push `((,(car keys)) . ,clause) clauses))))))
1447     ,@body))))
1448    
1449    
1450     ;;;-----------------------------------------------------------------------------
1451     ;;; Error Handling
1452     ;;;-----------------------------------------------------------------------------
1453    
1454     (eval-when (eval compile load)
1455     (defparameter
1456     *xerror-vector*
1457     '#(unknown-error
1458     request-error ; 1 bad request code
1459     value-error ; 2 integer parameter out of range
1460     window-error ; 3 parameter not a Window
1461     pixmap-error ; 4 parameter not a Pixmap
1462     atom-error ; 5 parameter not an Atom
1463     cursor-error ; 6 parameter not a Cursor
1464     font-error ; 7 parameter not a Font
1465     match-error ; 8 parameter mismatch
1466     drawable-error ; 9 parameter not a Pixmap or Window
1467     access-error ; 10 attempt to access private resource"
1468     alloc-error ; 11 insufficient resources
1469     colormap-error ; 12 no such colormap
1470     gcontext-error ; 13 parameter not a GContext
1471     id-choice-error ; 14 invalid resource ID for this connection
1472     name-error ; 15 font or color name does not exist
1473     length-error ; 16 request length incorrect;
1474     ; internal Xlib error
1475     implementation-error ; 17 server is defective
1476     ))
1477     )
1478    
1479     (defun make-error (display event asynchronous)
1480     (declare (type display display)
1481     (type reply-buffer event)
1482     (type boolean asynchronous))
1483     (reading-event (event)
1484     (let* ((error-code (read-card8 1))
1485     (error-key (get-error-key display error-code))
1486     (error-decode-function (get error-key 'error-decode-function))
1487     (params (funcall error-decode-function display event)))
1488     (list* error-code error-key
1489     :asynchronous asynchronous :current-sequence (display-request-number display)
1490     params))))
1491    
1492     (defun report-error (display error-code error-key &rest params)
1493     (declare (type display display)
1494     (dynamic-extent params))
1495     ;; All errors (synchronous and asynchronous) are processed by calling
1496     ;; an error handler in the display. The handler is called with the display
1497     ;; as the first argument and the error-key as its second argument. If handler is
1498     ;; an array it is expected to contain handler functions specific to
1499     ;; each error; the error code is used to index the array, fetching the
1500     ;; appropriate handler. Any results returned by the handler are ignored;;
1501     ;; it is assumed the handler either takes care of the error completely,
1502     ;; or else signals. For all core errors, additional keyword/value argument
1503     ;; pairs are:
1504     ;; :major integer
1505     ;; :minor integer
1506     ;; :sequence integer
1507     ;; :current-sequence integer
1508     ;; :asynchronous (member t nil)
1509     ;; For :colormap, :cursor, :drawable, :font, :GContext, :id-choice, :pixmap, and :window
1510     ;; errors another pair is:
1511     ;; :resource-id integer
1512     ;; For :atom errors, another pair is:
1513     ;; :atom-id integer
1514     ;; For :value errors, another pair is:
1515     ;; :value integer
1516     (let* ((handler (display-error-handler display))
1517     (handler-function
1518     (if (type? handler 'sequence)
1519     (elt handler error-code)
1520     handler)))
1521     (apply handler-function display error-key params)))
1522    
1523     (defun request-name (code &optional display)
1524     (if (< code (length *request-names*))
1525     (svref *request-names* code)
1526     (dolist (extension (and display (display-extension-alist display)) "unknown")
1527     (when (= code (second extension))
1528     (return (first extension))))))
1529    
1530 ram 1.2.1.2 #-(or clx-ansi-common-lisp excl lcl3.0)
1531 ram 1.1 (define-condition request-error (x-error)
1532 ram 1.2 ((display :reader request-error-display)
1533     (error-key :reader request-error-error-key)
1534     (major :reader request-error-major)
1535     (minor :reader request-error-minor)
1536     (sequence :reader request-error-sequence)
1537     (current-sequence :reader request-error-current-sequence)
1538     (asynchronous :reader request-error-asynchronous))
1539 ram 1.1 (:report report-request-error))
1540    
1541     (defun report-request-error (condition stream)
1542     (let ((error-key (request-error-error-key condition))
1543     (asynchronous (request-error-asynchronous condition))
1544     (major (request-error-major condition))
1545     (minor (request-error-minor condition))
1546     (sequence (request-error-sequence condition))
1547     (current-sequence (request-error-current-sequence condition)))
1548     (format stream "~:[~;Asynchronous ~]~a in ~:[request ~d (last request was ~d) ~;current request~2* ~] Code ~d.~d [~a]"
1549     asynchronous error-key (= sequence current-sequence)
1550     sequence current-sequence major minor
1551     (request-name major (request-error-display condition)))))
1552    
1553     ;; Since the :report arg is evaluated as (function report-request-error) the
1554     ;; define-condition must come after the function definition.
1555 ram 1.2.1.1
1556 ram 1.2.1.2 #+(or clx-ansi-common-lisp excl lcl3.0)
1557 ram 1.1 (define-condition request-error (x-error)
1558 ram 1.2 ((display :reader request-error-display :initarg :display)
1559     (error-key :reader request-error-error-key :initarg :error-key)
1560     (major :reader request-error-major :initarg :major)
1561     (minor :reader request-error-minor :initarg :minor)
1562     (sequence :reader request-error-sequence :initarg :sequence)
1563     (current-sequence :reader request-error-current-sequence :initarg :current-sequence)
1564     (asynchronous :reader request-error-asynchronous :initarg :asynchronous))
1565 ram 1.1 (:report report-request-error))
1566    
1567     (define-condition resource-error (request-error)
1568 ram 1.2 ((resource-id :reader resource-error-resource-id :initarg :resource-id))
1569     (:report
1570     (lambda (condition stream)
1571     (report-request-error condition stream)
1572     (format stream " ID #x~x" (resource-error-resource-id condition)))))
1573 ram 1.1
1574     (define-condition unknown-error (request-error)
1575 ram 1.2 ((error-code :reader unknown-error-error-code :initarg :error-code))
1576     (:report
1577     (lambda (condition stream)
1578     (report-request-error condition stream)
1579     (format stream " Error Code ~d." (unknown-error-error-code condition)))))
1580 ram 1.1
1581 ram 1.2 (define-condition access-error (request-error) ())
1582 ram 1.1
1583 ram 1.2 (define-condition alloc-error (request-error) ())
1584 ram 1.1
1585     (define-condition atom-error (request-error)
1586 ram 1.2 ((atom-id :reader atom-error-atom-id :initarg :atom-id))
1587     (:report
1588     (lambda (condition stream)
1589     (report-request-error condition stream)
1590     (format stream " Atom-ID #x~x" (atom-error-atom-id condition)))))
1591 ram 1.1
1592 ram 1.2 (define-condition colormap-error (resource-error) ())
1593 ram 1.1
1594 ram 1.2 (define-condition cursor-error (resource-error) ())
1595 ram 1.1
1596 ram 1.2 (define-condition drawable-error (resource-error) ())
1597 ram 1.1
1598 ram 1.2 (define-condition font-error (resource-error) ())
1599 ram 1.1
1600 ram 1.2 (define-condition gcontext-error (resource-error) ())
1601 ram 1.1
1602 ram 1.2 (define-condition id-choice-error (resource-error) ())
1603 ram 1.1
1604 ram 1.2 (define-condition illegal-request-error (request-error) ())
1605 ram 1.1
1606 ram 1.2 (define-condition length-error (request-error) ())
1607 ram 1.1
1608 ram 1.2 (define-condition match-error (request-error) ())
1609 ram 1.1
1610 ram 1.2 (define-condition name-error (request-error) ())
1611 ram 1.1
1612 ram 1.2 (define-condition pixmap-error (resource-error) ())
1613 ram 1.1
1614     (define-condition value-error (request-error)
1615 ram 1.2 ((value :reader value-error-value :initarg :value))
1616     (:report
1617     (lambda (condition stream)
1618     (report-request-error condition stream)
1619     (format stream " Value ~d." (value-error-value condition)))))
1620 ram 1.1
1621 ram 1.2 (define-condition window-error (resource-error)())
1622 ram 1.1
1623 ram 1.2 (define-condition implementation-error (request-error) ())
1624 ram 1.1
1625     ;;-----------------------------------------------------------------------------
1626     ;; Internal error conditions signaled by CLX
1627    
1628 ram 1.2.1.2 (define-condition x-type-error (type-error #-CMU x-error)
1629 ram 1.2 ((type-string :reader x-type-error-type-string :initarg :type-string))
1630     (:report
1631     (lambda (condition stream)
1632     (format stream "~s isn't a ~a"
1633     (type-error-datum condition)
1634     (or (x-type-error-type-string condition)
1635     (type-error-expected-type condition))))))
1636 ram 1.1
1637     (define-condition closed-display (x-error)
1638 ram 1.2 ((display :reader closed-display-display :initarg :display))
1639     (:report
1640     (lambda (condition stream)
1641     (format stream "Attempt to use closed display ~s"
1642     (closed-display-display condition)))))
1643 ram 1.1
1644     (define-condition lookup-error (x-error)
1645 ram 1.2 ((id :reader lookup-error-id :initarg :id)
1646     (display :reader lookup-error-display :initarg :display)
1647     (type :reader lookup-error-type :initarg :type)
1648     (object :reader lookup-error-object :initarg :object))
1649     (:report
1650     (lambda (condition stream)
1651     (format stream "ID ~d from display ~s should have been a ~s, but was ~s"
1652     (lookup-error-id condition)
1653     (lookup-error-display condition)
1654     (lookup-error-type condition)
1655     (lookup-error-object condition)))))
1656 ram 1.1
1657     (define-condition connection-failure (x-error)
1658 ram 1.2 ((major-version :reader connection-failure-major-version :initarg :major-version)
1659     (minor-version :reader connection-failure-minor-version :initarg :minor-version)
1660     (host :reader connection-failure-host :initarg :host)
1661     (display :reader connection-failure-display :initarg :display)
1662     (reason :reader connection-failure-reason :initarg :reason))
1663     (:report
1664     (lambda (condition stream)
1665     (format stream "Connection failure to X~d.~d server ~a display ~d: ~a"
1666     (connection-failure-major-version condition)
1667     (connection-failure-minor-version condition)
1668     (connection-failure-host condition)
1669     (connection-failure-display condition)
1670     (connection-failure-reason condition)))))
1671 ram 1.1
1672     (define-condition reply-length-error (x-error)
1673 ram 1.2 ((reply-length :reader reply-length-error-reply-length :initarg :reply-length)
1674     (expected-length :reader reply-length-error-expected-length :initarg :expected-length)
1675     (display :reader reply-length-error-display :initarg :display))
1676     (:report
1677     (lambda (condition stream)
1678     (format stream "Reply length was ~d when ~d words were expected for display ~s"
1679     (reply-length-error-reply-length condition)
1680     (reply-length-error-expected-length condition)
1681     (reply-length-error-display condition)))))
1682 ram 1.1
1683     (define-condition reply-timeout (x-error)
1684 ram 1.2 ((timeout :reader reply-timeout-timeout :initarg :timeout)
1685     (display :reader reply-timeout-display :initarg :display))
1686     (:report
1687     (lambda (condition stream)
1688     (format stream "Timeout after waiting ~d seconds for a reply for display ~s"
1689     (reply-timeout-timeout condition)
1690     (reply-timeout-display condition)))))
1691 ram 1.1
1692     (define-condition sequence-error (x-error)
1693 ram 1.2 ((display :reader sequence-error-display :initarg :display)
1694     (req-sequence :reader sequence-error-req-sequence :initarg :req-sequence)
1695     (msg-sequence :reader sequence-error-msg-sequence :initarg :msg-sequence))
1696     (:report
1697     (lambda (condition stream)
1698     (format stream "Reply out of sequence for display ~s.~% Expected ~d, Got ~d"
1699     (sequence-error-display condition)
1700     (sequence-error-req-sequence condition)
1701     (sequence-error-msg-sequence condition)))))
1702 ram 1.1
1703     (define-condition unexpected-reply (x-error)
1704 ram 1.2 ((display :reader unexpected-reply-display :initarg :display)
1705     (msg-sequence :reader unexpected-reply-msg-sequence :initarg :msg-sequence)
1706     (req-sequence :reader unexpected-reply-req-sequence :initarg :req-sequence)
1707     (length :reader unexpected-reply-length :initarg :length))
1708     (:report
1709     (lambda (condition stream)
1710     (format stream "Display ~s received a server reply when none was expected.~@
1711     Last request sequence ~d Reply Sequence ~d Reply Length ~d bytes."
1712     (unexpected-reply-display condition)
1713     (unexpected-reply-req-sequence condition)
1714     (unexpected-reply-msg-sequence condition)
1715     (unexpected-reply-length condition)))))
1716 ram 1.1
1717     (define-condition missing-parameter (x-error)
1718 ram 1.2 ((parameter :reader missing-parameter-parameter :initarg :parameter))
1719     (:report
1720     (lambda (condition stream)
1721     (let ((parm (missing-parameter-parameter condition)))
1722     (if (consp parm)
1723     (format stream "One or more of the required parameters ~a is missing."
1724     parm)
1725     (format stream "Required parameter ~a is missing or null." parm))))))
1726 ram 1.1
1727     ;; This can be signalled anywhere a pseudo font access fails.
1728     (define-condition invalid-font (x-error)
1729 ram 1.2 ((font :reader invalid-font-font :initarg :font))
1730     (:report
1731     (lambda (condition stream)
1732     (format stream "Can't access font ~s" (invalid-font-font condition)))))
1733 ram 1.1
1734     (define-condition device-busy (x-error)
1735 ram 1.2 ((display :reader device-busy-display :initarg :display))
1736     (:report
1737     (lambda (condition stream)
1738     (format stream "Device busy for display ~s"
1739     (device-busy-display condition)))))
1740 ram 1.1
1741     (define-condition unimplemented-event (x-error)
1742 ram 1.2 ((display :reader unimplemented-event-display :initarg :display)
1743     (event-code :reader unimplemented-event-event-code :initarg :event-code))
1744     (:report
1745     (lambda (condition stream)
1746     (format stream "Event code ~d not implemented for display ~s"
1747     (unimplemented-event-event-code condition)
1748     (unimplemented-event-display condition)))))
1749 ram 1.1
1750     (define-condition undefined-event (x-error)
1751 ram 1.2 ((display :reader undefined-event-display :initarg :display)
1752     (event-name :reader undefined-event-event-name :initarg :event-name))
1753     (:report
1754     (lambda (condition stream)
1755     (format stream "Event code ~d undefined for display ~s"
1756     (undefined-event-event-name condition)
1757     (undefined-event-display condition)))))
1758 ram 1.1
1759     (define-condition absent-extension (x-error)
1760 ram 1.2 ((name :reader absent-extension-name :initarg :name)
1761     (display :reader absent-extension-display :initarg :display))
1762     (:report
1763     (lambda (condition stream)
1764     (format stream "Extension ~a isn't defined for display ~s"
1765     (absent-extension-name condition)
1766     (absent-extension-display condition)))))
1767 ram 1.1
1768     (define-condition inconsistent-parameters (x-error)
1769 ram 1.2 ((parameters :reader inconsistent-parameters-parameters :initarg :parameters))
1770     (:report
1771     (lambda (condition stream)
1772     (format stream "inconsistent-parameters:~{ ~s~}"
1773     (inconsistent-parameters-parameters condition)))))
1774 ram 1.1
1775     (defun get-error-key (display error-code)
1776     (declare (type display display)
1777     (type array-index error-code))
1778     ;; Return the error-key associated with error-code
1779     (if (< error-code (length *xerror-vector*))
1780     (svref *xerror-vector* error-code)
1781     ;; Search the extensions for the error
1782     (dolist (entry (display-extension-alist display) 'unknown-error)
1783     (let* ((event-name (first entry))
1784     (first-error (fourth entry))
1785     (errors (third (assoc event-name *extensions*))))
1786     (declare (type keyword event-name)
1787     (type array-index first-error)
1788     (type list errors))
1789     (when (and errors
1790     (index<= first-error error-code
1791     (index+ first-error (index- (length errors) 1))))
1792     (return (nth (index- error-code first-error) errors)))))))
1793    
1794     (defmacro define-error (error-key function)
1795     ;; Associate a function with ERROR-KEY which will be called with
1796     ;; parameters DISPLAY and REPLY-BUFFER and
1797     ;; returns a plist of keyword/value pairs which will be passed on
1798     ;; to the error handler. A compiler warning is printed when
1799     ;; ERROR-KEY is not defined in a preceding DEFINE-EXTENSION.
1800     ;; Note: REPLY-BUFFER may used with the READING-EVENT and READ-type
1801     ;; macros for getting error fields. See DECODE-CORE-ERROR for
1802     ;; an example.
1803     (declare (type symbol error-key)
1804     (type function function))
1805     ;; First ensure the name is for a declared extension
1806     (unless (or (find error-key *xerror-vector*)
1807     (dolist (extension *extensions*)
1808     (when (member error-key (third extension))
1809     (return t))))
1810     (x-type-error error-key 'error-key))
1811     `(setf (get ',error-key 'error-decode-function) (function ,function)))
1812    
1813     ;; All core errors use this, so we make it available to extensions.
1814     (defun decode-core-error (display event &optional arg)
1815     ;; All core errors have the following keyword/argument pairs:
1816     ;; :major integer
1817     ;; :minor integer
1818     ;; :sequence integer
1819     ;; In addition, many have an additional argument that comes from the
1820     ;; same place in the event, but is named differently. When the ARG
1821     ;; argument is specified, the keyword ARG with card32 value starting
1822     ;; at byte 4 of the event is returned with the other keyword/argument
1823     ;; pairs.
1824     (declare (type display display)
1825     (type reply-buffer event)
1826     (type (or null keyword) arg))
1827     (declare (values keyword/arg-plist))
1828     display
1829     (reading-event (event)
1830     (let* ((sequence (read-card16 2))
1831     (minor-code (read-card16 8))
1832     (major-code (read-card8 10))
1833     (result (list :major major-code
1834     :minor minor-code
1835     :sequence sequence)))
1836     (when arg
1837     (setq result (list* arg (read-card32 4) result)))
1838     result)))
1839    
1840     (defun decode-resource-error (display event)
1841     (decode-core-error display event :resource-id))
1842    
1843     (define-error unknown-error
1844     (lambda (display event)
1845     (list* :error-code (aref (reply-ibuf8 event) 1)
1846     (decode-core-error display event))))
1847    
1848     (define-error request-error decode-core-error) ; 1 bad request code
1849    
1850     (define-error value-error ; 2 integer parameter out of range
1851     (lambda (display event)
1852     (decode-core-error display event :value)))
1853    
1854     (define-error window-error decode-resource-error) ; 3 parameter not a Window
1855    
1856     (define-error pixmap-error decode-resource-error) ; 4 parameter not a Pixmap
1857    
1858     (define-error atom-error ; 5 parameter not an Atom
1859     (lambda (display event)
1860     (decode-core-error display event :atom-id)))
1861    
1862     (define-error cursor-error decode-resource-error) ; 6 parameter not a Cursor
1863    
1864     (define-error font-error decode-resource-error) ; 7 parameter not a Font
1865    
1866     (define-error match-error decode-core-error) ; 8 parameter mismatch
1867    
1868     (define-error drawable-error decode-resource-error) ; 9 parameter not a Pixmap or Window
1869    
1870     (define-error access-error decode-core-error) ; 10 attempt to access private resource"
1871    
1872     (define-error alloc-error decode-core-error) ; 11 insufficient resources
1873    
1874     (define-error colormap-error decode-resource-error) ; 12 no such colormap
1875    
1876     (define-error gcontext-error decode-resource-error) ; 13 parameter not a GContext
1877    
1878     (define-error id-choice-error decode-resource-error) ; 14 invalid resource ID for this connection
1879    
1880     (define-error name-error decode-core-error) ; 15 font or color name does not exist
1881    
1882     (define-error length-error decode-core-error) ; 16 request length incorrect;
1883     ; internal Xlib error
1884    
1885     (define-error implementation-error decode-core-error) ; 17 server is defective

  ViewVC Help
Powered by ViewVC 1.1.5