lisp/mh-e/mh-acros.el

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