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

Diff of /src/clx/requests.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by emarsden, Mon Feb 3 14:19:58 2003 UTC revision 1.8 by fgilham, Tue Aug 21 15:49:28 2007 UTC
# Line 15  Line 15 
15  ;;; Texas Instruments Incorporated provides this software "as is" without  ;;; Texas Instruments Incorporated provides this software "as is" without
16  ;;; express or implied warranty.  ;;; express or implied warranty.
17  ;;;  ;;;
18    
19  #+cmu  #+cmu
20  (ext:file-comment  (ext:file-comment "$Id$")
   "$Header$")  
21    
22  (in-package :xlib)  (in-package :xlib)
23    
# Line 94  Line 94 
94        (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))        (setq do-not-propagate-mask (encode-device-event-mask do-not-propagate-mask)))
95    
96                                                  ;Make the request                                                  ;Make the request
97      (with-buffer-request (display *x-createwindow*)      (with-buffer-request (display +x-createwindow+)
98        (data depth)        (data depth)
99        (resource-id wid)        (resource-id wid)
100        (window parent)        (window parent)
# Line 108  Line 108 
108                           (t                           (t
109                            (visual-info-id visual))))                            (visual-info-id visual))))
110        (mask (card32 back-pixmap back-pixel border-pixmap border-pixel)        (mask (card32 back-pixmap back-pixel border-pixmap border-pixel)
111              ((member-vector *bit-gravity-vector*) bit-gravity)              ((member-vector +bit-gravity-vector+) bit-gravity)
112              ((member-vector *win-gravity-vector*) gravity)              ((member-vector +win-gravity-vector+) gravity)
113              ((member :not-useful :when-mapped :always) backing-store)              ((member :not-useful :when-mapped :always) backing-store)
114              (card32  backing-planes backing-pixel)              (card32  backing-planes backing-pixel)
115              ((member :off :on) override-redirect save-under)              ((member :off :on) override-redirect save-under)
# Line 120  Line 120 
120    
121  (defun destroy-window (window)  (defun destroy-window (window)
122    (declare (type window window))    (declare (type window window))
123    (with-buffer-request ((window-display window) *x-destroywindow*)    (with-buffer-request ((window-display window) +x-destroywindow+)
124      (window window)))      (window window)))
125    
126  (defun destroy-subwindows (window)  (defun destroy-subwindows (window)
127    (declare (type window window))    (declare (type window window))
128    (with-buffer-request ((window-display window) *x-destroysubwindows*)    (with-buffer-request ((window-display window) +x-destroysubwindows+)
129      (window window)))      (window window)))
130    
131  (defun add-to-save-set (window)  (defun add-to-save-set (window)
132    (declare (type window window))    (declare (type window window))
133    (with-buffer-request ((window-display window) *x-changesaveset*)    (with-buffer-request ((window-display window) +x-changesaveset+)
134      (data 0)      (data 0)
135      (window window)))      (window window)))
136    
137  (defun remove-from-save-set (window)  (defun remove-from-save-set (window)
138    (declare (type window window))    (declare (type window window))
139    (with-buffer-request ((window-display window) *x-changesaveset*)    (with-buffer-request ((window-display window) +x-changesaveset+)
140      (data 1)      (data 1)
141      (window window)))      (window window)))
142    
143  (defun reparent-window (window parent x y)  (defun reparent-window (window parent x y)
144    (declare (type window window parent)    (declare (type window window parent)
145             (type int16 x y))             (type int16 x y))
146    (with-buffer-request ((window-display window) *x-reparentwindow*)    (with-buffer-request ((window-display window) +x-reparentwindow+)
147      (window window parent)      (window window parent)
148      (int16 x y)))      (int16 x y)))
149    
150  (defun map-window (window)  (defun map-window (window)
151    (declare (type window window))    (declare (type window window))
152    (with-buffer-request ((window-display window) *x-mapwindow*)    (with-buffer-request ((window-display window) +x-mapwindow+)
153      (window window)))      (window window)))
154    
155  (defun map-subwindows (window)  (defun map-subwindows (window)
156    (declare (type window window))    (declare (type window window))
157    (with-buffer-request ((window-display window) *x-mapsubwindows*)    (with-buffer-request ((window-display window) +x-mapsubwindows+)
158      (window window)))      (window window)))
159    
160  (defun unmap-window (window)  (defun unmap-window (window)
161    (declare (type window window))    (declare (type window window))
162    (with-buffer-request ((window-display window) *x-unmapwindow*)    (with-buffer-request ((window-display window) +x-unmapwindow+)
163      (window window)))      (window window)))
164    
165  (defun unmap-subwindows (window)  (defun unmap-subwindows (window)
166    (declare (type window window))    (declare (type window window))
167    (with-buffer-request ((window-display window) *x-unmapsubwindows*)    (with-buffer-request ((window-display window) +x-unmapsubwindows+)
168      (window window)))      (window window)))
169    
170  (defun circulate-window-up (window)  (defun circulate-window-up (window)
171    (declare (type window window))    (declare (type window window))
172    (with-buffer-request ((window-display window) *x-circulatewindow*)    (with-buffer-request ((window-display window) +x-circulatewindow+)
173      (data 0)      (data 0)
174      (window window)))      (window window)))
175    
176  (defun circulate-window-down (window)  (defun circulate-window-down (window)
177    (declare (type window window))    (declare (type window window))
178    (with-buffer-request ((window-display window) *x-circulatewindow*)    (with-buffer-request ((window-display window) +x-circulatewindow+)
179      (data 1)      (data 1)
180      (window window)))      (window window)))
181    
# Line 185  Line 185 
185    (declare (clx-values (clx-sequence window) parent root))    (declare (clx-values (clx-sequence window) parent root))
186    (let ((display (window-display window)))    (let ((display (window-display window)))
187      (multiple-value-bind (root parent sequence)      (multiple-value-bind (root parent sequence)
188          (with-buffer-request-and-reply (display *x-querytree* nil :sizes (8 16 32))          (with-buffer-request-and-reply (display +x-querytree+ nil :sizes (8 16 32))
189               ((window window))               ((window window))
190            (values            (values
191              (window-get 8)              (window-get 8)
192              (resource-id-get 12)              (resource-id-get 12)
193              (sequence-get :length (card16-get 16) :result-type result-type              (sequence-get :length (card16-get 16) :result-type result-type
194                            :index *replysize*)))                            :index +replysize+)))
195        ;; Parent is NIL for root window        ;; Parent is NIL for root window
196        (setq parent (and (plusp parent) (lookup-window display parent)))        (setq parent (and (plusp parent) (lookup-window display parent)))
197        (dotimes (i (length sequence))            ; Convert ID's to window's        (dotimes (i (length sequence))            ; Convert ID's to window's
# Line 213  Line 213 
213          (let ((string (symbol-name name)))          (let ((string (symbol-name name)))
214            (declare (type string string))            (declare (type string string))
215            (multiple-value-bind (id)            (multiple-value-bind (id)
216                (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)                (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32)
217                     ((data 0)                     ((data 0)
218                      (card16 (length string))                      (card16 (length string))
219                      (pad16 nil)                      (pad16 nil)
# Line 237  Line 237 
237          (let ((string (symbol-name name)))          (let ((string (symbol-name name)))
238            (declare (type string string))            (declare (type string string))
239            (multiple-value-bind (id)            (multiple-value-bind (id)
240                (with-buffer-request-and-reply (display *x-internatom* 12 :sizes 32)                (with-buffer-request-and-reply (display +x-internatom+ 12 :sizes 32)
241                     ((data 1)                     ((data 1)
242                      (card16 (length string))                      (card16 (length string))
243                      (pad16 nil)                      (pad16 nil)
# Line 259  Line 259 
259        (let ((keyword        (let ((keyword
260                (kintern                (kintern
261                    (with-buffer-request-and-reply                    (with-buffer-request-and-reply
262                         (display *x-getatomname* nil :sizes (16))                         (display +x-getatomname+ nil :sizes (16))
263                       ((resource-id atom-id))                       ((resource-id atom-id))
264                    (values                    (values
265                      (string-get (card16-get 8) *replysize*))))))                      (string-get (card16-get 8) +replysize+))))))
266          (declare (type keyword keyword))          (declare (type keyword keyword))
267          (setf (atom-id keyword display) atom-id)          (setf (atom-id keyword display) atom-id)
268            keyword))))            keyword))))
# Line 293  Line 293 
293      (declare (type display display)      (declare (type display display)
294               (type array-index length)               (type array-index length)
295               (type resource-id property-id type-id))               (type resource-id property-id type-id))
296      (with-buffer-request (display *x-changeproperty*)      (with-buffer-request (display +x-changeproperty+)
297        ((data (member :replace :prepend :append)) mode)        ((data (member :replace :prepend :append)) mode)
298        (window window)        (window window)
299        (resource-id property-id type-id)        (resource-id property-id type-id)
# Line 315  Line 315 
315           (property-id (intern-atom display property)))           (property-id (intern-atom display property)))
316      (declare (type display display)      (declare (type display display)
317               (type resource-id property-id))               (type resource-id property-id))
318      (with-buffer-request (display *x-deleteproperty*)      (with-buffer-request (display +x-deleteproperty+)
319        (window window)        (window window)
320        (resource-id property-id))))        (resource-id property-id))))
321    
# Line 338  Line 338 
338               (type resource-id property-id)               (type resource-id property-id)
339               (type (or null resource-id) type-id))               (type (or null resource-id) type-id))
340      (multiple-value-bind (reply-format reply-type bytes-after data)      (multiple-value-bind (reply-format reply-type bytes-after data)
341          (with-buffer-request-and-reply (display *x-getproperty* nil :sizes (8 32))          (with-buffer-request-and-reply (display +x-getproperty+ nil :sizes (8 32))
342               (((data boolean) delete-p)               (((data boolean) delete-p)
343                (window window)                (window window)
344                (resource-id property-id)                (resource-id property-id)
# Line 358  Line 358 
358                       (0  nil) ;; (make-sequence result-type 0) ;; Property not found.                       (0  nil) ;; (make-sequence result-type 0) ;; Property not found.
359                       (8  (sequence-get :result-type result-type :format card8                       (8  (sequence-get :result-type result-type :format card8
360                                         :length nitems :transform transform                                         :length nitems :transform transform
361                                         :index *replysize*))                                         :index +replysize+))
362                       (16 (sequence-get :result-type result-type :format card16                       (16 (sequence-get :result-type result-type :format card16
363                                         :length nitems :transform transform                                         :length nitems :transform transform
364                                         :index *replysize*))                                         :index +replysize+))
365                       (32 (sequence-get :result-type result-type :format card32                       (32 (sequence-get :result-type result-type :format card32
366                                         :length nitems :transform transform                                         :length nitems :transform transform
367                                         :index *replysize*)))))))                                         :index +replysize+)))))))
368        (values data        (values data
369                (and (plusp reply-type) (atom-name display reply-type))                (and (plusp reply-type) (atom-name display reply-type))
370                reply-format                reply-format
# Line 385  Line 385 
385        ;; is started to allow InternAtom requests to be made.        ;; is started to allow InternAtom requests to be made.
386        (dotimes (i length)        (dotimes (i length)
387          (setf (aref sequence i) (intern-atom display (elt properties i))))          (setf (aref sequence i) (intern-atom display (elt properties i))))
388        (with-buffer-request (display *x-rotateproperties*)        (with-buffer-request (display +x-rotateproperties+)
389          (window window)          (window window)
390          (card16 length)          (card16 length)
391          (int16 (- delta))          (int16 (- delta))
# Line 398  Line 398 
398    (declare (clx-values (clx-sequence keyword)))    (declare (clx-values (clx-sequence keyword)))
399    (let ((display (window-display window)))    (let ((display (window-display window)))
400      (multiple-value-bind (seq)      (multiple-value-bind (seq)
401          (with-buffer-request-and-reply (display *x-listproperties* nil :sizes 16)          (with-buffer-request-and-reply (display +x-listproperties+ nil :sizes 16)
402               ((window window))               ((window window))
403            (values            (values
404              (sequence-get :result-type result-type :length (card16-get 8)              (sequence-get :result-type result-type :length (card16-get 8)
405                            :index *replysize*)))                            :index +replysize+)))
406        ;; lookup the atoms in the sequence        ;; lookup the atoms in the sequence
407        (if (listp seq)        (if (listp seq)
408            (do ((elt seq (cdr elt)))            (do ((elt seq (cdr elt)))
# Line 418  Line 418 
418    (let ((selection-id (intern-atom display selection)))    (let ((selection-id (intern-atom display selection)))
419      (declare (type resource-id selection-id))      (declare (type resource-id selection-id))
420      (multiple-value-bind (window)      (multiple-value-bind (window)
421          (with-buffer-request-and-reply (display *x-getselectionowner* 12 :sizes 32)          (with-buffer-request-and-reply (display +x-getselectionowner+ 12 :sizes 32)
422               ((resource-id selection-id))               ((resource-id selection-id))
423            (values            (values
424              (resource-id-or-nil-get 8)))              (resource-id-or-nil-get 8)))
# Line 431  Line 431 
431             (type timestamp time))             (type timestamp time))
432    (let ((selection-id (intern-atom display selection)))    (let ((selection-id (intern-atom display selection)))
433      (declare (type resource-id selection-id))      (declare (type resource-id selection-id))
434      (with-buffer-request (display *x-setselectionowner*)      (with-buffer-request (display +x-setselectionowner+)
435        ((or null window) owner)        ((or null window) owner)
436        (resource-id selection-id)        (resource-id selection-id)
437        ((or null card32) time))        ((or null card32) time))
# Line 453  Line 453 
453      (declare (type display display)      (declare (type display display)
454               (type resource-id selection-id type-id)               (type resource-id selection-id type-id)
455               (type (or null resource-id) property-id))               (type (or null resource-id) property-id))
456      (with-buffer-request (display *x-convertselection*)      (with-buffer-request (display +x-convertselection+)
457        (window requestor)        (window requestor)
458        (resource-id selection-id type-id)        (resource-id selection-id type-id)
459        ((or null resource-id) property-id)        ((or null resource-id) property-id)
# Line 486  Line 486 
486        (let ((keyword (getf args arg)))        (let ((keyword (getf args arg)))
487          (intern-atom display keyword)))          (intern-atom display keyword)))
488      ;; Make the sendevent request      ;; Make the sendevent request
489      (with-buffer-request (display *x-sendevent*)      (with-buffer-request (display +x-sendevent+)
490        ((data boolean) propagate-p)        ((data boolean) propagate-p)
491        (length 11) ;; 3 word request + 8 words for event = 11        (length 11) ;; 3 word request + 8 words for event = 11
492        ((or (member :pointer-window :input-focus) window) window)        ((or (member :pointer-window :input-focus) window) window)
# Line 506  Line 506 
506             (type timestamp time))             (type timestamp time))
507    (declare (clx-values grab-status))    (declare (clx-values grab-status))
508    (let ((display (window-display window)))    (let ((display (window-display window)))
509      (with-buffer-request-and-reply (display *x-grabpointer* nil :sizes 8)      (with-buffer-request-and-reply (display +x-grabpointer+ nil :sizes 8)
510           (((data boolean) owner-p)           (((data boolean) owner-p)
511            (window window)            (window window)
512            (card16 (encode-pointer-event-mask event-mask))            (card16 (encode-pointer-event-mask event-mask))
# Line 519  Line 519 
519    
520  (defun ungrab-pointer (display &key time)  (defun ungrab-pointer (display &key time)
521    (declare (type timestamp time))    (declare (type timestamp time))
522    (with-buffer-request (display *x-ungrabpointer*)    (with-buffer-request (display +x-ungrabpointer+)
523      ((or null card32) time)))      ((or null card32) time)))
524    
525  (defun grab-button (window button event-mask  (defun grab-button (window button event-mask
# Line 532  Line 532 
532             (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)             (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
533             (type (or null window) confine-to)             (type (or null window) confine-to)
534             (type (or null cursor) cursor))             (type (or null cursor) cursor))
535    (with-buffer-request ((window-display window) *x-grabbutton*)    (with-buffer-request ((window-display window) +x-grabbutton+)
536      ((data boolean) owner-p)      ((data boolean) owner-p)
537      (window window)      (window window)
538      (card16 (encode-pointer-event-mask event-mask))      (card16 (encode-pointer-event-mask event-mask))
# Line 547  Line 547 
547    (declare (type window window)    (declare (type window window)
548             (type (or (member :any) card8) button)             (type (or (member :any) card8) button)
549             (type modifier-mask modifiers))             (type modifier-mask modifiers))
550    (with-buffer-request ((window-display window) *x-ungrabbutton*)    (with-buffer-request ((window-display window) +x-ungrabbutton+)
551      (data (if (eq button :any) 0 button))      (data (if (eq button :any) 0 button))
552      (window window)      (window window)
553      (card16 (encode-modifier-mask modifiers))))      (card16 (encode-modifier-mask modifiers))))
# Line 557  Line 557 
557             (type pointer-event-mask event-mask)             (type pointer-event-mask event-mask)
558             (type (or null cursor) cursor)             (type (or null cursor) cursor)
559             (type timestamp time))             (type timestamp time))
560    (with-buffer-request (display *x-changeactivepointergrab*)    (with-buffer-request (display +x-changeactivepointergrab+)
561      ((or null cursor) cursor)      ((or null cursor) cursor)
562      ((or null card32) time)      ((or null card32) time)
563      (card16 (encode-pointer-event-mask event-mask))))      (card16 (encode-pointer-event-mask event-mask))))
# Line 568  Line 568 
568             (type timestamp time))             (type timestamp time))
569    (declare (clx-values grab-status))    (declare (clx-values grab-status))
570    (let ((display (window-display window)))    (let ((display (window-display window)))
571      (with-buffer-request-and-reply (display *x-grabkeyboard* nil :sizes 8)      (with-buffer-request-and-reply (display +x-grabkeyboard+ nil :sizes 8)
572           (((data boolean) owner-p)           (((data boolean) owner-p)
573            (window window)            (window window)
574            ((or null card32) time)            ((or null card32) time)
# Line 579  Line 579 
579  (defun ungrab-keyboard (display &key time)  (defun ungrab-keyboard (display &key time)
580    (declare (type display display)    (declare (type display display)
581             (type timestamp time))             (type timestamp time))
582    (with-buffer-request (display *x-ungrabkeyboard*)    (with-buffer-request (display +x-ungrabkeyboard+)
583      ((or null card32) time)))      ((or null card32) time)))
584    
585  (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)  (defun grab-key (window key &key (modifiers 0) owner-p sync-pointer-p sync-keyboard-p)
# Line 587  Line 587 
587             (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)             (type generalized-boolean owner-p sync-pointer-p sync-keyboard-p)
588             (type (or (member :any) card8) key)             (type (or (member :any) card8) key)
589             (type modifier-mask modifiers))             (type modifier-mask modifiers))
590    (with-buffer-request ((window-display window) *x-grabkey*)    (with-buffer-request ((window-display window) +x-grabkey+)
591      ((data boolean) owner-p)      ((data boolean) owner-p)
592      (window window)      (window window)
593      (card16 (encode-modifier-mask modifiers))      (card16 (encode-modifier-mask modifiers))
# Line 598  Line 598 
598    (declare (type window window)    (declare (type window window)
599             (type (or (member :any) card8) key)             (type (or (member :any) card8) key)
600             (type modifier-mask modifiers))             (type modifier-mask modifiers))
601    (with-buffer-request ((window-display window) *x-ungrabkey*)    (with-buffer-request ((window-display window) +x-ungrabkey+)
602      (data (if (eq key :any) 0 key))      (data (if (eq key :any) 0 key))
603      (window window)      (window window)
604      (card16 (encode-modifier-mask modifiers))))      (card16 (encode-modifier-mask modifiers))))
# Line 610  Line 610 
610                           :async-both :sync-both)                           :async-both :sync-both)
611                   mode)                   mode)
612             (type timestamp time))             (type timestamp time))
613    (with-buffer-request (display *x-allowevents*)    (with-buffer-request (display +x-allowevents+)
614      ((data (member :async-pointer :sync-pointer :replay-pointer      ((data (member :async-pointer :sync-pointer :replay-pointer
615                     :async-keyboard :sync-keyboard :replay-keyboard                     :async-keyboard :sync-keyboard :replay-keyboard
616                     :async-both :sync-both))                     :async-both :sync-both))
# Line 619  Line 619 
619    
620  (defun grab-server (display)  (defun grab-server (display)
621    (declare (type display display))    (declare (type display display))
622    (with-buffer-request (display *x-grabserver*)))    (with-buffer-request (display +x-grabserver+)))
623    
624  (defun ungrab-server (display)  (defun ungrab-server (display)
625    (with-buffer-request (display *x-ungrabserver*)))    (with-buffer-request (display +x-ungrabserver+)))
626    
627  (defmacro with-server-grabbed ((display) &body body)  (defmacro with-server-grabbed ((display) &body body)
628    ;; The body is not surrounded by a with-display.    ;; The body is not surrounded by a with-display.
# Line 639  Line 639 
639    (declare (type window window))    (declare (type window window))
640    (declare (clx-values x y same-screen-p child mask root-x root-y root))    (declare (clx-values x y same-screen-p child mask root-x root-y root))
641    (let ((display (window-display window)))    (let ((display (window-display window)))
642      (with-buffer-request-and-reply (display *x-querypointer* 26 :sizes (8 16 32))      (with-buffer-request-and-reply (display +x-querypointer+ 26 :sizes (8 16 32))
643           ((window window))           ((window window))
644        (values        (values
645          (int16-get 20)          (int16-get 20)
# Line 655  Line 655 
655    (declare (type window window))    (declare (type window window))
656    (declare (clx-values x y same-screen-p))    (declare (clx-values x y same-screen-p))
657    (let ((display (window-display window)))    (let ((display (window-display window)))
658      (with-buffer-request-and-reply (display *x-querypointer* 24 :sizes (8 16))      (with-buffer-request-and-reply (display +x-querypointer+ 24 :sizes (8 16))
659           ((window window))           ((window window))
660        (values        (values
661          (int16-get 20)          (int16-get 20)
# Line 665  Line 665 
665  (defun global-pointer-position (display)  (defun global-pointer-position (display)
666    (declare (type display display))    (declare (type display display))
667    (declare (clx-values root-x root-y root))    (declare (clx-values root-x root-y root))
668    (with-buffer-request-and-reply (display *x-querypointer* 20 :sizes (16 32))    (with-buffer-request-and-reply (display +x-querypointer+ 20 :sizes (16 32))
669         ((window (screen-root (first (display-roots display)))))         ((window (screen-root (first (display-roots display)))))
670      (values      (values
671        (int16-get 16)        (int16-get 16)
# Line 678  Line 678 
678             (type t result-type)) ;; a type specifier             (type t result-type)) ;; a type specifier
679    (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time))))    (declare (clx-values (repeat-seq (integer x) (integer y) (timestamp time))))
680    (let ((display (window-display window)))    (let ((display (window-display window)))
681      (with-buffer-request-and-reply (display *x-getmotionevents* nil :sizes 32)      (with-buffer-request-and-reply (display +x-getmotionevents+ nil :sizes 32)
682           ((window window)           ((window window)
683            ((or null card32) start stop))            ((or null card32) start stop))
684        (values        (values
685          (sequence-get :result-type result-type :length (index* (card32-get 8) 3)          (sequence-get :result-type result-type :length (index* (card32-get 8) 3)
686                        :index *replysize*)))))                        :index +replysize+)))))
687    
688  (defun translate-coordinates (src src-x src-y dst)  (defun translate-coordinates (src src-x src-y dst)
689    ;; Returns NIL when not on the same screen    ;; Returns NIL when not on the same screen
# Line 692  Line 692 
692             (type window dst))             (type window dst))
693    (declare (clx-values dst-x dst-y child))    (declare (clx-values dst-x dst-y child))
694    (let ((display (window-display src)))    (let ((display (window-display src)))
695      (with-buffer-request-and-reply (display *x-translatecoords* 16 :sizes (8 16 32))      (with-buffer-request-and-reply (display +x-translatecoords+ 16 :sizes (8 16 32))
696           ((window src dst)           ((window src dst)
697            (int16 src-x src-y))            (int16 src-x src-y))
698        (and (boolean-get 1)        (and (boolean-get 1)
# Line 704  Line 704 
704  (defun warp-pointer (dst dst-x dst-y)  (defun warp-pointer (dst dst-x dst-y)
705    (declare (type window dst)    (declare (type window dst)
706             (type int16 dst-x dst-y))             (type int16 dst-x dst-y))
707    (with-buffer-request ((window-display dst) *x-warppointer*)    (with-buffer-request ((window-display dst) +x-warppointer+)
708      (resource-id 0) ;; None      (resource-id 0) ;; None
709      (window dst)      (window dst)
710      (int16 0 0)      (int16 0 0)
# Line 714  Line 714 
714  (defun warp-pointer-relative (display x-off y-off)  (defun warp-pointer-relative (display x-off y-off)
715    (declare (type display display)    (declare (type display display)
716             (type int16 x-off y-off))             (type int16 x-off y-off))
717    (with-buffer-request (display *x-warppointer*)    (with-buffer-request (display +x-warppointer+)
718      (resource-id 0) ;; None      (resource-id 0) ;; None
719      (resource-id 0) ;; None      (resource-id 0) ;; None
720      (int16 0 0)      (int16 0 0)
# Line 729  Line 729 
729             (type int16 dst-x dst-y src-x src-y)             (type int16 dst-x dst-y src-x src-y)
730             (type (or null card16) src-width src-height))             (type (or null card16) src-width src-height))
731    (unless (or (eql src-width 0) (eql src-height 0))    (unless (or (eql src-width 0) (eql src-height 0))
732      (with-buffer-request ((window-display dst) *x-warppointer*)      (with-buffer-request ((window-display dst) +x-warppointer+)
733        (window src dst)        (window src dst)
734        (int16 src-x src-y)        (int16 src-x src-y)
735        (card16 (or src-width 0) (or src-height 0))        (card16 (or src-width 0) (or src-height 0))
# Line 743  Line 743 
743             (type int16 x-off y-off src-x src-y)             (type int16 x-off y-off src-x src-y)
744             (type (or null card16) src-width src-height))             (type (or null card16) src-width src-height))
745    (unless (or (eql src-width 0) (eql src-height 0))    (unless (or (eql src-width 0) (eql src-height 0))
746      (with-buffer-request ((window-display src) *x-warppointer*)      (with-buffer-request ((window-display src) +x-warppointer+)
747        (window src)        (window src)
748        (resource-id 0) ;; None        (resource-id 0) ;; None
749        (int16 src-x src-y)        (int16 src-x src-y)
# Line 755  Line 755 
755             (type (or (member :none :pointer-root) window) focus)             (type (or (member :none :pointer-root) window) focus)
756             (type (member :none :pointer-root :parent) revert-to)             (type (member :none :pointer-root :parent) revert-to)
757             (type timestamp time))             (type timestamp time))
758    (with-buffer-request (display *x-setinputfocus*)    (with-buffer-request (display +x-setinputfocus+)
759      ((data (member :none :pointer-root :parent)) revert-to)      ((data (member :none :pointer-root :parent)) revert-to)
760      ((or window (member :none :pointer-root)) focus)      ((or window (member :none :pointer-root)) focus)
761      ((or null card32) time)))      ((or null card32) time)))
# Line 763  Line 763 
763  (defun input-focus (display)  (defun input-focus (display)
764    (declare (type display display))    (declare (type display display))
765    (declare (clx-values focus revert-to))    (declare (clx-values focus revert-to))
766    (with-buffer-request-and-reply (display *x-getinputfocus* 16 :sizes (8 32))    (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
767         ()         ()
768      (values      (values
769        (or-get 8 window (member :none :pointer-root))        (or-get 8 window (member :none :pointer-root))
# Line 773  Line 773 
773    (declare (type display display)    (declare (type display display)
774             (type (or null (bit-vector 256)) bit-vector))             (type (or null (bit-vector 256)) bit-vector))
775    (declare (clx-values (bit-vector 256)))    (declare (clx-values (bit-vector 256)))
776    (with-buffer-request-and-reply (display *x-querykeymap* 40 :sizes 8)    (with-buffer-request-and-reply (display +x-querykeymap+ 40 :sizes 8)
777         ()         ()
778      (values      (values
779        (bit-vector256-get 8 8 bit-vector))))        (bit-vector256-get 8 8 bit-vector))))
# Line 793  Line 793 
793           (pixmap (or pixmap (make-pixmap :display display)))           (pixmap (or pixmap (make-pixmap :display display)))
794           (pid (allocate-resource-id display pixmap 'pixmap)))           (pid (allocate-resource-id display pixmap 'pixmap)))
795      (setf (pixmap-id pixmap) pid)      (setf (pixmap-id pixmap) pid)
796      (with-buffer-request (display *x-createpixmap*)      (with-buffer-request (display +x-createpixmap+)
797        (data depth)        (data depth)
798        (resource-id pid)        (resource-id pid)
799        (drawable drawable)        (drawable drawable)
# Line 803  Line 803 
803  (defun free-pixmap (pixmap)  (defun free-pixmap (pixmap)
804    (declare (type pixmap pixmap))    (declare (type pixmap pixmap))
805    (let ((display (pixmap-display pixmap)))    (let ((display (pixmap-display pixmap)))
806      (with-buffer-request (display *x-freepixmap*)      (with-buffer-request (display +x-freepixmap+)
807        (pixmap pixmap))        (pixmap pixmap))
808      (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))      (deallocate-resource-id display (pixmap-id pixmap) 'pixmap)))
809    
# Line 815  Line 815 
815             (type (or null card16) width height)             (type (or null card16) width height)
816             (type generalized-boolean exposures-p))             (type generalized-boolean exposures-p))
817    (unless (or (eql width 0) (eql height 0))    (unless (or (eql width 0) (eql height 0))
818      (with-buffer-request ((window-display window) *x-cleartobackground*)      (with-buffer-request ((window-display window) +x-cleartobackground+)
819        ((data boolean) exposures-p)        ((data boolean) exposures-p)
820        (window window)        (window window)
821        (int16 x y)        (int16 x y)
# Line 826  Line 826 
826             (type gcontext gcontext)             (type gcontext gcontext)
827             (type int16 src-x src-y dst-x dst-y)             (type int16 src-x src-y dst-x dst-y)
828             (type card16 width height))             (type card16 width height))
829    (with-buffer-request ((drawable-display src) *x-copyarea* :gc-force gcontext)    (with-buffer-request ((drawable-display src) +x-copyarea+ :gc-force gcontext)
830      (drawable src dst)      (drawable src dst)
831      (gcontext gcontext)      (gcontext gcontext)
832      (int16 src-x src-y dst-x dst-y)      (int16 src-x src-y dst-x dst-y)
# Line 838  Line 838 
838             (type pixel plane)             (type pixel plane)
839             (type int16 src-x src-y dst-x dst-y)             (type int16 src-x src-y dst-x dst-y)
840             (type card16 width height))             (type card16 width height))
841    (with-buffer-request ((drawable-display src) *x-copyplane* :gc-force gcontext)    (with-buffer-request ((drawable-display src) +x-copyplane+ :gc-force gcontext)
842      (drawable src dst)      (drawable src dst)
843      (gcontext gcontext)      (gcontext gcontext)
844      (int16 src-x src-y dst-x dst-y)      (int16 src-x src-y dst-x dst-y)
# Line 856  Line 856 
856      (let* ((colormap (make-colormap :display display :visual-info visual-info))      (let* ((colormap (make-colormap :display display :visual-info visual-info))
857             (id (allocate-resource-id display colormap 'colormap)))             (id (allocate-resource-id display colormap 'colormap)))
858        (setf (colormap-id colormap) id)        (setf (colormap-id colormap) id)
859        (with-buffer-request (display *x-createcolormap*)        (with-buffer-request (display +x-createcolormap+)
860          ((data boolean) alloc-p)          ((data boolean) alloc-p)
861          (card29 id)          (card29 id)
862          (window window)          (window window)
# Line 866  Line 866 
866  (defun free-colormap (colormap)  (defun free-colormap (colormap)
867    (declare (type colormap colormap))    (declare (type colormap colormap))
868    (let ((display (colormap-display colormap)))    (let ((display (colormap-display colormap)))
869      (with-buffer-request (display *x-freecolormap*)      (with-buffer-request (display +x-freecolormap+)
870        (colormap colormap))        (colormap colormap))
871      (deallocate-resource-id display (colormap-id colormap) 'colormap)))      (deallocate-resource-id display (colormap-id colormap) 'colormap)))
872    
# Line 878  Line 878 
878                                        :visual-info (colormap-visual-info colormap)))                                        :visual-info (colormap-visual-info colormap)))
879           (id (allocate-resource-id display new-colormap 'colormap)))           (id (allocate-resource-id display new-colormap 'colormap)))
880      (setf (colormap-id new-colormap) id)      (setf (colormap-id new-colormap) id)
881      (with-buffer-request (display *x-copycolormapandfree*)      (with-buffer-request (display +x-copycolormapandfree+)
882        (resource-id id)        (resource-id id)
883        (colormap colormap))        (colormap colormap))
884      new-colormap))      new-colormap))
885    
886  (defun install-colormap (colormap)  (defun install-colormap (colormap)
887    (declare (type colormap colormap))    (declare (type colormap colormap))
888    (with-buffer-request ((colormap-display colormap) *x-installcolormap*)    (with-buffer-request ((colormap-display colormap) +x-installcolormap+)
889      (colormap colormap)))      (colormap colormap)))
890    
891  (defun uninstall-colormap (colormap)  (defun uninstall-colormap (colormap)
892    (declare (type colormap colormap))    (declare (type colormap colormap))
893    (with-buffer-request ((colormap-display colormap) *x-uninstallcolormap*)    (with-buffer-request ((colormap-display colormap) +x-uninstallcolormap+)
894      (colormap colormap)))      (colormap colormap)))
895    
896  (defun installed-colormaps (window &key (result-type 'list))  (defun installed-colormaps (window &key (result-type 'list))
# Line 900  Line 900 
900    (let ((display (window-display window)))    (let ((display (window-display window)))
901      (flet ((get-colormap (id)      (flet ((get-colormap (id)
902               (lookup-colormap display id)))               (lookup-colormap display id)))
903        (with-buffer-request-and-reply (display *x-listinstalledcolormaps* nil :sizes 16)        (with-buffer-request-and-reply (display +x-listinstalledcolormaps+ nil :sizes 16)
904             ((window window))             ((window window))
905          (values          (values
906            (sequence-get :result-type result-type :length (card16-get 8)            (sequence-get :result-type result-type :length (card16-get 8)
907                          :transform #'get-colormap :index *replysize*))))))                          :transform #'get-colormap :index +replysize+))))))
908    
909  (defun alloc-color (colormap color)  (defun alloc-color (colormap color)
910    (declare (type colormap colormap)    (declare (type colormap colormap)
# Line 913  Line 913 
913    (let ((display (colormap-display colormap)))    (let ((display (colormap-display colormap)))
914      (etypecase color      (etypecase color
915        (color        (color
916          (with-buffer-request-and-reply (display *x-alloccolor* 20 :sizes (16 32))          (with-buffer-request-and-reply (display +x-alloccolor+ 20 :sizes (16 32))
917               ((colormap colormap)               ((colormap colormap)
918                (rgb-val (color-red color)                (rgb-val (color-red color)
919                         (color-green color)                         (color-green color)
# Line 928  Line 928 
928        (stringable        (stringable
929          (let* ((string (string color))          (let* ((string (string color))
930                 (length (length string)))                 (length (length string)))
931            (with-buffer-request-and-reply (display *x-allocnamedcolor* 24 :sizes (16 32))            (with-buffer-request-and-reply (display +x-allocnamedcolor+ 24 :sizes (16 32))
932                 ((colormap colormap)                 ((colormap colormap)
933                  (card16 length)                  (card16 length)
934                  (pad16 nil)                  (pad16 nil)
# Line 949  Line 949 
949             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
950    (declare (clx-values (clx-sequence pixel) (clx-sequence mask)))    (declare (clx-values (clx-sequence pixel) (clx-sequence mask)))
951    (let ((display (colormap-display colormap)))    (let ((display (colormap-display colormap)))
952      (with-buffer-request-and-reply (display *x-alloccolorcells* nil :sizes 16)      (with-buffer-request-and-reply (display +x-alloccolorcells+ nil :sizes 16)
953           (((data boolean) contiguous-p)           (((data boolean) contiguous-p)
954            (colormap colormap)            (colormap colormap)
955            (card16 colors planes))            (card16 colors planes))
956        (let ((pixel-length (card16-get 8))        (let ((pixel-length (card16-get 8))
957              (mask-length (card16-get 10)))              (mask-length (card16-get 10)))
958          (values          (values
959            (sequence-get :result-type result-type :length pixel-length :index *replysize*)            (sequence-get :result-type result-type :length pixel-length :index +replysize+)
960            (sequence-get :result-type result-type :length mask-length            (sequence-get :result-type result-type :length mask-length
961                          :index (index+ *replysize* (index* pixel-length 4))))))))                          :index (index+ +replysize+ (index* pixel-length 4))))))))
962    
963  (defun alloc-color-planes (colormap colors  (defun alloc-color-planes (colormap colors
964                             &key (reds 0) (greens 0) (blues 0)                             &key (reds 0) (greens 0) (blues 0)
# Line 969  Line 969 
969             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
970    (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))    (declare (clx-values (clx-sequence pixel) red-mask green-mask blue-mask))
971    (let ((display (colormap-display colormap)))    (let ((display (colormap-display colormap)))
972      (with-buffer-request-and-reply (display *x-alloccolorplanes* nil :sizes (16 32))      (with-buffer-request-and-reply (display +x-alloccolorplanes+ nil :sizes (16 32))
973           (((data boolean) contiguous-p)           (((data boolean) contiguous-p)
974            (colormap colormap)            (colormap colormap)
975            (card16 colors reds greens blues))            (card16 colors reds greens blues))
# Line 977  Line 977 
977              (green-mask (card32-get 16))              (green-mask (card32-get 16))
978              (blue-mask (card32-get 20)))              (blue-mask (card32-get 20)))
979          (values          (values
980            (sequence-get :result-type result-type :length (card16-get 8) :index *replysize*)            (sequence-get :result-type result-type :length (card16-get 8) :index +replysize+)
981            red-mask green-mask blue-mask)))))            red-mask green-mask blue-mask)))))
982    
983  (defun free-colors (colormap pixels &optional (plane-mask 0))  (defun free-colors (colormap pixels &optional (plane-mask 0))
984    (declare (type colormap colormap)    (declare (type colormap colormap)
985             (type sequence pixels) ;; Sequence of integers             (type sequence pixels) ;; Sequence of integers
986             (type pixel plane-mask))             (type pixel plane-mask))
987    (with-buffer-request ((colormap-display colormap) *x-freecolors*)    (with-buffer-request ((colormap-display colormap) +x-freecolors+)
988      (colormap colormap)      (colormap colormap)
989      (card32 plane-mask)      (card32 plane-mask)
990      (sequence pixels)))      (sequence pixels)))
# Line 1003  Line 1003 
1003      (when blue-p (incf flags 4))      (when blue-p (incf flags 4))
1004      (etypecase spec      (etypecase spec
1005        (color        (color
1006          (with-buffer-request (display *x-storecolors*)          (with-buffer-request (display +x-storecolors+)
1007            (colormap colormap)            (colormap colormap)
1008            (card32 pixel)            (card32 pixel)
1009            (rgb-val (color-red spec)            (rgb-val (color-red spec)
# Line 1014  Line 1014 
1014        (stringable        (stringable
1015          (let* ((string (string spec))          (let* ((string (string spec))
1016                 (length (length string)))                 (length (length string)))
1017            (with-buffer-request (display *x-storenamedcolor*)            (with-buffer-request (display +x-storenamedcolor+)
1018              ((data card8) flags)              ((data card8) flags)
1019              (colormap colormap)              (colormap colormap)
1020              (card32 pixel)              (card32 pixel)
# Line 1046  Line 1046 
1046             (type t result-type))   ;; a type specifier             (type t result-type))   ;; a type specifier
1047    (declare (clx-values (clx-sequence color)))    (declare (clx-values (clx-sequence color)))
1048    (let ((display (colormap-display colormap)))    (let ((display (colormap-display colormap)))
1049      (with-buffer-request-and-reply (display *x-querycolors* nil :sizes (8 16))      (with-buffer-request-and-reply (display +x-querycolors+ nil :sizes (8 16))
1050           ((colormap colormap)           ((colormap colormap)
1051            (sequence pixels))            (sequence pixels))
1052        (let ((sequence (make-sequence result-type (card16-get 8))))        (let ((sequence (make-sequence result-type (card16-get 8))))
1053          (advance-buffer-offset *replysize*)          (advance-buffer-offset +replysize+)
1054          (dotimes (i (length sequence) sequence)          (dotimes (i (length sequence) sequence)
1055            (setf (elt sequence i)            (setf (elt sequence i)
1056                  (make-color :red (rgb-val-get 0)                  (make-color :red (rgb-val-get 0)
# Line 1065  Line 1065 
1065    (let* ((display (colormap-display colormap))    (let* ((display (colormap-display colormap))
1066           (string (string name))           (string (string name))
1067           (length (length string)))           (length (length string)))
1068      (with-buffer-request-and-reply (display *x-lookupcolor* 20 :sizes 16)      (with-buffer-request-and-reply (display +x-lookupcolor+ 20 :sizes 16)
1069           ((colormap colormap)           ((colormap colormap)
1070            (card16 length)            (card16 length)
1071            (pad16 nil)            (pad16 nil)
# Line 1094  Line 1094 
1094           (cursor (make-cursor :display display))           (cursor (make-cursor :display display))
1095           (cid (allocate-resource-id display cursor 'cursor)))           (cid (allocate-resource-id display cursor 'cursor)))
1096      (setf (cursor-id cursor) cid)      (setf (cursor-id cursor) cid)
1097      (with-buffer-request (display *x-createcursor*)      (with-buffer-request (display +x-createcursor+)
1098        (resource-id cid)        (resource-id cid)
1099        (pixmap source)        (pixmap source)
1100        ((or null pixmap) mask)        ((or null pixmap) mask)
# Line 1127  Line 1127 
1127           (mask-font-id (if mask-font (font-id mask-font) 0)))           (mask-font-id (if mask-font (font-id mask-font) 0)))
1128      (setf (cursor-id cursor) cid)      (setf (cursor-id cursor) cid)
1129      (unless mask-char (setq mask-char 0))      (unless mask-char (setq mask-char 0))
1130      (with-buffer-request (display *x-createglyphcursor*)      (with-buffer-request (display +x-createglyphcursor+)
1131        (resource-id cid source-font-id mask-font-id)        (resource-id cid source-font-id mask-font-id)
1132        (card16 source-char)        (card16 source-char)
1133        (card16 mask-char)        (card16 mask-char)
# Line 1142  Line 1142 
1142  (defun free-cursor (cursor)  (defun free-cursor (cursor)
1143    (declare (type cursor cursor))    (declare (type cursor cursor))
1144    (let ((display (cursor-display cursor)))    (let ((display (cursor-display cursor)))
1145      (with-buffer-request (display *x-freecursor*)      (with-buffer-request (display +x-freecursor+)
1146        (cursor cursor))        (cursor cursor))
1147      (deallocate-resource-id display (cursor-id cursor) 'cursor)))      (deallocate-resource-id display (cursor-id cursor) 'cursor)))
1148    
1149  (defun recolor-cursor (cursor foreground background)  (defun recolor-cursor (cursor foreground background)
1150    (declare (type cursor cursor)    (declare (type cursor cursor)
1151             (type color foreground background))             (type color foreground background))
1152    (with-buffer-request ((cursor-display cursor) *x-recolorcursor*)    (with-buffer-request ((cursor-display cursor) +x-recolorcursor+)
1153      (cursor cursor)      (cursor cursor)
1154      (rgb-val (color-red foreground)      (rgb-val (color-red foreground)
1155               (color-green foreground)               (color-green foreground)
# Line 1168  Line 1168 
1168        (if (type? drawable 'drawable)        (if (type? drawable 'drawable)
1169            (values (drawable-display drawable) drawable)            (values (drawable-display drawable) drawable)
1170          (values drawable (screen-root (display-default-screen drawable))))          (values drawable (screen-root (display-default-screen drawable))))
1171      (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)      (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
1172           ((data 0)           ((data 0)
1173            (window drawable)            (window drawable)
1174            (card16 width height))            (card16 width height))
# Line 1181  Line 1181 
1181             (type drawable drawable))             (type drawable drawable))
1182    (declare (clx-values width height))    (declare (clx-values width height))
1183    (let ((display (drawable-display drawable)))    (let ((display (drawable-display drawable)))
1184      (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)      (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
1185           ((data 1)           ((data 1)
1186            (drawable drawable)            (drawable drawable)
1187            (card16 width height))            (card16 width height))
# Line 1194  Line 1194 
1194             (type drawable drawable))             (type drawable drawable))
1195    (declare (clx-values width height))    (declare (clx-values width height))
1196    (let ((display (drawable-display drawable)))    (let ((display (drawable-display drawable)))
1197      (with-buffer-request-and-reply (display *x-querybestsize* 12 :sizes 16)      (with-buffer-request-and-reply (display +x-querybestsize+ 12 :sizes 16)
1198           ((data 2)           ((data 2)
1199            (drawable drawable)            (drawable drawable)
1200            (card16 width height))            (card16 width height))
# Line 1207  Line 1207 
1207             (type stringable name))             (type stringable name))
1208    (declare (clx-values major-opcode first-event first-error))    (declare (clx-values major-opcode first-event first-error))
1209    (let ((string (string name)))    (let ((string (string name)))
1210      (with-buffer-request-and-reply (display *x-queryextension* 12 :sizes 8)      (with-buffer-request-and-reply (display +x-queryextension+ 12 :sizes 8)
1211           ((card16 (length string))           ((card16 (length string))
1212            (pad16 nil)            (pad16 nil)
1213            (string string))            (string string))
# Line 1221  Line 1221 
1221    (declare (type display display)    (declare (type display display)
1222             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
1223    (declare (clx-values (clx-sequence string)))    (declare (clx-values (clx-sequence string)))
1224    (with-buffer-request-and-reply (display *x-listextensions* size :sizes 8)    (with-buffer-request-and-reply (display +x-listextensions+ size :sizes 8)
1225         ()         ()
1226      (values      (values
1227        (read-sequence-string        (read-sequence-string
1228          buffer-bbuf (index- size *replysize*) (card8-get 1) result-type *replysize*))))          buffer-bbuf (index- size +replysize+) (card8-get 1) result-type +replysize+))))
1229    
1230  (defun change-keyboard-control (display &key key-click-percent  (defun change-keyboard-control (display &key key-click-percent
1231                                  bell-percent bell-pitch bell-duration                                  bell-percent bell-pitch bell-duration
# Line 1240  Line 1240 
1240    (when (eq bell-percent :default) (setq bell-percent -1))    (when (eq bell-percent :default) (setq bell-percent -1))
1241    (when (eq bell-pitch :default) (setq bell-pitch -1))    (when (eq bell-pitch :default) (setq bell-pitch -1))
1242    (when (eq bell-duration :default) (setq bell-duration -1))    (when (eq bell-duration :default) (setq bell-duration -1))
1243    (with-buffer-request (display *x-changekeyboardcontrol* :sizes (32))    (with-buffer-request (display +x-changekeyboardcontrol+ :sizes (32))
1244      (mask      (mask
1245        (integer key-click-percent bell-percent bell-pitch bell-duration)        (integer key-click-percent bell-percent bell-pitch bell-duration)
1246        (card32 led)        (card32 led)
# Line 1252  Line 1252 
1252    (declare (type display display))    (declare (type display display))
1253    (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration    (declare (clx-values key-click-percent bell-percent bell-pitch bell-duration
1254                    led-mask global-auto-repeat auto-repeats))                    led-mask global-auto-repeat auto-repeats))
1255    (with-buffer-request-and-reply (display *x-getkeyboardcontrol* 32 :sizes (8 16 32))    (with-buffer-request-and-reply (display +x-getkeyboardcontrol+ 32 :sizes (8 16 32))
1256         ()         ()
1257      (values      (values
1258        (card8-get 12)        (card8-get 12)
# Line 1261  Line 1261 
1261        (card16-get 16)        (card16-get 16)
1262        (card32-get 8)        (card32-get 8)
1263        (member8-get 1 :off :on)        (member8-get 1 :off :on)
1264        (bit-vector256-get 32))))        (bit-vector256-get 20))))
1265    
1266  ;;  The base volume should  ;;  The base volume should
1267  ;; be considered to be the "desired" volume in the normal case; that is, a  ;; be considered to be the "desired" volume in the normal case; that is, a
# Line 1276  Line 1276 
1276    ;; It is assumed that an eventual audio extension to X will provide more complete control.    ;; It is assumed that an eventual audio extension to X will provide more complete control.
1277    (declare (type display display)    (declare (type display display)
1278             (type int8 percent-from-normal))             (type int8 percent-from-normal))
1279    (with-buffer-request (display *x-bell*)    (with-buffer-request (display +x-bell+)
1280      (data (int8->card8 percent-from-normal))))      (data (int8->card8 percent-from-normal))))
1281    
1282  (defun pointer-mapping (display &key (result-type 'list))  (defun pointer-mapping (display &key (result-type 'list))
1283    (declare (type display display)    (declare (type display display)
1284             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
1285    (declare (clx-values sequence)) ;; Sequence of card    (declare (clx-values sequence)) ;; Sequence of card
1286    (with-buffer-request-and-reply (display *x-getpointermapping* nil :sizes 8)    (with-buffer-request-and-reply (display +x-getpointermapping+ nil :sizes 8)
1287         ()         ()
1288      (values      (values
1289        (sequence-get :length (card8-get 1) :result-type result-type :format card8        (sequence-get :length (card8-get 1) :result-type result-type :format card8
1290                      :index *replysize*))))                      :index +replysize+))))
1291    
1292  (defun set-pointer-mapping (display map)  (defun set-pointer-mapping (display map)
1293    ;; Can signal device-busy.    ;; Can signal device-busy.
1294    (declare (type display display)    (declare (type display display)
1295             (type sequence map)) ;; Sequence of card8             (type sequence map)) ;; Sequence of card8
1296    (when (with-buffer-request-and-reply (display *x-setpointermapping* 2 :sizes 8)    (when (with-buffer-request-and-reply (display +x-setpointermapping+ 2 :sizes 8)
1297               ((data (length map))               ((data (length map))
1298                ((sequence :format card8) map))                ((sequence :format card8) map))
1299            (values            (values
# Line 1334  Line 1334 
1334        (cond ((eq threshold :default) (setq threshold -1))        (cond ((eq threshold :default) (setq threshold -1))
1335              ((null threshold) (setq threshold -1              ((null threshold) (setq threshold -1
1336                                      threshold-p 0)))                                      threshold-p 0)))
1337        (with-buffer-request (display *x-changepointercontrol*)        (with-buffer-request (display +x-changepointercontrol+)
1338          (int16 numerator denominator threshold)          (int16 numerator denominator threshold)
1339          (card8 acceleration-p threshold-p)))))          (card8 acceleration-p threshold-p)))))
1340    
1341  (defun pointer-control (display)  (defun pointer-control (display)
1342    (declare (type display display))    (declare (type display display))
1343    (declare (clx-values acceleration threshold))    (declare (clx-values acceleration threshold))
1344    (with-buffer-request-and-reply (display *x-getpointercontrol* 16 :sizes 16)    (with-buffer-request-and-reply (display +x-getpointercontrol+ 16 :sizes 16)
1345         ()         ()
1346      (values      (values
1347        (/ (card16-get 8) (card16-get 10))        ; Should we float this?        (/ (card16-get 8) (card16-get 10))        ; Should we float this?
# Line 1356  Line 1356 
1356    (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off)))    (case exposures (:yes (setq exposures :on)) (:no (setq exposures :off)))
1357    (when (eq timeout :default) (setq timeout -1))    (when (eq timeout :default) (setq timeout -1))
1358    (when (eq interval :default) (setq interval -1))    (when (eq interval :default) (setq interval -1))
1359    (with-buffer-request (display *x-setscreensaver*)    (with-buffer-request (display +x-setscreensaver+)
1360      (int16 timeout interval)      (int16 timeout interval)
1361      ((member8 :on :off :default) blanking exposures)))      ((member8 :on :off :default) blanking exposures)))
1362    
# Line 1364  Line 1364 
1364    ;; Returns timeout and interval in seconds.    ;; Returns timeout and interval in seconds.
1365    (declare (type display display))    (declare (type display display))
1366    (declare (clx-values timeout interval blanking exposures))    (declare (clx-values timeout interval blanking exposures))
1367    (with-buffer-request-and-reply (display *x-getscreensaver* 14 :sizes (8 16))    (with-buffer-request-and-reply (display +x-getscreensaver+ 14 :sizes (8 16))
1368         ()         ()
1369      (values      (values
1370        (card16-get 8)        (card16-get 8)
# Line 1374  Line 1374 
1374    
1375  (defun activate-screen-saver (display)  (defun activate-screen-saver (display)
1376    (declare (type display display))    (declare (type display display))
1377    (with-buffer-request (display *x-forcescreensaver*)    (with-buffer-request (display +x-forcescreensaver+)
1378      (data 1)))      (data 1)))
1379    
1380  (defun reset-screen-saver (display)  (defun reset-screen-saver (display)
1381    (declare (type display display))    (declare (type display display))
1382    (with-buffer-request (display *x-forcescreensaver*)    (with-buffer-request (display +x-forcescreensaver+)
1383      (data 0)))      (data 0)))
1384    
1385  (defun add-access-host (display host &optional (family :internet))  (defun add-access-host (display host &optional (family :internet))
# Line 1410  Line 1410 
1410      (setq host (host-address host family)))      (setq host (host-address host family)))
1411    (let ((family (car host))    (let ((family (car host))
1412          (address (cdr host)))          (address (cdr host)))
1413      (with-buffer-request (display *x-changehosts*)      (with-buffer-request (display +x-changehosts+)
1414        ((data boolean) remove-p)        ((data boolean) remove-p)
1415        (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))        (card8 (encode-type (or null (member :internet :decnet :chaos) card32) family))
1416        (card16 (length address))        (card16 (length address))
# Line 1424  Line 1424 
1424    (declare (type display display)    (declare (type display display)
1425             (type t result-type)) ;; CL type             (type t result-type)) ;; CL type
1426    (declare (clx-values (clx-sequence host) enabled-p))    (declare (clx-values (clx-sequence host) enabled-p))
1427    (with-buffer-request-and-reply (display *x-listhosts* nil :sizes (8 16))    (with-buffer-request-and-reply (display +x-listhosts+ nil :sizes (8 16))
1428         ()         ()
1429      (let* ((enabled-p (boolean-get 1))      (let* ((enabled-p (boolean-get 1))
1430             (nhosts (card16-get 8))             (nhosts (card16-get 8))
1431             (sequence (make-sequence result-type nhosts)))             (sequence (make-sequence result-type nhosts)))
1432        (advance-buffer-offset *replysize*)        (advance-buffer-offset +replysize+)
1433        (dotimes (i nhosts)        (dotimes (i nhosts)
1434          (let ((family (card8-get 0))          (let ((family (card8-get 0))
1435                (len (card16-get 2)))                (len (card16-get 2)))
# Line 1447  Line 1447 
1447  (defun access-control (display)  (defun access-control (display)
1448    (declare (type display display))    (declare (type display display))
1449    (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED    (declare (clx-values generalized-boolean)) ;; True when access-control is ENABLED
1450    (with-buffer-request-and-reply (display *x-listhosts* 2 :sizes 8)    (with-buffer-request-and-reply (display +x-listhosts+ 2 :sizes 8)
1451         ()         ()
1452      (boolean-get 1)))      (boolean-get 1)))
1453    
1454  (defun set-access-control (display enabled-p)  (defun set-access-control (display enabled-p)
1455    (declare (type display display)    (declare (type display display)
1456             (type generalized-boolean enabled-p))             (type generalized-boolean enabled-p))
1457    (with-buffer-request (display *x-changeaccesscontrol*)    (with-buffer-request (display +x-changeaccesscontrol+)
1458      ((data boolean) enabled-p))      ((data boolean) enabled-p))
1459    enabled-p)    enabled-p)
1460    
# Line 1472  Line 1472 
1472    (declare (type display display)    (declare (type display display)
1473             (type (member :destroy :retain-permanent :retain-temporary) mode))             (type (member :destroy :retain-permanent :retain-temporary) mode))
1474    (setf (display-close-down-mode display) mode)    (setf (display-close-down-mode display) mode)
1475    (with-buffer-request (display *x-changeclosedownmode* :sizes (32))    (with-buffer-request (display +x-changeclosedownmode+ :sizes (32))
1476      ((data (member :destroy :retain-permanent :retain-temporary)) mode))      ((data (member :destroy :retain-permanent :retain-temporary)) mode))
1477    mode)    mode)
1478    
# Line 1481  Line 1481 
1481  (defun kill-client (display resource-id)  (defun kill-client (display resource-id)
1482    (declare (type display display)    (declare (type display display)
1483             (type resource-id resource-id))             (type resource-id resource-id))
1484    (with-buffer-request (display *x-killclient*)    (with-buffer-request (display +x-killclient+)
1485      (resource-id resource-id)))      (resource-id resource-id)))
1486    
1487  (defun kill-temporary-clients (display)  (defun kill-temporary-clients (display)
1488    (declare (type display display))    (declare (type display display))
1489    (with-buffer-request (display *x-killclient*)    (with-buffer-request (display +x-killclient+)
1490      (resource-id 0)))      (resource-id 0)))
1491    
1492  (defun no-operation (display)  (defun no-operation (display)
1493    (declare (type display display))    (declare (type display display))
1494    (with-buffer-request (display *x-nooperation*)))    (with-buffer-request (display +x-nooperation+)))

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

  ViewVC Help
Powered by ViewVC 1.1.5