lisp/mh-e/mh-acros.el

   1 ;;; mh-acros.el --- macros used in MH-E
   2
   3 ;; Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This file contains all macros that are used in more than one file.
  28 ;; If you run "make recompile" in Bazaar Emacs and see the message
  29 ;; "Source is newer than compiled," it is a sign that macro probably
  30 ;; needs to be moved here.
  31
  32 ;; Historically, it was so named with a silent "m" so that it would be
  33 ;; compiled first. Otherwise, "make recompile" in Bazaar Emacs would use
  34 ;; compiled files with stale macro definitions. Later, no-byte-compile
  35 ;; was added to the Local Variables section to avoid this problem and
  36 ;; because it's pointless to compile a file full of macros. But we
  37 ;; kept the name.
  38
  39 ;;; Change Log:
  40
  41 ;;; Code:
  42
  43 (require 'cl)
  44
  45 \f
  46
  47 ;;; Compatibility
  48
  49 ;;;###mh-autoload
  50 (defmacro mh-require-cl ()
  51   "Macro to load \"cl\" if needed.
  52
  53 Emacs coding conventions require that the \"cl\" package not be
  54 required at runtime. However, the \"cl\" package in Emacs 21.4
  55 and earlier left \"cl\" routines in their macro expansions. In
  56 particular, the expansion of (setf (gethash ...) ...) used
  57 functions in \"cl\" at run time. This macro recognizes that and
  58 loads \"cl\" appropriately."
  59   (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
  60       `(require 'cl)
  61     `(eval-when-compile (require 'cl))))
  62
  63 ;;;###mh-autoload
  64 (defmacro mh-do-in-gnu-emacs (&rest body)
  65   "Execute BODY if in GNU Emacs."
  66   (declare (debug t))
  67   (unless (featurep 'xemacs) `(progn ,@body)))
  68 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
  69
  70 ;;;###mh-autoload
  71 (defmacro mh-do-in-xemacs (&rest body)
  72   "Execute BODY if in XEmacs."
  73   (declare (debug t))
  74   (when (featurep 'xemacs) `(progn ,@body)))
  75 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
  76
  77 ;;;###mh-autoload
  78 (defmacro mh-funcall-if-exists (function &rest args)
  79   "Call FUNCTION with ARGS as parameters if it exists."
  80   (when (fboundp function)
  81     `(when (fboundp ',function)
  82        (funcall ',function ,@args))))
  83
  84 ;;;###mh-autoload
  85 (defmacro defun-mh (name function arg-list &rest body)
  86   "Create function NAME.
  87 If FUNCTION exists, then NAME becomes an alias for FUNCTION.
  88 Otherwise, create function NAME with ARG-LIST and BODY."
  89   (let ((defined-p (fboundp function)))
  90     (if defined-p
  91         `(defalias ',name ',function)
  92       `(defun ,name ,arg-list ,@body))))
  93 (put 'defun-mh 'lisp-indent-function 'defun)
  94 (put 'defun-mh 'doc-string-elt 4)
  95
  96 ;;;###mh-autoload
  97 (defmacro defmacro-mh (name macro arg-list &rest body)
  98   "Create macro NAME.
  99 If MACRO exists, then NAME becomes an alias for MACRO.
 100 Otherwise, create macro NAME with ARG-LIST and BODY."
 101   (let ((defined-p (fboundp macro)))
 102     (if defined-p
 103         `(defalias ',name ',macro)
 104       `(defmacro ,name ,arg-list ,@body))))
 105 (put 'defmacro-mh 'lisp-indent-function 'defun)
 106 (put 'defmacro-mh 'doc-string-elt 4)
 107
 108 \f
 109
 110 ;;; Miscellaneous
 111
 112 ;;;###mh-autoload
 113 (defmacro mh-make-local-hook (hook)
 114   "Make HOOK local if needed.
 115 XEmacs and versions of GNU Emacs before 21.1 require
 116 `make-local-hook' to be called."
 117   (when (and (fboundp 'make-local-hook)
 118              (not (get 'make-local-hook 'byte-obsolete-info)))
 119     `(make-local-hook ,hook)))
 120
 121 ;;;###mh-autoload
 122 (defmacro mh-mark-active-p (check-transient-mark-mode-flag)
 123   "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
 124 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then
 125 check if variable `transient-mark-mode' is active."
 126   (cond ((featurep 'xemacs)             ;XEmacs
 127          `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
 128         ((not check-transient-mark-mode-flag) ;GNU Emacs
 129          `(and (boundp 'mark-active) mark-active))
 130         (t                              ;GNU Emacs
 131          `(and (boundp 'transient-mark-mode) transient-mark-mode
 132                (boundp 'mark-active) mark-active))))
 133
 134 ;; Shush compiler.
 135 (mh-do-in-xemacs
 136   (defvar struct)
 137   (defvar x)
 138   (defvar y))
 139
 140 ;;;###mh-autoload
 141 (defmacro mh-defstruct (name-spec &rest fields)
 142   "Replacement for `defstruct' from the \"cl\" package.
 143 The `defstruct' in the \"cl\" library produces compiler warnings,
 144 and generates code that uses functions present in \"cl\" at
 145 run-time. This is a partial replacement, that avoids these
 146 issues.
 147
 148 NAME-SPEC declares the name of the structure, while FIELDS
 149 describes the various structure fields. Lookup `defstruct' for
 150 more details."
 151   (let* ((struct-name (if (atom name-spec) name-spec (car name-spec)))
 152          (conc-name (or (and (consp name-spec)
 153                              (cadr (assoc :conc-name (cdr name-spec))))
 154                         (format "%s-" struct-name)))
 155          (predicate (intern (format "%s-p" struct-name)))
 156          (constructor (or (and (consp name-spec)
 157                                (cadr (assoc :constructor (cdr name-spec))))
 158                           (intern (format "make-%s" struct-name))))
 159          (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields))
 160          (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x)))
 161                                    fields))
 162          (struct (gensym "S"))
 163          (x (gensym "X"))
 164          (y (gensym "Y")))
 165     `(progn
 166        (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y))
 167                                              field-names field-init-forms))
 168          (list (quote ,struct-name) ,@field-names))
 169        (defun ,predicate (arg)
 170          (and (consp arg) (eq (car arg) (quote ,struct-name))))
 171        ,@(loop for x from 1
 172                for y in field-names
 173                collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z)
 174                           (list 'nth ,x z)))
 175        (quote ,struct-name))))
 176
 177 ;;;###mh-autoload
 178 (defmacro with-mh-folder-updating (save-modification-flag &rest body)
 179   "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY).
 180 Execute BODY, which can modify the folder buffer without having to
 181 worry about file locking or the read-only flag, and return its result.
 182 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification flag
 183 is unchanged, otherwise it is cleared."
 184   (declare (debug t))
 185   (setq save-modification-flag (car save-modification-flag)) ; CL style
 186   `(prog1
 187        (let ((mh-folder-updating-mod-flag (buffer-modified-p))
 188              (buffer-read-only nil)
 189              (buffer-file-name nil))    ;don't let the buffer get locked
 190          (prog1
 191              (progn
 192                ,@body)
 193            (mh-set-folder-modified-p mh-folder-updating-mod-flag)))
 194      ,@(if (not save-modification-flag)
 195            '((mh-set-folder-modified-p nil)))))
 196 (put 'with-mh-folder-updating 'lisp-indent-hook 'defun)
 197
 198 ;;;###mh-autoload
 199 (defmacro mh-in-show-buffer (show-buffer &rest body)
 200   "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).
 201 Display buffer SHOW-BUFFER in other window and execute BODY in it.
 202 Stronger than `save-excursion', weaker than `save-window-excursion'."
 203   (declare (debug t))
 204   (setq show-buffer (car show-buffer))  ; CL style
 205   `(let ((mh-in-show-buffer-saved-window (selected-window)))
 206      (switch-to-buffer-other-window ,show-buffer)
 207      (if mh-bury-show-buffer-flag (bury-buffer (current-buffer)))
 208      (unwind-protect
 209          (progn
 210            ,@body)
 211        (select-window mh-in-show-buffer-saved-window))))
 212 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
 213
 214 ;;;###mh-autoload
 215 (defmacro mh-do-at-event-location (event &rest body)
 216   "Switch to the location of EVENT and execute BODY.
 217 After BODY has been executed return to original window. The
 218 modification flag of the buffer in the event window is
 219 preserved."
 220   (declare (debug t))
 221   (let ((event-window (make-symbol "event-window"))
 222         (event-position (make-symbol "event-position"))
 223         (original-window (make-symbol "original-window"))
 224         (original-position (make-symbol "original-position"))
 225         (modified-flag (make-symbol "modified-flag")))
 226     `(save-excursion
 227        (let* ((,event-window
 228                (or (mh-funcall-if-exists posn-window (event-start ,event))
 229                    (mh-funcall-if-exists event-window ,event)))
 230               (,event-position
 231                (or (mh-funcall-if-exists posn-point (event-start ,event))
 232                    (mh-funcall-if-exists event-closest-point ,event)))
 233               (,original-window (selected-window))
 234               (,original-position (progn
 235                                    (set-buffer (window-buffer ,event-window))
 236                                    (point-marker)))
 237               (,modified-flag (buffer-modified-p))
 238               (buffer-read-only nil))
 239          (unwind-protect (progn
 240                            (select-window ,event-window)
 241                            (goto-char ,event-position)
 242                            ,@body)
 243            (set-buffer-modified-p ,modified-flag)
 244            (goto-char ,original-position)
 245            (set-marker ,original-position nil)
 246            (select-window ,original-window))))))
 247 (put 'mh-do-at-event-location 'lisp-indent-hook 'defun)
 248
 249 \f
 250
 251 ;;; Sequences and Ranges
 252
 253 ;;;###mh-autoload
 254 (defsubst mh-seq-msgs (sequence)
 255   "Extract messages from the given SEQUENCE."
 256   (cdr sequence))
 257
 258 ;;;###mh-autoload
 259 (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)
 260   "Iterate over region.
 261
 262 VAR is bound to the message on the current line as we loop
 263 starting from BEGIN till END. In each step BODY is executed.
 264
 265 If VAR is nil then the loop is executed without any binding."
 266   (declare (debug (symbolp body)))
 267   (unless (symbolp var)
 268     (error "Can not bind the non-symbol %s" var))
 269   (let ((binding-needed-flag var))
 270     `(save-excursion
 271        (goto-char ,begin)
 272        (beginning-of-line)
 273        (while (and (<= (point) ,end) (not (eobp)))
 274          (when (looking-at mh-scan-valid-regexp)
 275            (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ())
 276              ,@body))
 277          (forward-line 1)))))
 278 (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
 279
 280 ;;;###mh-autoload
 281 (defmacro mh-iterate-on-range (var range &rest body)
 282   "Iterate an operation over a region or sequence.
 283
 284 VAR is bound to each message in turn in a loop over RANGE, which
 285 can be a message number, a list of message numbers, a sequence, a
 286 region in a cons cell, or a MH range (something like last:20) in
 287 a string. In each iteration, BODY is executed.
 288
 289 The parameter RANGE is usually created with
 290 `mh-interactive-range' in order to provide a uniform interface to
 291 MH-E functions."
 292   (declare (debug (symbolp body)))
 293   (unless (symbolp var)
 294     (error "Can not bind the non-symbol %s" var))
 295   (let ((binding-needed-flag var)
 296         (msgs (make-symbol "msgs"))
 297         (seq-hash-table (make-symbol "seq-hash-table")))
 298     `(cond ((numberp ,range)
 299             (when (mh-goto-msg ,range t t)
 300               (let ,(if binding-needed-flag `((,var ,range)) ())
 301                 ,@body)))
 302            ((and (consp ,range)
 303                  (numberp (car ,range)) (numberp (cdr ,range)))
 304             (mh-iterate-on-messages-in-region ,var
 305               (car ,range) (cdr ,range)
 306               ,@body))
 307            (t (let ((,msgs (cond ((and ,range (symbolp ,range))
 308                                   (mh-seq-to-msgs ,range))
 309                                  ((stringp ,range)
 310                                   (mh-translate-range mh-current-folder
 311                                                       ,range))
 312                                  (t ,range)))
 313                     (,seq-hash-table (make-hash-table)))
 314                 (dolist (msg ,msgs)
 315                   (setf (gethash msg ,seq-hash-table) t))
 316                 (mh-iterate-on-messages-in-region v (point-min) (point-max)
 317                   (when (gethash v ,seq-hash-table)
 318                     (let ,(if binding-needed-flag `((,var v)) ())
 319                       ,@body))))))))
 320 (put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
 321
 322 (provide 'mh-acros)
 323
 324 ;; Local Variables:
 325 ;; no-byte-compile: t
 326 ;; indent-tabs-mode: nil
 327 ;; sentence-end-double-space: nil
 328 ;; End:
 329
 330 ;;; mh-acros.el ends here