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

Contents of /src/clx/requests.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Mon Aug 19 16:22:20 2002 UTC (11 years, 8 months ago) by toy
Branch: MAIN
CVS Tags: LINKAGE_TABLE, PRE_LINKAGE_TABLE, UNICODE-BASE
Branch point for: UNICODE-BRANCH
Changes since 1.5: +3 -3 lines
From Iban Hatchondo:

    Also in request.lisp, we have all the grab/ungrab key/button that
    have 0 for the default value of the modifiers keyword
    argument. But the clx manual says:

    " A zero /modifier/mask is equivalent to issuing the request for all
    possible modifier-key combinations (including the combination of no
    modifiers)."

    Shouldn't be the default value :any ? Or is the documentation wrong ?
1 ram 1.1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2    
3     ;;;
4     ;;; TEXAS INSTRUMENTS INCORPORATED
5     ;;; P.O. BOX 2909
6     ;;; AUSTIN, TEXAS 78769
7     ;;;
8     ;;; Copyright (C) 1987 Texas Instruments Incorporated.
9     ;;;
10     ;;; Permission is granted to any individual or institution to use, copy, modify,
11     ;;; and distribute this software, provided that this complete copyright and
12     ;;; permission notice is maintained, intact, in all copies and supporting
13     ;;; documentation.
14     ;;;
15     ;;; Texas Instruments Incorporated provides this software "as is" without
16     ;;; express or implied warranty.
17     ;;;
18 dtc 1.5 #+cmu
19     (ext:file-comment
20 toy 1.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/requests.lisp,v 1.6 2002/08/19 16:22:20 toy Exp $")
21 ram 1.1
22     (in-package :xlib)
23    
24     (defun create-window (&key
25 ram 1.2 window
26 ram 1.1 (parent (required-arg parent))
27     (x (required-arg x))
28     (y (required-arg y))
29     (width (required-arg width))
30     (height (required-arg height))
31     (depth 0) (border-width 0)
32     (class :copy) (visual :copy)
33     background border
34     bit-gravity gravity
35     backing-store backing-planes backing-pixel save-under
36     event-mask do-not-propagate-mask override-redirect
37     colormap cursor)
38     ;; Display is obtained from parent. Only non-nil attributes are passed on in
39     ;; the request: the function makes no assumptions about what the actual protocol
40     ;; defaults are. Width and height are the inside size, excluding border.
41 ram 1.2 (declare (type (or null window) window)
42     (type window parent) ; required
43 ram 1.1 (type int16 x y) ;required
44     (type card16 width height) ;required
45     (type card16 depth border-width)
46     (type (member :copy :input-output :input-only) class)
47     (type (or (member :copy) visual-info resource-id) visual)
48     (type (or null (member :none :parent-relative) pixel pixmap) background)
49     (type (or null (member :copy) pixel pixmap) border)
50     (type (or null bit-gravity) bit-gravity)
51     (type (or null win-gravity) gravity)
52     (type (or null (member :not-useful :when-mapped :always)) backing-store)
53     (type (or null pixel) backing-planes backing-pixel)
54     (type (or null event-mask) event-mask)
55     (type (or null device-event-mask) do-not-propagate-mask)
56     (type (or null (member :on :off)) save-under override-redirect)
57     (type (or null (member :copy) colormap) colormap)
58     (type (or null (member :none) cursor) cursor))
59 ram 1.3 (declare (clx-values window))
60 ram 1.1 (let* ((display (window-display parent))
61 ram 1.2 (window (or window (make-window :display display)))
62 ram 1.1 (wid (allocate-resource-id display window 'window))
63     back-pixmap back-pixel
64     border-pixmap border-pixel)
65     (declare (type display display)
66     (type window window)
67     (type resource-id wid)
68     (type (or null resource-id) back-pixmap border-pixmap)
69     (type (or null pixel) back-pixel border-pixel))
70     (setf (window-id window) wid)
71     (case background
72     ((nil) nil)
73     (:none (setq back-pixmap 0))
74     (:parent-relative (setq back-pixmap 1))
75     (otherwise
76     (if (type? background 'pixmap)
77     (setq back-pixmap (pixmap-id background))
78     (if (integerp background)
79     (setq back-pixel background)
80     (x-type-error background
81     '(or null (member :none :parent-relative) integer pixmap))))))
82     (case border
83     ((nil) nil)
84     (:copy (setq border-pixmap 0))
85     (otherwise
86     (if (type? border 'pixmap)
87     (setq border-pixmap (pixmap-id border))
88     (if (integerp border)
89     (setq border-pixel border)
90     (x-type-error border '(or null (member :copy) integer pixmap))))))
91     (when event-mask
92     (setq event-mask (encode-event-mask event-mask)))
93     (when do-not-propagate-mask
94     (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
95    
96     ;Make the request
97     (with-buffer-request (display *x-createwindow*)
98     (data depth)
99     (resource-id wid)
100     (window parent)
101     (int16 x y)
102     (card16 width height border-width)
103     ((member16 :copy :input-output :input-only) class)
104     (resource-id (cond ((eq visual :copy)
105     0)
106     ((typep visual 'resource-id)
107     visual)
108     (t
109     (visual-info-id visual))))
110     (mask (card32 back-pixmap back-pixel border-pixmap border-pixel)
111     ((member-vector *bit-gravity-vector*) bit-gravity)
112     ((member-vector *win-gravity-vector*) gravity)
113     ((member :not-useful :when-mapped :always) backing-store)
114     (card32 backing-planes backing-pixel)
115     ((member :off :on) override-redirect save-under)
116     (card32 event-mask do-not-propagate-mask)
117     ((or (member :copy) colormap) colormap)
118     ((or (member :none) cursor) cursor)))
119     window))
120    
121     (defun destroy-window (window)
122     (declare (type window window))
123     (with-buffer-request ((window-display window) *x-destroywindow*)
124     (window window)))
125    
126     (defun destroy-subwindows (window)
127     (declare (type window window))
128     (with-buffer-request ((window-display window) *x-destroysubwindows*)
129     (window window)))
130    
131     (defun add-to-save-set (window)
132     (declare (type window window))
133     (with-buffer-request ((window-display window) *x-changesaveset*)
134     (data 0)
135     (window window)))
136    
137     (defun remove-from-save-set (window)
138     (declare (type window window))
139     (with-buffer-request ((window-display window) *x-changesaveset*)
140     (data 1)
141     (window window)))
142    
143     (defun reparent-window (window parent x y)
144     (declare (type window window parent)
145     (type int16 x y))
146     (with-buffer-request ((window-display window) *x-reparentwindow*)
147     (window window parent)
148     (int16 x y)))
149    
150     (defun map-window (window)
151     (declare (type window window))
152     (with-buffer-request ((window-display window) *x-mapwindow*)
153     (window window)))
154    
155     (defun map-subwindows (window)
156     (declare (type window window))
157     (with-buffer-request ((window-display window) *x-mapsubwindows*)
158     (window window)))
159    
160     (defun unmap-window (window)
161     (declare (type window window))
162     (with-buffer-request ((window-display window) *x-unmapwindow*)
163     (window window)))
164    
165     (defun unmap-subwindows (window)
166     (declare (type window window))
167     (with-buffer-request ((window-display window) *x-unmapsubwindows*)
168     (window window)))
169    
170     (defun circulate-window-up (window)
171     (declare (type window window))
172     (with-buffer-request ((window-display window) *x-circulatewindow*)
173     (data 0)
174     (window window)))
175    
176     (defun circulate-window-down (window)
177     (declare (type window window))
178     (with-buffer-request ((window-display window) *x-circulatewindow*)
179     (data 1)
180     (window window)))
181    
182     (defun query-tree (window &key (result-type 'list))
183     (declare (type window window)
184     (type t result-type)) ;;type specifier
185 ram 1.3 (declare (clx-values (clx-sequence window) parent root))
186 ram 1.1 (let ((display (window-display window)))
187     (multiple-value-bind (root parent sequence)
188     (with-buffer-request-and-reply (display *x-querytree* nil :sizes (8 16 32))
189     ((window window))
190     (values
191     (window-get 8)
192     (resource-id-get 12)
193     (sequence-get :length (card16-get 16) :result-type result-type
194     :index *replysize*)))
195     ;; Parent is NIL for root window
196     (setq parent (and (plusp parent) (lookup-window display parent)))
197     (dotimes (i (length sequence)) ; Convert ID's to window's
198     (setf (elt sequence i) (lookup-window display (elt sequence i))))
199     (values sequence parent root))))
200    
201     ;; Although atom-ids are not visible in the normal user interface, atom-ids might
202     ;; appear in window properties and other user data, so conversion hooks are needed.
203    
204     (defun intern-atom (display name)
205     (declare (type display display)
206     (type xatom name))
207 ram 1.3 (declare (clx-values resource-id))
208 ram 1.2 (let ((name (if (or (null name) (keywordp name))
209     name
210     (kintern (string name)))))
211     (declare (type symbol name))
212     (or (atom-id name display)
213     (let ((string (symbol-name name)))
214 ram 1.1 (declare (type string string))
215     (multiple-value-bind (id)
216     (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
217     ((data 0)
218     (card16 (length string))
219     (pad16 nil)
220     (string string))
221     (values
222     (resource-id-get 8)))
223     (declare (type resource-id id))
224 ram 1.2 (setf (atom-id name display) id)
225 ram 1.1 id)))))
226    
227     (defun find-atom (display name)
228     ;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True
229     (declare (type display display)
230     (type xatom name))
231 ram 1.3 (declare (clx-values (or null resource-id)))
232 ram 1.2 (let ((name (if (or (null name) (keywordp name))
233     name
234     (kintern (string name)))))
235     (declare (type symbol name))
236     (or (atom-id name display)
237     (let ((string (symbol-name name)))
238 ram 1.1 (declare (type string string))
239     (multiple-value-bind (id)
240     (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)
241     ((data 1)
242     (card16 (length string))
243     (pad16 nil)
244     (string string))
245     (values
246     (or-get 8 null resource-id)))
247     (declare (type (or null resource-id) id))
248     (when id
249 ram 1.2 (setf (atom-id name display) id))
250 ram 1.1 id)))))
251    
252     (defun atom-name (display atom-id)
253     (declare (type display display)
254     (type resource-id atom-id))
255 ram 1.3 (declare (clx-values keyword))
256 ram 1.2 (if (zerop atom-id)
257     nil
258 ram 1.1 (or (id-atom atom-id display)
259     (let ((keyword
260     (kintern
261 ram 1.2 (with-buffer-request-and-reply
262     (display *x-getatomname* nil :sizes (16))
263 ram 1.1 ((resource-id atom-id))
264     (values
265     (string-get (card16-get 8) *replysize*))))))
266     (declare (type keyword keyword))
267     (setf (atom-id keyword display) atom-id)
268 ram 1.2 keyword))))
269 ram 1.1
270     ;;; For binary compatibility with older code
271     (defun lookup-xatom (display atom-id)
272     (declare (type display display)
273     (type resource-id atom-id))
274     (atom-name display atom-id))
275    
276     (defun change-property (window property data type format
277     &key (mode :replace) (start 0) end transform)
278     ; Start and end affect sub-sequence extracted from data.
279     ; Transform is applied to each extracted element.
280     (declare (type window window)
281     (type xatom property type)
282     (type (member 8 16 32) format)
283     (type sequence data)
284     (type (member :replace :prepend :append) mode)
285     (type array-index start)
286     (type (or null array-index) end)
287 ram 1.3 (type (or null (function (t) integer)) transform))
288 ram 1.1 (unless end (setq end (length data)))
289     (let* ((display (window-display window))
290     (length (index- end start))
291     (property-id (intern-atom display property))
292     (type-id (intern-atom display type)))
293     (declare (type display display)
294     (type array-index length)
295     (type resource-id property-id type-id))
296     (with-buffer-request (display *x-changeproperty*)
297     ((data (member :replace :prepend :append)) mode)
298     (window window)
299     (resource-id property-id type-id)
300     (card8 format)
301     (card32 length)
302     (progn
303     (ecase format
304     (8 (sequence-put 24 data :format card8
305     :start start :end end :transform transform))
306     (16 (sequence-put 24 data :format card16
307     :start start :end end :transform transform))
308     (32 (sequence-put 24 data :format card32
309     :start start :end end :transform transform)))))))
310    
311     (defun delete-property (window property)
312     (declare (type window window)
313     (type xatom property))
314     (let* ((display (window-display window))
315     (property-id (intern-atom display property)))
316     (declare (type display display)
317     (type resource-id property-id))
318     (with-buffer-request (display *x-deleteproperty*)
319     (window window)
320     (resource-id property-id))))
321    
322     (defun get-property (window property
323     &key type (start 0) end delete-p (result-type 'list) transform)
324     ;; Transform is applied to each integer retrieved.
325     (declare (type window window)
326     (type xatom property)
327     (type (or null xatom) type)
328     (type array-index start)
329     (type (or null array-index) end)
330 dtc 1.4 (type generalized-boolean delete-p)
331 ram 1.1 (type t result-type) ;a sequence type
332 ram 1.3 (type (or null (function (integer) t)) transform))
333     (declare (clx-values data (or null type) format bytes-after))
334 ram 1.1 (let* ((display (window-display window))
335     (property-id (intern-atom display property))
336     (type-id (and type (intern-atom display type))))
337     (declare (type display display)
338     (type resource-id property-id)
339     (type (or null resource-id) type-id))
340     (multiple-value-bind (reply-format reply-type bytes-after data)
341     (with-buffer-request-and-reply (display *x-getproperty* nil :sizes (8 32))
342     (((data boolean) delete-p)
343     (window window)
344     (resource-id property-id)
345     ((or null resource-id) type-id)
346     (card32 start)
347     (card32 (index- (or end 64000) start)))
348     (let ((reply-format (card8-get 1))
349     (reply-type (card32-get 8))
350     (bytes-after (card32-get 12))
351     (nitems (card32-get 16)))
352     (values
353     reply-format
354     reply-type
355     bytes-after
356     (and (plusp nitems)
357     (ecase reply-format
358     (0 nil) ;; (make-sequence result-type 0) ;; Property not found.
359     (8 (sequence-get :result-type result-type :format card8
360     :length nitems :transform transform
361     :index *replysize*))
362     (16 (sequence-get :result-type result-type :format card16
363     :length nitems :transform transform
364     :index *replysize*))
365     (32 (sequence-get :result-type result-type :format card32
366     :length nitems :transform transform
367     :index *replysize*)))))))
368     (values data
369     (and (plusp reply-type) (atom-name display reply-type))
370     reply-format
371     bytes-after))))
372    
373     (defun rotate-properties (window properties &optional (delta 1))
374     ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
375     (declare (type window window)
376     (type sequence properties) ;; sequence of xatom
377     (type int16 delta))
378     (let* ((display (window-display window))
379     (length (length properties))
380     (sequence (make-array length)))
381     (declare (type display display)
382     (type array-index length))
383     (with-vector (sequence vector)
384     ;; Atoms must be interned before the RotateProperties request
385     ;; is started to allow InternAtom requests to be made.
386     (dotimes (i length)
387     (setf (aref sequence i) (intern-atom display (elt properties i))))
388     (with-buffer-request (display *x-rotateproperties*)
389     (window window)
390     (card16 length)
391     (int16 (- delta))
392     ((sequence :end length) sequence))))
393     nil)
394    
395     (defun list-properties (window &key (result-type 'list))
396     (declare (type window window)
397     (type t result-type)) ;; a sequence type
398 ram 1.3 (declare (clx-values (clx-sequence keyword)))
399 ram 1.1 (let ((display (window-display window)))
400     (multiple-value-bind (seq)
401     (with-buffer-request-and-reply (display *x-listproperties* nil :sizes 16)
402     ((window window))
403     (values
404     (sequence-get :result-type result-type :length (card16-get 8)
405     :index *replysize*)))
406     ;; lookup the atoms in the sequence
407     (if (listp seq)
408     (do ((elt seq (cdr elt)))
409     ((endp elt) seq)
410     (setf (car elt) (atom-name display (car elt))))
411     (dotimes (i (length seq) seq)
412     (setf (aref seq i) (atom-name display (aref seq i))))))))
413    
414     (defun selection-owner (display selection)
415     (declare (type display display)
416     (type xatom selection))
417 ram 1.3 (declare (clx-values (or null window)))
418 ram 1.1 (let ((selection-id (intern-atom display selection)))
419     (declare (type resource-id selection-id))
420     (multiple-value-bind (window)
421     (with-buffer-request-and-reply (display *x-getselectionowner* 12 :sizes 32)
422     ((resource-id selection-id))
423     (values
424     (resource-id-or-nil-get 8)))
425     (and window (lookup-window display window)))))
426    
427     (defun set-selection-owner (display selection owner &optional time)
428     (declare (type display display)
429     (type xatom selection)
430     (type (or null window) owner)
431     (type timestamp time))
432     (let ((selection-id (intern-atom display selection)))
433     (declare (type resource-id selection-id))
434     (with-buffer-request (display *x-setselectionowner*)
435     ((or null window) owner)
436     (resource-id selection-id)
437     ((or null card32) time))
438     owner))
439    
440     (defsetf selection-owner (display selection &optional time) (owner)
441     ;; A bit strange, but retains setf form.
442     `(set-selection-owner ,display ,selection ,owner ,time))
443    
444     (defun convert-selection (selection type requestor &optional property time)
445     (declare (type xatom selection type)
446     (type window requestor)
447     (type (or null xatom) property)
448     (type timestamp time))
449     (let* ((display (window-display requestor))
450     (selection-id (intern-atom display selection))
451     (type-id (intern-atom display type))
452     (property-id (and property (intern-atom display property))))
453     (declare (type display display)
454     (type resource-id selection-id type-id)
455     (type (or null resource-id) property-id))
456     (with-buffer-request (display *x-convertselection*)
457     (window requestor)
458     (resource-id selection-id type-id)
459     ((or null resource-id) property-id)
460     ((or null card32) time))))
461    
462     (defun send-event (window event-key event-mask &rest args
463     &key propagate-p display &allow-other-keys)
464     ;; Additional arguments depend on event-key, and are as specified further below
465     ;; with declare-event, except that both resource-ids and resource objects are
466     ;; accepted in the event components. The display argument is only required if the
467     ;; window is :pointer-window or :input-focus.
468     (declare (type (or window (member :pointer-window :input-focus)) window)
469     (type event-key event-key)
470     (type (or null event-mask) event-mask)
471 dtc 1.4 (type generalized-boolean propagate-p)
472 ram 1.1 (type (or null display) display)
473     (dynamic-extent args))
474     (unless event-mask (setq event-mask 0))
475     (unless display (setq display (window-display window)))
476     (let ((internal-event-code (get-event-code event-key))
477     (external-event-code (get-external-event-code display event-key)))
478     (declare (type card8 internal-event-code external-event-code))
479     ;; Ensure keyword atom-id's are cached
480     (dolist (arg (cdr (assoc event-key '((:property-notify :atom)
481     (:selection-clear :selection)
482     (:selection-request :selection :target :property)
483     (:selection-notify :selection :target :property)
484     (:client-message :type))
485     :test #'eq)))
486     (let ((keyword (getf args arg)))
487     (intern-atom display keyword)))
488     ;; Make the sendevent request
489     (with-buffer-request (display *x-sendevent*)
490     ((data boolean) propagate-p)
491     (length 11) ;; 3 word request + 8 words for event = 11
492     ((or (member :pointer-window :input-focus) window) window)
493     (card32 (encode-event-mask event-mask))
494     (card8 external-event-code)
495     (progn
496     (apply (svref *event-send-vector* internal-event-code) display args)
497     (setf (buffer-boffset display) (index+ buffer-boffset 44))))))
498    
499     (defun grab-pointer (window event-mask
500     &key owner-p sync-pointer-p sync-keyboard-p confine-to cursor time)
501     (declare (type window window)
502     (type pointer-event-mask event-mask)
503 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
504 ram 1.1 (type (or null window) confine-to)
505     (type (or null cursor) cursor)
506     (type timestamp time))
507 ram 1.3 (declare (clx-values grab-status))
508 ram 1.1 (let ((display (window-display window)))
509     (with-buffer-request-and-reply (display *x-grabpointer* nil :sizes 8)
510     (((data boolean) owner-p)
511     (window window)
512     (card16 (encode-pointer-event-mask event-mask))
513     (boolean (not sync-pointer-p) (not sync-keyboard-p))
514     ((or null window) confine-to)
515     ((or null cursor) cursor)
516     ((or null card32) time))
517     (values
518     (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
519    
520     (defun ungrab-pointer (display &key time)
521     (declare (type timestamp time))
522     (with-buffer-request (display *x-ungrabpointer*)
523     ((or null card32) time)))
524    
525     (defun grab-button (window button event-mask
526 toy 1.6 &key (modifiers :any)
527 ram 1.1 owner-p sync-pointer-p sync-keyboard-p confine-to cursor)
528     (declare (type window window)
529     (type (or (member :any) card8) button)
530     (type modifier-mask modifiers)
531     (type pointer-event-mask event-mask)
532 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
533 ram 1.1 (type (or null window) confine-to)
534     (type (or null cursor) cursor))
535     (with-buffer-request ((window-display window) *x-grabbutton*)
536     ((data boolean) owner-p)
537     (window window)
538     (card16 (encode-pointer-event-mask event-mask))
539     (boolean (not sync-pointer-p) (not sync-keyboard-p))
540     ((or null window) confine-to)
541     ((or null cursor) cursor)
542     (card8 (if (eq button :any) 0 button))
543     (pad8 1)
544     (card16 (encode-modifier-mask modifiers))))
545    
546 toy 1.6 (defun ungrab-button (window button &key (modifiers :any))
547 ram 1.1 (declare (type window window)
548     (type (or (member :any) card8) button)
549     (type modifier-mask modifiers))
550     (with-buffer-request ((window-display window) *x-ungrabbutton*)
551     (data (if (eq button :any) 0 button))
552     (window window)
553     (card16 (encode-modifier-mask modifiers))))
554    
555     (defun change-active-pointer-grab (display event-mask &optional cursor time)
556     (declare (type display display)
557     (type pointer-event-mask event-mask)
558     (type (or null cursor) cursor)
559     (type timestamp time))
560     (with-buffer-request (display *x-changeactivepointergrab*)
561     ((or null cursor) cursor)
562     ((or null card32) time)
563     (card16 (encode-pointer-event-mask event-mask))))
564    
565     (defun grab-keyboard (window &key owner-p sync-pointer-p sync-keyboard-p time)
566     (declare (type window window)
567 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
568 ram 1.1 (type timestamp time))
569 ram 1.3 (declare (clx-values grab-status))
570 ram 1.1 (let ((display (window-display window)))
571     (with-buffer-request-and-reply (display *x-grabkeyboard* nil :sizes 8)
572     (((data boolean) owner-p)
573     (window window)
574     ((or null card32) time)
575     (boolean (not sync-pointer-p) (not sync-keyboard-p)))
576     (values
577     (member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
578    
579     (defun ungrab-keyboard (display &key time)
580     (declare (type display display)
581     (type timestamp time))
582     (with-buffer-request (display *x-ungrabkeyboard*)
583     ((or null card32) time)))
584    
585     (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
586     (declare (type window window)
587 dtc 1.4 (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
588 ram 1.1 (type (or (member :any) card8) key)
589     (type modifier-mask modifiers))
590     (with-buffer-request ((window-display window) *x-grabkey*)
591     ((data boolean) owner-p)
592     (window window)
593     (card16 (encode-modifier-mask modifiers))
594     (card8 (if (eq key :any) 0 key))
595     (boolean (not sync-pointer-p) (not sync-keyboard-p))))
596    
597     (defun ungrab-key (window key &key (modifiers 0))
598     (declare (type window window)
599     (type (or (member :any) card8) key)
600     (type modifier-mask modifiers))
601     (with-buffer-request ((window-display window) *x-ungrabkey*)
602     (data (if (eq key :any) 0 key))
603     (window window)
604     (card16 (encode-modifier-mask modifiers))))
605    
606     (defun allow-events (display mode &optional time)
607     (declare (type display display)
608     (type (member :async-pointer :sync-pointer :replay-pointer
609     :async-keyboard :sync-keyboard :replay-keyboard
610     :async-both :sync-both)
611     mode)
612     (type timestamp time))
613     (with-buffer-request (display *x-allowevents*)
614     ((data (member :async-pointer :sync-pointer :replay-pointer
615     :async-keyboard :sync-keyboard :replay-keyboard
616     :async-both :sync-both))
617     mode)
618     ((or null card32) time)))
619    
620     (defun grab-server (display)
621     (declare (type display display))
622     (with-buffer-request (display *x-grabserver*)))
623    
624     (defun ungrab-server (display)
625     (with-buffer-request (display *x-ungrabserver*)))
626    
627     (defmacro with-server-grabbed ((display) &body body)
628     ;; The body is not surrounded by a with-display.
629     (let ((disp (if (symbolp display) display (gensym))))
630     `(let ((,disp ,display))
631     (declare (type display ,disp))
632     (unwind-protect
633     (progn
634     (grab-server ,disp)
635     ,@body)
636     (ungrab-server ,disp)))))
637    
638     (defun query-pointer (window)
639     (declare (type window window))
640 ram 1.3 (declare (clx-values x y same-screen-p child mask root-x root-y root))
641 ram 1.1 (let ((display (window-display window)))
642     (with-buffer-request-and-reply (display *x-querypointer* 26 :sizes (8 16 32))
643     ((window window))
644     (values
645     (int16-get 20)
646     (int16-get 22)
647     (boolean-get 1)
648     (or-get 12 null window)
649     (card16-get 24)
650     (int16-get 16)
651     (int16-get 18)
652     (window-get 8)))))
653    
654     (defun pointer-position (window)
655     (declare (type window window))
656 ram 1.3 (declare (clx-values x y same-screen-p))
657 ram 1.1 (let ((display (window-display window)))
658     (with-buffer-request-and-reply (display *x-querypointer* 24 :sizes (8 16))
659     ((window window))
660     (values
661     (int16-get 20)
662     (int16-get 22)
663     (boolean-get 1)))))
664    
665     (defun global-pointer-position (display)
666     (declare (type display display))
667 ram 1.3 (declare (clx-values root-x root-y root))
668 ram 1.1 (with-buffer-request-and-reply (display *x-querypointer* 20 :sizes (16 32))
669     ((window (screen-root (first (display-roots display)))))
670     (values
671     (int16-get 16)
672     (int16-get 18)
673     (window-get 8))))
674    
675     (defun motion-events (window &key start stop (result-type 'list))
676     (declare (type window window)
677     (type timestamp start stop)
678     (type t result-type)) ;; a type specifier
679 ram 1.3 (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time))))
680 ram 1.1 (let ((display (window-display window)))
681     (with-buffer-request-and-reply (display *x-getmotionevents* nil :sizes 32)
682     ((window window)
683     ((or null card32) start stop))
684     (values
685     (sequence-get :result-type result-type :length (index* (card32-get 8) 3)
686     :index *replysize*)))))
687    
688     (defun translate-coordinates (src src-x src-y dst)
689     ;; Returns NIL when not on the same screen
690     (declare (type window src)
691     (type int16 src-x src-y)
692     (type window dst))
693 ram 1.3 (declare (clx-values dst-x dst-y child))
694 ram 1.1 (let ((display (window-display src)))
695     (with-buffer-request-and-reply (display *x-translatecoords* 16 :sizes (8 16 32))
696     ((window src dst)
697     (int16 src-x src-y))
698     (and (boolean-get 1)
699     (values
700     (int16-get 12)
701     (int16-get 14)
702     (or-get 8 null window))))))
703    
704     (defun warp-pointer (dst dst-x dst-y)
705     (declare (type window dst)
706     (type int16 dst-x dst-y))
707     (with-buffer-request ((window-display dst) *x-warppointer*)
708     (resource-id 0) ;; None
709     (window dst)
710     (int16 0 0)
711     (card16 0 0)
712     (int16 dst-x dst-y)))
713    
714     (defun warp-pointer-relative (display x-off y-off)
715     (declare (type display display)
716     (type int16 x-off y-off))
717     (with-buffer-request (display *x-warppointer*)
718     (resource-id 0) ;; None
719     (resource-id 0) ;; None
720     (int16 0 0)
721     (card16 0 0)
722     (int16 x-off y-off)))
723    
724     (defun warp-pointer-if-inside (dst dst-x dst-y src src-x src-y
725     &optional src-width src-height)
726     ;; Passing in a zero src-width or src-height is a no-op.
727     ;; A null src-width or src-height translates into a zero value in the protocol request.
728     (declare (type window dst src)
729     (type int16 dst-x dst-y src-x src-y)
730     (type (or null card16) src-width src-height))
731     (unless (or (eql src-width 0) (eql src-height 0))
732     (with-buffer-request ((window-display dst) *x-warppointer*)
733     (window src dst)
734     (int16 src-x src-y)
735     (card16 (or src-width 0) (or src-height 0))
736     (int16 dst-x dst-y))))
737    
738     (defun warp-pointer-relative-if-inside (x-off y-off src src-x src-y
739     &optional src-width src-height)
740     ;; Passing in a zero src-width or src-height is a no-op.
741     ;; A null src-width or src-height translates into a zero value in the protocol request.
742     (declare (type window src)
743     (type int16 x-off y-off src-x src-y)
744     (type (or null card16) src-width src-height))
745     (unless (or (eql src-width 0) (eql src-height 0))
746     (with-buffer-request ((window-display src) *x-warppointer*)
747     (window src)
748     (resource-id 0) ;; None
749     (int16 src-x src-y)
750     (card16 (or src-width 0) (or src-height 0))
751     (int16 x-off y-off))))
752    
753     (defun set-input-focus (display focus revert-to &optional time)
754     (declare (type display display)
755     (type (or (member :none :pointer-root) window) focus)
756 ram 1.2 (type (member :none :pointer-root :parent) revert-to)
757 ram 1.1 (type timestamp time))
758     (with-buffer-request (display *x-setinputfocus*)
759 ram 1.2 ((data (member :none :pointer-root :parent)) revert-to)
760 ram 1.1 ((or window (member :none :pointer-root)) focus)
761     ((or null card32) time)))
762    
763     (defun input-focus (display)
764     (declare (type display display))
765 ram 1.3 (declare (clx-values focus revert-to))
766 ram 1.1 (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))
767     ()
768     (values
769     (or-get 8 (member :none :pointer-root) window)
770     (member8-get 1 :none :pointer-root :parent))))
771    
772     (defun query-keymap (display &optional bit-vector)
773     (declare (type display display)
774     (type (or null (bit-vector 256)) bit-vector))
775 ram 1.3 (declare (clx-values (bit-vector 256)))
776 ram 1.1 (with-buffer-request-and-reply (display *x-querykeymap* 40 :sizes 8)
777     ()
778     (values
779     (bit-vector256-get 8 8 bit-vector))))
780    
781     (defun create-pixmap (&key
782 ram 1.2 pixmap
783 ram 1.1 (width (required-arg width))
784     (height (required-arg height))
785     (depth (required-arg depth))
786     (drawable (required-arg drawable)))
787 ram 1.2 (declare (type (or null pixmap) pixmap)
788     (type card8 depth) ;; required
789 ram 1.1 (type card16 width height) ;; required
790     (type drawable drawable)) ;; required
791 ram 1.3 (declare (clx-values pixmap))
792 ram 1.1 (let* ((display (drawable-display drawable))
793 ram 1.2 (pixmap (or pixmap (make-pixmap :display display)))
794 ram 1.1 (pid (allocate-resource-id display pixmap 'pixmap)))
795     (setf (pixmap-id pixmap) pid)
796     (with-buffer-request (display *x-createpixmap*)
797     (data depth)
798     (resource-id pid)
799     (drawable drawable)
800     (card16 width height))
801     pixmap))
802    
803     (defun free-pixmap (pixmap)
804     (declare (type pixmap pixmap))
805     (let ((display (pixmap-display pixmap)))
806     (with-buffer-request (display *x-freepixmap*)
807     (pixmap pixmap))
808     (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
809    
810     (defun clear-area (window &key (x 0) (y 0) width height exposures-p)
811     ;; Passing in a zero width or height is a no-op.
812     ;; A null width or height translates into a zero value in the protocol request.
813     (declare (type window window)
814     (type int16 x y)
815     (type (or null card16) width height)
816 dtc 1.4 (type generalized-boolean exposures-p))
817 ram 1.1 (unless (or (eql width 0) (eql height 0))
818     (with-buffer-request ((window-display window) *x-cleartobackground*)
819     ((data boolean) exposures-p)
820     (window window)
821     (int16 x y)
822     (card16 (or width 0) (or height 0)))))
823    
824     (defun copy-area (src gcontext src-x src-y width height dst dst-x dst-y)
825     (declare (type drawable src dst)
826     (type gcontext gcontext)
827     (type int16 src-x src-y dst-x dst-y)
828     (type card16 width height))
829     (with-buffer-request ((drawable-display src) *x-copyarea* :gc-force gcontext)
830     (drawable src dst)
831     (gcontext gcontext)
832     (int16 src-x src-y dst-x dst-y)
833     (card16 width height)))
834    
835     (defun copy-plane (src gcontext plane src-x src-y width height dst dst-x dst-y)
836     (declare (type drawable src dst)
837     (type gcontext gcontext)
838     (type pixel plane)
839     (type int16 src-x src-y dst-x dst-y)
840     (type card16 width height))
841     (with-buffer-request ((drawable-display src) *x-copyplane* :gc-force gcontext)
842     (drawable src dst)
843     (gcontext gcontext)
844     (int16 src-x src-y dst-x dst-y)
845     (card16 width height)
846     (card32 plane)))
847    
848     (defun create-colormap (visual-info window &optional alloc-p)
849     (declare (type (or visual-info resource-id) visual-info)
850     (type window window)
851 dtc 1.4 (type generalized-boolean alloc-p))
852 ram 1.3 (declare (clx-values colormap))
853 ram 1.1 (let ((display (window-display window)))
854     (when (typep visual-info 'resource-id)
855     (setf visual-info (visual-info display visual-info)))
856     (let* ((colormap (make-colormap :display display :visual-info visual-info))
857     (id (allocate-resource-id display colormap 'colormap)))
858     (setf (colormap-id colormap) id)
859     (with-buffer-request (display *x-createcolormap*)
860     ((data boolean) alloc-p)
861     (card29 id)
862     (window window)
863     (card29 (visual-info-id visual-info)))
864     colormap)))
865    
866     (defun free-colormap (colormap)
867     (declare (type colormap colormap))
868     (let ((display (colormap-display colormap)))
869     (with-buffer-request (display *x-freecolormap*)
870     (colormap colormap))
871     (deallocate-resource-id display (colormap-id colormap) 'colormap)))
872    
873     (defun copy-colormap-and-free (colormap)
874     (declare (type colormap colormap))
875 ram 1.3 (declare (clx-values colormap))
876 ram 1.1 (let* ((display (colormap-display colormap))
877     (new-colormap (make-colormap :display display
878     :visual-info (colormap-visual-info colormap)))
879     (id (allocate-resource-id display new-colormap 'colormap)))
880     (setf (colormap-id new-colormap) id)
881     (with-buffer-request (display *x-copycolormapandfree*)
882     (resource-id id)
883     (colormap colormap))
884     new-colormap))
885    
886     (defun install-colormap (colormap)
887     (declare (type colormap colormap))
888     (with-buffer-request ((colormap-display colormap) *x-installcolormap*)
889     (colormap colormap)))
890    
891     (defun uninstall-colormap (colormap)
892     (declare (type colormap colormap))
893     (with-buffer-request ((colormap-display colormap) *x-uninstallcolormap*)
894     (colormap colormap)))
895    
896     (defun installed-colormaps (window &key (result-type 'list))
897     (declare (type window window)
898     (type t result-type)) ;; CL type
899 ram 1.3 (declare (clx-values (clx-sequence colormap)))
900 ram 1.1 (let ((display (window-display window)))
901     (flet ((get-colormap (id)
902     (lookup-colormap display id)))
903     (with-buffer-request-and-reply (display *x-listinstalledcolormaps* nil :sizes 16)
904     ((window window))
905     (values
906     (sequence-get :result-type result-type :length (card16-get 8)
907     :transform #'get-colormap :index *replysize*))))))
908    
909     (defun alloc-color (colormap color)
910     (declare (type colormap colormap)
911     (type (or stringable color) color))
912 ram 1.3 (declare (clx-values pixel screen-color exact-color))
913 ram 1.1 (let ((display (colormap-display colormap)))
914     (etypecase color
915     (color
916     (with-buffer-request-and-reply (display *x-alloccolor* 20 :sizes (16 32))
917     ((colormap colormap)
918     (rgb-val (color-red color)
919     (color-green color)
920     (color-blue color))
921     (pad16 nil))
922     (values
923     (card32-get 16)
924     (make-color :red (rgb-val-get 8)
925     :green (rgb-val-get 10)
926     :blue (rgb-val-get 12))
927     color)))
928     (stringable
929     (let* ((string (string color))
930     (length (length string)))
931     (with-buffer-request-and-reply (display *x-allocnamedcolor* 24 :sizes (16 32))
932     ((colormap colormap)
933     (card16 length)
934     (pad16 nil)
935     (string string))
936     (values
937     (card32-get 8)
938 ram 1.2 (make-color :red (rgb-val-get 18)
939     :green (rgb-val-get 20)
940     :blue (rgb-val-get 22))
941 ram 1.1 (make-color :red (rgb-val-get 12)
942     :green (rgb-val-get 14)
943 ram 1.2 :blue (rgb-val-get 16)))))))))
944 ram 1.1
945     (defun alloc-color-cells (colormap colors &key (planes 0) contiguous-p (result-type 'list))
946     (declare (type colormap colormap)
947     (type card16 colors planes)
948 dtc 1.4 (type generalized-boolean contiguous-p)
949 ram 1.1 (type t result-type)) ;; CL type
950 ram 1.3 (declare (clx-values (clx-sequence pixel) (clx-sequence mask)))
951 ram 1.1 (let ((display (colormap-display colormap)))
952     (with-buffer-request-and-reply (display *x-alloccolorcells* nil :sizes 16)
953     (((data boolean) contiguous-p)
954     (colormap colormap)
955     (card16 colors planes))
956     (let ((pixel-length (card16-get 8))
957     (mask-length (card16-get 10)))
958     (values
959     (sequence-get :result-type result-type :length pixel-length :index *replysize*)
960     (sequence-get :result-type result-type :length mask-length
961     :index (index+ *replysize* (index* pixel-length 4))))))))
962    
963     (defun alloc-color-planes (colormap colors
964     &key (reds 0) (greens 0) (blues 0)
965     contiguous-p (result-type 'list))
966     (declare (type colormap colormap)
967     (type card16 colors reds greens blues)
968 dtc 1.4 (type generalized-boolean contiguous-p)
969 ram 1.1 (type t result-type)) ;; CL type
970 ram 1.3 (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))
971 ram 1.1 (let ((display (colormap-display colormap)))
972     (with-buffer-request-and-reply (display *x-alloccolorplanes* nil :sizes (16 32))
973     (((data boolean) contiguous-p)
974     (colormap colormap)
975     (card16 colors reds greens blues))
976     (let ((red-mask (card32-get 12))
977     (green-mask (card32-get 16))
978     (blue-mask (card32-get 20)))
979     (values
980     (sequence-get :result-type result-type :length (card16-get 8) :index *replysize*)
981     red-mask green-mask blue-mask)))))
982    
983     (defun free-colors (colormap pixels &optional (plane-mask 0))
984     (declare (type colormap colormap)
985     (type sequence pixels) ;; Sequence of integers
986     (type pixel plane-mask))
987     (with-buffer-request ((colormap-display colormap) *x-freecolors*)
988     (colormap colormap)
989     (card32 plane-mask)
990     (sequence pixels)))
991    
992     (defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
993     (declare (type colormap colormap)
994     (type pixel pixel)
995     (type (or stringable color) spec)
996 dtc 1.4 (type generalized-boolean red-p green-p blue-p))
997 ram 1.1 (let ((display (colormap-display colormap))
998     (flags 0))
999     (declare (type display display)
1000     (type card8 flags))
1001     (when red-p (setq flags 1))
1002     (when green-p (incf flags 2))
1003     (when blue-p (incf flags 4))
1004     (etypecase spec
1005     (color
1006     (with-buffer-request (display *x-storecolors*)
1007     (colormap colormap)
1008     (card32 pixel)
1009     (rgb-val (color-red spec)
1010     (color-green spec)
1011     (color-blue spec))
1012     (card8 flags)
1013     (pad8 nil)))
1014     (stringable
1015     (let* ((string (string spec))
1016     (length (length string)))
1017     (with-buffer-request (display *x-storenamedcolor*)
1018     ((data card8) flags)
1019     (colormap colormap)
1020     (card32 pixel)
1021     (card16 length)
1022     (pad16 nil)
1023     (string string)))))))
1024    
1025     (defun store-colors (colormap specs &key (red-p t) (green-p t) (blue-p t))
1026     ;; If stringables are specified for colors, it is unspecified whether all
1027     ;; stringables are first resolved and then a single StoreColors protocol request is
1028     ;; issued, or whether multiple StoreColors protocol requests are issued.
1029     (declare (type colormap colormap)
1030     (type sequence specs)
1031 dtc 1.4 (type generalized-boolean red-p green-p blue-p))
1032 ram 1.1 (etypecase specs
1033     (list
1034 ram 1.2 (do ((spec specs (cddr spec)))
1035 ram 1.1 ((endp spec))
1036 ram 1.2 (store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p)))
1037 ram 1.1 (vector
1038 ram 1.2 (do ((i 0 (+ i 2))
1039     (len (length specs)))
1040 ram 1.1 ((>= i len))
1041 ram 1.2 (store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p)))))
1042 ram 1.1
1043     (defun query-colors (colormap pixels &key (result-type 'list))
1044     (declare (type colormap colormap)
1045     (type sequence pixels) ;; sequence of integer
1046     (type t result-type)) ;; a type specifier
1047 ram 1.3 (declare (clx-values (clx-sequence color)))
1048 ram 1.1 (let ((display (colormap-display colormap)))
1049     (with-buffer-request-and-reply (display *x-querycolors* nil :sizes (8 16))
1050     ((colormap colormap)
1051     (sequence pixels))
1052     (let ((sequence (make-sequence result-type (card16-get 8))))
1053     (advance-buffer-offset *replysize*)
1054     (dotimes (i (length sequence) sequence)
1055     (setf (elt sequence i)
1056     (make-color :red (rgb-val-get 0)
1057     :green (rgb-val-get 2)
1058     :blue (rgb-val-get 4)))
1059     (advance-buffer-offset 8))))))
1060    
1061     (defun lookup-color (colormap name)
1062     (declare (type colormap colormap)
1063     (type stringable name))
1064 ram 1.3 (declare (clx-values screen-color true-color))
1065 ram 1.1 (let* ((display (colormap-display colormap))
1066     (string (string name))
1067     (length (length string)))
1068     (with-buffer-request-and-reply (display *x-lookupcolor* 20 :sizes 16)
1069     ((colormap colormap)
1070     (card16 length)
1071     (pad16 nil)
1072     (string string))
1073     (values
1074     (make-color :red (rgb-val-get 14)
1075     :green (rgb-val-get 16)
1076     :blue (rgb-val-get 18))
1077     (make-color :red (rgb-val-get 8)
1078     :green (rgb-val-get 10)
1079     :blue (rgb-val-get 12))))))
1080    
1081     (defun create-cursor (&key
1082     (source (required-arg source))
1083     mask
1084     (x (required-arg x))
1085     (y (required-arg y))
1086     (foreground (required-arg foreground))
1087     (background (required-arg background)))
1088     (declare (type pixmap source) ;; required
1089     (type (or null pixmap) mask)
1090     (type card16 x y) ;; required
1091     (type (or null color) foreground background)) ;; required
1092 ram 1.3 (declare (clx-values cursor))
1093 ram 1.1 (let* ((display (pixmap-display source))
1094     (cursor (make-cursor :display display))
1095     (cid (allocate-resource-id display cursor 'cursor)))
1096     (setf (cursor-id cursor) cid)
1097     (with-buffer-request (display *x-createcursor*)
1098     (resource-id cid)
1099     (pixmap source)
1100     ((or null pixmap) mask)
1101     (rgb-val (color-red foreground)
1102     (color-green foreground)
1103     (color-blue foreground))
1104     (rgb-val (color-red background)
1105     (color-green background)
1106     (color-blue background))
1107     (card16 x y))
1108     cursor))
1109    
1110     (defun create-glyph-cursor (&key
1111     (source-font (required-arg source-font))
1112     (source-char (required-arg source-char))
1113     mask-font
1114     mask-char
1115     (foreground (required-arg foreground))
1116     (background (required-arg background)))
1117     (declare (type font source-font) ;; Required
1118     (type card16 source-char) ;; Required
1119     (type (or null font) mask-font)
1120     (type (or null card16) mask-char)
1121     (type color foreground background)) ;; required
1122 ram 1.3 (declare (clx-values cursor))
1123 ram 1.1 (let* ((display (font-display source-font))
1124     (cursor (make-cursor :display display))
1125     (cid (allocate-resource-id display cursor 'cursor))
1126     (source-font-id (font-id source-font))
1127     (mask-font-id (if mask-font (font-id mask-font) 0)))
1128     (setf (cursor-id cursor) cid)
1129     (unless mask-char (setq mask-char 0))
1130     (with-buffer-request (display *x-createglyphcursor*)
1131     (resource-id cid source-font-id mask-font-id)
1132     (card16 source-char)
1133     (card16 mask-char)
1134     (rgb-val (color-red foreground)
1135     (color-green foreground)
1136     (color-blue foreground))
1137     (rgb-val (color-red background)
1138     (color-green background)
1139     (color-blue background)))
1140     cursor))
1141    
1142     (defun free-cursor (cursor)
1143     (declare (type cursor cursor))
1144     (let ((display (cursor-display cursor)))
1145     (with-buffer-request (display *x-freecursor*)
1146     (cursor cursor))
1147     (deallocate-resource-id display (cursor-id cursor) 'cursor)))
1148    
1149     (defun recolor-cursor (cursor foreground background)
1150     (declare (type cursor cursor)
1151     (type color foreground background))
1152     (with-buffer-request ((cursor-display cursor) *x-recolorcursor*)
1153     (cursor cursor)
1154     (rgb-val (color-red foreground)
1155     (color-green foreground)
1156     (color-blue foreground))
1157     (rgb-val (color-red background)
1158     (color-green background)
1159     (color-blue background))
1160     ))
1161    
1162     (defun query-best-cursor (width height drawable)
1163     (declare (type card16 width height)
1164     (type (or drawable display) drawable))
1165 ram 1.3 (declare (clx-values width height))
1166 ram 1.1 ;; Drawable can be a display for compatibility.
1167     (multiple-value-bind (display drawable)
1168     (if (type? drawable 'drawable)
1169     (values (drawable-display drawable) drawable)
1170     (values drawable (screen-root (display-default-screen drawable))))
1171     (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
1172     ((data 0)
1173     (window drawable)
1174     (card16 width height))
1175     (values
1176     (card16-get 8)
1177     (card16-get 10)))))
1178    
1179     (defun query-best-tile (width height drawable)
1180     (declare (type card16 width height)
1181     (type drawable drawable))
1182 ram 1.3 (declare (clx-values width height))
1183 ram 1.1 (let ((display (drawable-display drawable)))
1184     (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
1185     ((data 1)
1186     (drawable drawable)
1187     (card16 width height))
1188     (values
1189     (card16-get 8)
1190     (card16-get 10)))))
1191    
1192     (defun query-best-stipple (width height drawable)
1193     (declare (type card16 width height)
1194     (type drawable drawable))
1195 ram 1.3 (declare (clx-values width height))
1196 ram 1.1 (let ((display (drawable-display drawable)))
1197     (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)
1198     ((data 2)
1199     (drawable drawable)
1200     (card16 width height))
1201     (values
1202     (card16-get 8)
1203     (card16-get 10)))))
1204    
1205     (defun query-extension (display name)
1206     (declare (type display display)
1207     (type stringable name))
1208 ram 1.3 (declare (clx-values major-opcode first-event first-error))
1209 ram 1.1 (let ((string (string name)))
1210     (with-buffer-request-and-reply (display *x-queryextension* 12 :sizes 8)
1211     ((card16 (length string))
1212     (pad16 nil)
1213     (string string))
1214     (and (boolean-get 8) ;; If present
1215     (values
1216     (card8-get 9)
1217     (card8-get 10)
1218     (card8-get 11))))))
1219    
1220     (defun list-extensions (display &key (result-type 'list))
1221     (declare (type display display)
1222     (type t result-type)) ;; CL type
1223 ram 1.3 (declare (clx-values (clx-sequence string)))
1224 ram 1.1 (with-buffer-request-and-reply (display *x-listextensions* size :sizes 8)
1225     ()
1226     (values
1227     (read-sequence-string
1228     buffer-bbuf (index- size *replysize*) (card8-get 1) result-type *replysize*))))
1229    
1230     (defun change-keyboard-control (display &key key-click-percent
1231     bell-percent bell-pitch bell-duration
1232     led led-mode key auto-repeat-mode)
1233     (declare (type display display)
1234     (type (or null (member :default) int16) key-click-percent
1235     bell-percent bell-pitch bell-duration)
1236     (type (or null card8) led key)
1237     (type (or null (member :on :off)) led-mode)
1238     (type (or null (member :on :off :default)) auto-repeat-mode))
1239     (when (eq key-click-percent :default) (setq key-click-percent -1))
1240     (when (eq bell-percent :default) (setq bell-percent -1))
1241     (when (eq bell-pitch :default) (setq bell-pitch -1))
1242     (when (eq bell-duration :default) (setq bell-duration -1))
1243     (with-buffer-request (display *x-changekeyboardcontrol* :sizes (32))
1244     (mask
1245     (integer key-click-percent bell-percent bell-pitch bell-duration)
1246     (card32 led)
1247     ((member :off :on) led-mode)
1248     (card32 key)
1249     ((member :off :on :default) auto-repeat-mode))))
1250    
1251     (defun keyboard-control (display)
1252     (declare (type display display))
1253 ram 1.3 (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration
1254 ram 1.1 led-mask global-auto-repeat auto-repeats))
1255     (with-buffer-request-and-reply (display *x-getkeyboardcontrol* 32 :sizes (8 16 32))
1256     ()
1257     (values
1258     (card8-get 12)
1259     (card8-get 13)
1260     (card16-get 14)
1261     (card16-get 16)
1262     (card32-get 8)
1263     (member8-get 1 :off :on)
1264     (bit-vector256-get 32))))
1265    
1266     ;; The base volume should
1267     ;; be considered to be the "desired" volume in the normal case; that is, a
1268     ;; typical application should call XBell with 0 as the percent. Rather
1269     ;; than using a simple sum, the percent argument is instead used as the
1270     ;; percentage of the remaining range to alter the base volume by. That is,
1271     ;; the actual volume is:
1272     ;; if percent>=0: base - [(base * percent) / 100] + percent
1273     ;; if percent<0: base + [(base * percent) / 100]
1274    
1275     (defun bell (display &optional (percent-from-normal 0))
1276     ;; It is assumed that an eventual audio extension to X will provide more complete control.
1277     (declare (type display display)
1278     (type int8 percent-from-normal))
1279     (with-buffer-request (display *x-bell*)
1280     (data (int8->card8 percent-from-normal))))
1281    
1282     (defun pointer-mapping (display &key (result-type 'list))
1283     (declare (type display display)
1284     (type t result-type)) ;; CL type
1285 ram 1.3 (declare (clx-values sequence)) ;; Sequence of card
1286 ram 1.1 (with-buffer-request-and-reply (display *x-getpointermapping* nil :sizes 8)
1287     ()
1288     (values
1289     (sequence-get :length (card8-get 1) :result-type result-type :format card8
1290     :index *replysize*))))
1291    
1292     (defun set-pointer-mapping (display map)
1293     ;; Can signal device-busy.
1294     (declare (type display display)
1295     (type sequence map)) ;; Sequence of card8
1296     (when (with-buffer-request-and-reply (display *x-setpointermapping* 2 :sizes 8)
1297     ((data (length map))
1298     ((sequence :format card8) map))
1299     (values
1300     (boolean-get 1)))
1301     (x-error 'device-busy :display display))
1302     map)
1303    
1304     (defsetf pointer-mapping set-pointer-mapping)
1305    
1306     (defun change-pointer-control (display &key acceleration threshold)
1307     ;; Acceleration is rationalized if necessary.
1308     (declare (type display display)
1309     (type (or null (member :default) number) acceleration)
1310 ram 1.3 (type (or null (member :default) integer) threshold))
1311 ram 1.1 (flet ((rationalize16 (number)
1312     ;; Rationalize NUMBER into the ratio of two signed 16 bit numbers
1313 ram 1.3 (declare (type number number))
1314     (declare (clx-values numerator denominator))
1315 ram 1.1 (do* ((rational (rationalize number))
1316     (numerator (numerator rational) (ash numerator -1))
1317     (denominator (denominator rational) (ash denominator -1)))
1318     ((or (= numerator 1)
1319     (and (< (abs numerator) #x8000)
1320     (< denominator #x8000)))
1321     (values
1322     numerator (min denominator #x7fff))))))
1323 ram 1.3 (declare (inline rationalize16))
1324 ram 1.1 (let ((acceleration-p 1)
1325     (threshold-p 1)
1326     (numerator 0)
1327     (denominator 1))
1328     (declare (type card8 acceleration-p threshold-p)
1329     (type int16 numerator denominator))
1330     (cond ((eq acceleration :default) (setq numerator -1))
1331     (acceleration (multiple-value-setq (numerator denominator)
1332     (rationalize16 acceleration)))
1333     (t (setq acceleration-p 0)))
1334     (cond ((eq threshold :default) (setq threshold -1))
1335     ((null threshold) (setq threshold -1
1336     threshold-p 0)))
1337     (with-buffer-request (display *x-changepointercontrol*)
1338     (int16 numerator denominator threshold)
1339     (card8 acceleration-p threshold-p)))))
1340    
1341     (defun pointer-control (display)
1342     (declare (type display display))
1343 ram 1.3 (declare (clx-values acceleration threshold))
1344 ram 1.1 (with-buffer-request-and-reply (display *x-getpointercontrol* 16 :sizes 16)
1345     ()
1346     (values
1347 ram 1.3 (/ (card16-get 8) (card16-get 10)) ; Should we float this?
1348     (card16-get 12))))
1349 ram 1.1
1350     (defun set-screen-saver (display timeout interval blanking exposures)
1351     ;; Timeout and interval are in seconds, will be rounded to minutes.
1352     (declare (type display display)
1353     (type (or (member :default) int16) timeout interval)
1354     (type (member :on :off :default :yes :no) blanking exposures))
1355     (case blanking (:yes (setq blanking :on)) (:no (setq blanking :off)))
1356     (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off)))
1357     (when (eq timeout :default) (setq timeout -1))
1358     (when (eq interval :default) (setq interval -1))
1359     (with-buffer-request (display *x-setscreensaver*)
1360     (int16 timeout interval)
1361     ((member8 :on :off :default) blanking exposures)))
1362    
1363     (defun screen-saver (display)
1364     ;; Returns timeout and interval in seconds.
1365     (declare (type display display))
1366 ram 1.3 (declare (clx-values timeout interval blanking exposures))
1367 ram 1.1 (with-buffer-request-and-reply (display *x-getscreensaver* 14 :sizes (8 16))
1368     ()
1369     (values
1370     (card16-get 8)
1371     (card16-get 10)
1372     (member8-get 12 :on :off :default)
1373     (member8-get 13 :on :off :default))))
1374    
1375     (defun activate-screen-saver (display)
1376     (declare (type display display))
1377     (with-buffer-request (display *x-forcescreensaver*)
1378     (data 1)))
1379    
1380     (defun reset-screen-saver (display)
1381     (declare (type display display))
1382     (with-buffer-request (display *x-forcescreensaver*)
1383     (data 0)))
1384    
1385     (defun add-access-host (display host &optional (family :internet))
1386     ;; A string must be acceptable as a host, but otherwise the possible types for
1387     ;; host are not constrained, and will likely be very system dependent.
1388     ;; This implementation uses a list whose car is the family keyword
1389     ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
1390     (declare (type display display)
1391     (type (or stringable list) host)
1392     (type (or null (member :internet :decnet :chaos) card8) family))
1393     (change-access-host display host family nil))
1394    
1395     (defun remove-access-host (display host &optional (family :internet))
1396     ;; A string must be acceptable as a host, but otherwise the possible types for
1397     ;; host are not constrained, and will likely be very system dependent.
1398     ;; This implementation uses a list whose car is the family keyword
1399     ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
1400     (declare (type display display)
1401     (type (or stringable list) host)
1402     (type (or null (member :internet :decnet :chaos) card8) family))
1403     (change-access-host display host family t))
1404    
1405     (defun change-access-host (display host family remove-p)
1406     (declare (type display display)
1407     (type (or stringable list) host)
1408     (type (or null (member :internet :decnet :chaos) card8) family))
1409     (unless (consp host)
1410     (setq host (host-address host family)))
1411     (let ((family (car host))
1412     (address (cdr host)))
1413     (with-buffer-request (display *x-changehosts*)
1414     ((data boolean) remove-p)
1415     (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))
1416     (card16 (length address))
1417     ((sequence :format card8) address))))
1418    
1419     (defun access-hosts (display &optional (result-type 'list))
1420     ;; The type of host objects returned is not constrained, except that the hosts must
1421     ;; be acceptable to add-access-host and remove-access-host.
1422     ;; This implementation uses a list whose car is the family keyword
1423     ;; (:internet :DECnet :Chaos) and cdr is a list of network address bytes.
1424     (declare (type display display)
1425     (type t result-type)) ;; CL type
1426 ram 1.3 (declare (clx-values (clx-sequence host) enabled-p))
1427 ram 1.1 (with-buffer-request-and-reply (display *x-listhosts* nil :sizes (8 16))
1428     ()
1429     (let* ((enabled-p (boolean-get 1))
1430     (nhosts (card16-get 8))
1431     (sequence (make-sequence result-type nhosts)))
1432     (advance-buffer-offset *replysize*)
1433     (dotimes (i nhosts)
1434     (let ((family (card8-get 0))
1435     (len (card16-get 2)))
1436     (setf (elt sequence i)
1437     (cons (if (< family 3)
1438     (svref '#(:internet :decnet :chaos) family)
1439     family)
1440     (sequence-get :length len :format card8 :result-type 'list
1441     :index (+ buffer-boffset 4))))
1442     (advance-buffer-offset (+ 4 (* 4 (ceiling len 4))))))
1443     (values
1444     sequence
1445     enabled-p))))
1446    
1447     (defun access-control (display)
1448     (declare (type display display))
1449 dtc 1.4 (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED
1450 ram 1.1 (with-buffer-request-and-reply (display *x-listhosts* 2 :sizes 8)
1451     ()
1452     (boolean-get 1)))
1453    
1454     (defun set-access-control (display enabled-p)
1455     (declare (type display display)
1456 dtc 1.4 (type generalized-boolean enabled-p))
1457 ram 1.1 (with-buffer-request (display *x-changeaccesscontrol*)
1458     ((data boolean) enabled-p))
1459     enabled-p)
1460    
1461     (defsetf access-control set-access-control)
1462    
1463     (defun close-down-mode (display)
1464     ;; setf'able
1465     ;; Cached locally in display object.
1466     (declare (type display display))
1467 ram 1.3 (declare (clx-values (member :destroy :retain-permanent :retain-temporary nil)))
1468 ram 1.1 (display-close-down-mode display))
1469    
1470     (defun set-close-down-mode (display mode)
1471     ;; Cached locally in display object.
1472     (declare (type display display)
1473     (type (member :destroy :retain-permanent :retain-temporary) mode))
1474     (setf (display-close-down-mode display) mode)
1475     (with-buffer-request (display *x-changeclosedownmode* :sizes (32))
1476     ((data (member :destroy :retain-permanent :retain-temporary)) mode))
1477     mode)
1478    
1479     (defsetf close-down-mode set-close-down-mode)
1480    
1481     (defun kill-client (display resource-id)
1482     (declare (type display display)
1483     (type resource-id resource-id))
1484     (with-buffer-request (display *x-killclient*)
1485     (resource-id resource-id)))
1486    
1487     (defun kill-temporary-clients (display)
1488     (declare (type display display))
1489     (with-buffer-request (display *x-killclient*)
1490     (resource-id 0)))
1491    
1492     (defun no-operation (display)
1493     (declare (type display display))
1494     (with-buffer-request (display *x-nooperation*)))

  ViewVC Help
Powered by ViewVC 1.1.5