Line data Source code
1 : ;;; case-table.el --- code to extend the character set and support case tables -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 1988, 1994, 2001-2017 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 0 : (let ((description (make-char-table 'case-table)))
40 0 : (map-char-table
41 0 : (function (lambda (key value)
42 0 : (if (not (natnump value))
43 0 : (if (consp key)
44 0 : (set-char-table-range description key "case-invariant")
45 0 : (aset description key "case-invariant"))
46 0 : (let (from to)
47 0 : (if (consp key)
48 0 : (setq from (car key) to (cdr key))
49 0 : (setq from (setq to key)))
50 0 : (while (<= from to)
51 0 : (aset
52 0 : description from
53 0 : (cond ((/= from (downcase from))
54 0 : (concat "uppercase, matches "
55 0 : (char-to-string (downcase from))))
56 0 : ((/= from (upcase from))
57 0 : (concat "lowercase, matches "
58 0 : (char-to-string (upcase from))))
59 0 : (t "case-invariant")))
60 0 : (setq from (1+ from)))))))
61 0 : (current-case-table))
62 0 : (save-excursion
63 0 : (with-output-to-temp-buffer "*Help*"
64 0 : (set-buffer standard-output)
65 0 : (describe-vector description)
66 0 : (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 0 : (let ((slot-nb (cdr (assq table '((up . 0) (canon . 1) (eqv . 2))))))
72 0 : (or (if (eq table 'down) case-table)
73 0 : (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 0 : (let ((old (standard-case-table)))
77 0 : (unwind-protect
78 0 : (progn
79 0 : (set-standard-case-table case-table)
80 0 : (char-table-extra-slot case-table slot-nb))
81 0 : (or (eq case-table old)
82 0 : (set-standard-case-table old)))))))
83 :
84 : (defun get-upcase-table (case-table)
85 : "Return the upcase table of CASE-TABLE."
86 0 : (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 0 : (let ((copy (copy-sequence case-table))
91 0 : (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 0 : (if up
95 0 : (set-char-table-extra-slot copy 0 (copy-sequence up)))
96 0 : (set-char-table-extra-slot copy 1 nil)
97 0 : (set-char-table-extra-slot copy 2 nil)
98 0 : 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 0 : (aset table l l)
107 0 : (aset table r r)
108 0 : (let ((up (case-table-get-table table 'up)))
109 0 : (aset up l l)
110 0 : (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 0 : (set-char-table-extra-slot table 1 nil)
114 0 : (set-char-table-extra-slot table 2 nil)
115 0 : (modify-syntax-entry l (concat "(" (char-to-string r) " ")
116 0 : (standard-syntax-table))
117 0 : (modify-syntax-entry r (concat ")" (char-to-string l) " ")
118 0 : (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 0 : (aset table uc lc)
127 0 : (aset table lc lc)
128 0 : (let ((up (case-table-get-table table 'up)))
129 0 : (aset up uc uc)
130 0 : (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 0 : (set-char-table-extra-slot table 1 nil)
134 0 : (set-char-table-extra-slot table 2 nil)
135 0 : (modify-syntax-entry lc "w " (standard-syntax-table))
136 0 : (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 0 : (aset table lc lc)
143 0 : (let ((up (case-table-get-table table 'up)))
144 0 : (aset up uc uc)
145 0 : (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 0 : (set-char-table-extra-slot table 1 nil)
149 0 : (set-char-table-extra-slot table 2 nil)
150 0 : (modify-syntax-entry lc "w " (standard-syntax-table))
151 0 : (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 0 : (aset table uc lc)
158 0 : (aset table lc lc)
159 0 : (let ((up (case-table-get-table table 'up)))
160 0 : (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 0 : (set-char-table-extra-slot table 1 nil)
164 0 : (set-char-table-extra-slot table 2 nil)
165 0 : (modify-syntax-entry lc "w " (standard-syntax-table))
166 0 : (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 0 : (aset table c c)
175 0 : (let ((up (case-table-get-table table 'up)))
176 0 : (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 0 : (set-char-table-extra-slot table 1 nil)
180 0 : (set-char-table-extra-slot table 2 nil)
181 0 : (modify-syntax-entry c syntax (standard-syntax-table)))
182 :
183 : (provide 'case-table)
184 :
185 : ;;; case-table.el ends here
|