case-table.el 6.95 KB
Newer Older
1
;;; case-table.el --- code to extend the character set and support case tables  -*- lexical-binding: t -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1988, 1994, 2001-2020 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

Eric S. Raymond's avatar
Eric S. Raymond committed
5
;; Author: Howard Gayle
6
;; Maintainer: emacs-devel@gnu.org
Jim Blandy's avatar
Jim Blandy committed
7
;; Keywords: i18n
8
;; Package: emacs
Joseph Arceneaux's avatar
Joseph Arceneaux committed
9 10 11

;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
Joseph Arceneaux's avatar
Joseph Arceneaux committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
16 17 18 19 20 21 22

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
24

Eric S. Raymond's avatar
Eric S. Raymond committed
25
;;; Commentary:
Joseph Arceneaux's avatar
Joseph Arceneaux committed
26 27 28 29 30 31 32 33

;; Written by:
;; TN/ETX/TX/UMG Howard Gayle        UUCP : seismo!enea!erix!howard
;; Telefonaktiebolaget L M Ericsson  Phone: +46 8 719 55 65
;; Ericsson Telecom     	     Telex: 14910 ERIC S
;; S-126 25 Stockholm                FAX  : +46 8 719 64 82
;; Sweden

Eric S. Raymond's avatar
Eric S. Raymond committed
34 35
;;; Code:

