cgit.sxemacs.org Git - packages/blob - xemacs-packages/x-symbol/lisp/x-symbol-macs.el

   1 ;;; x-symbol-macs.el --- macros used when compiling or interpreting x-symbol.el
   2
   3 ;; Copyright (C) 1998-2002 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Christoph Wedler <wedler@users.sourceforge.net>
   6 ;; Maintainer: (Please use `M-x x-symbol-package-bug' to contact the maintainer)
   7 ;; Version: 4.5
   8 ;; Keywords: WYSIWYG, LaTeX, HTML, wp, math, internationalization
   9 ;; X-URL: http://x-symbol.sourceforge.net/
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, write to the Free Software
  23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; If you want to use package x-symbol, please visit the URL (use
  28 ;; \\[x-symbol-package-web]) and read the info (use \\[x-symbol-package-info]).
  29
  30 ;; Macro expansion must not dependent on Mule vs no-Mule!  Depending on Emacs
  31 ;; vs XEmacs is OK, since the elc files aren't compatible anyway.
  32
  33 ;;; Code:
  34
  35 (provide 'x-symbol-macs)
  36 (require 'cl)
  37
  38
  39 ;;;===========================================================================
  40 ;;;
  41 ;;;===========================================================================
  42
  43 (defmacro x-symbol-ignore-property-changes (&rest body)
  44   (if (featurep 'xemacs)
  45       (cons 'progn body)
  46     (let ((modified (gensym "--x-symbol-modified--")))
  47       `(let ((,modified (buffer-modified-p))
  48              (buffer-undo-list t)
  49              (inhibit-read-only t)
  50              (inhibit-modification-hooks t)
  51              (inhibit-point-motion-hooks t))
  52          (unwind-protect
  53              (progn ,@body)
  54            (and (not ,modified) (buffer-modified-p)
  55                 (set-buffer-modified-p nil)))))))
  56
  57
  58 ;;;===========================================================================
  59 ;;;  Function used by macros and the macros
  60 ;;;===========================================================================
  61
  62 (defun x-symbol-set/push-assq/assoc (x key alist pushp test)
  63   (let* ((temp (gensym "--x-symbol-set/push-assq/assoc-temp--"))
  64          (evalp (and (consp key) (null (eq (car key) 'quote))))
  65          (keysymb (if evalp
  66                       (gensym "--x-symbol-set/push-assq/assoc-temp--")
  67                     key))
  68          (keydef (and evalp (list (list keysymb key)))))
  69     `(let* (,@keydef
  70             (,temp (,test ,keysymb ,alist)))
  71        (if ,temp
  72            (setcdr ,temp ,(if pushp `(cons ,x (cdr ,temp)) x))
  73          (setq ,alist (cons (,(if pushp 'list 'cons) ,keysymb ,x) ,alist)))
  74        ,temp)))
  75
  76 (defmacro x-symbol-set-assq (x key alist)
  77   "Set X to be the association for KEY in ALIST.
  78 If no car of an element in ALIST is `eq' to KEY, inserts (KEY . X) at
  79 the head of ALIST."
  80   (x-symbol-set/push-assq/assoc x key alist nil 'assq))
  81
  82 (defmacro x-symbol-set-assoc (x key alist)
  83   "Set X to be the association for KEY in ALIST.
  84 If no car of an element in ALIST is `equal' to KEY, inserts (KEY . X) at
  85 the head of ALIST."
  86   (x-symbol-set/push-assq/assoc x key alist nil 'assoc))
  87
  88 (defmacro x-symbol-push-assq (x key alist)
  89   "Insert X at the head of the association for KEY in ALIST.
  90 If no car of an element in ALIST is `eq' to KEY, inserts (KEY X) at the
  91 head of ALIST.  An element (KEY A B) would look like (KEY X A B) after
  92 the operation."
  93   (x-symbol-set/push-assq/assoc x key alist t 'assq))
  94
  95 (defmacro x-symbol-push-assoc (x key alist)
  96   "Insert X at the head of the association for KEY in ALIST.
  97 If no car of an element in ALIST is `equal' to KEY, inserts (KEY X) at
  98 the head of ALIST.  An element (KEY A B) would look like (KEY X A B)
  99 after the operation."
 100   (x-symbol-set/push-assq/assoc x key alist t 'assoc))
 101
 102
 103 ;;;===========================================================================
 104 ;;;  Macros
 105 ;;;===========================================================================
 106
 107 (defmacro x-symbol-dolist-delaying (spec cond &rest body)
 108   ;; checkdoc-params: (spec)
 109   "Loop over a list delaying elements if condition yields non-nil.
 110 The macro looks like
 111   (x-symbol-dolist-delaying (VAR LIST [WORKING [DELAYED]]) COND BODY...)
 112 Bind VAR to each `car' from LIST, in turn.  If COND yields nil, evaluate
 113 BODY.  Otherwise, BODY with VAR bound to the list value is evaluated
 114 after all other list values have been processed.  Return all list
 115 values which could not been processed.
 116
 117 The looping is done in cycles.  In each cycle, the value of WORKING,
 118 which defaults to some internal symbol, is the list of elements still to
 119 be processed during the current cycle.  VAR is always the head of
 120 WORKING.  If COND yields non-nil, VAR is inserted at the head of the
 121 list stored in DELAYED which defaults to some internal symbol.  At the
 122 end of each CYCLE, WORKING is set to the reversed value of DELAYED.  The
 123 macro ends if all elements has been processed or all elements in a cycle
 124 has been inserted into the delayed list."
 125   (let ((working (or (nth 2 spec)
 126                      (gensym "--x-symbol-dolist-delaying-temp--")))
 127         (delayed (or (nth 3 spec)
 128                      (gensym "--x-symbol-dolist-delaying-temp--")))
 129         (non-circ (gensym "--x-symbol-dolist-delaying-temp--")))
 130     `(block nil
 131        (let ((,working ,(nth 1 spec))
 132              (,non-circ t)
 133              ,delayed
 134              ,(car spec))
 135          (while (and ,working ,non-circ)
 136            (setq ,delayed nil
 137                  ,non-circ nil)
 138            (while ,working
 139              (setq ,(car spec) (car ,working))
 140              (if ,cond
 141                  (setq ,delayed (cons ,(car spec) ,delayed))
 142                ,@body
 143                (setq ,non-circ t))
 144              (setq ,working (cdr ,working)))
 145            (setq ,working (nreverse ,delayed)))
 146          ,working))))
 147
 148 (defmacro x-symbol-do-plist (spec &rest body)
 149   ;; checkdoc-params: (spec)
 150   "Loop over a property list.
 151 The macro looks like
 152   (x-symbol-do-plist (PROP VAR PLIST) BODY...)
 153 Evaluate BODY with each PROP bound to each property of PLIST and VAR
 154 bound to the corresponding value, in turn.  PROP and VAR can also be nil
 155 if their value is not important.  Return nil."
 156   (let ((plist (gensym "--x-symbol-do-plist-temp--")))
 157     `(block nil
 158        (let ((,plist ,(nth 2 spec))
 159              ,@(and (car spec) (list (car spec)))
 160              ,@(and (nth 1 spec) (list (nth 1 spec))))
 161          (while ,plist
 162            (setq ,@(and (car spec) `(,(car spec) (car ,plist)))
 163                  ,@(and (nth 1 spec) `(,(nth 1 spec) (cadr ,plist))))
 164            ,@body
 165            (setq ,plist (cddr ,plist)))
 166          nil))))
 167
 168 (defmacro x-symbol-while-charsym (spec &rest body)
 169   "(x-symbol-while-charsym (CHARSYM CHAR) BODY...)"
 170   (unless (and (consp spec)
 171                (symbolp (car spec))
 172                (symbolp (cadr spec))
 173                (null (cddr spec)))
 174     (error "Wrong call of `x-symbol-while-charsym'."))
 175   (let ((charsym (car spec))
 176         (char (cadr spec)))
 177     `(let (,charsym ,char)
 178        (block nil
 179          (skip-chars-forward "\000-\177")
 180          (while (setq ,char (char-after))
 181            (if (setq ,charsym
 182                      ,(if (featurep 'xemacs)
 183                           '(x-symbol-encode-charsym-after)
 184                         ;; no need for nomule byte-comp in Emacs => inline
 185                         `(get-char-table ,char x-symbol-mule-char-table)))
 186                (progn ,@body)
 187              (forward-char x-symbol-encode-rchars))
 188            (skip-chars-forward "\000-\177"))))))
 189
 190 (defmacro x-symbol-encode-for-charsym (spec &rest body)
 191   "(x-symbol-while-charsym ((TOKEN-TABLE FCHAR-TABLE FCHAR-FALLBACK-TABLE) TOKEN CHARSYM)) BODY...)"
 192   (let* ((tables (car spec))
 193          (vars (cdr spec))
 194          (fchar-table (cadr tables))
 195          (fchar-fb-table (caddr tables))
 196          (token (car vars))
 197          (charsym (or (cadr vars)
 198                       (gensym "--x-symbol-encode-for-charsym-temp--")))
 199          (char (gensym "--x-symbol-encode-for-charsym-temp--"))
 200          (fchar (gensym "--x-symbol-encode-for-charsym-temp--")))
 201     `(let (,fchar ,token)
 202        (x-symbol-while-charsym ,(list charsym char)
 203          (cond ((and ,fchar-table
 204                      (setq ,fchar (gethash ,charsym ,fchar-table)))
 205                 ;; fchar-fb-table = nil => no recoding
 206                 (if (or (null ,fchar-fb-table) (eq ,fchar ,char))
 207                     (forward-char x-symbol-encode-rchars)
 208                   (insert ,fchar)
 209                   (delete-char x-symbol-encode-rchars)))
 210                ((setq ,token (gethash ,charsym ,(car tables)))
 211                 ,@body)
 212                ((setq ,fchar (gethash ,charsym ,fchar-fb-table))
 213                 (if (eq ,fchar ,char)
 214                     (forward-char x-symbol-encode-rchars)
 215                   (insert ,fchar)
 216                   (delete-char x-symbol-encode-rchars)))
 217                (t
 218                 (forward-char x-symbol-encode-rchars)))))))
 219
 220 (defmacro x-symbol-decode-for-charsym (spec undefined &rest body)
 221   "(x-symbol-decode-for-charsym ((REGEXP DECODE-OBARRAY CASE-FN) DEFN BEG END) UNDEFINED BODY...)"
 222   (let* ((grammar (car spec))
 223          (case-fn (caddar spec))
 224          (defn (cadr spec))
 225          (beg (caddr spec))
 226          (end (cadddr spec)))
 227     `(let (,beg ,end ,defn)
 228        (block nil
 229          (while (re-search-forward ,(car grammar) nil t)
 230            (setq ,beg (match-beginning 0)
 231                  ,end (match-end 0))
 232            (if (setq ,defn (intern-soft
 233                             ,(if case-fn
 234                                  `(if ,case-fn
 235                                       (funcall ,case-fn
 236                                                (buffer-substring ,beg ,end))
 237                                     (buffer-substring ,beg ,end))
 238                                `(buffer-substring ,beg ,end))
 239                             ,(cadr grammar)))
 240                (progn
 241                  (setq ,defn (symbol-value ,defn)) ; nil shouldn't happen
 242                  ,@body)
 243              ,@(if undefined (list undefined))))))))
 244
 245 (defmacro x-symbol-decode-unique-test (token-spec unique)
 246   `(and ,unique
 247         (or (cddr ,token-spec)
 248             (and (hash-table-p ,unique)
 249                  (gethash (car ,token-spec) ,unique)))))
 250
 251 (defmacro x-symbol-set-buffer-multibyte ()
 252   ;; Make sure the buffer is not in unibyte mode (for Emacs).
 253   (unless (featurep 'xemacs)
 254     '(set-buffer-multibyte t)))
 255
 256 ;;; Local IspellPersDict: .ispell_xsymb
 257 ;;; x-symbol-macs.el ends here