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