Fix bug #13723 with redrawing vertical border in GUI sessions.
[emacs.git] / lisp / case-table.el
blob711d4e4ec8ca1f4cb5577785b6393a0241a03652
1 ;;; case-table.el --- code to extend the character set and support case tables
3 ;; Copyright (C) 1988, 1994, 2001-2013 Free Software Foundation, Inc.
5 ;; Author: Howard Gayle
6 ;; Maintainer: FSF
7 ;; Keywords: i18n
8 ;; Package: emacs
10 ;; This file is part of GNU Emacs.
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.
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.
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/>.
25 ;;; Commentary:
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
34 ;;; Code:
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)))))
68 (defun get-upcase-table (case-table)
69 "Return the upcase table of CASE-TABLE."
70 (or (char-table-extra-slot case-table 0)
71 ;; Setup all extra slots of CASE-TABLE by temporarily selecting
72 ;; it as the standard case table.
73 (let ((old (standard-case-table)))
74 (unwind-protect
75 (progn
76 (set-standard-case-table case-table)
77 (char-table-extra-slot case-table 0))
78 (or (eq case-table old)
79 (set-standard-case-table old))))))
81 (defun copy-case-table (case-table)
82 (let ((copy (copy-sequence case-table))
83 (up (char-table-extra-slot case-table 0)))
84 ;; Clear out the extra slots (except for upcase table) so that
85 ;; they will be recomputed from the main (downcase) table.
86 (if up
87 (set-char-table-extra-slot copy 0 (copy-sequence up)))
88 (set-char-table-extra-slot copy 1 nil)
89 (set-char-table-extra-slot copy 2 nil)
90 copy))
92 (defun set-case-syntax-delims (l r table)
93 "Make characters L and R a matching pair of non-case-converting delimiters.
94 This sets the entries for L and R in TABLE, which is a string
95 that will be used as the downcase part of a case table.
96 It also modifies `standard-syntax-table' to
97 indicate left and right delimiters."
98 (aset table l l)
99 (aset table r r)
100 (let ((up (get-upcase-table table)))
101 (aset up l l)
102 (aset up r r))
103 ;; Clear out the extra slots so that they will be
104 ;; recomputed from the main (downcase) table and upcase table.
105 (set-char-table-extra-slot table 1 nil)
106 (set-char-table-extra-slot table 2 nil)
107 (modify-syntax-entry l (concat "(" (char-to-string r) " ")
108 (standard-syntax-table))
109 (modify-syntax-entry r (concat ")" (char-to-string l) " ")
110 (standard-syntax-table)))
112 (defun set-case-syntax-pair (uc lc table)
113 "Make characters UC and LC a pair of inter-case-converting letters.
114 This sets the entries for characters UC and LC in TABLE, which is a string
115 that will be used as the downcase part of a case table.
116 It also modifies `standard-syntax-table' to give them the syntax of
117 word constituents."
118 (aset table uc lc)
119 (aset table lc lc)
120 (let ((up (get-upcase-table table)))
121 (aset up uc uc)
122 (aset up lc uc))
123 ;; Clear out the extra slots so that they will be
124 ;; recomputed from the main (downcase) table and upcase table.
125 (set-char-table-extra-slot table 1 nil)
126 (set-char-table-extra-slot table 2 nil)
127 (modify-syntax-entry lc "w " (standard-syntax-table))
128 (modify-syntax-entry uc "w " (standard-syntax-table)))
130 (defun set-upcase-syntax (uc lc table)
131 "Make character UC an upcase of character LC.
132 It also modifies `standard-syntax-table' to give them the syntax of
133 word constituents."
134 (aset table lc lc)
135 (let ((up (get-upcase-table table)))
136 (aset up uc uc)
137 (aset up lc uc))
138 ;; Clear out the extra slots so that they will be
139 ;; recomputed from the main (downcase) table and upcase table.
140 (set-char-table-extra-slot table 1 nil)
141 (set-char-table-extra-slot table 2 nil)
142 (modify-syntax-entry lc "w " (standard-syntax-table))
143 (modify-syntax-entry uc "w " (standard-syntax-table)))
145 (defun set-downcase-syntax (uc lc table)
146 "Make character LC a downcase of character UC.
147 It also modifies `standard-syntax-table' to give them the syntax of
148 word constituents."
149 (aset table uc lc)
150 (aset table lc lc)
151 (let ((up (get-upcase-table table)))
152 (aset up uc uc))
153 ;; Clear out the extra slots so that they will be
154 ;; recomputed from the main (downcase) table and upcase table.
155 (set-char-table-extra-slot table 1 nil)
156 (set-char-table-extra-slot table 2 nil)
157 (modify-syntax-entry lc "w " (standard-syntax-table))
158 (modify-syntax-entry uc "w " (standard-syntax-table)))
160 (defun set-case-syntax (c syntax table)
161 "Make character C case-invariant with syntax SYNTAX.
162 This sets the entry for character C in TABLE, which is a string
163 that will be used as the downcase part of a case table.
164 It also modifies `standard-syntax-table'.
165 SYNTAX should be \" \", \"w\", \".\" or \"_\"."
166 (aset table c c)
167 (let ((up (get-upcase-table table)))
168 (aset up c c))
169 ;; Clear out the extra slots so that they will be
170 ;; recomputed from the main (downcase) table and upcase table.
171 (set-char-table-extra-slot table 1 nil)
172 (set-char-table-extra-slot table 2 nil)
173 (modify-syntax-entry c syntax (standard-syntax-table)))
175 (provide 'case-table)
177 ;;; case-table.el ends here