34 |
|
|
35 |
;;; Code: |
;;; Code: |
36 |
|
|
|
(defvar set-case-syntax-offset 0) |
|
|
|
|
|
(defvar set-case-syntax-set-multibyte nil) |
|
|
|
|
37 |
(defun describe-buffer-case-table () |
(defun describe-buffer-case-table () |
38 |
"Describe the case table of the current buffer." |
"Describe the case table of the current buffer." |
39 |
(interactive) |
(interactive) |
40 |
(let ((description (make-char-table 'case-table))) |
(let ((description (make-char-table 'case-table))) |
41 |
(map-char-table |
(map-char-table |
42 |
(function (lambda (key value) |
(function (lambda (key value) |
43 |
(aset |
(if (consp key) |
44 |
description key |
(set-char-table-range description key "case-invariant") |
45 |
(cond ((not (natnump value)) |
(aset |
46 |
"case-invariant") |
description key |
47 |
((/= key (downcase key)) |
(cond ((not (natnump value)) |
48 |
(concat "uppercase, matches " |
"case-invariant") |
49 |
(char-to-string (downcase key)))) |
((/= key (downcase key)) |
50 |
((/= key (upcase key)) |
(concat "uppercase, matches " |
51 |
(concat "lowercase, matches " |
(char-to-string (downcase key)))) |
52 |
(char-to-string (upcase key)))) |
((/= key (upcase key)) |
53 |
(t "case-invariant"))))) |
(concat "lowercase, matches " |
54 |
|
(char-to-string (upcase key)))) |
55 |
|
(t "case-invariant")))))) |
56 |
(current-case-table)) |
(current-case-table)) |
57 |
(save-excursion |
(save-excursion |
58 |
(with-output-to-temp-buffer "*Help*" |
(with-output-to-temp-buffer "*Help*" |
69 |
(set-char-table-extra-slot copy 2 nil) |
(set-char-table-extra-slot copy 2 nil) |
70 |
copy)) |
copy)) |
71 |
|
|
|
(defsubst set-case-syntax-1 (char) |
|
|
"Offset CHAR by `set-case-syntax-offset' if CHAR is a non-ASCII 8-bit char." |
|
|
(if (and (>= char 128) (< char 256)) |
|
|
(+ char set-case-syntax-offset) |
|
|
char)) |
|
|
|
|
72 |
(defun set-case-syntax-delims (l r table) |
(defun set-case-syntax-delims (l r table) |
73 |
"Make characters L and R a matching pair of non-case-converting delimiters. |
"Make characters L and R a matching pair of non-case-converting delimiters. |
74 |
This sets the entries for L and R in TABLE, which is a string |
This sets the entries for L and R in TABLE, which is a string |
75 |
that will be used as the downcase part of a case table. |
that will be used as the downcase part of a case table. |
76 |
It also modifies `standard-syntax-table' to |
It also modifies `standard-syntax-table' to |
77 |
indicate left and right delimiters." |
indicate left and right delimiters." |
|
(setq l (set-case-syntax-1 l)) |
|
|
(setq r (set-case-syntax-1 r)) |
|
78 |
(aset table l l) |
(aset table l l) |
79 |
(aset table r r) |
(aset table r r) |
80 |
;; Clear out the extra slots so that they will be |
;; Clear out the extra slots so that they will be |
93 |
that will be used as the downcase part of a case table. |
that will be used as the downcase part of a case table. |
94 |
It also modifies `standard-syntax-table' to give them the syntax of |
It also modifies `standard-syntax-table' to give them the syntax of |
95 |
word constituents." |
word constituents." |
|
(unless (= (charset-bytes (char-charset uc)) |
|
|
(charset-bytes (char-charset lc))) |
|
|
(error "Can't casify chars with different `charset-bytes' values")) |
|
|
(setq uc (set-case-syntax-1 uc)) |
|
|
(setq lc (set-case-syntax-1 lc)) |
|
96 |
(aset table uc lc) |
(aset table uc lc) |
97 |
(aset table lc lc) |
(aset table lc lc) |
98 |
(set-char-table-extra-slot table 0 nil) |
(set-char-table-extra-slot table 0 nil) |
107 |
that will be used as the downcase part of a case table. |
that will be used as the downcase part of a case table. |
108 |
It also modifies `standard-syntax-table'. |
It also modifies `standard-syntax-table'. |
109 |
SYNTAX should be \" \", \"w\", \".\" or \"_\"." |
SYNTAX should be \" \", \"w\", \".\" or \"_\"." |
|
(setq c (set-case-syntax-1 c)) |
|
110 |
(aset table c c) |
(aset table c c) |
111 |
(set-char-table-extra-slot table 0 nil) |
(set-char-table-extra-slot table 0 nil) |
112 |
(set-char-table-extra-slot table 1 nil) |
(set-char-table-extra-slot table 1 nil) |