lisp/mh-e/mh-acros.el

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