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