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, 2006 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 most, if not all, macros. It is so named with a
  30 ;; silent "m" so that it is compiled first. Otherwise, "make
  31 ;; recompile" in CVS Emacs may use compiled files with stale macro
  32 ;; definitions.
  33
  34 ;; This file must always be included like this:
  35 ;;
  36 ;;   (eval-when-compile (require 'mh-acros))
  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-defun-compat (function arg-list &rest body)
  78   "This is a macro to define functions which are not defined.
  79 It is used for functions which were added to Emacs recently.
  80 If FUNCTION is not defined then it is defined to have argument
  81 list, ARG-LIST and body, BODY."
  82   (let ((defined-p (fboundp function)))
  83     (unless defined-p
  84       `(defun ,function ,arg-list ,@body))))
  85 (put 'mh-defun-compat 'lisp-indent-function 'defun)
  86
  87 (defmacro mh-defmacro-compat (function arg-list &rest body)
  88   "This is a macro to define functions which are not defined.
  89 It is used for macros which were added to Emacs recently.
  90 If FUNCTION is not defined then it is defined to have argument
  91 list, ARG-LIST and body, BODY."
  92   (let ((defined-p (fboundp function)))
  93     (unless defined-p
  94       `(defmacro ,function ,arg-list ,@body))))
  95 (put 'mh-defmacro-compat 'lisp-indent-function 'defun)
  96
  97 (defmacro mh-make-local-hook (hook)
  98   "Make HOOK local if needed.
  99 XEmacs and versions of GNU Emacs before 21.1 require
 100 `make-local-hook' to be called."
 101   (when (and (fboundp 'make-local-hook)
 102              (not (get 'make-local-hook 'byte-obsolete-info)))
 103     `(make-local-hook ,hook)))
 104
 105 (defmacro mh-mark-active-p (check-transient-mark-mode-flag)
 106   "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
 107 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then
 108 check if variable `transient-mark-mode' is active."
 109   (cond ((featurep 'xemacs)             ;XEmacs
 110          `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
 111         ((not check-transient-mark-mode-flag) ;GNU Emacs
 112          `(and (boundp 'mark-active) mark-active))
 113         (t                              ;GNU Emacs
 114          `(and (boundp 'transient-mark-mode) transient-mark-mode
 115                (boundp 'mark-active) mark-active))))
 116
 117 (defmacro mh-defstruct (name-spec &rest fields)
 118   "Replacement for `defstruct' from the \"cl\" package.
 119 The `defstruct' in the \"cl\" library produces compiler warnings,
 120 and generates code that uses functions present in \"cl\" at
 121 run-time. This is a partial replacement, that avoids these
 122 issues.
 123
 124 NAME-SPEC declares the name of the structure, while FIELDS
 125 describes the various structure fields. Lookup `defstruct' for
 126 more details."
 127   (let* ((struct-name (if (atom name-spec) name-spec (car name-spec)))
 128          (conc-name (or (and (consp name-spec)
 129                              (cadr (assoc :conc-name (cdr name-spec))))
 130                         (format "%s-" struct-name)))
 131          (predicate (intern (format "%s-p" struct-name)))
 132          (constructor (or (and (consp name-spec)
 133                                (cadr (assoc :constructor (cdr name-spec))))
 134                           (intern (format "make-%s" struct-name))))
 135          (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields))
 136          (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x)))
 137                                    fields))
 138          (struct (gensym "S"))
 139          (x (gensym "X"))
 140          (y (gensym "Y")))
 141     `(progn
 142        (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y))
 143                                              field-names field-init-forms))
 144          (list (quote ,struct-name) ,@field-names))
 145        (defun ,predicate (arg)
 146          (and (consp arg) (eq (car arg) (quote ,struct-name))))
 147        ,@(loop for x from 1
 148                for y in field-names
 149                collect `(defmacro ,(intern (format "%s%s" conc-name y)) (z)
 150                           (list 'nth ,x z)))
 151        (quote ,struct-name))))
 152
 153 (unless (fboundp 'assoc-string)
 154   (defsubst assoc-string (key list case-fold)
 155     "Like `assoc' but specifically for strings.
 156 Case is ignored if CASE-FOLD is non-nil.
 157 This function added by MH-E for Emacs versions that lack
 158 `assoc-string', introduced in Emacs 22."
 159     (if case-fold
 160         (assoc-ignore-case key list)
 161       (assoc key list))))
 162
 163 (provide 'mh-acros)
 164
 165 ;; Local Variables:
 166 ;; no-byte-compile: t
 167 ;; indent-tabs-mode: nil
 168 ;; sentence-end-double-space: nil
 169 ;; End:
 170
 171 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
 172 ;;; mh-acros.el ends here