X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3a801d0c71755fad1c33585e7ed54d9dc240999c..ad8b6d89ef6f038921104c219ff9010ee08cb0ca:/lisp/case-table.el diff --git a/lisp/case-table.el b/lisp/case-table.el index 1999f80cb8..4dfdd0538f 100644 --- a/lisp/case-table.el +++ b/lisp/case-table.el @@ -1,10 +1,11 @@ -;;; 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 Free Software Foundation, Inc. +;; Copyright (C) 1988, 1994, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Howard Gayle ;; Maintainer: FSF -;; Keywords: i14n +;; Keywords: i18n ;; This file is part of GNU Emacs. @@ -19,8 +20,9 @@ ;; GNU General Public License for more details. ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -33,62 +35,157 @@ ;;; Code: +(defvar set-case-syntax-offset 0) + +(defvar set-case-syntax-set-multibyte nil) + (defun describe-buffer-case-table () "Describe the case table of the current buffer." (interactive) - (let ((vector (make-vector 256 nil)) - (case-table (current-case-table)) - (i 0)) - (while (< i 256) - (aset vector i - (cond ((/= ch (downcase ch)) - (concat "uppercase, matches " - (text-char-description (downcase ch)))) - ((/= ch (upcase ch)) - (concat "lowercase, matches " - (text-char-description (upcase ch)))) - (t "case-invariant"))) - (setq i (1+ i)))) - (with-output-to-temp-buffer "*Help*" - (describe-vector vector))) - -(defun set-case-syntax-delims (l r string) + (let ((description (make-char-table 'case-table))) + (map-char-table + (function (lambda (key value) + (aset + description key + (cond ((not (natnump value)) + "case-invariant") + ((/= key (downcase key)) + (concat "uppercase, matches " + (char-to-string (downcase key)))) + ((/= key (upcase key)) + (concat "lowercase, matches " + (char-to-string (upcase key)))) + (t "case-invariant"))))) + (current-case-table)) + (save-excursion + (with-output-to-temp-buffer "*Help*" + (set-buffer standard-output) + (describe-vector description) + (help-mode))))) + +(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)) + (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)) + +(defsubst set-case-syntax-1 (char) + "Offset CHAR by `set-case-syntax-offset' if CHAR is a non-ASCII 8-bit char." + (if (and (>= char 128) (< char 256)) + (+ char set-case-syntax-offset) + char)) + +(defun set-case-syntax-delims (l r table) "Make characters L and R a matching pair of non-case-converting delimiters. -Sets the entries for L and R in STRING, which is a downcasing table. -Also modifies `standard-syntax-table', and `text-mode-syntax-table' to +This sets the entries for L and R in TABLE, which is a string +that will be used as the downcase part of a case table. +It also modifies `standard-syntax-table' to indicate left and right delimiters." - (aset string l l) - (aset string r r) - (modify-syntax-entry l (concat "(" (char-to-string r) " ") - (standard-syntax-table)) + (setq l (set-case-syntax-1 l)) + (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 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) " ") - text-mode-syntax-table) - (modify-syntax-entry r (concat ")" (char-to-string l) " ") (standard-syntax-table)) (modify-syntax-entry r (concat ")" (char-to-string l) " ") - text-mode-syntax-table)) + (standard-syntax-table))) -(defun set-case-syntax-pair (uc lc string) +(defun set-case-syntax-pair (uc lc table) "Make characters UC and LC a pair of inter-case-converting letters. -Sets the entries for characters UC and LC in STRING, which is a downcasing table. -Also modify `standard-syntax-table' and `text-mode-syntax-table' to indicate an -(uppercase, lowercase) pair of letters." - (aset string uc lc) - (aset (car (cdr (standard-case-table))) lc uc) +This sets the entries for characters UC and LC in TABLE, which is a string +that will be used as the downcase part of a case table. +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) + (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 lc "w " text-mode-syntax-table) - (modify-syntax-entry uc "w " (standard-syntax-table)) - (modify-syntax-entry uc "w " text-mode-syntax-table)) - -(defun set-case-syntax (c syntax string) - "Make characters C case-invariant with syntax SYNTAX. -Sets the entries for character C in STRING, which is the downcasing table. -Also modify `standard-syntax-table' and `text-mode-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))) + +(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 +that will be used as the downcase part of a case table. +It also modifies `standard-syntax-table'. SYNTAX should be \" \", \"w\", \".\" or \"_\"." - (aset string c c) - (modify-syntax-entry c syntax (standard-syntax-table)) - (modify-syntax-entry c syntax text-mode-syntax-table)) + (setq c (set-case-syntax-1 c)) + (aset table c c) + (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