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