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., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, 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
  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)
  54       `(progn
  55          (require 'cl)
  56          ;; Autoloads of CL functions go here...
  57          (autoload 'cl-puthash "cl")
  58          (autoload 'values "cl")
  59          (autoload 'copy-tree "cl"))
  60     `(eval-when-compile (require 'cl))))
  61
  62 ;;; Macros to generate correct code for different emacs variants
  63
  64 (defmacro mh-do-in-gnu-emacs (&rest body)
  65   "Execute BODY if in GNU Emacs."
  66   (unless (featurep 'xemacs) `(progn ,@body)))
  67 (put 'mh-do-in-gnu-emacs 'lisp-indent-hook 'defun)
  68
  69 (defmacro mh-do-in-xemacs (&rest body)
  70   "Execute BODY if in GNU Emacs."
  71   (when (featurep 'xemacs) `(progn ,@body)))
  72 (put 'mh-do-in-xemacs 'lisp-indent-hook 'defun)
  73
  74 (defmacro mh-funcall-if-exists (function &rest args)
  75   "Call FUNCTION with ARGS as parameters if it exists."
  76   (if (fboundp function)
  77       `(funcall ',function ,@args)))
  78
  79 (defmacro mh-make-local-hook (hook)
  80   "Make HOOK local if needed.
  81 XEmacs and versions of GNU Emacs before 21.1 require `make-local-hook' to be
  82 called."
  83   (when (and (fboundp 'make-local-hook)
  84              (not (get 'make-local-hook 'byte-obsolete-info)))
  85     `(make-local-hook ,hook)))
  86
  87 (defmacro mh-mark-active-p (check-transient-mark-mode-flag)
  88   "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs.
  89 In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if
  90 variable `transient-mark-mode' is active."
  91   (cond ((featurep 'xemacs)             ;XEmacs
  92          `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p)))
  93         ((not check-transient-mark-mode-flag) ;GNU Emacs
  94          `(and (boundp 'mark-active) mark-active))
  95         (t                              ;GNU Emacs
  96          `(and (boundp 'transient-mark-mode) transient-mark-mode
  97                (boundp 'mark-active) mark-active))))
  98
  99 (defmacro mh-defstruct (name-spec &rest fields)
 100   "Replacement for `defstruct' from the `cl' package.
 101 The `defstruct' in the `cl' library produces compiler warnings, and generates
 102 code that uses functions present in `cl' at run-time.  This is a partial
 103 replacement, that avoids these issues.
 104
 105 NAME-SPEC declares the name of the structure, while FIELDS describes the
 106 various structure fields. Lookup `defstruct' for 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
 134 (provide 'mh-acros)
 135
 136 ;;; Local Variables:
 137 ;;; no-byte-compile: t
 138 ;;; indent-tabs-mode: nil
 139 ;;; sentence-end-double-space: nil
 140 ;;; End:
 141
 142 ;; arch-tag: b383b49a-494f-4ed0-a30a-cb6d5d2da4ff
 143 ;;; mh-acros.el ends here