From ad7b4049546bab480594621a011acfebac151883 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sun, 12 Jan 2020 16:52:08 +0100 Subject: [PATCH] cosmetic: clean up whitespace and reindent the file manager.lisp --- manager.lisp | 686 ++++++++++++++++++++++++++------------------------- 1 file changed, 344 insertions(+), 342 deletions(-) diff --git a/manager.lisp b/manager.lisp index 8ffc76e..65e5955 100644 --- a/manager.lisp +++ b/manager.lisp @@ -30,8 +30,8 @@ (defun set-string-property (window property string) (declare (type window window) - (type keyword property) - (type stringable string)) + (type keyword property) + (type stringable string)) (change-property window property (string string) :STRING 8 :transform #'char->card8) string) @@ -39,7 +39,7 @@ (declare (type window window)) (declare (clx-values string)) (get-property window :WM_ICON_NAME :type :STRING - :result-type 'string :transform #'card8->char)) + :result-type 'string :transform #'card8->char)) (defsetf wm-icon-name (window) (name) `(set-string-property ,window :WM_ICON_NAME ,name)) @@ -48,7 +48,7 @@ (declare (type window window)) (declare (clx-values string)) (get-property window :WM_CLIENT_MACHINE :type :STRING - :result-type 'string :transform #'card8->char)) + :result-type 'string :transform #'card8->char)) (defsetf wm-client-machine (window) (name) `(set-string-property ,window :WM_CLIENT_MACHINE ,name)) @@ -60,63 +60,63 @@ (declare (type (or null (vector card8)) value)) (when value (let* ((name-len (position 0 (the (vector card8) value))) - (name (subseq (the (vector card8) value) 0 name-len)) - (class - (when name-len - (subseq (the (vector card8) value) (1+ name-len) - (position 0 (the (vector card8) value) :start (1+ name-len)))))) - (values (and (plusp (length name)) (map 'string #'card8->char name)) - (and (plusp (length class)) (map 'string #'card8->char class))))))) + (name (subseq (the (vector card8) value) 0 name-len)) + (class + (when name-len + (subseq (the (vector card8) value) (1+ name-len) + (position 0 (the (vector card8) value) :start (1+ name-len)))))) + (values (and (plusp (length name)) (map 'string #'card8->char name)) + (and (plusp (length class)) (map 'string #'card8->char class))))))) (defun set-wm-class (window resource-name resource-class) (declare (type window window) - (type (or null stringable) resource-name resource-class)) + (type (or null stringable) resource-name resource-class)) (change-property window :WM_CLASS - (concatenate '(vector card8) - (map '(vector card8) #'char->card8 - (string (or resource-name ""))) - #(0) - (map '(vector card8) #'char->card8 - (string (or resource-class ""))) - #(0)) - :string 8) + (concatenate '(vector card8) + (map '(vector card8) #'char->card8 + (string (or resource-name ""))) + #(0) + (map '(vector card8) #'char->card8 + (string (or resource-class ""))) + #(0)) + :string 8) (values)) (defun wm-command (window) - ;; Returns a list whose car is the command and + ;; Returns a list whose car is the command and ;; whose cdr is the list of arguments (declare (type window window)) (declare (clx-values list)) (do* ((command-string (get-property window :WM_COMMAND :type :STRING - :result-type '(vector card8))) - (command nil) - (start 0 (1+ end)) - (end 0) - (len (length command-string))) + :result-type '(vector card8))) + (command nil) + (start 0 (1+ end)) + (end 0) + (len (length command-string))) ((>= start len) (nreverse command)) (setq end (position 0 command-string :start start)) (push (map 'string #'card8->char (subseq command-string start end)) - command))) + command))) (defsetf wm-command set-wm-command) (defun set-wm-command (window command) ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or ;; equivalent), with elements of command separated by NULL characters. This - ;; enables + ;; enables ;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window))) ;; to recover a lisp command. (declare (type window window) - (type list command)) + (type list command)) (change-property window :WM_COMMAND - (apply #'concatenate '(vector card8) - (mapcan #'(lambda (c) - (list (map '(vector card8) #'char->card8 - (with-output-to-string (stream) - (with-standard-io-syntax - (prin1 c stream)))) - #(0))) - command)) - :string 8) + (apply #'concatenate '(vector card8) + (mapcan #'(lambda (c) + (list (map '(vector card8) #'char->card8 + (with-output-to-string (stream) + (with-standard-io-syntax + (prin1 c stream)))) + #(0))) + command)) + :string 8) command) ;;----------------------------------------------------------------------------- @@ -145,47 +145,47 @@ (defsetf wm-hints set-wm-hints) (defun set-wm-hints (window wm-hints) (declare (type window window) - (type wm-hints wm-hints)) + (type wm-hints wm-hints)) (declare (clx-values wm-hints)) (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32) wm-hints) (defun decode-wm-hints (vector display) (declare (type (simple-vector *) vector) - (type display display)) + (type display display)) (declare (clx-values wm-hints)) (let ((hint-mask (1- (ash 1 29))) - (input-hint 0) - (state-hint 1) - (icon-pixmap-hint 2) - (icon-window-hint 3) - (icon-position-hint 4) - (icon-mask-hint 5) - (window-group-hint 6)) + (input-hint 0) + (state-hint 1) + (icon-pixmap-hint 2) + (icon-window-hint 3) + (icon-position-hint 4) + (icon-mask-hint 5) + (window-group-hint 6)) (let ((flags (aref vector 0)) - (hints (make-wm-hints)) - (%buffer display)) + (hints (make-wm-hints)) + (%buffer display)) (declare (type card32 flags) - (type wm-hints hints) - (type display %buffer)) + (type wm-hints hints) + (type display %buffer)) (setf (wm-hints-flags hints) flags) (when (logbitp input-hint flags) - (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) + (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1)))) (when (logbitp state-hint flags) - (setf (wm-hints-initial-state hints) - (decode-type (member :dont-care :normal :zoom :iconic :inactive) - (aref vector 2)))) + (setf (wm-hints-initial-state hints) + (decode-type (member :dont-care :normal :zoom :iconic :inactive) + (aref vector 2)))) (when (logbitp icon-pixmap-hint flags) - (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) + (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3)))) (when (logbitp icon-window-hint flags) - (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) + (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4)))) (when (logbitp icon-position-hint flags) - (setf (wm-hints-icon-x hints) (logand hint-mask (aref vector 5)) - (wm-hints-icon-y hints) (logand hint-mask (aref vector 6)))) + (setf (wm-hints-icon-x hints) (logand hint-mask (aref vector 5)) + (wm-hints-icon-y hints) (logand hint-mask (aref vector 6)))) (when (logbitp icon-mask-hint flags) - (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) + (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7)))) (when (and (logbitp window-group-hint flags) (> (length vector) 7)) - (setf (wm-hints-window-group hints) (logand hint-mask (aref vector 8)))) + (setf (wm-hints-window-group hints) (logand hint-mask (aref vector 8)))) hints))) @@ -193,41 +193,41 @@ (declare (type wm-hints wm-hints)) (declare (clx-values simple-vector)) (let ((input-hint #b1) - (state-hint #b10) - (icon-pixmap-hint #b100) - (icon-window-hint #b1000) - (icon-position-hint #b10000) - (icon-mask-hint #b100000) - (window-group-hint #b1000000) - (mask #b1111111) - ) + (state-hint #b10) + (icon-pixmap-hint #b100) + (icon-window-hint #b1000) + (icon-position-hint #b10000) + (icon-mask-hint #b100000) + (window-group-hint #b1000000) + (mask #b1111111) + ) (let ((vector (make-array 9 :initial-element 0)) - (flags 0)) + (flags 0)) (declare (type (simple-vector 9) vector) - (type card16 flags)) + (type card16 flags)) (when (wm-hints-input wm-hints) - (setf flags input-hint - (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) + (setf flags input-hint + (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints)))) (when (wm-hints-initial-state wm-hints) - (setf flags (logior flags state-hint) - (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) - (wm-hints-initial-state wm-hints)))) + (setf flags (logior flags state-hint) + (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive) + (wm-hints-initial-state wm-hints)))) (when (wm-hints-icon-pixmap wm-hints) - (setf flags (logior flags icon-pixmap-hint) - (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) + (setf flags (logior flags icon-pixmap-hint) + (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints)))) (when (wm-hints-icon-window wm-hints) - (setf flags (logior flags icon-window-hint) - (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) + (setf flags (logior flags icon-window-hint) + (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints)))) (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints)) - (setf flags (logior flags icon-position-hint) - (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) - (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) + (setf flags (logior flags icon-position-hint) + (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints)) + (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints)))) (when (wm-hints-icon-mask wm-hints) - (setf flags (logior flags icon-mask-hint) - (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) + (setf flags (logior flags icon-mask-hint) + (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints)))) (when (wm-hints-window-group wm-hints) - (setf flags (logior flags window-group-hint) - (aref vector 8) (wm-hints-window-group wm-hints))) + (setf flags (logior flags window-group-hint) + (aref vector 8) (wm-hints-window-group wm-hints))) (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask))) vector))) @@ -268,7 +268,7 @@ (defsetf wm-normal-hints set-wm-normal-hints) (defun set-wm-normal-hints (window hints) (declare (type window window) - (type wm-size-hints hints)) + (type wm-size-hints hints)) (declare (clx-values wm-size-hints)) (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) hints) @@ -284,7 +284,7 @@ ;;; OBSOLETE (defun set-wm-zoom-hints (window hints) (declare (type window window) - (type wm-size-hints hints)) + (type wm-size-hints hints)) (declare (clx-values wm-size-hints)) (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32) hints) @@ -294,22 +294,22 @@ (declare (clx-values (or null wm-size-hints))) (when vector (let ((flags (aref vector 0)) - (hints (make-wm-size-hints))) + (hints (make-wm-size-hints))) (declare (type card16 flags) - (type wm-size-hints hints)) + (type wm-size-hints hints)) (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags)) (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags)) (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags)) (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags)) (when (logbitp 4 flags) - (setf (wm-size-hints-min-width hints) (aref vector 5) - (wm-size-hints-min-height hints) (aref vector 6))) + (setf (wm-size-hints-min-width hints) (aref vector 5) + (wm-size-hints-min-height hints) (aref vector 6))) (when (logbitp 5 flags) - (setf (wm-size-hints-max-width hints) (aref vector 7) - (wm-size-hints-max-height hints) (aref vector 8))) + (setf (wm-size-hints-max-width hints) (aref vector 7) + (wm-size-hints-max-height hints) (aref vector 8))) (when (logbitp 6 flags) - (setf (wm-size-hints-width-inc hints) (aref vector 9) - (wm-size-hints-height-inc hints) (aref vector 10))) + (setf (wm-size-hints-width-inc hints) (aref vector 9) + (wm-size-hints-height-inc hints) (aref vector 10))) (when (logbitp 7 flags) (let ((low (aref vector 12))) (unless (zerop low) @@ -318,36 +318,36 @@ (unless (zerop low) (setf (wm-size-hints-max-aspect hints) (/ (aref vector 13) low))))) (when (> (length vector) 15) - ;; This test is for backwards compatibility since old Xlib programs - ;; can set a size-hints structure that is too small. See ICCCM. - (when (logbitp 8 flags) - (setf (wm-size-hints-base-width hints) (aref vector 15) - (wm-size-hints-base-height hints) (aref vector 16))) - (when (logbitp 9 flags) - (setf (wm-size-hints-win-gravity hints) - ;; many games don't initialize win-gravity correctly, - ;; so we need to bring it to within the correct range - ;; ICCCM specifies a default gravity of NorthWest - (let ((gravity (aref vector 17))) - (if (< 0 gravity #.(length +win-gravity-vector+)) - (decode-type (member-vector +win-gravity-vector+) gravity) - :north-west))))) + ;; This test is for backwards compatibility since old Xlib programs + ;; can set a size-hints structure that is too small. See ICCCM. + (when (logbitp 8 flags) + (setf (wm-size-hints-base-width hints) (aref vector 15) + (wm-size-hints-base-height hints) (aref vector 16))) + (when (logbitp 9 flags) + (setf (wm-size-hints-win-gravity hints) + ;; many games don't initialize win-gravity correctly, + ;; so we need to bring it to within the correct range + ;; ICCCM specifies a default gravity of NorthWest + (let ((gravity (aref vector 17))) + (if (< 0 gravity #.(length +win-gravity-vector+)) + (decode-type (member-vector +win-gravity-vector+) gravity) + :north-west))))) ;; Obsolete fields (when (or (logbitp 0 flags) (logbitp 2 flags)) - (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) - (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) + (setf (wm-size-hints-x hints) (card32->int32 (aref vector 1)) + (wm-size-hints-y hints) (card32->int32 (aref vector 2)))) (when (or (logbitp 1 flags) (logbitp 3 flags)) - (setf (wm-size-hints-width hints) (aref vector 3) - (wm-size-hints-height hints) (aref vector 4))) + (setf (wm-size-hints-width hints) (aref vector 3) + (wm-size-hints-height hints) (aref vector 4))) hints))) (defun encode-wm-size-hints (hints) (declare (type wm-size-hints hints)) (declare (clx-values simple-vector)) (let ((vector (make-array 18 :initial-element 0)) - (flags 0)) + (flags 0)) (declare (type (simple-vector 18) vector) - (type card16 flags)) + (type card16 flags)) (when (wm-size-hints-user-specified-position-p hints) (setf (ldb (byte 1 0) flags) 1)) (when (wm-size-hints-user-specified-size-p hints) @@ -358,47 +358,47 @@ (setf (ldb (byte 1 3) flags) 1)) (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints)) (setf (ldb (byte 1 4) flags) 1 - (aref vector 5) (wm-size-hints-min-width hints) - (aref vector 6) (wm-size-hints-min-height hints))) + (aref vector 5) (wm-size-hints-min-width hints) + (aref vector 6) (wm-size-hints-min-height hints))) (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints)) (setf (ldb (byte 1 5) flags) 1 - (aref vector 7) (wm-size-hints-max-width hints) - (aref vector 8) (wm-size-hints-max-height hints))) + (aref vector 7) (wm-size-hints-max-width hints) + (aref vector 8) (wm-size-hints-max-height hints))) (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints)) (setf (ldb (byte 1 6) flags) 1 - (aref vector 9) (wm-size-hints-width-inc hints) - (aref vector 10) (wm-size-hints-height-inc hints))) + (aref vector 9) (wm-size-hints-width-inc hints) + (aref vector 10) (wm-size-hints-height-inc hints))) (let ((min-aspect (wm-size-hints-min-aspect hints)) - (max-aspect (wm-size-hints-max-aspect hints))) + (max-aspect (wm-size-hints-max-aspect hints))) (when (and min-aspect max-aspect) - (setf (ldb (byte 1 7) flags) 1 - min-aspect (rationalize min-aspect) - max-aspect (rationalize max-aspect) - (aref vector 11) (numerator min-aspect) - (aref vector 12) (denominator min-aspect) - (aref vector 13) (numerator max-aspect) - (aref vector 14) (denominator max-aspect)))) + (setf (ldb (byte 1 7) flags) 1 + min-aspect (rationalize min-aspect) + max-aspect (rationalize max-aspect) + (aref vector 11) (numerator min-aspect) + (aref vector 12) (denominator min-aspect) + (aref vector 13) (numerator max-aspect) + (aref vector 14) (denominator max-aspect)))) (when (and (wm-size-hints-base-width hints) - (wm-size-hints-base-height hints)) + (wm-size-hints-base-height hints)) (setf (ldb (byte 1 8) flags) 1 - (aref vector 15) (wm-size-hints-base-width hints) - (aref vector 16) (wm-size-hints-base-height hints))) + (aref vector 15) (wm-size-hints-base-width hints) + (aref vector 16) (wm-size-hints-base-height hints))) (when (wm-size-hints-win-gravity hints) (setf (ldb (byte 1 9) flags) 1 - (aref vector 17) (encode-type - (member-vector +win-gravity-vector+) - (wm-size-hints-win-gravity hints)))) + (aref vector 17) (encode-type + (member-vector +win-gravity-vector+) + (wm-size-hints-win-gravity hints)))) ;; Obsolete fields - (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) + (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) (unless (wm-size-hints-user-specified-position-p hints) - (setf (ldb (byte 1 2) flags) 1)) + (setf (ldb (byte 1 2) flags) 1)) (setf (aref vector 1) (int32->card32 (wm-size-hints-x hints)) - (aref vector 2) (int32->card32 (wm-size-hints-y hints)))) + (aref vector 2) (int32->card32 (wm-size-hints-y hints)))) (when (and (wm-size-hints-width hints) (wm-size-hints-height hints)) (unless (wm-size-hints-user-specified-size-p hints) - (setf (ldb (byte 1 3) flags) 1)) + (setf (ldb (byte 1 3) flags) 1)) (setf (aref vector 3) (wm-size-hints-width hints) - (aref vector 4) (wm-size-hints-height hints))) + (aref vector 4) (wm-size-hints-height hints))) (setf (aref vector 0) flags) vector)) @@ -414,23 +414,23 @@ (declare (type (or null (simple-vector 6)) vector)) (when vector (make-wm-size-hints - :min-width (aref vector 0) - :min-height (aref vector 1) - :max-width (aref vector 2) - :max-height (aref vector 3) - :width-inc (aref vector 4) - :height-inc (aref vector 5))))) - + :min-width (aref vector 0) + :min-height (aref vector 1) + :max-width (aref vector 2) + :max-height (aref vector 3) + :width-inc (aref vector 4) + :height-inc (aref vector 5))))) + (defsetf icon-sizes set-icon-sizes) (defun set-icon-sizes (window wm-size-hints) (declare (type window window) - (type wm-size-hints wm-size-hints)) + (type wm-size-hints wm-size-hints)) (let ((vector (vector (wm-size-hints-min-width wm-size-hints) - (wm-size-hints-min-height wm-size-hints) - (wm-size-hints-max-width wm-size-hints) - (wm-size-hints-max-height wm-size-hints) - (wm-size-hints-width-inc wm-size-hints) - (wm-size-hints-height-inc wm-size-hints)))) + (wm-size-hints-min-height wm-size-hints) + (wm-size-hints-max-width wm-size-hints) + (wm-size-hints-max-height wm-size-hints) + (wm-size-hints-width-inc wm-size-hints) + (wm-size-hints-height-inc wm-size-hints)))) (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32) wm-size-hints)) @@ -444,9 +444,9 @@ (defsetf wm-protocols set-wm-protocols) (defun set-wm-protocols (window protocols) (change-property window :WM_PROTOCOLS - (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) - protocols) - :ATOM 32) + (map 'list #'(lambda (atom) (intern-atom (window-display window) atom)) + protocols) + :ATOM 32) protocols) ;;----------------------------------------------------------------------------- @@ -454,13 +454,13 @@ (defun wm-colormap-windows (window) (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW - :transform #'(lambda (id) - (lookup-window (window-display window) id))))) + :transform #'(lambda (id) + (lookup-window (window-display window) id))))) (defsetf wm-colormap-windows set-wm-colormap-windows) (defun set-wm-colormap-windows (window colormap-windows) (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32 - :transform #'window-id) + :transform #'window-id) colormap-windows) ;;----------------------------------------------------------------------------- @@ -479,51 +479,51 @@ ;;----------------------------------------------------------------------------- ;; Set-WM-Properties -(defun set-wm-properties (window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints zoom-hints - ;; the following are used for wm-normal-hints - (user-specified-position-p nil usppp) - (user-specified-size-p nil usspp) - (program-specified-position-p nil psppp) - (program-specified-size-p nil psspp) - x y width height min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group) +(defun set-wm-properties (window &rest options &key + name icon-name resource-name resource-class command + client-machine hints normal-hints zoom-hints + ;; the following are used for wm-normal-hints + (user-specified-position-p nil usppp) + (user-specified-size-p nil usspp) + (program-specified-position-p nil psppp) + (program-specified-size-p nil psspp) + x y width height min-width min-height max-width max-height + width-inc height-inc min-aspect max-aspect + base-width base-height win-gravity + ;; the following are used for wm-hints + input initial-state icon-pixmap icon-window + icon-x icon-y icon-mask window-group) ;; Set properties for WINDOW. - (declare (arglist window &rest options &key - name icon-name resource-name resource-class command - client-machine hints normal-hints - ;; the following are used for wm-normal-hints - user-specified-position-p user-specified-size-p - program-specified-position-p program-specified-size-p - min-width min-height max-width max-height - width-inc height-inc min-aspect max-aspect - base-width base-height win-gravity - ;; the following are used for wm-hints - input initial-state icon-pixmap icon-window - icon-x icon-y icon-mask window-group)) + (declare (arglist window &rest options &key + name icon-name resource-name resource-class command + client-machine hints normal-hints + ;; the following are used for wm-normal-hints + user-specified-position-p user-specified-size-p + program-specified-position-p program-specified-size-p + min-width min-height max-width max-height + width-inc height-inc min-aspect max-aspect + base-width base-height win-gravity + ;; the following are used for wm-hints + input initial-state icon-pixmap icon-window + icon-x icon-y icon-mask window-group)) (declare (type window window) - (type (or null stringable) name icon-name resource-name resource-class client-machine) - (type (or null list) command) - (type (or null wm-hints) hints) - (type (or null wm-size-hints) normal-hints zoom-hints) - (type generalized-boolean user-specified-position-p user-specified-size-p) - (type generalized-boolean program-specified-position-p program-specified-size-p) - (type (or null int32) x y) - (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) - (type (or null win-gravity) win-gravity) - (type (or null number) min-aspect max-aspect) - (type (or null (member :off :on)) input) - (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) - (type (or null pixmap) icon-pixmap icon-mask) - (type (or null window) icon-window) - (type (or null card32) icon-x icon-y) - (type (or null resource-id) window-group) - (dynamic-extent options)) + (type (or null stringable) name icon-name resource-name resource-class client-machine) + (type (or null list) command) + (type (or null wm-hints) hints) + (type (or null wm-size-hints) normal-hints zoom-hints) + (type generalized-boolean user-specified-position-p user-specified-size-p) + (type generalized-boolean program-specified-position-p program-specified-size-p) + (type (or null int32) x y) + (type (or null card32) width height min-width min-height max-width max-height width-inc height-inc base-width base-height) + (type (or null win-gravity) win-gravity) + (type (or null number) min-aspect max-aspect) + (type (or null (member :off :on)) input) + (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state) + (type (or null pixmap) icon-pixmap icon-mask) + (type (or null window) icon-window) + (type (or null card32) icon-x icon-y) + (type (or null resource-id) window-group) + (dynamic-extent options)) (when name (setf (wm-name window) name)) (when icon-name (setf (wm-icon-name window) icon-name)) (when client-machine (setf (wm-client-machine window) client-machine)) @@ -532,51 +532,51 @@ (when command (setf (wm-command window) command)) ;; WM-HINTS (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window - :icon-x :icon-y :icon-mask :window-group)) - (when (getf options arg) (return t))) + :icon-x :icon-y :icon-mask :window-group)) + (when (getf options arg) (return t))) (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints)))) - (when input (setf (wm-hints-input wm-hints) input)) - (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) - (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) - (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) - (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) - (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) - (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) - (when window-group (setf (wm-hints-window-group wm-hints) window-group)) - (setf (wm-hints window) wm-hints)) + (when input (setf (wm-hints-input wm-hints) input)) + (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state)) + (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap)) + (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window)) + (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x)) + (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y)) + (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask)) + (when window-group (setf (wm-hints-window-group wm-hints) window-group)) + (setf (wm-hints window) wm-hints)) (when hints (setf (wm-hints window) hints))) ;; WM-NORMAL-HINTS (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height - :width-inc :height-inc :min-aspect :max-aspect - :user-specified-position-p :user-specified-size-p - :program-specified-position-p :program-specified-size-p - :base-width :base-height :win-gravity)) - (when (getf options arg) (return t))) + :width-inc :height-inc :min-aspect :max-aspect + :user-specified-position-p :user-specified-size-p + :program-specified-position-p :program-specified-size-p + :base-width :base-height :win-gravity)) + (when (getf options arg) (return t))) (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints)))) - (when x (setf (wm-size-hints-x size) x)) - (when y (setf (wm-size-hints-y size) y)) - (when width (setf (wm-size-hints-width size) width)) - (when height (setf (wm-size-hints-height size) height)) - (when min-width (setf (wm-size-hints-min-width size) min-width)) - (when min-height (setf (wm-size-hints-min-height size) min-height)) - (when max-width (setf (wm-size-hints-max-width size) max-width)) - (when max-height (setf (wm-size-hints-max-height size) max-height)) - (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) - (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) - (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) - (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) - (when base-width (setf (wm-size-hints-base-width size) base-width)) - (when base-height (setf (wm-size-hints-base-height size) base-height)) - (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) - (when usppp - (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) - (when usspp - (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) - (when psppp - (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) - (when psspp - (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) - (setf (wm-normal-hints window) size)) + (when x (setf (wm-size-hints-x size) x)) + (when y (setf (wm-size-hints-y size) y)) + (when width (setf (wm-size-hints-width size) width)) + (when height (setf (wm-size-hints-height size) height)) + (when min-width (setf (wm-size-hints-min-width size) min-width)) + (when min-height (setf (wm-size-hints-min-height size) min-height)) + (when max-width (setf (wm-size-hints-max-width size) max-width)) + (when max-height (setf (wm-size-hints-max-height size) max-height)) + (when width-inc (setf (wm-size-hints-width-inc size) width-inc)) + (when height-inc (setf (wm-size-hints-height-inc size) height-inc)) + (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect)) + (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect)) + (when base-width (setf (wm-size-hints-base-width size) base-width)) + (when base-height (setf (wm-size-hints-base-height size) base-height)) + (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity)) + (when usppp + (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p)) + (when usspp + (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p)) + (when psppp + (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p)) + (when psspp + (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p)) + (setf (wm-normal-hints window) size)) (when normal-hints (setf (wm-normal-hints window) normal-hints))) (when zoom-hints (setf (wm-zoom-hints window) zoom-hints)) ) @@ -591,20 +591,20 @@ (defun iconify-window (window screen) (declare (type window window) - (type screen screen)) + (type screen screen)) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :client-message '(:substructure-redirect :substructure-notify) - :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) + :window window :format 32 :type :WM_CHANGE_STATE :data (list 3)))) (defun withdraw-window (window screen) (declare (type window window) - (type screen screen)) + (type screen screen)) (unmap-window window) (let ((root (screen-root screen))) (declare (type window root)) (send-event root :unmap-notify '(:substructure-redirect :substructure-notify) - :window window :event-window root :configure-p nil))) + :window window :event-window root :configure-p nil))) ;;----------------------------------------------------------------------------- @@ -617,145 +617,148 @@ (mult-color nil :type (or null color)) (visual nil :type (or null visual-info)) (kill nil :type (or (member nil :release-by-freeing-colormap) - drawable gcontext cursor colormap font))) + drawable gcontext cursor colormap font))) (defun rgb-colormaps (window property) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (list (make-standard-colormap - :colormap (lookup-colormap (window-display window) (aref prop 0)) - :base-pixel (aref prop 7) - :max-color (make-color :red (card16->rgb-val (aref prop 1)) - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - :mult-color (make-color :red (card16->rgb-val (aref prop 2)) - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))) - :visual (and (<= 9 (length prop)) - (visual-info (window-display window) (aref prop 8))) - :kill (and (<= 10 (length prop)) - (let ((killid (aref prop 9))) - (if (= killid 1) - :release-by-freeing-colormap - (lookup-resource-id (window-display window) killid))))))))) + :colormap (lookup-colormap (window-display window) (aref prop 0)) + :base-pixel (aref prop 7) + :max-color (make-color :red (card16->rgb-val (aref prop 1)) + :green (card16->rgb-val (aref prop 3)) + :blue (card16->rgb-val (aref prop 5))) + :mult-color (make-color :red (card16->rgb-val (aref prop 2)) + :green (card16->rgb-val (aref prop 4)) + :blue (card16->rgb-val (aref prop 6))) + :visual (and (<= 9 (length prop)) + (visual-info (window-display window) (aref prop 8))) + :kill (and (<= 10 (length prop)) + (let ((killid (aref prop 9))) + (if (= killid 1) + :release-by-freeing-colormap + (lookup-resource-id (window-display window) killid))))))))) (defsetf rgb-colormaps set-rgb-colormaps) (defun set-rgb-colormaps (window property maps) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type list maps)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) + property) + (type list maps)) (let ((prop (make-array (* 10 (length maps)) :element-type 'card32)) - (index -1)) + (index -1)) (dolist (map maps) (setf (aref prop (incf index)) - (encode-type colormap (standard-colormap-colormap map))) + (encode-type colormap (standard-colormap-colormap map))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-max-color map)))) + (encode-type rgb-val (color-red (standard-colormap-max-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) + (encode-type rgb-val (color-red (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-max-color map)))) + (encode-type rgb-val (color-green (standard-colormap-max-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) + (encode-type rgb-val (color-green (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) + (encode-type rgb-val (color-blue (standard-colormap-max-color map)))) (setf (aref prop (incf index)) - (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) + (encode-type rgb-val (color-blue (standard-colormap-mult-color map)))) (setf (aref prop (incf index)) - (standard-colormap-base-pixel map)) + (standard-colormap-base-pixel map)) (setf (aref prop (incf index)) - (visual-info-id (standard-colormap-visual map))) + (visual-info-id (standard-colormap-visual map))) (setf (aref prop (incf index)) - (let ((kill (standard-colormap-kill map))) - (etypecase kill - (symbol - (ecase kill - ((nil) 0) - ((:release-by-freeing-colormap) 1))) - (drawable (drawable-id kill)) - (gcontext (gcontext-id kill)) - (cursor (cursor-id kill)) - (colormap (colormap-id kill)) - (font (font-id kill)))))) + (let ((kill (standard-colormap-kill map))) + (etypecase kill + (symbol + (ecase kill + ((nil) 0) + ((:release-by-freeing-colormap) 1))) + (drawable (drawable-id kill)) + (gcontext (gcontext-id kill)) + (cursor (cursor-id kill)) + (colormap (colormap-id kill)) + (font (font-id kill)))))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;; OBSOLETE (defun get-standard-colormap (window property) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) + property)) (declare (clx-values colormap base-pixel max-color mult-color)) (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector))) (declare (type (or null simple-vector) prop)) (when prop (values (lookup-colormap (window-display window) (aref prop 0)) - (aref prop 7) ;Base Pixel - (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color - :green (card16->rgb-val (aref prop 3)) - :blue (card16->rgb-val (aref prop 5))) - (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color - :green (card16->rgb-val (aref prop 4)) - :blue (card16->rgb-val (aref prop 6))))))) + (aref prop 7) ;Base Pixel + (make-color :red (card16->rgb-val (aref prop 1)) ;Max Color + :green (card16->rgb-val (aref prop 3)) + :blue (card16->rgb-val (aref prop 5))) + (make-color :red (card16->rgb-val (aref prop 2)) ;Mult color + :green (card16->rgb-val (aref prop 4)) + :blue (card16->rgb-val (aref prop 6))))))) ;;; OBSOLETE (defun set-standard-colormap (window property colormap base-pixel max-color mult-color) (declare (type window window) - (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP - :RGB_GREEN_MAP :RGB_BLUE_MAP) property) - (type colormap colormap) - (type pixel base-pixel) - (type color max-color mult-color)) + (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP + :RGB_GREEN_MAP :RGB_BLUE_MAP) + property) + (type colormap colormap) + (type pixel base-pixel) + (type color max-color mult-color)) (let ((prop (vector (encode-type colormap colormap) - (encode-type rgb-val (color-red max-color)) - (encode-type rgb-val (color-red mult-color)) - (encode-type rgb-val (color-green max-color)) - (encode-type rgb-val (color-green mult-color)) - (encode-type rgb-val (color-blue max-color)) - (encode-type rgb-val (color-blue mult-color)) - base-pixel))) + (encode-type rgb-val (color-red max-color)) + (encode-type rgb-val (color-red mult-color)) + (encode-type rgb-val (color-green max-color)) + (encode-type rgb-val (color-green mult-color)) + (encode-type rgb-val (color-blue max-color)) + (encode-type rgb-val (color-blue mult-color)) + base-pixel))) (change-property window property prop :RGB_COLOR_MAP 32))) ;;----------------------------------------------------------------------------- ;; Cut-Buffers (defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string) - (transform #'card8->char) (start 0) end) + (transform #'card8->char) (start 0) end) ;; Return the contents of cut-buffer BUFFER (declare (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type array-index start) - (type (or null array-index) end) - (type t result-type) ;a sequence type - (type (or null (function (integer) t)) transform)) + (type (integer 0 7) buffer) + (type xatom type) + (type array-index start) + (type (or null array-index) end) + (type t result-type) ;a sequence type + (type (or null (function (integer) t)) transform)) (declare (clx-values sequence type format bytes-after)) (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) + (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) + buffer))) (get-property root property :type type :result-type result-type - :start start :end end :transform transform))) + :start start :end end :transform transform))) (defun (setf cut-buffer) - (data display &key (buffer 0) (type :STRING) (format 8) - (start 0) end (transform #'char->card8)) + (data display &key (buffer 0) (type :STRING) (format 8) + (start 0) end (transform #'char->card8)) (declare (type sequence data) - (type display display) - (type (integer 0 7) buffer) - (type xatom type) - (type (member 8 16 32) format) - (type array-index start) - (type (or null array-index) end) - (type (or null (function (integer) t)) transform)) + (type display display) + (type (integer 0 7) buffer) + (type xatom type) + (type (member 8 16 32) format) + (type array-index start) + (type (or null array-index) end) + (type (or null (function (integer) t)) transform)) (let* ((root (screen-root (first (display-roots display)))) - (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 - :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) - buffer))) + (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3 + :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7) + buffer))) (change-property root property data type format :transform transform :start start :end end) data)) @@ -763,15 +766,14 @@ ;; Positive rotates left, negative rotates right (opposite of actual protocol request). ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors. (declare (type display display) - (type int16 delta) - (type generalized-boolean careful-p)) + (type int16 delta) + (type generalized-boolean careful-p)) (let* ((root (screen-root (first (display-roots display)))) - (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 - :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) + (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3 + :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7))) (when careful-p (let ((props (list-properties root))) - (dotimes (i 8) - (unless (member (aref buffers i) props) - (setf (cut-buffer display :buffer i) ""))))) + (dotimes (i 8) + (unless (member (aref buffers i) props) + (setf (cut-buffer display :buffer i) ""))))) (rotate-properties root buffers delta))) -