PageRenderTime 65ms CodeModel.GetById 27ms RepoModel.GetById 0ms app.codeStats 0ms

/modules/clx/new-clx/clx.lisp

https://github.com/ynd/clisp-branch--ynd-devel
Lisp | 1837 lines | 1477 code | 190 blank | 170 comment | 10 complexity | 49fad498f922208ff578919a3346b0c3 MD5 | raw file
Possible License(s): LGPL-2.0, GPL-2.0, BSD-3-Clause

Large files files are truncated, but you can click here to view the full file

    

  1. ;;;; Copyright (C) 1996 by Gilbert Baumann
    2. 

  2. ;;;; Copyright (C) 2001-2007 by Sam Steingold
    3. 

  3. ;;;; Distributed under GPL.
    4. 

  4. ;;;; Some parts are from the MIT-CLX Distribution, copyrighted by
    5. 

  5. ;;;; Texas Instruments Incorporated, but freely distributable
    6. 

  6. ;;;; for details see image.lisp or the MIT-CLX distribution.
    7. 

  7. 

  8. (defpackage #:xlib)
    9. 

  9. 

  10. (provide "clx")
    11. 

  11. 

  12. (in-package :xlib)
    13. 

  13. 

  14. (defvar *displays* nil)
    15. 

  15. (push :clx *features*)
    16. 

  16. (push :clx-ansi-common-lisp *features*)
    17. 

  17. (declaim (declaration values))
    18. 

  18. 

  19. (defconstant *version* "CLISP-CLX 1997-06-12")
    20. 

  20. 

  21. 
    22. 

  22. ;;;; --------------------------------------------------------------------------
    23. 

  23. ;;;;  Exports
    24. 

  24. ;;;; --------------------------------------------------------------------------
    25. 

  25. (export
    26. 

  26.  '(*version* access-control access-error access-hosts activate-screen-saver
    27. 

  27.    add-access-host add-resource add-to-save-set alist alloc-color
    28. 

  28.    alloc-color-cells alloc-color-planes alloc-error allow-events angle
    29. 

  29.    arc-seq array-index atom-error atom-name bell bit-gravity bitmap
    30. 

  30.    bitmap-format bitmap-format-lsb-first-p bitmap-format-p
    31. 

  31.    bitmap-format-pad bitmap-format-unit bitmap-image boole-constant boolean
    32. 

  32.    card16 card29 card32 card8 card8->char change-active-pointer-grab
    33. 

  33.    change-keyboard-control change-keyboard-mapping change-pointer-control
    34. 

  34.    change-property char->card8 char-ascent char-attributes char-descent
    35. 

  35.    char-left-bearing char-right-bearing char-width character->keysyms
    36. 

  36.    character-in-map-p circulate-window-down circulate-window-up clear-area
    37. 

  37.    close-display close-down-mode close-font closed-display color color-blue
    38. 

  38.    color-green color-p color-red color-rgb colormap colormap-display
    39. 

  39.    colormap-equal colormap-error colormap-id colormap-p colormap-plist
    40. 

  40.    colormap-visual-info connection-failure convert-selection copy-area
    41. 

  41.    copy-colormap-and-free copy-gcontext copy-gcontext-components copy-image
    42. 

  42.    copy-plane create-colormap create-cursor create-gcontext
    43. 

  43.    create-glyph-cursor create-image create-pixmap create-window cursor
    44. 

  44.    cursor-display cursor-equal cursor-error cursor-id cursor-p cursor-plist
    45. 

  45.    cut-buffer declare-event decode-core-error default-error-handler
    46. 

  46.    default-keysym-index default-keysym-translate define-error
    47. 

  47.    define-extension define-gcontext-accessor define-keysym
    48. 

  48.    define-keysym-set delete-property delete-resource destroy-subwindows
    49. 

  49.    destroy-window device-busy device-event-mask device-event-mask-class
    50. 

  50.    discard-current-event discard-font-info display display-after-function
    51. 

  51.    display-authorization        ; extension
    52. 

  52.    display-authorization-data display-authorization-name
    53. 

  53.    display-bitmap-format display-byte-order display-default-screen
    54. 

  54.    display-display display-error-handler display-finish-output
    55. 

  55.    display-force-output display-host display-image-lsb-first-p
    56. 

  56.    display-invoke-after-function display-keycode-range display-max-keycode
    57. 

  57.    display-max-request-length display-min-keycode
    58. 

  58.    display-motion-buffer-size display-nscreens display-p
    59. 

  59.    display-pixmap-formats display-plist display-protocol-major-version
    60. 

  60.    display-protocol-minor-version display-protocol-version
    61. 

  61.    display-release-number display-report-asynchronous-errors
    62. 

  62.    display-resource-id-base display-resource-id-mask display-roots
    63. 

  63.    display-vendor display-vendor-name display-xid draw-arc draw-arcs
    64. 

  64.    draw-direction draw-glyph draw-glyphs draw-image-glyph draw-image-glyphs
    65. 

  65.    draw-line draw-lines draw-point draw-points draw-rectangle
    66. 

  66.    draw-rectangles draw-segments drawable drawable-border-width
    67. 

  67.    drawable-depth drawable-display drawable-equal drawable-error
    68. 

  68.    drawable-height drawable-id drawable-p drawable-plist drawable-root
    69. 

  69.    drawable-width drawable-x drawable-y error-key event-case event-cond
    70. 

  70.    event-handler event-key event-listen event-mask event-mask-class
    71. 

  71.    extension-opcode find-atom font font-all-chars-exist-p font-ascent
    72. 

  72.    font-default-char font-descent font-direction font-display font-equal
    73. 

  73.    font-error font-id font-max-byte1 font-max-byte2 font-max-char
    74. 

  74.    font-min-byte1 font-min-byte2 font-min-char font-name font-p font-path
    75. 

  75.    font-plist font-properties font-property fontable force-gcontext-changes
    76. 

  76.    free-colormap free-colors free-cursor free-gcontext free-pixmap gcontext
    77. 

  77.    gcontext-arc-mode gcontext-background gcontext-cache-p
    78. 

  78.    gcontext-cap-style gcontext-clip-mask gcontext-clip-ordering
    79. 

  79.    gcontext-clip-x gcontext-clip-y gcontext-dash-offset gcontext-dashes
    80. 

  80.    gcontext-display gcontext-equal gcontext-error gcontext-exposures
    81. 

  81.    gcontext-fill-rule gcontext-fill-style gcontext-font gcontext-foreground
    82. 

  82.    gcontext-function gcontext-id gcontext-join-style gcontext-key
    83. 

  83.    gcontext-line-style gcontext-line-width gcontext-p gcontext-plane-mask
    84. 

  84.    gcontext-plist gcontext-stipple gcontext-subwindow-mode gcontext-tile
    85. 

  85.    gcontext-ts-x gcontext-ts-y get-external-event-code get-image
    86. 

  86.    get-property get-raw-image get-resource get-search-resource
    87. 

  87.    get-search-table get-standard-colormap get-wm-class
    88. 

  88.    global-pointer-position grab-button grab-key grab-keyboard grab-pointer
    89. 

  89.    grab-server grab-status icon-sizes iconify-window id-choice-error
    90. 

  90.    illegal-request-error image image-blue-mask image-depth image-green-mask
    91. 

  91.    image-height image-name image-pixmap image-plist image-red-mask
    92. 

  92.    image-width image-x image-x-hot image-x-p image-xy image-xy-bitmap-list
    93. 

  93.    image-xy-p image-y-hot image-z image-z-bits-per-pixel image-z-p
    94. 

  94.    image-z-pixarray implementation-error input-focus install-colormap
    95. 

  95.    installed-colormaps int16 int32 int8 intern-atom invalid-font
    96. 

  96.    keyboard-control keyboard-mapping keycode->character keycode->keysym
    97. 

  97.    keysym keysym->character keysym->keycodes keysym-in-map-p keysym-set
    98. 

  98.    kill-client kill-temporary-clients length-error list-extensions
    99. 

  99.    list-font-names list-fonts list-properties lookup-color lookup-error
    100. 

  100.    make-color make-event-handlers make-event-keys make-event-mask
    101. 

  101.    make-resource-database make-state-keys make-state-mask make-wm-hints
    102. 

  102.    make-wm-size-hints map-resource map-subwindows map-window mapping-notify
    103. 

  103.    mask16 mask32 match-error max-char-ascent max-char-attributes
    104. 

  104.    max-char-descent max-char-left-bearing max-char-right-bearing
    105. 

  105.    max-char-width merge-resources min-char-ascent min-char-attributes
    106. 

  106.    min-char-descent min-char-left-bearing min-char-right-bearing
    107. 

  107.    min-char-width missing-parameter modifier-key modifier-mapping
    108. 

  108.    modifier-mask motion-events name-error no-operation open-display
    109. 

  109.    open-font pixarray pixel pixmap pixmap-display pixmap-equal pixmap-error
    110. 

  110.    pixmap-format pixmap-format-bits-per-pixel pixmap-format-depth
    111. 

  111.    pixmap-format-p pixmap-format-scanline-pad pixmap-id pixmap-p
    112. 

  112.    pixmap-plist point-seq pointer-control pointer-event-mask
    113. 

  113.    pointer-event-mask-class pointer-mapping pointer-position process-event
    114. 

  114.    put-image put-raw-image query-best-cursor query-best-stipple
    115. 

  115.    query-best-tile query-colors query-extension query-keymap query-pointer
    116. 

  116.    query-tree queue-event read-bitmap-file read-resources recolor-cursor
    117. 

  117.    rect-seq remove-access-host remove-from-save-set reparent-window
    118. 

  118.    repeat-seq reply-length-error reply-timeout request-error
    119. 

  119.    reset-screen-saver resource-database resource-database-timestamp
    120. 

  120.    resource-error resource-id resource-key rgb-colormaps rgb-val
    121. 

  121.    root-resources rotate-cut-buffers rotate-properties screen
    122. 

  122.    screen-backing-stores screen-black-pixel screen-default-colormap
    123. 

  123.    screen-depths screen-event-mask-at-open screen-height
    124. 

  124.    screen-height-in-millimeters screen-max-installed-maps
    125. 

  125.    screen-min-installed-maps screen-p screen-plist screen-root
    126. 

  126.    screen-root-depth screen-root-visual screen-root-visual-info
    127. 

  127.    screen-save-unders-p screen-saver screen-white-pixel screen-width
    128. 

  128.    screen-width-in-millimeters seg-seq selection-owner set-selection-owner
    129. 

  129.    send-event sequence-error set-input-focus
    130. 

  130.    set-modifier-mapping  set-screen-saver
    131. 

  131.    set-standard-colormap set-standard-properties
    132. 

  132.    set-wm-class set-wm-properties set-wm-resources state-keysym-p
    133. 

  133.    state-mask-key store-color store-colors stringable text-extents
    134. 

  134.    text-width timestamp transient-for translate-coordinates
    135. 

  135.    translate-default translation-function #-cmu type-error undefine-keysym
    136. 

  136.    unexpected-reply ungrab-button ungrab-key ungrab-keyboard ungrab-pointer
    137. 

  137.    ungrab-server uninstall-colormap unknown-error unmap-subwindows
    138. 

  138.    unmap-window value-error visual-info visual-info-bits-per-rgb
    139. 

  139.    visual-info-blue-mask visual-info-class visual-info-colormap-entries
    140. 

  140.    visual-info-display visual-info-green-mask visual-info-id visual-info-p
    141. 

  141.    visual-info-plist visual-info-red-mask warp-pointer
    142. 

  142.    warp-pointer-if-inside warp-pointer-relative
    143. 

  143.    warp-pointer-relative-if-inside win-gravity window
    144. 

  144.    window-all-event-masks window-background window-backing-pixel
    145. 

  145.    window-backing-planes window-backing-store window-bit-gravity
    146. 

  146.    window-border window-class window-colormap window-colormap-installed-p
    147. 

  147.    window-cursor window-display window-do-not-propagate-mask window-equal
    148. 

  148.    window-error window-event-mask window-gravity window-id window-map-state
    149. 

  149.    window-override-redirect window-p window-plist window-priority
    150. 

  150.    window-save-under window-visual window-visual-info with-display
    151. 

  151.    with-event-queue with-gcontext with-server-grabbed with-state
    152. 

  152.    withdraw-window wm-client-machine wm-colormap-windows wm-command
    153. 

  153.    wm-hints wm-hints-flags wm-hints-icon-mask wm-hints-icon-pixmap
    154. 

  154.    wm-hints-icon-window wm-hints-icon-x wm-hints-icon-y
    155. 

  155.    wm-hints-initial-state wm-hints-input wm-hints-p wm-hints-window-group
    156. 

  156.    wm-icon-name wm-name wm-normal-hints wm-protocols wm-resources
    157. 

  157.    wm-size-hints wm-size-hints-base-height wm-size-hints-base-width
    158. 

  158.    wm-size-hints-height wm-size-hints-height-inc wm-size-hints-max-aspect
    159. 

  159.    wm-size-hints-max-height wm-size-hints-max-width
    160. 

  160.    wm-size-hints-min-aspect wm-size-hints-min-height
    161. 

  161.    wm-size-hints-min-width wm-size-hints-p
    162. 

  162.    wm-size-hints-user-specified-position-p
    163. 

  163.    wm-size-hints-user-specified-size-p wm-size-hints-width
    164. 

  164.    wm-size-hints-width-inc wm-size-hints-win-gravity wm-size-hints-x
    165. 

  165.    wm-size-hints-y wm-zoom-hints write-bitmap-file write-resources xatom
    166. 

  166.    x-error
    167. 

  167.    keysym-name
    168. 

  168.    trace-display suspend-display-tracing resume-display-tracing
    169. 

  169.    untrace-display show-trace
    170. 

  170.    display-trace ; for backwards compatibility describe-request describe-event describe-reply
    171. 

  171.    closed-display-p
    172. 

  172.    ;; extensions
    173. 

  173.    open-default-display
    174. 

  174.    ;; display-xdefaults resource-database-to-string resource-database-of-string
    175. 

  175.    ;; resource-database-locale
    176. 

  176.    ;; not implemented
    177. 

  177.    describe-error describe-trace))
    178. 

  178. 

  179. ;;; SHAPE extension
    180. 

  180. (export '(shape-version shape-combine shape-offset shape-extents shape-rectangles))
    181. 

    182. 

  182. 
    183. 

  183. ;;;; --------------------------------------------------------------------------
    184. 

  184. ;;;;  Types
    185. 

  185. ;;;; --------------------------------------------------------------------------
    186. 

  186. ;;;;
    187. 

  187. ;;;; Lots of deftypes randomly gathered from MIT-CLX implementation
    188. 

  188. ;;;;
    189. 

  189. 

  190. (deftype card4 ()       '(unsigned-byte 4))    ;not exported
    191. 

  191. (deftype card8 ()       '(unsigned-byte 8))
    192. 

  192. (deftype card16 ()      '(unsigned-byte 16))
    193. 

  193. (deftype card24 ()      '(unsigned-byte 24))   ;not exported
    194. 

  194. (deftype card29 ()      '(unsigned-byte 29))
    195. 

  195. (deftype card32 ()      '(unsigned-byte 32))
    196. 

    197. 

  197. (deftype int8 ()        '(signed-byte 8))
    198. 

  198. (deftype int16 ()       '(signed-byte 16))
    199. 

  199. (deftype int32 ()       '(signed-byte 32))
    200. 

    201. 

  201. (deftype rgb-val ()     '(real 0 1))
    202. 

  202. (deftype stringable ()  '(or string symbol))
    203. 

  203. (deftype fontable ()    '(or stringable font))
    204. 

    205. 

  205. (deftype array-index () `(integer 0 ,array-dimension-limit))
    206. 

    207. 

  207. (deftype angle ()       '(real #.(* -2 pi) #.(* 2 pi)))
    208. 

  208. (deftype mask32 ()      'card32)
    209. 

  209. (deftype mask16 ()      'card16)
    210. 

  210. (deftype pixel ()       '(unsigned-byte 32))
    211. 

  211. (deftype image-depth () '(integer 0 32))
    212. 

  212. (deftype resource-id () 'card29)
    213. 

  213. (deftype keysym ()      'card32)
    214. 

    215. 

  215. (deftype alist (key-type-and-name datum-type-and-name)
    216. 

  216.   (declare (ignore key-type-and-name datum-type-and-name))
    217. 

  217.   'list)
    218. 

    219. 

  219. (deftype repeat-seq (&rest elts) elts 'sequence)
    220. 

  220. (deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
    221. 

  221. (deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
    222. 

  222. (deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
    223. 

  223. (deftype arc-seq ()
    224. 

  224.   '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
    225. 

  225.                (angle angle1) (angle angle2)))
    226. 

    227. 

  227. (deftype timestamp () '(or null card32))
    228. 

  228. (deftype bit-gravity () '(member :forget :north-west :north :north-east :west :center :east :south-west :south :south-east :static))
    229. 

    230. 

  230. (deftype boole-constant ()
    231. 

  231.   `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
    232. 

  232.            ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior
    233. 

  233.            ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2
    234. 

  234.            ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set))
    235. 

  235. 

  236. (deftype device-event-mask ()
    237. 

  237.   '(or mask32 list)) ;;  '(or integer (list device-event-mask-class)))
    238. 

  238. 

  239. (deftype device-event-mask-class ()
    240. 

  240.   '(member :key-press :key-release :button-press :button-release :pointer-motion
    241. 

  241.            :button-1-motion :button-2-motion :button-3-motion :button-4-motion
    242. 

  242.            :button-5-motion :button-motion))
    243. 

  243. 

  244. (deftype draw-direction ()
    245. 

  245.   '(member :left-to-right :right-to-left))
    246. 

    247. 

  247. (deftype error-key ()
    248. 

  248.   '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
    249. 

  249.            :illegal-request :implementation :length :match :name :pixmap :value :window))
    250. 

  250. 

  251. (deftype gcontext-key ()
    252. 

  252.   '(member :function :plane-mask :foreground :background
    253. 

  253.            :line-width :line-style :cap-style :join-style :fill-style
    254. 

  254.            :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
    255. 

  255.            :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
    256. 

  256.            :arc-mode))
    257. 

  257. 

  258. (deftype event-key ()
    259. 

  259.   '(member :key-press :key-release :button-press :button-release :motion-notify
    260. 

  260.            :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
    261. 

  261.            :exposure :graphics-exposure :no-exposure :visibility-notify
    262. 

  262.            :create-notify :destroy-notify :unmap-notify :map-notify :map-request
    263. 

  263.            :reparent-notify :configure-notify :gravity-notify :resize-request
    264. 

  264.            :configure-request :circulate-notify :circulate-request :property-notify
    265. 

  265.            :selection-clear :selection-request :selection-notify
    266. 

  266.            :colormap-notify :client-message :mapping-notify))
    267. 

  267. 

  268. (deftype event-mask-class ()
    269. 

  269.   '(member :key-press :key-release :owner-grab-button :button-press :button-release
    270. 

  270.            :enter-window :leave-window :pointer-motion :pointer-motion-hint
    271. 

  271.            :button-1-motion :button-2-motion :button-3-motion :button-4-motion
    272. 

  272.            :button-5-motion :button-motion :exposure :visibility-change
    273. 

  273.            :structure-notify :resize-redirect :substructure-notify :substructure-redirect
    274. 

  274.            :focus-change :property-change :colormap-change :keymap-state))
    275. 

  275. 

  276. (deftype event-mask ()
    277. 

  277.   '(or mask32 list)) ;; (OR integer (LIST event-mask-class))
    278. 

    279. 

  279. (deftype grab-status ()
    280. 

  280.   '(member :success :already-grabbed :invalid-time :not-viewable))
    281. 

    282. 

  282. (deftype modifier-key ()
    283. 

  283.   '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
    284. 

    285. 

  285. (deftype modifier-mask ()
    286. 

  286.   '(or (member :any) mask16 list)) ;;  '(or (member :any) integer (list modifier-key)))
    287. 

  287. 

  288. (deftype state-mask-key ()
    289. 

  289.   '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
    290. 

    291. 

  291. (deftype translation-function ()
    292. 

  292.   '(function (sequence array-index array-index (or null font) vector array-index)
    293. 

  293.              (values array-index (or null int16 font) (or null int32))))
    294. 

  294. 

  295. (deftype win-gravity ()
    296. 

  296.   '(member :unmap :north-west :north :north-east :west :center :east :south-west :south :south-east :static))
    297. 

    298. 

  298. (deftype xatom () '(or string symbol))
    299. 

    300. 

  300. (deftype pointer-event-mask-class ()
    301. 

  301.   '(member :button-press :button-release
    302. 

  302.            :enter-window :leave-window :pointer-motion :pointer-motion-hint
    303. 

  303.            :button-1-motion :button-2-motion :button-3-motion :button-4-motion
    304. 

  304.            :button-5-motion :button-motion :keymap-state))
    305. 

  305. 

  306. (deftype pointer-event-mask ()
    307. 

  307.   '(or mask32 list)) ;;  '(or integer (list pointer-event-mask-class)))
    308. 

  308. 

  309. 

  310. ;; ***************************************************************************
    311. 

  311. ;; ****************************** C A U T I O N ******************************
    312. 

  312. ;; ***************************************************************************
    313. 

  313. ;;   THE LAYOUT OF THESE STRUCTURE DEFINITIONS HAS TO BE IN SYNC WITH CLX.D
    314. 

  314. ;; ***************************************************************************
    315. 

  315. 

  316. (defstruct bitmap-format unit pad lsb-first-p)
    317. 

  317. (defstruct pixmap-format depth bits-per-pixel scanline-pad)
    318. 

  318. 

  319. (defstruct (color (:constructor make-color-internal (red green blue))
    320. 

  320.                   (:copier nil))
    321. 

  321.   ;; Short floats are good enough (no consing)
    322. 

  322.   (red   0.0s0 :type rgb-val)
    323. 

  323.   (green 0.0s0 :type rgb-val)
    324. 

  324.   (blue  0.0s0 :type rgb-val))
    325. 

  325. 

  326. (defstruct (visual-info (:copier nil))
    327. 

  327.   id
    328. 

  328.   class
    329. 

  329.   red-mask green-mask blue-mask
    330. 

  330.   bits-per-rgb
    331. 

  331.   colormap-entries
    332. 

  332.   ;; There appears also a plist and a display slot in the MIT-CLX,
    333. 

  333.   ;; but not in the manual!
    334. 

  334.   ;; With what should we be compatible?!
    335. 

  335.   ;; plist display
    336. 

  336.   )
    337. 

  337. 

  338. (defstruct (display (:predicate nil)
    339. 

  339.                     (:constructor nil)
    340. 

  340.                     (:copier nil)
    341. 

  341.                     (:conc-name %display-))
    342. 

  342.   foreign-pointer ;; these two slots are for use in clx.d only.
    343. 

  343.   hash-table      ;; .. so keep hands off here!
    344. 

  344.   plist
    345. 

  345.   after-function
    346. 

  346.   error-handler
    347. 

  347.   display)
    348. 

  348. 

  349. ;; (defstruct (resource-database (:constructor %make-rdb (foreign-pointer)))
    350. 

  350. ;;   (foreign-pointer nil :read-only t))
    351. 

  351. ;; (defstruct (search-table (:constructor %make-search-table (foreign-pointer)))
    352. 

  352. ;;   (foreign-pointer nil :read-only t))
    353. 

  353. 

  354. ;; ***************************************************************************
    355. 

  355. ;; ... CAUTION ending here (resume careless coding)
    356. 

  356. ;; ***************************************************************************
    357. 

  357. 

  358. ;; (eval-when (:compile-toplevel)
    359. 

  359. ;;   (defpackage #:posix (:export #:mkstemp)))
    360. 

  360. ;; (defun resource-database-to-string (rdb)
    361. 

  361. ;;   (let ((tmp-file (posix:mkstemp "/tmp/rdb")))
    362. 

  362. ;;     (close tmp-file)
    363. 

  363. ;;     (write-resources rdb tmp-file)
    364. 

  364. ;;     (unwind-protect
    365. 

  365. ;;         (with-open-file (in tmp-file)
    366. 

  366. ;;           (let ((st (make-string (file-length in))))
    367. 

  367. ;;             (read-sequence st in)
    368. 

  368. ;;             st))
    369. 

  369. ;;       (delete-file tmp-file))))
    370. 

  370. 

  371. (defun make-color (&key (red 1.0s0) (green 1.0s0) (blue 1.0s0)
    372. 

  372.                    &allow-other-keys)
    373. 

  373.   (make-color-internal red green blue))
    374. 

  374. 

  375. (defun color-rgb (color)
    376. 

  376.   (values (color-red color) (color-green color) (color-blue color)))
    377. 

  377. 

  378. (defclass xlib-object ()
    379. 

  379.   ((plist :initarg :plist :initform nil)
    380. 

  380.    (display :initarg :display)))
    381. 

  381. 

  382. (defclass xid-object  (xlib-object)           ((id  :initarg :id)))
    383. 

  383. (defclass ptr-object  (xlib-object)           ((ptr :initarg :ptr)))
    384. 

  384. 

  385. (defclass drawable    (xid-object)            ())
    386. 

  386. (defclass window      (drawable)              ())
    387. 

  387. (defclass pixmap      (drawable)              ())
    388. 

  388. (defclass cursor      (xid-object)            ())
    389. 

  389. (defclass colormap    (xid-object)            (#|(visual-info :initarg :visual-info :accessor colormap-visual-info)|#))
    390. 

  390. (defclass gcontext    (ptr-object)            ((%dashes) (%clip-mask) (%timestamp :accessor gcontext-internal-timestamp :initform 0)))
    391. 

  391. (defclass screen      (ptr-object)            ())
    392. 

  392. (defclass font        (xid-object)
    393. 

  393.   ((font-info :initform nil :initarg :font-info)
    394. 

  394.    (name :initarg :name)
    395. 

  395.    (encoding :initform nil :initarg :encoding)))
    396. 

  396. 

  397. 

  398. 
    399. 

  399. ;;;; --------------------------------------------------------------------------
    400. 

  400. ;;;;  Setf Methods
    401. 

  401. ;;;; --------------------------------------------------------------------------
    402. 

  402. (defsetf ACCESS-CONTROL               SET-ACCESS-CONTROL)
    403. 

  403. (defsetf CLOSE-DOWN-MODE (display) (mode)
    404. 

  404.   `(SET-CLOSE-DOWN-MODE ,mode ,display))
    405. 

  405. (defsetf DISPLAY-AFTER-FUNCTION       SET-DISPLAY-AFTER-FUNCTION)
    406. 

  406. (defsetf DISPLAY-ERROR-HANDLER        SET-DISPLAY-ERROR-HANDLER)
    407. 

  407. (defsetf DISPLAY-PLIST                SET-DISPLAY-PLIST)
    408. 

  408. (defsetf DISPLAY-DEFAULT-SCREEN       SET-DISPLAY-DEFAULT-SCREEN)
    409. 

  409. (defsetf DISPLAY-XDEFAULTS            SET-DISPLAY-XDEFAULTS)
    410. 

  410. (defsetf DRAWABLE-BORDER-WIDTH        SET-DRAWABLE-BORDER-WIDTH)
    411. 

  411. (defsetf DRAWABLE-HEIGHT              SET-DRAWABLE-HEIGHT)
    412. 

  412. (defsetf DRAWABLE-PLIST               SET-DRAWABLE-PLIST)
    413. 

  413. (defsetf DRAWABLE-WIDTH               SET-DRAWABLE-WIDTH)
    414. 

  414. (defsetf DRAWABLE-X                   SET-DRAWABLE-X)
    415. 

  415. (defsetf DRAWABLE-Y                   SET-DRAWABLE-Y)
    416. 

  416. (defsetf FONT-PATH                    SET-FONT-PATH)
    417. 

  417. (defsetf FONT-PLIST                   SET-FONT-PLIST)
    418. 

  418. (defsetf GCONTEXT-ARC-MODE            SET-GCONTEXT-ARC-MODE)
    419. 

  419. (defsetf GCONTEXT-BACKGROUND          SET-GCONTEXT-BACKGROUND)
    420. 

  420. (defsetf GCONTEXT-CACHE-P             SET-GCONTEXT-CACHE-P)
    421. 

  421. (defsetf GCONTEXT-CAP-STYLE           SET-GCONTEXT-CAP-STYLE)
    422. 

  422. (defsetf GCONTEXT-CLIP-MASK (gcontext &optional ordering) (clip-mask)
    423. 

  423.   `(SET-GCONTEXT-CLIP-MASK ,clip-mask ,gcontext ,ordering))
    424. 

  424. (defsetf GCONTEXT-CLIP-X              SET-GCONTEXT-CLIP-X)
    425. 

  425. (defsetf GCONTEXT-CLIP-Y              SET-GCONTEXT-CLIP-Y)
    426. 

  426. (defsetf GCONTEXT-DASH-OFFSET         SET-GCONTEXT-DASH-OFFSET)
    427. 

  427. (defsetf GCONTEXT-DASHES              SET-GCONTEXT-DASHES)
    428. 

  428. (defsetf GCONTEXT-EXPOSURES           SET-GCONTEXT-EXPOSURES)
    429. 

  429. (defsetf GCONTEXT-FILL-RULE           SET-GCONTEXT-FILL-RULE)
    430. 

  430. (defsetf GCONTEXT-FILL-STYLE          SET-GCONTEXT-FILL-STYLE)
    431. 

  431. (defsetf GCONTEXT-FONT (gcontext &optional pseudo-font-p) (font)
    432. 

  432.   `(SET-GCONTEXT-FONT ,font ,gcontext ,pseudo-font-p))
    433. 

  433. (defsetf GCONTEXT-FOREGROUND          SET-GCONTEXT-FOREGROUND)
    434. 

  434. (defsetf GCONTEXT-FUNCTION            SET-GCONTEXT-FUNCTION)
    435. 

  435. (defsetf GCONTEXT-JOIN-STYLE          SET-GCONTEXT-JOIN-STYLE)
    436. 

  436. (defsetf GCONTEXT-LINE-STYLE          SET-GCONTEXT-LINE-STYLE)
    437. 

  437. (defsetf GCONTEXT-LINE-WIDTH          SET-GCONTEXT-LINE-WIDTH)
    438. 

  438. (defsetf GCONTEXT-PLANE-MASK          SET-GCONTEXT-PLANE-MASK)
    439. 

  439. (defsetf GCONTEXT-PLIST               SET-GCONTEXT-PLIST)
    440. 

  440. (defsetf GCONTEXT-STIPPLE             SET-GCONTEXT-STIPPLE)
    441. 

  441. (defsetf GCONTEXT-SUBWINDOW-MODE      SET-GCONTEXT-SUBWINDOW-MODE)
    442. 

  442. (defsetf GCONTEXT-TILE                SET-GCONTEXT-TILE)
    443. 

  443. (defsetf GCONTEXT-TS-X                SET-GCONTEXT-TS-X)
    444. 

  444. (defsetf GCONTEXT-TS-Y                SET-GCONTEXT-TS-Y)
    445. 

  445. (defsetf PIXMAP-PLIST                 SET-PIXMAP-PLIST)
    446. 

  446. (defsetf POINTER-MAPPING              SET-POINTER-MAPPING)
    447. 

  447. (defsetf SCREEN-PLIST                 SET-SCREEN-PLIST)
    448. 

  448. (defsetf SELECTION-OWNER (display selection &optional time) (owner)
    449. 

  449.   `(SET-SELECTION-OWNER ,display ,selection ,owner ,time))
    450. 

  450. (defsetf WINDOW-BACKGROUND            SET-WINDOW-BACKGROUND)
    451. 

  451. (defsetf WINDOW-BACKING-PIXEL         SET-WINDOW-BACKING-PIXEL)
    452. 

  452. (defsetf WINDOW-BACKING-PLANES        SET-WINDOW-BACKING-PLANES)
    453. 

  453. (defsetf WINDOW-BACKING-STORE         SET-WINDOW-BACKING-STORE)
    454. 

  454. (defsetf WINDOW-COLORMAP              SET-WINDOW-COLORMAP)
    455. 

  455. (defsetf WINDOW-CURSOR                SET-WINDOW-CURSOR)
    456. 

  456. (defsetf WINDOW-BIT-GRAVITY           SET-WINDOW-BIT-GRAVITY)
    457. 

  457. (defsetf WINDOW-BORDER                SET-WINDOW-BORDER)
    458. 

  458. (defsetf WINDOW-EVENT-MASK            SET-WINDOW-EVENT-MASK)
    459. 

  459. (defsetf WINDOW-GRAVITY               SET-WINDOW-GRAVITY)
    460. 

  460. (defsetf WINDOW-DO-NOT-PROPAGATE-MASK SET-WINDOW-DO-NOT-PROPAGATE-MASK)
    461. 

  461. (defsetf WINDOW-OVERRIDE-REDIRECT     SET-WINDOW-OVERRIDE-REDIRECT)
    462. 

  462. (defsetf WINDOW-PLIST                 SET-WINDOW-PLIST)
    463. 

  463. (defsetf WINDOW-PRIORITY (window &optional sibling) (mode)
    464. 

  464.   `(SET-WINDOW-PRIORITY ,mode ,window ,sibling))
    465. 

  465. (defsetf WINDOW-SAVE-UNDER            SET-WINDOW-SAVE-UNDER)
    466. 

    467. 

  467. ;; for CLUE
    468. 

  468. (defsetf GCONTEXT-DISPLAY SET-GCONTEXT-DISPLAY)
    469. 

    470. 

  470. 
    471. 

  471. ;;;; --------------------------------------------------------------------------
    472. 

  472. ;;;;  Macros
    473. 

  473. ;;;; --------------------------------------------------------------------------
    474. 

    475. 

  475. (defmacro EVENT-COND ((display &key timeout peek-p discard-p (force-output-p t))
    476. 

  476.                       &body clauses)
    477. 

  477.   (let ((slots (gensym)))
    478. 

  478.     ;; FIXME this implementation is not 100%
    479. 

  479.     `(process-event ,display
    480. 

  480.        :timeout ,timeout
    481. 

  481.        :peek-p ,peek-p
    482. 

  482.        :discard-p ,discard-p
    483. 

  483.        :force-output-p ,force-output-p
    484. 

  484.        :handler
    485. 

  485.        (lambda (&rest ,slots &key event-key &allow-other-keys)
    486. 

  486.          ;; (print slots)
    487. 

  487.          (cond ,@(mapcar
    488. 

  488.                   (lambda (clause)
    489. 

  489.                     (let ((event-or-events (car clause))
    490. 

  490.                           (binding-list (cadr clause))
    491. 

  491.                           (test-form (caddr clause))
    492. 

  492.                           (body-forms (cdddr clause)))
    493. 

  493.                       (cond ((member event-or-events '(t otherwise))
    494. 

  494.                              ;;Special case
    495. 

  495.                              `((and t
    496. 

  496.                                     ,@(if test-form
    497. 

  497.                                           (list `(apply #'(lambda (&key ,@binding-list &allow-other-keys) ,test-form) ,slots))
    498. 

  498.                                           nil))
    499. 

  499.                                ,@(if body-forms
    500. 

  500.                                      (list `(apply (lambda (&key ,@binding-list &allow-other-keys)
    501. 

  501.                                                      ,@body-forms)
    502. 

  502.                                                    ,slots))
    503. 

  503.                                      nil)))
    504. 

  504.                             (t ;; Make-up keywords from the event-keys
    505. 

  505.                              (unless (listp event-or-events)
    506. 

  506.                                (setq event-or-events (list event-or-events)))
    507. 

  507.                              (setq event-or-events
    508. 

  508.                                    (mapcar #'kintern event-or-events))
    509. 

  509.                              `((and ,(if (cdr event-or-events)
    510. 

  510.                                          `(member event-key ',event-or-events)
    511. 

  511.                                          `(eq event-key ',(car event-or-events)))
    512. 

  512.                                     ,@(if test-form
    513. 

  513.                                           (list `(apply #'(lambda (&key ,@binding-list &allow-other-keys) ,test-form) ,slots))
    514. 

  514.                                           nil))
    515. 

  515.                                ,@(if body-forms
    516. 

  516.                                      (list `(apply #'(lambda (&key ,@binding-list &allow-other-keys)
    517. 

  517.                                                        ,@body-forms)
    518. 

  518.                                                    ,slots))
    519. 

  519.                                      nil))))))
    520. 

  520.                   clauses))))))
    521. 

  521. 

  522. (defmacro EVENT-CASE ((&rest args) &body clauses)
    523. 

  523.   ;; Event-case is just event-cond with the whole body in the test-form
    524. 

  524.   `(event-cond ,args
    525. 

  525.                ,@(mapcar
    526. 

  526.                    #'(lambda (clause)
    527. 

  527.                        `(,(car clause) ,(cadr clause) (progn ,@(cddr clause))))
    528. 

  528.                    clauses)))
    529. 

  529. 

  530. (defmacro WITH-STATE ((drawable) &body body)
    531. 

  531.   `(progn ,drawable ,@body))
    532. 

    533. 

  533. (defmacro WITH-EVENT-QUEUE ((display) &body body)
    534. 

  534.   `(progn ,display ,@body))
    535. 

  535. 

  536. (defmacro WITH-GCONTEXT ((gcontext &rest options) &body body)
    537. 

  537.   (let ((saved (gensym)) (gcon (gensym)) (g0 (gensym)) (g1 (gensym))
    538. 

  538.         (comps 0)
    539. 

  539.         (setf-forms nil)
    540. 

  540.         dashes? clip-mask?)
    541. 

  541.     (do ((q options (cddr q)))
    542. 

  542.         ((null q))
    543. 

  543.         (cond ((eq (car q) :dashes)    (setf dashes? t))
    544. 

  544.               ((eq (car q) :clip-mask) (setf clip-mask? t)))
    545. 

  545.         (setf comps      (logior comps (%gcontext-key->mask (car q)))
    546. 

  546.               setf-forms (nconc setf-forms
    547. 

  547.                                 (list (list (find-symbol (string-concat "GCONTEXT-" (symbol-name (car q))) :xlib)
    548. 

  548.                                             gcon)
    549. 

  549.                                       (cadr q)))) )
    550. 

  550.     `(LET* ((,gcon ,gcontext)
    551. 

  551.             (,saved (%SAVE-GCONTEXT-COMPONENTS ,gcon ,comps))
    552. 

  552.             ,@(if dashes?    (list `(,g0 (GCONTEXT-DASHES    ,gcon))))
    553. 

  553.             ,@(if clip-mask? (list `(,g1 (GCONTEXT-CLIP-MASK ,gcon)))) )
    554. 

  554.        (UNWIND-PROTECT
    555. 

  555.            (PROGN
    556. 

  556.              (SETF ,@setf-forms)
    557. 

  557.              ,@body)
    558. 

  558.          (PROGN
    559. 

  559.            (%RESTORE-GCONTEXT-COMPONENTS ,gcon ,saved)
    560. 

  560.            ,@(if dashes?    (list `(SETF (GCONTEXT-DASHES ,gcon) ,g0)) )
    561. 

  561.            ,@(if clip-mask? (list `(SETF (GCONTEXT-CLIP-MASK ,gcon) ,g1)) )))) ))
    562. 

    563. 

  563. (defmacro WITH-SERVER-GRABBED ((display) &body body)
    564. 

  564.   ;; The body is not surrounded by a with-display.
    565. 

  565.   (let ((disp (if (symbolp display) display (gensym))))
    566. 

  566.     `(let ((,disp ,display))
    567. 

  567.        (declare (type display ,disp))
    568. 

  568.        (unwind-protect
    569. 

  569.            (progn
    570. 

  570.              (grab-server ,disp)
    571. 

  571.              ,@body)
    572. 

  572.          (ungrab-server ,disp)))))
    573. 

  573. 

  574. 
    575. 

  575. ;;;; --------------------------------------------------------------------------
    576. 

  576. ;;;;  Window Manager Property functions
    577. 

  577. ;;;; --------------------------------------------------------------------------
    578. 

  578. 

  579. (defun wm-name (window)
    580. 

  580.   (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char))
    581. 

  581. 

  582. (defsetf wm-name (window) (name)
    583. 

  583.   `(set-string-property ,window :WM_NAME ,name))
    584. 

    585. 

  585. (defun set-string-property (window property string)
    586. 

  586.   (change-property window property (string string) :STRING 8 :transform #'char->card8)
    587. 

  587.   string)
    588. 

    589. 

  589. (defun wm-icon-name (window)
    590. 

  590.   (get-property window :WM_ICON_NAME :type :STRING
    591. 

  591.                 :result-type 'string :transform #'card8->char))
    592. 

    593. 

  593. (defsetf wm-icon-name (window) (name)
    594. 

  594.   `(set-string-property ,window :WM_ICON_NAME ,name))
    595. 

  595. 

  596. (defun wm-client-machine (window)
    597. 

  597.   (get-property window :WM_CLIENT_MACHINE :type :STRING :result-type 'string :transform #'card8->char))
    598. 

  598. 

  599. (defsetf wm-client-machine (window) (name)
    600. 

  600.   `(set-string-property ,window :WM_CLIENT_MACHINE ,name))
    601. 

    602. 

  602. (defun get-wm-class (window)
    603. 

  603.   (let ((value (get-property window :WM_CLASS :type :STRING :result-type 'string :transform #'card8->char)))
    604. 

  604.     (when value
    605. 

  605.       (let* ((name-len (position (load-time-value (card8->char 0)) (the string value)))
    606. 

  606.              (name (subseq (the string value) 0 name-len))
    607. 

  607.              (class (subseq (the string value) (1+ name-len) (1- (length value)))))
    608. 

  608.         (values (and (plusp (length name)) name)
    609. 

  609.                 (and (plusp (length class)) class))))))
    610. 

    611. 

  611. (defun set-wm-class (window resource-name resource-class)
    612. 

  612.   (set-string-property window :WM_CLASS
    613. 

  613.                        (string-concat
    614. 

  614.                         (string (or resource-name ""))
    615. 

  615.                         (load-time-value
    616. 

  616.                          (make-string 1 :initial-element (card8->char 0)))
    617. 

  617.                         (string (or resource-class ""))
    618. 

  618.                         (load-time-value
    619. 

  619.                          (make-string 1 :initial-element (card8->char 0)))))
    620. 

  620.   (values))
    621. 

    622. 

  622. (defun wm-command (window)
    623. 

  623.   ;; Returns a list whose car is the command and
    624. 

  624.   ;; whose cdr is the list of arguments
    625. 

  625.   (do* ((command-string (get-property window :WM_COMMAND :type :STRING
    626. 

  626.                                       :result-type 'string :transform #'card8->char))
    627. 

  627.         (command nil)
    628. 

  628.         (start 0 (1+ end))
    629. 

  629.         (end 0)
    630. 

  630.         (len (length command-string)))
    631. 

  631.        ((>= start len) (nreverse command))
    632. 

  632.     (setq end (position (load-time-value (card8->char 0)) command-string :start start))
    633. 

  633.     (push (subseq command-string start end) command)))
    634. 

    635. 

  635. (defsetf wm-command set-wm-command)
    636. 

  636. (defun set-wm-command (window command)
    637. 

  637.   ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX
    638. 

  638.   ;; (or equivalent), with elements of command separated by NULL
    639. 

  639.   ;; characters.  This enables
    640. 

  640.   ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
    641. 

  641.   ;; to recover a lisp command.
    642. 

  642.   (set-string-property
    643. 

  643.     window :WM_COMMAND
    644. 

  644.     (with-output-to-string (stream)
    645. 

  645.       (with-standard-io-syntax
    646. 

  646.         (dolist (c command)
    647. 

  647.           (prin1 c stream)
    648. 

  648.           (write-char (load-time-value (card8->char 0)) stream)))))
    649. 

  649.   command)
    650. 

    651. 

  651. ;;-----------------------------------------------------------------------------
    652. 

  652. ;; WM_HINTS
    653. 

    654. 

  654. ;; Some of the functions below need decode-type and encode-type,
    655. 

  655. ;; I provide here a limited implementation to get these functions working.
    656. 

  656. ;;
    657. 

  657. (defmacro decode-type (type value)
    658. 

  658.   (cond ((eq type 'pixmap) `(lookup-pixmap %buffer ,value))
    659. 

  659.         ((eq type 'window) `(lookup-window %buffer ,value))
    660. 

  660.         ((and (consp type) (eq (car type) 'member))
    661. 

  661.          `(aref ',(coerce (cdr type) 'vector) ,value))
    662. 

  662.         (t (error "Unknown type ~S." type)) ))
    663. 

    664. 

  664. (defmacro encode-type (type value)
    665. 

  665.   (cond ((eq type 'pixmap)   `(pixmap-id ,value))
    666. 

  666.         ((eq type 'window)   `(window-id ,value))
    667. 

  667.         ((eq type 'card16)   `,value)
    668. 

  668.         ((eq type 'colormap) `(colormap-id ,value))
    669. 

  669.         ((eq type 'rgb-val)  `(round (the rgb-val ,value)
    670. 

  670.                                (load-time-value (/ 1.0s0 #xffff))))
    671. 

  671.         ((and (consp type) (eq (car type) 'member))
    672. 

  672.          `(position ,value ',(cdr type)))
    673. 

  673.         (t (error "Unknown type ~S." type)) ))
    674. 

    675. 

  675. (defstruct wm-hints
    676. 

  676.   (input nil )
    677. 

  677.   (initial-state nil )
    678. 

  678.   (icon-pixmap nil )
    679. 

  679.   (icon-window nil )
    680. 

  680.   (icon-x nil )
    681. 

  681.   (icon-y nil )
    682. 

  682.   (icon-mask nil )
    683. 

  683.   (window-group nil )
    684. 

  684.   (flags 0)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
    685. 

  685.   ;; may be extended in the future
    686. 

  686.   )
    687. 

    688. 

  688. (defun wm-hints (window)
    689. 

  689.   (let ((prop (get-property window :WM_HINTS :type :WM_HINTS
    690. 

  690.                             :result-type 'vector)))
    691. 

  691.     (when prop
    692. 

  692.       (decode-wm-hints prop (window-display window)))))
    693. 

    694. 

  694. (defsetf wm-hints set-wm-hints)
    695. 

  695. (defun set-wm-hints (window wm-hints)
    696. 

  696.   (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
    697. 

  697.   wm-hints)
    698. 

    699. 

  699. (defun decode-wm-hints (vector display)
    700. 

  700.   (let ((input-hint 0)
    701. 

  701.         (state-hint 1)
    702. 

  702.         (icon-pixmap-hint 2)
    703. 

  703.         (icon-window-hint 3)
    704. 

  704.         (icon-position-hint 4)
    705. 

  705.         (icon-mask-hint 5)
    706. 

  706.         (window-group-hint 6))
    707. 

  707.     (let ((flags (aref vector 0))
    708. 

  708.           (hints (make-wm-hints))
    709. 

  709.           (%buffer display))
    710. 

  710.       (setf (wm-hints-flags hints) flags)
    711. 

  711.       (when (logbitp input-hint flags)
    712. 

  712.         (setf (wm-hints-input hints) (decode-type (member :off :on)
    713. 

  713.                                                   (aref vector 1))))
    714. 

  714.       (when (logbitp state-hint flags)
    715. 

  715.         (setf (wm-hints-initial-state hints)
    716. 

  716.               (decode-type (member :dont-care :normal :zoom :iconic :inactive)
    717. 

  717.                            (aref vector 2))))
    718. 

  718.       (when (logbitp icon-pixmap-hint flags)
    719. 

  719.         (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
    720. 

  720.       (when (logbitp icon-window-hint flags)
    721. 

  721.         (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
    722. 

  722.       (when (logbitp icon-position-hint flags)
    723. 

  723.         (setf (wm-hints-icon-x hints) (aref vector 5)
    724. 

  724.               (wm-hints-icon-y hints) (aref vector 6)))
    725. 

  725.       (when (logbitp icon-mask-hint flags)
    726. 

  726.         (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
    727. 

  727.       (when (and (logbitp window-group-hint flags) (> (length vector) 7))
    728. 

  728.         (setf (wm-hints-window-group hints) (aref vector 8)))
    729. 

  729.       hints)))
    730. 

    731. 

  731. (defun encode-wm-hints (wm-hints)
    732. 

  732.   (let ((input-hint         #b1)
    733. 

  733.         (state-hint         #b10)
    734. 

  734.         (icon-pixmap-hint   #b100)
    735. 

  735.         (icon-window-hint   #b1000)
    736. 

  736.         (icon-position-hint #b10000)
    737. 

  737.         (icon-mask-hint     #b100000)
    738. 

  738.         (window-group-hint  #b1000000)
    739. 

  739.         (mask               #b1111111)
    740. 

  740.         )
    741. 

  741.     (let ((vector (make-array 9 :initial-element 0))
    742. 

  742.           (flags 0))
    743. 

  743.       (declare (type (simple-vector 9) vector)
    744. 

  744.                (type card16 flags))
    745. 

  745.       (when (wm-hints-input wm-hints)
    746. 

  746.         (setf flags input-hint
    747. 

  747.               (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
    748. 

  748.       (when (wm-hints-initial-state wm-hints)
    749. 

  749.         (setf flags (logior flags state-hint)
    750. 

  750.               (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
    751. 

  751.                                            (wm-hints-initial-state wm-hints))))
    752. 

  752.       (when (wm-hints-icon-pixmap wm-hints)
    753. 

  753.         (setf flags (logior flags icon-pixmap-hint)
    754. 

  754.               (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
    755. 

  755.       (when (wm-hints-icon-window wm-hints)
    756. 

  756.         (setf flags (logior flags icon-window-hint)
    757. 

  757.               (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
    758. 

  758.       (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
    759. 

  759.         (setf flags (logior flags icon-position-hint)
    760. 

  760.               (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
    761. 

  761.               (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
    762. 

  762.       (when (wm-hints-icon-mask wm-hints)
    763. 

  763.         (setf flags (logior flags icon-mask-hint)
    764. 

  764.               (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
    765. 

  765.       (when (wm-hints-window-group wm-hints)
    766. 

  766.         (setf flags (logior flags window-group-hint)
    767. 

  767.               (aref vector 8) (wm-hints-window-group wm-hints)))
    768. 

  768.       (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
    769. 

  769.       vector)))
    770. 

    771. 

    772. 

  772. ;;-----------------------------------------------------------------------------
    773. 

  773. ;; WM_SIZE_HINTS
    774. 

    775. 

  775. ;; XXX
    776. 

    777. 

  777. ;; This code is buggy. My interpretation of change-property and get-property is
    778. 

  778. ;; that they only deal with unsigned data, but the as obsolete marked fields x
    779. 

  779. ;; and y are signed, and the code below does not take care.  Running it
    780. 

  780. ;; interpreted, hence with type checks gets errors.
    781. 

    782. 

  782. (defstruct wm-size-hints
    783. 

  783.   (user-specified-position-p nil :type boolean) ;; True when user specified x y
    784. 

  784.   (user-specified-size-p nil :type boolean)     ;; True when user specified width height
    785. 

  785.   (x nil #|:type (or null int16)|#)                     ;; Obsolete
    786. 

  786.   (y nil #|:type (or null int16)|#)                     ;; Obsolete
    787. 

  787.   (width nil #|:type (or null card16)|#)                ;; Obsolete
    788. 

  788.   (height nil #|:type (or null card16)|#)               ;; Obsolete
    789. 

  789.   (min-width nil :type (or null card16))
    790. 

  790.   (min-height nil :type (or null card16))
    791. 

  791.   (max-width nil :type (or null card16))
    792. 

  792.   (max-height nil :type (or null card16))
    793. 

  793.   (width-inc nil :type (or null card16))
    794. 

  794.   (height-inc nil :type (or null card16))
    795. 

  795.   (min-aspect nil :type (or null number))
    796. 

  796.   (max-aspect nil :type (or null number))
    797. 

  797.   (base-width nil :type (or null card16))
    798. 

  798.   (base-height nil :type (or null card16))
    799. 

  799.   (win-gravity nil :type (or null win-gravity))
    800. 

  800.   (program-specified-position-p nil :type boolean) ;; True when program specified x y
    801. 

  801.   (program-specified-size-p nil :type boolean)     ;; True when program specified width height
    802. 

  802.   )
    803. 

    804. 

  804. (defun wm-normal-hints (window)
    805. 

  805.   (declare (type window window))
    806. 

  806.   (declare (values wm-size-hints))
    807. 

  807.   (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
    808. 

    809. 

  809. (defsetf wm-normal-hints set-wm-normal-hints)
    810. 

  810. (defun set-wm-normal-hints (window hints)
    811. 

  811.   (declare (type window window)
    812. 

  812.            (type wm-size-hints hints))
    813. 

  813.   (declare (values wm-size-hints))
    814. 

  814.   (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
    815. 

  815.   hints)
    816. 

    817. 

  817. ;;; OBSOLETE
    818. 

  818. (defun wm-zoom-hints (window)
    819. 

  819.   (declare (type window window))
    820. 

  820.   (declare (values wm-size-hints))
    821. 

  821.   (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
    822. 

    823. 

  823. ;;; OBSOLETE
    824. 

  824. (defsetf wm-zoom-hints set-wm-zoom-hints)
    825. 

  825. ;;; OBSOLETE
    826. 

  826. (defun set-wm-zoom-hints (window hints)
    827. 

  827.   (declare (type window window)
    828. 

  828.            (type wm-size-hints hints))
    829. 

  829.   (declare (values wm-size-hints))
    830. 

  830.   (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
    831. 

  831.   hints)
    832. 

    833. 

  833. (defun decode-wm-size-hints (vector)
    834. 

  834.   (declare (type (or null (simple-vector *)) vector))
    835. 

  835.   (declare (values (or null wm-size-hints)))
    836. 

  836.   (when vector
    837. 

  837.     (let ((flags (aref vector 0))
    838. 

  838.           (hints (make-wm-size-hints)))
    839. 

  839.       (declare (type card16 flags)
    840. 

  840.                (type wm-size-hints hints))
    841. 

  841.       (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags))
    842. 

  842.       (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags))
    843. 

  843.       (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags))
    844. 

  844.       (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags))
    845. 

  845.       (when (logbitp 4 flags)
    846. 

  846.         (setf (wm-size-hints-min-width hints) (aref vector 5)
    847. 

  847.               (wm-size-hints-min-height hints) (aref vector 6)))
    848. 

  848.       (when (logbitp 5 flags)
    849. 

  849.         (setf (wm-size-hints-max-width hints) (aref vector 7)
    850. 

  850.               (wm-size-hints-max-height hints) (aref vector 8)))
    851. 

  851.       (when (logbitp 6 flags)
    852. 

  852.         (setf (wm-size-hints-width-inc hints) (aref vector 9)
    853. 

  853.               (wm-size-hints-height-inc hints) (aref vector 10)))
    854. 

  854.       (when (logbitp 7 flags)
    855. 

  855.         (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
    856. 

  856.               (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
    857. 

  857.       (when (> (length vector) 15)
    858. 

  858.         ;; This test is for backwards compatibility since old Xlib programs
    859. 

  859.         ;; can set a size-hints structure that is too small.  See ICCCM.
    860. 

  860.         (when (logbitp 8 flags)
    861. 

  861.           (setf (wm-size-hints-base-width hints) (aref vector 15)
    862. 

  862.                 (wm-size-hints-base-height hints) (aref vector 16)))
    863. 

  863.         (when (logbitp 9 flags)
    864. 

  864.           (setf (wm-size-hints-win-gravity hints)
    865. 

  865.                 (decode-type (member :unmap :north-west :north :north-east :west
    866. 

  866.                                      :center :east :south-west :south :south-east :static)
    867. 

  867.                              (aref vector 17)))))
    868. 

  868.       ;; Obsolete fields
    869. 

  869.       (when (or (logbitp 0 flags) (logbitp 2 flags))
    870. 

  870.         (setf (wm-size-hints-x hints) (aref vector 1)
    871. 

  871.               (wm-size-hints-y hints) (aref vector 2)))
    872. 

  872.       (when (or (logbitp 1 flags) (logbitp 3 flags))
    873. 

  873.         (setf (wm-size-hints-width hints) (aref vector 3)
    874. 

  874.               (wm-size-hints-height hints) (aref vector 4)))
    875. 

  875.       hints)))
    876. 

    877. 

  877. (defun encode-wm-size-hints (hints)
    878. 

  878.   (declare (type wm-size-hints hints))
    879. 

  879.   (declare (values simple-vector))
    880. 

  880.   (let ((vector (make-array 18 :initial-element 0))
    881. 

  881.         (flags 0))
    882. 

  882.     (declare (type (simple-vector 18) vector)
    883. 

  883.              (type card16 flags))
    884. 

  884.     (when (wm-size-hints-user-specified-position-p hints)
    885. 

  885.       (setf (ldb (byte 1 0) flags) 1))
    886. 

  886.     (when (wm-size-hints-user-specified-size-p hints)
    887. 

  887.       (setf (ldb (byte 1 1) flags) 1))
    888. 

  888.     (when (wm-size-hints-program-specified-position-p hints)
    889. 

  889.       (setf (ldb (byte 1 2) flags) 1))
    890. 

  890.     (when (wm-size-hints-program-specified-size-p hints)
    891. 

  891.       (setf (ldb (byte 1 3) flags) 1))
    892. 

  892.     (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
    893. 

  893.       (setf (ldb (byte 1 4) flags) 1
    894. 

  894.             (aref vector 5) (wm-size-hints-min-width hints)
    895. 

  895.             (aref vector 6) (wm-size-hints-min-height hints)))
    896. 

  896.     (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
    897. 

  897.       (setf (ldb (byte 1 5) flags) 1
    898. 

  898.             (aref vector 7) (wm-size-hints-max-width hints)
    899. 

  899.             (aref vector 8) (wm-size-hints-max-height hints)))
    900. 

  900.     (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
    901. 

  901.       (setf (ldb (byte 1 6) flags) 1
    902. 

  902.             (aref vector 9) (wm-size-hints-width-inc hints)
    903. 

  903.             (aref vector 10) (wm-size-hints-height-inc hints)))
    904. 

  904.     (let ((min-aspect (wm-size-hints-min-aspect hints))
    905. 

  905.           (max-aspect (wm-size-hints-max-aspect hints)))
    906. 

  906.       (when (and min-aspect max-aspect)
    907. 

  907.         (setf (ldb (byte 1 7) flags) 1
    908. 

  908.               min-aspect (rationalize min-aspect)
    909. 

  909.               max-aspect (rationalize max-aspect)
    910. 

  910.               (aref vector 11) (numerator min-aspect)
    911. 

  911.               (aref vector 12) (denominator min-aspect)
    912. 

  912.               (aref vector 13) (numerator max-aspect)
    913. 

  913.               (aref vector 14) (denominator max-aspect))))
    914. 

  914.     (when (and (wm-size-hints-base-width hints)
    915. 

  915.                (wm-size-hints-base-height hints))
    916. 

  916.       (setf (ldb (byte 1 8) flags) 1
    917. 

  917.             (aref vector 15) (wm-size-hints-base-width hints)
    918. 

  918.             (aref vector 16) (wm-size-hints-base-height hints)))
    919. 

  919.     (when (wm-size-hints-win-gravity hints)
    920. 

  920.       (setf (ldb (byte 1 9) flags) 1
    921. 

  921.             (aref vector 17) (encode-type
    922. 

  922.                                (member :unmap :north-west :north :north-east :west
    923. 

  923.                                        :center :east :south-west :south :south-east :static)
    924. 

  924.                                (wm-size-hints-win-gravity hints))))
    925. 

  925.     ;; Obsolete fields
    926. 

  926.     (when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
    927. 

  927.       (unless (wm-size-hints-user-specified-position-p hints)
    928. 

  928.         (setf (ldb (byte 1 2) flags) 1))
    929. 

  929.       (setf (aref vector 1) (wm-size-hints-x hints)
    930. 

  930.             (aref vector 2) (wm-size-hints-y hints)))
    931. 

  931.     (when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
    932. 

  932.       (unless (wm-size-hints-user-specified-size-p hints)
    933. 

  933.         (setf (ldb (byte 1 3) flags) 1))
    934. 

  934.       (setf (aref vector 3) (wm-size-hints-width hints)
    935. 

  935.             (aref vector 4) (wm-size-hints-height hints)))
    936. 

  936.     (setf (aref vector 0) flags)
    937. 

  937.     vector))
    938. 

    939. 

  939. ;;-----------------------------------------------------------------------------
    940. 

  940. ;; Icon_Size
    941. 

    942. 

  942. ;; Use the same intermediate structure as WM_SIZE_HINTS
    943. 

    944. 

  944. (defun icon-sizes (window)
    945. 

  945.   (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector)))
    946. 

  946.     (when vector
    947. 

  947.       (make-wm-size-hints
    948. 

  948.        :min-width   (aref vector 0)
    949. 

  949.         :min-height (aref vector 1)
    950. 

  950.         :max-width  (aref vector 2)
    951. 

  951.         :max-height (aref vector 3)
    952. 

  952.         :width-inc  (aref vector 4)
    953. 

  953.         :height-inc (aref vector 5)))))
    954. 

    955. 

  955. (defsetf icon-sizes set-icon-sizes)
    956. 

  956. (defun set-icon-sizes (window wm-size-hints)
    957. 

  957.   (let ((vector (vector (wm-size-hints-min-width wm-size-hints)
    958. 

  958.                         (wm-size-hints-min-height wm-size-hints)
    959. 

  959.                         (wm-size-hints-max-width wm-size-hints)
    960. 

  960.                         (wm-size-hints-max-height wm-size-hints)
    961. 

  961.                         (wm-size-hints-width-inc wm-size-hints)
    962. 

  962.                         (wm-size-hints-height-inc wm-size-hints))))
    963. 

  963.     (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
    964. 

  964.     wm-size-hints))
    965. 

    966. 

  966. ;;-----------------------------------------------------------------------------
    967. 

  967. ;; WM-Protocols
    968. 

    969. 

  969. (defun wm-protocols (window)
    970. 

  970.   (map 'list #'(lambda (id) (atom-name (window-display window) id))
    971. 

  971.        (get-property window :WM_PROTOCOLS :type :ATOM)))
    972. 

    973. 

  973. (defsetf wm-protocols set-wm-protocols)
    974. 

  974. (defun set-wm-protocols (window protocols)
    975. 

  975.   (change-property window :WM_PROTOCOLS
    976. 

  976.                    (map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
    977. 

  977.                         protocols)
    978. 

  978.                    :ATOM 32)
    979. 

  979.   protocols)
    980. 

    981. 

  981. ;;-----------------------------------------------------------------------------
    982. 

  982. ;; WM-Colormap-windows
    983. 

    984. 

  984. (defun wm-colormap-windows (window)
    985. 

  985.   (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
    986. 

  986.                         :transform #'(lambda (id)
    987. 

  987.                                        (lookup-window (window-display window) id)))))
    988. 

    989. 

  989. (defsetf wm-colormap-windows set-wm-colormap-windows)
    990. 

  990. (defun set-wm-colormap-windows (window colormap-windows)
    991. 

  991.   (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
    992. 

  992.                    :transform #'window-id)
    993. 

  993.   colormap-windows)
    994. 

    995. 

  995. ;;-----------------------------------------------------------------------------
    996. 

  996. ;; Transient-For
    997. 

    998. 

  998. (defun transient-for (window)
    999. 

  999.   (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list)))
    1000. 

  1000.     (and prop (lookup-window (window-display window) (car prop)))))
    1001. 

    1002. 

  1002. (defsetf transient-for set-transient-for)
    1003. 

  1003. (defun set-transient-for (window transient)
    1004. 

  1004.   (declare (type window window transient))
    1005. 

  1005.   (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32)
    1006. 

  1006.   transient)
    1007. 

    1008. 

  1008. ;;-----------------------------------------------------------------------------
    1009. 

  1009. ;; Set-WM-Properties
    1010. 

    1011. 

  1011. (defun set-wm-properties (window &rest options &key
    1012. 

  1012.                           name icon-name resource-name resource-class command
    1013. 

  1013.                           client-machine hints normal-hints zoom-hints
    1014. 

  1014.                           ;; the following are used for wm-normal-hints
    1015. 

  1015.                           (user-specified-position-p nil usppp)
    1016. 

  1016.                           (user-specified-size-p nil usspp)
    1017. 

  1017.                           (program-specified-position-p nil psppp)
    1018. 

  1018.                           (program-specified-size-p nil psspp)
    1019. 

  1019.                           x y width height min-width min-height max-width max-height
    1020. 

  1020.                           width-inc height-inc min-aspect max-aspect
    1021. 

  1021.                           base-width base-height win-gravity
    1022. 

  1022.                           ;; the following are used for wm-hints
    1023. 

  1023.                           input initial-state icon-pixmap icon-window
    1024. 

  1024.                           icon-x icon-y icon-mask window-group)
    1025. 

  1025.   ;; Set properties for WINDOW.
    1026. 

  1026.   (when name (setf (wm-name window) name))
    1027. 

  1027.   (when icon-name (setf (wm-icon-name window) icon-name))
    1028. 

  1028.   (when client-machine (setf (wm-client-machine window) client-machine))
    1029. 

  1029.   (when (or resource-name resource-class)
    1030. 

  1030.     (set-wm-class window resource-name resource-class))
    1031. 

  1031.   (when command (setf (wm-command window) command))
    1032. 

  1032.   ;; WM-HINTS
    1033. 

  1033.   (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
    1034. 

  1034.                             :icon-x :icon-y :icon-mask :window-group))
    1035. 

  1035.         (when (getf options arg) (return t)))
    1036. 

  1036.       (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
    1037. 

  1037.         (when input (setf (wm-hints-input wm-hints) input))
    1038. 

  1038.         (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
    1039. 

  1039.         (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
    1040. 

  1040.         (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
    1041. 

  1041.         (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
    1042. 

  1042.         (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
    1043. 

  1043.         (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
    1044. 

  1044.         (when window-group
    1045. 

  1045.           (setf (wm-hints-window-group wm-hints) window-group))
    1046. 

  1046.         (setf (wm-hints window) wm-hints))
    1047. 

  1047.       (when hints (setf (wm-hints window) hints)))
    1048. 

  1048.   ;; WM-NORMAL-HINTS
    1049. 

  1049.   (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
    1050. 

  1050.                         :width-inc :height-inc :min-aspect :max-aspect
    1051. 

  1051.                         :user-specified-position-p :user-specified-size-p
    1052. 

  1052.       …
    1053.

Large files files are truncated, but you can click here to view the full file