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

Contents of /src/clx/attributes.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Wed Jun 17 18:22:45 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.7: +14 -9 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; Window Attributes
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20
21 ;;; The special variable *window-attributes* is an alist containg:
22 ;;; (drawable attributes attribute-changes geometry geometry-changes)
23 ;;; Where DRAWABLE is the associated window or pixmap
24 ;;; ATTRIBUTES is NIL or a reply-buffer containing the drawable's
25 ;;; attributes for use by the accessors.
26 ;;; ATTRIBUTE-CHANGES is NIL or an array. The first element
27 ;;; of the array is a "value-mask", indicating which
28 ;;; attributes have changed. The other elements are
29 ;;; integers associated with the changed values, ready
30 ;;; for insertion into a server request.
31 ;;; GEOMETRY is like ATTRIBUTES, but for window geometry
32 ;;; GEOMETRY-CHANGES is like ATTRIBUTE-CHANGES, but for window geometry
33 ;;;
34 ;;; Attribute and Geometry accessors and SETF's look on the special variable
35 ;;; *window-attributes* for the drawable. If its not there, the accessor is
36 ;;; NOT within a WITH-STATE, and a server request is made to get or put a value.
37 ;;; If an entry is found in *window-attributes*, the cache buffers are used
38 ;;; for the access.
39 ;;;
40 ;;; All WITH-STATE has to do (re)bind *Window-attributes* to a list including
41 ;;; the new drawable. The caches are initialized to NIL and allocated as needed.
42
43 #+cmu
44 (ext:file-comment "$Id: attributes.lisp,v 1.8 2009/06/17 18:22:45 rtoy Rel $")
45
46 (in-package :xlib)
47
48 (eval-when (:compile-toplevel :load-toplevel :execute)
49 (defconstant +attribute-size+ 44)
50 (defconstant +geometry-size+ 24)
51 (defconstant +context-size+ (max +attribute-size+ +geometry-size+ (* 16 4))))
52
53 (defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE
54
55 ;; Window Attribute reply buffer resource
56 (defvar *context-free-list* nil) ;; resource of free reply buffers
57
58 (defun allocate-context ()
59 (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer)
60 (make-reply-buffer +context-size+)))
61
62 (defun deallocate-context (context)
63 (declare (type reply-buffer context))
64 (threaded-atomic-push context *context-free-list* reply-next reply-buffer))
65
66 (defmacro state-attributes (state) `(second ,state))
67 (defmacro state-attribute-changes (state) `(third ,state))
68 (defmacro state-geometry (state) `(fourth ,state))
69 (defmacro state-geometry-changes (state) `(fifth ,state))
70
71 (defmacro drawable-equal-function ()
72 ;; Since drawables are not always cached, we must use drawable-equal
73 ;; to determine equality.
74 ''drawable-equal)
75
76 (defmacro window-equal-function ()
77 ;; Since windows are not always cached, we must use window-equal
78 ;; to determine equality.
79 ''window-equal)
80
81 (defmacro with-state ((drawable) &body body)
82 ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
83 ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
84 ;; ConfigureWindow. The body is not surrounded by a with-display. Within the
85 ;; indefinite scope of the body, on a per-process basis in a multi-process
86 ;; environment, the first call within an Accessor Group on the specified drawable
87 ;; (the object, not just the variable) causes the complete results of the protocol
88 ;; request to be retained, and returned in any subsequent accessor calls. Calls
89 ;; within a Setf Group are delayed, and executed in a single request on exit from
90 ;; the body. In addition, if a call on a function within an Accessor Group follows
91 ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
92 ;; that group are executed, any retained accessor information for that group is
93 ;; discarded, the corresponding protocol request is (re)issued, and the results are
94 ;; (again) retained, and returned in any subsequent accessor calls.
95
96 ;; Accessor Group A (for GetWindowAttributes):
97 ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity,
98 ;; window-backing-store, window-backing-planes, window-backing-pixel,
99 ;; window-save-under, window-colormap, window-colormap-installed-p,
100 ;; window-map-state, window-all-event-masks, window-event-mask,
101 ;; window-do-not-propagate-mask, window-override-redirect
102
103 ;; Setf Group A (for ChangeWindowAttributes):
104 ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
105 ;; window-backing-pixel, window-save-under, window-event-mask,
106 ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
107 ;; window-cursor
108
109 ;; Accessor Group G (for GetGeometry):
110 ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
111 ;; drawable-height, drawable-border-width
112
113 ;; Setf Group G (for ConfigureWindow):
114 ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
115 ;; window-priority
116 (let ((state-entry (gensym)))
117 ;; alist of (drawable attributes attribute-changes geometry geometry-changes)
118 `(with-stack-list (,state-entry ,drawable nil nil nil nil)
119 (with-stack-list* (*window-attributes* ,state-entry *window-attributes*)
120 (multiple-value-prog1
121 (progn ,@body)
122 (cleanup-state-entry ,state-entry))))))
123
124 (defun cleanup-state-entry (state)
125 ;; Return buffers to the free-list
126 (let ((entry (state-attributes state)))
127 (when entry (deallocate-context entry)))
128 (let ((entry (state-attribute-changes state)))
129 (when entry
130 (put-window-attribute-changes (car state) entry)
131 (deallocate-gcontext-state entry)))
132 (let ((entry (state-geometry state)))
133 (when entry (deallocate-context entry)))
134 (let ((entry (state-geometry-changes state)))
135 (when entry
136 (put-drawable-geometry-changes (car state) entry)
137 (deallocate-gcontext-state entry))))
138
139
140
141 (defun change-window-attribute (window number value)
142 ;; Called from window attribute SETF's to alter an attribute value
143 ;; number is the change-attributes request mask bit number
144 (declare (type window window)
145 (type card8 number)
146 (type card32 value))
147 (let ((state-entry nil)
148 (changes nil))
149 (if (and *window-attributes*
150 (setq state-entry (assoc window (the list *window-attributes*)
151 :test (window-equal-function))))
152 (progn ; Within a WITH-STATE - cache changes
153 (setq changes (state-attribute-changes state-entry))
154 (unless changes
155 (setq changes (allocate-gcontext-state))
156 (setf (state-attribute-changes state-entry) changes)
157 (setf (aref changes 0) 0)) ;; Initialize mask to zero
158 (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
159 (setf (aref changes (1+ number)) value)) ;; save value
160 ; Send change to the server
161 (with-buffer-request ((window-display window) +x-changewindowattributes+)
162 (window window)
163 (card32 (ash 1 number) value)))))
164 ;;
165 ;; These two are twins (change-window-attribute change-drawable-geometry)
166 ;; If you change one, you probably need to change the other...
167 ;;
168 (defun change-drawable-geometry (drawable number value)
169 ;; Called from drawable geometry SETF's to alter an attribute value
170 ;; number is the change-attributes request mask bit number
171 (declare (type drawable drawable)
172 (type card8 number)
173 (type card29 value))
174 (let ((state-entry nil)
175 (changes nil))
176 (if (and *window-attributes*
177 (setq state-entry (assoc drawable (the list *window-attributes*)
178 :test (drawable-equal-function))))
179 (progn ; Within a WITH-STATE - cache changes
180 (setq changes (state-geometry-changes state-entry))
181 (unless changes
182 (setq changes (allocate-gcontext-state))
183 (setf (state-geometry-changes state-entry) changes)
184 (setf (aref changes 0) 0)) ;; Initialize mask to zero
185 (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
186 (setf (aref changes (1+ number)) value)) ;; save value
187 ; Send change to the server
188 (with-buffer-request ((drawable-display drawable) +x-configurewindow+)
189 (drawable drawable)
190 (card16 (ash 1 number))
191 (card29 value)))))
192
193 (defun get-window-attributes-buffer (window)
194 (declare (type window window))
195 (let ((state-entry nil)
196 (changes nil))
197 (or (and *window-attributes*
198 (setq state-entry (assoc window (the list *window-attributes*)
199 :test (window-equal-function)))
200 (null (setq changes (state-attribute-changes state-entry)))
201 (state-attributes state-entry))
202 (let ((display (window-display window)))
203 (with-display (display)
204 ;; When SETF's have been done, flush changes to the server
205 (when changes
206 (put-window-attribute-changes window changes)
207 (deallocate-gcontext-state (state-attribute-changes state-entry))
208 (setf (state-attribute-changes state-entry) nil))
209 ;; Get window attributes
210 (with-buffer-request-and-reply (display +x-getwindowattributes+ size :sizes (8))
211 ((window window))
212 (let ((repbuf (or (state-attributes state-entry) (allocate-context))))
213 (declare (type reply-buffer repbuf))
214 ;; Copy into repbuf from reply buffer
215 (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
216 (when state-entry (setf (state-attributes state-entry) repbuf))
217 repbuf)))))))
218
219 ;;
220 ;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer)
221 ;; If you change one, you probably need to change the other...
222 ;;
223 (defun get-drawable-geometry-buffer (drawable)
224 (declare (type drawable drawable))
225 (let ((state-entry nil)
226 (changes nil))
227 (or (and *window-attributes*
228 (setq state-entry (assoc drawable (the list *window-attributes*)
229 :test (drawable-equal-function)))
230 (null (setq changes (state-geometry-changes state-entry)))
231 (state-geometry state-entry))
232 (let ((display (drawable-display drawable)))
233 (with-display (display)
234 ;; When SETF's have been done, flush changes to the server
235 (when changes
236 (put-drawable-geometry-changes drawable changes)
237 (deallocate-gcontext-state (state-geometry-changes state-entry))
238 (setf (state-geometry-changes state-entry) nil))
239 ;; Get drawable attributes
240 (with-buffer-request-and-reply (display +x-getgeometry+ size :sizes (8))
241 ((drawable drawable))
242 (let ((repbuf (or (state-geometry state-entry) (allocate-context))))
243 (declare (type reply-buffer repbuf))
244 ;; Copy into repbuf from reply buffer
245 (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
246 (when state-entry (setf (state-geometry state-entry) repbuf))
247 repbuf)))))))
248
249 (defun put-window-attribute-changes (window changes)
250 ;; change window attributes
251 ;; Always from Called within a WITH-DISPLAY
252 (declare (type window window)
253 (type gcontext-state changes))
254 (let* ((display (window-display window))
255 (mask (aref changes 0)))
256 (declare (type display display)
257 (type mask32 mask))
258 (with-buffer-request (display +x-changewindowattributes+)
259 (window window)
260 (card32 mask)
261 (progn ;; Insert a word in the request for each one bit in the mask
262 (do ((bits mask (ash bits -1))
263 (request-size 2) ;Word count
264 (i 1 (index+ i 1))) ;Entry count
265 ((zerop bits)
266 (card16-put 2 (index-incf request-size))
267 (index-incf (buffer-boffset display) (index* request-size 4)))
268 (declare (type mask32 bits)
269 (type array-index i request-size))
270 (when (oddp bits)
271 (card32-put (index* (index-incf request-size) 4) (aref changes i))))))))
272 ;;
273 ;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes)
274 ;; If you change one, you probably need to change the other...
275 ;;
276 (defun put-drawable-geometry-changes (window changes)
277 ;; change window attributes or geometry (depending on request-number...)
278 ;; Always from Called within a WITH-DISPLAY
279 (declare (type window window)
280 (type gcontext-state changes))
281 (let* ((display (window-display window))
282 (mask (aref changes 0)))
283 (declare (type display display)
284 (type mask16 mask))
285 (with-buffer-request (display +x-configurewindow+)
286 (window window)
287 (card16 mask)
288 (progn ;; Insert a word in the request for each one bit in the mask
289 (do ((bits mask (ash bits -1))
290 (request-size 2) ;Word count
291 (i 1 (index+ i 1))) ;Entry count
292 ((zerop bits)
293 (card16-put 2 (incf request-size))
294 (index-incf (buffer-boffset display) (* request-size 4)))
295 (declare (type mask16 bits)
296 (type fixnum request-size)
297 (type array-index i))
298 (when (oddp bits)
299 (card29-put (* (incf request-size) 4) (aref changes i))))))))
300
301 (defmacro with-attributes ((window &rest options) &body body)
302 `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window)))
303 (declare (type reply-buffer .with-attributes-reply-buffer.))
304 (prog1
305 (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body)
306 (unless *window-attributes*
307 (deallocate-context .with-attributes-reply-buffer.)))))
308 ;;
309 ;; These two are twins (with-attributes with-geometry)
310 ;; If you change one, you probably need to change the other...
311 ;;
312 (defmacro with-geometry ((window &rest options) &body body)
313 `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window)))
314 (declare (type reply-buffer .with-geometry-reply-buffer.))
315 (prog1
316 (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body)
317 (unless *window-attributes*
318 (deallocate-context .with-geometry-reply-buffer.)))))
319
320 ;;;-----------------------------------------------------------------------------
321 ;;; Group A: (for GetWindowAttributes)
322 ;;;-----------------------------------------------------------------------------
323
324 (defun window-visual (window)
325 (declare (type window window))
326 (declare (clx-values resource-id))
327 (with-attributes (window :sizes 32)
328 (resource-id-get 8)))
329
330 (defun window-visual-info (window)
331 (declare (type window window))
332 (declare (clx-values visual-info))
333 (with-attributes (window :sizes 32)
334 (visual-info (window-display window) (resource-id-get 8))))
335
336 (defun window-class (window)
337 (declare (type window window))
338 (declare (clx-values (member :input-output :input-only)))
339 (with-attributes (window :sizes 16)
340 (member16-get 12 :copy :input-output :input-only)))
341
342 (defun set-window-background (window background)
343 (declare (type window window)
344 (type (or (member :none :parent-relative) pixel pixmap) background))
345 (cond ((eq background :none) (change-window-attribute window 0 0))
346 ((eq background :parent-relative) (change-window-attribute window 0 1))
347 ((integerp background) ;; Background pixel
348 (change-window-attribute window 0 0) ;; pixmap :NONE
349 (change-window-attribute window 1 background))
350 ((type? background 'pixmap) ;; Background pixmap
351 (change-window-attribute window 0 (pixmap-id background)))
352 (t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
353 background)
354
355 #+Genera (eval-when (compile) (compiler:function-defined 'window-background))
356
357 (defsetf window-background set-window-background)
358
359 (defun set-window-border (window border)
360 (declare (type window window)
361 (type (or (member :copy) pixel pixmap) border))
362 (cond ((eq border :copy) (change-window-attribute window 2 0))
363 ((type? border 'pixmap) ;; Border pixmap
364 (change-window-attribute window 2 (pixmap-id border)))
365 ((integerp border) ;; Border pixel
366 (change-window-attribute window 3 border))
367 (t (x-type-error border '(or (member :copy) integer pixmap))))
368 border)
369
370 #+Genera (eval-when (compile) (compiler:function-defined 'window-border))
371
372 (defsetf window-border set-window-border)
373
374 (defun window-bit-gravity (window)
375 ;; setf'able
376 (declare (type window window))
377 (declare (clx-values bit-gravity))
378 (with-attributes (window :sizes 8)
379 (member8-vector-get 14 +bit-gravity-vector+)))
380
381 (defun set-window-bit-gravity (window gravity)
382 (change-window-attribute
383 window 4 (encode-type (member-vector +bit-gravity-vector+) gravity))
384 gravity)
385
386 (defsetf window-bit-gravity set-window-bit-gravity)
387
388 (defun window-gravity (window)
389 ;; setf'able
390 (declare (type window window))
391 (declare (clx-values win-gravity))
392 (with-attributes (window :sizes 8)
393 (member8-vector-get 15 +win-gravity-vector+)))
394
395 (defun set-window-gravity (window gravity)
396 (change-window-attribute
397 window 5 (encode-type (member-vector +win-gravity-vector+) gravity))
398 gravity)
399
400 (defsetf window-gravity set-window-gravity)
401
402 (defun window-backing-store (window)
403 ;; setf'able
404 (declare (type window window))
405 (declare (clx-values (member :not-useful :when-mapped :always)))
406 (with-attributes (window :sizes 8)
407 (member8-get 1 :not-useful :when-mapped :always)))
408
409 (defun set-window-backing-store (window when)
410 (change-window-attribute
411 window 6 (encode-type (member :not-useful :when-mapped :always) when))
412 when)
413
414 (defsetf window-backing-store set-window-backing-store)
415
416 (defun window-backing-planes (window)
417 ;; setf'able
418 (declare (type window window))
419 (declare (clx-values pixel))
420 (with-attributes (window :sizes 32)
421 (card32-get 16)))
422
423 (defun set-window-backing-planes (window planes)
424 (change-window-attribute window 7 (encode-type card32 planes))
425 planes)
426
427 (defsetf window-backing-planes set-window-backing-planes)
428
429 (defun window-backing-pixel (window)
430 ;; setf'able
431 (declare (type window window))
432 (declare (clx-values pixel))
433 (with-attributes (window :sizes 32)
434 (card32-get 20)))
435
436 (defun set-window-backing-pixel (window pixel)
437 (change-window-attribute window 8 (encode-type card32 pixel))
438 pixel)
439
440 (defsetf window-backing-pixel set-window-backing-pixel)
441
442 (defun window-save-under (window)
443 ;; setf'able
444 (declare (type window window))
445 (declare (clx-values (member :off :on)))
446 (with-attributes (window :sizes 8)
447 (member8-get 24 :off :on)))
448
449 (defun set-window-save-under (window when)
450 (change-window-attribute window 10 (encode-type (member :off :on) when))
451 when)
452
453 (defsetf window-save-under set-window-save-under)
454
455 (defun window-override-redirect (window)
456 ;; setf'able
457 (declare (type window window))
458 (declare (clx-values (member :off :on)))
459 (with-attributes (window :sizes 8)
460 (member8-get 27 :off :on)))
461
462 (defun set-window-override-redirect (window when)
463 (change-window-attribute window 9 (encode-type (member :off :on) when))
464 when)
465
466 (defsetf window-override-redirect set-window-override-redirect)
467
468 (defun window-event-mask (window)
469 ;; setf'able
470 (declare (type window window))
471 (declare (clx-values mask32))
472 (with-attributes (window :sizes 32)
473 (card32-get 36)))
474
475 (defsetf window-event-mask (window) (event-mask)
476 (let ((em (gensym)))
477 `(let ((,em ,event-mask))
478 (declare (type event-mask ,em))
479 (change-window-attribute ,window 11 (encode-event-mask ,em))
480 ,em)))
481
482 (defun window-do-not-propagate-mask (window)
483 ;; setf'able
484 (declare (type window window))
485 (declare (clx-values mask32))
486 (with-attributes (window :sizes 32)
487 (card32-get 40)))
488
489 (defsetf window-do-not-propagate-mask (window) (device-event-mask)
490 (let ((em (gensym)))
491 `(let ((,em ,device-event-mask))
492 (declare (type device-event-mask ,em))
493 (change-window-attribute ,window 12 (encode-device-event-mask ,em))
494 ,em)))
495
496 (defun window-colormap (window)
497 (declare (type window window))
498 (declare (clx-values (or null colormap)))
499 (with-attributes (window :sizes 32)
500 (let ((id (resource-id-get 28)))
501 (if (zerop id)
502 nil
503 (let ((colormap (lookup-colormap (window-display window) id)))
504 (unless (colormap-visual-info colormap)
505 (setf (colormap-visual-info colormap)
506 (visual-info (window-display window) (resource-id-get 8))))
507 colormap)))))
508
509 (defun set-window-colormap (window colormap)
510 (change-window-attribute
511 window 13 (encode-type (or (member :copy) colormap) colormap))
512 colormap)
513
514 (defsetf window-colormap set-window-colormap)
515
516 (defun window-cursor (window)
517 (declare (type window window))
518 (declare (clx-values cursor))
519 window
520 (error "~S can only be set" 'window-cursor))
521
522 (defun set-window-cursor (window cursor)
523 (change-window-attribute
524 window 14 (encode-type (or (member :none) cursor) cursor))
525 cursor)
526
527 (defsetf window-cursor set-window-cursor)
528
529 (defun window-colormap-installed-p (window)
530 (declare (type window window))
531 (declare (clx-values generalized-boolean))
532 (with-attributes (window :sizes 8)
533 (boolean-get 25)))
534
535 (defun window-all-event-masks (window)
536 (declare (type window window))
537 (declare (clx-values mask32))
538 (with-attributes (window :sizes 32)
539 (card32-get 32)))
540
541 (defun window-map-state (window)
542 (declare (type window window))
543 (declare (clx-values (member :unmapped :unviewable :viewable)))
544 (with-attributes (window :sizes 8)
545 (member8-get 26 :unmapped :unviewable :viewable)))
546
547
548 ;;;-----------------------------------------------------------------------------
549 ;;; Group G: (for GetGeometry)
550 ;;;-----------------------------------------------------------------------------
551
552 (defun drawable-root (drawable)
553 (declare (type drawable drawable))
554 (declare (clx-values window))
555 (with-geometry (drawable :sizes 32)
556 (window-get 8 (drawable-display drawable))))
557
558 (defun drawable-x (drawable)
559 ;; setf'able
560 (declare (type drawable drawable))
561 (declare (clx-values int16))
562 (with-geometry (drawable :sizes 16)
563 (int16-get 12)))
564
565 (defun set-drawable-x (drawable x)
566 (change-drawable-geometry drawable 0 (encode-type int16 x))
567 x)
568
569 (defsetf drawable-x set-drawable-x)
570
571 (defun drawable-y (drawable)
572 ;; setf'able
573 (declare (type drawable drawable))
574 (declare (clx-values int16))
575 (with-geometry (drawable :sizes 16)
576 (int16-get 14)))
577
578 (defun set-drawable-y (drawable y)
579 (change-drawable-geometry drawable 1 (encode-type int16 y))
580 y)
581
582 (defsetf drawable-y set-drawable-y)
583
584 (defun drawable-width (drawable)
585 ;; setf'able
586 ;; Inside width, excluding border.
587 (declare (type drawable drawable))
588 (declare (clx-values card16))
589 (with-geometry (drawable :sizes 16)
590 (card16-get 16)))
591
592 (defun set-drawable-width (drawable width)
593 (change-drawable-geometry drawable 2 (encode-type card16 width))
594 width)
595
596 (defsetf drawable-width set-drawable-width)
597
598 (defun drawable-height (drawable)
599 ;; setf'able
600 ;; Inside height, excluding border.
601 (declare (type drawable drawable))
602 (declare (clx-values card16))
603 (with-geometry (drawable :sizes 16)
604 (card16-get 18)))
605
606 (defun set-drawable-height (drawable height)
607 (change-drawable-geometry drawable 3 (encode-type card16 height))
608 height)
609
610 (defsetf drawable-height set-drawable-height)
611
612 (defun drawable-depth (drawable)
613 (declare (type drawable drawable))
614 (declare (clx-values card8))
615 (with-geometry (drawable :sizes 8)
616 (card8-get 1)))
617
618 (defun drawable-border-width (drawable)
619 ;; setf'able
620 (declare (type drawable drawable))
621 (declare (clx-values integer))
622 (with-geometry (drawable :sizes 16)
623 (card16-get 20)))
624
625 (defun set-drawable-border-width (drawable width)
626 (change-drawable-geometry drawable 4 (encode-type card16 width))
627 width)
628
629 (defsetf drawable-border-width set-drawable-border-width)
630
631 (defun set-window-priority (mode window sibling)
632 (declare (type (member :above :below :top-if :bottom-if :opposite) mode)
633 (type window window)
634 (type (or null window) sibling))
635 (with-state (window)
636 (change-drawable-geometry
637 window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode))
638 (when sibling
639 (change-drawable-geometry window 5 (encode-type window sibling))))
640 mode)
641
642 #+Genera (eval-when (compile) (compiler:function-defined 'window-priority))
643
644 (defsetf window-priority (window &optional sibling) (mode)
645 ;; A bit strange, but retains setf form.
646 `(set-window-priority ,mode ,window ,sibling))

  ViewVC Help
Powered by ViewVC 1.1.5