Small addition to glasses.el (bug#8524)
[emacs.git] / lisp / mh-e / mh-acros.el
blobc1964d5a4ea90acbd1b1f6669735376409af6fa3
1 ;;; mh-acros.el --- macros used in MH-E
3 ;; Copyright (C) 2004, 2006-2011 Free Software Foundation, Inc.
5 ;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
7 ;; Keywords: mail
8 ;; See: mh-e.el
10 ;; This file is part of GNU Emacs.
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.
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.
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/>.
25 ;;; Commentary:
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.
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.
39 ;;; Change Log:
41 ;;; Code:
43 (require 'cl)
47 ;;; Compatibility
49 ;;;###mh-autoload
50 (defmacro mh-require-cl ()
51 "Macro to load \"cl\" if needed.
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."
59 (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
60 `(require 'cl)
61 `(eval-when-compile (require 'cl))))
63 ;;;###mh-autoload
64 (defmacro mh-do-in-gnu-emacs (&rest body)
65 "Execute BODY if in GNU Emacs."
66 (declare (debug t))
67 (unless (featurep 'xemacs) `(progn ,@body)))
68 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
70 ;;;###mh-autoload
71 (defmacro mh-do-in-xemacs (&rest body)
72 "Execute BODY if in XEmacs."
73 (declare (debug t))
74 (when (featurep 'xemacs) `(progn ,@body)))
75 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
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))))
84 ;;;###mh-autoload
85 (defmacro defun-mh (name function arg-list &rest body)
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."
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 (put 'defun-mh 'doc-string-elt 4)
96 ;;;###mh-autoload
97 (defmacro defmacro-mh (name macro arg-list &rest body)
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))))
105 (put 'defmacro-mh 'lisp-indent-function 'defun)
106 (put 'defmacro-mh 'doc-string-elt 4)
110 ;;; Miscellaneous
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)))
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))))
134 ;; Shush compiler.
135 (defvar struct) ; XEmacs
136 (defvar x) ; XEmacs
137 (defvar y) ; XEmacs
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.
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))))
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)
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)
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)
250 ;;; Sequences and Ranges
252 ;;;###mh-autoload
253 (defsubst mh-seq-msgs (sequence)
254 "Extract messages from the given SEQUENCE."
255 (cdr sequence))
257 ;;;###mh-autoload
258 (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)
259 "Iterate over region.
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.
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)
279 ;;;###mh-autoload
280 (defmacro mh-iterate-on-range (var range &rest body)
281 "Iterate an operation over a region or sequence.
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.
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)
321 (provide 'mh-acros)
323 ;; Local Variables:
324 ;; no-byte-compile: t
325 ;; indent-tabs-mode: nil
326 ;; sentence-end-double-space: nil
327 ;; End:
329 ;;; mh-acros.el ends here