1
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
4
;;; TEXAS INSTRUMENTS INCORPORATED
6
;;; AUSTIN, TEXAS 78769
8
;;; Copyright (C) 1987 Texas Instruments Incorporated.
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
15
;;; Texas Instruments Incorporated provides this software "as is" without
16
;;; express or implied warranty.
21
(defun create-window (&key
23
(parent (required-arg parent))
26
(width (required-arg width))
27
(height (required-arg height))
28
(depth 0) (border-width 0)
29
(class :copy) (visual :copy)
32
backing-store backing-planes backing-pixel save-under
33
event-mask do-not-propagate-mask override-redirect
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)
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)
70
(:none (setq back-pixmap 0))
71
(:parent-relative (setq back-pixmap 1))
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))))))
81
(:copy (setq border-pixmap 0))
83
(if (type? border 'pixmap)
84
(setq border-pixmap (pixmap-id border))
86
(setq border-pixel border)
87
(x-type-error border '(or null (member :copy) integer pixmap))))))
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)))
94
(with-buffer-request (display +x-createwindow+)
99
(card16 width height border-width)
100
((member16 :copy :input-output :input-only) class)
101
(resource-id (cond ((eq visual :copy)
103
((typep visual 'resource-id)
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)))
118
(defun destroy-window (window)
119
(declare (type window window))
120
(with-buffer-request ((window-display window) +x-destroywindow+)
123
(defun destroy-subwindows (window)
124
(declare (type window window))
125
(with-buffer-request ((window-display window) +x-destroysubwindows+)
128
(defun add-to-save-set (window)
129
(declare (type window window))
130
(with-buffer-request ((window-display window) +x-changesaveset+)
134
(defun remove-from-save-set (window)
135
(declare (type window window))
136
(with-buffer-request ((window-display window) +x-changesaveset+)
140
(defun reparent-window (window parent x y)
141
(declare (type window window parent)
143
(with-buffer-request ((window-display window) +x-reparentwindow+)
144
(window window parent)
147
(defun map-window (window)
148
(declare (type window window))
149
(with-buffer-request ((window-display window) +x-mapwindow+)
152
(defun map-subwindows (window)
153
(declare (type window window))
154
(with-buffer-request ((window-display window) +x-mapsubwindows+)
157
(defun unmap-window (window)
158
(declare (type window window))
159
(with-buffer-request ((window-display window) +x-unmapwindow+)
162
(defun unmap-subwindows (window)
163
(declare (type window window))
164
(with-buffer-request ((window-display window) +x-unmapsubwindows+)
167
(defun circulate-window-up (window)
168
(declare (type window window))
169
(with-buffer-request ((window-display window) +x-circulatewindow+)
173
(defun circulate-window-down (window)
174
(declare (type window window))
175
(with-buffer-request ((window-display window) +x-circulatewindow+)
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))
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))))
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.
201
(defun intern-atom (display name)
202
(declare (type display display)
204
(declare (clx-values resource-id))
205
(let ((name (if (or (null name) (keywordp 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)
215
(card16 (length string))
219
(resource-id-get 8)))
220
(declare (type resource-id id))
221
(setf (atom-id name display) id)
224
(defun find-atom (display name)
225
;; Same as INTERN-ATOM, but with the ONLY-IF-EXISTS flag True
226
(declare (type display display)
228
(declare (clx-values (or null resource-id)))
229
(let ((name (if (or (null name) (keywordp 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)
239
(card16 (length string))
243
(or-get 8 null resource-id)))
244
(declare (type (or null resource-id) id))
246
(setf (atom-id name display) id))
249
(defun atom-name (display atom-id)
250
(declare (type display display)
251
(type resource-id atom-id))
252
(declare (clx-values keyword))
255
(or (id-atom atom-id display)
258
(with-buffer-request-and-reply
259
(display +x-getatomname+ nil :sizes (16))
260
((resource-id atom-id))
262
(string-get (card16-get 8) +replysize+))))))
263
(declare (type keyword keyword))
264
(setf (atom-id keyword display) atom-id)
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))
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)
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)
296
(resource-id property-id type-id)
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)))))))
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+)
317
(resource-id property-id))))
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)
341
(resource-id property-id)
342
((or null resource-id) type-id)
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)))
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
359
(16 (sequence-get :result-type result-type :format card16
360
:length nitems :transform transform
362
(32 (sequence-get :result-type result-type :format card32
363
:length nitems :transform transform
364
:index +replysize+)))))))
366
(and (plusp reply-type) (atom-name display reply-type))
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
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.
384
(setf (aref sequence i) (intern-atom display (elt properties i))))
385
(with-buffer-request (display +x-rotateproperties+)
389
((sequence :end length) sequence))))
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)
401
(sequence-get :result-type result-type :length (card16-get 8)
402
:index +replysize+)))
403
;; lookup the atoms in the sequence
405
(do ((elt seq (cdr elt)))
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))))))))
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))
421
(resource-id-or-nil-get 8)))
422
(and window (lookup-window display window)))))
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))
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))
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+)
455
(resource-id selection-id type-id)
456
((or null resource-id) property-id)
457
((or null card32) time))))
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))
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)
493
(apply (svref *event-send-vector* internal-event-code) display args)
494
(setf (buffer-boffset display) (index+ buffer-boffset 44))))))
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)
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))
515
(member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
517
(defun ungrab-pointer (display &key time)
518
(declare (type timestamp time))
519
(with-buffer-request (display +x-ungrabpointer+)
520
((or null card32) time)))
522
(defun grab-button (window button event-mask
523
&key (modifiers :any)
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)
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))
541
(card16 (encode-modifier-mask modifiers))))
543
(defun ungrab-button (window button &key (modifiers :any))
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))
550
(card16 (encode-modifier-mask modifiers))))
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))))
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)
571
((or null card32) time)
572
(boolean (not sync-pointer-p) (not sync-keyboard-p)))
574
(member8-get 1 :success :already-grabbed :invalid-time :not-viewable :frozen)))))
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)))
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)
590
(card16 (encode-modifier-mask modifiers))
591
(card8 (if (eq key :any) 0 key))
592
(boolean (not sync-pointer-p) (not sync-keyboard-p))))
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))
601
(card16 (encode-modifier-mask modifiers))))
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)
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))
615
((or null card32) time)))
617
(defun grab-server (display)
618
(declare (type display display))
619
(with-buffer-request (display +x-grabserver+)))
621
(defun ungrab-server (display)
622
(with-buffer-request (display +x-ungrabserver+)))
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))
633
(ungrab-server ,disp)))))
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))
645
(or-get 12 null window)
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))
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)))))
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)
680
((or null card32) start stop))
682
(sequence-get :result-type result-type :length (index* (card32-get 8) 3)
683
:index +replysize+)))))
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)
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))
699
(or-get 8 null window))))))
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
709
(int16 dst-x dst-y)))
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
719
(int16 x-off y-off)))
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+)
732
(card16 (or src-width 0) (or src-height 0))
733
(int16 dst-x dst-y))))
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+)
745
(resource-id 0) ;; None
747
(card16 (or src-width 0) (or src-height 0))
748
(int16 x-off y-off))))
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)))
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))
766
(or-get 8 window (member :none :pointer-root))
767
(member8-get 1 :none :pointer-root :parent))))
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)
776
(bit-vector256-get 8 8 bit-vector))))
778
(defun create-pixmap (&key
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+)
797
(card16 width height))
800
(defun free-pixmap (pixmap)
801
(declare (type pixmap pixmap))
802
(let ((display (pixmap-display pixmap)))
803
(with-buffer-request (display +x-freepixmap+)
805
(deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
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)
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)
819
(card16 (or width 0) (or height 0)))))
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)
829
(int16 src-x src-y dst-x dst-y)
830
(card16 width height)))
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)
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)
841
(int16 src-x src-y dst-x dst-y)
842
(card16 width height)
845
(defun create-colormap (visual-info window &optional alloc-p)
846
(declare (type (or visual-info resource-id) visual-info)
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)
860
(card29 (visual-info-id visual-info)))
863
(defun free-colormap (colormap)
864
(declare (type colormap colormap))
865
(let ((display (colormap-display colormap)))
866
(with-buffer-request (display +x-freecolormap+)
868
(deallocate-resource-id display (colormap-id colormap) 'colormap)))
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+)
883
(defun install-colormap (colormap)
884
(declare (type colormap colormap))
885
(with-buffer-request ((colormap-display colormap) +x-installcolormap+)
886
(colormap colormap)))
888
(defun uninstall-colormap (colormap)
889
(declare (type colormap colormap))
890
(with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+)
891
(colormap colormap)))
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)
903
(sequence-get :result-type result-type :length (card16-get 8)
904
:transform #'get-colormap :index +replysize+))))))
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)))
913
(with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32))
915
(rgb-val (color-red color)
921
(make-color :red (rgb-val-get 8)
922
:green (rgb-val-get 10)
923
:blue (rgb-val-get 12))
926
(let* ((string (string color))
927
(length (length string)))
928
(with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32))
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)))))))))
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)
952
(card16 colors planes))
953
(let ((pixel-length (card16-get 8))
954
(mask-length (card16-get 10)))
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))))))))
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)
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)))
977
(sequence-get :result-type result-type :length (card16-get 8) :index +replysize+)
978
red-mask green-mask blue-mask)))))
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+)
989
(defun store-color (colormap pixel spec &key (red-p t) (green-p t) (blue-p t))
990
(declare (type colormap colormap)
992
(type (or stringable color) spec)
993
(type generalized-boolean red-p green-p blue-p))
994
(let ((display (colormap-display colormap))
996
(declare (type display display)
998
(when red-p (setq flags 1))
999
(when green-p (incf flags 2))
1000
(when blue-p (incf flags 4))
1003
(with-buffer-request (display +x-storecolors+)
1006
(rgb-val (color-red spec)
1012
(let* ((string (string spec))
1013
(length (length string)))
1014
(with-buffer-request (display +x-storenamedcolor+)
1015
((data card8) flags)
1020
(string string)))))))
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))
1031
(do ((spec specs (cddr spec)))
1033
(store-color colormap (car spec) (cadr spec) :red-p red-p :green-p green-p :blue-p blue-p)))
1036
(len (length specs)))
1038
(store-color colormap (aref specs i) (aref specs (1+ i)) :red-p red-p :green-p green-p :blue-p blue-p)))))
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)
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))))))
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)
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))))))
1078
(defun create-cursor (&key
1079
(source (required-arg source))
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+)
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))
1107
(defun create-glyph-cursor (&key
1108
(source-font (required-arg source-font))
1109
(source-char (required-arg source-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)
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)))
1139
(defun free-cursor (cursor)
1140
(declare (type cursor cursor))
1141
(let ((display (cursor-display cursor)))
1142
(with-buffer-request (display +x-freecursor+)
1144
(deallocate-resource-id display (cursor-id cursor) 'cursor)))
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+)
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))
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)
1171
(card16 width height))
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)
1184
(card16 width height))
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)
1197
(card16 width height))
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))
1211
(and (boolean-get 8) ;; If present
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)
1224
(read-sequence-string
1225
buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+))))
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))
1242
(integer key-click-percent bell-percent bell-pitch bell-duration)
1244
((member :off :on) led-mode)
1246
((member :off :on :default) auto-repeat-mode))))
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))
1260
(member8-get 1 :off :on)
1261
(bit-vector256-get 32))))
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]
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))))
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)
1286
(sequence-get :length (card8-get 1) :result-type result-type :format card8
1287
:index +replysize+))))
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))
1298
(x-error 'device-busy :display display))
1301
(defsetf pointer-mapping set-pointer-mapping)
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)))
1319
numerator (min denominator #x7fff))))))
1320
(declare (inline rationalize16))
1321
(let ((acceleration-p 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
1334
(with-buffer-request (display +x-changepointercontrol+)
1335
(int16 numerator denominator threshold)
1336
(card8 acceleration-p threshold-p)))))
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)
1344
(/ (card16-get 8) (card16-get 10)) ; Should we float this?
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)))
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))
1369
(member8-get 12 :on :off :default)
1370
(member8-get 13 :on :off :default))))
1372
(defun activate-screen-saver (display)
1373
(declare (type display display))
1374
(with-buffer-request (display +x-forcescreensaver+)
1377
(defun reset-screen-saver (display)
1378
(declare (type display display))
1379
(with-buffer-request (display +x-forcescreensaver+)
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))
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))
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))))
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))
1426
(let* ((enabled-p (boolean-get 1))
1427
(nhosts (card16-get 8))
1428
(sequence (make-sequence result-type nhosts)))
1429
(advance-buffer-offset +replysize+)
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)
1437
(sequence-get :length len :format card8 :result-type 'list
1438
:index (+ buffer-boffset 4))))
1439
(advance-buffer-offset (+ 4 (* 4 (ceiling len 4))))))
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)
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))
1458
(defsetf access-control set-access-control)
1460
(defun close-down-mode (display)
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))
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))
1476
(defsetf close-down-mode set-close-down-mode)
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)))
1484
(defun kill-temporary-clients (display)
1485
(declare (type display display))
1486
(with-buffer-request (display +x-killclient+)
1489
(defun no-operation (display)
1490
(declare (type display display))
1491
(with-buffer-request (display +x-nooperation+)))
added
removed
src/clx/requests.lisp
