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

Contents of /src/clx/requests.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5