Mercurial > hg > xemacs-beta

comparison lisp/disp-table.el @ 5118:e0db3c197671 ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 3742ea8250b5 1f0aa40cafe0
children e84ee15ca495
comparison
equal deleted inserted replaced
5117:3742ea8250b5 5118:e0db3c197671
1 ;;; disp-table.el --- functions for dealing with char tables. 1 ;;; disp-table.el --- functions for dealing with char tables.
2 2
3 ;; Copyright (C) 1987, 1994, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1987, 1994, 1997, 2007 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Sun Microsystems. 4 ;; Copyright (C) 1995 Sun Microsystems.
5 ;; Copyright (C) 2005 Ben Wing. 5 ;; Copyright (C) 2005 Ben Wing.
6 6
7 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: i18n, internal 8 ;; Keywords: i18n, internal
26 26
27 ;;; Synched up with: Not synched with FSF. 27 ;;; Synched up with: Not synched with FSF.
28 28
29 ;;; Commentary: 29 ;;; Commentary:
30 30
31 ;; #### Needs work.
32
33 ;; Rewritten for XEmacs July 1995, Ben Wing. 31 ;; Rewritten for XEmacs July 1995, Ben Wing.
34 ;; November 1998?, display tables generalized to char/range tables, Hrvoje 32 ;; November 1998?, display tables generalized to char/range tables, Hrvoje
35 ;; Niksic. 33 ;; Niksic.
36 ;; February 2005, rewrite this file to handle generalized display tables, 34 ;; July 2007, rewrite this file to handle generalized display tables,
37 ;; Ben Wing. 35 ;; Aidan Kehoe.
38 36
39 ;;; Code: 37 ;;; Code:
38
39 ;;;###autoload
40 (defun make-display-table ()
41 "Return a new, empty display table.
42
43 This returns a generic character table; previously it returned a vector, but
44 that was not helpful when dealing with internationalized characters above
45 ?\xFF. See `make-char-table' for details of character tables in general. To
46 write code that works with both vectors and character tables, add something
47 like the following to the beginning of your file, and use
48 `put-display-table' to set what a given character is displayed as, and
49 `get-display-table' to examine what that character is currently displayed
50 as:
51
52 \(defun-when-void put-display-table (range value display-table)
53 \"Set the value for char RANGE to VALUE in DISPLAY-TABLE. \"
54 (if (sequencep display-table)
55 (aset display-table range value)
56 (put-char-table range value display-table)))
57
58 \(defun-when-void get-display-table (character display-table)
59 \"Find value for CHARACTER in DISPLAY-TABLE. \"
60 (if (sequencep display-table)
61 (aref display-table character)
62 (get-char-table character display-table)))
63
64 In this implementation, `put-display-table' and `get-display-table' are
65 aliases of `put-char-table' and `get-char-table' respectively, and are
66 always available."
67 (make-char-table 'generic))
68
69 ;;;###autoload
70 (defalias 'put-display-table #'put-char-table)
71
72 ;;;###autoload
73 (defalias 'get-display-table #'get-char-table)
40 74
41 (defun describe-display-table (dt) 75 (defun describe-display-table (dt)
42 "Describe the display table DT in a help buffer." 76 "Describe the display table DT in a help buffer."
43 (with-displaying-help-buffer 77 (with-displaying-help-buffer
44 (lambda () 78 (lambda ()
45 (princ "\nCharacter display glyph sequences:\n") 79 (map-char-table
46 (flet ((describe-display-table-entry 80 (lambda (range value)
47 (entry stream) 81 (cond
48 ;; #### Write better version 82 ((eq range t)
49 (princ entry stream)) 83 (princ "\nAll characters: \n")
50 (describe-display-table-range 84 (princ (format " %S" value)))
51 (first last entry) 85 ((eq 'charset (and (symbolp range) (type-of (find-charset range))))
52 (if (eq first last) 86 (princ (format "\n\nCharset %S: \n" (charset-name range)))
53 (princ (format "%s\t\t" 87 (princ (format " %S" value)))
54 (single-key-description (int-char first)))) 88 ((vectorp range)
55 (let ((str (format "%s - %s" 89 (princ (format "\n\nCharset %S, row %d \n"
56 (single-key-description (int-char first)) 90 (charset-name (aref value 0))
57 (single-key-description (int-char last))))) 91 (aref value 1)))
58 (princ str) 92 (princ (format " %S\n\n" value)))
59 (princ (make-string (max (- 2 (/ (length str) 93 ((characterp range)
60 tab-width)) 1) ?\t)))) 94 (princ (format "\nCharacter U+%04X, %S: "
61 (describe-display-table-entry entry standard-output) 95 range (if (fboundp 'split-char)
62 (terpri))) 96 (split-char range)
63 (cond ((vectorp dt) 97 (list 'ascii (char-to-int range)))))
64 (save-excursion 98 (princ (format " %S" value))))
65 (let ((vector (make-vector 256 nil)) 99 nil) dt)
66 (i 0)) 100 (princ
67 (while (< i 256) 101 "\n\nFor some of the various other glyphs that GNU Emacs uses the display
68 (aset vector i (aref dt i)) 102 table for, see the XEmacs specifiers `truncation-glyph' ,
69 (incf i)) 103 `continuation-glyph', `control-arrow-glyph', `octal-escape-glyph' and the
70 ;; FSF calls `describe-vector' here, but it is so incredibly 104 others described in the docstring of `make-glyph'. \n\n"))))
71 ;; lame a function for that name that I cannot bring myself 105
72 ;; to port it. Here is what `describe-vector' does:
73 (terpri)
74 (let ((old (aref vector 0))
75 (oldpos 0)
76 (i 1))
77 (while (<= i 256)
78 (when (or (= i 256)
79 (not (equal old (aref vector i))))
80 (describe-display-table-range oldpos (1- i) old)
81 (or (= i 256)
82 (setq old (aref vector i)
83 oldpos i)))
84 (incf i))))))
85 ((char-table-p dt)
86 (describe-char-table dt 'map-char-table
87 'describe-display-table-entry
88 standard-output))
89 ((range-table-p dt)
90 (map-range-table
91 #'(lambda (beg end value)
92 (describe-display-table-range beg end value))
93 dt)))))))
94 106
95 ;;;###autoload 107 ;;;###autoload
96 (defun describe-current-display-table (&optional domain) 108 (defun describe-current-display-table (&optional domain)
97 "Describe the display table in use in the selected window and buffer." 109 "Describe the display table in use in the selected window and buffer."
98 (interactive) 110 (interactive)
100 (let ((disptab (specifier-instance current-display-table domain))) 112 (let ((disptab (specifier-instance current-display-table domain)))
101 (if disptab 113 (if disptab
102 (describe-display-table disptab) 114 (describe-display-table disptab)
103 (message "No display table")))) 115 (message "No display table"))))
104 116
105 ;;;###autoload
106 (defun make-display-table ()
107 "Return a new, empty display table.
108 Modify a display table using `put-display-table'. Look up in display tables
109 using `get-display-table'. The exact format of display tables and their
110 specs is described in `current-display-table'."
111 ;; #### This should do something smarter.
112 ;; #### Should use range table but there are bugs in range table and
113 ;; perhaps in callers not expecting this.
114 ;(make-range-table 'start-closed-end-closed)
115 ;(make-vector 256 nil)
116 ;; #### Should be type `display-table'
117 (make-char-table 'generic))
118
119 (defun display-table-p (object)
120 "Return t if OBJECT is a display table.
121 See `make-display-table'."
122 (or (and (vectorp object) (= (length object) 256))
123 (and (char-table-p object) (memq (char-table-type object)
124 '(char generic display)))
125 (range-table-p object)))
126
127 ;; #### we need a generic frob-specifier function. 117 ;; #### we need a generic frob-specifier function.
128 ;; #### this also needs to be redone like frob-face-property. 118 ;; #### this also needs to be redone like frob-face-property.
129 119
130 ;; Let me say one more time how much dynamic scoping sucks. 120 ;; Let me say one more time how much dynamic scoping sucks.
131 121
132 ;; #### Need more thinking about basic primitives for modifying a specifier. 122 ;; #### Need more thinking about basic primitives for modifying a specifier.
133 ;; cf `modify-specifier-instances'. 123 ;; cf `modify-specifier-instances'.
134 124
125 ;;;###autoload
135 (defun frob-display-table (fdt-function fdt-locale &optional tag-set) 126 (defun frob-display-table (fdt-function fdt-locale &optional tag-set)
136 (or fdt-locale (setq fdt-locale 'global)) 127 (or fdt-locale (setq fdt-locale 'global))
137 (or (specifier-spec-list current-display-table fdt-locale tag-set) 128 (or (specifier-spec-list current-display-table fdt-locale tag-set)
138 (add-spec-to-specifier current-display-table (make-display-table) 129 (add-spec-to-specifier current-display-table (make-display-table)
139 fdt-locale tag-set)) 130 fdt-locale tag-set))
145 (funcall fdt-function (cdr fdt-x)) 136 (funcall fdt-function (cdr fdt-x))
146 fdt-x) 137 fdt-x)
147 (cdar (specifier-spec-list current-display-table 138 (cdar (specifier-spec-list current-display-table
148 fdt-locale tag-set))))))) 139 fdt-locale tag-set)))))))
149 140
150 (defun put-display-table-range (l h spec display-table)
151 "Display characters in range L .. H, inclusive, in DISPLAY-TABLE using SPEC.
152 Display tables are described in `current-display-table'."
153 (check-argument-type 'display-table-p display-table)
154 (cond ((vectorp display-table)
155 (while (<= l h)
156 (aset display-table l spec)
157 (setq l (1+ l))))
158 ((char-table-p display-table)
159 (while (<= l h)
160 (put-char-table l spec display-table)
161 (setq l (1+ l))))
162 ((range-table-p display-table)
163 (put-range-table l h spec display-table))))
164
165 (defun put-display-table (ch spec display-table)
166 "Display character spec CH in DISPLAY-TABLE using SPEC.
167 CH can be a character, a charset, or t for all characters.
168 Display tables are described in `current-display-table'."
169 (cond ((eq ch t)
170 (cond ((vectorp display-table)
171 (put-display-table-range 0 (1- (length display-table)) spec
172 display-table))
173 ((range-table-p display-table)
174 ; major hack
175 (put-display-table-range 0 (string-to-int "3FFFFFFF" 16)
176 spec display-table))
177 ((char-table-p display-table)
178 (put-char-table t spec display-table))))
179 ((charsetp ch)
180 (cond ((vectorp display-table)
181 ;; #### fix
182 nil)
183 ((range-table-p display-table)
184 ;; #### fix
185 nil)
186 ((char-table-p display-table)
187 (put-char-table ch spec display-table))))
188 (t (put-display-table-range ch ch spec display-table))))
189
190 (defun get-display-table (char display-table)
191 "Return SPEC of CHAR in DISPLAY-TABLE.
192 See `current-display-table'."
193 (check-argument-type 'display-table-p display-table)
194 (cond ((vectorp display-table)
195 (aref display-table char))
196 ((char-table-p display-table)
197 (get-char-table char display-table))
198 ((range-table-p display-table)
199 (get-range-table char display-table))))
200
201 (defun standard-display-8bit-1 (dt l h) 141 (defun standard-display-8bit-1 (dt l h)
202 (while (<= l h) 142 (while (<= l h)
203 (put-display-table l (char-to-string l) dt) 143 (remove-char-table (int-to-char l) dt)
204 (setq l (1+ l)))) 144 (setq l (1+ l))))
205 145
206 ;;;###autoload 146 ;;;###autoload
207 (defun standard-display-8bit (l h &optional locale) 147 (defun standard-display-8bit (l h &optional locale)
208 "Display characters in the range L to H literally." 148 "Display characters in the range L to H literally [sic].
149
150 GNU Emacs includes this function. There, `literally' has no good meaning.
151 Under XEmacs, this function makes characters with numeric values in the
152 range L to H display as themselves; that is, as ASCII, latin-iso8859-1,
153 latin-iso8859-2 or whatever. See `standard-display-default' for the inverse
154 function. "
209 (frob-display-table 155 (frob-display-table
210 (lambda (x) 156 (lambda (x)
211 (standard-display-8bit-1 x l h)) 157 (standard-display-8bit-1 x l h))
212 locale)) 158 locale))
213 159
214 (defun standard-display-default-1 (dt l h) 160 (defun standard-display-default-1 (dt l h)
161 "Misnamed function under XEmacs. See `standard-display-default'."
215 (while (<= l h) 162 (while (<= l h)
216 (put-display-table l nil dt) 163 (put-char-table (int-to-char l) (format "\\%o" l) dt)
217 (setq l (1+ l)))) 164 (setq l (1+ l))))
218 165
219 ;;;###autoload 166 ;;;###autoload
220 (defun standard-display-default (l h &optional locale) 167 (defun standard-display-default (l h &optional locale)
221 "Display characters in the range L to H using the default notation." 168 "Display characters in the range L to H using octal escape notation.
169
170 In the XEmacs context this function is misnamed. Under GNU Emacs,
171 characters in the range #xA0 to #xFF display as octal escapes unless
172 `standard-display-european' has been called; this function neutralizes the
173 effects of `standard-display-european'. Under XEmacs, those characters
174 normally do not display as octal escapes (this ignores hackery like
175 specifying the X11 font character set on non-Mule builds) and this function
176 sets them to display as octal escapes. "
222 (frob-display-table 177 (frob-display-table
223 (lambda (x) 178 (lambda (x)
224 (standard-display-default-1 x l h)) 179 (standard-display-default-1 x l h))
225 locale)) 180 locale))
226 181
227 ;;;###autoload 182 ;;;###autoload
228 (defun standard-display-ascii (c s &optional locale) 183 (defun standard-display-ascii (c s &optional locale)
229 "Display character C using printable string S." 184 "Display character C using printable string S."
230 (frob-display-table 185 (frob-display-table
231 (lambda (x) 186 (lambda (x)
232 (put-display-table c s x)) 187 (put-char-table c s x))
233 locale)) 188 locale))
234 189
235 ;;;###autoload 190 ;;;###autoload
236 (defun standard-display-g1 (c sc &optional locale) 191 (defun standard-display-g1 (c sc &optional locale)
237 "Display character C as character SC in the g1 character set. 192 "Display character C as character SC in the g1 character set.
238 This only has an effect on TTY devices and assumes that your terminal uses 193 This only has an effect on TTY devices and assumes that your terminal uses
239 the SO/SI characters." 194 the SO/SI characters."
240 (frob-display-table 195 (frob-display-table
241 (lambda (x) 196 (lambda (x)
242 (put-display-table c (concat "\016" (char-to-string sc) "\017") x)) 197 (put-char-table c (concat "\016" (char-to-string sc) "\017") x))
243 locale 198 locale '(tty)))
244 'tty))
245 199
246 ;;;###autoload 200 ;;;###autoload
247 (defun standard-display-graphic (c gc &optional locale) 201 (defun standard-display-graphic (c gc &optional locale)
248 "Display character C as character GC in graphics character set. 202 "Display character C as character GC in graphics character set.
249 This only has an effect on TTY devices and assumes VT100-compatible escapes." 203 This only has an effect on TTY devices and assumes VT100-compatible escapes."
250 (frob-display-table 204 (frob-display-table
251 (lambda (x) 205 (lambda (x)
252 (put-display-table c (concat "\e(0" (char-to-string gc) "\e(B") x)) 206 (put-char-table c (concat "\e(0" (char-to-string gc) "\e(B") x))
253 locale 207 locale '(tty)))
254 'tty))
255
256 ;;; #### the FSF equivalent of this makes this character be displayed
257 ;;; in the 'underline face. There's no current way to do this with
258 ;;; XEmacs display tables.
259 208
260 ;;;###autoload 209 ;;;###autoload
261 (defun standard-display-underline (c uc &optional locale) 210 (defun standard-display-underline (c uc &optional locale)
262 "Display character C as character UC plus underlining." 211 "Display character C as character UC plus underlining."
263 (frob-display-table 212 (frob-display-table
264 (lambda (x) 213 (lambda (x)
265 (put-display-table c (concat "\e[4m" (char-to-string uc) "\e[m") x)) 214 (let (glyph)
266 locale 215 (setq glyph (make-glyph (vector 'string :data (char-to-string uc))))
267 'tty)) 216 (set-glyph-face glyph 'underline)
217 (put-char-table c glyph x)))
218 locale))
268 219
269 ;;;###autoload 220 ;;;###autoload
270 (defun standard-display-european (arg &optional locale) 221 (defun standard-display-european (arg &optional locale)
271 "Toggle display of European characters encoded with ISO 8859. 222 "Toggle display of European characters encoded with ISO 8859-1.
272 When enabled, characters in the range of 160 to 255 display not 223 When enabled (the default), characters in the range of 160 to 255 display
273 as octal escapes, but as accented characters. 224 as accented characters. With negative prefix argument, display characters in
274 With prefix argument, enable European character display iff arg is positive." 225 that range as octal escapes.
226
227 If you want to work in a Western European language under XEmacs, it
228 shouldn't be necessary to call this function--things should just work. But
229 it's in a sufficient number of init files that we're not in a hurry to
230 remove it. "
275 (interactive "P") 231 (interactive "P")
276 (frob-display-table 232 (if (<= (prefix-numeric-value arg) 0)
277 (lambda (x) 233 (frob-display-table
278 (if (or (<= (prefix-numeric-value arg) 0) 234 (lambda (x)
279 (and (null arg) 235 (standard-display-default-1 x 160 255))
280 (equal (get-display-table 160 x) (char-to-string 160)))) 236 locale)
281 (standard-display-default-1 x 160 255) 237 (frob-display-table
282 (standard-display-8bit-1 x 160 255))) 238 (lambda (x)
283 locale)) 239 (standard-display-8bit-1 x 160 255))
240 locale)))
284 241
285 (provide 'disp-table) 242 (provide 'disp-table)
286 243
287 ;;; disp-table.el ends here 244 ;;; disp-table.el ends here