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

Contents of /src/clx/doc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Nov 7 16:57:31 1991 UTC (22 years, 5 months ago) by ram
Branch: MAIN
Changes since 1.1: +18 -21 lines
CLX R5 changes.
1 ram 1.1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2    
3     ;;; Copyright 1987, 1988 Massachusetts Institute of Technology, and
4     ;;; Texas Instruments Incorporated
5    
6     ;;; Permission to use, copy, modify, and distribute this document for any purpose
7     ;;; and without fee is hereby granted, provided that the above copyright notice
8     ;;; appear in all copies and that both that copyright notice and this permission
9     ;;; notice are retained, and that the name of M.I.T. not be used in advertising or
10     ;;; publicity pertaining to this document without specific, written prior
11     ;;; permission. M.I.T. makes no representations about the suitability of this
12     ;;; document or the protocol defined in this document for any purpose. It is
13     ;;; provided "as is" without express or implied warranty.
14    
15     ;;; Texas Instruments Incorporated provides this document "as is" without
16     ;;; express or implied warranty.
17    
18     ;; Version 4
19    
20     ;; This is considered a somewhat changeable interface. Discussion of better
21     ;; integration with CLOS, support for user-specified subclassess of basic
22     ;; objects, and the additional functionality to match the C Xlib is still in
23     ;; progress.
24    
25     ;; Primary Interface Author:
26     ;; Robert W. Scheifler
27     ;; MIT Laboratory for Computer Science
28     ;; 545 Technology Square, Room 418
29     ;; Cambridge, MA 02139
30     ;; rws@zermatt.lcs.mit.edu
31    
32     ;; Design Contributors:
33     ;; Dan Cerys, Texas Instruments
34     ;; Scott Fahlman, CMU
35     ;; Charles Hornig, Symbolics
36     ;; John Irwin, Franz
37     ;; Kerry Kimbrough, Texas Instruments
38     ;; Chris Lindblad, MIT
39     ;; Rob MacLachlan, CMU
40     ;; Mike McMahon, Symbolics
41     ;; David Moon, Symbolics
42     ;; LaMott Oren, Texas Instruments
43     ;; Daniel Weinreb, Symbolics
44     ;; John Wroclawski, MIT
45     ;; Richard Zippel, Symbolics
46    
47     ;; CLX Extensions
48     ;; Adds some of the functionality provided by the C XLIB library.
49     ;;
50     ;; Primary Author
51     ;; LaMott G. Oren
52     ;; Texas Instruments
53     ;;
54     ;; Design Contributors:
55     ;; Robert W. Scheifler, MIT
56    
57    
58     ;; Note: all of the following is in the package XLIB.
59    
60     ;; Note: various perversions of the CL type system are used below.
61     ;; Examples: (list elt-type) (sequence elt-type)
62    
63     (proclaim '(declaration arglist values))
64    
65     ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
66     ;; the relationships should be fairly obvious. We have no intention of writing yet
67     ;; another moby document for this interface.
68    
69     (deftype card32 () '(unsigned-byte 32))
70    
71     (deftype card29 () '(unsigned-byte 29))
72    
73     (deftype int32 () '(signed-byte 32))
74    
75     (deftype card16 () '(unsigned-byte 16))
76    
77     (deftype int16 () '(signed-byte 16))
78    
79     (deftype card8 () '(unsigned-byte 8))
80    
81     (deftype int8 () '(signed-byte 8))
82    
83     (deftype mask32 () 'card32)
84    
85     (deftype mask16 () 'card16)
86    
87     (deftype resource-id () 'card29)
88    
89     ;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
90     ;; These types are defined solely by a functional interface; we do not specify
91     ;; whether they are implemented as structures or flavors or ... Although functions
92     ;; below are written using DEFUN, this is not an implementation requirement (although
93     ;; it is a requirement that they be functions as opposed to macros or special forms).
94     ;; It is unclear whether with-slots in the Common Lisp Object System must work on
95     ;; them.
96    
97     ;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
98     ;; compound objects, rather than as integer resource-ids. This allows applications
99     ;; to deal with multiple displays without having an explicit display argument in the
100     ;; most common functions. Every function uses the display object indicated by the
101     ;; first argument that is or contains a display; it is an error if arguments contain
102     ;; different displays, and predictable results are not guaranteed.
103    
104     ;; Each of window, pixmap, drawable, cursor, font, gcontext, and colormap have the
105     ;; following five functions:
106    
107     (defun <mumble>-display (<mumble>)
108     (declare (type <mumble> <mumble>)
109     (values display)))
110    
111     (defun <mumble>-id (<mumble>)
112     (declare (type <mumble> <mumble>)
113     (values resource-id)))
114    
115     (defun <mumble>-equal (<mumble>-1 <mumble>-2)
116     (declare (type <mumble> <mumble>-1 <mumble>-2)))
117    
118     (defun <mumble>-p (<mumble>)
119     (declare (type <mumble> <mumble>)
120     (values boolean)))
121    
122     ;; The following functions are provided by color objects:
123    
124     ;; The intention is that IHS and YIQ and CYM interfaces will also exist. Note that
125     ;; we are explicitly using a different spectrum representation than what is actually
126     ;; transmitted in the protocol.
127    
128     (deftype rgb-val () '(real 0 1))
129    
130     (defun make-color (&key red green blue &allow-other-keys) ; for expansion
131     (declare (type rgb-val red green blue)
132     (values color)))
133    
134     (defun color-rgb (color)
135     (declare (type color color)
136     (values red green blue)))
137    
138     (defun color-red (color)
139     ;; setf'able
140     (declare (type color color)
141     (values rgb-val)))
142    
143     (defun color-green (color)
144     ;; setf'able
145     (declare (type color color)
146     (values rgb-val)))
147    
148     (defun color-blue (color)
149     ;; setf'able
150     (declare (type color color)
151     (values rgb-val)))
152    
153     (deftype drawable () '(or window pixmap))
154    
155     ;; Atoms are accepted as strings or symbols, and are always returned as keywords.
156     ;; Protocol-level integer atom ids are hidden, using a cache in the display object.
157    
158     (deftype xatom () '(or string symbol))
159    
160     (deftype stringable () '(or string symbol))
161    
162     (deftype fontable () '(or stringable font))
163    
164     ;; Nil stands for CurrentTime.
165    
166     (deftype timestamp () '(or null card32))
167    
168     (deftype bit-gravity () '(member :forget :static :north-west :north :north-east
169     :west :center :east :south-west :south :south-east))
170    
171     (deftype win-gravity () '(member :unmap :static :north-west :north :north-east
172     :west :center :east :south-west :south :south-east))
173    
174     (deftype grab-status ()
175     '(member :success :already-grabbed :frozen :invalid-time :not-viewable))
176    
177     (deftype boolean () '(or null (not null)))
178    
179     (deftype pixel () '(unsigned-byte 32))
180     (deftype image-depth () '(integer 0 32))
181    
182     (deftype keysym () 'card32)
183    
184     (deftype array-index () `(integer 0 ,array-dimension-limit))
185    
186     ;; An association list.
187    
188     (deftype alist (key-type-and-name datum-type-and-name) 'list)
189    
190     ;; A sequence, containing zero or more repetitions of the given elements,
191     ;; with the elements expressed as (type name).
192    
193     (deftype repeat-seq (&rest elts) 'sequence)
194    
195     (deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
196    
197     (deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
198    
199     (deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
200    
201     ;; Note that we are explicitly using a different angle representation than what
202     ;; is actually transmitted in the protocol.
203    
204     (deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
205    
206     (deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
207     (angle angle1) (angle angle2)))
208    
209     (deftype event-mask-class ()
210     '(member :key-press :key-release :owner-grab-button :button-press :button-release
211     :enter-window :leave-window :pointer-motion :pointer-motion-hint
212     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
213     :button-5-motion :button-motion :exposure :visibility-change
214     :structure-notify :resize-redirect :substructure-notify :substructure-redirect
215     :focus-change :property-change :colormap-change :keymap-state))
216    
217     (deftype event-mask ()
218     '(or mask32 (list event-mask-class)))
219    
220     (deftype pointer-event-mask-class ()
221     '(member :button-press :button-release
222     :enter-window :leave-window :pointer-motion :pointer-motion-hint
223     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
224     :button-5-motion :button-motion :keymap-state))
225    
226     (deftype pointer-event-mask ()
227     '(or mask32 (list pointer-event-mask-class)))
228    
229     (deftype device-event-mask-class ()
230     '(member :key-press :key-release :button-press :button-release :pointer-motion
231     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
232     :button-5-motion :button-motion))
233    
234     (deftype device-event-mask ()
235     '(or mask32 (list device-event-mask-class)))
236    
237     (deftype modifier-key ()
238     '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
239    
240     (deftype modifier-mask ()
241     '(or (member :any) mask16 (list modifier-key)))
242    
243     (deftype state-mask-key ()
244     '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
245    
246     (deftype gcontext-key ()
247     '(member :function :plane-mask :foreground :background
248     :line-width :line-style :cap-style :join-style :fill-style :fill-rule
249     :arc-mode :tile :stipple :ts-x :ts-y :font :subwindow-mode
250     :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes))
251    
252     (deftype event-key ()
253     '(member :key-press :key-release :button-press :button-release :motion-notify
254     :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
255     :exposure :graphics-exposure :no-exposure :visibility-notify
256     :create-notify :destroy-notify :unmap-notify :map-notify :map-request
257     :reparent-notify :configure-notify :gravity-notify :resize-request
258     :configure-request :circulate-notify :circulate-request :property-notify
259     :selection-clear :selection-request :selection-notify
260     :colormap-notify :client-message))
261    
262     (deftype error-key ()
263     '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
264     :illegal-request :implementation :length :match :name :pixmap :value :window))
265    
266     (deftype draw-direction ()
267     '(member :left-to-right :right-to-left))
268    
269     (defstruct bitmap-format
270     (unit <unspec> :type (member 8 16 32))
271     (pad <unspec> :type (member 8 16 32))
272     (lsb-first-p <unspec> :type boolean))
273    
274     (defstruct pixmap-format
275     (depth <unspec> :type image-depth)
276     (bits-per-pixel <unspec> :type (member 1 4 8 16 24 32))
277     (pad <unspec> :type (member 8 16 32)))
278    
279     (defstruct visual-info
280     (id <unspec> :type resource-id)
281     (display <unspec> :type display)
282     (class <unspec> :type (member :static-gray :static-color :true-color
283     :gray-scale :pseudo-color :direct-color))
284     (red-mask <unspec> :type pixel)
285     (green-mask <unspec> :type pixel)
286     (blue-mask <unspec> :type pixel)
287     (bits-per-rgb <unspec> :type card8)
288     (colormap-entries <unspec> :type card16))
289    
290     (defstruct screen
291     (root <unspec> :type window)
292     (width <unspec> :type card16)
293     (height <unspec> :type card16)
294     (width-in-millimeters <unspec> :type card16)
295     (height-in-millimeters <unspec> :type card16)
296     (depths <unspec> :type (alist (image-depth depth) ((list visual-info) visuals)))
297     (root-depth <unspec> :type image-depth)
298     (root-visual-info <unspec> :type visual-info)
299     (default-colormap <unspec> :type colormap)
300     (white-pixel <unspec> :type pixel)
301     (black-pixel <unspec> :type pixel)
302     (min-installed-maps <unspec> :type card16)
303     (max-installed-maps <unspec> :type card16)
304     (backing-stores <unspec> :type (member :never :when-mapped :always))
305     (save-unders-p <unspec> :type boolean)
306     (event-mask-at-open <unspec> :type mask32))
307    
308     (defun screen-root-visual (screen)
309     (declare (type screen screen)
310     (values resource-id)))
311    
312     ;; The list contains alternating keywords and integers.
313    
314     (deftype font-props () 'list)
315    
316     (defun open-display (host &key (display 0) protocol)
317     ;; A string must be acceptable as a host, but otherwise the possible types for host
318     ;; and protocol are not constrained, and will likely be very system dependent. The
319     ;; default protocol is system specific. Authorization, if any, is assumed to come
320     ;; from the environment somehow.
321     (declare (type integer display)
322     (values display)))
323    
324     (defun display-protocol-major-version (display)
325     (declare (type display display)
326     (values card16)))
327    
328     (defun display-protocol-minor-version (display)
329     (declare (type display display)
330     (values card16)))
331    
332     (defun display-vendor-name (display)
333     (declare (type display display)
334     (values string)))
335    
336     (defun display-release-number (display)
337     (declare (type display display)
338     (values card32)))
339    
340     (defun display-image-lsb-first-p (display)
341     (declare (type display display)
342     (values boolean)))
343    
344     (defun display-bitmap-formap (display)
345     (declare (type display display)
346     (values bitmap-format)))
347    
348     (defun display-pixmap-formats (display)
349     (declare (type display display)
350     (values (list pixmap-formats))))
351    
352     (defun display-roots (display)
353     (declare (type display display)
354     (values (list screen))))
355    
356     (defun display-motion-buffer-size (display)
357     (declare (type display display)
358     (values card32)))
359    
360     (defun display-max-request-length (display)
361     (declare (type display display)
362     (values card16)))
363    
364     (defun display-min-keycode (display)
365     (declare (type display display)
366     (values card8)))
367    
368     (defun display-max-keycode (display)
369     (declare (type display display)
370     (values card8)))
371    
372     (defun close-display (display)
373     (declare (type display display)))
374    
375     (defun display-error-handler (display)
376     (declare (type display display)
377     (values handler)))
378    
379     (defsetf display-error-handler (display) (handler)
380     ;; All errors (synchronous and asynchronous) are processed by calling an error
381     ;; handler in the display. If handler is a sequence it is expected to contain
382     ;; handler functions specific to each error; the error code is used to index the
383     ;; sequence, fetching the appropriate handler. Any results returned by the handler
384     ;; are ignored; it is assumed the handler either takes care of the error
385     ;; completely, or else signals. For all core errors, the keyword/value argument
386     ;; pairs are:
387     ;; :major card8
388     ;; :minor card16
389     ;; :sequence card16
390     ;; :current-sequence card16
391     ;; :asynchronous (member t nil)
392     ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
393     ;; :window errors another pair is:
394     ;; :resource-id card32
395     ;; For :atom errors, another pair is:
396     ;; :atom-id card32
397     ;; For :value errors, another pair is:
398     ;; :value card32
399     (declare (type display display)
400     (type (or (sequence (function (display symbol &rest key-vals)))
401     (function (display symbol &rest key-vals)))
402     handler)))
403    
404     (defsetf display-report-asynchronous-errors (display) (when)
405     ;; Most useful in multi-process lisps.
406     ;;
407     ;; Synchronous errors are always signalled in the process that made the
408     ;; synchronous request. An error is considered synchronous if a process is
409     ;; waiting for a reply with the same request-id as the error.
410     ;;
411     ;; Asynchronous errors can be signalled at any one of these three times:
412     ;;
413     ;; 1. As soon as they are read. They get signalled in whichever process
414     ;; was doing the reading. This is enabled by
415     ;; (setf (xlib:display-report-asynchronous-errors display)
416     ;; '(:immediately))
417     ;; This is the default.
418     ;;
419     ;; 2. Before any events are to be handled. You get these by doing an
420     ;; event-listen with any timeout value other than 0, or in of the event
421     ;; processing forms. This is useful if you using a background process to
422     ;; handle input. This is enabled by
423     ;; (setf (xlib:display-report-asynchronous-errors display)
424     ;; '(:before-event-handling))
425     ;;
426     ;; 3. After a display-finish-output. You get these by doing a
427     ;; display-finish-output. A cliche using this might have a with-display
428     ;; wrapped around the display operations that possibly cause an asynchronous
429     ;; error, with a display-finish-output right the end of the with-display to
430     ;; catch any asynchronous errors. This is enabled by
431     ;; (setf (xlib:display-report-asynchronous-errors display)
432     ;; '(:after-finish-output))
433     ;;
434     ;; You can select any combination of the three keywords. For example, to
435     ;; get errors reported before event handling and after finish-output,
436     ;; (setf (xlib:display-report-asynchronous-errors display)
437     ;; '(:before-event-handling :after-finish-output))
438     (declare (type list when))
439     )
440    
441     (defmacro define-condition (name base &body items)
442     ;; just a place-holder here for the real thing
443     )
444    
445     (define-condition request-error error
446     display
447     major
448     minor
449     sequence
450     current-sequence
451     asynchronous)
452    
453     (defun default-error-handler (display error-key &rest key-vals)
454     ;; The default display-error-handler.
455     ;; It signals the conditions listed below.
456     (declare (type display display)
457     (type symbol error-key))
458     )
459    
460     (define-condition resource-error request-error
461     resource-id)
462    
463     (define-condition access-error request-error)
464    
465     (define-condition alloc-error request-error)
466    
467     (define-condition atom-error request-error
468     atom-id)
469    
470     (define-condition colormap-error resource-error)
471    
472     (define-condition cursor-error resource-error)
473    
474     (define-condition drawable-error resource-error)
475    
476     (define-condition font-error resource-error)
477    
478     (define-condition gcontext-error resource-error)
479    
480     (define-condition id-choice-error resource-error)
481    
482     (define-condition illegal-request-error request-error)
483    
484     (define-condition implementation-error request-error)
485    
486     (define-condition length-error request-error)
487    
488     (define-condition match-error request-error)
489    
490     (define-condition name-error request-error)
491    
492     (define-condition pixmap-error resource-error)
493    
494     (define-condition value-error request-error
495     value)
496    
497     (define-condition window-error resource-error)
498    
499     (defmacro with-display ((display) &body body)
500     ;; This macro is for use in a multi-process environment. It provides exclusive
501     ;; access to the local display object for multiple request generation. It need not
502     ;; provide immediate exclusive access for replies; that is, if another process is
503     ;; waiting for a reply (while not in a with-display), then synchronization need not
504     ;; (but can) occur immediately. Except where noted, all routines effectively
505     ;; contain an implicit with-display where needed, so that correct synchronization
506     ;; is always provided at the interface level on a per-call basis. Nested uses of
507     ;; this macro will work correctly. This macro does not prevent concurrent event
508     ;; processing; see with-event-queue.
509     )
510    
511     (defun display-force-output (display)
512     ;; Output is normally buffered; this forces any buffered output.
513     (declare (type display display)))
514    
515     (defun display-finish-output (display)
516     ;; Forces output, then causes a round-trip to ensure that all possible errors and
517     ;; events have been received.
518     (declare (type display display)))
519    
520     (defun display-after-function (display)
521     ;; setf'able
522     ;; If defined, called after every protocol request is generated, even those inside
523     ;; explicit with-display's, but never called from inside the after-function itself.
524     ;; The function is called inside the effective with-display for the associated
525     ;; request. Default value is nil. Can be set, for example, to
526     ;; #'display-force-output or #'display-finish-output.
527     (declare (type display display)
528     (values (or null (function (display))))))
529    
530     (defun create-window (&key parent x y width height (depth 0) (border-width 0)
531     (class :copy) (visual :copy)
532     background border gravity bit-gravity
533     backing-store backing-planes backing-pixel save-under
534     event-mask do-not-propagate-mask override-redirect
535     colormap cursor)
536     ;; Display is obtained from parent. Only non-nil attributes are passed on in the
537     ;; request: the function makes no assumptions about what the actual protocol
538     ;; defaults are. Width and height are the inside size, excluding border.
539     (declare (type window parent)
540     (type int16 x y)
541     (type card16 width height depth border-width)
542     (type (member :copy :input-output :input-only) class)
543     (type (or (member :copy) visual-info) visual)
544     (type (or null (member :none :parent-relative) pixel pixmap) background)
545     (type (or null (member :copy) pixel pixmap) border)
546     (type (or null win-gravity) gravity)
547     (type (or null bit-gravity) bit-gravity)
548     (type (or null (member :not-useful :when-mapped :always) backing-store))
549     (type (or null pixel) backing-planes backing-pixel)
550     (type (or null event-mask) event-mask)
551     (type (or null device-event-mask) do-not-propagate-mask)
552     (type (or null (member :on :off)) save-under override-redirect)
553     (type (or null (member :copy) colormap) colormap)
554     (type (or null (member :none) cursor) cursor)
555     (values window)))
556    
557     (defun window-class (window)
558     (declare (type window window)
559     (values (member :input-output :input-only))))
560    
561     (defun window-visual-info (window)
562     (declare (type window window)
563     (values visual-info)))
564    
565     (defun window-visual (window)
566     (declare (type window window)
567     (values resource-id)))
568    
569     (defsetf window-background (window) (background)
570     (declare (type window window)
571     (type (or (member :none :parent-relative) pixel pixmap) background)))
572    
573     (defsetf window-border (window) (border)
574     (declare (type window window)
575     (type (or (member :copy) pixel pixmap) border)))
576    
577     (defun window-gravity (window)
578     ;; setf'able
579     (declare (type window window)
580     (values win-gravity)))
581    
582     (defun window-bit-gravity (window)
583     ;; setf'able
584     (declare (type window window)
585     (values bit-gravity)))
586    
587     (defun window-backing-store (window)
588     ;; setf'able
589     (declare (type window window)
590     (values (member :not-useful :when-mapped :always))))
591    
592     (defun window-backing-planes (window)
593     ;; setf'able
594     (declare (type window window)
595     (values pixel)))
596    
597     (defun window-backing-pixel (window)
598     ;; setf'able
599     (declare (type window window)
600     (values pixel)))
601    
602     (defun window-save-under (window)
603     ;; setf'able
604     (declare (type window window)
605     (values (member :on :off))))
606    
607     (defun window-event-mask (window)
608     ;; setf'able
609     (declare (type window window)
610     (values mask32)))
611    
612     (defun window-do-not-propagate-mask (window)
613     ;; setf'able
614     (declare (type window window)
615     (values mask32)))
616    
617     (defun window-override-redirect (window)
618     ;; setf'able
619     (declare (type window window)
620     (values (member :on :off))))
621    
622     (defun window-colormap (window)
623     (declare (type window window)
624     (values (or null colormap))))
625    
626     (defsetf window-colormap (window) (colormap)
627     (declare (type window window)
628     (type (or (member :copy) colormap) colormap)))
629    
630     (defsetf window-cursor (window) (cursor)
631     (declare (type window window)
632     (type (or (member :none) cursor) cursor)))
633    
634     (defun window-colormap-installed-p (window)
635     (declare (type window window)
636     (values boolean)))
637    
638     (defun window-all-event-masks (window)
639     (declare (type window window)
640     (values mask32)))
641    
642     (defun window-map-state (window)
643     (declare (type window window)
644     (values (member :unmapped :unviewable :viewable))))
645    
646     (defsetf drawable-x (window) (x)
647     (declare (type window window)
648     (type int16 x)))
649    
650     (defsetf drawable-y (window) (y)
651     (declare (type window window)
652     (type int16 y)))
653    
654     (defsetf drawable-width (window) (width)
655     ;; Inside width, excluding border.
656     (declare (type window window)
657     (type card16 width)))
658    
659     (defsetf drawable-height (window) (height)
660     ;; Inside height, excluding border.
661     (declare (type window window)
662     (type card16 height)))
663    
664     (defsetf drawable-border-width (window) (border-width)
665     (declare (type window window)
666     (type card16 border-width)))
667    
668     (defsetf window-priority (window &optional sibling) (mode)
669     ;; A bit strange, but retains setf form.
670     (declare (type window window)
671     (type (or null window) sibling)
672     (type (member :above :below :top-if :bottom-if :opposite) mode)))
673    
674     (defmacro with-state ((drawable) &body body)
675     ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
676     ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
677     ;; ConfigureWindow. The body is not surrounded by a with-display. Within the
678     ;; indefinite scope of the body, on a per-process basis in a multi-process
679     ;; environment, the first call within an Accessor Group on the specified drawable
680     ;; (the object, not just the variable) causes the complete results of the protocol
681     ;; request to be retained, and returned in any subsequent accessor calls. Calls
682     ;; within a Setf Group are delayed, and executed in a single request on exit from
683     ;; the body. In addition, if a call on a function within an Accessor Group follows
684     ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
685     ;; that group are executed, any retained accessor information for that group is
686     ;; discarded, the corresponding protocol request is (re)issued, and the results are
687     ;; (again) retained, and returned in any subsequent accessor calls.
688    
689     ;; Accessor Group A (for GetWindowAttributes):
690     ;; window-visual-info, window-visual, window-class, window-gravity, window-bit-gravity,
691     ;; window-backing-store, window-backing-planes, window-backing-pixel,
692     ;; window-save-under, window-colormap, window-colormap-installed-p,
693     ;; window-map-state, window-all-event-masks, window-event-mask,
694     ;; window-do-not-propagate-mask, window-override-redirect
695    
696     ;; Setf Group A (for ChangeWindowAttributes):
697     ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
698     ;; window-backing-pixel, window-save-under, window-event-mask,
699     ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
700     ;; window-cursor
701    
702     ;; Accessor Group G (for GetGeometry):
703     ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
704     ;; drawable-height, drawable-border-width
705    
706     ;; Setf Group G (for ConfigureWindow):
707     ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
708     ;; window-priority
709     )
710    
711     (defun destroy-window (window)
712     (declare (type window window)))
713    
714     (defun destroy-subwindows (window)
715     (declare (type window window)))
716    
717     (defun add-to-save-set (window)
718     (declare (type window window)))
719    
720     (defun remove-from-save-set (window)
721     (declare (type window window)))
722    
723     (defun reparent-window (window parent x y)
724     (declare (type window window parent)
725     (type int16 x y)))
726    
727     (defun map-window (window)
728     (declare (type window window)))
729    
730     (defun map-subwindows (window)
731     (declare (type window window)))
732    
733     (defun unmap-window (window)
734     (declare (type window window)))
735    
736     (defun unmap-subwindows (window)
737     (declare (type window window)))
738    
739     (defun circulate-window-up (window)
740     (declare (type window window)))
741    
742     (defun circulate-window-down (window)
743     (declare (type window window)))
744    
745     (defun drawable-root (drawable)
746     (declare (type drawable drawable)
747     (values window)))
748    
749     (defun drawable-depth (drawable)
750     (declare (type drawable drawable)
751     (values card8)))
752    
753     (defun drawable-x (drawable)
754     (declare (type drawable drawable)
755     (values int16)))
756    
757     (defun drawable-y (drawable)
758     (declare (type drawable drawable)
759     (values int16)))
760    
761     (defun drawable-width (drawable)
762     ;; For windows, inside width, excluding border.
763     (declare (type drawable drawable)
764     (values card16)))
765    
766     (defun drawable-height (drawable)
767     ;; For windows, inside height, excluding border.
768     (declare (type drawable drawable)
769     (values card16)))
770    
771     (defun drawable-border-width (drawable)
772     (declare (type drawable drawable)
773     (values card16)))
774    
775     (defun query-tree (window &key (result-type 'list))
776     (declare (type window window)
777     (type type result-type)
778     (values (sequence window) parent root)))
779    
780     (defun change-property (window property data type format
781     &key (mode :replace) (start 0) end transform)
782     ;; Start and end affect sub-sequence extracted from data.
783     ;; Transform is applied to each extracted element.
784     (declare (type window window)
785     (type xatom property type)
786     (type (member 8 16 32) format)
787     (type sequence data)
788     (type (member :replace :prepend :append) mode)
789     (type array-index start)
790     (type (or null array-index) end)
791     (type (or null (function (t) integer)) transform)))
792    
793     (defun delete-property (window property)
794     (declare (type window window)
795     (type xatom property)))
796    
797     (defun get-property (window property
798     &key type (start 0) end delete-p (result-type 'list) transform)
799     ;; Transform is applied to each integer retrieved.
800     ;; Nil is returned for type when the protocol returns None.
801     (declare (type window window)
802     (type xatom property)
803     (type (or null xatom) type)
804     (type array-index start)
805     (type (or null array-index) end)
806     (type boolean delete-p)
807     (type type result-type)
808     (type (or null (function (integer) t)) transform)
809     (values data type format bytes-after)))
810    
811     (defun rotate-properties (window properties &optional (delta 1))
812     ;; Postive rotates left, negative rotates right (opposite of actual protocol request).
813     (declare (type window window)
814     (type (sequence xatom) properties)
815     (type int16 delta)))
816    
817     (defun list-properties (window &key (result-type 'list))
818     (declare (type window window)
819     (type type result-type)
820     (values (sequence keyword))))
821    
822     ;; Although atom-ids are not visible in the normal user interface, atom-ids might
823     ;; appear in window properties and other user data, so conversion hooks are needed.
824    
825     (defun intern-atom (display name)
826     (declare (type display display)
827     (type xatom name)
828     (values resource-id)))
829    
830     (defun find-atom (display name)
831     (declare (type display display)
832     (type xatom name)
833     (values (or null resource-id))))
834    
835     (defun atom-name (display atom-id)
836     (declare (type display display)
837     (type resource-id atom-id)
838     (values keyword)))
839    
840     (defun selection-owner (display selection)
841     (declare (type display display)
842     (type xatom selection)
843     (values (or null window))))
844    
845     (defsetf selection-owner (display selection &optional time) (owner)
846     ;; A bit strange, but retains setf form.
847     (declare (type display display)
848     (type xatom selection)
849     (type (or null window) owner)
850     (type timestamp time)))
851    
852     (defun convert-selection (selection type requestor &optional property time)
853     (declare (type xatom selection type)
854     (type window requestor)
855     (type (or null xatom) property)
856     (type timestamp time)))
857    
858     (defun send-event (window event-key event-mask &rest args
859     &key propagate-p display &allow-other-keys)
860     ;; Additional arguments depend on event-key, and are as specified further below
861     ;; with declare-event, except that both resource-ids and resource objects are
862     ;; accepted in the event components. The display argument is only required if the
863     ;; window is :pointer-window or :input-focus. If an argument has synonyms, it is
864     ;; only necessary to supply a value for one of them; it is an error to specify
865     ;; different values for synonyms.
866     (declare (type (or window (member :pointer-window :input-focus)) window)
867     (type (or null event-key) event-key)
868     (type event-mask event-mask)
869     (type boolean propagate-p)
870     (type (or null display) display)))
871    
872     (defun grab-pointer (window event-mask
873     &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
874     (declare (type window window)
875     (type pointer-event-mask event-mask)
876     (type boolean owner-p sync-pointer-p sync-keyboard-p)
877     (type (or null window) confine-to)
878     (type (or null cursor) cursor)
879     (type timestamp time)
880     (values grab-status)))
881    
882     (defun ungrab-pointer (display &key time)
883     (declare (type display display)
884     (type timestamp time)))
885    
886     (defun grab-button (window button event-mask
887     &key (modifiers 0)
888     owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
889     (declare (type window window)
890     (type (or (member :any) card8) button)
891     (type modifier-mask modifiers)
892     (type pointer-event-mask event-mask)
893     (type boolean owner-p sync-pointer-p sync-keyboard-p)
894     (type (or null window) confine-to)
895     (type (or null cursor) cursor)))
896    
897     (defun ungrab-button (window button &key (modifiers 0))
898     (declare (type window window)
899     (type (or (member :any) card8) button)
900     (type modifier-mask modifiers)))
901    
902     (defun change-active-pointer-grab (display event-mask &optional cursor time)
903     (declare (type display display)
904     (type pointer-event-mask event-mask)
905     (type (or null cursor) cursor)
906     (type timestamp time)))
907    
908     (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
909     (declare (type window window)
910     (type boolean owner-p sync-pointer-p sync-keyboard-p)
911     (type timestamp time)
912     (values grab-status)))
913    
914     (defun ungrab-keyboard (display &key time)
915     (declare (type display display)
916     (type timestamp time)))
917    
918     (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
919     (declare (type window window)
920     (type boolean owner-p sync-pointer-p sync-keyboard-p)
921     (type (or (member :any) card8) key)
922     (type modifier-mask modifiers)))
923    
924     (defun ungrab-key (window key &key (modifiers 0))
925     (declare (type window window)
926     (type (or (member :any) card8) key)
927     (type modifier-mask modifiers)))
928    
929     (defun allow-events (display mode &optional time)
930     (declare (type display display)
931     (type (member :async-pointer :sync-pointer :reply-pointer
932     :async-keyboard :sync-keyboard :replay-keyboard
933     :async-both :sync-both)
934     mode)
935     (type timestamp time)))
936    
937     (defun grab-server (display)
938     (declare (type display display)))
939    
940     (defun ungrab-server (display)
941     (declare (type display display)))
942    
943     (defmacro with-server-grabbed ((display) &body body)
944     ;; The body is not surrounded by a with-display.
945     )
946    
947     (defun query-pointer (window)
948     (declare (type window window)
949     (values x y same-screen-p child mask root-x root-y root)))
950    
951     (defun pointer-position (window)
952     (declare (type window window)
953     (values x y same-screen-p)))
954    
955     (defun global-pointer-position (display)
956     (declare (type display display)
957     (values root-x root-y root)))
958    
959     (defun motion-events (window &key start stop (result-type 'list))
960     (declare (type window window)
961     (type timestamp start stop)
962     (type type result-type)
963     (values (repeat-seq (int16 x) (int16 y) (timestamp time)))))
964    
965     (defun translate-coordinates (src src-x src-y dst)
966     ;; If src and dst are not on the same screen, nil is returned.
967     (declare (type window src)
968     (type int16 src-x src-y)
969     (type window dst)
970     (values dst-x dst-y child)))
971    
972     (defun warp-pointer (dst dst-x dst-y)
973     (declare (type window dst)
974     (type int16 dst-x dst-y)))
975    
976     (defun warp-pointer-relative (display x-off y-off)
977     (declare (type display display)
978     (type int16 x-off y-off)))
979    
980     (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
981     &optional src-width src-height)
982     ;; Passing in a zero src-width or src-height is a no-op. A null src-width or
983     ;; src-height translates into a zero value in the protocol request.
984     (declare (type window dst src)
985     (type int16 dst-x dst-y src-x src-y)
986     (type (or null card16) src-width src-height)))
987    
988     (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
989     &optional src-width src-height)
990     ;; Passing in a zero src-width or src-height is a no-op. A null src-width or
991     ;; src-height translates into a zero value in the protocol request.
992     (declare (type window src)
993     (type int16 x-off y-off src-x src-y)
994     (type (or null card16) src-width src-height)))
995    
996     (defun set-input-focus (display focus revert-to &optional time)
997     ;; Setf ought to allow multiple values.
998     (declare (type display display)
999     (type (or (member :none :pointer-root) window) focus)
1000     (type (member :none :parent :pointer-root) revert-to)
1001     (type timestamp time)))
1002    
1003     (defun input-focus (display)
1004     (declare (type display display)
1005     (values focus revert-to)))
1006    
1007     (defun query-keymap (display)
1008     (declare (type display display)
1009     (values (bit-vector 256))))
1010    
1011     (defun open-font (display name)
1012     ;; Font objects may be cached and reference counted locally within the display
1013     ;; object. This function might not execute a with-display if the font is cached.
1014     ;; The protocol QueryFont request happens on-demand under the covers.
1015     (declare (type display display)
1016     (type stringable name)
1017     (values font)))
1018    
1019     ;; We probably want a per-font bit to indicate whether caching on
1020     ;; text-extents/width calls is desirable. But what to name it?
1021    
1022     (defun discard-font-info (font)
1023     ;; Discards any state that can be re-obtained with QueryFont. This is simply
1024     ;; a performance hint for memory-limited systems.
1025     (declare (type font font)))
1026    
1027     ;; This can be signalled anywhere a pseudo font access fails.
1028    
1029     (define-condition invalid-font error
1030     font)
1031    
1032     ;; Note: font-font-info removed.
1033    
1034     (defun font-name (font)
1035     ;; Returns nil for a pseudo font returned by gcontext-font.
1036     (declare (type font font)
1037     (values (or null string))))
1038    
1039     (defun font-direction (font)
1040     (declare (type font font)
1041     (values draw-direction)))
1042    
1043     (defun font-min-char (font)
1044     (declare (type font font)
1045     (values card16)))
1046    
1047     (defun font-max-char (font)
1048     (declare (type font font)
1049     (values card16)))
1050    
1051     (defun font-min-byte1 (font)
1052     (declare (type font font)
1053     (values card8)))
1054    
1055     (defun font-max-byte1 (font)
1056     (declare (type font font)
1057     (values card8)))
1058    
1059     (defun font-min-byte2 (font)
1060     (declare (type font font)
1061     (values card8)))
1062    
1063     (defun font-max-byte2 (font)
1064     (declare (type font font)
1065     (values card8)))
1066    
1067     (defun font-all-chars-exist-p (font)
1068     (declare (type font font)
1069     (values boolean)))
1070    
1071     (defun font-default-char (font)
1072     (declare (type font font)
1073     (values card16)))
1074    
1075     (defun font-ascent (font)
1076     (declare (type font font)
1077     (values int16)))
1078    
1079     (defun font-descent (font)
1080     (declare (type font font)
1081     (values int16)))
1082    
1083     ;; The list contains alternating keywords and int32s.
1084    
1085     (deftype font-props () 'list)
1086    
1087     (defun font-properties (font)
1088     (declare (type font font)
1089     (values font-props)))
1090    
1091     (defun font-property (font name)
1092     (declare (type font font)
1093     (type keyword name)
1094     (values (or null int32))))
1095    
1096     ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
1097    
1098     (defun char-<metric> (font index)
1099     ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
1100     ;; (or an in-bounds index on a pseudo font), although returning zero or
1101     ;; signalling might be better.
1102     (declare (type font font)
1103     (type card16 index)
1104     (values (or null int16))))
1105    
1106     (defun max-char-<metric> (font)
1107     ;; Note: I have tentatively chosen separate accessors over allowing :min and
1108     ;; :max as an index above.
1109     (declare (type font font)
1110     (values int16)))
1111    
1112     (defun min-char-<metric> (font)
1113     (declare (type font font)
1114     (values int16)))
1115    
1116     ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
1117    
1118     (defun close-font (font)
1119     ;; This might not generate a protocol request if the font is reference
1120     ;; counted locally or if it is a pseudo font.
1121     (declare (type font font)))
1122    
1123     (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
1124     (declare (type display display)
1125     (type string pattern)
1126     (type card16 max-fonts)
1127     (type type result-type)
1128     (values (sequence string))))
1129    
1130     (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
1131     ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
1132     ;; no per-character metrics and no resource-ids. These pseudo fonts will be
1133     ;; converted (internally) to real fonts dynamically as needed, by issuing an
1134     ;; OpenFont request. However, the OpenFont might fail, in which case the
1135     ;; invalid-font error can arise.
1136     (declare (type display display)
1137     (type string pattern)
1138     (type card16 max-fonts)
1139     (type type result-type)
1140     (values (sequence font))))
1141    
1142     (defun font-path (display &key (result-type 'list))
1143     (declare (type display display)
1144     (type type result-type)
1145     (values (sequence (or string pathname)))))
1146    
1147     (defsetf font-path (display) (paths)
1148     (declare (type display display)
1149     (type (sequence (or string pathname)) paths)))
1150    
1151     (defun create-pixmap (&key width height depth drawable)
1152     (declare (type card16 width height)
1153     (type card8 depth)
1154     (type drawable drawable)
1155     (values pixmap)))
1156    
1157     (defun free-pixmap (pixmap)
1158     (declare (type pixmap pixmap)))
1159    
1160     (defun create-gcontext (&key drawable function plane-mask foreground background
1161     line-width line-style cap-style join-style fill-style fill-rule
1162     arc-mode tile stipple ts-x ts-y font subwindow-mode
1163     exposures clip-x clip-y clip-mask clip-ordering
1164     dash-offset dashes
1165     (cache-p t))
1166     ;; Only non-nil components are passed on in the request, but for effective caching
1167     ;; assumptions have to be made about what the actual protocol defaults are. For
1168     ;; all gcontext components, a value of nil causes the default gcontext value to be
1169     ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented
1170     ;; as a list. Note: use of stringable as font will cause an implicit open-font.
1171     ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If
1172     ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
1173     ;; component will have no effect unless the new value differs from the cached
1174     ;; value. Component changes (setfs and with-gcontext) are always deferred
1175     ;; regardless of the cache mode, and sent over the protocol only when required by a
1176     ;; local operation or by an explicit call to force-gcontext-changes.
1177     (declare (type drawable drawable)
1178     (type (or null boole-constant) function)
1179     (type (or null pixel) plane-mask foreground background)
1180     (type (or null card16) line-width dash-offset)
1181     (type (or null int16) ts-x ts-y clip-x clip-y)
1182     (type (or null (member :solid :dash :double-dash)) line-style)
1183     (type (or null (member :not-last :butt :round :projecting)) cap-style)
1184     (type (or null (member :miter :round :bevel)) join-style)
1185     (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
1186     (type (or null (member :even-odd :winding)) fill-rule)
1187     (type (or null (member :chord :pie-slice)) arc-mode)
1188     (type (or null pixmap) tile stipple)
1189     (type (or null fontable) font)
1190     (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
1191     (type (or null (member :on :off)) exposures)
1192     (type (or null (member :none) pixmap rect-seq) clip-mask)
1193     (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
1194     (type (or null (or card8 (sequence card8))) dashes)
1195     (type boolean cache)
1196     (values gcontext)))
1197    
1198     ;; For each argument to create-gcontext (except font, clip-mask and
1199     ;; clip-ordering) declared as (type <type> <name>), there is an accessor:
1200    
1201     (defun gcontext-<name> (gcontext)
1202     ;; The value will be nil if the last value stored is unknown (e.g., the cache was
1203     ;; off, or the component was copied from a gcontext with unknown state).
1204     (declare (type gcontext gcontext)
1205     (values <type>)))
1206    
1207     ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
1208     ;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
1209    
1210     (defsetf gcontext-<name> (gcontext) (value)
1211     (declare (type gcontext gcontext)
1212     (type <type> value)))
1213    
1214     (defun gcontext-font (gcontext &optional metrics-p)
1215     ;; If the stored font is known, it is returned. If it is not known and
1216     ;; metrics-p is false, then nil is returned. If it is not known and
1217     ;; metrics-p is true, then a pseudo font is returned. Full metric and
1218     ;; property information can be obtained, but the font does not have a name or
1219     ;; a resource-id, and attempts to use it where a resource-id is required will
1220     ;; result in an invalid-font error.
1221     (declare (type gcontext gcontext)
1222     (type boolean metrics-p)
1223     (values (or null font))))
1224    
1225     (defun gcontext-clip-mask (gcontext)
1226     (declare (type gcontext gcontext)
1227     (values (or null (member :none) pixmap rect-seq)
1228     (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))))
1229    
1230     (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
1231     ;; Is nil illegal here, or is it transformed to a vector?
1232     ;; A bit strange, but retains setf form.
1233     (declare (type gcontext gcontext)
1234     (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
1235     (type (or (member :none) pixmap rect-seq) clip-mask)))
1236    
1237     (defun force-gcontext-changes (gcontext)
1238     ;; Force any delayed changes.
1239     (declare (type gcontext gcontext)))
1240    
1241     (defmacro with-gcontext ((gcontext &key
1242     function plane-mask foreground background
1243     line-width line-style cap-style join-style fill-style fill-rule
1244     arc-mode tile stipple ts-x ts-y font subwindow-mode
1245     exposures clip-x clip-y clip-mask clip-ordering
1246     dashes dash-offset)
1247     &body body)
1248     ;; Changes gcontext components within the dynamic scope of the body (i.e.,
1249     ;; indefinite scope and dynamic extent), on a per-process basis in a multi-process
1250     ;; environment. The values are all evaluated before bindings are performed. The
1251     ;; body is not surrounded by a with-display. If cache-p is nil or the some
1252     ;; component states are unknown, this will implement save/restore by creating a
1253     ;; temporary gcontext and doing gcontext-components to and from it.
1254     )
1255    
1256     (defun copy-gcontext-components (src dst &rest keys)
1257     (declare (type gcontext src dst)
1258     (type (list gcontext-key) keys)))
1259    
1260     (defun copy-gcontext (src dst)
1261     (declare (type gcontext src dst))
1262     ;; Copies all components.
1263     )
1264    
1265     (defun free-gcontext (gcontext)
1266     (declare (type gcontext gcontext)))
1267    
1268     (defun clear-area (window &key (x 0) (y 0) width height exposures-p)
1269     ;; Passing in a zero width or height is a no-op. A null width or height translates
1270     ;; into a zero value in the protocol request.
1271     (declare (type window window)
1272     (type int16 x y)
1273     (type (or null card16) width height)
1274     (type boolean exposures-p)))
1275    
1276     (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
1277     (declare (type drawable src dst)
1278     (type gcontext gcontext)
1279     (type int16 src-x src-y dst-x dst-y)
1280     (type card16 width height)))
1281    
1282     (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
1283     (declare (type drawable src dst)
1284     (type gcontext gcontext)
1285     (type pixel plane)
1286     (type int16 src-x src-y dst-x dst-y)
1287     (type card16 width height)))
1288    
1289     (defun draw-point (drawable gcontext x y)
1290     ;; Should be clever about appending to existing buffered protocol request, provided
1291     ;; gcontext has not been modified.
1292     (declare (type drawable drawable)
1293     (type gcontext gcontext)
1294     (type int16 x y)))
1295    
1296     (defun draw-points (drawable gcontext points &optional relative-p)
1297     (declare (type drawable drawable)
1298     (type gcontext gcontext)
1299     (type point-seq points)
1300     (type boolean relative-p)))
1301    
1302     (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
1303     ;; Should be clever about appending to existing buffered protocol request, provided
1304     ;; gcontext has not been modified.
1305     (declare (type drawable drawable)
1306     (type gcontext gcontext)
1307     (type int16 x1 y1 x2 y2)
1308     (type boolean relative-p)))
1309    
1310     (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
1311     (declare (type drawable drawable)
1312     (type gcontext gcontext)
1313     (type point-seq points)
1314     (type boolean relative-p fill-p)
1315     (type (member :complex :non-convex :convex) shape)))
1316    
1317     (defun draw-segments (drawable gcontext segments)
1318     (declare (type drawable drawable)
1319     (type gcontext gcontext)
1320     (type seg-seq segments)))
1321    
1322     (defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
1323     ;; Should be clever about appending to existing buffered protocol request, provided
1324     ;; gcontext has not been modified.
1325     (declare (type drawable drawable)
1326     (type gcontext gcontext)
1327     (type int16 x y)
1328     (type card16 width height)
1329     (type boolean fill-p)))
1330    
1331     (defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
1332     (declare (type drawable drawable)
1333     (type gcontext gcontext)
1334     (type rect-seq rectangles)
1335     (type boolean fill-p)))
1336    
1337     (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
1338     ;; Should be clever about appending to existing buffered protocol request, provided
1339     ;; gcontext has not been modified.
1340     (declare (type drawable drawable)
1341     (type gcontext gcontext)
1342     (type int16 x y)
1343     (type card16 width height)
1344     (type angle angle1 angle2)
1345     (type boolean fill-p)))
1346    
1347     (defun draw-arcs (drawable gcontext arcs &optional fill-p)
1348     (declare (type drawable drawable)
1349     (type gcontext gcontext)
1350     (type arc-seq arcs)
1351     (type boolean fill-p)))
1352    
1353     ;; The following image routines are bare minimum. It may be useful to define some
1354     ;; form of "image" object to hide representation details and format conversions. It
1355     ;; also may be useful to provide stream-oriented interfaces for reading and writing
1356     ;; the data.
1357    
1358     (defun put-raw-image (drawable gcontext data
1359     &key (start 0) depth x y width height (left-pad 0) format)
1360     ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
1361     ;; for transmission; the caller is responsible for all byte and bit swapping and
1362     ;; compaction. Start is the starting index in data; the end is computed from the
1363     ;; other arguments.
1364     (declare (type drawable drawable)
1365     (type gcontext gcontext)
1366     (type (sequence card8) data)
1367     (type array-index start)
1368     (type card8 depth left-pad)
1369     (type int16 x y)
1370     (type card16 width height)
1371     (type (member :bitmap :xy-pixmap :z-pixmap) format)))
1372    
1373     (defun get-raw-image (drawable &key data (start 0) x y width height
1374     (plane-mask 0xffffffff) format
1375     (result-type '(vector (unsigned-byte 8))))
1376     ;; If data is given, it is modified in place (and returned), otherwise a new
1377     ;; sequence is created and returned, with a size computed from the other arguments
1378     ;; and the returned depth. The sequence is filled with 8-bit quantities, in
1379     ;; transmission format; the caller is responsible for any byte and bit swapping and
1380     ;; compaction required for further local use.
1381     (declare (type drawable drawable)
1382     (type (or null (sequence card8)) data)
1383     (type array-index start)
1384     (type int16 x y)
1385     (type card16 width height)
1386     (type pixel plane-mask)
1387     (type (member :xy-pixmap :z-pixmap) format)
1388     (values (sequence card8) depth visual-info)))
1389    
1390     (defun translate-default (src src-start src-end font dst dst-start)
1391     ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
1392     ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
1393     ;; on context. font is the current font, if known. The function should
1394     ;; translate as many elements of src as possible into indexes in the current
1395     ;; font, and store them into dst. The first return value should be the src
1396     ;; index of the first untranslated element. If no further elements need to
1397     ;; be translated, the second return value should be nil. If a horizontal
1398     ;; motion is required before further translation, the second return value
1399     ;; should be the delta in x coordinate. If a font change is required for
1400     ;; further translation, the second return value should be the new font. If
1401     ;; known, the pixel width of the translated text can be returned as the third
1402     ;; value; this can allow for appending of subsequent output to the same
1403     ;; protocol request, if no overall width has been specified at the higher
1404     ;; level.
1405     (declare (type sequence src)
1406     (type array-index src-start src-end dst-start)
1407     (type (or null font) font)
1408     (type vector dst)
1409     (values array-index (or null int16 font) (or null int32))))
1410    
1411     ;; There is a question below of whether translate should always be required, or
1412     ;; if not, what the default should be or where it should come from. For
1413     ;; example, the default could be something that expected a string as src and
1414     ;; translated the CL standard character set to ASCII indexes, and ignored fonts
1415     ;; and bits. Or the default could expect a string but otherwise be "system
1416     ;; dependent". Or the default could be something that expected a vector of
1417     ;; integers and did no translation. Or the default could come from the
1418     ;; gcontext (but what about text-extents and text-width?).
1419    
1420     (defun text-extents (font sequence &key (start 0) end translate)
1421     ;; If multiple fonts are involved, font-ascent and font-descent will be the
1422     ;; maximums. If multiple directions are involved, the direction will be nil.
1423     ;; Translate will always be called with a 16-bit dst buffer.
1424     (declare (type sequence sequence)
1425     (type (or font gcontext) font)
1426     (type translate translate)
1427     (values width ascent descent left right font-ascent font-descent direction
1428     (or null array-index))))
1429    
1430     (defun text-width (font sequence &key (start 0) end translate)
1431     ;; Translate will always be called with a 16-bit dst buffer.
1432     (declare (type sequence sequence)
1433     (type (or font gcontext) font)
1434     (type translate translate)
1435     (values int32 (or null array-index))))
1436    
1437     ;; This controls the element size of the dst buffer given to translate. If
1438     ;; :default is specified, the size will be based on the current font, if known,
1439     ;; and otherwise 16 will be used. [An alternative would be to pass the buffer
1440     ;; size to translate, and allow it to return the desired size if it doesn't
1441     ;; like the current size. The problem is that the protocol doesn't allow
1442     ;; switching within a single request, so to allow switching would require
1443     ;; knowing the width of text, which isn't necessarily known. We could call
1444     ;; text-width to compute it, but perhaps that is doing too many favors?] [An
1445     ;; additional possibility is to allow an index-size of :two-byte, in which case
1446     ;; translate would be given a double-length 8-bit array, and translate would be
1447     ;; expected to store first-byte/second-byte instead of 16-bit integers.]
1448    
1449     (deftype index-size () '(member :default 8 16))
1450    
1451     ;; In the glyph functions below, if width is specified, it is assumed to be the
1452     ;; total pixel width of whatever string of glyphs is actually drawn.
1453     ;; Specifying width will allow for appending the output of subsequent calls to
1454     ;; the same protocol request, provided gcontext has not been modified in the
1455     ;; interim. If width is not specified, appending of subsequent output might
1456     ;; not occur (unless translate returns the width). Specifying width is simply
1457     ;; a hint, for performance.
1458    
1459     (defun draw-glyph (drawable gcontext x y elt
1460     &key translate width (size :default))
1461     ;; Returns true if elt is output, nil if translate refuses to output it.
1462     ;; Second result is width, if known.
1463     (declare (type drawable drawable)
1464     (type gcontext gcontext)
1465     (type int16 x y)
1466     (type translate translate)
1467     (type (or null int32) width)
1468     (type index-size size)
1469     (values boolean (or null int32))))
1470    
1471     (defun draw-glyphs (drawable gcontext x y sequence
1472     &key (start 0) end translate width (size :default))
1473     ;; First result is new start, if end was not reached. Second result is
1474     ;; overall width, if known.
1475     (declare (type drawable drawable)
1476     (type gcontext gcontext)
1477     (type int16 x y)
1478     (type sequence sequence)
1479     (type array-index start)
1480     (type (or null array-index) end)
1481     (type (or null int32) width)
1482     (type translate translate)
1483     (type index-size size)
1484     (values (or null array-index) (or null int32))))
1485    
1486     (defun draw-image-glyph (drawable gcontext x y elt
1487     &key translate width (size :default))
1488     ;; Returns true if elt is output, nil if translate refuses to output it.
1489     ;; Second result is overall width, if known. An initial font change is
1490     ;; allowed from translate.
1491     (declare (type drawable drawable)
1492     (type gcontext gcontext)
1493     (type int16 x y)
1494     (type translate translate)
1495     (type (or null int32) width)
1496     (type index-size size)
1497     (values boolean (or null int32))))
1498    
1499     (defun draw-image-glyphs (drawable gcontext x y sequence
1500     &key (start 0) end width translate (size :default))
1501     ;; An initial font change is allowed from translate, but any subsequent font
1502     ;; change or horizontal motion will cause termination (because the protocol
1503     ;; doesn't support chaining). [Alternatively, font changes could be accepted
1504     ;; as long as they are accompanied with a width return value, or always
1505     ;; accept font changes and call text-width as required. However, horizontal
1506     ;; motion can't really be accepted, due to semantics.] First result is new
1507     ;; start, if end was not reached. Second result is overall width, if known.
1508     (declare (type drawable drawable)
1509     (type gcontext gcontext)
1510     (type int16 x y)
1511     (type sequence sequence)
1512     (type array-index start)
1513     (type (or null array-index) end)
1514     (type (or null int32) width)
1515     (type translate translate)
1516     (type index-size size)
1517     (values (or null array-index) (or null int32))))
1518    
1519     (defun create-colormap (visual window &optional alloc-p)
1520     (declare (type visual-info visual)
1521     (type window window)
1522     (type boolean alloc-p)
1523     (values colormap)))
1524    
1525     (defun free-colormap (colormap)
1526     (declare (type colormap colormap)))
1527    
1528     (defun copy-colormap-and-free (colormap)
1529     (declare (type colormap colormap)
1530     (values colormap)))
1531    
1532     (defun install-colormap (colormap)
1533     (declare (type colormap colormap)))
1534    
1535     (defun uninstall-colormap (colormap)
1536     (declare (type colormap colormap)))
1537    
1538     (defun installed-colormaps (window &key (result-type 'list))
1539     (declare (type window window)
1540     (type type result-type)
1541     (values (sequence colormap))))
1542    
1543     (defun alloc-color (colormap color)
1544     (declare (type colormap colormap)
1545     (type (or stringable color) color)
1546     (values pixel screen-color exact-color)))
1547    
1548     (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
1549     (declare (type colormap colormap)
1550     (type card16 colors planes)
1551     (type boolean contiguous-p)
1552     (type type result-type)
1553     (values (sequence pixel) (sequence mask))))
1554    
1555     (defun alloc-color-planes (colormap colors
1556     &key (reds 0) (greens 0) (blues 0)
1557     contiguous-p (result-type 'list))
1558     (declare (type colormap colormap)
1559     (type card16 colors reds greens blues)
1560     (type boolean contiguous-p)
1561     (type type result-type)
1562     (values (sequence pixel) red-mask green-mask blue-mask)))
1563    
1564     (defun free-colors (colormap pixels &optional (plane-mask 0))
1565     (declare (type colormap colormap)
1566     (type (sequence pixel) pixels)
1567     (type pixel plane-mask)))
1568    
1569     (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
1570     (declare (type colormap colormap)
1571     (type pixel pixel)
1572     (type (or stringable color) spec)
1573     (type boolean red-p green-p blue-p)))
1574    
1575     (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
1576     ;; If stringables are specified for colors, it is unspecified whether all
1577     ;; stringables are first resolved and then a single StoreColors protocol request is
1578     ;; issued, or whether multiple StoreColors protocol requests are issued.
1579     (declare (type colormap colormap)
1580     (type (repeat-seq (pixel pixel) ((or stringable color) color)) specs)
1581     (type boolean red-p green-p blue-p)))
1582    
1583     (defun query-colors (colormap pixels &key (result-type 'list))
1584     (declare (type colormap colormap)
1585     (type (sequence pixel) pixels)
1586     (type type result-type)
1587     (values (sequence color))))
1588    
1589     (defun lookup-color (colormap name)
1590     (declare (type colormap colormap)
1591     (type stringable name)
1592     (values screen-color true-color)))
1593    
1594     (defun create-cursor (&key source mask x y foreground background)
1595     (declare (type pixmap source)
1596     (type (or null pixmap) mask)
1597     (type card16 x y)
1598     (type color foreground background)
1599     (values cursor)))
1600    
1601     (defun create-glyph-cursor (&key source-font source-char mask-font mask-char
1602     foreground background)
1603     (declare (type font source-font)
1604     (type card16 source-char)
1605     (type (or null font) mask-font)
1606     (type (or null card16) mask-char)
1607     (type color foreground background)
1608     (values cursor)))
1609    
1610     (defun free-cursor (cursor)
1611     (declare (type cursor cursor)))
1612    
1613     (defun recolor-cursor (cursor foreground background)
1614     (declare (type cursor cursor)
1615     (type color foreground background)))
1616    
1617     (defun query-best-cursor (width height drawable)
1618     (declare (type card16 width height)
1619     (type drawable display)
1620     (values width height)))
1621    
1622     (defun query-best-tile (width height drawable)
1623     (declare (type card16 width height)
1624     (type drawable drawable)
1625     (values width height)))
1626    
1627     (defun query-best-stipple (width height drawable)
1628     (declare (type card16 width height)
1629     (type drawable drawable)
1630     (values width height)))
1631    
1632     (defun query-extension (display name)
1633     (declare (type display display)
1634     (type stringable name)
1635     (values major-opcode first-event first-error)))
1636    
1637     (defun list-extensions (display &key (result-type 'list))
1638     (declare (type display display)
1639     (type type result-type)
1640     (values (sequence string))))
1641    
1642     ;; Should pointer-mapping setf be changed to set-pointer-mapping?
1643    
1644     (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
1645     ;; Can signal device-busy.
1646     ;; Setf ought to allow multiple values.
1647     ;; Returns true for success, nil for failure
1648     (declare (type display display)
1649     (type (sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5)
1650     (values (member :success :busy :failed))))
1651    
1652     (defun modifier-mapping (display)
1653     ;; each value is a list of card8s
1654     (declare (type display display)
1655     (values shift lock control mod1 mod2 mod3 mod4 mod5)))
1656    
1657     ;; Either we will want lots of defconstants for well-known values, or perhaps
1658     ;; an integer-to-keyword translation function for well-known values.
1659    
1660     (defun change-keyboard-mapping (display keysyms
1661     &key (start 0) end (first-keycode start))
1662     ;; start/end give subrange of keysyms
1663     ;; first-keycode is the first-keycode to store at
1664     (declare (type display display)
1665     (type (array * (* *)) keysyms)
1666     (type array-index start)
1667     (type (or null array-index) end)
1668     (type card8 first-keycode)))
1669    
1670     (defun keyboard-mapping (display &key first-keycode start end data)
1671     ;; First-keycode specifies which keycode to start at (defaults to
1672     ;; min-keycode). Start specifies where (in result) to put first-keycode
1673     ;; (defaults to first-keycode). (- end start) is the number of keycodes to
1674     ;; get (end defaults to (1+ max-keycode)). If data is specified, the results
1675     ;; are put there.
1676     (declare (type display display)
1677     (type (or null card8) first-keycode)
1678     (type (or null array-index) start end)
1679     (type (or null (array * (* *))) data)
1680     (values (array * (* *)))))
1681    
1682     (defun change-keyboard-control (display &key key-click-percent
1683     bell-percent bell-pitch bell-duration
1684     led led-mode key auto-repeat-mode)
1685     (declare (type display display)
1686     (type (or null (member :default) int16) key-click-percent
1687     bell-percent bell-pitch bell-duration)
1688     (type (or null card8) led key)
1689     (type (or null (member :on :off)) led-mode)
1690     (type (or null (member :on :off :default)) auto-repeat-mode)))
1691    
1692     (defun keyboard-control (display)
1693     (declare (type display display)
1694     (values key-click-percent bell-percent bell-pitch bell-duration
1695     led-mask global-auto-repeat auto-repeats)))
1696    
1697     (defun bell (display &optional (percent-from-normal 0))
1698     ;; It is assumed that an eventual audio extension to X will provide more complete
1699     ;; control.
1700     (declare (type display display)
1701     (type int8 percent-from-normal)))
1702    
1703     (defun pointer-mapping (display &key (result-type 'list))
1704     (declare (type display display)
1705     (type type result-type)
1706     (values (sequence card8))))
1707    
1708     (defsetf pointer-mapping (display) (map)
1709     ;; Can signal device-busy.
1710     (declare (type display display)
1711     (type (sequence card8) map)))
1712    
1713     (defun change-pointer-control (display &key acceleration threshold)
1714     ;; Acceleration is rationalized if necessary.
1715     (declare (type display display)
1716     (type (or null (member :default) number) acceleration)
1717     (type (or null (member :default) integer) threshold)))
1718    
1719     (defun pointer-control (display)
1720     (declare (type display display)
1721     (values acceleration threshold)))
1722    
1723     (defun set-screen-saver (display timeout interval blanking exposures)
1724     ;; Setf ought to allow multiple values.
1725     ;; Timeout and interval are in seconds, will be rounded to minutes.
1726     (declare (type display display)
1727     (type (or (member :default) int16) timeout interval)
1728     (type (member :on :off :default) blanking exposures)))
1729    
1730     (defun screen-saver (display)
1731     ;; Returns timeout and interval in seconds.
1732     (declare (type display display)
1733     (values timeout interval blanking exposures)))
1734    
1735     (defun activate-screen-saver (display)
1736     (declare (type display display)))
1737    
1738     (defun reset-screen-saver (display)
1739     (declare (type display display)))
1740    
1741     (defun add-access-host (display host)
1742     ;; A string must be acceptable as a host, but otherwise the possible types for host
1743     ;; are not constrained, and will likely be very system dependent.
1744     (declare (type display display)))
1745    
1746     (defun remove-access-host (display host)
1747     ;; A string must be acceptable as a host, but otherwise the possible types for host
1748     ;; are not constrained, and will likely be very system dependent.
1749     (declare (type display display)))
1750    
1751     (defun access-hosts (display &key (result-type 'list))
1752     ;; The type of host objects returned is not constrained, except that the hosts must
1753     ;; be acceptable to add-access-host and remove-access-host.
1754     (declare (type display display)
1755     (type type result-type)
1756     (values (sequence host) enabled-p)))
1757    
1758     (defun access-control (display)
1759     ;; setf'able
1760     (declare (type display display)
1761     (values boolean)))
1762    
1763     (defun close-down-mode (display)
1764     ;; setf'able
1765     ;; Cached locally in display object.
1766     (declare (type display display)
1767     (values (member :destroy :retain-permanent :retain-temporary))))
1768    
1769     (defun kill-client (display resource-id)
1770     (declare (type display display)
1771     (type resource-id resource-id)))
1772    
1773     (defun kill-temporary-clients (display)
1774     (declare (type display display)))
1775    
1776     (defun make-event-mask (&rest keys)
1777     ;; This is only defined for core events.
1778     ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
1779     (declare (type (list event-mask-class) keys)
1780     (values mask32)))
1781    
1782     (defun make-event-keys (event-mask)
1783     ;; This is only defined for core events.
1784     (declare (type mask32 event-mask)
1785     (values (list event-mask-class))))
1786    
1787     (defun make-state-mask (&rest keys)
1788     ;; Useful for constructing modifier-mask, state-mask.
1789     (declare (type (list state-mask-key) keys)
1790     (values mask16)))
1791    
1792     (defun make-state-keys (state-mask)
1793     (declare (type mask16 mask)
1794     (values (list state-mask-key))))
1795    
1796     (defmacro with-event-queue ((display) &body body)
1797     ;; Grants exclusive access to event queue.
1798     )
1799    
1800     (defun event-listen (display &optional (timeout 0))
1801     (declare (type display display)
1802     (type (or null number) timeout)
1803     (values (or null number) (or null (member :timeout) (not null))))
1804     ;; Returns the number of events queued locally, if any, else nil. Hangs
1805     ;; waiting for events, forever if timeout is nil, else for the specified
1806     ;; number of seconds. The second value returned is :timeout if the
1807     ;; operation timed out, and some other non-nil value if an EOF has been
1808     ;; detected.
1809     )
1810    
1811     (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
1812     ;; If force-output-p is true, first invokes display-force-output. Invokes
1813     ;; handler on each queued event until handler returns non-nil, and that
1814     ;; returned object is then returned by process-event. If peek-p is true,
1815     ;; then the event is not removed from the queue. If discard-p is true, then
1816     ;; events for which handler returns nil are removed from the queue,
1817     ;; otherwise they are left in place. Hangs until non-nil is generated for
1818     ;; some event, or for the specified timeout (in seconds, if given); however,
1819     ;; it is acceptable for an implementation to wait only once on network data,
1820     ;; and therefore timeout prematurely. Returns nil on timeout or EOF, with a
1821     ;; second return value being :timeout for a timeout and some other non-nil
1822     ;; value for EOF. If handler is a sequence, it is expected to contain
1823     ;; handler functions specific to each event class; the event code is used to
1824     ;; index the sequence, fetching the appropriate handler. The arguments to
1825     ;; the handler are described further below using declare-event. If
1826     ;; process-event is invoked recursively, the nested invocation begins with
1827     ;; the event after the one currently being processed.
1828     (declare (type display display)
1829     (type (or (sequence (function (&rest key-vals) t))
1830     (function (&rest key-vals) t))
1831     handler)
1832     (type (or null number) timeout)
1833     (type boolean peek-p)))
1834    
1835     (defun make-event-handlers (&key (type 'array) default)
1836     (declare (type t type) ;Sequence type specifier
1837     (type function default)
1838     (values sequence)) ;Default handler for initial content
1839     ;; Makes a handler sequence suitable for process-event
1840     )
1841    
1842     (defun event-handler (handlers event-key)
1843     (declare (type sequence handlers)
1844     (type event-key event-key)
1845     (values function))
1846     ;; Accessor for a handler sequence
1847     )
1848    
1849     (defsetf event-handler (handlers event-key) (handler)
1850     (declare (type sequence handlers)
1851     (type event-key event-key)
1852     (type function handler)
1853     (values function))
1854     ;; Setf accessor for a handler sequence
1855     )
1856    
1857     (defmacro event-case ((display &key timeout peek-p discard-p (force-output-p t))
1858     &body clauses)
1859     (declare (arglist (display &key timeout peek-p discard-p force-output-p)
1860     (event-or-events ((&rest args) |...|) &body body) |...|))
1861     ;; If force-output-p is true, first invokes display-force-output. Executes
1862     ;; the matching clause for each queued event until a clause returns non-nil,
1863     ;; and that returned object is then returned by event-case. If peek-p is
1864     ;; true, then the event is not removed from the queue. If discard-p is
1865     ;; true, then events for which the clause returns nil are removed from the
1866     ;; queue, otherwise they are left in place. Hangs until non-nil is
1867     ;; generated for some event, or for the specified timeout (in seconds, if
1868     ;; given); however, it is acceptable for an implementation to wait only once
1869     ;; on network data, and therefore timeout prematurely. Returns nil on
1870     ;; timeout or EOF with a second return value being :timeout for a timeout
1871     ;; and some other non-nil value for EOF. In each clause, event-or-events is
1872     ;; an event-key or a list of event-keys (but they need not be typed as
1873     ;; keywords) or the symbol t or otherwise (but only in the last clause).
1874     ;; The keys are not evaluated, and it is an error for the same key to appear
1875     ;; in more than one clause. Args is the list of event components of
1876     ;; interest; corresponding values (if any) are bound to variables with these
1877     ;; names (i.e., the args are variable names, not keywords, the keywords are
1878     ;; derived from the variable names). An arg can also be a (keyword var)
1879     ;; form, as for keyword args in a lambda lists. If no t/otherwise clause
1880     ;; appears, it is equivalent to having one that returns nil. If
1881     ;; process-event is invoked recursively, the nested invocation begins with
1882     ;; the event after the one currently being processed.
1883     )
1884    
1885     (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
1886     &body clauses)
1887     ;; The clauses of event-cond are of the form:
1888     ;; (event-or-events binding-list test-form . body-forms)
1889     ;;
1890     ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they
1891     ;; need not be typed as keywords) or the symbol t
1892     ;; or otherwise (but only in the last clause). If
1893     ;; no t/otherwise clause appears, it is equivalent
1894     ;; to having one that returns nil. The keys are
1895     ;; not evaluated, and it is an error for the same
1896     ;; key to appear in more than one clause.
1897     ;;
1898     ;; BINDING-LIST The list of event components of interest.
1899     ;; corresponding values (if any) are bound to
1900     ;; variables with these names (i.e., the binding-list
1901     ;; has variable names, not keywords, the keywords are
1902     ;; derived from the variable names). An arg can also
1903     ;; be a (keyword var) form, as for keyword args in a
1904     ;; lambda list.
1905     ;;
1906     ;; The matching TEST-FORM for each queued event is executed until a
1907     ;; clause's test-form returns non-nil. Then the BODY-FORMS are
1908     ;; evaluated, returning the (possibly multiple) values of the last
1909     ;; form from event-cond. If there are no body-forms then, if the
1910     ;; test-form is non-nil, the value of the test-form is returned as a
1911     ;; single value.
1912     ;;
1913     ;; Options:
1914     ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no
1915     ;; input is pending.
1916     ;;
1917     ;; PEEK-P When true, then the event is not removed from the queue.
1918     ;;
1919     ;; DISCARD-P When true, then events for which the clause returns nil
1920     ;; are removed from the queue, otherwise they are left in place.
1921     ;;
1922     ;; TIMEOUT If NIL, hang until non-nil is generated for some event's
1923     ;; test-form. Otherwise return NIL after TIMEOUT seconds have
1924     ;; elapsed. NIL is also returned whenever EOF is read.
1925     ;; Whenever NIL is returned a second value is returned which
1926     ;; is either :TIMEOUT if a timeout occurred or some other
1927     ;; non-NIL value if an EOF is detected.
1928     ;;
1929     (declare (arglist (display &key timeout peek-p discard-p force-output-p)
1930     (event-or-events (&rest args) test-form &body body) |...|))
1931     )
1932    
1933     (defun discard-current-event (display)
1934     (declare (type display display)
1935     (values boolean))
1936     ;; Discard the current event for DISPLAY.
1937     ;; Returns NIL when the event queue is empty, else T.
1938     ;; To ensure events aren't ignored, application code should only call
1939     ;; this when throwing out of event-case or process-next-event, or from
1940     ;; inside even-case, event-cond or process-event when :peek-p is T and
1941     ;; :discard-p is NIL.
1942     )
1943    
1944     (defmacro declare-event (event-codes &rest declares)
1945     ;; Used to indicate the keyword arguments for handler functions in process-event
1946     ;; and event-case. In the declares, an argument listed as (name1 name2) indicates
1947     ;; synonyms for the same argument. All process-event handlers can have
1948     ;; (display display), (event-key event-key), and (boolean send-event-p) as keyword
1949     ;; arguments, and an event-case clause can also have event-key and send-event-p as
1950     ;; arguments.
1951     (declare (arglist event-key-or-keys &rest (type &rest keywords))))
1952    
1953     (declare-event (:key-press :key-release :button-press :button-release)
1954     (card16 sequence)
1955     (window (window event-window) root)
1956     ((or null window) child)
1957     (boolean same-screen-p)
1958     (int16 x y root-x root-y)
1959     (card16 state)
1960 ram 1.2 ((or null card32) time)
1961 ram 1.1 ;; for key-press and key-release, code is the keycode
1962     ;; for button-press and button-release, code is the button number
1963     (card8 code))
1964    
1965     (declare-event :motion-notify
1966     (card16 sequence)
1967     (window (window event-window) root)
1968     ((or null window) child)
1969     (boolean same-screen-p)
1970     (int16 x y root-x root-y)
1971     (card16 state)
1972 ram 1.2 ((or null card32) time)
1973 ram 1.1 (boolean hint-p))
1974    
1975     (declare-event (:enter-notify :leave-notify)
1976     (card16 sequence)
1977     (window (window event-window) root)
1978     ((or null window) child)
1979     (boolean same-screen-p)
1980     (int16 x y root-x root-y)
1981     (card16 state)
1982 ram 1.2 ((or null card32) time)
1983 ram 1.1 ((member :normal :grab :ungrab) mode)
1984     ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind)
1985     (boolean focus-p))
1986    
1987     (declare-event (:focus-in :focus-out)
1988     (card16 sequence)
1989     (window (window event-window))
1990     ((member :normal :while-grabbed :grab :ungrab) mode)
1991     ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
1992     :pointer :pointer-root :none)
1993     kind))
1994    
1995     (declare-event :keymap-notify
1996     ((bit-vector 256) keymap))
1997    
1998     (declare-event :exposure
1999     (card16 sequence)
2000     (window (window event-window))
2001     (card16 x y width height count))
2002    
2003     (declare-event :graphics-exposure
2004     (card16 sequence)
2005     (drawable (drawable event-window))
2006     (card16 x y width height count)
2007     (card8 major)
2008     (card16 minor))
2009    
2010     (declare-event :no-exposure
2011     (card16 sequence)
2012     (drawable (drawable event-window))
2013     (card8 major)
2014     (card16 minor))
2015    
2016     (declare-event :visibility-notify
2017     (card16 sequence)
2018     (window (window event-window))
2019     ((member :unobscured :partially-obscured :fully-obscured) state))
2020    
2021     (declare-event :create-notify
2022     (card16 sequence)
2023     (window window (parent event-window))
2024     (int16 x y)
2025     (card16 width height border-width)
2026     (boolean override-redirect-p))
2027    
2028     (declare-event :destroy-notify
2029     (card16 sequence)
2030     (window event-window window))
2031    
2032     (declare-event :unmap-notify
2033     (card16 sequence)
2034     (window event-window window)
2035     (boolean configure-p))
2036    
2037     (declare-event :map-notify
2038     (card16 sequence)
2039     (window event-window window)
2040     (boolean override-redirect-p))
2041    
2042     (declare-event :map-request
2043     (card16 sequence)
2044     (window (parent event-window) window))
2045    
2046     (declare-event :reparent-notify
2047     (card16 sequence)
2048     (window event-window window parent)
2049     (int16 x y)
2050     (boolean override-redirect-p))
2051    
2052     (declare-event :configure-notify
2053     (card16 sequence)
2054     (window event-window window)
2055     (int16 x y)
2056     (card16 width height border-width)
2057     ((or null window) above-sibling)
2058     (boolean override-redirect-p))
2059    
2060     (declare-event :gravity-notify
2061     (card16 sequence)
2062     (window event-window window)
2063     (int16 x y))
2064    
2065     (declare-event :resize-request
2066     (card16 sequence)
2067     (window (window event-window))
2068     (card16 width height))
2069    
2070     (declare-event :configure-request
2071     (card16 sequence)
2072     (window (parent event-window) window)
2073     (int16 x y)
2074     (card16 width height border-width)
2075     ((member :above :below :top-if :bottom-if :opposite) stack-mode)
2076     ((or null window) above-sibling)
2077     (mask16 value-mask))
2078    
2079     (declare-event :circulate-notify
2080     (card16 sequence)
2081     (window event-window window)
2082     ((member :top :bottom) place))
2083    
2084     (declare-event :circulate-request
2085     (card16 sequence)
2086     (window (parent event-window) window)
2087     ((member :top :bottom) place))
2088    
2089     (declare-event :property-notify
2090     (card16 sequence)
2091     (window (window event-window))
2092     (keyword atom)
2093     ((member :new-value :deleted) state)
2094 ram 1.2 ((or null card32) time))
2095 ram 1.1
2096     (declare-event :selection-clear
2097     (card16 sequence)
2098     (window (window event-window))
2099     (keyword selection)
2100 ram 1.2 ((or null card32) time))
2101 ram 1.1
2102     (declare-event :selection-request
2103     (card16 sequence)
2104     (window (window event-window) requestor)
2105     (keyword selection target)
2106     ((or null keyword) property)
2107 ram 1.2 ((or null card32) time))
2108 ram 1.1
2109     (declare-event :selection-notify
2110     (card16 sequence)
2111     (window (window event-window))
2112     (keyword selection target)
2113     ((or null keyword) property)
2114 ram 1.2 ((or null card32) time))
2115 ram 1.1
2116     (declare-event :colormap-notify
2117     (card16 sequence)
2118     (window (window event-window))
2119     ((or null colormap) colormap)
2120     (boolean new-p installed-p))
2121    
2122     (declare-event :mapping-notify
2123     (card16 sequence)
2124     ((member :modifier :keyboard :pointer) request)
2125     (card8 start count))
2126    
2127     (declare-event :client-message
2128     (card16 sequence)
2129     (window (window event-window))
2130     ((member 8 16 32) format)
2131     ((sequence integer) data))
2132    
2133     (defun queue-event (display event-key &rest args &key append-p &allow-other-keys)
2134     ;; The event is put at the head of the queue if append-p is nil, else the tail.
2135     ;; Additional arguments depend on event-key, and are as specified above with
2136     ;; declare-event, except that both resource-ids and resource objects are accepted
2137     ;; in the event components.
2138     (declare (type display display)
2139     (type event-key event-key)
2140     (type boolean append-p)))
2141    
2142    
2143    
2144     ;;; From here on, there has been less coherent review of the interface:
2145    
2146     ;;;-----------------------------------------------------------------------------
2147     ;;; Window Manager Property functions
2148    
2149     (defun wm-name (window)
2150     (declare (type window window)