cgit.sxemacs.org Git - packages/blob - xemacs-packages/xlib/lisp/xlib-xwin.el

   1 ;;; xlib-xwin.el --- Core X structures.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: 18 October 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xlib-xwin.el,v 1.9 2005-04-04 19:55:31 lg Exp $
   9 ;; X-URL: http://lgarc.narod.ru/xwem/index.html
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;;
  33
  34 ;;; Code:
  35 \f
  36 (eval-when-compile
  37   (require 'cl)
  38
  39   (mapc (lambda (el)
  40           (autoload el "xlib-xlib"))
  41         '(X-invalidate-cl-struct XOpenFont XQueryFont XQueryTextExtents))
  42   )
  43
  44 (require 'xlib-xc)
  45
  46 ;; Point is either a cons cell in form (x . y) or X-Point structure
  47 (defstruct (X-Point (:predicate X-Point-ispoint-p))
  48   xx yy)
  49
  50 (defsubst X-Point-p (xpnt &optional sig)
  51   "Return non-nil if XPNT is point."
  52   (let ((ispnt (or (consp xpnt) (X-Point-ispoint-p xpnt))))
  53     (if (and sig (not ispnt))
  54         (signal 'wrong-type-argument (list sig 'X-Point-p xpnt))
  55       ispnt)))
  56
  57 (defmacro X-Point-x (xpnt)
  58   `(if (consp ,xpnt)
  59        (car ,xpnt)
  60      (X-Point-xx ,xpnt)))
  61
  62 (defmacro X-Point-y (xpnt)
  63   `(if (consp ,xpnt)
  64        (cdr ,xpnt)
  65      (X-Point-yy ,xpnt)))
  66
  67 (defsetf X-Point-x (xpnt) (val)
  68   `(if (consp ,xpnt)
  69        (setcar ,xpnt ,val)
  70      (setf (X-Point-xx ,xpnt) ,val)))
  71
  72 (defsetf X-Point-y (xpnt) (val)
  73   `(if (consp ,xpnt)
  74        (setcdr ,xpnt ,val)
  75      (setf (X-Point-yy ,xpnt) ,val)))
  76
  77 (defun X-Point-message (xpnt)
  78   "Return string representing x point XPNT."
  79   (concat (int->string2 (X-Point-x xpnt))
  80           (int->string2 (X-Point-y xpnt))))
  81
  82 ;; Segment is a pair of points
  83 (defun X-Segment-message (xseg)
  84   "Return string representing x segment XSEG."
  85   (concat (X-Point-message (car xseg))
  86           (X-Point-message (cdr xseg))))
  87
  88 ;; Rectangle
  89 (defstruct (X-Rect (:predicate X-Rect-isrect-p))
  90   x y width height)
  91
  92 (defsubst X-Rect-p (xrect &optional sig)
  93   "Return non-nil if XRECT is X-Rect structure."
  94   (X-Generic-p 'X-Rect 'X-Rect-isrect-p xrect sig))
  95
  96 (defun X-Rect-internal-intersect-p (xrect1 xrect2)
  97   "Return non-nil if two rectangles XRECT1 and XRECT2 have common part."
  98   (let ((minx (min (X-Rect-x xrect1) (X-Rect-x xrect2)))
  99         (maxx (max (+ (X-Rect-x xrect1) (X-Rect-width xrect1))
 100                    (+ (X-Rect-x xrect2) (X-Rect-width xrect2))))
 101         (miny (min (X-Rect-y xrect1) (X-Rect-y xrect2)))
 102         (maxy (max (+ (X-Rect-y xrect1) (X-Rect-height xrect1))
 103                    (+ (X-Rect-y xrect2) (X-Rect-height xrect2)))))
 104
 105   (and (> (+ (X-Rect-width xrect1) (X-Rect-width xrect2))
 106           (- maxx minx))
 107
 108        (> (+ (X-Rect-height xrect1) (X-Rect-height xrect2))
 109           (- maxy miny)))))
 110
 111 (defun X-Rect-intersect-p (&rest xrects)
 112   "Return non-nil if rectangles in XRECTS are intersects."
 113   (while (and xrects
 114               (not (member t (mapcar #'(lambda (r)
 115                                          (X-Rect-internal-intersect-p (car xrects) r))
 116                                      (cdr xrects)))))
 117     (setq xrects (cdr xrects)))
 118
 119   xrects)
 120
 121 (defun X-Rect-message (xrect)
 122   "Return string representing X-Rect XRECT."
 123   (concat (int->string2 (X-Rect-x xrect))
 124           (int->string2 (X-Rect-y xrect))
 125           (int->string2 (X-Rect-width xrect))
 126           (int->string2 (X-Rect-height xrect))))
 127
 128 ;; Geometry
 129 (defstruct (X-Geom (:include X-Rect)
 130                    (:predicate X-Geom-isgeom-p))
 131   (border-width 0))
 132
 133 (defun X-Geom-p (geom &optional sig)
 134   "Return non-nil if GEOM is X-Geom structure.
 135 If SIG is gived and GEOM is not X-Geom structure, SIG will be signaled."
 136   (X-Generic-p 'X-Geom 'X-Geom-isgeom-p geom sig))
 137
 138 (defun X-Geom-apply (fn geom1 geom2)
 139   "Apply function FN to each element of GEOM1 and GEOM2.
 140 Return new geom."
 141   (X-Geom-p geom1 'X-Geom-apply)
 142   (X-Geom-p geom2 'X-Geom-apply)
 143
 144   (make-X-Geom :x (funcall fn (X-Geom-x geom1) (X-Geom-x geom2))
 145                :y (funcall fn (X-Geom-y geom1) (X-Geom-y geom2))
 146                :width (funcall fn (X-Geom-width geom1) (X-Geom-width geom2))
 147                :height (funcall fn (X-Geom-height geom1) (X-Geom-height geom2))
 148                :border-width (funcall fn (X-Geom-border-width geom1) (X-Geom-border-width geom2))))
 149
 150 (defun X-Geom-sum (geom1 geom2)
 151   "Create new geometry which elements is sum of corresponded elements of GEOM1 and GEOM2."
 152   (X-Geom-apply '+ geom1 geom2))
 153
 154 (defun X-Geom-sub (geom1 geom2)
 155   (X-Geom-apply '- geom1 geom2))
 156
 157 (defun X-Geom-width-with-borders (geom)
 158   "Return GEOM width including border's width."
 159   (+ (X-Geom-width geom)
 160      (* 2 (X-Geom-border-width geom))))
 161
 162 (defun X-Geom-height-with-borders (geom)
 163   "Return GEOM height including border's width."
 164   (+ (X-Geom-height geom)
 165      (* 2 (X-Geom-border-width geom))))
 166
 167 ;;; X-Geom <--> X-Rect conversation
 168 (defun X-Geom-to-X-Rect (xgeom)
 169   "Convert XGEOM to X-Rect."
 170   (make-X-Rect :x (X-Geom-x xgeom)
 171                :y (X-Geom-y xgeom)
 172                :width (X-Geom-width xgeom)
 173                :height (X-Geom-height xgeom)))
 174
 175 (defun X-Rect-to-X-Geom (xrect)
 176   "Convert XRECT to X-Geom."
 177   (make-X-Geom :x (X-Rect-x xrect)
 178                :y (X-Rect-y xrect)
 179                :width (X-Rect-width xrect)
 180                :height (X-Rect-height xrect)))
 181
 182 ;; Arc
 183 (defstruct (X-Arc (:include X-Rect)
 184                   (:predicate X-Arc-isarc-p))
 185   angle1 angle2)
 186
 187 (defsubst X-Arc-p (xarc &optional sig)
 188   "Return non-nil xf XARC is X-Arc structure."
 189   (X-Generic-p 'X-Arc 'X-Arc-isarc-p xarc sig))
 190
 191 (defun X-Arc-message (xarc)
 192   "Return string representing XARC."
 193   (concat (int->string2 (X-Arc-x xarc))
 194           (int->string2 (X-Arc-y xarc))
 195           (int->string2 (X-Arc-width xarc))
 196           (int->string2 (X-Arc-height xarc))
 197           (int->string2 (* 64 (X-Arc-angle1 xarc)))
 198           (int->string2 (* 64 (X-Arc-angle2 xarc)))))
 199
 200 ;; Atoms operations
 201 (defstruct (X-Atom (:predicate X-Atom-isatom-p))
 202   dpy id name)
 203
 204 (defsubst X-Atom-p (atom &optional sig)
 205   "Return non-nil if ATOM is atom structure.
 206 If SIG is given and ATOM is not atom structure, SIG will be signaled."
 207   (X-Generic-p 'X-Atom 'X-Atom-isatom-p atom sig))
 208
 209 (defsubst X-Atom-insert (xdpy atom)
 210   "Insert ATOM in XDPY's atoms list, if not already there."
 211   (pushnew atom (X-Dpy-atoms xdpy)
 212            :test #'(lambda (a1 a2)
 213                      (= (X-Atom-id a1) (X-Atom-id a2)))))
 214
 215 (defsubst X-Atom-find (xdpy aid)
 216   "Find atom with id AID on X display XDPY."
 217   (X-Dpy-p xdpy 'X-Atom-find)
 218
 219   (let ((al (X-Dpy-atoms xdpy)))
 220     (while (and al (not (= (X-Atom-id (car al)) aid)))
 221       (setq al (cdr al)))
 222
 223     (car al)))
 224
 225 (defsubst X-Atom-find-or-make (xdpy aid)
 226   "On XDPY find atom with id AID, if no such atom, create new one."
 227   (X-Dpy-p xdpy 'X-Atom-find-or-make)
 228
 229   (or (X-Atom-find xdpy aid)
 230       (car (X-Atom-insert xdpy (make-X-Atom :dpy xdpy :id aid)))))
 231
 232 (defsubst X-Atom-find-by-name (xdpy aname)
 233   "Find atom with name ANAME on X display XDPY."
 234   (let ((al (X-Dpy-atoms xdpy)))
 235     (while (and al (not (string= (X-Atom-name (car al)) aname)))
 236       (setq al (cdr al)))
 237     (car al)))
 238
 239 (defsubst X-Atom-equal (a1 a2)
 240   "Return non-nil if two atoms A1 and A2 are equal."
 241   (eq (and (X-Atom-p a1) (X-Atom-id a1))
 242       (and (X-Atom-p a2) (X-Atom-id a2))))
 243
 244 ;;; Predefined Atoms
 245 (defconst XA-AnyPropertyType (make-X-Atom :id 0.0 :name "") "Any atom.")
 246 (defconst XA-primary (make-X-Atom :id 1.0 :name "PRIMARY") "Atom primary encoding.")
 247 (defconst XA-secondary (make-X-Atom :id 2.0 :name "SECONDARY") "Atom secondary encoding.")
 248 (defconst XA-arc (make-X-Atom :id 3.0 :name "ARC") "Atom arc encoding.")
 249 (defconst XA-atom (make-X-Atom :id 4.0 :name "ATOM") "Atom atom encoding.")
 250 (defconst XA-bitmap (make-X-Atom :id 5.0 :name "BITMAP") "Atom bitmap encoding.")
 251 (defconst XA-cardinal (make-X-Atom :id 6.0 :name "CARDINAL") "Atom cardinal encoding.")
 252 (defconst XA-colormap (make-X-Atom :id 7.0 :name "COLORMAP") "Atom colormap encoding.")
 253 (defconst XA-cursor (make-X-Atom :id 8.0 :name "CURSOR") "Atom cursor encoding.")
 254 (defconst XA-cut-buffer0 (make-X-Atom :id 9.0 :name "XA_CUT_BUFFER0") "Atom cut-buffer0 encoding.")
 255 (defconst XA-cut-buffer1 (make-X-Atom :id 10.0 :name "CUT_BUFFER1") "Atom cut-buffer1 eoncoding.")
 256 (defconst XA-cut-buffer2 (make-X-Atom :id 11.0 :name "CUT_BUFFER2") "Atom cut-buffer2 eoncoding.")
 257 (defconst XA-cut-buffer3 (make-X-Atom :id 12.0 :name "CUT_BUFFER3") "Atom cut-buffer3 eoncoding.")
 258 (defconst XA-cut-buffer4 (make-X-Atom :id 13.0 :name "CUT_BUFFER4") "Atom cut-buffer4 eoncoding.")
 259 (defconst XA-cut-buffer5 (make-X-Atom :id 14.0 :name "CUT_BUFFER5") "Atom cut-buffer5 eoncoding.")
 260 (defconst XA-cut-buffer6 (make-X-Atom :id 15.0 :name "CUT_BUFFER6") "Atom cut-buffer6 eoncoding.")
 261 (defconst XA-cut-buffer7 (make-X-Atom :id 16.0 :name "CUT_BUFFER7") "Atom cut-buffer7 eoncoding.")
 262 (defconst XA-drawable (make-X-Atom :id 17.0 :name "XA_DRAWABLE") "Atom drawable eoncoding.")
 263 (defconst XA-font (make-X-Atom :id 18.0 :name "FONT") "Atom font eoncoding.")
 264 (defconst XA-integer (make-X-Atom :id 19.0 :name "INTEGER") "Atom integer eoncoding.")
 265 (defconst XA-pixmap (make-X-Atom :id 20.0 :name "PIXMAP") "Atom pixmap eoncoding.")
 266 (defconst XA-point (make-X-Atom :id 21.0 :name "POINT") "Atom point eoncoding.")
 267 (defconst XA-rectangle (make-X-Atom :id 22.0 :name "RECTANGLE") "Atom rectangle eoncoding.")
 268 (defconst XA-resource-manager (make-X-Atom :id 23.0 :name "RESOURCE_MANAGER") "Atom resource-manager eoncoding.")
 269 (defconst XA-rgb-color-map (make-X-Atom :id 24.0 :name "RGB_COLOR_MAP") "Atom rgb-color-map eoncoding.")
 270 (defconst XA-rgb-best-map (make-X-Atom :id 25.0 :name "RGB_BEST_MAP") "Atom rgb-best-map eoncoding.")
 271 (defconst XA-rgb-blue-map (make-X-Atom :id 26.0 :name "RGB_BLUE_MAP") "Atom rgb-blue-map eoncoding.")
 272 (defconst XA-rgb-default-map (make-X-Atom :id 27.0 :name "RGB_DEFAULT_MAP") "Atom rgb-default-map eoncoding.")
 273 (defconst XA-rgb-gray-map (make-X-Atom :id 28.0 :name "RGB_GRAY_MAP") "Atom rgb-gray-map eoncoding.")
 274 (defconst XA-rgb-green-map (make-X-Atom :id 29.0 :name "RGB_GREEN_MAP") "Atom rgb-green-map eoncoding.")
 275 (defconst XA-rgb-red-map (make-X-Atom :id 30.0 :name "RGB_RED_MAP") "Atom rgb-red-map eoncoding.")
 276 (defconst XA-string (make-X-Atom :id 31.0 :name "STRING") "Atom string eoncoding.")
 277 (defconst XA-visualid (make-X-Atom :id 32.0 :name "VISUALID") "Atom visualid eoncoding.")
 278 (defconst XA-window (make-X-Atom :id 33.0 :name "WINDOW") "Atom window eoncoding.")
 279 (defconst XA-wm-command (make-X-Atom :id 34.0 :name "WM_COMMAND") "Atom wm-command eoncoding.")
 280 (defconst XA-wm-hints (make-X-Atom :id 35.0 :name "WM_HINTS") "Atom wm-hints eoncoding.")
 281 (defconst XA-wm-client-machine (make-X-Atom :id 36.0 :name "WM_CLIENT_MACHINE") "Atom wm-client-machine eoncoding.")
 282 (defconst XA-wm-icon-name (make-X-Atom :id 37.0 :name "WM_ICON_NAME") "Atom wm-icon-name eoncoding.")
 283 (defconst XA-wm-icon-size (make-X-Atom :id 38.0 :name "WM_ICON_SIZE") "Atom wm-icon-size eoncoding.")
 284 (defconst XA-wm-name (make-X-Atom :id 39.0 :name "WM_NAME") "Atom wm-name eoncoding.")
 285 (defconst XA-wm-normal-hints (make-X-Atom :id 40.0 :name "WM_NORMAL_HINTS") "Atom wm-normal-hints eoncoding.")
 286 (defconst XA-wm-size-hints (make-X-Atom :id 41.0 :name "WM_SIZE_HINTS") "Atom wm-size-hints eoncoding.")
 287 (defconst XA-wm-zoom-hints (make-X-Atom :id 42.0 :name "WM_ZOOM_HINTS") "Atom wm-zoom-hints eoncoding.")
 288 (defconst XA-min-space (make-X-Atom :id 43.0 :name "MIN_SPACE") "Atom min-space eoncoding.")
 289 (defconst XA-norm-space (make-X-Atom :id 44.0 :name "NORM_SPACE") "Atom norm-space eoncoding.")
 290 (defconst XA-max-space (make-X-Atom :id 45.0 :name "MAX_SPACE") "Atom max-space eoncoding.")
 291 (defconst XA-end-space (make-X-Atom :id 46.0 :name "END_SPACE") "Atom end-space eoncoding.")
 292 (defconst XA-superscript-x (make-X-Atom :id 47.0 :name "SUPERSCRIPT_X") "Atom superscript-x eoncoding.")
 293 (defconst XA-superscript-y (make-X-Atom :id 48.0 :name "SUPERSCRIPT_Y") "Atom superscript-y eoncoding.")
 294 (defconst XA-subscript-x (make-X-Atom :id 49.0 :name "SUBSCRIPT_X") "Atom subscript-x eoncoding.")
 295 (defconst XA-subscript-y (make-X-Atom :id 50.0 :name "SUBSCRIPT_Y") "Atom subscript-y eoncoding.")
 296 (defconst XA-underline-position (make-X-Atom :id 51.0 :name "UNDERLINE_POSITION") "Atom underline-position eoncoding.")
 297 (defconst XA-underline-thickness (make-X-Atom :id 52.0 :name "UNDERLINE_THICKNESS") "Atom underline-thickness eoncoding.")
 298 (defconst XA-strikeout-ascent (make-X-Atom :id 53.0 :name "STRIKEOUT_ASCENT") "Atom strikeout-ascent eoncoding.")
 299 (defconst XA-strikeout-descent (make-X-Atom :id 54.0 :name "STRIKEOUT_DESCENT") "Atom strikeout-descent eoncoding.")
 300 (defconst XA-italic-angle (make-X-Atom :id 55.0 :name "ITALIC_ANGLE") "Atom italic-angle eoncoding.")
 301 (defconst XA-x-height (make-X-Atom :id 56.0 :name "X_HEIGHT") "Atom x-height eoncoding.")
 302 (defconst XA-quad-width (make-X-Atom :id 57.0 :name "QUAD_WIDTH") "Atom quad-width eoncoding.")
 303 (defconst XA-weight (make-X-Atom :id 58.0 :name "WEIGHT") "Atom weight eoncoding.")
 304 (defconst XA-point-size (make-X-Atom :id 59.0 :name "POINT_SIZE") "Atom point-size eoncoding.")
 305 (defconst XA-resolution (make-X-Atom :id 60.0 :name "RESOLUTION") "Atom resolution eoncoding.")
 306 (defconst XA-copyright (make-X-Atom :id 61.0 :name "COPYRIGHT") "Atom copyright eoncoding.")
 307 (defconst XA-notice (make-X-Atom :id 62.0 :name "NOTICE") "Atom notice eoncoding.")
 308 (defconst XA-font-name (make-X-Atom :id 63.0 :name "FONT_NAME") "Atom font-name eoncoding.")
 309 (defconst XA-family-name (make-X-Atom :id 64.0 :name "FAMILY_NAME") "Atom family-name eoncoding.")
 310 (defconst XA-full-name (make-X-Atom :id 65.0 :name "FULL_NAME") "Atom full-name eoncoding.")
 311 (defconst XA-cap-height (make-X-Atom :id 66.0 :name "CAP_HEIGHT") "Atom cap-height eoncoding.")
 312 (defconst XA-wm-class (make-X-Atom :id 67.0 :name "WM_CLASS") "Atom wm-class eoncoding.")
 313 (defconst XA-wm-transient-for (make-X-Atom :id 68.0 :name "WM_TRANSIENT_FOR") "Atom wm-transient-for eoncoding.")
 314
 315 \f
 316 ;;; Common predicates
 317 (defsubst X-Win-p (win &optional sig)
 318   "Return non-nil if WIN is X-Win structure.
 319 If SIG is given and WIN is not X-Win structure, SIG will
 320 be signaled."
 321   (X-Generic-p 'X-Win 'X-Win-iswin-p win sig))
 322
 323 (defsubst X-Pixmap-p (pixmap &optional sig)
 324   "Return non-nil if PIXMAP is X-Pixmap structure.
 325 If SIG is given and PIXMAP is not X-Pixmap structure, SIG will be signaled."
 326   (X-Generic-p 'X-Pixmap 'X-Pixmap-ispixmap-p pixmap sig))
 327
 328 (defsubst X-Colormap-p (cmap &optional sig)
 329   "Return non-nil if CMAP is X-Colormap structure.
 330 If SIG is given and CMAP is not X-Colormap structure, SIG will be signaled."
 331   (X-Generic-p 'X-Colormap 'X-Colormap-iscmap-p cmap sig))
 332
 333 (defsubst X-Cursor-p (cursor &optional sig)
 334   (X-Generic-p 'X-Cursor 'X-Cursor-iscursor-p cursor sig))
 335
 336 \f
 337 ;;; Attributes operations
 338 (defstruct (X-Attr (:predicate X-Attr-isattr-p))
 339   ;; any *-pixel is X-Color structure
 340   dpy id
 341   background-pixmap background-pixel
 342   border-pixmap border-pixel
 343   bit-gravity win-gravity
 344   backing-store backing-planes backing-pixel
 345   override-redirect
 346   save-under
 347   event-mask
 348   do-not-propagate-mask
 349   colormap                              ; X-Colormap
 350   cursor                                ; X-Cursor
 351   visualid
 352   mapstate
 353   ;; List of extractors
 354   (list (list
 355          (cons #'(lambda (attr)
 356                    (if (X-Pixmap-p (X-Attr-background-pixmap attr))
 357                        (X-Pixmap-id (X-Attr-background-pixmap attr))
 358                      (X-Attr-background-pixmap attr)))
 359                4)
 360          (cons #'(lambda (attr)
 361                    (if (X-Color-p (X-Attr-background-pixel attr))
 362                        (X-Color-id (X-Attr-background-pixel attr))
 363                      (X-Attr-background-pixel attr)))
 364                4)
 365          (cons #'(lambda (attr)
 366                    (if (X-Pixmap-p (X-Attr-border-pixmap attr))
 367                        (X-Pixmap-id (X-Attr-border-pixmap attr))
 368                      (X-Attr-border-pixmap attr)))
 369                4)
 370          (cons #'(lambda (attr)
 371                    (if (X-Color-p (X-Attr-border-pixel attr))
 372                        (X-Color-id (X-Attr-border-pixel attr))
 373                      (X-Attr-border-pixel attr)))
 374                4)
 375          (cons 'X-Attr-bit-gravity 1)
 376          (cons 'X-Attr-win-gravity 1)
 377          (cons 'X-Attr-backing-store 1)
 378          (cons 'X-Attr-backing-planes 4)
 379          (cons #'(lambda (attr)
 380                    (if (X-Color-p (X-Attr-backing-pixel attr))
 381                        (X-Color-id (X-Attr-backing-pixel attr))
 382                      (X-Attr-backing-pixel attr)))
 383                4)
 384          (cons 'X-Attr-override-redirect 1)
 385          (cons 'X-Attr-save-under 1)
 386          (cons 'X-Attr-event-mask 4)
 387          (cons 'X-Attr-do-not-propagate-mask 4)
 388          (cons #'(lambda (attr)
 389                    (if (X-Colormap-p (X-Attr-colormap attr))
 390                        (X-Colormap-id (X-Attr-colormap attr))
 391                      (X-Attr-colormap attr)))
 392                4)
 393          (cons #'(lambda (attr)
 394                    (if (X-Cursor-p (X-Attr-cursor attr))
 395                        (X-Cursor-id (X-Attr-cursor attr))
 396                      (X-Attr-cursor attr)))
 397                4))))
 398
 399 (defun X-Attr-p (attr &optional sig)
 400   "Return non-nil if ATTR is attributes structure.
 401 If SIG is given and ATTR is not attributes structure, SIG will be signaled."
 402   (let ((isattr (X-Attr-isattr-p attr)))
 403     (if (and (not isattr) sig)
 404         (signal 'wrong-type-argument (list sig 'X-Attr-p attr))
 405       isattr)))
 406
 407 (defun X-Attr-message (attr)
 408   "Return a string representing the attributes ATTR."
 409   (X-Generate-message 'X-Attr attr))
 410
 411 ;;;Configure window structure
 412 ;;
 413 (defstruct (X-Conf (:predicate X-Conf-isconf-p))
 414   dpy id
 415   x y width height
 416   border-width
 417   sibling
 418   stackmode
 419   (list (list
 420          (cons 'X-Conf-x 2)
 421          (cons 'X-Conf-y 2)
 422          (cons 'X-Conf-width 2)
 423          (cons 'X-Conf-height 2)
 424          (cons 'X-Conf-border-width 2)
 425          (cons #'(lambda (conf)
 426                    (if (X-Win-p (X-Conf-sibling conf))
 427                        (X-Win-id (X-Conf-sibling conf))
 428                      (X-Conf-sibling conf)))
 429                4)
 430          (cons 'X-Conf-stackmode 1))))
 431
 432 (defsubst X-Conf-p (conf &optional sig)
 433   "Return non-nil if CONF is X-Conf structure.
 434 If SIG is given and CONF is not X-Conf structure, SIG will be signaled."
 435   (X-Generic-p 'X-Conf 'X-Conf-isconf-p conf sig))
 436
 437 (defun X-Conf-message (conf)
 438   "Return a string representing the configuration CONF."
 439   (X-Generate-message 'X-Conf conf 2))
 440
 441 ;;; Window allocation/testing/setting routines.
 442 (defstruct (X-Win (:predicate X-Win-iswin-p))
 443   dpy id
 444
 445   event-handlers                        ; list of X-EventHandler
 446
 447   plist)                                ; user defined plist
 448
 449 (defun X-Win-invalidate (xdpy win)
 450   "Remove WIN from dpy list and invalidate cl struct."
 451   (add-timeout X-default-timeout
 452                #'(lambda (xdpy-win)
 453                    (setf (X-Dpy-windows (car xdpy-win))
 454                          (delq (cdr xdpy-win) (X-Dpy-windows (car xdpy-win))))
 455                    (X-invalidate-cl-struct (cdr xdpy-win)))
 456                (cons xdpy win)))
 457
 458 ;; Properties list operations
 459 (defsubst X-Win-put-prop (win prop val)
 460   (setf (X-Win-plist win) (plist-put (X-Win-plist win) prop val)))
 461
 462 (defsubst X-Win-get-prop (win prop)
 463   (plist-get (X-Win-plist win) prop))
 464
 465 (defsubst X-Win-rem-prop (win prop)
 466   (setf (X-Win-plist win) (plist-remprop (X-Win-plist win) prop)))
 467
 468 (defsubst X-Win-equal (win1 win2)
 469   "Return non-nil if id's of WIN1 and WIN2 are equal."
 470   (equal (X-Win-id win1) (X-Win-id win2)))
 471
 472 (defsubst X-Win-EventHandler-add (win handler &optional priority evtypes-list)
 473   "To X-Win add events HANDLER.
 474
 475 HANDLER is function which should accept three arguments - xdpy(X-Dpy),
 476 xwin(X-Win) and xev(X-Event).  Only events with type that in
 477 EVTYPES-LIST are passed to HANDLER. By default all events passed.
 478 PRIORITY is place in events handler list, i.e. when HANDLER will be
 479 called. Higher priorities runs first."
 480   (setf (X-Win-event-handlers win)
 481         (X-EventHandler-add (X-Win-event-handlers win) handler priority evtypes-list)))
 482
 483 (defsubst X-Win-EventHandler-isset (win handler &optional priority evtypes-list)
 484   "For WIN's event handlers return X-EventHandler with HANDLER, PRIORITY and EVTYPES-LIST.
 485 If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs.
 486 If event handler not found - nil will be returned."
 487   (X-EventHandler-isset (X-Win-event-handlers win) handler priority evtypes-list))
 488
 489 (defsubst X-Win-EventHandler-add-new (win handler &optional priority evtypes-list)
 490   "To X-Win add events HANDLER, only if no such handler already installed.
 491
 492 HANDLER is function which should accept three arguments - xdpy(X-Dpy),
 493 xwin(X-Win) and xev(X-Event).  Only events with type that in
 494 EVTYPES-LIST are passed to HANDLER. By default all events passed.
 495 PRIORITY is place in events handler list, i.e. when HANDLER will be
 496 called. Higher priorities runs first."
 497   (unless (X-Win-EventHandler-isset win handler priority evtypes-list)
 498     (setf (X-Win-event-handlers win)
 499           (X-EventHandler-add (X-Win-event-handlers win) handler priority evtypes-list))
 500     ))
 501
 502 (defsubst X-Win-EventHandler-rem (win handler &optional priority evtypes-list)
 503   "From WIN's events handlers remove event HANDLER with PRIORITY and EVTYPES-LIST.
 504 If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs."
 505   (setf (X-Win-event-handlers win)
 506         (X-EventHandler-rem (X-Win-event-handlers win) handler priority evtypes-list)))
 507
 508 (defsubst X-Win-EventHandler-enable (win handler &optional priority evtypes-list)
 509   "In WIN's event handlers list mark HANDLER with PRIORITY and EVTYPES-LIST as active."
 510   (X-EventHandler-enable (X-Win-event-handlers win) handler priority evtypes-list))
 511
 512 (defsubst X-Win-EventHandler-disable (win handler &optional priority evtypes-list)
 513   "In WIN's event handlers list mark HANDLER with PRIORITY and EVTYPES-LIST as inactive."
 514   (X-EventHandler-disable (X-Win-event-handlers win) handler priority evtypes-list))
 515
 516 (defsubst X-Win-EventHandler-runall (win xev)
 517   "Run all WIN's event handlers on XEV.
 518 Signal `X-Events-stop' to stop events processing."
 519   (X-EventHandler-runall (X-Win-event-handlers win) xev))
 520
 521 (defun X-Win-find (xdpy wid)
 522   "Find X-Win with id WID on XDPY."
 523   (X-Dpy-p xdpy 'X-Win-find)
 524
 525   (let ((wl (X-Dpy-windows xdpy)))
 526     (while (and wl (not (= (X-Win-id (car wl)) wid)))
 527       (setq wl (cdr wl)))
 528     (car wl)))
 529
 530 (defun X-Win-find-or-make (xdpy wid)
 531   "Find X-Win with id WID on display XDPY, or make new one if not found."
 532   (X-Dpy-p xdpy 'X-Win-find-or-make)
 533
 534   (or (X-Win-find xdpy wid)
 535       (let ((xwin (make-X-Win :dpy xdpy :id wid)))
 536         (X-Dpy-log xdpy 'x-event "XDPY Adding new window: %S" 'wid)
 537         (push xwin (X-Dpy-windows xdpy))
 538         xwin)))
 539
 540 ;;;
 541 (defstruct (X-Pixmap (:predicate X-Pixmap-ispixmap-p))
 542   dpy id d
 543
 544   plist)                                ; User defined plist
 545
 546 (defun X-Pixmap-find-or-make (dpy id)
 547   (make-X-Pixmap :dpy dpy :id id))
 548
 549 ;; Properties list operations
 550 (defsubst X-Pixmap-put-prop (pixmap prop val)
 551   (setf (X-Pixmap-plist pixmap) (plist-put (X-Pixmap-plist pixmap) prop val)))
 552
 553 (defsubst X-Pixmap-get-prop (pixmap prop)
 554   (plist-get (X-Pixmap-plist pixmap) prop))
 555
 556 (defsubst X-Pixmap-rem-prop (pixmap prop)
 557   (setf (X-Pixmap-plist pixmap) (plist-remprop (X-Pixmap-plist pixmap) prop)))
 558
 559 (defsubst X-Pixmap-width (pixmap)
 560   "Return PIXMAP's width."
 561   (X-Pixmap-get-prop pixmap 'width))
 562 (defsetf X-Pixmap-width (pixmap) (nw)
 563   `(X-Pixmap-put-prop ,pixmap 'width ,nw))
 564
 565 (defsubst X-Pixmap-height (pixmap)
 566   "Return PIXMAP's height."
 567   (X-Pixmap-get-prop pixmap 'height))
 568 (defsetf X-Pixmap-height (pixmap) (nh)
 569   `(X-Pixmap-put-prop ,pixmap 'height ,nh))
 570
 571 (defsubst X-Pixmap-depth (pixmap)
 572   "Return PIXMAP's depth."
 573   (X-Pixmap-get-prop pixmap 'depth))
 574 (defsetf X-Pixmap-depth (pixmap) (nd)
 575   `(X-Pixmap-put-prop ,pixmap 'depth ,nd))
 576
 577 ;;;
 578 ;; DRAWABLE stuff.  A drawable is something you can draw to,
 579 ;; therefore, the only fn we need, is a drawable-p function.
 580 ;;
 581 ;; Each time we make a new drawable surface, add that to the list
 582 ;; of checks here!
 583 ;;
 584 (defun X-Drawable-p (d &optional sig)
 585   "Return non-nil if D is drawable.
 586 If SIG, then signal on error."
 587   (let ((isdp (or (X-Win-p d) (X-Pixmap-p d))))
 588     (if (and sig (not isdp))
 589         (signal 'wrong-type-argument (list sig 'X-Drawable-p d))
 590       isdp)))
 591
 592 (defun X-Drawable-id (d)
 593   "Return id of drawable D."
 594   (X-Drawable-p d 'X-Drawable-id)
 595
 596   (if (X-Win-p d)
 597       (X-Win-id d)
 598     (X-Pixmap-id d)))
 599
 600 (defun X-Drawable-dpy (d)
 601   "Return dpy of drawable D."
 602   (X-Drawable-p d 'X-Drawable-dpy)
 603
 604   (if (X-Win-p d)
 605       (X-Win-dpy d)
 606     (X-Pixmap-dpy d)))
 607
 608 ;;; Colormaps
 609 (defstruct (X-Colormap (:predicate X-Colormap-iscmap-p))
 610   dpy id
 611   colors)                               ; list of X-Color [unused]
 612
 613 (defun X-Colormap-lookup-by-rgb (cmap col)
 614   "Lookup color in colormap CMAP by R G B values of X-Color COL."
 615   (let ((cols (X-Colormap-colors cmap)))
 616     (while (and cols
 617                 (not (and (= (X-Color-red col)
 618                              (X-Color-red (car cols)))
 619                           (= (X-Color-green col)
 620                              (X-Color-green (car cols)))
 621                           (= (X-Color-blue col)
 622                              (X-Color-blue (car cols))))))
 623       (setq cols (cdr cols)))
 624
 625     (car cols)))
 626
 627 (defun X-Colormap-lookup-by-name (cmap color-name)
 628   "Lookup in CMAP color cache color named by COLOR-NAME."
 629   (let ((cols (X-Colormap-colors cmap)))
 630     (while (and cols
 631                 (not (and (stringp (X-Color-name (car cols)))
 632                           (string= (X-Color-name (car cols)) color-name))))
 633       (setq cols (cdr cols)))
 634     (car cols)))
 635
 636 (defun X-Colormap-lookup-by-id (cmap id)
 637   "Lookup color in colormap CMAP by ID."
 638   (let ((cols (X-Colormap-colors cmap)))
 639     (while (and cols (not (= id (X-Color-id (car cols)))))
 640       (setq cols (cdr cols)))
 641     (car cols)))
 642
 643 ;;; Color structure
 644 (defstruct (X-Color (:predicate X-Color-iscolor-p))
 645   dpy id
 646   cmap                                  ; back reference to X-Colormap
 647   red green blue                        ; RGB values
 648   name                                  ; non-nil if allocated using `XAllocNamedColor'
 649   flags)
 650
 651 (defun X-Color-p (col &optional sig)
 652   (X-Generic-p 'X-Color 'X-Color-iscolor-p col sig))
 653
 654 (defun X-Color-message (col)
 655   "Convert COL into X request message."
 656   (X-Create-message (list [4 (X-Color-id col)]
 657                           [2 (X-Color-red col)] ; red
 658                           [2 (X-Color-green col)] ; green
 659                           [2 (X-Color-blue col)] ; blue
 660                           [1 (or (X-Color-flags col) X-DoRedGreenBlue)]
 661                           [1 nil])))
 662
 663 ;;; Graphical context structure
 664 ;;
 665 (defstruct (X-Gc (:predicate X-Gc-isgc-p))
 666   dpy id
 667   style
 668   function
 669   plane-mask
 670   foreground                            ; X-Color
 671   background                            ; X-Color
 672   line-width
 673   line-style cap-style join-style fill-style
 674   fill-rule tile stipple
 675   tile-stipple-x-origin tile-stipple-y-origin
 676   font                                  ; X-Font
 677   subwindow-mode
 678   graphics-exposures
 679   clip-x-origin
 680   clip-y-origin
 681   clip-mask
 682   dash-offset dashes
 683   arc-mode
 684   (list (list
 685          (cons 'X-Gc-function 1)
 686          (cons 'X-Gc-plane-mask 4)
 687          (cons #'(lambda (gc)
 688                    (if (X-Color-p (X-Gc-foreground gc))
 689                        (X-Color-id (X-Gc-foreground gc))
 690                      (X-Gc-foreground gc)))
 691                4)
 692          (cons #'(lambda (gc)
 693                    (if (X-Color-p (X-Gc-background gc))
 694                        (X-Color-id (X-Gc-background gc))
 695                      (X-Gc-background gc)))
 696                4)
 697          (cons 'X-Gc-line-width 2)
 698          (cons 'X-Gc-line-style 1)
 699          (cons 'X-Gc-cap-style 1)
 700          (cons 'X-Gc-join-style 1)
 701          (cons 'X-Gc-fill-style 1)
 702          (cons 'X-Gc-fill-rule 1)
 703          (cons 'X-Gc-tile 4)
 704          (cons 'X-Gc-stipple 4)
 705          (cons 'X-Gc-tile-stipple-x-origin 2)
 706          (cons 'X-Gc-tile-stipple-y-origin 2)
 707          (cons #'(lambda (gc)
 708                    (if (X-Font-p (X-Gc-font gc))
 709                        (X-Font-id (X-Gc-font gc))
 710                      (X-Gc-font gc)))
 711                4)
 712          (cons 'X-Gc-subwindow-mode 1)
 713          (cons 'X-Gc-graphics-exposures 1)
 714          (cons 'X-Gc-clip-x-origin 2)
 715          (cons 'X-Gc-clip-y-origin 2)
 716          (cons #'(lambda (gc)
 717                    (if (X-Pixmap-p (X-Gc-clip-mask gc))
 718                        (X-Pixmap-id (X-Gc-clip-mask gc))
 719                      (X-Gc-clip-mask gc)))
 720                4)
 721          (cons 'X-Gc-dash-offset 2)
 722          (cons 'X-Gc-dashes 1)
 723          (cons 'X-Gc-arc-mode 1))))
 724
 725 (defun X-Gc-p (gc &optional sig)
 726   (X-Generic-p 'X-Gc 'X-Gc-isgc-p gc sig))
 727
 728 (defun X-Gc-real-line-width (gc)
 729   "Return real GC's line width.
 730 The thing is that 0 line width is actually 1, but uses hardware
 731 assistance to draw such lines."
 732   (let ((lw (X-Gc-line-width gc)))
 733     (if (zerop lw) 1 lw)))
 734
 735 (defun X-Gc-message (gc)
 736   "Convert GC into message string."
 737   (X-Generate-message 'X-Gc gc))
 738
 739 ;;; Font structure
 740 (defstruct (X-CharInfo (:predicate X-CharInfo-ischarinfo-p))
 741   )
 742
 743 (defstruct (X-Font (:predicate X-Font-isfont-p))
 744   dpy id
 745   name
 746   minb maxb
 747   micob macob
 748   defchar
 749   nprops
 750   dd
 751   minbyte maxbyte
 752   allce
 753   fontascent fontdescent
 754   ncinfo props chinfo)
 755
 756 (defun X-Font-p (font &optional sig)
 757   (X-Generic-p 'X-Font 'X-Font-isfont-p font sig))
 758
 759 (defun X-Font-find (xdpy fid)
 760   "Find font with id FID on X display XDPY."
 761   (X-Dpy-p xdpy 'X-Font-find)
 762
 763   (let ((fl (X-Dpy-fonts xdpy)))
 764     (while (and fl (not (= (X-Font-id (car fl)) fid)))
 765       (setq fl (cdr fl)))
 766     (car fl)))
 767
 768 (defcustom X-use-queryfont t "*Non-nil mean use QueryFont.")
 769
 770 (defun X-Font-get (xdpy fname)
 771   "Get font by its name FNAME on display XDPY."
 772   (X-Dpy-p xdpy 'X-Font-get)
 773
 774   (let ((fl (X-Dpy-fonts xdpy))
 775         rfn)
 776
 777     (while (and fl (not (string= (X-Font-name (car fl)) fname)))
 778       (setq fl (cdr fl)))
 779
 780     (setq rfn (car fl))
 781     (if (X-Font-p rfn)
 782         rfn
 783
 784       ;; Else query X server for font
 785       (setq rfn (make-X-Font :dpy xdpy :id (X-Dpy-get-id xdpy) :name fname))
 786       (XOpenFont xdpy rfn)
 787       (when X-use-queryfont
 788         (unless (XQueryFont xdpy rfn)
 789           (setq rfn nil)))
 790
 791       (when rfn
 792         (pushnew rfn (X-Dpy-fonts xdpy)))
 793       rfn)))
 794
 795 ;; TODO: X-Font-height, X-Font-width, etc
 796 (defun X-Font-heigth (font)
 797   "Return FONT height."
 798   (+ (X-Font-fontascent font)
 799      (X-Font-fontdescent font)))
 800
 801 ;; NOTE: what if chr is '\n', '\t' or such?
 802 (defun X-Font-char-width (chr font)
 803   "Return CHR width for FONT."
 804   (let* ((idx (- (Xforcenum chr) (X-Font-micob font)))
 805          (wi (aref
 806               (if (> (length (X-Font-chinfo font)) idx)
 807                   (aref (X-Font-chinfo font) idx)
 808                 (X-Font-maxb font)) 2)))
 809     wi))
 810
 811 (defun X-Text-ascent (dpy font text &optional font-asc)
 812   "Return overall TEXT's ascent.
 813 If FONT-ASC is non-nil, return FONT's ascent."
 814   (if (not X-use-queryfont)
 815       (let ((qtex (XQueryTextExtents dpy font text)))
 816         (nth (if font-asc 3 5) qtex))
 817     (X-Font-fontascent font)))
 818
 819 (defun X-Text-descent (dpy font text &optional font-desc)
 820   "Return overall TEXT's descent.
 821 If FONT-DESC is non-nil, return FONT's descent."
 822   (if (not X-use-queryfont)
 823       (let ((qtex (XQueryTextExtents dpy font text)))
 824         (nth (if font-desc 4 6) qtex))
 825     (X-Font-fontdescent font)))
 826
 827 (defun X-Text-height (dpy font text)
 828   "Return TEXT height for FONT."
 829   (if (not X-use-queryfont)
 830       (let ((qtex (XQueryTextExtents dpy font text)))
 831         (+ (nth 3 qtex) (nth 4 qtex)))
 832     (X-Font-heigth font)))
 833
 834 (defun X-Text-width (dpy font text)
 835   "Return width of TEXT when it will be displayed in FONT."
 836   (if (not X-use-queryfont)
 837       (nth 7 (XQueryTextExtents dpy font text))
 838
 839     (apply '+ (mapcar #'(lambda (chr)
 840                           (X-Font-char-width chr font))
 841                       text))))
 842
 843 ;;; Fontable stuff
 844 (defun X-Fontable-p (fa &optional sig)
 845   "Return non-nil if FA is fontable object.
 846 If SIG, then signal on error."
 847   (let ((isdp (or (X-Font-p fa) (X-Gc-p fa))))
 848     (if (and sig (not isdp))
 849         (signal 'wrong-type-argument (list sig 'X-Fontable-p fa))
 850       isdp)))
 851
 852 (defun X-Fontable-id (fa)
 853   "Return id of fontable object FA."
 854   (X-Fontable-p fa 'X-Fontable-p)
 855
 856   (if (X-Font-p fa)
 857       (X-Font-id fa)
 858     (X-Gc-id fa)))
 859
 860 (defun X-Fontable-dpy (fa)
 861   "Return dpy of fontable object FA."
 862   (X-Fontable-p fa 'X-Fontable-dpy)
 863
 864   (if (X-Font-p fa)
 865       (X-Font-dpy fa)
 866     (X-Gc-dpy fa)))
 867
 868 ;;; Cursors structure
 869 (defstruct (X-Cursor (:predicate X-Cursor-iscursor-p))
 870   dpy id
 871   source
 872   mask
 873   src-char msk-char
 874   fgred fggreen fgblue
 875   bgred bggreen bgblue
 876
 877   (list (list
 878          (cons #'(lambda (curs)
 879                    (if (X-Font-p (X-Cursor-source curs))
 880                        (X-Font-id (X-Cursor-source curs))
 881                      (X-Cursor-source curs)))
 882                4)
 883          (cons #'(lambda (curs)
 884                    (if (X-Font-p (X-Cursor-mask curs))
 885                        (X-Font-id (X-Cursor-mask curs))
 886                      (X-Cursor-mask curs)))
 887                4)
 888          (cons 'X-Cursor-src-char 2)
 889          (cons 'X-Cursor-msk-char 2)
 890          (cons 'X-Cursor-fgred 2)
 891          (cons 'X-Cursor-fggreen 2)
 892          (cons 'X-Cursor-fgblue 2)
 893          (cons 'X-Cursor-bgred 2)
 894          (cons 'X-Cursor-bggreen 2)
 895          (cons 'X-Cursor-bgblue 2))))
 896
 897 (defun X-Cursor-find-or-make (dpy id)
 898   (make-X-Cursor :dpy dpy :id id))
 899
 900 (defsubst X-Cursor-message (cursor)
 901   "Turn CURSOR into the text of a message."
 902   (X-Generate-simple-message 'X-Cursor cursor))
 903
 904 ;; Hints
 905 (defstruct (X-WMSize (:predicate X-WMSize-issize-p))
 906   flags
 907   x y width height
 908   min-width min-height
 909   max-width max-height
 910   width-inc height-inc
 911   min-aspect-x min-aspect-y
 912   max-aspect-x max-aspect-y
 913   base-width base-height                ; added by ICCCM v1
 914   gravity)
 915
 916 (defsubst X-WMSize-p (wms &optional sig)
 917   (X-Generic-p 'X-WMSize 'X-WMSize-issize-p wms sig))
 918
 919 (defsubst X-WMSize-uspos-p (wms)
 920   "Return non-nil if WMS have user specified x, y."
 921   (Xtest (X-WMSize-flags wms) 1))
 922
 923 (defsubst X-WMSize-ussize-p (wms)
 924   "Return non-nil if WMS have user specified width, height."
 925   (Xtest (X-WMSize-flags wms) 2))
 926
 927 (defsubst X-WMSize-ppos-p (wms)
 928   "Return non-nil if WMS have program specified position."
 929   (Xtest (X-WMSize-flags wms) 4))
 930
 931 (defsubst X-WMSize-psize-p (wms)
 932   "Return non-nil if WMS have program specified size."
 933   (Xtest (X-WMSize-flags wms) 8))
 934
 935 (defsubst X-WMSize-pminsize-p (wms)
 936   "Return non-nil if WMS have program specified minimum size."
 937   (Xtest (X-WMSize-flags wms) 16))
 938
 939 (defsubst X-WMSize-pmaxsize-p (wms)
 940   "Return non-nil if WMS have program specified maximum size."
 941   (Xtest (X-WMSize-flags wms) 32))
 942
 943 (defsubst X-WMSize-presizeinc-p (wms)
 944   "Return non-nil if WMS have program specified resize increments."
 945   (Xtest (X-WMSize-flags wms) 64))
 946
 947 (defsubst X-WMSize-paspect-p (wms)
 948   "Return non-nil if WMS have program specified min and max aspect ratios."
 949   (Xtest (X-WMSize-flags wms) 128))
 950
 951 (defsubst X-WMSize-pbasesize-p (wms)
 952   "Return non-nil if WMS have program specified base for incrementing."
 953   (Xtest (X-WMSize-flags wms) 256))
 954
 955 (defsubst X-WMSize-pgravity-p (wms)
 956   "Return non-nil if WMS have program specified window graivty."
 957   (Xtest (X-WMSize-flags wms) 512))
 958
 959 (defstruct (X-WMHints (:predicate X-WMHints-ishints-p))
 960   flags
 961   input                                 ;does this app rely on the window manager to get keyboard input?
 962   initial-state
 963   icon-pixmap                           ; X-Pixmap
 964   icon-window                           ; X-Win
 965   icon-x icon-y
 966   icon-mask                             ; X-Pixmap
 967   window-group                          ; X-Win id
 968   )
 969
 970 (defsubst X-WMHints-input-p (wmh)
 971   "Return non-nil if WMH have InputHint."
 972   (Xtest (X-WMHints-flags wmh) 1))
 973
 974 (defsubst X-WMHints-state-p (wmh)
 975   "Return non-nil if WMH have StateHint."
 976   (Xtest (X-WMHints-flags wmh) 2))
 977
 978 (defsubst X-WMHints-iconpixmap-p (wmh)
 979   "Return non-nil if WMH have IconPixmapHint."
 980   (Xtest (X-WMHints-flags wmh) 4))
 981
 982 (defsubst X-WMHints-iconwindow-p (wmh)
 983   "Return non-nil if WMH have IconWindowHint."
 984   (Xtest (X-WMHints-flags wmh) 8))
 985
 986 (defsubst X-WMHints-iconpos-p (wmh)
 987   "Return non-nil if WMH have IconPositionHint."
 988   (Xtest (X-WMHints-flags wmh) 16))
 989
 990 (defsubst X-WMHints-iconmask-p (wmh)
 991   "Return non-nil if WMH have IconMaskHint."
 992   (Xtest (X-WMHints-flags wmh) 32))
 993
 994 (defsubst X-WMHints-wingroup-p (wmh)
 995   "Return non-nil if WMH have WindowGroupHint."
 996   (Xtest (X-WMHints-flags wmh) 64))
 997
 998 (defsubst X-WMHints-urgency-p (wmh)
 999   "Return non-nil if WMH have UrgencyHint."
1000   (Xtest (X-WMHints-flags wmh) 256))
1001
1002 ;; Generic functions
1003 (defun X-Generic-struct-p (gstruct)
1004   "Return non-nil if GSTRUCT is generic struct which have id field."
1005   ;; DO NOT USE THIS FUNCTION
1006   (and (vectorp gstruct) (intern (concat (substring (symbol-name (aref gstruct 0)) 10) "-id"))))
1007
1008 (defun X-Generic-p (type pfunc thing &optional sig)
1009   "Returns non-nil if THING is of TYPE, using predicate PFUNC.
1010 If SIG is given, then signal if error."
1011
1012   (let ((isit (funcall pfunc thing)))
1013     (if (and (not isit) sig)
1014         (signal 'wrong-type-argument (list sig type thing))
1015       isit)))
1016
1017 (defun X-Generate-message (type attr &optional bitmask-size)
1018   "Convert the attribute structure ATTR to a string.
1019 The string is the message starting with VALUE_MASK, needed for
1020 variable length requests, and the LISTofVALUE parts, depending if
1021 those parts have been set.
1022 Optional BITMASK-SIZE determines how much space is used by the bitmask
1023 used in the message.  If it is excluded, then it defaults to 4."
1024
1025   (funcall (intern (format "%s-p" type)) attr 'X-Generate-message)
1026
1027   (when (null bitmask-size)
1028     (setq bitmask-size 4))
1029
1030   (let* ((gc-cons-threshold most-positive-fixnum) ; inhibit gc'ing
1031          (m (float 0))                  ; mask o parts
1032          (l (cond ((= bitmask-size 4)   ; the mask o given parts
1033                    (list [4 'm] ))
1034                   ((= bitmask-size 2)
1035                    (list [2 nil]                ; reversed later
1036                          [2 'm] ))
1037                   ((= bitmask-size 0)
1038                    nil)
1039                   (t (error "Unsupported bitmask-size! Update the code."))))
1040          (sal (funcall (intern (format "%s-list" type)) attr)) ; saved attr list
1041          (xal sal)
1042          (tempv nil))                   ;temp vector
1043
1044     (flet ((getval (what)
1045                    (funcall what attr)))
1046       (while xal
1047         (when (or (= bitmask-size 0)
1048                   (getval (caar xal)))
1049           ;; set the value part
1050           (setq l (cons (progn
1051                           (setq tempv (make-vector 2 nil))
1052                           (aset tempv 0 (cdar xal)) ;size
1053                           (aset tempv 1 (getval (caar xal)))
1054                           tempv)
1055                         l))
1056
1057           ;; put in padding if we need it.
1058           ;; put it only if bitmask-size > 0
1059           (when (and (> bitmask-size 0) (< (cdar xal) 4))
1060             (setq l (cons (progn
1061                             (setq tempv (make-vector 2 nil))
1062                             (aset tempv 0 (- 4 (cdar xal)))
1063                             tempv)
1064                           l)))
1065
1066           (setq m (Xmask-or m (Xmask (- (length sal) (length  xal))))))
1067         (setq xal (cdr xal))))
1068
1069     (when (<= bitmask-size 2)
1070       (setq m (truncate m)))
1071
1072     (X-Create-message (reverse l) (= bitmask-size 0))))
1073
1074 (defun X-Generate-simple-message (type struct)
1075   "Same as `X-Generate-message', but does not put value_mask."
1076   (X-Generate-message type struct 0))
1077
1078 (defun X-Generate-message-for-list (structs-list genfun)
1079   "For given list of structures STRUCTS-LIST, generate message using function GENFUNC.
1080 Each element in STRUCTS-LIST is of STRUCT-TYPE."
1081   (mapconcat genfun structs-list ""))
1082
1083 \f
1084 (provide 'xlib-xwin)
1085
1086 ;;; xlib-xwin.el ends here