home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / attributes.l next >
Encoding:
Text File  |  1991-07-07  |  23.2 KB  |  639 lines
  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. (in-package :xlib)
  44.  
  45. (eval-when (compile load eval)            ;needed by Franz Lisp
  46. (defconstant *attribute-size* 44)
  47. (defconstant *geometry-size* 24)
  48. (defconstant *context-size* (max *attribute-size* *geometry-size* (* 16 4))))
  49.  
  50. (defvar *window-attributes* nil) ;; Bound to an alist of (drawable . state) within WITH-STATE
  51.  
  52. ;; Window Attribute reply buffer resource
  53. (defvar *context-free-list* nil) ;; resource of free reply buffers
  54.  
  55. (defun allocate-context ()
  56.   (or (threaded-atomic-pop *context-free-list* reply-next reply-buffer)
  57.       (make-reply-buffer *context-size*)))
  58.  
  59. (defun deallocate-context (context)
  60.   (declare (type reply-buffer context))
  61.   (threaded-atomic-push context *context-free-list* reply-next reply-buffer))
  62.  
  63. (defmacro state-attributes (state) `(second ,state))
  64. (defmacro state-attribute-changes (state) `(third ,state))
  65. (defmacro state-geometry (state) `(fourth ,state))
  66. (defmacro state-geometry-changes (state) `(fifth ,state))
  67.  
  68. (defmacro drawable-equal-function ()
  69.   (if (member 'drawable *clx-cached-types*)
  70.       ''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
  71.     ''drawable-equal))
  72.  
  73. (defmacro window-equal-function ()
  74.   (if (member 'window *clx-cached-types*)
  75.       ''eq
  76.     ''drawable-equal))
  77.  
  78. (defmacro with-state ((drawable) &body body)
  79.   ;; Allows a consistent view to be obtained of data returned by GetWindowAttributes
  80.   ;; and GetGeometry, and allows a coherent update using ChangeWindowAttributes and
  81.   ;; ConfigureWindow.  The body is not surrounded by a with-display.  Within the
  82.   ;; indefinite scope of the body, on a per-process basis in a multi-process
  83.   ;; environment, the first call within an Accessor Group on the specified drawable
  84.   ;; (the object, not just the variable) causes the complete results of the protocol
  85.   ;; request to be retained, and returned in any subsequent accessor calls.  Calls
  86.   ;; within a Setf Group are delayed, and executed in a single request on exit from
  87.   ;; the body.  In addition, if a call on a function within an Accessor Group follows
  88.   ;; a call on a function in the corresponding Setf Group, then all delayed setfs for
  89.   ;; that group are executed, any retained accessor information for that group is
  90.   ;; discarded, the corresponding protocol request is (re)issued, and the results are
  91.   ;; (again) retained, and returned in any subsequent accessor calls.
  92.  
  93.   ;; Accessor Group A (for GetWindowAttributes):
  94.   ;; window-visual, window-visual-info, window-class, window-gravity, window-bit-gravity,
  95.   ;; window-backing-store, window-backing-planes, window-backing-pixel,
  96.   ;; window-save-under, window-colormap, window-colormap-installed-p,
  97.   ;; window-map-state, window-all-event-masks, window-event-mask,
  98.   ;; window-do-not-propagate-mask, window-override-redirect
  99.  
  100.   ;; Setf Group A (for ChangeWindowAttributes):
  101.   ;; window-gravity, window-bit-gravity, window-backing-store, window-backing-planes,
  102.   ;; window-backing-pixel, window-save-under, window-event-mask,
  103.   ;; window-do-not-propagate-mask, window-override-redirect, window-colormap,
  104.   ;; window-cursor
  105.  
  106.   ;; Accessor Group G (for GetGeometry):
  107.   ;; drawable-root, drawable-depth, drawable-x, drawable-y, drawable-width,
  108.   ;; drawable-height, drawable-border-width
  109.  
  110.   ;; Setf Group G (for ConfigureWindow):
  111.   ;; drawable-x, drawable-y, drawable-width, drawable-height, drawable-border-width,
  112.   ;; window-priority
  113.   (let ((state-entry (gensym)))
  114.      ;; alist of (drawable attributes attribute-changes geometry geometry-changes)
  115.     `(with-stack-list (,state-entry ,drawable nil nil nil nil)
  116.        (with-stack-list* (*window-attributes* ,state-entry *window-attributes*)
  117.      (multiple-value-prog1
  118.        (progn ,@body)
  119.        (cleanup-state-entry ,state-entry))))))
  120.  
  121. (defun cleanup-state-entry (state)
  122.   ;; Return buffers to the free-list
  123.   (let ((entry (state-attributes state)))
  124.     (when entry (deallocate-context entry)))
  125.   (let ((entry (state-attribute-changes state)))
  126.     (when entry
  127.       (put-window-attribute-changes (car state) entry)
  128.       (deallocate-gcontext-state entry)))
  129.   (let ((entry (state-geometry state)))
  130.     (when entry (deallocate-context entry)))
  131.   (let ((entry (state-geometry-changes state)))
  132.     (when entry
  133.       (put-drawable-geometry-changes (car state) entry)
  134.       (deallocate-gcontext-state entry))))
  135.  
  136.  
  137.  
  138. (defun change-window-attribute (window number value)
  139.   ;; Called from window attribute SETF's to alter an attribute value
  140.   ;; number is the change-attributes request mask bit number
  141.   (declare (type window window)
  142.        (type card8 number)
  143.        (type card32 value))
  144.   (let ((state-entry nil)
  145.     (changes nil))
  146.     (if (and *window-attributes*
  147.          (setq state-entry (assoc window (the list *window-attributes*)
  148.                       :test (window-equal-function))))
  149.     (progn                    ; Within a WITH-STATE - cache changes
  150.       (setq changes (state-attribute-changes state-entry))
  151.       (unless changes
  152.         (setq changes (allocate-gcontext-state))
  153.         (setf (state-attribute-changes state-entry) changes)
  154.         (setf (aref changes 0) 0)) ;; Initialize mask to zero
  155.       (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
  156.       (setf (aref changes (1+ number)) value))    ;; save value
  157.                         ; Send change to the server
  158.       (with-buffer-request ((window-display window) *x-changewindowattributes*)
  159.     (window window)
  160.     (card32 (ash 1 number) value)))))
  161. ;;
  162. ;; These two are twins (change-window-attribute change-drawable-geometry)
  163. ;; If you change one, you probably need to change the other...
  164. ;;
  165. (defun change-drawable-geometry (drawable number value)
  166.   ;; Called from drawable geometry SETF's to alter an attribute value
  167.   ;; number is the change-attributes request mask bit number
  168.   (declare (type drawable drawable)
  169.        (type card8 number)
  170.        (type card29 value))
  171.   (let ((state-entry nil)
  172.     (changes nil))
  173.     (if (and *window-attributes*
  174.          (setq state-entry (assoc drawable (the list *window-attributes*)
  175.                       :test (drawable-equal-function))))
  176.     (progn                    ; Within a WITH-STATE - cache changes
  177.       (setq changes (state-geometry-changes state-entry))
  178.       (unless changes
  179.         (setq changes (allocate-gcontext-state))
  180.         (setf (state-geometry-changes state-entry) changes)
  181.         (setf (aref changes 0) 0)) ;; Initialize mask to zero
  182.       (setf (aref changes 0) (logior (aref changes 0) (ash 1 number))) ;; set mask bit
  183.       (setf (aref changes (1+ number)) value))    ;; save value
  184.                         ; Send change to the server
  185.       (with-buffer-request ((drawable-display drawable) *x-configurewindow*)
  186.     (drawable drawable)
  187.     (card16 (ash 1 number))
  188.     (card29 value)))))
  189.  
  190. (defun get-window-attributes-buffer (window)
  191.   (declare (type window window))
  192.   (let ((state-entry nil)
  193.     (changes nil))
  194.     (or (and *window-attributes*
  195.          (setq state-entry (assoc window (the list *window-attributes*)
  196.                       :test (window-equal-function)))
  197.          (null (setq changes (state-attribute-changes state-entry)))
  198.          (state-attributes state-entry))
  199.     (let ((display (window-display window)))
  200.       (with-display (display)
  201.         ;; When SETF's have been done, flush changes to the server
  202.         (when changes
  203.           (put-window-attribute-changes window changes)
  204.           (deallocate-gcontext-state (state-attribute-changes state-entry))
  205.           (setf (state-attribute-changes state-entry) nil))
  206.         ;; Get window attributes
  207.         (with-buffer-request-and-reply (display *x-getwindowattributes* size :sizes (8))
  208.          ((window window))
  209.           (let ((repbuf (or (state-attributes state-entry) (allocate-context))))
  210.         (declare (type reply-buffer repbuf))
  211.         ;; Copy into repbuf from reply buffer
  212.         (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
  213.         (when state-entry (setf (state-attributes state-entry) repbuf))
  214.         repbuf)))))))
  215.  
  216. ;;
  217. ;; These two are twins (get-window-attributes-buffer get-drawable-geometry-buffer)
  218. ;; If you change one, you probably need to change the other...
  219. ;;
  220. (defun get-drawable-geometry-buffer (drawable)
  221.   (declare (type drawable drawable))
  222.   (let ((state-entry nil)
  223.     (changes nil))
  224.     (or (and *window-attributes*
  225.          (setq state-entry (assoc drawable (the list *window-attributes*)
  226.                       :test (drawable-equal-function)))
  227.          (null (setq changes (state-geometry-changes state-entry)))
  228.          (state-geometry state-entry))
  229.     (let ((display (drawable-display drawable)))
  230.       (with-display (display)
  231.         ;; When SETF's have been done, flush changes to the server
  232.         (when changes
  233.           (put-drawable-geometry-changes drawable changes)
  234.           (deallocate-gcontext-state (state-geometry-changes state-entry))
  235.           (setf (state-geometry-changes state-entry) nil))
  236.         ;; Get drawable attributes
  237.         (with-buffer-request-and-reply (display *x-getgeometry* size :sizes (8))
  238.          ((drawable drawable))
  239.           (let ((repbuf (or (state-geometry state-entry) (allocate-context))))
  240.         (declare (type reply-buffer repbuf))
  241.         ;; Copy into repbuf from reply buffer
  242.         (buffer-replace (reply-ibuf8 repbuf) buffer-bbuf 0 size)
  243.         (when state-entry (setf (state-geometry state-entry) repbuf))
  244.         repbuf)))))))
  245.  
  246. (defun put-window-attribute-changes (window changes)
  247.   ;; change window attributes
  248.   ;; Always from Called within a WITH-DISPLAY
  249.   (declare (type window window)
  250.        (type gcontext-state changes))
  251.   (let* ((display (window-display window))
  252.      (mask (aref changes 0)))
  253.     (declare (type display display)
  254.          (type mask32 mask))
  255.     (with-buffer-request (display *x-changewindowattributes*)
  256.       (window window)
  257.       (card32 mask)
  258.       (progn ;; Insert a word in the request for each one bit in the mask
  259.     (do ((bits mask (ash bits -1))
  260.          (request-size 2)            ;Word count
  261.          (i 1 (index+ i 1)))        ;Entry count
  262.         ((zerop bits)
  263.          (card16-put 2 (index-incf request-size))
  264.          (index-incf (buffer-boffset display) (index* request-size 4)))
  265.       (declare (type mask32 bits)
  266.            (type array-index i request-size))
  267.       (when (oddp bits)
  268.         (card32-put (index* (index-incf request-size) 4) (aref changes i))))))))
  269. ;;
  270. ;; These two are twins (put-window-attribute-changes put-drawable-geometry-changes)
  271. ;; If you change one, you probably need to change the other...
  272. ;;
  273. (defun put-drawable-geometry-changes (window changes)
  274.   ;; change window attributes or geometry (depending on request-number...)
  275.   ;; Always from Called within a WITH-DISPLAY
  276.   (declare (type window window)
  277.        (type gcontext-state changes))
  278.   (let* ((display (window-display window))
  279.      (mask (aref changes 0)))
  280.     (declare (type display display)
  281.          (type mask16 mask))
  282.     (with-buffer-request (display *x-configurewindow*)
  283.       (window window)
  284.       (card16 mask)
  285.       (progn ;; Insert a word in the request for each one bit in the mask
  286.     (do ((bits mask (ash bits -1))
  287.          (request-size 2)            ;Word count
  288.          (i 1 (index+ i 1)))        ;Entry count
  289.         ((zerop bits)
  290.          (card16-put 2 (incf request-size))
  291.          (index-incf (buffer-boffset display) (* request-size 4)))
  292.       (declare (type mask16 bits)
  293.            (type fixnum request-size)
  294.            (type array-index i))
  295.       (when (oddp bits)
  296.         (card29-put (* (incf request-size) 4) (aref changes i))))))))
  297.  
  298. (defmacro with-attributes ((window &rest options) &body body)
  299.   `(let ((.with-attributes-reply-buffer. (get-window-attributes-buffer ,window)))
  300.      (declare (type reply-buffer .with-attributes-reply-buffer.))
  301.      (prog1 
  302.        (with-buffer-input (.with-attributes-reply-buffer. ,@options) ,@body)
  303.        (unless *window-attributes*
  304.      (deallocate-context .with-attributes-reply-buffer.)))))
  305. ;;
  306. ;; These two are twins (with-attributes with-geometry)
  307. ;; If you change one, you probably need to change the other...
  308. ;;
  309. (defmacro with-geometry ((window &rest options) &body body)
  310.   `(let ((.with-geometry-reply-buffer. (get-drawable-geometry-buffer ,window)))
  311.      (declare (type reply-buffer .with-geometry-reply-buffer.))
  312.      (prog1 
  313.        (with-buffer-input (.with-geometry-reply-buffer. ,@options) ,@body)
  314.        (unless *window-attributes*
  315.      (deallocate-context .with-geometry-reply-buffer.)))))
  316.  
  317. ;;;-----------------------------------------------------------------------------
  318. ;;; Group A: (for GetWindowAttributes)
  319. ;;;-----------------------------------------------------------------------------
  320.  
  321. (defun window-visual (window)
  322.   (declare (type window window))
  323.   (declare (values resource-id))
  324.   (with-attributes (window :sizes 32)
  325.     (resource-id-get 8)))
  326.  
  327. (defun window-visual-info (window)
  328.   (declare (type window window))
  329.   (declare (values visual-info))
  330.   (with-attributes (window :sizes 32)
  331.     (visual-info (window-display window) (resource-id-get 8))))
  332.  
  333. (defun window-class (window)
  334.   (declare (type window window))
  335.   (declare (values (member :input-output :input-only)))
  336.   (with-attributes (window :sizes 16)
  337.     (member16-get 12 :copy :input-output :input-only)))
  338.  
  339. (defun set-window-background (window background)
  340.   (declare (type window window)
  341.        (type (or (member :none :parent-relative) pixel pixmap) background))
  342.   (cond ((eq background :none) (change-window-attribute window 0 0))
  343.     ((eq background :parent-relative) (change-window-attribute window 0 1))
  344.     ((integerp background) ;; Background pixel
  345.      (change-window-attribute window 0 0) ;; pixmap :NONE
  346.      (change-window-attribute window 1 background))
  347.     ((type? background 'pixmap) ;; Background pixmap
  348.      (change-window-attribute window 0 (pixmap-id background)))
  349.     (t (x-type-error background '(or (member :none :parent-relative) integer pixmap))))
  350.   background)
  351.  
  352. #+Genera (eval-when (compile) (compiler:function-defined 'window-background))
  353.  
  354. (defsetf window-background set-window-background)
  355.  
  356. (defun set-window-border (window border)
  357.   (declare (type window window)
  358.        (type (or (member :copy) pixel pixmap) border))
  359.   (cond ((eq border :copy) (change-window-attribute window 2 0))
  360.     ((type? border 'pixmap) ;; Border pixmap
  361.      (change-window-attribute window 2 (pixmap-id border)))
  362.     ((integerp border) ;; Border pixel
  363.      (change-window-attribute window 3 border))
  364.     (t (x-type-error border '(or (member :copy) integer pixmap))))
  365.   border)
  366.  
  367. #+Genera (eval-when (compile) (compiler:function-defined 'window-border))
  368.  
  369. (defsetf window-border set-window-border)
  370.  
  371. (defun window-bit-gravity (window)
  372.   ;; setf'able
  373.   (declare (type window window))
  374.   (declare (values bit-gravity))
  375.   (with-attributes (window :sizes 8)
  376.     (member8-vector-get 14 *bit-gravity-vector*)))
  377.  
  378. (defun set-window-bit-gravity (window gravity)
  379.   (change-window-attribute
  380.     window 4 (encode-type (member-vector *bit-gravity-vector*) gravity))
  381.   gravity)
  382.  
  383. (defsetf window-bit-gravity set-window-bit-gravity)
  384.  
  385. (defun window-gravity (window)
  386.   ;; setf'able
  387.   (declare (type window window))
  388.   (declare (values win-gravity))
  389.   (with-attributes (window :sizes 8)
  390.     (member8-vector-get 15 *win-gravity-vector*)))
  391.  
  392. (defun set-window-gravity (window gravity)
  393.   (change-window-attribute
  394.     window 5 (encode-type (member-vector *win-gravity-vector*) gravity))
  395.   gravity)
  396.  
  397. (defsetf window-gravity set-window-gravity)
  398.  
  399. (defun window-backing-store (window)
  400.   ;; setf'able
  401.   (declare (type window window))
  402.   (declare (values (member :not-useful :when-mapped :always)))
  403.   (with-attributes (window :sizes 8)
  404.     (member8-get 1 :not-useful :when-mapped :always)))
  405.  
  406. (defun set-window-backing-store (window when)
  407.   (change-window-attribute
  408.     window 6 (encode-type (member :not-useful :when-mapped :always) when))
  409.   when)
  410.  
  411. (defsetf window-backing-store set-window-backing-store)
  412.  
  413. (defun window-backing-planes (window)
  414.   ;; setf'able
  415.   (declare (type window window))
  416.   (declare (values pixel))
  417.   (with-attributes (window :sizes 32)
  418.     (card32-get 16)))
  419.  
  420. (defun set-window-backing-planes (window planes)
  421.   (change-window-attribute window 7 (encode-type card32 planes))
  422.   planes)
  423.  
  424. (defsetf window-backing-planes set-window-backing-planes)
  425.  
  426. (defun window-backing-pixel (window)
  427.   ;; setf'able
  428.   (declare (type window window))
  429.   (declare (values pixel))
  430.   (with-attributes (window :sizes 32)
  431.     (card32-get 20)))
  432.  
  433. (defun set-window-backing-pixel (window pixel)
  434.   (change-window-attribute window 8 (encode-type card32 pixel))
  435.   pixel)
  436.  
  437. (defsetf window-backing-pixel set-window-backing-pixel)
  438.  
  439. (defun window-save-under (window)
  440.   ;; setf'able
  441.   (declare (type window window))
  442.   (declare (values (member :off :on)))
  443.   (with-attributes (window :sizes 8)
  444.     (member8-get 24 :off :on)))
  445.  
  446. (defun set-window-save-under (window when)
  447.   (change-window-attribute window 10 (encode-type (member :off :on) when))
  448.   when)
  449.  
  450. (defsetf window-save-under set-window-save-under)
  451.  
  452. (defun window-override-redirect (window)
  453.   ;; setf'able
  454.   (declare (type window window))
  455.   (declare (values (member :off :on)))
  456.   (with-attributes (window :sizes 8)
  457.     (member8-get 27 :off :on)))
  458.  
  459. (defun set-window-override-redirect (window when)
  460.   (change-window-attribute window 9 (encode-type (member :off :on) when))
  461.   when)
  462.  
  463. (defsetf window-override-redirect set-window-override-redirect)
  464.  
  465. (defun window-event-mask (window)
  466.   ;; setf'able
  467.   (declare (type window window))
  468.   (declare (values mask32))
  469.   (with-attributes (window :sizes 32)
  470.     (card32-get 36)))
  471.  
  472. (defsetf window-event-mask (window) (event-mask)
  473.   (let ((em (gensym)))
  474.     `(let ((,em ,event-mask))
  475.        (declare (type event-mask ,em))
  476.        (change-window-attribute ,window 11 (encode-event-mask ,em))
  477.        ,em)))
  478.  
  479. (defun window-do-not-propagate-mask (window)
  480.   ;; setf'able
  481.   (declare (type window window))
  482.   (declare (values mask32))
  483.   (with-attributes (window :sizes 32)
  484.     (card32-get 40)))
  485.  
  486. (defsetf window-do-not-propagate-mask (window) (device-event-mask)
  487.   (let ((em (gensym)))
  488.     `(let ((,em ,device-event-mask))
  489.        (declare (type device-event-mask ,em))
  490.        (change-window-attribute ,window 12 (encode-device-event-mask ,em))
  491.        ,em)))
  492.  
  493. (defun window-colormap (window)
  494.   (declare (type window window))
  495.   (declare (values (or null colormap)))
  496.   (with-attributes (window :sizes 32)
  497.     (let ((id (resource-id-get 28)))
  498.       (if (zerop id) nil
  499.     (lookup-colormap (window-display window) id)))))
  500.  
  501. (defun set-window-colormap (window colormap)
  502.   (change-window-attribute
  503.     window 13 (encode-type (or (member :copy) colormap) colormap))
  504.   colormap)
  505.  
  506. (defsetf window-colormap set-window-colormap)
  507.  
  508. (defun window-cursor (window)
  509.   (declare (type window window))
  510.   (declare (values cursor))
  511.   window
  512.   (error "~S can only be set" 'window-cursor))
  513.  
  514. (defun set-window-cursor (window cursor)
  515.   (change-window-attribute
  516.     window 14 (encode-type (or (member :none) cursor) cursor))
  517.   cursor)
  518.  
  519. (defsetf window-cursor set-window-cursor)
  520.  
  521. (defun window-colormap-installed-p (window)
  522.   (declare (type window window))
  523.   (declare (values boolean))
  524.   (with-attributes (window :sizes 8)
  525.     (boolean-get 25)))
  526.  
  527. (defun window-all-event-masks (window)
  528.   (declare (type window window))
  529.   (declare (values mask32))
  530.   (with-attributes (window :sizes 32)
  531.     (card32-get 32)))
  532.  
  533. (defun window-map-state (window)
  534.   (declare (type window window))
  535.   (declare (values (member :unmapped :unviewable :viewable)))
  536.   (with-attributes (window :sizes 8)
  537.     (member8-get 26 :unmapped :unviewable :viewable)))
  538.  
  539.  
  540. ;;;-----------------------------------------------------------------------------
  541. ;;; Group G: (for GetGeometry)
  542. ;;;-----------------------------------------------------------------------------
  543.  
  544. (defun drawable-root (drawable)
  545.   (declare (type drawable drawable))
  546.   (declare (values window))
  547.   (with-geometry (drawable :sizes 32)
  548.     (window-get 8 (drawable-display drawable))))
  549.  
  550. (defun drawable-x (drawable)
  551.   ;; setf'able
  552.   (declare (type drawable drawable))
  553.   (declare (values int16))
  554.   (with-geometry (drawable :sizes 16)
  555.     (int16-get 12)))
  556.  
  557. (defun set-drawable-x (drawable x)
  558.   (change-drawable-geometry drawable 0 (encode-type int16 x))
  559.   x)
  560.  
  561. (defsetf drawable-x set-drawable-x)
  562.  
  563. (defun drawable-y (drawable)
  564.   ;; setf'able
  565.   (declare (type drawable drawable))
  566.   (declare (values int16))
  567.   (with-geometry (drawable :sizes 16)
  568.     (int16-get 14)))
  569.  
  570. (defun set-drawable-y (drawable y)
  571.   (change-drawable-geometry drawable 1 (encode-type int16 y))
  572.   y)
  573.  
  574. (defsetf drawable-y set-drawable-y)
  575.  
  576. (defun drawable-width (drawable)
  577.   ;; setf'able
  578.   ;; Inside width, excluding border.
  579.   (declare (type drawable drawable))
  580.   (declare (values card16))
  581.   (with-geometry (drawable :sizes 16)
  582.     (card16-get 16)))
  583.  
  584. (defun set-drawable-width (drawable width)
  585.   (change-drawable-geometry drawable 2 (encode-type card16 width))
  586.   width)
  587.  
  588. (defsetf drawable-width set-drawable-width)
  589.  
  590. (defun drawable-height (drawable)
  591.   ;; setf'able
  592.   ;; Inside height, excluding border.
  593.   (declare (type drawable drawable))
  594.   (declare (values card16))
  595.   (with-geometry (drawable :sizes 16)
  596.     (card16-get 18)))
  597.  
  598. (defun set-drawable-height (drawable height)
  599.   (change-drawable-geometry drawable 3 (encode-type card16 height))
  600.   height)
  601.  
  602. (defsetf drawable-height set-drawable-height)
  603.  
  604. (defun drawable-depth (drawable)
  605.   (declare (type drawable drawable))
  606.   (declare (values card8))
  607.   (with-geometry (drawable :sizes 8)
  608.     (card8-get 1)))
  609.  
  610. (defun drawable-border-width (drawable)
  611.   ;; setf'able
  612.   (declare (type drawable drawable))
  613.   (declare (values integer))
  614.   (with-geometry (drawable :sizes 16)
  615.     (card16-get 20)))
  616.  
  617. (defun set-drawable-border-width (drawable width)
  618.   (change-drawable-geometry drawable 4 (encode-type card16 width))
  619.   width)
  620.  
  621. (defsetf drawable-border-width set-drawable-border-width)
  622.  
  623. (defun set-window-priority (mode window sibling)
  624.   (declare (type (member :above :below :top-if :bottom-if :opposite) mode)
  625.        (type window window)
  626.        (type (or null window) sibling))
  627.   (with-state (window)
  628.     (change-drawable-geometry
  629.       window 6 (encode-type (member :above :below :top-if :bottom-if :opposite) mode))
  630.     (when sibling
  631.       (change-drawable-geometry window 5 (encode-type window sibling))))
  632.   mode)
  633.  
  634. #+Genera (eval-when (compile) (compiler:function-defined 'window-priority))
  635.  
  636. (defsetf window-priority (window &optional sibling) (mode)
  637.   ;; A bit strange, but retains setf form.
  638.   `(set-window-priority ,mode ,window ,sibling))
  639.