Revert arch-tagline change
[bpt/emacs.git] / lisp / case-table.el
CommitLineData
55535639 1;;; case-table.el --- code to extend the character set and support case tables
e5167999 2
e1e89a70 3;; Copyright (C) 1988, 1994, 2005 Free Software Foundation, Inc.
3a801d0c 4
e5167999
ER
5;; Author: Howard Gayle
6;; Maintainer: FSF
a1d15b3e 7;; Keywords: i18n
a2535589
JA
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
e5167999 13;; the Free Software Foundation; either version 2, or (at your option)
a2535589
JA
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
b578f267
EN
22;; along with GNU Emacs; see the file COPYING. If not, write to the
23;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24;; Boston, MA 02111-1307, USA.
a2535589 25
e5167999 26;;; Commentary:
a2535589
JA
27
28;; Written by:
29;; TN/ETX/TX/UMG Howard Gayle UUCP : seismo!enea!erix!howard
30;; Telefonaktiebolaget L M Ericsson Phone: +46 8 719 55 65
31;; Ericsson Telecom Telex: 14910 ERIC S
32;; S-126 25 Stockholm FAX : +46 8 719 64 82
33;; Sweden
34
e5167999
ER
35;;; Code:
36
cc1cdd74
RS
37(defvar set-case-syntax-offset 0)
38
40f30b63
RS
39(defvar set-case-syntax-set-multibyte nil)
40
a2535589
JA
41(defun describe-buffer-case-table ()
42 "Describe the case table of the current buffer."
43 (interactive)
e6905346
RS
44 (let ((description (make-char-table 'case-table)))
45 (map-char-table
46 (function (lambda (key value)
adfb70a1 47 (aset
e6905346 48 description key
adfb70a1 49 (cond ((not (natnump value))
e6905346
RS
50 "case-invariant")
51 ((/= key (downcase key))
52 (concat "uppercase, matches "
53 (char-to-string (downcase key))))
54 ((/= key (upcase key))
55 (concat "lowercase, matches "
56 (char-to-string (upcase key))))
57 (t "case-invariant")))))
58 (current-case-table))
4536d484
RS
59 (save-excursion
60 (with-output-to-temp-buffer "*Help*"
61 (set-buffer standard-output)
e6905346 62 (describe-vector description)
383669af 63 (help-mode)))))
a2535589 64
e1e89a70
KH
65(defun get-upcase-table (case-table)
66 "Return the upcase table of CASE-TABLE."
67 (or (char-table-extra-slot case-table 0)
68 ;; Setup all extra slots of CASE-TABLE by temporarily selecting
69 ;; it as the standard case table.
70 (let ((old (standard-case-table)))
71 (unwind-protect
72 (progn
73 (set-standard-case-table case-table)
74 (char-table-extra-slot case-table 0))
75 (or (eq case-table old)
76 (set-standard-case-table old))))))
77
e6905346 78(defun copy-case-table (case-table)
e1e89a70
KH
79 (let ((copy (copy-sequence case-table))
80 (up (char-table-extra-slot case-table 0)))
81 ;; Clear out the extra slots (except for upcase table) so that
82 ;; they will be recomputed from the main (downcase) table.
83 (if up
84 (set-char-table-extra-slot copy 0 (copy-sequence up)))
e6905346
RS
85 (set-char-table-extra-slot copy 1 nil)
86 (set-char-table-extra-slot copy 2 nil)
87 copy))
1a7c2dbf 88
c9e83877
RS
89(defsubst set-case-syntax-1 (char)
90 "Offset CHAR by `set-case-syntax-offset' if CHAR is a non-ASCII 8-bit char."
91 (if (and (>= char 128) (< char 256))
92 (+ char set-case-syntax-offset)
93 char))
94
8db3f421 95(defun set-case-syntax-delims (l r table)
a2535589 96 "Make characters L and R a matching pair of non-case-converting delimiters.
8db3f421
RS
97This sets the entries for L and R in TABLE, which is a string
98that will be used as the downcase part of a case table.
f46efdf9 99It also modifies `standard-syntax-table' to
03131799 100indicate left and right delimiters."
c9e83877
RS
101 (setq l (set-case-syntax-1 l))
102 (setq r (set-case-syntax-1 r))
8db3f421
RS
103 (aset table l l)
104 (aset table r r)
e1e89a70
KH
105 (let ((up (get-upcase-table table)))
106 (aset up l l)
107 (aset up r r))
e6905346 108 ;; Clear out the extra slots so that they will be
e1e89a70 109 ;; recomputed from the main (downcase) table and upcase table.
e6905346
RS
110 (set-char-table-extra-slot table 1 nil)
111 (set-char-table-extra-slot table 2 nil)
a2535589
JA
112 (modify-syntax-entry l (concat "(" (char-to-string r) " ")
113 (standard-syntax-table))
a2535589 114 (modify-syntax-entry r (concat ")" (char-to-string l) " ")
f46efdf9 115 (standard-syntax-table)))
a2535589 116
8db3f421 117(defun set-case-syntax-pair (uc lc table)
a2535589 118 "Make characters UC and LC a pair of inter-case-converting letters.
8db3f421
RS
119This sets the entries for characters UC and LC in TABLE, which is a string
120that will be used as the downcase part of a case table.
f46efdf9
RS
121It also modifies `standard-syntax-table' to give them the syntax of
122word constituents."
e1e89a70
KH
123 (setq uc (set-case-syntax-1 uc))
124 (setq lc (set-case-syntax-1 lc))
125 (aset table uc lc)
126 (aset table lc lc)
127 (let ((up (get-upcase-table table)))
128 (aset up uc uc)
129 (aset up lc uc))
130 ;; Clear out the extra slots so that they will be
131 ;; recomputed from the main (downcase) table and upcase table.
132 (set-char-table-extra-slot table 1 nil)
133 (set-char-table-extra-slot table 2 nil)
134 (modify-syntax-entry lc "w " (standard-syntax-table))
135 (modify-syntax-entry uc "w " (standard-syntax-table)))
136
137(defun set-upcase-syntax (uc lc table)
138 "Make character UC an upcase of character LC.
139It also modifies `standard-syntax-table' to give them the syntax of
140word constituents."
141 (setq uc (set-case-syntax-1 uc))
142 (setq lc (set-case-syntax-1 lc))
9afd1c3c 143 (aset table lc lc)
e1e89a70
KH
144 (let ((up (get-upcase-table table)))
145 (aset up uc uc)
146 (aset up lc uc))
147 ;; Clear out the extra slots so that they will be
148 ;; recomputed from the main (downcase) table and upcase table.
149 (set-char-table-extra-slot table 1 nil)
150 (set-char-table-extra-slot table 2 nil)
151 (modify-syntax-entry lc "w " (standard-syntax-table))
152 (modify-syntax-entry uc "w " (standard-syntax-table)))
153
154(defun set-downcase-syntax (uc lc table)
155 "Make character LC a downcase of character UC.
156It also modifies `standard-syntax-table' to give them the syntax of
157word constituents."
c9e83877
RS
158 (setq uc (set-case-syntax-1 uc))
159 (setq lc (set-case-syntax-1 lc))
8db3f421
RS
160 (aset table uc lc)
161 (aset table lc lc)
9afd1c3c
KH
162 (let ((up (get-upcase-table table)))
163 (aset up uc uc))
2cf2fc27 164 ;; Clear out the extra slots so that they will be
e1e89a70 165 ;; recomputed from the main (downcase) table and upcase table.
e6905346
RS
166 (set-char-table-extra-slot table 1 nil)
167 (set-char-table-extra-slot table 2 nil)
a2535589 168 (modify-syntax-entry lc "w " (standard-syntax-table))
f46efdf9 169 (modify-syntax-entry uc "w " (standard-syntax-table)))
a2535589 170
8db3f421 171(defun set-case-syntax (c syntax table)
1a7c2dbf
KH
172 "Make character C case-invariant with syntax SYNTAX.
173This sets the entry for character C in TABLE, which is a string
8db3f421 174that will be used as the downcase part of a case table.
f46efdf9 175It also modifies `standard-syntax-table'.
a2535589 176SYNTAX should be \" \", \"w\", \".\" or \"_\"."
c9e83877 177 (setq c (set-case-syntax-1 c))
8db3f421 178 (aset table c c)
e1e89a70
KH
179 (let ((up (get-upcase-table table)))
180 (aset up c c))
2cf2fc27 181 ;; Clear out the extra slots so that they will be
e1e89a70 182 ;; recomputed from the main (downcase) table and upcase table.
e6905346
RS
183 (set-char-table-extra-slot table 1 nil)
184 (set-char-table-extra-slot table 2 nil)
f46efdf9 185 (modify-syntax-entry c syntax (standard-syntax-table)))
a2535589
JA
186
187(provide 'case-table)
c0274f38 188
ab5796a9 189;;; arch-tag: 3c2cf885-2c9a-449a-9972-2e269191896d
c0274f38 190;;; case-table.el ends here