1 |
;;; case-table.el --- code to extend the character set and support case tables |
;;; case-table.el --- code to extend the character set and support case tables |
2 |
|
|
3 |
;; Copyright (C) 1988, 1994 Free Software Foundation, Inc. |
;; Copyright (C) 1988, 1994, 2005 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Howard Gayle |
;; Author: Howard Gayle |
6 |
;; Maintainer: FSF |
;; Maintainer: FSF |
62 |
(describe-vector description) |
(describe-vector description) |
63 |
(help-mode))))) |
(help-mode))))) |
64 |
|
|
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 |
|
|
78 |
(defun copy-case-table (case-table) |
(defun copy-case-table (case-table) |
79 |
(let ((copy (copy-sequence case-table))) |
(let ((copy (copy-sequence case-table)) |
80 |
;; Clear out the extra slots so that they will be |
(up (char-table-extra-slot case-table 0))) |
81 |
;; recomputed from the main (downcase) table. |
;; Clear out the extra slots (except for upcase table) so that |
82 |
(set-char-table-extra-slot copy 0 nil) |
;; they will be recomputed from the main (downcase) table. |
83 |
|
(if up |
84 |
|
(set-char-table-extra-slot copy 0 (copy-sequence up))) |
85 |
(set-char-table-extra-slot copy 1 nil) |
(set-char-table-extra-slot copy 1 nil) |
86 |
(set-char-table-extra-slot copy 2 nil) |
(set-char-table-extra-slot copy 2 nil) |
87 |
copy)) |
copy)) |
102 |
(setq r (set-case-syntax-1 r)) |
(setq r (set-case-syntax-1 r)) |
103 |
(aset table l l) |
(aset table l l) |
104 |
(aset table r r) |
(aset table r r) |
105 |
|
(let ((up (get-upcase-table table))) |
106 |
|
(aset up l l) |
107 |
|
(aset up r r)) |
108 |
;; Clear out the extra slots so that they will be |
;; Clear out the extra slots so that they will be |
109 |
;; recomputed from the main (downcase) table. |
;; recomputed from the main (downcase) table and upcase table. |
|
(set-char-table-extra-slot table 0 nil) |
|
110 |
(set-char-table-extra-slot table 1 nil) |
(set-char-table-extra-slot table 1 nil) |
111 |
(set-char-table-extra-slot table 2 nil) |
(set-char-table-extra-slot table 2 nil) |
112 |
(modify-syntax-entry l (concat "(" (char-to-string r) " ") |
(modify-syntax-entry l (concat "(" (char-to-string r) " ") |
120 |
that will be used as the downcase part of a case table. |
that will be used as the downcase part of a case table. |
121 |
It also modifies `standard-syntax-table' to give them the syntax of |
It also modifies `standard-syntax-table' to give them the syntax of |
122 |
word constituents." |
word constituents." |
123 |
(unless (= (charset-bytes (char-charset uc)) |
(setq uc (set-case-syntax-1 uc)) |
124 |
(charset-bytes (char-charset lc))) |
(setq lc (set-case-syntax-1 lc)) |
125 |
(error "Can't casify chars with different `charset-bytes' values")) |
(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. |
139 |
|
It also modifies `standard-syntax-table' to give them the syntax of |
140 |
|
word constituents." |
141 |
|
(setq uc (set-case-syntax-1 uc)) |
142 |
|
(setq lc (set-case-syntax-1 lc)) |
143 |
|
(let ((up (get-upcase-table table))) |
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 |
(setq uc (set-case-syntax-1 uc)) |
(setq uc (set-case-syntax-1 uc)) |
158 |
(setq lc (set-case-syntax-1 lc)) |
(setq lc (set-case-syntax-1 lc)) |
159 |
(aset table uc lc) |
(aset table uc lc) |
160 |
(aset table lc lc) |
(aset table lc lc) |
161 |
;; Clear out the extra slots so that they will be |
;; Clear out the extra slots so that they will be |
162 |
;; recomputed from the main (downcase) table. |
;; recomputed from the main (downcase) table and upcase table. |
|
(set-char-table-extra-slot table 0 nil) |
|
163 |
(set-char-table-extra-slot table 1 nil) |
(set-char-table-extra-slot table 1 nil) |
164 |
(set-char-table-extra-slot table 2 nil) |
(set-char-table-extra-slot table 2 nil) |
165 |
(modify-syntax-entry lc "w " (standard-syntax-table)) |
(modify-syntax-entry lc "w " (standard-syntax-table)) |
173 |
SYNTAX should be \" \", \"w\", \".\" or \"_\"." |
SYNTAX should be \" \", \"w\", \".\" or \"_\"." |
174 |
(setq c (set-case-syntax-1 c)) |
(setq c (set-case-syntax-1 c)) |
175 |
(aset table c c) |
(aset table c c) |
176 |
|
(let ((up (get-upcase-table table))) |
177 |
|
(aset up c c)) |
178 |
;; Clear out the extra slots so that they will be |
;; Clear out the extra slots so that they will be |
179 |
;; recomputed from the main (downcase) table. |
;; recomputed from the main (downcase) table and upcase table. |
|
(set-char-table-extra-slot table 0 nil) |
|
180 |
(set-char-table-extra-slot table 1 nil) |
(set-char-table-extra-slot table 1 nil) |
181 |
(set-char-table-extra-slot table 2 nil) |
(set-char-table-extra-slot table 2 nil) |
182 |
(modify-syntax-entry c syntax (standard-syntax-table))) |
(modify-syntax-entry c syntax (standard-syntax-table))) |