Mercurial > emacs
annotate lisp/mh-e/mh-acros.el @ 69060:89f6168254d0
(Watch Expressions): Update and describe gdb-speedbar-auto-raise.
author | Nick Roberts <nickrob@snap.net.nz> |
---|---|
date | Tue, 21 Feb 2006 03:57:43 +0000 |
parents | 6a7173abcf59 |
children | d81780942bb8 |
rev | line source |
---|---|
68465 | 1 ;;; mh-acros.el --- macros used in MH-E |
56676 | 2 |
68137
ec4727559827
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Move here from
Bill Wohler <wohler@newt.com>
parents:
67760
diff
changeset
|
3 ;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. |
56676 | 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 | |
64085 | 24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 ;; Boston, MA 02110-1301, USA. | |
56676 | 26 |
27 ;;; Commentary: | |
28 | |
68465 | 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. | |
68213
a08b47775f9b
* mh-acros.el (require): Remove defadvice of require as defadvice is
Bill Wohler <wohler@newt.com>
parents:
68189
diff
changeset
|
33 |
68465 | 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. | |
56676 | 40 |
41 ;;; Change Log: | |
42 | |
43 ;;; Code: | |
44 | |
45 (require 'cl) | |
68465 | 46 |
47 | |
56676 | 48 |
68465 | 49 ;;; Compatibility |
50 | |
51 ;;;###mh-autoload | |
56676 | 52 (defmacro mh-require-cl () |
67760
9c3504ae6060
Follow MH-E Developers Guide conventions. Use `' quotes for Help
Bill Wohler <wohler@newt.com>
parents:
67758
diff
changeset
|
53 "Macro to load \"cl\" if needed. |
68465 | 54 |
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." | |
56676 | 61 (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash) |
56787
25da1d331c99
Upgraded to MH-E version 7.82.
Bill Wohler <wohler@newt.com>
parents:
56751
diff
changeset
|
62 `(require 'cl) |
56676 | 63 `(eval-when-compile (require 'cl)))) |
64 | |
68465 | 65 ;;;###mh-autoload |
56676 | 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 | |
68465 | 71 ;;;###mh-autoload |
56676 | 72 (defmacro mh-do-in-xemacs (&rest body) |
68465 | 73 "Execute BODY if in XEmacs." |
56676 | 74 (when (featurep 'xemacs) `(progn ,@body))) |
75 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun) | |
76 | |
68465 | 77 ;;;###mh-autoload |
56676 | 78 (defmacro mh-funcall-if-exists (function &rest args) |
79 "Call FUNCTION with ARGS as parameters if it exists." | |
62847
aa8c2e12ee24
Upgraded to MH-E version 7.84.
Bill Wohler <wohler@newt.com>
parents:
62465
diff
changeset
|
80 (when (fboundp function) |
aa8c2e12ee24
Upgraded to MH-E version 7.84.
Bill Wohler <wohler@newt.com>
parents:
62465
diff
changeset
|
81 `(when (fboundp ',function) |
aa8c2e12ee24
Upgraded to MH-E version 7.84.
Bill Wohler <wohler@newt.com>
parents:
62465
diff
changeset
|
82 (funcall ',function ,@args)))) |
56676 | 83 |
68465 | 84 ;;;###mh-autoload |
68520
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
85 (defmacro mh-defun-compat (name function arg-list &rest body) |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
86 "Create function NAME. |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
87 If FUNCTION exists, then NAME becomes an alias for FUNCTION. |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
88 Otherwise, create function NAME with ARG-LIST and BODY." |
68137
ec4727559827
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Move here from
Bill Wohler <wohler@newt.com>
parents:
67760
diff
changeset
|
89 (let ((defined-p (fboundp function))) |
68520
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
90 (if defined-p |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
91 `(defalias ',name ',function) |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
92 `(defun ,name ,arg-list ,@body)))) |
68137
ec4727559827
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Move here from
Bill Wohler <wohler@newt.com>
parents:
67760
diff
changeset
|
93 (put 'mh-defun-compat 'lisp-indent-function 'defun) |
ec4727559827
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Move here from
Bill Wohler <wohler@newt.com>
parents:
67760
diff
changeset
|
94 |
68465 | 95 ;;;###mh-autoload |
68520
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
96 (defmacro mh-defmacro-compat (name macro arg-list &rest body) |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
97 "Create macro NAME. |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
98 If MACRO exists, then NAME becomes an alias for MACRO. |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
99 Otherwise, create macro NAME with ARG-LIST and BODY." |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
100 (let ((defined-p (fboundp macro))) |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
101 (if defined-p |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
102 `(defalias ',name ',macro) |
6a7173abcf59
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Add name argument
Bill Wohler <wohler@newt.com>
parents:
68465
diff
changeset
|
103 `(defmacro ,name ,arg-list ,@body)))) |
68137
ec4727559827
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Move here from
Bill Wohler <wohler@newt.com>
parents:
67760
diff
changeset
|
104 (put 'mh-defmacro-compat 'lisp-indent-function 'defun) |
ec4727559827
* mh-acros.el (mh-defun-compat, mh-defmacro-compat): Move here from
Bill Wohler <wohler@newt.com>
parents:
67760
diff
changeset
|
105 |
68465 | 106 |
107 | |
108 ;;; Miscellaneous | |
109 | |
110 ;;;###mh-autoload | |
56676 | 111 (defmacro mh-make-local-hook (hook) |
112 "Make HOOK local if needed. | |
67758
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
113 XEmacs and versions of GNU Emacs before 21.1 require |
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
114 `make-local-hook' to be called." |
56676 | 115 (when (and (fboundp 'make-local-hook) |
116 (not (get 'make-local-hook 'byte-obsolete-info))) | |
117 `(make-local-hook ,hook))) | |
118 | |
68465 | 119 ;;;###mh-autoload |
56676 | 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. | |
67758
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
122 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then |
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
123 check if variable `transient-mark-mode' is active." |
56676 | 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 | |
68465 | 132 ;; Shush compiler. |
133 (eval-when-compile (mh-do-in-xemacs (defvar struct) (defvar x) (defvar y))) | |
134 | |
135 ;;;###mh-autoload | |
56676 | 136 (defmacro mh-defstruct (name-spec &rest fields) |
67760
9c3504ae6060
Follow MH-E Developers Guide conventions. Use `' quotes for Help
Bill Wohler <wohler@newt.com>
parents:
67758
diff
changeset
|
137 "Replacement for `defstruct' from the \"cl\" package. |
9c3504ae6060
Follow MH-E Developers Guide conventions. Use `' quotes for Help
Bill Wohler <wohler@newt.com>
parents:
67758
diff
changeset
|
138 The `defstruct' in the \"cl\" library produces compiler warnings, |
9c3504ae6060
Follow MH-E Developers Guide conventions. Use `' quotes for Help
Bill Wohler <wohler@newt.com>
parents:
67758
diff
changeset
|
139 and generates code that uses functions present in \"cl\" at |
67758
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
140 run-time. This is a partial replacement, that avoids these |
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
141 issues. |
56676 | 142 |
67758
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
143 NAME-SPEC declares the name of the structure, while FIELDS |
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
144 describes the various structure fields. Lookup `defstruct' for |
6b063593fdad
Follow Emacs coding conventions. Use default setting of
Bill Wohler <wohler@newt.com>
parents:
67681
diff
changeset
|
145 more details." |
56676 | 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))) | |
156 fields)) | |
157 (struct (gensym "S")) | |
158 (x (gensym "X")) | |
159 (y (gensym "Y"))) | |
160 `(progn | |
161 (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y)) | |
162 field-names field-init-forms)) | |
56751
72a02133177e
Upgraded to MH-E version 7.81.
Bill Wohler <wohler@newt.com>
parents:
56677
diff
changeset
|
163 (list (quote ,struct-name) ,@field-names)) |
56676 | 164 (defun ,predicate (arg) |
56751
72a02133177e
Upgraded to MH-E version 7.81.
Bill Wohler <wohler@newt.com>
parents:
56677
diff
changeset
|
165 (and (consp arg) (eq (car arg) (quote ,struct-name)))) |
72a02133177e
Upgraded to MH-E version 7.81.
Bill Wohler <wohler@newt.com>
parents:
56677
diff
changeset
|
166 ,@(loop for x from 1 |
56676 | 167 for y in field-names |
168 collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z) | |
169 (list 'nth ,x z))) | |
170 (quote ,struct-name)))) | |
171 | |
68465 | 172 ;;;###mh-autoload |
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 | |
180 `(prog1 | |
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 | |
184 (prog1 | |
185 (progn | |
186 ,@body) | |
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) | |
191 | |
192 ;;;###mh-autoload | |
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))) | |
201 (unwind-protect | |
202 (progn | |
203 ,@body) | |
204 (select-window mh-in-show-buffer-saved-window)))) | |
205 (put 'mh-in-show-buffer 'lisp-indent-hook 'defun) | |
206 | |
207 ;;;###mh-autoload | |
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 | |
212 preserved." | |
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"))) | |
218 `(save-excursion | |
219 (let* ((,event-window | |
220 (or (mh-funcall-if-exists posn-window (event-start ,event)) | |
221 (mh-funcall-if-exists event-window ,event))) | |
222 (,event-position | |
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) | |
234 ,@body) | |
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) | |
240 | |
241 | |
242 | |
243 ;;; Sequences and Ranges | |
244 | |
245 ;;;###mh-autoload | |
246 (defmacro mh-seq-msgs (sequence) | |
247 "Extract messages from the given SEQUENCE." | |
248 (list 'cdr sequence)) | |
249 | |
250 ;;;###mh-autoload | |
251 (defmacro mh-iterate-on-messages-in-region (var begin end &rest body) | |
252 "Iterate over region. | |
253 | |
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. | |
256 | |
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)) | |
261 `(save-excursion | |
262 (goto-char ,begin) | |
263 (beginning-of-line) | |
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))) ()) | |
267 ,@body)) | |
268 (forward-line 1))))) | |
269 (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun) | |
270 | |
271 ;;;###mh-autoload | |
272 (defmacro mh-iterate-on-range (var range &rest body) | |
273 "Iterate an operation over a region or sequence. | |
274 | |
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. | |
279 | |
280 The parameter RANGE is usually created with | |
281 `mh-interactive-range' in order to provide a uniform interface to | |
282 MH-E functions." | |
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)) ()) | |
291 ,@body))) | |
292 ((and (consp ,range) | |
293 (numberp (car ,range)) (numberp (cdr ,range))) | |
294 (mh-iterate-on-messages-in-region ,var | |
295 (car ,range) (cdr ,range) | |
296 ,@body)) | |
297 (t (let ((,msgs (cond ((and ,range (symbolp ,range)) | |
298 (mh-seq-to-msgs ,range)) | |
299 ((stringp ,range) | |
300 (mh-translate-range mh-current-folder | |
301 ,range)) | |
302 (t ,range))) | |
303 (,seq-hash-table (make-hash-table))) | |
304 (dolist (msg ,msgs) | |
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)) ()) | |
309 ,@body)))))))) | |
310 (put 'mh-iterate-on-range 'lisp-indent-hook 'defun) | |
66357
f5ade15d46f2
* mh-identity.el (mh-assoc-ignore-case): Merge with version in
Bill Wohler <wohler@newt.com>
parents:
64085
diff
changeset
|
311 |
56676 | 312 (provide 'mh-acros) |
313 | |
67681 | 314 ;; Local Variables: |
315 ;; no-byte-compile: t | |
316 ;; indent-tabs-mode: nil | |
317 ;; sentence-end-double-space: nil | |
318 ;; End: | |
56676 | 319 |
56677 | 320 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff |
56676 | 321 ;;; mh-acros.el ends here |