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