xwem / lisp / xwem-macros.el

;;; xwem-macros.el --- Generic XWEM's macros.

;; Copyright (C) 2003 by Free Software Foundation, Inc.

;; Author: Zajcev Evgeny <>
;; Created: 1 Sep 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id$

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:


;;; Code:

(defmacro xwem-misc-aref0 (vec)
  `(aref ,vec 0))

(defmacro xwem-misc-aref1 (vec)
  `(aref ,vec 1))

(defmacro xwem-misc-aref2 (vec)
  `(aref ,vec 2))

(defmacro xwem-misc-aref3 (vec)
  `(aref ,vec 3))

(defmacro xwem-misc-aref4 (vec)
  `(aref ,vec 4))

(defmacro xwem-misc-aref5 (vec)
  `(aref ,vec 5))

(defmacro xwem-misc-aref6 (vec)
  `(aref ,vec 6))

(defmacro xwem-misc-aref7 (vec)
  `(aref ,vec 7))

(defmacro xwem-misc-aset0 (vec val)
  `(aset ,vec 0 ,val))

(defmacro xwem-misc-aset1 (vec val)
  `(aset ,vec 1 ,val))

(defmacro xwem-misc-aset2 (vec val)
  `(aset ,vec 2 ,val))

(defmacro xwem-misc-aset3 (vec val)
  `(aset ,vec 3 ,val))

(defmacro xwem-misc-aset4 (vec val)
  `(aset ,vec 4 ,val))

(defmacro xwem-misc-aset5 (vec val)
  `(aset ,vec 5 ,val))

(defmacro xwem-misc-aset6 (vec val)
  `(aset ,vec 6 ,val))

(defmacro xwem-misc-aset7 (vec val)
  `(aset ,vec 7 ,val))

(defmacro defmacro-alias (new old &optional doc-str)
  "Define NEW macro as alias to OLD macro.
It will look like (defmacro-alias new-macro 'old-macro)."
  `(defmacro ,new (&rest args)
     `(,,old ,@args)))

;;; CL macros
(defmacro xwem-dpy-dummy ()
  `(make-vector 3 nil))

(defmacro xwem-dpy ()
  `(aref xwem-root-screen 0))

(defmacro xwem-minkeycode ()
  `(aref (xwem-dpy) 12))

(defmacro xwem-maxkeycode ()
  `(aref (xwem-dpy) 13))

(defmacro xwem-rootwin ()
  `(aref xwem-root-screen 1))

(defmacro xwem-rootgeom ()
  `(aref xwem-root-screen 2))

