X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/adfb70a19a0070f62c53628241b5124380a835d3..dfe7296633a3b574b85adb0e47f2e0bcfee15efa:/lisp/case-table.el diff --git a/lisp/case-table.el b/lisp/case-table.el index c66f76919a..a69ed329cb 100644 --- a/lisp/case-table.el +++ b/lisp/case-table.el @@ -1,6 +1,7 @@ -;;; case-table.el --- code to extend the character set and support case tables. +;;; case-table.el --- code to extend the character set and support case tables -;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1988, 1994, 2002, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Howard Gayle ;; Maintainer: FSF @@ -20,8 +21,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -38,7 +39,6 @@ (defvar set-case-syntax-set-multibyte nil) -;;;###autoload (defun describe-buffer-case-table () "Describe the case table of the current buffer." (interactive) @@ -63,12 +63,26 @@ (describe-vector description) (help-mode))))) -;;;###autoload +(defun get-upcase-table (case-table) + "Return the upcase table of CASE-TABLE." + (or (char-table-extra-slot case-table 0) + ;; Setup all extra slots of CASE-TABLE by temporarily selecting + ;; it as the standard case table. + (let ((old (standard-case-table))) + (unwind-protect + (progn + (set-standard-case-table case-table) + (char-table-extra-slot case-table 0)) + (or (eq case-table old) + (set-standard-case-table old)))))) + (defun copy-case-table (case-table) - (let ((copy (copy-sequence case-table))) - ;; Clear out the extra slots so that they will be - ;; recomputed from the main (downcase) table. - (set-char-table-extra-slot copy 0 nil) + (let ((copy (copy-sequence case-table)) + (up (char-table-extra-slot case-table 0))) + ;; Clear out the extra slots (except for upcase table) so that + ;; they will be recomputed from the main (downcase) table. + (if up + (set-char-table-extra-slot copy 0 (copy-sequence up))) (set-char-table-extra-slot copy 1 nil) (set-char-table-extra-slot copy 2 nil) copy)) @@ -79,7 +93,6 @@ (+ char set-case-syntax-offset) char)) -;;;###autoload (defun set-case-syntax-delims (l r table) "Make characters L and R a matching pair of non-case-converting delimiters. This sets the entries for L and R in TABLE, which is a string @@ -90,9 +103,11 @@ indicate left and right delimiters." (setq r (set-case-syntax-1 r)) (aset table l l) (aset table r r) + (let ((up (get-upcase-table table))) + (aset up l l) + (aset up r r)) ;; Clear out the extra slots so that they will be - ;; recomputed from the main (downcase) table. - (set-char-table-extra-slot table 0 nil) + ;; recomputed from the main (downcase) table and upcase table. (set-char-table-extra-slot table 1 nil) (set-char-table-extra-slot table 2 nil) (modify-syntax-entry l (concat "(" (char-to-string r) " ") @@ -100,7 +115,6 @@ indicate left and right delimiters." (modify-syntax-entry r (concat ")" (char-to-string l) " ") (standard-syntax-table))) -;;;###autoload (defun set-case-syntax-pair (uc lc table) "Make characters UC and LC a pair of inter-case-converting letters. This sets the entries for characters UC and LC in TABLE, which is a string @@ -111,13 +125,50 @@ word constituents." (setq lc (set-case-syntax-1 lc)) (aset table uc lc) (aset table lc lc) - (set-char-table-extra-slot table 0 nil) + (let ((up (get-upcase-table table))) + (aset up uc uc) + (aset up lc uc)) + ;; Clear out the extra slots so that they will be + ;; recomputed from the main (downcase) table and upcase table. + (set-char-table-extra-slot table 1 nil) + (set-char-table-extra-slot table 2 nil) + (modify-syntax-entry lc "w " (standard-syntax-table)) + (modify-syntax-entry uc "w " (standard-syntax-table))) + +(defun set-upcase-syntax (uc lc table) + "Make character UC an upcase of character LC. +It also modifies `standard-syntax-table' to give them the syntax of +word constituents." + (setq uc (set-case-syntax-1 uc)) + (setq lc (set-case-syntax-1 lc)) + (aset table lc lc) + (let ((up (get-upcase-table table))) + (aset up uc uc) + (aset up lc uc)) + ;; Clear out the extra slots so that they will be + ;; recomputed from the main (downcase) table and upcase table. + (set-char-table-extra-slot table 1 nil) + (set-char-table-extra-slot table 2 nil) + (modify-syntax-entry lc "w " (standard-syntax-table)) + (modify-syntax-entry uc "w " (standard-syntax-table))) + +(defun set-downcase-syntax (uc lc table) + "Make character LC a downcase of character UC. +It also modifies `standard-syntax-table' to give them the syntax of +word constituents." + (setq uc (set-case-syntax-1 uc)) + (setq lc (set-case-syntax-1 lc)) + (aset table uc lc) + (aset table lc lc) + (let ((up (get-upcase-table table))) + (aset up uc uc)) + ;; Clear out the extra slots so that they will be + ;; recomputed from the main (downcase) table and upcase table. (set-char-table-extra-slot table 1 nil) (set-char-table-extra-slot table 2 nil) (modify-syntax-entry lc "w " (standard-syntax-table)) (modify-syntax-entry uc "w " (standard-syntax-table))) -;;;###autoload (defun set-case-syntax (c syntax table) "Make character C case-invariant with syntax SYNTAX. This sets the entry for character C in TABLE, which is a string @@ -126,11 +177,15 @@ It also modifies `standard-syntax-table'. SYNTAX should be \" \", \"w\", \".\" or \"_\"." (setq c (set-case-syntax-1 c)) (aset table c c) - (set-char-table-extra-slot table 0 nil) + (let ((up (get-upcase-table table))) + (aset up c c)) + ;; Clear out the extra slots so that they will be + ;; recomputed from the main (downcase) table and upcase table. (set-char-table-extra-slot table 1 nil) (set-char-table-extra-slot table 2 nil) (modify-syntax-entry c syntax (standard-syntax-table))) (provide 'case-table) +;;; arch-tag: 3c2cf885-2c9a-449a-9972-2e269191896d ;;; case-table.el ends here