1;;; case-table.el --- code to extend the character set and support case tables 2 3;; Copyright (C) 1988, 1994, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Howard Gayle 7;; Maintainer: FSF 8;; Keywords: i18n 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., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 29;; Written by: 30;; TN/ETX/TX/UMG Howard Gayle UUCP : seismo!enea!erix!howard 31;; Telefonaktiebolaget L M Ericsson Phone: +46 8 719 55 65 32;; Ericsson Telecom Telex: 14910 ERIC S 33;; S-126 25 Stockholm FAX : +46 8 719 64 82 34;; Sweden 35 36;;; Code: 37 38(defvar set-case-syntax-offset 0) 39 40(defvar set-case-syntax-set-multibyte nil) 41 42(defun describe-buffer-case-table () 43 "Describe the case table of the current buffer." 44 (interactive) 45 (let ((description (make-char-table 'case-table))) 46 (map-char-table 47 (function (lambda (key value) 48 (aset 49 description key 50 (cond ((not (natnump value)) 51 "case-invariant") 52 ((/= key (downcase key)) 53 (concat "uppercase, matches " 54 (char-to-string (downcase key)))) 55 ((/= key (upcase key)) 56 (concat "lowercase, matches " 57 (char-to-string (upcase key)))) 58 (t "case-invariant"))))) 59 (current-case-table)) 60 (save-excursion 61 (with-output-to-temp-buffer "*Help*" 62 (set-buffer standard-output) 63 (describe-vector description) 64 (help-mode))))) 65 66(defun get-upcase-table (case-table) 67 "Return the upcase table of CASE-TABLE." 68 (or (char-table-extra-slot case-table 0) 69 ;; Setup all extra slots of CASE-TABLE by temporarily selecting 70 ;; it as the standard case table. 71 (let ((old (standard-case-table))) 72 (unwind-protect 73 (progn 74 (set-standard-case-table case-table) 75 (char-table-extra-slot case-table 0)) 76 (or (eq case-table old) 77 (set-standard-case-table old)))))) 78 79(defun copy-case-table (case-table) 80 (let ((copy (copy-sequence case-table)) 81 (up (char-table-extra-slot case-table 0))) 82 ;; Clear out the extra slots (except for upcase table) so that 83 ;; they will be recomputed from the main (downcase) table. 84 (if up 85 (set-char-table-extra-slot copy 0 (copy-sequence up))) 86 (set-char-table-extra-slot copy 1 nil) 87 (set-char-table-extra-slot copy 2 nil) 88 copy)) 89 90(defsubst set-case-syntax-1 (char) 91 "Offset CHAR by `set-case-syntax-offset' if CHAR is a non-ASCII 8-bit char." 92 (if (and (>= char 128) (< char 256)) 93 (+ char set-case-syntax-offset) 94 char)) 95 96(defun set-case-syntax-delims (l r table) 97 "Make characters L and R a matching pair of non-case-converting delimiters. 98This sets the entries for L and R in TABLE, which is a string 99that will be used as the downcase part of a case table. 100It also modifies `standard-syntax-table' to 101indicate left and right delimiters." 102 (setq l (set-case-syntax-1 l)) 103 (setq r (set-case-syntax-1 r)) 104 (aset table l l) 105 (aset table r r) 106 (let ((up (get-upcase-table table))) 107 (aset up l l) 108 (aset up r r)) 109 ;; Clear out the extra slots so that they will be 110 ;; recomputed from the main (downcase) table and upcase table. 111 (set-char-table-extra-slot table 1 nil) 112 (set-char-table-extra-slot table 2 nil) 113 (modify-syntax-entry l (concat "(" (char-to-string r) " ") 114 (standard-syntax-table)) 115 (modify-syntax-entry r (concat ")" (char-to-string l) " ") 116 (standard-syntax-table))) 117 118(defun set-case-syntax-pair (uc lc table) 119 "Make characters UC and LC a pair of inter-case-converting letters. 120This sets the entries for characters UC and LC in TABLE, which is a string 121that will be used as the downcase part of a case table. 122It also modifies `standard-syntax-table' to give them the syntax of 123word constituents." 124 (setq uc (set-case-syntax-1 uc)) 125 (setq lc (set-case-syntax-1 lc)) 126 (aset table uc lc) 127 (aset table lc lc) 128 (let ((up (get-upcase-table table))) 129 (aset up uc uc) 130 (aset up lc uc)) 131 ;; Clear out the extra slots so that they will be 132 ;; recomputed from the main (downcase) table and upcase table. 133 (set-char-table-extra-slot table 1 nil) 134 (set-char-table-extra-slot table 2 nil) 135 (modify-syntax-entry lc "w " (standard-syntax-table)) 136 (modify-syntax-entry uc "w " (standard-syntax-table))) 137 138(defun set-upcase-syntax (uc lc table) 139 "Make character UC an upcase of character LC. 140It also modifies `standard-syntax-table' to give them the syntax of 141word constituents." 142 (setq uc (set-case-syntax-1 uc)) 143 (setq lc (set-case-syntax-1 lc)) 144 (aset table lc lc) 145 (let ((up (get-upcase-table table))) 146 (aset up uc uc) 147 (aset up lc uc)) 148 ;; Clear out the extra slots so that they will be 149 ;; recomputed from the main (downcase) table and upcase table. 150 (set-char-table-extra-slot table 1 nil) 151 (set-char-table-extra-slot table 2 nil) 152 (modify-syntax-entry lc "w " (standard-syntax-table)) 153 (modify-syntax-entry uc "w " (standard-syntax-table))) 154 155(defun set-downcase-syntax (uc lc table) 156 "Make character LC a downcase of character UC. 157It also modifies `standard-syntax-table' to give them the syntax of 158word constituents." 159 (setq uc (set-case-syntax-1 uc)) 160 (setq lc (set-case-syntax-1 lc)) 161 (aset table uc lc) 162 (aset table lc lc) 163 (let ((up (get-upcase-table table))) 164 (aset up uc uc)) 165 ;; Clear out the extra slots so that they will be 166 ;; recomputed from the main (downcase) table and upcase table. 167 (set-char-table-extra-slot table 1 nil) 168 (set-char-table-extra-slot table 2 nil) 169 (modify-syntax-entry lc "w " (standard-syntax-table)) 170 (modify-syntax-entry uc "w " (standard-syntax-table))) 171 172(defun set-case-syntax (c syntax table) 173 "Make character C case-invariant with syntax SYNTAX. 174This sets the entry for character C in TABLE, which is a string 175that will be used as the downcase part of a case table. 176It also modifies `standard-syntax-table'. 177SYNTAX should be \" \", \"w\", \".\" or \"_\"." 178 (setq c (set-case-syntax-1 c)) 179 (aset table c c) 180 (let ((up (get-upcase-table table))) 181 (aset up c c)) 182 ;; Clear out the extra slots so that they will be 183 ;; recomputed from the main (downcase) table and upcase table. 184 (set-char-table-extra-slot table 1 nil) 185 (set-char-table-extra-slot table 2 nil) 186 (modify-syntax-entry c syntax (standard-syntax-table))) 187 188(provide 'case-table) 189 190;;; arch-tag: 3c2cf885-2c9a-449a-9972-2e269191896d 191;;; case-table.el ends here 192