;;; Macros
(defmacro xwem-cl-selected ()
  "Return selected client."
  `(xwem-win-cl (xwem-win-selected)))

(defmacro xwem-cl-frame (cl)
  "Return frame where CL."
  `(let ((win (xwem-cl-win ,cl)))
     (if (xwem-win-p win)
	 (xwem-win-frame win)

(defmacro xwem-cl-tabber (cl)
  "Return CL's tabber."
  `(and (xwem-frame-p (xwem-cl-frame ,cl))
	(xwem-frame-tabber (xwem-cl-frame ,cl))))

(defmacro xwem-tab-item-tabber (tabi)
  `(xwem-cl-tabber (xwem-tab-item-cl ,tabi)))

(defmacro xwem-cl-win-geom (cl)
  "Get geometry for client CL. Actually return xwem window geometry."
  `(xwem-win-geom (xwem-cl-win ,cl)))

;;; Window macros
(defmacro xwem-win-put-prop (window prop val)
  "Set property PROP of WINDOW to VAL."
  `(when (xwem-win-p ,window)
     (aset ,window 2 (plist-put (xwem-win-props ,window) ,prop ,val))))

(defmacro xwem-win-get-prop (window prop)
  "Get property PROP for WINDOW."
  `(when (xwem-win-p ,window)
     (plist-get (xwem-win-props ,window) ,prop)))

(defmacro xwem-win-child (window)
  "Return child of WINDOW, hchild checked first then if not set vchild
  `(or (xwem-win-hchild ,window) (xwem-win-vchild ,window)))

(defmacro xwem-win-mark-deleted (win)
  "Mark WIN as deleted window."
  `(setf (xwem-win-deleted ,win) t))

;; -- Expectations macros
(defmacro xwem-win-get-expt (win expt)
  "Get value of EXPT from expectances plist of WIN.
Returns 0 if EXPT is not in plist."
  `(let ((exv (lax-plist-get (xwem-win-expectances ,win) ,expt)))
     (if (null exv) 0 exv)))

(defmacro xwem-win-set-expt (win expt expt-value)
  "Set EXPT with value EXPT-VALUE in expectations plist for WIN."
  `(setf (xwem-win-expectances ,win)
	 (lax-plist-put (xwem-win-expectances ,win) ,expt ,expt-value)))
(defmacro xwem-win-expt-inc (win expt &optional howmuch)
  "Include by one EXPT in expectations plist for WIN.
If there no such EXPT, new one will be created with count equal to one."
    ,win ,expt
    (+ (xwem-win-get-expt ,win ,expt) (if ,howmuch ,howmuch 1))))

(defmacro xwem-win-expt-dec (win expt &optional howmuch)
  "Decrement by one value of EXPT in expectations plist for WIN."
  `(let ((exv (xwem-win-get-expt ,win ,expt))
	 (hm (if ,howmuch ,howmuch 1)))
     (xwem-win-set-expt ,win ,expt
			(if (> (- exv hm) 0) (- exv hm) 0))))

;;; Frames macros
(defmacro xwem-frame-get-prop (frame prop)
  `(plist-get (xwem-frame-props ,frame) ,prop))

(defmacro xwem-frame-set-prop (frame prop val)
  "Puts PROP with VAL to FRAME's properties list."
  `(let ((props (xwem-frame-props ,frame)))
     (setq props (plist-put props ,prop ,val))
     (setf (xwem-frame-props ,frame) props)))

(defmacro xwem-frame-link-insert-after (frame1 frame2)
  "Make FRAME2 to be after FRAME1."
  `(let ((nf (xwem-frame-link-next ,frame1)))
     (when (xwem-frame-p nf)
       (setf (xwem-frame-link-prev nf) ,frame2))
     (setf (xwem-frame-link-next ,frame1) ,frame2)
     (setf (xwem-frame-link-prev ,frame2) ,frame1)
     (setf (xwem-frame-link-next ,frame2) nf)))

(defmacro xwem-frame-link-insert-before (frame1 frame2)
  "Make FRAME2 to be before FRAME1."
  `(let ((pf (xwem-frame-link-prev ,frame1)))
     (when (xwem-frame-p pf)
       (setf (xwem-frame-link-next pf) ,frame2))
     (setf (xwem-frame-link-prev ,frame1) ,frame2)
     (setf (xwem-frame-link-next ,frame2) ,frame1)
     (setf (xwem-frame-link-prev ,frame2) pf)))

(defmacro xwem-frame-link-remove (frame)
  "Remove FRAME from linkage."
  `(let ((nfr (xwem-frame-link-next ,frame))
	 (pfr (xwem-frame-link-prev ,frame)))
     (when (xwem-frame-p pfr)
       (setf (xwem-frame-link-next pfr) nfr))
     (when (xwem-frame-p nfr)
       (setf (xwem-frame-link-prev nfr) pfr))))

(defmacro xwem-frame-link-head (frame)
  "Returns head frame of FRAME's linkage."
  `(let ((fr ,frame))
     (while (xwem-frame-p (xwem-frame-link-prev fr))
       (setq fr (xwem-frame-link-prev fr)))

(defmacro xwem-frame-linkage-map (frame fn)
  "Call FN for each frame in FRAME's linkage.
FN called with one argument - frame."
  ;; TODO: avoid infinit recursion
  `(let ((fr (xwem-frame-link-head ,frame)))

     (while (xwem-frame-p fr)
       (funcall ,fn fr)
       (setq fr (xwem-frame-link-next fr)))))

;;; Key macros
(defmacro xwem-kbd-private-makemask (mlist)
  `(apply 'Xmask-or (cons 0 ,mlist)))

(defmacro xwem-kbd-shiftmask ()
  `(xwem-kbd-private-makemask (aref xwem-kbd-private-modifiers 0)))

(defmacro xwem-kbd-lockmask ()
  `(xwem-kbd-private-makemask (aref xwem-kbd-private-modifiers 1)))

(defmacro xwem-kbd-controlmask ()
  `(xwem-kbd-private-makemask (aref xwem-kbd-private-modifiers 2)))

(defmacro xwem-kbd-metamask ()
  `(xwem-kbd-private-makemask (aref xwem-kbd-private-modifiers 3)))

(defmacro xwem-kbd-hypermask ()
  `(xwem-kbd-private-makemask (aref xwem-kbd-private-modifiers 4)))

(defmacro xwem-kbd-supermask ()
  `(xwem-kbd-private-makemask (aref xwem-kbd-private-modifiers 5)))

(defmacro xwem-help-display (&rest forms)
  "Evaluate FORMS in special emacs frame and xwem help buffer."
  `(let ((temp-buffer-show-function 'xwem-special-popup-frame))
      (lambda ()
	(set-buffer standard-output)
	(progn ,@forms))

(defmacro xwem-interactive (&rest ispec)
  "Just like `interactive', but accepts xwem specific arguments.
Code letters available are:
s -- String.
k -- Single key.
K -- Key sequence that executes command.
c -- Client.
f -- Existing file.
F -- Possible non-existing file.
p -- Prefix argument as number.
P -- Prefix argument in raw form.
C -- Command.
e -- External command."
  (let ((is (cond ((and (= (length ispec) 1)
			(stringp (car ispec)))
		   (setq ispec (car ispec))
		   (split-string ispec "\n"))

		  (t ispec))))

    (if (not (stringp ispec))
	`(interactive (let ((xwem-interactively t))
                        (prog1 (progn ,@ispec)
                          (setq xwem-prefix-arg nil))))

      `(interactive (prog1 (xwem-interactive-ilist (quote ,is))
                      (setq xwem-prefix-arg nil))))

(defmacro define-xwem-command (funsym args docstring inter &rest body)
  "Same as `xwem-defun', but make FUNSYM to be interactive command.
INTER is actually a for of `xwem-interactive'."
  `(defun ,funsym ,args
     ,(macroexpand inter)
     ;; Maybe run command without GCing at all
     (let ((gc-cons-threshold (if xwem-commands-inhibit-gc

(put 'xwem-command 'lisp-indent-function 'defun)

(defmacro xwem-under-minib-focus (&rest forms)
  "Evaluate FORM under XWEM's minibuffer focus."
     (xwem-focus-set (xwem-minib-cl xwem-minibuffer))

	 (progn ,@forms)


(defmacro xwem-cursor-shape-choice ()
  "Return choice dialog to select cursor shape."
  `(`(choice (const :tag "Left" X-XC-left_ptr)
	     (const :tag "Right" X-XC-right_ptr )
	     (const :tag "Cross" X-XC-cross)
	     (const :tag "Reverse Cross" X-XC-cross_reverse)
	     (const :tag "Crosshair" X-XC-crosshair)
	     (const :tag "Daimond cross" X-XC-diamond_cross)
	     ;; TODO: add more, take a look at Cursors section in
	     ;; xlib-const.el
	     (const :tag "Dot" X-XC-dot)
	     (const :tag "Square Icon" X-XC-icon)
	     (const :tag "Down Arrow" X-XC-sb_down_arrow)
	     (const :tag "Question Arrow" X-XC-question_arrow)
	     (const :tag "Fluer" X-XC-fleur)
	     (const :tag "Bottom Left corner" X-XC-bottom_left_corner)
	     (const :tag "Bottom Right corner" X-XC-bottom_right_corner)
	     (const :tag "Top Left corner" X-XC-top_left_arrow)
	     (const :tag "Top Right corner" X-XC-top_right_arrow)

(defmacro xwem-gc-function-choice ()
  "Return choice dialog to select GC function."
  `(`(choice (const :tag "None" nil)
	     (const :tag "Clear" X-GXClear)
	     (const :tag "And" X-GXAnd)
	     (const :tag "Reverse And" X-GXAndReverse)
	     (const :tag "Inverted And" X-GXAndInverted)
	     (const :tag "Xor" X-GXXor)
	     (const :tag "Or" X-GXOr)
	     (const :tag "Reverse Or" X-GXOrReverse)
	     (const :tag "Inverted Or" X-GXOrInverted)
	     (const :tag "Nor" X-GXNor)
	     (const :tag "Equive" X-GXEquiv)
	     (const :tag "Invert" X-GXInvert)
	     (const :tag "Copy" X-GXCopy)
	     (const :tag "Inverted Copy" X-GXCopyInverted)
	     (const :tag "Set" X-GXSet))))

(provide 'xwem-macros)

;;; xwem-macros.el ends here