1 ;;; mh-acros.el --- Macros used in MH-E
3 ;; Copyright (C) 2004 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., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
29 ;; This file contains macros that would normally be in mh-utils.el except that
30 ;; their presence there would cause a dependency loop with mh-customize.el.
31 ;; This file must always be included like this:
33 ;; (eval-when-compile (require 'mh-acros))
35 ;; It is so named with a silent `m' so that it is compiled first. Otherwise,
36 ;; "make recompile" in Emacs 21.4 fails.
44 ;; The Emacs coding conventions require that the cl package not be required at
45 ;; runtime. However, the cl package in versions of Emacs prior to 21.4 left cl
46 ;; routines in their macro expansions. Use mh-require-cl to provide the cl
47 ;; routines in the best way possible.
48 (defmacro mh-require-cl
()
49 "Macro to load `cl' if needed.
50 Some versions of `cl' produce code for the expansion of
51 \(setf (gethash ...) ...) that uses functions in `cl' at run time. This macro
52 recognizes that and loads `cl' where appropriate."
53 (if (eq (car (macroexpand '(setf (gethash foo bar
) baz
))) 'cl-puthash
)
55 `(eval-when-compile (require 'cl
))))
57 ;;; Macros to generate correct code for different emacs variants
59 (defmacro mh-do-in-gnu-emacs
(&rest body
)
60 "Execute BODY if in GNU Emacs."
61 (unless (featurep 'xemacs
) `(progn ,@body
)))
62 (put 'mh-do-in-gnu-emacs
'lisp-indent-hook
'defun
)
64 (defmacro mh-do-in-xemacs
(&rest body
)
65 "Execute BODY if in GNU Emacs."
66 (when (featurep 'xemacs
) `(progn ,@body
)))
67 (put 'mh-do-in-xemacs
'lisp-indent-hook
'defun
)
69 (defmacro mh-funcall-if-exists
(function &rest args
)
70 "Call FUNCTION with ARGS as parameters if it exists."
71 (if (fboundp function
)
72 `(funcall ',function
,@args
)))
74 (defmacro mh-make-local-hook
(hook)
75 "Make HOOK local if needed.
76 XEmacs and versions of GNU Emacs before 21.1 require `make-local-hook' to be
78 (when (and (fboundp 'make-local-hook
)
79 (not (get 'make-local-hook
'byte-obsolete-info
)))
80 `(make-local-hook ,hook
)))
82 (defmacro mh-mark-active-p
(check-transient-mark-mode-flag)
83 "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
84 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if
85 variable `transient-mark-mode' is active."
86 (cond ((featurep 'xemacs
) ;XEmacs
87 `(and (boundp 'zmacs-regions
) zmacs-regions
(region-active-p)))
88 ((not check-transient-mark-mode-flag
) ;GNU Emacs
89 `(and (boundp 'mark-active
) mark-active
))
91 `(and (boundp 'transient-mark-mode
) transient-mark-mode
92 (boundp 'mark-active
) mark-active
))))
94 (defmacro mh-defstruct
(name-spec &rest fields
)
95 "Replacement for `defstruct' from the `cl' package.
96 The `defstruct' in the `cl' library produces compiler warnings, and generates
97 code that uses functions present in `cl' at run-time. This is a partial
98 replacement, that avoids these issues.
100 NAME-SPEC declares the name of the structure, while FIELDS describes the
101 various structure fields. Lookup `defstruct' for more details."
102 (let* ((struct-name (if (atom name-spec
) name-spec
(car name-spec
)))
103 (conc-name (or (and (consp name-spec
)
104 (cadr (assoc :conc-name
(cdr name-spec
))))
105 (format "%s-" struct-name
)))
106 (predicate (intern (format "%s-p" struct-name
)))
107 (constructor (or (and (consp name-spec
)
108 (cadr (assoc :constructor
(cdr name-spec
))))
109 (intern (format "make-%s" struct-name
))))
110 (field-names (mapcar #'(lambda (x) (if (atom x
) x
(car x
))) fields
))
111 (field-init-forms (mapcar #'(lambda (x) (and (consp x
) (cadr x
)))
113 (struct (gensym "S"))
117 (defun* ,constructor
(&key
,@(mapcar* #'(lambda (x y
) (list x y
))
118 field-names field-init-forms
))
119 (list (quote ,struct-name
) ,@field-names
))
120 (defun ,predicate
(arg)
121 (and (consp arg
) (eq (car arg
) (quote ,struct-name
))))
124 collect
`(defmacro ,(intern (format "%s%s" conc-name y
)) (z)
126 (quote ,struct-name
))))
128 (defadvice require
(around mh-prefer-el activate
)
129 "Modify `require' to load uncompiled MH-E files."
130 (or (featurep (ad-get-arg 0))
131 (and (string-match "^mh-" (symbol-name (ad-get-arg 0)))
132 (load (format "%s.el" (ad-get-arg 0)) t t
))
138 ;;; no-byte-compile: t
139 ;;; indent-tabs-mode: nil
140 ;;; sentence-end-double-space: nil
143 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
144 ;;; mh-acros.el ends here