lisp/mh-e/mh-acros.el

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