cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-macro.el

   1 ;;; vm-macro.el ---  Random VM macros
   2 ;;
   3 ;; Copyright (C) 1989-1997 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21 (defsubst vm-marker (pos &optional buffer)
  22   (set-marker (make-marker) pos buffer))
  23
  24 (defsubst vm-select-folder-buffer ()
  25   (cond (vm-mail-buffer
  26          (or (buffer-name vm-mail-buffer)
  27              (error "Folder buffer has been killed."))
  28          (set-buffer vm-mail-buffer))
  29         ((not (memq major-mode '(vm-mode vm-virtual-mode)))
  30          (error "No VM folder buffer associated with this buffer"))))
  31
  32 (defsubst vm-select-folder-buffer-if-possible ()
  33   (cond ((and (bufferp vm-mail-buffer)
  34               (buffer-name vm-mail-buffer))
  35          (set-buffer vm-mail-buffer))))
  36
  37 (defsubst vm-error-if-folder-read-only ()
  38   (while vm-folder-read-only
  39     (signal 'folder-read-only (list (current-buffer)))))
  40
  41 (defsubst vm-error-if-virtual-folder ()
  42   (and (eq major-mode 'vm-virtual-mode)
  43        (error "%s cannot be applied to virtual folders." this-command)))
  44
  45 (defsubst vm-build-threads-if-unbuilt ()
  46   (if (not (vectorp vm-thread-obarray))
  47       (vm-build-threads nil)))
  48
  49 (defsubst vm-binary-coding-system ()
  50   (cond (vm-xemacs-mule-p 'binary)
  51         (vm-xemacs-file-coding-p 'binary)
  52         (t 'no-conversion)))
  53
  54 (defsubst vm-line-ending-coding-system ()
  55   (cond (vm-xemacs-mule-p 'no-conversion)
  56         (vm-xemacs-file-coding-p 'no-conversion)
  57         (t 'raw-text)))
  58
  59 ;;; can't use defsubst where quoting is needed in some places but
  60 ;; not others.
  61
  62 ;; save-restriction flubs restoring the clipping region if you
  63 ;; (widen) and modify text outside the old region.
  64 ;; This should do it right.
  65 (defmacro vm-save-restriction (&rest forms)
  66   (let ((vm-sr-clip (make-symbol "vm-sr-clip"))
  67         (vm-sr-min (make-symbol "vm-sr-min"))
  68         (vm-sr-max (make-symbol "vm-sr-max")))
  69     `(let ((,vm-sr-clip (> (buffer-size) (- (point-max) (point-min))))
  70            ;; this shouldn't be necessary but the
  71            ;; byte-compiler turns these into interned symbols
  72            ;; which utterly defeats the purpose of the
  73            ;; make-symbol calls above.  Soooo, until the compiler
  74            ;; is fixed, these must be made into (let ...)
  75            ;; temporaries so that nested calls to this macros
  76            ;; won't misbehave.
  77            ,vm-sr-min ,vm-sr-max)
  78           (and ,vm-sr-clip
  79                (setq ,vm-sr-min (set-marker (make-marker) (point-min)))
  80                (setq ,vm-sr-max (set-marker (make-marker) (point-max))))
  81           (unwind-protect
  82               (progn ,@forms)
  83             (widen)
  84             (and ,vm-sr-clip
  85                  (progn
  86                    (narrow-to-region ,vm-sr-min ,vm-sr-max)
  87                    (set-marker ,vm-sr-min nil)
  88                    (set-marker ,vm-sr-max nil)))))))
  89
  90 (defmacro vm-save-buffer-excursion (&rest forms)
  91   `(let ((vm-sbe-buffer (current-buffer)))
  92     (unwind-protect
  93         (progn ,@forms)
  94       (and (not (eq vm-sbe-buffer (current-buffer)))
  95            (buffer-name vm-sbe-buffer)
  96            (set-buffer vm-sbe-buffer)))))
  97
  98 (defmacro vm-assert (expression)
  99   (list 'or expression
 100         (list 'let
 101               (list (list 'debug-on-error t))
 102               (list 'error "assertion failed: %S"
 103                     (list 'quote expression)))))
 104
 105 (defmacro vm-increment (variable)
 106   (list 'setq variable (list '1+ variable)))
 107
 108 (defmacro vm-decrement (variable)
 109   (list 'setq variable (list '1- variable)))
 110
 111 (provide 'vm-macro)
 112
 113 ;;; vm-macro.el ends here