Joseph Arceneaux's avatar
Joseph Arceneaux committed
36 37 38
(defun describe-buffer-case-table ()
  "Describe the case table of the current buffer."
  (interactive)
39 40 41
  (let ((description (make-char-table 'case-table)))
    (map-char-table
     (function (lambda (key value)
42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
		 (if (not (natnump value))
		     (if (consp key)
			 (set-char-table-range description key "case-invariant")
		       (aset description key "case-invariant"))
		   (let (from to)
		     (if (consp key)
			 (setq from (car key) to (cdr key))
		       (setq from (setq to key)))
		     (while (<= from to)
		       (aset
			description from
			(cond ((/= from (downcase from))
			       (concat "uppercase, matches "
				       (char-to-string (downcase from))))
			      ((/= from (upcase from))
			       (concat "lowercase, matches "
				       (char-to-string (upcase from))))
			      (t "case-invariant")))
		       (setq from (1+ from)))))))
61
     (current-case-table))
62 63 64
    (save-excursion
     (with-output-to-temp-buffer "*Help*"
       (set-buffer standard-output)
65
       (describe-vector description)
66
       (help-mode)))))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
67

68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
(defun case-table-get-table (case-table table)
  "Return the TABLE of CASE-TABLE.
TABLE can be `down', `up', `eqv' or `canon'."
  (let ((slot-nb (cdr (assq table '((up . 0) (canon . 1) (eqv . 2))))))
    (or (if (eq table 'down) case-table)
        (char-table-extra-slot case-table slot-nb)
        ;; Setup all extra slots of CASE-TABLE by temporarily selecting
        ;; it as the standard case table.
        (let ((old (standard-case-table)))
          (unwind-protect
              (progn
                (set-standard-case-table case-table)
                (char-table-extra-slot case-table slot-nb))
            (or (eq case-table old)
                (set-standard-case-table old)))))))

84 85
(defun get-upcase-table (case-table)
  "Return the upcase table of CASE-TABLE."
86 87
  (case-table-get-table case-table 'up))
(make-obsolete 'get-upcase-table 'case-table-get-table "24.4")
88

89
(defun copy-case-table (case-table)
90 91 92 93 94 95
  (let ((copy (copy-sequence case-table))
	(up (char-table-extra-slot case-table 0)))
    ;; Clear out the extra slots (except for upcase table) so that
    ;; they will be recomputed from the main (downcase) table.
    (if up
	(set-char-table-extra-slot copy 0 (copy-sequence up)))
96 97 98
    (set-char-table-extra-slot copy 1 nil)
    (set-char-table-extra-slot copy 2 nil)
    copy))
Karl Heuer's avatar
Karl Heuer committed
99

100
(defun set-case-syntax-delims (l r table)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
101
  "Make characters L and R a matching pair of non-case-converting delimiters.
102 103
This sets the entries for L and R in TABLE, which is a string
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 107
  (aset table l l)
  (aset table r r)
108
  (let ((up (case-table-get-table table 'up)))
109 110
    (aset up l l)
    (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 114
  (set-char-table-extra-slot table 1 nil)
  (set-char-table-extra-slot table 2 nil)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
115 116 117
  (modify-syntax-entry l (concat "(" (char-to-string r) "  ")
		       (standard-syntax-table))
  (modify-syntax-entry r (concat ")" (char-to-string l) "  ")
118
		       (standard-syntax-table)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
119

120
(defun set-case-syntax-pair (uc lc table)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
121
  "Make characters UC and LC a pair of inter-case-converting letters.
122 123
This sets the entries for characters UC and LC in TABLE, which is a string
that will be used as the downcase part of a case table.
124 125
It also modifies `standard-syntax-table' to give them the syntax of
word constituents."
126 127
  (aset table uc lc)
  (aset table lc lc)
128
  (let ((up (case-table-get-table table 'up)))
129 130
    (aset up uc uc)
    (aset up lc uc))
Richard M. Stallman's avatar
Richard M. Stallman committed
131
  ;; Clear out the extra slots so that they will be
132 133 134 135 136 137 138 139 140 141 142
  ;; recomputed from the main (downcase) table and upcase table.
  (set-char-table-extra-slot table 1 nil)
  (set-char-table-extra-slot table 2 nil)
  (modify-syntax-entry lc "w   " (standard-syntax-table))
  (modify-syntax-entry uc "w   " (standard-syntax-table)))

(defun set-upcase-syntax (uc lc table)
  "Make character UC an upcase of character LC.
It also modifies `standard-syntax-table' to give them the syntax of
word constituents."
  (aset table lc lc)
143
  (let ((up (case-table-get-table table 'up)))
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
    (aset up uc uc)
    (aset up lc uc))
  ;; Clear out the extra slots so that they will be
  ;; recomputed from the main (downcase) table and upcase table.
  (set-char-table-extra-slot table 1 nil)
  (set-char-table-extra-slot table 2 nil)
  (modify-syntax-entry lc "w   " (standard-syntax-table))
  (modify-syntax-entry uc "w   " (standard-syntax-table)))

(defun set-downcase-syntax (uc lc table)
  "Make character LC a downcase of character UC.
It also modifies `standard-syntax-table' to give them the syntax of
word constituents."
  (aset table uc lc)
  (aset table lc lc)
159
  (let ((up (case-table-get-table table 'up)))
160 161 162
    (aset up uc uc))
  ;; Clear out the extra slots so that they will be
  ;; recomputed from the main (downcase) table and upcase table.
163 164
  (set-char-table-extra-slot table 1 nil)
  (set-char-table-extra-slot table 2 nil)
Joseph Arceneaux's avatar
Joseph Arceneaux committed
165
  (modify-syntax-entry lc "w   " (standard-syntax-table))
166
  (modify-syntax-entry uc "w   " (standard-syntax-table)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
167

168
(defun set-case-syntax (c syntax table)
Karl Heuer's avatar
Karl Heuer committed
169 170
  "Make character C case-invariant with syntax SYNTAX.
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'.
Joseph Arceneaux's avatar
Joseph Arceneaux committed
173
SYNTAX should be \" \", \"w\", \".\" or \"_\"."
174
  (aset table c c)
175
  (let ((up (case-table-get-table table 'up)))
176
    (aset up c c))
Richard M. Stallman's avatar
Richard M. Stallman committed
177
  ;; Clear out the extra slots so that they will be
178
  ;; recomputed from the main (downcase) table and upcase table.
179 180
  (set-char-table-extra-slot table 1 nil)
  (set-char-table-extra-slot table 2 nil)
181
  (modify-syntax-entry c syntax (standard-syntax-table)))
Joseph Arceneaux's avatar
Joseph Arceneaux committed
182 183

(provide 'case-table)
Eric S. Raymond's avatar
Eric S. Raymond committed
184 185

;;; case-table.el ends here