1 ;;; mh-acros.el --- macros used in MH-E
3 ;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
5 ;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
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 2, or (at your option)
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; 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.
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.
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
52 (defmacro mh-require-cl ()
53 "Macro to load \"cl\" if needed.
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)
63 `(eval-when-compile (require 'cl))))
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)
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)
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))))
85 (defmacro mh-defun-compat (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)))
91 `(defalias ',name ',function)
92 `(defun ,name ,arg-list ,@body))))
93 (put 'mh-defun-compat 'lisp-indent-function 'defun)
96 (defmacro mh-defmacro-compat (name macro arg-list &rest body)
98 If MACRO exists, then NAME becomes an alias for MACRO.
99 Otherwise, create macro NAME with ARG-LIST and BODY."
100 (let ((defined-p (fboundp macro)))
102 `(defalias ',name ',macro)
103 `(defmacro ,name ,arg-list ,@body))))
104 (put 'mh-defmacro-compat 'lisp-indent-function 'defun)
111 (defmacro mh-make-local-hook (hook)
112 "Make HOOK local if needed.
113 XEmacs 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)))
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.
122 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then
123 check 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))
129 `(and (boundp 'transient-mark-mode) transient-mark-mode
130 (boundp 'mark-active) mark-active))))
133 (eval-when-compile (mh-do-in-xemacs (defvar struct) (defvar x) (defvar y)))
136 (defmacro mh-defstruct (name-spec &rest fields)
137 "Replacement for `defstruct' from the \"cl\" package.
138 The `defstruct' in the \"cl\" library produces compiler warnings,
139 and generates code that uses functions present in \"cl\" at
140 run-time. This is a partial replacement, that avoids these
143 NAME-SPEC declares the name of the structure, while FIELDS
144 describes the various structure fields. Lookup `defstruct' for
146 (let* ((struct-name (if (atom name-spec) name-spec (car name-spec)))
147 (conc-name (or (and (consp name-spec)
148 (cadr (assoc :conc-name (cdr name-spec))))
149 (format "%s-" struct-name)))
150 (predicate (intern (format "%s-p" struct-name)))
151 (constructor (or (and (consp name-spec)
152 (cadr (assoc :constructor (cdr name-spec))))
153 (intern (format "make-%s" struct-name))))
154 (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields))
155 (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x)))
157 (struct (gensym "S"))
161 (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y))
162 field-names field-init-forms))
163 (list (quote ,struct-name) ,@field-names))
164 (defun ,predicate (arg)
165 (and (consp arg) (eq (car arg) (quote ,struct-name))))
168 collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z)
170 (quote ,struct-name))))
173 (defmacro with-mh-folder-updating (save-modification-flag &rest body)
174 "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY).
175 Execute BODY, which can modify the folder buffer without having to
176 worry about file locking or the read-only flag, and return its result.
177 If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification flag
178 is unchanged, otherwise it is cleared."
179 (setq save-modification-flag (car save-modification-flag)) ; CL style
181 (let ((mh-folder-updating-mod-flag (buffer-modified-p))
182 (buffer-read-only nil)
183 (buffer-file-name nil)) ;don't let the buffer get locked
187 (mh-set-folder-modified-p mh-folder-updating-mod-flag)))
188 ,@(if (not save-modification-flag)
189 '((mh-set-folder-modified-p nil)))))
190 (put 'with-mh-folder-updating 'lisp-indent-hook 'defun)
193 (defmacro mh-in-show-buffer (show-buffer &rest body)
194 "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY).
195 Display buffer SHOW-BUFFER in other window and execute BODY in it.
196 Stronger than `save-excursion', weaker than `save-window-excursion'."
197 (setq show-buffer (car show-buffer)) ; CL style
198 `(let ((mh-in-show-buffer-saved-window (selected-window)))
199 (switch-to-buffer-other-window ,show-buffer)
200 (if mh-bury-show-buffer-flag (bury-buffer (current-buffer)))
204 (select-window mh-in-show-buffer-saved-window))))
205 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun)
208 (defmacro mh-do-at-event-location (event &rest body)
209 "Switch to the location of EVENT and execute BODY.
210 After BODY has been executed return to original window. The
211 modification flag of the buffer in the event window is
213 (let ((event-window (make-symbol "event-window"))
214 (event-position (make-symbol "event-position"))
215 (original-window (make-symbol "original-window"))
216 (original-position (make-symbol "original-position"))
217 (modified-flag (make-symbol "modified-flag")))
219 (let* ((,event-window
220 (or (mh-funcall-if-exists posn-window (event-start ,event))
221 (mh-funcall-if-exists event-window ,event)))
223 (or (mh-funcall-if-exists posn-point (event-start ,event))
224 (mh-funcall-if-exists event-closest-point ,event)))
225 (,original-window (selected-window))
226 (,original-position (progn
227 (set-buffer (window-buffer ,event-window))
228 (set-marker (make-marker) (point))))
229 (,modified-flag (buffer-modified-p))
230 (buffer-read-only nil))
231 (unwind-protect (progn
232 (select-window ,event-window)
233 (goto-char ,event-position)
235 (set-buffer-modified-p ,modified-flag)
236 (goto-char ,original-position)
237 (set-marker ,original-position nil)
238 (select-window ,original-window))))))
239 (put 'mh-do-at-event-location 'lisp-indent-hook 'defun)
243 ;;; Sequences and Ranges
246 (defmacro mh-seq-msgs (sequence)
247 "Extract messages from the given SEQUENCE."
248 (list 'cdr sequence))
251 (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)
252 "Iterate over region.
254 VAR is bound to the message on the current line as we loop
255 starting from BEGIN till END. In each step BODY is executed.
257 If VAR is nil then the loop is executed without any binding."
258 (unless (symbolp var)
259 (error "Can not bind the non-symbol %s" var))
260 (let ((binding-needed-flag var))
264 (while (and (<= (point) ,end) (not (eobp)))
265 (when (looking-at mh-scan-valid-regexp)
266 (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ())
269 (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
272 (defmacro mh-iterate-on-range (var range &rest body)
273 "Iterate an operation over a region or sequence.
275 VAR is bound to each message in turn in a loop over RANGE, which
276 can be a message number, a list of message numbers, a sequence, a
277 region in a cons cell, or a MH range (something like last:20) in
278 a string. In each iteration, BODY is executed.
280 The parameter RANGE is usually created with
281 `mh-interactive-range' in order to provide a uniform interface to
283 (unless (symbolp var)
284 (error "Can not bind the non-symbol %s" var))
285 (let ((binding-needed-flag var)
286 (msgs (make-symbol "msgs"))
287 (seq-hash-table (make-symbol "seq-hash-table")))
288 `(cond ((numberp ,range)
289 (when (mh-goto-msg ,range t t)
290 (let ,(if binding-needed-flag `((,var ,range)) ())
293 (numberp (car ,range)) (numberp (cdr ,range)))
294 (mh-iterate-on-messages-in-region ,var
295 (car ,range) (cdr ,range)
297 (t (let ((,msgs (cond ((and ,range (symbolp ,range))
298 (mh-seq-to-msgs ,range))
300 (mh-translate-range mh-current-folder
303 (,seq-hash-table (make-hash-table)))
305 (setf (gethash msg ,seq-hash-table) t))
306 (mh-iterate-on-messages-in-region v (point-min) (point-max)
307 (when (gethash v ,seq-hash-table)
308 (let ,(if binding-needed-flag `((,var v)) ())
310 (put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
315 ;; no-byte-compile: t
316 ;; indent-tabs-mode: nil
317 ;; sentence-end-double-space: nil
320 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
321 ;;; mh-acros.el ends here