code.delx.au - gnu-emacs/blob - lisp/mh-e/mh-acros.el

   1 ;;; mh-acros.el --- Macros used in MH-E
   2
   3 ;; Copyright (C) 2004 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 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:
  32 ;;
  33 ;;   (eval-when-compile (require 'mh-acros))
  34 ;;
  35 ;; It is so named with a silent "m" so that it is compiled first. Otherwise,
  36 ;; "make recompile" in Emacs 21.4 fails.
  37
  38 ;;; Change Log:
  39
  40 ;;; Code:
  41
  42 (require 'cl)
  43 (require 'advice)
  44
  45 ;; The Emacs coding conventions require that the cl package not be required at
  46 ;; runtime. However, the cl package in versions of Emacs prior to 21.4 left cl
  47 ;; routines in their macro expansions. Use mh-require-cl to provide the cl
  48 ;; routines in the best way possible.
  49 (defmacro mh-require-cl ()
  50   "Macro to load \"cl\" if needed.
  51 Some versions of \"cl\" produce code for the expansion of
  52 \(setf (gethash ...) ...) that uses functions in \"cl\" at run
  53 time. This macro recognizes that and loads \"cl\" where
  54 appropriate."
  55   (if (eq (car (macroexpand '(setf (gethash foo bar) baz))) 'cl-puthash)
  56       `(require 'cl)
  57     `(eval-when-compile (require 'cl))))
  58
  59 ;; Macros to generate correct code for different emacs variants
  60
  61 (defmacro mh-do-in-gnu-emacs (&rest body)
  62   "Execute BODY if in GNU Emacs."
  63   (unless (featurep 'xemacs) `(progn ,@body)))
  64 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
  65
  66 (defmacro mh-do-in-xemacs (&rest body)
  67   "Execute BODY if in GNU Emacs."
  68   (when (featurep 'xemacs) `(progn ,@body)))
  69 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
  70
  71 (defmacro mh-funcall-if-exists (function &rest args)
  72   "Call FUNCTION with ARGS as parameters if it exists."
  73   (when (fboundp function)
  74     `(when (fboundp ',function)
  75        (funcall ',function ,@args))))
  76
  77 (defmacro mh-make-local-hook (hook)
  78   "Make HOOK local if needed.
  79 XEmacs and versions of GNU Emacs before 21.1 require
  80 `make-local-hook' to be called."
  81   (when (and (fboundp 'make-local-hook)
  82              (not (get 'make-local-hook 'byte-obsolete-info)))
  83     `(make-local-hook ,hook)))
  84
  85 (defmacro mh-mark-active-p (check-transient-mark-mode-flag)
  86   "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
  87 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then
  88 check if variable `transient-mark-mode' is active."
  89   (cond ((featurep 'xemacs)             ;XEmacs
  90          `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
  91         ((not check-transient-mark-mode-flag) ;GNU Emacs
  92          `(and (boundp 'mark-active) mark-active))
  93         (t                              ;GNU Emacs
  94          `(and (boundp 'transient-mark-mode) transient-mark-mode
  95                (boundp 'mark-active) mark-active))))
  96
  97 (defmacro mh-defstruct (name-spec &rest fields)
  98   "Replacement for `defstruct' from the \"cl\" package.
  99 The `defstruct' in the \"cl\" library produces compiler warnings,
 100 and generates code that uses functions present in \"cl\" at
 101 run-time. This is a partial replacement, that avoids these
 102 issues.
 103
 104 NAME-SPEC declares the name of the structure, while FIELDS
 105 describes the various structure fields. Lookup `defstruct' for
 106 more details."
 107   (let* ((struct-name (if (atom name-spec) name-spec (car name-spec)))
 108          (conc-name (or (and (consp name-spec)
 109                              (cadr (assoc :conc-name (cdr name-spec))))
 110                         (format "%s-" struct-name)))
 111          (predicate (intern (format "%s-p" struct-name)))
 112          (constructor (or (and (consp name-spec)
 113                                (cadr (assoc :constructor (cdr name-spec))))
 114                           (intern (format "make-%s" struct-name))))
 115          (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields))
 116          (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x)))
 117                                    fields))
 118          (struct (gensym "S"))
 119          (x (gensym "X"))
 120          (y (gensym "Y")))
 121     `(progn
 122        (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y))
 123                                              field-names field-init-forms))
 124          (list (quote ,struct-name) ,@field-names))
 125        (defun ,predicate (arg)
 126          (and (consp arg) (eq (car arg) (quote ,struct-name))))
 127        ,@(loop for x from 1
 128                for y in field-names
 129                collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z)
 130                           (list 'nth ,x z)))
 131        (quote ,struct-name))))
 132
 133 (defadvice require (around mh-prefer-el activate)
 134   "Modify `require' to load uncompiled MH-E files."
 135   (or (featurep (ad-get-arg 0))
 136       (and (string-match "^mh-" (symbol-name (ad-get-arg 0)))
 137            (load (format "%s.el" (ad-get-arg 0)) t t))
 138       ad-do-it))
 139
 140 (defmacro mh-assoc-ignore-case (key alist)
 141   "Check if KEY is present in ALIST while ignoring case to do the comparison.
 142 Compatibility macro for Emacs versions that lack `assoc-string',
 143 introduced in Emacs 22."
 144   (if (fboundp 'assoc-string)
 145       `(assoc-string ,key ,alist t)
 146     `(assoc-ignore-case ,key ,alist)))
 147
 148 (provide 'mh-acros)
 149
 150 ;; Local Variables:
 151 ;; no-byte-compile: t
 152 ;; indent-tabs-mode: nil
 153 ;; sentence-end-double-space: nil
 154 ;; End:
 155
 156 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
 157 ;;; mh-acros.el ends here