Commit | Line | Data |
---|---|---|
dda00b2c | 1 | ;;; mh-acros.el --- macros used in MH-E |
863e5e39 | 2 | |
acaf905b | 3 | ;; Copyright (C) 2004, 2006-2012 Free Software Foundation, Inc. |
863e5e39 BW |
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 | ||
5e809f55 | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
863e5e39 | 13 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
863e5e39 BW |
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 | |
5e809f55 | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
863e5e39 BW |
24 | |
25 | ;;; Commentary: | |
26 | ||
dda00b2c | 27 | ;; This file contains all macros that are used in more than one file. |
272f6ebf | 28 | ;; If you run "make recompile" in Bazaar Emacs and see the message |
dda00b2c BW |
29 | ;; "Source is newer than compiled," it is a sign that macro probably |
30 | ;; needs to be moved here. | |
1e4db53b | 31 | |
dda00b2c | 32 | ;; Historically, it was so named with a silent "m" so that it would be |
272f6ebf | 33 | ;; compiled first. Otherwise, "make recompile" in Bazaar Emacs would use |
dda00b2c BW |
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. | |
863e5e39 BW |
38 | |
39 | ;;; Change Log: | |
40 | ||
41 | ;;; Code: | |
42 | ||
43 | (require 'cl) | |
44 | ||
dda00b2c BW |
45 | \f |
46 | ||
47 | ;;; Compatibility | |
48 | ||
49 | ;;;###mh-autoload | |
863e5e39 | 50 | (defmacro mh-require-cl () |
5a4aad03 | 51 | "Macro to load \"cl\" if needed. |
dda00b2c BW |
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." | |
863e5e39 | 59 | (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash) |
eccf9613 | 60 | `(require 'cl) |
863e5e39 BW |
61 | `(eval-when-compile (require 'cl)))) |
62 | ||
dda00b2c | 63 | ;;;###mh-autoload |
863e5e39 BW |
64 | (defmacro mh-do-in-gnu-emacs (&rest body) |
65 | "Execute BODY if in GNU Emacs." | |
64137f20 | 66 | (declare (debug t)) |
863e5e39 BW |
67 | (unless (featurep 'xemacs) `(progn ,@body))) |
68 | (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun) | |
69 | ||
dda00b2c | 70 | ;;;###mh-autoload |
863e5e39 | 71 | (defmacro mh-do-in-xemacs (&rest body) |
dda00b2c | 72 | "Execute BODY if in XEmacs." |
64137f20 | 73 | (declare (debug t)) |
863e5e39 BW |
74 | (when (featurep 'xemacs) `(progn ,@body))) |
75 | (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun) | |
76 | ||
dda00b2c | 77 | ;;;###mh-autoload |
863e5e39 BW |
78 | (defmacro mh-funcall-if-exists (function &rest args) |
79 | "Call FUNCTION with ARGS as parameters if it exists." | |
e495eaec BW |
80 | (when (fboundp function) |
81 | `(when (fboundp ',function) | |
82 | (funcall ',function ,@args)))) | |
863e5e39 | 83 | |
dda00b2c | 84 | ;;;###mh-autoload |
c90c4cf1 | 85 | (defmacro defun-mh (name function arg-list &rest body) |
06e7028b BW |
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." | |
549afb31 | 89 | (let ((defined-p (fboundp function))) |
06e7028b BW |
90 | (if defined-p |
91 | `(defalias ',name ',function) | |
92 | `(defun ,name ,arg-list ,@body)))) | |
c90c4cf1 | 93 | (put 'defun-mh 'lisp-indent-function 'defun) |
524fec4d | 94 | (put 'defun-mh 'doc-string-elt 4) |
549afb31 | 95 | |
dda00b2c | 96 | ;;;###mh-autoload |
c90c4cf1 | 97 | (defmacro defmacro-mh (name macro arg-list &rest body) |
06e7028b BW |
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)))) | |
c90c4cf1 | 105 | (put 'defmacro-mh 'lisp-indent-function 'defun) |
524fec4d | 106 | (put 'defmacro-mh 'doc-string-elt 4) |
549afb31 | 107 | |
dda00b2c BW |
108 | \f |
109 | ||
110 | ;;; Miscellaneous | |
111 | ||
112 | ;;;###mh-autoload | |
863e5e39 BW |
113 | (defmacro mh-make-local-hook (hook) |
114 | "Make HOOK local if needed. | |
2dcf34f9 BW |
115 | XEmacs and versions of GNU Emacs before 21.1 require |
116 | `make-local-hook' to be called." | |
863e5e39 BW |
117 | (when (and (fboundp 'make-local-hook) |
118 | (not (get 'make-local-hook 'byte-obsolete-info))) | |
119 | `(make-local-hook ,hook))) | |
120 | ||
dda00b2c | 121 | ;;;###mh-autoload |
863e5e39 BW |
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. | |
2dcf34f9 BW |
124 | In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then |
125 | check if variable `transient-mark-mode' is active." | |
863e5e39 BW |
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 | ||
dda00b2c | 134 | ;; Shush compiler. |
54a5db74 BW |
135 | (mh-do-in-xemacs |
136 | (defvar struct) | |
137 | (defvar x) | |
138 | (defvar y)) | |
dda00b2c BW |
139 | |
140 | ;;;###mh-autoload | |
863e5e39 | 141 | (defmacro mh-defstruct (name-spec &rest fields) |
5a4aad03 BW |
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 | |
2dcf34f9 BW |
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." | |
863e5e39 BW |
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)) | |
d103d8b3 | 168 | (list (quote ,struct-name) ,@field-names)) |
863e5e39 | 169 | (defun ,predicate (arg) |
d103d8b3 BW |
170 | (and (consp arg) (eq (car arg) (quote ,struct-name)))) |
171 | ,@(loop for x from 1 | |
863e5e39 BW |
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 | ||
dda00b2c BW |
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." | |
64137f20 | 184 | (declare (debug t)) |
dda00b2c BW |
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'." | |
64137f20 | 203 | (declare (debug t)) |
dda00b2c BW |
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." | |
64137f20 | 220 | (declare (debug t)) |
dda00b2c BW |
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 | (set-marker (make-marker) (point)))) | |
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 | |
64137f20 | 254 | (defsubst mh-seq-msgs (sequence) |
dda00b2c | 255 | "Extract messages from the given SEQUENCE." |
64137f20 | 256 | (cdr sequence)) |
dda00b2c BW |
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." | |
64137f20 | 266 | (declare (debug (symbolp body))) |
dda00b2c BW |
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." | |
64137f20 | 292 | (declare (debug (symbolp body))) |
dda00b2c BW |
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) | |
9a51cf9e | 321 | |
863e5e39 BW |
322 | (provide 'mh-acros) |
323 | ||
cee9f5c6 BW |
324 | ;; Local Variables: |
325 | ;; no-byte-compile: t | |
326 | ;; indent-tabs-mode: nil | |
327 | ;; sentence-end-double-space: nil | |
328 | ;; End: | |
863e5e39 BW |
329 | |
330 | ;;; mh-acros.el ends here |