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

Contents of /src/clx/doc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sat Dec 19 15:21:16 1998 UTC (15 years, 4 months ago) by dtc
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +3 -0 lines
Add CMUCL style file-comment's; from Peter Van Eynde.
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 #+cmu
18 (ext:file-comment
19 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/doc.lisp,v 1.4 1998/12/19 15:21:16 dtc Rel $")
20
21 ;; Version 4
22
23 ;; This is considered a somewhat changeable interface. Discussion of better
24 ;; integration with CLOS, support for user-specified subclassess of basic
25 ;; objects, and the additional functionality to match the C Xlib is still in
26 ;; progress.
27
28 ;; Primary Interface Author:
29 ;; Robert W. Scheifler
30 ;; MIT Laboratory for Computer Science
31 ;; 545 Technology Square, Room 418
32 ;; Cambridge, MA 02139
33 ;; rws@zermatt.lcs.mit.edu
34
35 ;; Design Contributors:
36 ;; Dan Cerys, Texas Instruments
37 ;; Scott Fahlman, CMU
38 ;; Charles Hornig, Symbolics
39 ;; John Irwin, Franz
40 ;; Kerry Kimbrough, Texas Instruments
41 ;; Chris Lindblad, MIT
42 ;; Rob MacLachlan, CMU
43 ;; Mike McMahon, Symbolics
44 ;; David Moon, Symbolics
45 ;; LaMott Oren, Texas Instruments
46 ;; Daniel Weinreb, Symbolics
47 ;; John Wroclawski, MIT
48 ;; Richard Zippel, Symbolics
49
50 ;; CLX Extensions
51 ;; Adds some of the functionality provided by the C XLIB library.
52 ;;
53 ;; Primary Author
54 ;; LaMott G. Oren
55 ;; Texas Instruments
56 ;;
57 ;; Design Contributors:
58 ;; Robert W. Scheifler, MIT
59
60
61 ;; Note: all of the following is in the package XLIB.
62
63 (declaim (declaration arglist clx-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 (clx-values display)))
110
111 (defun <mumble>-id (<mumble>)
112 (declare (type <mumble> <mumble>)
113 (clx-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 (clx-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 (clx-values color)))
133
134 (defun color-rgb (color)
135 (declare (type color color)
136 (clx-values red green blue)))
137
138 (defun color-red (color)
139 ;; setf'able
140 (declare (type color color)
141 (clx-values rgb-val)))
142
143 (defun color-green (color)
144 ;; setf'able
145 (declare (type color color)
146 (clx-values rgb-val)))
147
148 (defun color-blue (color)
149 ;; setf'able
150 (declare (type color color)
151 (clx-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 (deftype clx-list (&optional element-type) 'list)
191 (deftype clx-sequence (&optional element-type) 'sequence)
192
193 ;; A sequence, containing zero or more repetitions of the given elements,
194 ;; with the elements expressed as (type name).
195
196 (deftype repeat-seq (&rest elts) 'sequence)
197
198 (deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
199
200 (deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
201
202 (deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
203
204 ;; Note that we are explicitly using a different angle representation than what
205 ;; is actually transmitted in the protocol.
206
207 (deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
208
209 (deftype arc-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
210 (angle angle1) (angle angle2)))
211
212 (deftype event-mask-class ()
213 '(member :key-press :key-release :owner-grab-button :button-press :button-release
214 :enter-window :leave-window :pointer-motion :pointer-motion-hint
215 :button-1-motion :button-2-motion :button-3-motion :button-4-motion
216 :button-5-motion :button-motion :exposure :visibility-change
217 :structure-notify :resize-redirect :substructure-notify :substructure-redirect
218 :focus-change :property-change :colormap-change :keymap-state))
219
220 (deftype event-mask ()
221 '(or mask32 (clx-list event-mask-class)))
222
223 (deftype pointer-event-mask-class ()
224 '(member :button-press :button-release
225 :enter-window :leave-window :pointer-motion :pointer-motion-hint
226 :button-1-motion :button-2-motion :button-3-motion :button-4-motion
227 :button-5-motion :button-motion :keymap-state))
228
229 (deftype pointer-event-mask ()
230 '(or mask32 (clx-list pointer-event-mask-class)))
231
232 (deftype device-event-mask-class ()
233 '(member :key-press :key-release :button-press :button-release :pointer-motion
234 :button-1-motion :button-2-motion :button-3-motion :button-4-motion
235 :button-5-motion :button-motion))
236
237 (deftype device-event-mask ()
238 '(or mask32 (clx-list device-event-mask-class)))
239
240 (deftype modifier-key ()
241 '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
242
243 (deftype modifier-mask ()
244 '(or (member :any) mask16 (clx-list modifier-key)))
245
246 (deftype state-mask-key ()
247 '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
248
249 (deftype gcontext-key ()
250 '(member :function :plane-mask :foreground :background
251 :line-width :line-style :cap-style :join-style :fill-style :fill-rule
252 :arc-mode :tile :stipple :ts-x :ts-y :font :subwindow-mode
253 :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes))
254
255 (deftype event-key ()
256 '(member :key-press :key-release :button-press :button-release :motion-notify
257 :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
258 :exposure :graphics-exposure :no-exposure :visibility-notify
259 :create-notify :destroy-notify :unmap-notify :map-notify :map-request
260 :reparent-notify :configure-notify :gravity-notify :resize-request
261 :configure-request :circulate-notify :circulate-request :property-notify
262 :selection-clear :selection-request :selection-notify
263 :colormap-notify :client-message))
264
265 (deftype error-key ()
266 '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
267 :illegal-request :implementation :length :match :name :pixmap :value :window))
268
269 (deftype draw-direction ()
270 '(member :left-to-right :right-to-left))
271
272 (defstruct bitmap-format
273 (unit <unspec> :type (member 8 16 32))
274 (pad <unspec> :type (member 8 16 32))
275 (lsb-first-p <unspec> :type boolean))
276
277 (defstruct pixmap-format
278 (depth <unspec> :type image-depth)
279 (bits-per-pixel <unspec> :type (member 1 4 8 16 24 32))
280 (pad <unspec> :type (member 8 16 32)))
281
282 (defstruct visual-info
283 (id <unspec> :type resource-id)
284 (display <unspec> :type display)
285 (class <unspec> :type (member :static-gray :static-color :true-color
286 :gray-scale :pseudo-color :direct-color))
287 (red-mask <unspec> :type pixel)
288 (green-mask <unspec> :type pixel)
289 (blue-mask <unspec> :type pixel)
290 (bits-per-rgb <unspec> :type card8)
291 (colormap-entries <unspec> :type card16))
292
293 (defstruct screen
294 (root <unspec> :type window)
295 (width <unspec> :type card16)
296 (height <unspec> :type card16)
297 (width-in-millimeters <unspec> :type card16)
298 (height-in-millimeters <unspec> :type card16)
299 (depths <unspec> :type (alist (image-depth depth) ((clx-list visual-info) visuals)))
300 (root-depth <unspec> :type image-depth)
301 (root-visual-info <unspec> :type visual-info)
302 (default-colormap <unspec> :type colormap)
303 (white-pixel <unspec> :type pixel)
304 (black-pixel <unspec> :type pixel)
305 (min-installed-maps <unspec> :type card16)
306 (max-installed-maps <unspec> :type card16)
307 (backing-stores <unspec> :type (member :never :when-mapped :always))
308 (save-unders-p <unspec> :type boolean)
309 (event-mask-at-open <unspec> :type mask32))
310
311 (defun screen-root-visual (screen)
312 (declare (type screen screen)
313 (clx-values resource-id)))
314
315 ;; The list contains alternating keywords and integers.
316
317 (deftype font-props () 'list)
318
319 (defun open-display (host &key (display 0) protocol)
320 ;; A string must be acceptable as a host, but otherwise the possible types for host
321 ;; and protocol are not constrained, and will likely be very system dependent. The
322 ;; default protocol is system specific. Authorization, if any, is assumed to come
323 ;; from the environment somehow.
324 (declare (type integer display)
325 (clx-values display)))
326
327 (defun display-protocol-major-version (display)
328 (declare (type display display)
329 (clx-values card16)))
330
331 (defun display-protocol-minor-version (display)
332 (declare (type display display)
333 (clx-values card16)))
334
335 (defun display-vendor-name (display)
336 (declare (type display display)
337 (clx-values string)))
338
339 (defun display-release-number (display)
340 (declare (type display display)
341 (clx-values card32)))
342
343 (defun display-image-lsb-first-p (display)
344 (declare (type display display)
345 (clx-values boolean)))
346
347 (defun display-bitmap-formap (display)
348 (declare (type display display)
349 (clx-values bitmap-format)))
350
351 (defun display-pixmap-formats (display)
352 (declare (type display display)
353 (clx-values (clx-list pixmap-formats))))
354
355 (defun display-roots (display)
356 (declare (type display display)
357 (clx-values (clx-list screen))))
358
359 (defun display-motion-buffer-size (display)
360 (declare (type display display)
361 (clx-values card32)))
362
363 (defun display-max-request-length (display)
364 (declare (type display display)
365 (clx-values card16)))
366
367 (defun display-min-keycode (display)
368 (declare (type display display)
369 (clx-values card8)))
370
371 (defun display-max-keycode (display)
372 (declare (type display display)
373 (clx-values card8)))
374
375 (defun close-display (display)
376 (declare (type display display)))
377
378 (defun display-error-handler (display)
379 (declare (type display display)
380 (clx-values handler)))
381
382 (defsetf display-error-handler (display) (handler)
383 ;; All errors (synchronous and asynchronous) are processed by calling an error
384 ;; handler in the display. If handler is a sequence it is expected to contain
385 ;; handler functions specific to each error; the error code is used to index the
386 ;; sequence, fetching the appropriate handler. Any results returned by the handler
387 ;; are ignored; it is assumed the handler either takes care of the error
388 ;; completely, or else signals. For all core errors, the keyword/value argument
389 ;; pairs are:
390 ;; :major card8
391 ;; :minor card16
392 ;; :sequence card16
393 ;; :current-sequence card16
394 ;; :asynchronous (member t nil)
395 ;; For :colormap, :cursor, :drawable, :font, :gcontext, :id-choice, :pixmap, and
396 ;; :window errors another pair is:
397 ;; :resource-id card32
398 ;; For :atom errors, another pair is:
399 ;; :atom-id card32
400 ;; For :value errors, another pair is:
401 ;; :value card32
402 (declare (type display display)
403 (type (or (clx-sequence (function (display symbol &key &allow-other-keys)))
404 (function (display symbol &key &allow-other-keys)))
405 handler)))
406
407 (defsetf display-report-asynchronous-errors (display) (when)
408 ;; Most useful in multi-process lisps.
409 ;;
410 ;; Synchronous errors are always signalled in the process that made the
411 ;; synchronous request. An error is considered synchronous if a process is
412 ;; waiting for a reply with the same request-id as the error.
413 ;;
414 ;; Asynchronous errors can be signalled at any one of these three times:
415 ;;
416 ;; 1. As soon as they are read. They get signalled in whichever process
417 ;; was doing the reading. This is enabled by
418 ;; (setf (xlib:display-report-asynchronous-errors display)
419 ;; '(:immediately))
420 ;; This is the default.
421 ;;
422 ;; 2. Before any events are to be handled. You get these by doing an
423 ;; event-listen with any timeout value other than 0, or in of the event
424 ;; processing forms. This is useful if you using a background process to
425 ;; handle input. This is enabled by
426 ;; (setf (xlib:display-report-asynchronous-errors display)
427 ;; '(:before-event-handling))
428 ;;
429 ;; 3. After a display-finish-output. You get these by doing a
430 ;; display-finish-output. A cliche using this might have a with-display
431 ;; wrapped around the display operations that possibly cause an asynchronous
432 ;; error, with a display-finish-output right the end of the with-display to
433 ;; catch any asynchronous errors. This is enabled by
434 ;; (setf (xlib:display-report-asynchronous-errors display)
435 ;; '(:after-finish-output))
436 ;;
437 ;; You can select any combination of the three keywords. For example, to
438 ;; get errors reported before event handling and after finish-output,
439 ;; (setf (xlib:display-report-asynchronous-errors display)
440 ;; '(:before-event-handling :after-finish-output))
441 (declare (type list when))
442 )
443
444 (defmacro define-condition (name base &body items)
445 ;; just a place-holder here for the real thing
446 )
447
448 (define-condition request-error error
449 display
450 major
451 minor
452 sequence
453 current-sequence
454 asynchronous)
455
456 (defun default-error-handler (display error-key &key &allow-other-keys)
457 ;; The default display-error-handler.
458 ;; It signals the conditions listed below.
459 (declare (type display display)
460 (type symbol error-key))
461 )
462
463 (define-condition resource-error request-error
464 resource-id)
465
466 (define-condition access-error request-error)
467
468 (define-condition alloc-error request-error)
469
470 (define-condition atom-error request-error
471 atom-id)
472
473 (define-condition colormap-error resource-error)
474
475 (define-condition cursor-error resource-error)
476
477 (define-condition drawable-error resource-error)
478
479 (define-condition font-error resource-error)
480
481 (define-condition gcontext-error resource-error)
482
483 (define-condition id-choice-error resource-error)
484
485 (define-condition illegal-request-error request-error)
486
487 (define-condition implementation-error request-error)
488
489 (define-condition length-error request-error)
490
491 (define-condition match-error request-error)
492
493 (define-condition name-error request-error)
494
495 (define-condition pixmap-error resource-error)
496
497 (define-condition value-error request-error
498 value)
499
500 (define-condition window-error resource-error)
501
502 (defmacro with-display ((display) &body body)
503 ;; This macro is for use in a multi-process environment. It provides exclusive
504 ;; access to the local display object for multiple request generation. It need not
505 ;; provide immediate exclusive access for replies; that is, if another process is
506 ;; waiting for a reply (while not in a with-display), then synchronization need not
507 ;; (but can) occur immediately. Except where noted, all routines effectively
508 ;; contain an implicit with-display where needed, so that correct synchronization
509 ;; is always provided at the interface level on a per-call basis. Nested uses of
510 ;; this macro will work correctly. This macro does not prevent concurrent event
511 ;; processing; see with-event-queue.
512 )
513
514 (defun display-force-output (display)
515 ;; Output is normally buffered; this forces any buffered output.
516 (declare (type display display)))
517
518 (defun display-finish-output (display)
519 ;; Forces output, then causes a round-trip to ensure that all possible errors and
520 ;; events have been received.
521 (declare (type display display)))
522
523 (defun display-after-function (display)
524 ;; setf'able
525 ;; If defined, called after every protocol request is generated, even those inside
526 ;; explicit with-display's, but never called from inside the after-function itself.
527 ;; The function is called inside the effective with-display for the associated
528 ;; request. Default value is nil. Can be set, for example, to
529 ;; #'display-force-output or #'display-finish-output.
530 (declare (type display display)
531 (clx-values (or null (function (display))))))
532
533 (defun create-window (&key parent x y width height (depth 0) (border-width 0)
534 (class :copy) (visual :copy)
535 background border gravity bit-gravity
536 backing-store backing-planes backing-pixel save-under
537 event-mask do-not-propagate-mask override-redirect
538 colormap cursor)
539 ;; Display is obtained from parent. Only non-nil attributes are passed on in the
540 ;; request: the function makes no assumptions about what the actual protocol
541 ;; defaults are. Width and height are the inside size, excluding border.
542 (declare (type window parent)
543 (type int16 x y)
544 (type card16 width height depth border-width)
545 (type (member :copy :input-output :input-only) class)
546 (type (or (member :copy) visual-info) visual)
547 (type (or null (member :none :parent-relative) pixel pixmap) background)
548 (type (or null (member :copy) pixel pixmap) border)
549 (type (or null win-gravity) gravity)
550 (type (or null bit-gravity) bit-gravity)
551 (type (or null (member :not-useful :when-mapped :always) backing-store))
552 (type (or null pixel) backing-planes backing-pixel)
553 (type (or null event-mask) event-mask)
554 (type (or null device-event-mask) do-not-propagate-mask)
555 (type (or null (member :on :off)) save-under override-redirect)
556 (type (or null (member :copy) colormap) colormap)
557 (type (or null (member :none) cursor) cursor)
558 (clx-values window)))
559
560 (defun window-class (window)
561 (declare (type window window)
562 (clx-values (member :input-output :input-only))))
563
564 (defun window-visual-info (window)
565 (declare (type window window)
566 (clx-values visual-info)))
567
568 (defun window-visual (window)
569 (declare (type window window)
570 (clx-values resource-id)))
571
572 (defsetf window-background (window) (background)
573 (declare (type window window)
574 (type (or (member :none :parent-relative) pixel pixmap) background)))
575
576 (defsetf window-border (window) (border)
577 (declare (type window window)
578 (type (or (member :copy) pixel pixmap) border)))
579
580 (defun window-gravity (window)
581 ;; setf'able
582 (declare (type window window)
583 (clx-values win-gravity)))
584
585 (defun window-bit-gravity (window)
586 ;; setf'able
587 (declare (type window window)
588 (clx-values bit-gravity)))
589
590 (defun window-backing-store (window)
591 ;; setf'able
592 (declare (type window window)
593 (clx-values (member :not-useful :when-mapped :always))))
594
595 (defun window-backing-planes (window)
596 ;; setf'able
597 (declare (type window window)
598 (clx-values pixel)))
599
600 (defun window-backing-pixel (window)
601 ;; setf'able
602 (declare (type window window)
603 (clx-values pixel)))
604
605 (defun window-save-under (window)
606 ;; setf'able
607 (declare (type window window)
608 (clx-values (member :on :off))))
609
610 (defun window-event-mask (window)
611 ;; setf'able
612 (declare (type window window)
613 (clx-values mask32)))
614
615 (defun window-do-not-propagate-mask (window)
616 ;; setf'able
617 (declare (type window window)
618 (clx-values mask32)))
619
620 (defun window-override-redirect (window)
621 ;; setf'able
622 (declare (type window window)
623 (clx-values (member :on :off))))
624
625 (defun window-colormap (window)
626 (declare (type window window)
627 (clx-values (or null colormap))))
628
629 (defsetf window-colormap (window) (colormap)
630 (declare (type window window)
631 (type (or (member :copy) colormap) colormap)))
632
633 (defsetf window-cursor (window) (cursor)
634 (declare (type window window)
635 (type (or (member :none) cursor) cursor)))
636
637 (defun window-colormap-installed-p (window)
638 (declare (type window window)
639 (clx-values boolean)))
640
641 (defun window-all-event-masks (window)
642 (declare (type window window)
643 (clx-values mask32)))
644
645 (defun window-map-state (window)
646 (declare (type window window)
647 (clx-values (member :unmapped :unviewable :viewable))))
648
649 (defsetf drawable-x (window) (x)
650 (declare (type window window)
651 (type int16 x)))
652
653 (defsetf drawable-y (window) (y)
654 (declare (type window window)
655 (type int16 y)))
656
657 (defsetf drawable-width (window) (width)
658 ;; Inside width, excluding border.
659 (declare (type window window)
660 (type card16 width)))
661
662 (defsetf drawable-height (window) (height)
663 ;; Inside height, excluding border.
664 (declare (type window window)
665 (type card16 height)))
666
667 (defsetf drawable-border-width (window) (border-width)
668 (declare (type window window)
669 (type card16 border-width)))
670
671 (defsetf window-priority (window &optional sibling) (mode)
672 ;; A bit strange, but retains setf form.
673 (declare (type window window)
674 (type (or null window) sibling)
675 (type (member :above :below :top-if :bottom-if :opposite) mode)))
676
677 (defmacro with-state ((drawable) &body body)
678 ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
679 ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
680 ;; ConfigureWindow. The body is not surrounded by a with-display. Within the
681 ;; indefinite scope of the body, on a per-process basis in a multi-process
682 ;; environment, the first call within an Accessor Group on the specified drawable
683 ;; (the object, not just the variable) causes the complete results of the protocol
684 ;; request to be retained, and returned in any subsequent accessor calls. Calls
685 ;; within a Setf Group are delayed, and executed in a single request on exit from
686 ;; the body. In addition, if a call on a function within an Accessor Group follows
687 ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
688 ;; that group are executed, any retained accessor information for that group is
689 ;; discarded, the corresponding protocol request is (re)issued, and the results are
690 ;; (again) retained, and returned in any subsequent accessor calls.
691
692 ;; Accessor Group A (for GetWindowAttributes):
693 ;; window-visual-info, window-visual, window-class, window-gravity, window-bit-gravity,
694 ;; window-backing-store, window-backing-planes, window-backing-pixel,
695 ;; window-save-under, window-colormap, window-colormap-installed-p,
696 ;; window-map-state, window-all-event-masks, window-event-mask,
697 ;; window-do-not-propagate-mask, window-override-redirect
698
699 ;; Setf Group A (for ChangeWindowAttributes):
700 ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
701 ;; window-backing-pixel, window-save-under, window-event-mask,
702 ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
703 ;; window-cursor
704
705 ;; Accessor Group G (for GetGeometry):
706 ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
707 ;; drawable-height, drawable-border-width
708
709 ;; Setf Group G (for ConfigureWindow):
710 ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
711 ;; window-priority
712 )
713
714 (defun destroy-window (window)
715 (declare (type window window)))
716
717 (defun destroy-subwindows (window)
718 (declare (type window window)))
719
720 (defun add-to-save-set (window)
721 (declare (type window window)))
722
723 (defun remove-from-save-set (window)
724 (declare (type window window)))
725
726 (defun reparent-window (window parent x y)
727 (declare (type window window parent)
728 (type int16 x y)))
729
730 (defun map-window (window)
731 (declare (type window window)))
732
733 (defun map-subwindows (window)
734 (declare (type window window)))
735
736 (defun unmap-window (window)
737 (declare (type window window)))
738
739 (defun unmap-subwindows (window)
740 (declare (type window window)))
741
742 (defun circulate-window-up (window)
743 (declare (type window window)))
744
745 (defun circulate-window-down (window)
746 (declare (type window window)))
747
748 (defun drawable-root (drawable)
749 (declare (type drawable drawable)
750 (clx-values window)))
751
752 (defun drawable-depth (drawable)
753 (declare (type drawable drawable)
754 (clx-values card8)))
755
756 (defun drawable-x (drawable)
757 (declare (type drawable drawable)
758 (clx-values int16)))
759
760 (defun drawable-y (drawable)
761 (declare (type drawable drawable)
762 (clx-values int16)))
763
764 (defun drawable-width (drawable)
765 ;; For windows, inside width, excluding border.
766 (declare (type drawable drawable)
767 (clx-values card16)))
768
769 (defun drawable-height (drawable)
770 ;; For windows, inside height, excluding border.
771 (declare (type drawable drawable)
772 (clx-values card16)))
773
774 (defun drawable-border-width (drawable)
775 (declare (type drawable drawable)
776 (clx-values card16)))
777
778 (defun query-tree (window &key (result-type 'list))
779 (declare (type window window)
780 (type type result-type)
781 (clx-values (clx-sequence window) parent root)))
782
783 (defun change-property (window property data type format
784 &key (mode :replace) (start 0) end transform)
785 ;; Start and end affect sub-sequence extracted from data.
786 ;; Transform is applied to each extracted element.
787 (declare (type window window)
788 (type xatom property type)
789 (type (member 8 16 32) format)
790 (type sequence data)
791 (type (member :replace :prepend :append) mode)
792 (type array-index start)
793 (type (or null array-index) end)
794 (type (or null (function (t) integer)) transform)))
795
796 (defun delete-property (window property)
797 (declare (type window window)
798 (type xatom property)))
799
800 (defun get-property (window property
801 &key type (start 0) end delete-p (result-type 'list) transform)
802 ;; Transform is applied to each integer retrieved.
803 ;; Nil is returned for type when the protocol returns None.
804 (declare (type window window)
805 (type xatom property)
806 (type (or null xatom) type)
807 (type array-index start)
808 (type (or null array-index) end)
809 (type boolean delete-p)
810 (type type result-type)
811 (type (or null (function (integer) t)) transform)
812 (clx-values data type format bytes-after)))
813
814 (defun rotate-properties (window properties &optional (delta 1))
815 ;; Postive rotates left, negative rotates right (opposite of actual protocol request).
816 (declare (type window window)
817 (type (clx-sequence xatom) properties)
818 (type int16 delta)))
819
820 (defun list-properties (window &key (result-type 'list))
821 (declare (type window window)
822 (type type result-type)
823 (clx-values (clx-sequence keyword))))
824
825 ;; Although atom-ids are not visible in the normal user interface, atom-ids might
826 ;; appear in window properties and other user data, so conversion hooks are needed.
827
828 (defun intern-atom (display name)
829 (declare (type display display)
830 (type xatom name)
831 (clx-values resource-id)))
832
833 (defun find-atom (display name)
834 (declare (type display display)
835 (type xatom name)
836 (clx-values (or null resource-id))))
837
838 (defun atom-name (display atom-id)
839 (declare (type display display)
840 (type resource-id atom-id)
841 (clx-values keyword)))
842
843 (defun selection-owner (display selection)
844 (declare (type display display)
845 (type xatom selection)
846 (clx-values (or null window))))
847
848 (defsetf selection-owner (display selection &optional time) (owner)
849 ;; A bit strange, but retains setf form.
850 (declare (type display display)
851 (type xatom selection)
852 (type (or null window) owner)
853 (type timestamp time)))
854
855 (defun convert-selection (selection type requestor &optional property time)
856 (declare (type xatom selection type)
857 (type window requestor)
858 (type (or null xatom) property)
859 (type timestamp time)))
860
861 (defun send-event (window event-key event-mask &rest args
862 &key propagate-p display &allow-other-keys)
863 ;; Additional arguments depend on event-key, and are as specified further below
864 ;; with declare-event, except that both resource-ids and resource objects are
865 ;; accepted in the event components. The display argument is only required if the
866 ;; window is :pointer-window or :input-focus. If an argument has synonyms, it is
867 ;; only necessary to supply a value for one of them; it is an error to specify
868 ;; different values for synonyms.
869 (declare (type (or window (member :pointer-window :input-focus)) window)
870 (type (or null event-key) event-key)
871 (type event-mask event-mask)
872 (type boolean propagate-p)
873 (type (or null display) display)))
874
875 (defun grab-pointer (window event-mask
876 &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
877 (declare (type window window)
878 (type pointer-event-mask event-mask)
879 (type boolean owner-p sync-pointer-p sync-keyboard-p)
880 (type (or null window) confine-to)
881 (type (or null cursor) cursor)
882 (type timestamp time)
883 (clx-values grab-status)))
884
885 (defun ungrab-pointer (display &key time)
886 (declare (type display display)
887 (type timestamp time)))
888
889 (defun grab-button (window button event-mask
890 &key (modifiers 0)
891 owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
892 (declare (type window window)
893 (type (or (member :any) card8) button)
894 (type modifier-mask modifiers)
895 (type pointer-event-mask event-mask)
896 (type boolean owner-p sync-pointer-p sync-keyboard-p)
897 (type (or null window) confine-to)
898 (type (or null cursor) cursor)))
899
900 (defun ungrab-button (window button &key (modifiers 0))
901 (declare (type window window)
902 (type (or (member :any) card8) button)
903 (type modifier-mask modifiers)))
904
905 (defun change-active-pointer-grab (display event-mask &optional cursor time)
906 (declare (type display display)
907 (type pointer-event-mask event-mask)
908 (type (or null cursor) cursor)
909 (type timestamp time)))
910
911 (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
912 (declare (type window window)
913 (type boolean owner-p sync-pointer-p sync-keyboard-p)
914 (type timestamp time)
915 (clx-values grab-status)))
916
917 (defun ungrab-keyboard (display &key time)
918 (declare (type display display)
919 (type timestamp time)))
920
921 (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
922 (declare (type window window)
923 (type boolean owner-p sync-pointer-p sync-keyboard-p)
924 (type (or (member :any) card8) key)
925 (type modifier-mask modifiers)))
926
927 (defun ungrab-key (window key &key (modifiers 0))
928 (declare (type window window)
929 (type (or (member :any) card8) key)
930 (type modifier-mask modifiers)))
931
932 (defun allow-events (display mode &optional time)
933 (declare (type display display)
934 (type (member :async-pointer :sync-pointer :reply-pointer
935 :async-keyboard :sync-keyboard :replay-keyboard
936 :async-both :sync-both)
937 mode)
938 (type timestamp time)))
939
940 (defun grab-server (display)
941 (declare (type display display)))
942
943 (defun ungrab-server (display)
944 (declare (type display display)))
945
946 (defmacro with-server-grabbed ((display) &body body)
947 ;; The body is not surrounded by a with-display.
948 )
949
950 (defun query-pointer (window)
951 (declare (type window window)
952 (clx-values x y same-screen-p child mask root-x root-y root)))
953
954 (defun pointer-position (window)
955 (declare (type window window)
956 (clx-values x y same-screen-p)))
957
958 (defun global-pointer-position (display)
959 (declare (type display display)
960 (clx-values root-x root-y root)))
961
962 (defun motion-events (window &key start stop (result-type 'list))
963 (declare (type window window)
964 (type timestamp start stop)
965 (type type result-type)
966 (clx-values (repeat-seq (int16 x) (int16 y) (timestamp time)))))
967
968 (defun translate-coordinates (src src-x src-y dst)
969 ;; If src and dst are not on the same screen, nil is returned.
970 (declare (type window src)
971 (type int16 src-x src-y)
972 (type window dst)
973 (clx-values dst-x dst-y child)))
974
975 (defun warp-pointer (dst dst-x dst-y)
976 (declare (type window dst)
977 (type int16 dst-x dst-y)))
978
979 (defun warp-pointer-relative (display x-off y-off)
980 (declare (type display display)
981 (type int16 x-off y-off)))
982
983 (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
984 &optional src-width src-height)
985 ;; Passing in a zero src-width or src-height is a no-op. A null src-width or
986 ;; src-height translates into a zero value in the protocol request.
987 (declare (type window dst src)
988 (type int16 dst-x dst-y src-x src-y)
989 (type (or null card16) src-width src-height)))
990
991 (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
992 &optional src-width src-height)
993 ;; Passing in a zero src-width or src-height is a no-op. A null src-width or
994 ;; src-height translates into a zero value in the protocol request.
995 (declare (type window src)
996 (type int16 x-off y-off src-x src-y)
997 (type (or null card16) src-width src-height)))
998
999 (defun set-input-focus (display focus revert-to &optional time)
1000 ;; Setf ought to allow multiple values.
1001 (declare (type display display)
1002 (type (or (member :none :pointer-root) window) focus)
1003 (type (member :none :parent :pointer-root) revert-to)
1004 (type timestamp time)))
1005
1006 (defun input-focus (display)
1007 (declare (type display display)
1008 (clx-values focus revert-to)))
1009
1010 (defun query-keymap (display)
1011 (declare (type display display)
1012 (clx-values (bit-vector 256))))
1013
1014 (defun open-font (display name)
1015 ;; Font objects may be cached and reference counted locally within the display
1016 ;; object. This function might not execute a with-display if the font is cached.
1017 ;; The protocol QueryFont request happens on-demand under the covers.
1018 (declare (type display display)
1019 (type stringable name)
1020 (clx-values font)))
1021
1022 ;; We probably want a per-font bit to indicate whether caching on
1023 ;; text-extents/width calls is desirable. But what to name it?
1024
1025 (defun discard-font-info (font)
1026 ;; Discards any state that can be re-obtained with QueryFont. This is simply
1027 ;; a performance hint for memory-limited systems.
1028 (declare (type font font)))
1029
1030 ;; This can be signalled anywhere a pseudo font access fails.
1031
1032 (define-condition invalid-font error
1033 font)
1034
1035 ;; Note: font-font-info removed.
1036
1037 (defun font-name (font)
1038 ;; Returns nil for a pseudo font returned by gcontext-font.
1039 (declare (type font font)
1040 (clx-values (or null string))))
1041
1042 (defun font-direction (font)
1043 (declare (type font font)
1044 (clx-values draw-direction)))
1045
1046 (defun font-min-char (font)
1047 (declare (type font font)
1048 (clx-values card16)))
1049
1050 (defun font-max-char (font)
1051 (declare (type font font)
1052 (clx-values card16)))
1053
1054 (defun font-min-byte1 (font)
1055 (declare (type font font)
1056 (clx-values card8)))
1057
1058 (defun font-max-byte1 (font)
1059 (declare (type font font)
1060 (clx-values card8)))
1061
1062 (defun font-min-byte2 (font)
1063 (declare (type font font)
1064 (clx-values card8)))
1065
1066 (defun font-max-byte2 (font)
1067 (declare (type font font)
1068 (clx-values card8)))
1069
1070 (defun font-all-chars-exist-p (font)
1071 (declare (type font font)
1072 (clx-values boolean)))
1073
1074 (defun font-default-char (font)
1075 (declare (type font font)
1076 (clx-values card16)))
1077
1078 (defun font-ascent (font)
1079 (declare (type font font)
1080 (clx-values int16)))
1081
1082 (defun font-descent (font)
1083 (declare (type font font)
1084 (clx-values int16)))
1085
1086 ;; The list contains alternating keywords and int32s.
1087
1088 (deftype font-props () 'list)
1089
1090 (defun font-properties (font)
1091 (declare (type font font)
1092 (clx-values font-props)))
1093
1094 (defun font-property (font name)
1095 (declare (type font font)
1096 (type keyword name)
1097 (clx-values (or null int32))))
1098
1099 ;; For each of left-bearing, right-bearing, width, ascent, descent, attributes:
1100
1101 (defun char-<metric> (font index)
1102 ;; Note: I have tentatively chosen to return nil for an out-of-bounds index
1103 ;; (or an in-bounds index on a pseudo font), although returning zero or
1104 ;; signalling might be better.
1105 (declare (type font font)
1106 (type card16 index)
1107 (clx-values (or null int16))))
1108
1109 (defun max-char-<metric> (font)
1110 ;; Note: I have tentatively chosen separate accessors over allowing :min and
1111 ;; :max as an index above.
1112 (declare (type font font)
1113 (clx-values int16)))
1114
1115 (defun min-char-<metric> (font)
1116 (declare (type font font)
1117 (clx-values int16)))
1118
1119 ;; Note: char16-<metric> accessors could be defined to accept two-byte indexes.
1120
1121 (defun close-font (font)
1122 ;; This might not generate a protocol request if the font is reference
1123 ;; counted locally or if it is a pseudo font.
1124 (declare (type font font)))
1125
1126 (defun list-font-names (display pattern &key (max-fonts 65535) (result-type 'list))
1127 (declare (type display display)
1128 (type string pattern)
1129 (type card16 max-fonts)
1130 (type type result-type)
1131 (clx-values (clx-sequence string))))
1132
1133 (defun list-fonts (display pattern &key (max-fonts 65535) (result-type 'list))
1134 ;; Returns "pseudo" fonts that contain basic font metrics and properties, but
1135 ;; no per-character metrics and no resource-ids. These pseudo fonts will be
1136 ;; converted (internally) to real fonts dynamically as needed, by issuing an
1137 ;; OpenFont request. However, the OpenFont might fail, in which case the
1138 ;; invalid-font error can arise.
1139 (declare (type display display)
1140 (type string pattern)
1141 (type card16 max-fonts)
1142 (type type result-type)
1143 (clx-values (clx-sequence font))))
1144
1145 (defun font-path (display &key (result-type 'list))
1146 (declare (type display display)
1147 (type type result-type)
1148 (clx-values (clx-sequence (or string pathname)))))
1149
1150 (defsetf font-path (display) (paths)
1151 (declare (type display display)
1152 (type (clx-sequence (or string pathname)) paths)))
1153
1154 (defun create-pixmap (&key width height depth drawable)
1155 (declare (type card16 width height)
1156 (type card8 depth)
1157 (type drawable drawable)
1158 (clx-values pixmap)))
1159
1160 (defun free-pixmap (pixmap)
1161 (declare (type pixmap pixmap)))
1162
1163 (defun create-gcontext (&key drawable function plane-mask foreground background
1164 line-width line-style cap-style join-style fill-style fill-rule
1165 arc-mode tile stipple ts-x ts-y font subwindow-mode
1166 exposures clip-x clip-y clip-mask clip-ordering
1167 dash-offset dashes
1168 (cache-p t))
1169 ;; Only non-nil components are passed on in the request, but for effective caching
1170 ;; assumptions have to be made about what the actual protocol defaults are. For
1171 ;; all gcontext components, a value of nil causes the default gcontext value to be
1172 ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented
1173 ;; as a list. Note: use of stringable as font will cause an implicit open-font.
1174 ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If
1175 ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
1176 ;; component will have no effect unless the new value differs from the cached
1177 ;; value. Component changes (setfs and with-gcontext) are always deferred
1178 ;; regardless of the cache mode, and sent over the protocol only when required by a
1179 ;; local operation or by an explicit call to force-gcontext-changes.
1180 (declare (type drawable drawable)
1181 (type (or null boole-constant) function)
1182 (type (or null pixel) plane-mask foreground background)
1183 (type (or null card16) line-width dash-offset)
1184 (type (or null int16) ts-x ts-y clip-x clip-y)
1185 (type (or null (member :solid :dash :double-dash)) line-style)
1186 (type (or null (member :not-last :butt :round :projecting)) cap-style)
1187 (type (or null (member :miter :round :bevel)) join-style)
1188 (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
1189 (type (or null (member :even-odd :winding)) fill-rule)
1190 (type (or null (member :chord :pie-slice)) arc-mode)
1191 (type (or null pixmap) tile stipple)
1192 (type (or null fontable) font)
1193 (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
1194 (type (or null (member :on :off)) exposures)
1195 (type (or null (member :none) pixmap rect-seq) clip-mask)
1196 (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
1197 (type (or null (or card8 (clx-sequence card8))) dashes)
1198 (type boolean cache)
1199 (clx-values gcontext)))
1200
1201 ;; For each argument to create-gcontext (except font, clip-mask and
1202 ;; clip-ordering) declared as (type <type> <name>), there is an accessor:
1203
1204 (defun gcontext-<name> (gcontext)
1205 ;; The value will be nil if the last value stored is unknown (e.g., the cache was
1206 ;; off, or the component was copied from a gcontext with unknown state).
1207 (declare (type gcontext gcontext)
1208 (clx-values <type>)))
1209
1210 ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
1211 ;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
1212
1213 (defsetf gcontext-<name> (gcontext) (value)
1214 (declare (type gcontext gcontext)
1215 (type <type> value)))
1216
1217 (defun gcontext-font (gcontext &optional metrics-p)
1218 ;; If the stored font is known, it is returned. If it is not known and
1219 ;; metrics-p is false, then nil is returned. If it is not known and
1220 ;; metrics-p is true, then a pseudo font is returned. Full metric and
1221 ;; property information can be obtained, but the font does not have a name or
1222 ;; a resource-id, and attempts to use it where a resource-id is required will
1223 ;; result in an invalid-font error.
1224 (declare (type gcontext gcontext)
1225 (type boolean metrics-p)
1226 (clx-values (or null font))))
1227
1228 (defun gcontext-clip-mask (gcontext)
1229 (declare (type gcontext gcontext)
1230 (clx-values (or null (member :none) pixmap rect-seq)
1231 (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)))))
1232
1233 (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
1234 ;; Is nil illegal here, or is it transformed to a vector?
1235 ;; A bit strange, but retains setf form.
1236 (declare (type gcontext gcontext)
1237 (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
1238 (type (or (member :none) pixmap rect-seq) clip-mask)))
1239
1240 (defun force-gcontext-changes (gcontext)
1241 ;; Force any delayed changes.
1242 (declare (type gcontext gcontext)))
1243
1244 (defmacro with-gcontext ((gcontext &key
1245 function plane-mask foreground background
1246 line-width line-style cap-style join-style fill-style fill-rule
1247 arc-mode tile stipple ts-x ts-y font subwindow-mode
1248 exposures clip-x clip-y clip-mask clip-ordering
1249 dashes dash-offset)
1250 &body body)
1251 ;; Changes gcontext components within the dynamic scope of the body (i.e.,
1252 ;; indefinite scope and dynamic extent), on a per-process basis in a multi-process
1253 ;; environment. The values are all evaluated before bindings are performed. The
1254 ;; body is not surrounded by a with-display. If cache-p is nil or the some
1255 ;; component states are unknown, this will implement save/restore by creating a
1256 ;; temporary gcontext and doing gcontext-components to and from it.
1257 )
1258
1259 (defun copy-gcontext-components (src dst &rest keys)
1260 (declare (type gcontext src dst)
1261 (type (clx-list gcontext-key) keys)))
1262
1263 (defun copy-gcontext (src dst)
1264 (declare (type gcontext src dst))
1265 ;; Copies all components.
1266 )
1267
1268 (defun free-gcontext (gcontext)
1269 (declare (type gcontext gcontext)))
1270
1271 (defun clear-area (window &key (x 0) (y 0) width height exposures-p)
1272 ;; Passing in a zero width or height is a no-op. A null width or height translates
1273 ;; into a zero value in the protocol request.
1274 (declare (type window window)
1275 (type int16 x y)
1276 (type (or null card16) width height)
1277 (type boolean exposures-p)))
1278
1279 (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
1280 (declare (type drawable src dst)
1281 (type gcontext gcontext)
1282 (type int16 src-x src-y dst-x dst-y)
1283 (type card16 width height)))
1284
1285 (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
1286 (declare (type drawable src dst)
1287 (type gcontext gcontext)
1288 (type pixel plane)
1289 (type int16 src-x src-y dst-x dst-y)
1290 (type card16 width height)))
1291
1292 (defun draw-point (drawable gcontext x y)
1293 ;; Should be clever about appending to existing buffered protocol request, provided
1294 ;; gcontext has not been modified.
1295 (declare (type drawable drawable)
1296 (type gcontext gcontext)
1297 (type int16 x y)))
1298
1299 (defun draw-points (drawable gcontext points &optional relative-p)
1300 (declare (type drawable drawable)
1301 (type gcontext gcontext)
1302 (type point-seq points)
1303 (type boolean relative-p)))
1304
1305 (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
1306 ;; Should be clever about appending to existing buffered protocol request, provided
1307 ;; gcontext has not been modified.
1308 (declare (type drawable drawable)
1309 (type gcontext gcontext)
1310 (type int16 x1 y1 x2 y2)
1311 (type boolean relative-p)))
1312
1313 (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
1314 (declare (type drawable drawable)
1315 (type gcontext gcontext)
1316 (type point-seq points)
1317 (type boolean relative-p fill-p)
1318 (type (member :complex :non-convex :convex) shape)))
1319
1320 (defun draw-segments (drawable gcontext segments)
1321 (declare (type drawable drawable)
1322 (type gcontext gcontext)
1323 (type seg-seq segments)))
1324
1325 (defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
1326 ;; Should be clever about appending to existing buffered protocol request, provided
1327 ;; gcontext has not been modified.
1328 (declare (type drawable drawable)
1329 (type gcontext gcontext)
1330 (type int16 x y)
1331 (type card16 width height)
1332 (type boolean fill-p)))
1333
1334 (defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
1335 (declare (type drawable drawable)
1336 (type gcontext gcontext)
1337 (type rect-seq rectangles)
1338 (type boolean fill-p)))
1339
1340 (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
1341 ;; Should be clever about appending to existing buffered protocol request, provided
1342 ;; gcontext has not been modified.
1343 (declare (type drawable drawable)
1344 (type gcontext gcontext)
1345 (type int16 x y)
1346 (type card16 width height)
1347 (type angle angle1 angle2)
1348 (type boolean fill-p)))
1349
1350 (defun draw-arcs (drawable gcontext arcs &optional fill-p)
1351 (declare (type drawable drawable)
1352 (type gcontext gcontext)
1353 (type arc-seq arcs)
1354 (type boolean fill-p)))
1355
1356 ;; The following image routines are bare minimum. It may be useful to define some
1357 ;; form of "image" object to hide representation details and format conversions. It
1358 ;; also may be useful to provide stream-oriented interfaces for reading and writing
1359 ;; the data.
1360
1361 (defun put-raw-image (drawable gcontext data
1362 &key (start 0) depth x y width height (left-pad 0) format)
1363 ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
1364 ;; for transmission; the caller is responsible for all byte and bit swapping and
1365 ;; compaction. Start is the starting index in data; the end is computed from the
1366 ;; other arguments.
1367 (declare (type drawable drawable)
1368 (type gcontext gcontext)
1369 (type (clx-sequence card8) data)
1370 (type array-index start)
1371 (type card8 depth left-pad)
1372 (type int16 x y)
1373 (type card16 width height)
1374 (type (member :bitmap :xy-pixmap :z-pixmap) format)))
1375
1376 (defun get-raw-image (drawable &key data (start 0) x y width height
1377 (plane-mask 0xffffffff) format
1378 (result-type '(vector (unsigned-byte 8))))
1379 ;; If data is given, it is modified in place (and returned), otherwise a new
1380 ;; sequence is created and returned, with a size computed from the other arguments
1381 ;; and the returned depth. The sequence is filled with 8-bit quantities, in
1382 ;; transmission format; the caller is responsible for any byte and bit swapping and
1383 ;; compaction required for further local use.
1384 (declare (type drawable drawable)
1385 (type (or null (clx-sequence card8)) data)
1386 (type array-index start)
1387 (type int16 x y)
1388 (type card16 width height)
1389 (type pixel plane-mask)
1390 (type (member :xy-pixmap :z-pixmap) format)
1391 (clx-values (clx-sequence card8) depth visual-info)))
1392
1393 (defun translate-default (src src-start src-end font dst dst-start)
1394 ;; dst is guaranteed to have room for (- src-end src-start) integer elements,
1395 ;; starting at dst-start; whether dst holds 8-bit or 16-bit elements depends
1396 ;; on context. font is the current font, if known. The function should
1397 ;; translate as many elements of src as possible into indexes in the current
1398 ;; font, and store them into dst. The first return value should be the src
1399 ;; index of the first untranslated element. If no further elements need to
1400 ;; be translated, the second return value should be nil. If a horizontal
1401 ;; motion is required before further translation, the second return value
1402 ;; should be the delta in x coordinate. If a font change is required for
1403 ;; further translation, the second return value should be the new font. If
1404 ;; known, the pixel width of the translated text can be returned as the third
1405 ;; value; this can allow for appending of subsequent output to the same
1406 ;; protocol request, if no overall width has been specified at the higher
1407 ;; level.
1408 (declare (type sequence src)
1409 (type array-index src-start src-end dst-start)
1410 (type (or null font) font)
1411 (type vector dst)
1412 (clx-values array-index (or null int16 font) (or null int32))))
1413
1414 ;; There is a question below of whether translate should always be required, or
1415 ;; if not, what the default should be or where it should come from. For
1416 ;; example, the default could be something that expected a string as src and
1417 ;; translated the CL standard character set to ASCII indexes, and ignored fonts
1418 ;; and bits. Or the default could expect a string but otherwise be "system
1419 ;; dependent". Or the default could be something that expected a vector of
1420 ;; integers and did no translation. Or the default could come from the
1421 ;; gcontext (but what about text-extents and text-width?).
1422
1423 (defun text-extents (font sequence &key (start 0) end translate)
1424 ;; If multiple fonts are involved, font-ascent and font-descent will be the
1425 ;; maximums. If multiple directions are involved, the direction will be nil.
1426 ;; Translate will always be called with a 16-bit dst buffer.
1427 (declare (type sequence sequence)
1428 (type (or font gcontext) font)
1429 (type translate translate)
1430 (clx-values width ascent descent left right font-ascent font-descent direction
1431 (or null array-index))))
1432
1433 (defun text-width (font sequence &key (start 0) end translate)
1434 ;; Translate will always be called with a 16-bit dst buffer.
1435 (declare (type sequence sequence)
1436 (type (or font gcontext) font)
1437 (type translate translate)
1438 (clx-values int32 (or null array-index))))
1439
1440 ;; This controls the element size of the dst buffer given to translate. If
1441 ;; :default is specified, the size will be based on the current font, if known,
1442 ;; and otherwise 16 will be used. [An alternative would be to pass the buffer
1443 ;; size to translate, and allow it to return the desired size if it doesn't
1444 ;; like the current size. The problem is that the protocol doesn't allow
1445 ;; switching within a single request, so to allow switching would require
1446 ;; knowing the width of text, which isn't necessarily known. We could call
1447 ;; text-width to compute it, but perhaps that is doing too many favors?] [An
1448 ;; additional possibility is to allow an index-size of :two-byte, in which case
1449 ;; translate would be given a double-length 8-bit array, and translate would be
1450 ;; expected to store first-byte/second-byte instead of 16-bit integers.]
1451
1452 (deftype index-size () '(member :default 8 16))
1453
1454 ;; In the glyph functions below, if width is specified, it is assumed to be the
1455 ;; total pixel width of whatever string of glyphs is actually drawn.
1456 ;; Specifying width will allow for appending the output of subsequent calls to
1457 ;; the same protocol request, provided gcontext has not been modified in the
1458 ;; interim. If width is not specified, appending of subsequent output might
1459 ;; not occur (unless translate returns the width). Specifying width is simply
1460 ;; a hint, for performance.
1461
1462 (defun draw-glyph (drawable gcontext x y elt
1463 &key translate width (size :default))
1464 ;; Returns true if elt is output, nil if translate refuses to output it.
1465 ;; Second result is width, if known.
1466 (declare (type drawable drawable)
1467 (type gcontext gcontext)
1468 (type int16 x y)
1469 (type translate translate)
1470 (type (or null int32) width)
1471 (type index-size size)
1472 (clx-values boolean (or null int32))))
1473
1474 (defun draw-glyphs (drawable gcontext x y sequence
1475 &key (start 0) end translate width (size :default))
1476 ;; First result is new start, if end was not reached. Second result is
1477 ;; overall width, if known.
1478 (declare (type drawable drawable)
1479 (type gcontext gcontext)
1480 (type int16 x y)
1481 (type sequence sequence)
1482 (type array-index start)
1483 (type (or null array-index) end)
1484 (type (or null int32) width)
1485 (type translate translate)
1486 (type index-size size)
1487 (clx-values (or null array-index) (or null int32))))
1488
1489 (defun draw-image-glyph (drawable gcontext x y elt
1490 &key translate width (size :default))
1491 ;; Returns true if elt is output, nil if translate refuses to output it.
1492 ;; Second result is overall width, if known. An initial font change is
1493 ;; allowed from translate.
1494 (declare (type drawable drawable)
1495 (type gcontext gcontext)
1496 (type int16 x y)
1497 (type translate translate)
1498 (type (or null int32) width)
1499 (type index-size size)
1500 (clx-values boolean (or null int32))))
1501
1502 (defun draw-image-glyphs (drawable gcontext x y sequence
1503 &key (start 0) end width translate (size :default))
1504 ;; An initial font change is allowed from translate, but any subsequent font
1505 ;; change or horizontal motion will cause termination (because the protocol
1506 ;; doesn't support chaining). [Alternatively, font changes could be accepted
1507 ;; as long as they are accompanied with a width return value, or always
1508 ;; accept font changes and call text-width as required. However, horizontal
1509 ;; motion can't really be accepted, due to semantics.] First result is new
1510 ;; start, if end was not reached. Second result is overall width, if known.
1511 (declare (type drawable drawable)
1512 (type gcontext gcontext)
1513 (type int16 x y)
1514 (type sequence sequence)
1515 (type array-index start)
1516 (type (or null array-index) end)
1517 (type (or null int32) width)
1518 (type translate translate)
1519 (type index-size size)
1520 (clx-values (or null array-index) (or null int32))))
1521
1522 (defun create-colormap (visual window &optional alloc-p)
1523 (declare (type visual-info visual)
1524 (type window window)
1525 (type boolean alloc-p)
1526 (clx-values colormap)))
1527
1528 (defun free-colormap (colormap)
1529 (declare (type colormap colormap)))
1530
1531 (defun copy-colormap-and-free (colormap)
1532 (declare (type colormap colormap)
1533 (clx-values colormap)))
1534
1535 (defun install-colormap (colormap)
1536 (declare (type colormap colormap)))
1537
1538 (defun uninstall-colormap (colormap)
1539 (declare (type colormap colormap)))
1540
1541 (defun installed-colormaps (window &key (result-type 'list))
1542 (declare (type window window)
1543 (type type result-type)
1544 (clx-values (clx-sequence colormap))))
1545
1546 (defun alloc-color (colormap color)
1547 (declare (type colormap colormap)
1548 (type (or stringable color) color)
1549 (clx-values pixel screen-color exact-color)))
1550
1551 (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
1552 (declare (type colormap colormap)
1553 (type card16 colors planes)
1554 (type boolean contiguous-p)
1555 (type type result-type)
1556 (clx-values (clx-sequence pixel) (clx-sequence mask))))
1557
1558 (defun alloc-color-planes (colormap colors
1559 &key (reds 0) (greens 0) (blues 0)
1560 contiguous-p (result-type 'list))
1561 (declare (type colormap colormap)
1562 (type card16 colors reds greens blues)
1563 (type boolean contiguous-p)
1564 (type type result-type)
1565 (clx-values (clx-sequence pixel) red-mask green-mask blue-mask)))
1566
1567 (defun free-colors (colormap pixels &optional (plane-mask 0))
1568 (declare (type colormap colormap)
1569 (type (clx-sequence pixel) pixels)
1570 (type pixel plane-mask)))
1571
1572 (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
1573 (declare (type colormap colormap)
1574 (type pixel pixel)
1575 (type (or stringable color) spec)
1576 (type boolean red-p green-p blue-p)))
1577
1578 (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
1579 ;; If stringables are specified for colors, it is unspecified whether all
1580 ;; stringables are first resolved and then a single StoreColors protocol request is
1581 ;; issued, or whether multiple StoreColors protocol requests are issued.
1582 (declare (type colormap colormap)
1583 (type (repeat-seq (pixel pixel) ((or stringable color) color)) specs)
1584 (type boolean red-p green-p blue-p)))
1585
1586 (defun query-colors (colormap pixels &key (result-type 'list))
1587 (declare (type colormap colormap)
1588 (type (clx-sequence pixel) pixels)
1589 (type type result-type)
1590 (clx-values (clx-sequence color))))
1591
1592 (defun lookup-color (colormap name)
1593 (declare (type colormap colormap)
1594 (type stringable name)
1595 (clx-values screen-color true-color)))
1596
1597 (defun create-cursor (&key source mask x y foreground background)
1598 (declare (type pixmap source)
1599 (type (or null pixmap) mask)
1600 (type card16 x y)
1601 (type color foreground background)
1602 (clx-values cursor)))
1603
1604 (defun create-glyph-cursor (&key source-font source-char mask-font mask-char
1605 foreground background)
1606 (declare (type font source-font)
1607 (type card16 source-char)
1608 (type (or null font) mask-font)
1609 (type (or null card16) mask-char)
1610 (type color foreground background)
1611 (clx-values cursor)))
1612
1613 (defun free-cursor (cursor)
1614 (declare (type cursor cursor)))
1615
1616 (defun recolor-cursor (cursor foreground background)
1617 (declare (type cursor cursor)
1618 (type color foreground background)))
1619
1620 (defun query-best-cursor (width height drawable)
1621 (declare (type card16 width height)
1622 (type drawable display)
1623 (clx-values width height)))
1624
1625 (defun query-best-tile (width height drawable)
1626 (declare (type card16 width height)
1627 (type drawable drawable)
1628 (clx-values width height)))
1629
1630 (defun query-best-stipple (width height drawable)
1631 (declare (type card16 width height)
1632 (type drawable drawable)
1633 (clx-values width height)))
1634
1635 (defun query-extension (display name)
1636 (declare (type display display)
1637 (type stringable name)
1638 (clx-values major-opcode first-event first-error)))
1639
1640 (defun list-extensions (display &key (result-type 'list))
1641 (declare (type display display)
1642 (type type result-type)
1643 (clx-values (clx-sequence string))))
1644
1645 ;; Should pointer-mapping setf be changed to set-pointer-mapping?
1646
1647 (defun set-modifier-mapping (display &key shift lock control mod1 mod2 mod3 mod4 mod5)
1648 ;; Can signal device-busy.
1649 ;; Setf ought to allow multiple values.
1650 ;; Returns true for success, nil for failure
1651 (declare (type display display)
1652 (type (clx-sequence card8) shift lock control mod1 mod2 mod3 mod4 mod5)
1653 (clx-values (member :success :busy :failed))))
1654
1655 (defun modifier-mapping (display)
1656 ;; each value is a list of card8s
1657 (declare (type display display)
1658 (clx-values shift lock control mod1 mod2 mod3 mod4 mod5)))
1659
1660 ;; Either we will want lots of defconstants for well-known values, or perhaps
1661 ;; an integer-to-keyword translation function for well-known values.
1662
1663 (defun change-keyboard-mapping (display keysyms
1664 &key (start 0) end (first-keycode start))
1665 ;; start/end give subrange of keysyms
1666 ;; first-keycode is the first-keycode to store at
1667 (declare (type display display)
1668 (type (array * (* *)) keysyms)
1669 (type array-index start)
1670 (type (or null array-index) end)
1671 (type card8 first-keycode)))
1672
1673 (defun keyboard-mapping (display &key first-keycode start end data)
1674 ;; First-keycode specifies which keycode to start at (defaults to
1675 ;; min-keycode). Start specifies where (in result) to put first-keycode
1676 ;; (defaults to first-keycode). (- end start) is the number of keycodes to
1677 ;; get (end defaults to (1+ max-keycode)). If data is specified, the results
1678 ;; are put there.
1679 (declare (type display display)
1680 (type (or null card8) first-keycode)
1681 (type (or null array-index) start end)
1682 (type (or null (array * (* *))) data)
1683 (clx-values (array * (* *)))))
1684
1685 (defun change-keyboard-control (display &key key-click-percent
1686 bell-percent bell-pitch bell-duration
1687 led led-mode key auto-repeat-mode)
1688 (declare (type display display)
1689 (type (or null (member :default) int16) key-click-percent
1690 bell-percent bell-pitch bell-duration)
1691 (type (or null card8) led key)
1692 (type (or null (member :on :off)) led-mode)
1693 (type (or null (member :on :off :default)) auto-repeat-mode)))
1694
1695 (defun keyboard-control (display)
1696 (declare (type display display)
1697 (clx-values key-click-percent bell-percent bell-pitch bell-duration
1698 led-mask global-auto-repeat auto-repeats)))
1699
1700 (defun bell (display &optional (percent-from-normal 0))
1701 ;; It is assumed that an eventual audio extension to X will provide more complete
1702 ;; control.
1703 (declare (type display display)
1704 (type int8 percent-from-normal)))
1705
1706 (defun pointer-mapping (display &key (result-type 'list))
1707 (declare (type display display)
1708 (type type result-type)
1709 (clx-values (clx-sequence card8))))
1710
1711 (defsetf pointer-mapping (display) (map)
1712 ;; Can signal device-busy.
1713 (declare (type display display)
1714 (type (clx-sequence card8) map)))
1715
1716 (defun change-pointer-control (display &key acceleration threshold)
1717 ;; Acceleration is rationalized if necessary.
1718 (declare (type display display)
1719 (type (or null (member :default) number) acceleration)
1720 (type (or null (member :default) integer) threshold)))
1721
1722 (defun pointer-control (display)
1723 (declare (type display display)
1724 (clx-values acceleration threshold)))
1725
1726 (defun set-screen-saver (display timeout interval blanking exposures)
1727 ;; Setf ought to allow multiple values.
1728 ;; Timeout and interval are in seconds, will be rounded to minutes.
1729 (declare (type display display)
1730 (type (or (member :default) int16) timeout interval)
1731 (type (member :on :off :default) blanking exposures)))
1732
1733 (defun screen-saver (display)
1734 ;; Returns timeout and interval in seconds.
1735 (declare (type display display)
1736 (clx-values timeout interval blanking exposures)))
1737
1738 (defun activate-screen-saver (display)
1739 (declare (type display display)))
1740
1741 (defun reset-screen-saver (display)
1742 (declare (type display display)))
1743
1744 (defun add-access-host (display host)
1745 ;; A string must be acceptable as a host, but otherwise the possible types for host
1746 ;; are not constrained, and will likely be very system dependent.
1747 (declare (type display display)))
1748
1749 (defun remove-access-host (display host)
1750 ;; A string must be acceptable as a host, but otherwise the possible types for host
1751 ;; are not constrained, and will likely be very system dependent.
1752 (declare (type display display)))
1753
1754 (defun access-hosts (display &key (result-type 'list))
1755 ;; The type of host objects returned is not constrained, except that the hosts must
1756 ;; be acceptable to add-access-host and remove-access-host.
1757 (declare (type display display)
1758 (type type result-type)
1759 (clx-values (clx-sequence host) enabled-p)))
1760
1761 (defun access-control (display)
1762 ;; setf'able
1763 (declare (type display display)
1764 (clx-values boolean)))
1765
1766 (defun close-down-mode (display)
1767 ;; setf'able
1768 ;; Cached locally in display object.
1769 (declare (type display display)
1770 (clx-values (member :destroy :retain-permanent :retain-temporary))))
1771
1772 (defun kill-client (display resource-id)
1773 (declare (type display display)
1774 (type resource-id resource-id)))
1775
1776 (defun kill-temporary-clients (display)
1777 (declare (type display display)))
1778
1779 (defun make-event-mask (&rest keys)
1780 ;; This is only defined for core events.
1781 ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
1782 (declare (type (clx-list event-mask-class) keys)
1783 (clx-values mask32)))
1784
1785 (defun make-event-keys (event-mask)
1786 ;; This is only defined for core events.
1787 (declare (type mask32 event-mask)
1788 (clx-values (clx-list event-mask-class))))
1789
1790 (defun make-state-mask (&rest keys)
1791 ;; Useful for constructing modifier-mask, state-mask.
1792 (declare (type (clx-list state-mask-key) keys)
1793 (clx-values mask16)))
1794
1795 (defun make-state-keys (state-mask)
1796 (declare (type mask16 mask)
1797 (clx-values (clx-list state-mask-key))))
1798
1799 (defmacro with-event-queue ((display) &body body)
1800 ;; Grants exclusive access to event queue.
1801 )
1802
1803 (defun event-listen (display &optional (timeout 0))
1804 (declare (type display display)
1805 (type (or null number) timeout)
1806 (clx-values (or null number) (or null (member :timeout) (not null))))
1807 ;; Returns the number of events queued locally, if any, else nil. Hangs
1808 ;; waiting for events, forever if timeout is nil, else for the specified
1809 ;; number of seconds. The second value returned is :timeout if the
1810 ;; operation timed out, and some other non-nil value if an EOF has been
1811 ;; detected.
1812 )
1813
1814 (defun process-event (display &key handler timeout peek-p discard-p (force-output-p t))
1815 ;; If force-output-p is true, first invokes display-force-output. Invokes
1816 ;; handler on each queued event until handler returns non-nil, and that
1817 ;; returned object is then returned by process-event. If peek-p is true,
1818 ;; then the event is not removed from the queue. If discard-p is true, then
1819 ;; events for which handler returns nil are removed from the queue,
1820 ;; otherwise they are left in place. Hangs until non-nil is generated for
1821 ;; some event, or for the specified timeout (in seconds, if given); however,
1822 ;; it is acceptable for an implementation to wait only once on network data,
1823 ;; and therefore timeout prematurely. Returns nil on timeout or EOF, with a
1824 ;; second return value being :timeout for a timeout and some other non-nil
1825 ;; value for EOF. If handler is a sequence, it is expected to contain
1826 ;; handler functions specific to each event class; the event code is used to
1827 ;; index the sequence, fetching the appropriate handler. The arguments to
1828 ;; the handler are described further below using declare-event. If
1829 ;; process-event is invoked recursively, the nested invocation begins with
1830 ;; the event after the one currently being processed.
1831 (declare (type display display)
1832 (type (or (clx-sequence (function (&key &allow-other-keys) t))
1833 (function (&key &allow-other-keys) t))
1834 handler)
1835 (type (or null number) timeout)
1836 (type boolean peek-p)))
1837
1838 (defun make-event-handlers (&key (type 'array) default)
1839 (declare (type t type) ;Sequence type specifier
1840 (type function default)
1841 (clx-values sequence)) ;Default handler for initial content
1842 ;; Makes a handler sequence suitable for process-event
1843 )
1844
1845 (defun event-handler (handlers event-key)
1846 (declare (type sequence handlers)
1847 (type event-key event-key)
1848 (clx-values function))
1849 ;; Accessor for a handler sequence
1850 )
1851
1852 (defsetf event-handler (handlers event-key) (handler)
1853 (declare (type sequence handlers)
1854 (type event-key event-key)
1855 (type function handler)
1856 (clx-values function))
1857 ;; Setf accessor for a handler sequence
1858 )
1859
1860 (defmacro event-case ((display &key timeout peek-p discard-p (force-output-p t))
1861 &body clauses)
1862 (declare (arglist (display &key timeout peek-p discard-p force-output-p)
1863 (event-or-events ((&rest args) |...|) &body body) |...|))
1864 ;; If force-output-p is true, first invokes display-force-output. Executes
1865 ;; the matching clause for each queued event until a clause returns non-nil,
1866 ;; and that returned object is then returned by event-case. If peek-p is
1867 ;; true, then the event is not removed from the queue. If discard-p is
1868 ;; true, then events for which the clause returns nil are removed from the
1869 ;; queue, otherwise they are left in place. Hangs until non-nil is
1870 ;; generated for some event, or for the specified timeout (in seconds, if
1871 ;; given); however, it is acceptable for an implementation to wait only once
1872 ;; on network data, and therefore timeout prematurely. Returns nil on
1873 ;; timeout or EOF with a second return value being :timeout for a timeout
1874 ;; and some other non-nil value for EOF. In each clause, event-or-events is
1875 ;; an event-key or a list of event-keys (but they need not be typed as
1876 ;; keywords) or the symbol t or otherwise (but only in the last clause).
1877 ;; The keys are not evaluated, and it is an error for the same key to appear
1878 ;; in more than one clause. Args is the list of event components of
1879 ;; interest; corresponding values (if any) are bound to variables with these
1880 ;; names (i.e., the args are variable names, not keywords, the keywords are
1881 ;; derived from the variable names). An arg can also be a (keyword var)
1882 ;; form, as for keyword args in a lambda lists. If no t/otherwise clause
1883 ;; appears, it is equivalent to having one that returns nil. If
1884 ;; process-event is invoked recursively, the nested invocation begins with
1885 ;; the event after the one currently being processed.
1886 )
1887
1888 (defmacro event-cond ((display &key timeout peek-p discard-p (force-output-p t))
1889 &body clauses)
1890 ;; The clauses of event-cond are of the form:
1891 ;; (event-or-events binding-list test-form . body-forms)
1892 ;;
1893 ;; EVENT-OR-EVENTS event-key or a list of event-keys (but they
1894 ;; need not be typed as keywords) or the symbol t
1895 ;; or otherwise (but only in the last clause). If
1896 ;; no t/otherwise clause appears, it is equivalent
1897 ;; to having one that returns nil. The keys are
1898 ;; not evaluated, and it is an error for the same
1899 ;; key to appear in more than one clause.
1900 ;;
1901 ;; BINDING-LIST The list of event components of interest.
1902 ;; corresponding values (if any) are bound to
1903 ;; variables with these names (i.e., the binding-list
1904 ;; has variable names, not keywords, the keywords are
1905 ;; derived from the variable names). An arg can also
1906 ;; be a (keyword var) form, as for keyword args in a
1907 ;; lambda list.
1908 ;;
1909 ;; The matching TEST-FORM for each queued event is executed until a
1910 ;; clause's test-form returns non-nil. Then the BODY-FORMS are
1911 ;; evaluated, returning the (possibly multiple) values of the last
1912 ;; form from event-cond. If there are no body-forms then, if the
1913 ;; test-form is non-nil, the value of the test-form is returned as a
1914 ;; single value.
1915 ;;
1916 ;; Options:
1917 ;; FORCE-OUTPUT-P When true, first invoke display-force-output if no
1918 ;; input is pending.
1919 ;;
1920 ;; PEEK-P When true, then the event is not removed from the queue.
1921 ;;
1922 ;; DISCARD-P When true, then events for which the clause returns nil
1923 ;; are removed from the queue, otherwise they are left in place.
1924 ;;
1925 ;; TIMEOUT If NIL, hang until non-nil is generated for some event's
1926 ;; test-form. Otherwise return NIL after TIMEOUT seconds have
1927 ;; elapsed. NIL is also returned whenever EOF is read.
1928 ;; Whenever NIL is returned a second value is returned which
1929 ;; is either :TIMEOUT if a timeout occurred or some other
1930 ;; non-NIL value if an EOF is detected.
1931 ;;
1932 (declare (arglist (display &key timeout peek-p discard-p force-output-p)
1933 (event-or-events (&rest args) test-form &body body) |...|))
1934 )
1935
1936 (defun discard-current-event (display)
1937 (declare (type display display)
1938 (clx-values boolean))
1939 ;; Discard the current event for DISPLAY.
1940 ;; Returns NIL when the event queue is empty, else T.
1941 ;; To ensure events aren't ignored, application code should only call
1942 ;; this when throwing out of event-case or process-next-event, or from
1943 ;; inside even-case, event-cond or process-event when :peek-p is T and
1944 ;; :discard-p is NIL.
1945 )
1946
1947 (defmacro declare-event (event-codes &rest declares)
1948 ;; Used to indicate the keyword arguments for handler functions in process-event
1949 ;; and event-case. In the declares, an argument listed as (name1 name2) indicates
1950 ;; synonyms for the same argument. All process-event handlers can have
1951 ;; (display display), (event-key event-key), and (boolean send-event-p) as keyword
1952 ;; arguments, and an event-case clause can also have event-key and send-event-p as
1953 ;; arguments.
1954 (declare (arglist event-key-or-keys &rest (type &rest keywords))))
1955
1956 (declare-event (:key-press :key-release :button-press :button-release)
1957 (card16 sequence)
1958 (window (window event-window) root)
1959 ((or null window) child)
1960 (boolean same-screen-p)
1961 (int16 x y root-x root-y)
1962 (card16 state)
1963 ((or null card32) time)
1964 ;; for key-press and key-release, code is the keycode
1965 ;; for button-press and button-release, code is the button number
1966 (card8 code))
1967
1968 (declare-event :motion-notify
1969 (card16 sequence)
1970 (window (window event-window) root)
1971 ((or null window) child)
1972 (boolean same-screen-p)
1973 (int16 x y root-x root-y)
1974 (card16 state)
1975 ((or null card32) time)
1976 (boolean hint-p))
1977
1978 (declare-event (:enter-notify :leave-notify)
1979 (card16 sequence)
1980 (window (window event-window) root)
1981 ((or null window) child)
1982 (boolean same-screen-p)
1983 (int16 x y root-x root-y)
1984 (card16 state)
1985 ((or null card32) time)
1986 ((member :normal :grab :ungrab) mode)
1987 ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual) kind)
1988 (boolean focus-p))
1989
1990 (declare-event (:focus-in :focus-out)
1991 (card16 sequence)
1992 (window (window event-window))
1993 ((member :normal :while-grabbed :grab :ungrab) mode)
1994 ((member :ancestor :virtual :inferior :nonlinear :nonlinear-virtual
1995 :pointer :pointer-root :none)
1996 kind))
1997
1998 (declare-event :keymap-notify
1999 ((bit-vector 256) keymap))
2000
2001 (declare-event :exposure
2002 (card16 sequence)
2003 (window (window event-window))
2004 (card16 x y width height count))
2005
2006 (declare-event :graphics-exposure
2007 (card16 sequence)
2008 (drawable (drawable event-window))
2009 (card16 x y width height count)
2010 (card8 major)
2011 (card16 minor))
2012
2013 (declare-event :no-exposure
2014 (card16 sequence)
2015 (drawable (drawable event-window))
2016 (card8 major)
2017 (card16 minor))
2018
2019 (declare-event :visibility-notify
2020 (card16 sequence)
2021 (window (window event-window))
2022 ((member :unobscured :partially-obscured :fully-obscured) state))
2023
2024 (declare-event :create-notify
2025 (card16 sequence)
2026 (window window (parent event-window))
2027 (int16 x y)
2028 (card16 width height border-width)
2029 (boolean override-redirect-p))
2030
2031 (declare-event :destroy-notify
2032 (card16 sequence)
2033 (window event-window window))
2034
2035 (declare-event :unmap-notify
2036 (card16 sequence)
2037 (window event-window window)
2038 (boolean configure-p))
2039
2040 (declare-event :map-notify
2041 (card16 sequence)
2042 (window event-window window)
2043 (boolean override-redirect-p))
2044
2045 (declare-event :map-request
2046 (card16 sequence)
2047 (window (parent event-window) window))
2048
2049 (declare-event :reparent-notify
2050 (card16 sequence)
2051 (window event-window window parent)
2052 (int16 x y)
2053 (boolean override-redirect-p))
2054
2055 (declare-event :configure-notify
2056 (card16 sequence)
2057 (window event-window window)
2058 (int16 x y)
2059 (card16 width height border-width)
2060 ((or null window) above-sibling)
2061 (boolean override-redirect-p))
2062
2063 (declare-event :gravity-notify
2064 (card16 sequence)
2065 (window event-window window)
2066 (int16 x y))
2067
2068 (declare-event :resize-request
2069 (card16 sequence)
2070 (window (window event-window))
2071 (card16 width height))
2072
2073 (declare-event :configure-request
2074 (card16 sequence)
2075 (window (parent event-window) window)
2076 (int16 x y)
2077 (card16 width height border-width)
2078 ((member :above :below :top-if :bottom-if :opposite) stack-mode)
2079 ((or null window) above-sibling)
2080 (mask16 value-mask))
2081
2082 (declare-event :circulate-notify
2083 (card16 sequence)
2084 (window event-window window)
2085 ((member :top :bottom) place))
2086
2087 (declare-event :circulate-request
2088 (card16 sequence)
2089 (window (parent event-window) window)
2090 ((member :top :bottom) place))
2091
2092 (declare-event :property-notify
2093 (card16 sequence)
2094 (window (window event-window))
2095 (keyword atom)
2096 ((member :new-value :deleted) state)
2097 ((or null card32) time))
2098
2099 (declare-event :selection-clear
2100 (card16 sequence)
2101 (window (window event-window))
2102 (keyword selection)
2103 ((or null card32) time))
2104
2105 (declare-event :selection-request
2106 (card16 sequence)
2107 (window (window event-window) requestor)
2108 (keyword selection target)
2109 ((or null keyword) property)
2110 ((or null card32) time))
2111
2112 (declare-event :selection-notify
2113 (card16 sequence)
2114 (window (window event-window))
2115 (keyword selection target)
2116 ((or null keyword) property)
2117 ((or null card32) time))
2118
2119 (declare-event :colormap-notify
2120 (card16 sequence)
2121 (window (window event-window))
2122 ((or null colormap) colormap)
2123 (boolean new-p installed-p))
2124
2125 (declare-event :mapping-notify
2126 (card16 sequence)
2127 ((member :modifier :keyboard :pointer) request)
2128 (card8 start count))
2129
2130 (declare-event :client-message
2131 (card16 sequence)
2132 (window (window event-window))
2133 ((member 8 16 32) format)
2134 (sequence data))
2135
2136 (defun queue-event (display event-key &rest args &key append-p &allow-other-keys)
2137 ;; The event is put at the head of the queue if append-p is nil, else the tail.
2138 ;; Additional arguments depend on event-key, and are as specified above with
2139 ;; declare-event, except that both resource-ids and resource objects are accepted
2140 ;; in the event components.
2141 (declare (type display display)
2142 (type event-key event-key)
2143 (type boolean append-p)))
2144
2145
2146
2147 ;;; From here on, there has been less coherent review of the interface:
2148
2149 ;;;-----------------------------------------------------------------------------
2150 ;;; Window Manager Property functions
2151
2152 (defun wm-name (window)
2153 (declare (type window window)
2154 (clx-values string)))
2155
2156 (defsetf wm-name (window) (name))
2157
2158 (defun wm-icon-name (window)
2159 (declare (type window window)
2160 (clx-values string)))
2161
2162 (defsetf wm-icon-name (window) (name))
2163
2164 (defun get-wm-class (window)
2165 (declare (type window window)
2166 (clx-values (or null name-string) (or null class-string))))
2167
2168 (defun set-wm-class (window resource-name resource-class)
2169 (declare (type window window)
2170 (type (or null stringable) resource-name resource-class)))
2171
2172 (defun wm-command (window)
2173 ;; Returns a list whose car is a command string and
2174 ;; whose cdr is the list of argument strings.
2175 (declare (type window window)
2176 (clx-values (clx-list string))))
2177
2178 (defsetf wm-command (window) (command)
2179 ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
2180 ;; equivalent), with elements of command separated by NULL characters. This
2181 ;; enables
2182 ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
2183 ;; to recover a lisp command.
2184 (declare (type window window)
2185 (type (clx-list stringable) command)))
2186
2187 (defun wm-client-machine (window)
2188 ;; Returns a list whose car is a command string and
2189 ;; whose cdr is the list of argument strings.
2190 (declare (type window window)
2191 (clx-values string)))
2192
2193 (defsetf wm-client-machine (window) (string)
2194 (declare (type window window)
2195 (type stringable string)))
2196
2197 (defstruct wm-hints
2198 (input nil :type (or null (member :off :on)))
2199 (initial-state nil :type (or null (member :normal :iconic)))
2200 (icon-pixmap nil :type (or null pixmap))
2201 (icon-window nil :type (or null window))
2202 (icon-x nil :type (or null card16))
2203 (icon-y nil :type (or null card16))
2204 (icon-mask nil :type (or null pixmap))
2205 (window-group nil :type (or null resource-id))
2206 (flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field
2207 ;; may be extended in the future
2208 )
2209
2210 (defun wm-hints (window)
2211 (declare (type window window)
2212 (clx-values wm-hints)))
2213
2214 (defsetf wm-hints (window) (wm-hints))
2215
2216
2217 (defstruct wm-size-hints
2218 ;; Defaulted T to put the burden of remembering these on widget programmers.
2219 (user-specified-position-p t :type boolean) ;; True when user specified x y
2220 (user-specified-size-p t :type boolean) ;; True when user specified width height
2221 (x nil :type (or null int16)) ;; Obsolete
2222 (y nil :type (or null int16)) ;; Obsolete
2223 (width nil :type (or null card16)) ;; Obsolete
2224 (height nil :type (or null card16)) ;; Obsolete
2225 (min-width nil :type (or null card16))
2226 (min-height nil :type (or null card16))
2227 (max-width nil :type (or null card16))
2228 (max-height nil :type (or null card16))
2229 (width-inc nil :type (or null card16))
2230 (height-inc nil :type (or null card16))
2231 (min-aspect nil :type (or null number))
2232 (max-aspect nil :type (or null number))
2233 (base-width nil :type (or null card16))
2234 (base-height nil :type (or null card16))
2235 (win-gravity nil :type (or null win-gravity)))
2236
2237 (defun wm-normal-hints (window)
2238 (declare (type window window)
2239 (clx-values wm-size-hints)))
2240
2241 (defsetf wm-normal-hints (window) (wm-size-hints))
2242
2243 ;; ICON-SIZES uses the SIZE-HINTS structure
2244
2245 (defun icon-sizes (window)
2246 (declare (type window window)
2247 (clx-values wm-size-hints)))
2248
2249 (defsetf icon-sizes (window) (wm-size-hints))
2250
2251 (defun wm-protocols (window)
2252 (declare (type window window)
2253 (clx-values protocols)))
2254
2255 (defsetf wm-protocols (window) (protocols)
2256 (declare (type window window)
2257 (type (clx-list keyword) protocols)))
2258
2259 (defun wm-colormap-windows (window)
2260 (declare (type window window)
2261 (clx-values windows)))
2262
2263 (defsetf wm-colormap-windows (window) (windows)
2264 (declare (type window window)
2265 (type (clx-list window) windows)))
2266
2267 (defun transient-for (window)
2268 (declare (type window window)
2269 (clx-values window)))
2270
2271 (defsetf transient-for (window) (transient)
2272 (declare (type window window transient)))
2273
2274 (defun set-wm-properties (window &rest options &key
2275 name icon-name resource-name resource-class command
2276 hints normal-hints
2277 ;; the following are used for wm-normal-hints
2278 user-specified-position-p user-specified-size-p
2279 program-specified-position-p program-specified-size-p
2280 min-width min-height max-width max-height
2281 width-inc height-inc min-aspect max-aspect
2282 base-width base-height win-gravity
2283 ;; the following are used for wm-hints
2284 input initial-state icon-pixmap icon-window
2285 icon-x icon-y icon-mask window-group)
2286 ;; Set properties for WINDOW.
2287 (declare (type window window)
2288 (type (or null stringable) name icoin-name resource-name resource-class)
2289 (type (or null list) command)
2290 (type (or null wm-hints) hints)
2291 (type (or null wm-size-hints) normal-hints)
2292 (type boolean user-specified-position-p user-specified-size-p)
2293 (type boolean program-specified-position-p program-specified-size-p)
2294 (type (or null card16) min-width min-height max-width max-height width-inc height-inc base-width base-height win-gravity)
2295 (type (or null number) min-aspect max-aspect)
2296 (type (or null (member :off :on)) input)
2297 (type (or null (member :normal :iconic)) initial-state)
2298 (type (or null pixmap) icon-pixmap icon-mask)
2299 (type (or null window) icon-window)
2300 (type (or null card16) icon-x icon-y)
2301 (type (or null resource-id) window-group)))
2302
2303 (defun iconify-window (window)
2304 (declare (type window window)))
2305
2306 (defun withdraw-window (window)
2307 (declare (type window window)))
2308
2309 (defstruct standard-colormap
2310 (colormap nil :type (or null colormap))
2311 (base-pixel 0 :type pixel)
2312 (max-color nil :type (or null color))
2313 (mult-color nil :type (or null color))
2314 (visual nil :type (or null visual-info))
2315 (kill nil :type (or (member nil :release-by-freeing-colormap)
2316 drawable gcontext cursor colormap font)))
2317
2318 (defun rgb-colormaps (window property)
2319 (declare (type window window)
2320 (type (member :rgb_default_map :rgb_best_map :rgb_red_map
2321 :rgb_green_map :rgb_blue_map) property)
2322 (clx-values (clx-list standard-colormap))))
2323
2324 (defsetf rgb-colormaps (window property) (standard-colormaps)
2325 (declare (type window window)
2326 (type (member :rgb_default_map :rgb_best_map :rgb_red_map
2327 :rgb_green_map :rgb_blue_map) property)
2328 (type (clx-list standard-colormap) standard-colormaps)))
2329
2330 (defun cut-buffer (display &key (buffer 0) (type :string) (result-type 'string)
2331 (transform #'card8->char) (start 0) end)
2332 ;; Return the contents of cut-buffer BUFFER
2333 (declare (type display display)
2334 (type (integer 0 7) buffer)
2335 (type xatom type)
2336 (type array-index start)
2337 (type (or null array-index) end)
2338 (type t result-type) ;a sequence type
2339 (type (or null (function (integer) t)) transform)
2340 (clx-values sequence type format bytes-after)))
2341
2342 (defsetf cut-buffer (display buffer &key (type :string) (format 8)
2343 (transform #'char->card8) (start 0) end) (data))
2344
2345 (defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
2346 ;; Positive rotates left, negative rotates right (opposite of actual
2347 ;; protocol request). When careful-p, ensure all cut-buffer
2348 ;; properties are defined, to prevent errors.
2349 (declare (type display display)
2350 (type int16 delta)
2351 (type boolean careful-p)))
2352
2353 ;;;-----------------------------------------------------------------------------
2354 ;;; Keycode mapping
2355
2356 (defun define-keysym-set (set first-keysym last-keysym)
2357 ;; Define all keysyms from first-keysym up to and including
2358 ;; last-keysym to be in SET (returned from the keysym-set function).
2359 ;; Signals an error if the keysym range overlaps an existing set.
2360 (declare (type keyword set)
2361 (type keysym first-keysym last-keysym)))
2362
2363 (defun keysym-set (keysym)
2364 ;; Return the character code set name of keysym
2365 ;; Note that the keyboard set (255) has been broken up into its parts.
2366 (declare (type keysym keysym)
2367 (clx-values keyword)))
2368
2369 (defun define-keysym (object keysym &key lowercase translate modifiers mask display)
2370 ;; Define the translation from keysym/modifiers to a (usually
2371 ;; character) object. ANy previous keysym definition with
2372 ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
2373 ;;
2374 ;; MODIFIERS is either a modifier-mask or list containing intermixed
2375 ;; keysyms and state-mask-keys specifying when to use this
2376 ;; keysym-translation. The default is NIL.
2377 ;;
2378 ;; MASK is either a modifier-mask or list containing intermixed
2379 ;; keysyms and state-mask-keys specifying which modifiers to look at
2380 ;; (i.e. modifiers not specified are don't-cares).
2381 ;; If mask is :MODIFIERS then the mask is the same as the modifiers
2382 ;; (i.e. modifiers not specified by modifiers are don't cares)
2383 ;; The default mask is *default-keysym-translate-mask*
2384 ;;
2385 ;; If DISPLAY is specified, the translation will be local to DISPLAY,
2386 ;; otherwise it will be the default translation for all displays.
2387 ;;
2388 ;; LOWERCASE is used for uppercase alphabetic keysyms. The value
2389 ;; is the associated lowercase keysym. This information is used
2390 ;; by the keysym-both-case-p predicate (for caps-lock computations)
2391 ;; and by the keysym-downcase function.
2392 ;;
2393 ;; TRANSLATE will be called with parameters (display state OBJECT)
2394 ;; when translating KEYSYM and modifiers and mask are satisfied.
2395 ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
2396 ;; (or modifiers 0)))
2397 ;; when mask and modifiers aren't lists of keysyms]
2398 ;; The default is #'default-keysym-translate
2399 ;;
2400 (declare (type (or base-char t) object)
2401 (type keysym keysym)
2402 (type (or null mask16 (clx-list (or keysym state-mask-key)))
2403 modifiers)
2404 (type (or null (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
2405 mask)
2406 (type (or null display) display)
2407 (type (or null keysym) lowercase)
2408 (type (function (display card16 t) t) translate)))
2409
2410 (defvar *default-keysym-translate-mask*
2411 (the (or (member :modifiers) mask16 (clx-list (or keysym state-mask-key)))
2412 (logand #xff (lognot (make-state-mask :lock))))
2413 "Default keysym state mask to use during keysym-translation.")
2414
2415 (defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)
2416 ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
2417 ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
2418 (declare (type (or base-char t) object)
2419 (type keysym keysym)
2420 (type (or null mask16 (clx-list (or keysym state-mask-key)))
2421 modifiers)
2422 (type (or null display) display)))
2423
2424 (defun default-keysym-translate (display state object)
2425 ;; If object is a character, char-bits are set from state.
2426 ;; If object is a list, it is an alist with entries:
2427 ;; (base-char [modifiers] [mask-modifiers)
2428 ;; When MODIFIERS are specified, this character translation
2429 ;; will only take effect when the specified modifiers are pressed.
2430 ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
2431 ;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
2432 ;; In ambiguous cases, the most specific translation is used.
2433 (declare (type display display)
2434 (type card16 state)
2435 (type t object)
2436 (clx-values t))) ;; Object returned by keycode->character
2437
2438 (defmacro keysym (keysym &rest bytes)
2439 ;; Build a keysym.
2440 ;; If KEYSYM is an integer, it is used as the most significant bits of
2441 ;; the keysym, and BYTES are used to specify low order bytes. The last
2442 ;; parameter is always byte4 of the keysym. If KEYSYM is not an
2443 ;; integer, the keysym associated with KEYSYM is returned.
2444 ;;
2445 ;; This is a macro and not a function macro to promote compile-time
2446 ;; lookup. All arguments are evaluated.
2447 (declare (type t keysym)
2448 (type (clx-list card8) bytes)
2449 (clx-values keysym)))
2450
2451 (defun character->keysyms (character &optional display)
2452 ;; Given a character, return a list of all matching keysyms.
2453 ;; If DISPLAY is given, translations specific to DISPLAY are used,
2454 ;; otherwise only global translations are used.
2455 ;; Implementation dependent function.
2456 ;; May be slow [i.e. do a linear search over all known keysyms]
2457 (declare (type t character)
2458 (type (or null display) display)
2459 (clx-values (clx-list keysym))))
2460
2461 (defun keycode->keysym (display keycode keysym-index)
2462 (declare (type display display)
2463 (type card8 code)
2464 (type card16 state)
2465 (type card8 keysym-index)
2466 (clx-values keysym)))
2467
2468 (defun keysym->keycodes (display keysym)
2469 ;; Return keycodes for keysym, as multiple values
2470 (declare (type display display)
2471 (type keysym keysym)
2472 (clx-values (or null keycode) (or null keycode) (or null keycode)))
2473 )
2474
2475 (defun keysym->character (display keysym &optional state)
2476 ;; Find the character associated with a keysym.
2477 ;; STATE is used for adding char-bits to character as follows:
2478 ;; control -> char-control-bit
2479 ;; mod-1 -> char-meta-bit
2480 ;; mod-2 -> char-super-bit
2481 ;; mod-3 -> char-hyper-bit
2482 ;; Implementation dependent function.
2483 (declare (type display display)
2484 (type keysym keysym)
2485 (type (or null card16) state)
2486 (clx-values (or null character))))
2487
2488 (defun keycode->character (display keycode state &key keysym-index
2489 (keysym-index-function #'default-keysym-index))
2490 ;; keysym-index defaults to the result of keysym-index-function which
2491 ;; is called with the following parameters:
2492 ;; (char0 state caps-lock-p keysyms-per-keycode)
2493 ;; where char0 is the "character" object associated with keysym-index 0 and
2494 ;; caps-lock-p is non-nil when the keysym associated with the lock
2495 ;; modifier is for caps-lock.
2496 ;; STATE is also used for setting char-bits:
2497 ;; control -> char-control-bit
2498 ;; mod-1 -> char-meta-bit
2499 ;; mod-2 -> char-super-bit
2500 ;; mod-3 -> char-hyper-bit
2501 ;; Implementation dependent function.
2502 (declare (type display display)
2503 (type card8 keycode)
2504 (type card16 state)
2505 (type (or null card8) keysym-index)
2506 (type (or null (function (char0 state caps-lock-p keysyms-per-keycode) card8))
2507 keysym-index-function)
2508 (clx-values (or null character))))
2509
2510 (defun default-keysym-index (display keycode state)
2511 ;; Returns a keysym-index for use with keycode->character
2512 (declare (clx-values card8))
2513 )
2514
2515 ;;; default-keysym-index implements the following tables:
2516 ;;;
2517 ;;; control shift caps-lock character character
2518 ;;; 0 0 0 #\a #\8
2519 ;;; 0 0 1 #\A #\8
2520 ;;; 0 1 0 #\A #\*
2521 ;;; 0 1 1 #\A #\*
2522 ;;; 1 0 0 #\control-A #\control-8
2523 ;;; 1 0 1 #\control-A #\control-8
2524 ;;; 1 1 0 #\control-shift-a #\control-*
2525 ;;; 1 1 1 #\control-shift-a #\control-*
2526 ;;;
2527 ;;; control shift shift-lock character character
2528 ;;; 0 0 0 #\a #\8
2529 ;;; 0 0 1 #\A #\*
2530 ;;; 0 1 0 #\A #\*
2531 ;;; 0 1 1 #\A #\8
2532 ;;; 1 0 0 #\control-A #\control-8
2533 ;;; 1 0 1 #\control-A #\control-*
2534 ;;; 1 1 0 #\control-shift-a #\control-*
2535 ;;; 1 1 1 #\control-shift-a #\control-8
2536
2537 (defun state-keysymp (display state keysym)
2538 ;; Returns T when a modifier key associated with KEYSYM is on in STATE
2539 (declare (type display display)
2540 (type card16 state)
2541 (type keysym keysym)
2542 (clx-values boolean)))
2543
2544 (defun mapping-notify (display request start count)
2545 ;; Called on a mapping-notify event to update
2546 ;; the keyboard-mapping cache in DISPLAY
2547 (declare (type display display)
2548 (type (member :modifier :keyboard :pointer) request)
2549 (type card8 start count)))
2550
2551 (defun keysym-in-map-p (display keysym keymap)
2552 ;; Returns T if keysym is found in keymap
2553 (declare (type display display)
2554 (type keysym keysym)
2555 (type (bit-vector 256) keymap)
2556 (value boolean)))
2557
2558 (defun character-in-map-p (display character keymap)
2559 ;; Implementation dependent function.
2560 ;; Returns T if character is found in keymap
2561 (declare (type display display)
2562 (type t character)
2563 (type (bit-vector 256) keymap)
2564 (value boolean)))
2565
2566 ;;;-----------------------------------------------------------------------------
2567 ;;; Extensions
2568
2569 (defmacro define-extension (name &key events errors)
2570 ;; Define extension NAME with EVENTS and ERRORS.
2571 ;; Note: The case of NAME is important.
2572 ;; To define the request, Use:
2573 ;; (with-buffer-request (display (extension-opcode ,name)) ,@body)
2574 ;; See the REQUESTS file for lots of examples.
2575 ;; To define event handlers, use declare-event.
2576 ;; To define error handlers, use declare-error and define-condition.
2577 (declare (type stringable name)
2578 (type (clx-list symbol) events errors)))
2579
2580 (defmacro extension-opcode (display name)
2581 ;; Returns the major opcode for extension NAME.
2582 ;;