Mercurial > hg > xemacs-beta

comparison lisp/disp-table.el @ 5117:3742ea8250b5 ben-lisp-object ben-lisp-object-final-ws-year-2005

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Checking in final CVS version of workspace 'ben-lisp-object'
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 00:20:27 -0600
parents 262b8bb4a523
children e0db3c197671
comparison
equal deleted inserted replaced
5116:e56f73345619 5117:3742ea8250b5
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 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Sun Microsystems. 4 ;; Copyright (C) 1995 Sun Microsystems.
5 5 ;; Copyright (C) 2005 Ben Wing.
6 ;; Author: Howard Gayle 6
7 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: i18n, internal 8 ;; Keywords: i18n, internal
9 9
10 ;; This file is part of XEmacs. 10 ;; This file is part of XEmacs.
11 11
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 ;; #### Need lots of work. make-display-table depends on a value 31 ;; #### Needs work.
32 ;; that is a define in the C code. Maybe we should just move the
33 ;; function into C.
34
35 ;; #### display-tables-as-vectors is really evil and a big pain in
36 ;; the ass.
37 32
38 ;; Rewritten for XEmacs July 1995, Ben Wing. 33 ;; Rewritten for XEmacs July 1995, Ben Wing.
39 34 ;; November 1998?, display tables generalized to char/range tables, Hrvoje
35 ;; Niksic.
36 ;; February 2005, rewrite this file to handle generalized display tables,
37 ;; Ben Wing.
40 38
41 ;;; Code: 39 ;;; Code:
42 40
43 (defun describe-display-table (dt) 41 (defun describe-display-table (dt)
44 "Describe the display table DT in a help buffer." 42 "Describe the display table DT in a help buffer."
45 (with-displaying-help-buffer 43 (with-displaying-help-buffer
46 (lambda () 44 (lambda ()
47 (princ "\nCharacter display glyph sequences:\n") 45 (princ "\nCharacter display glyph sequences:\n")
48 (save-excursion 46 (flet ((describe-display-table-entry
49 (let ((vector (make-vector 256 nil)) 47 (entry stream)
50 (i 0)) 48 ;; #### Write better version
51 (while (< i 256) 49 (princ entry stream))
52 (aset vector i (aref dt i)) 50 (describe-display-table-range
53 (incf i)) 51 (first last entry)
54 ;; FSF calls `describe-vector' here, but it is so incredibly 52 (if (eq first last)
55 ;; lame a function for that name that I cannot bring myself 53 (princ (format "%s\t\t"
56 ;; to porting it. Here is what `describe-vector' does: 54 (single-key-description (int-char first))))
57 (terpri) 55 (let ((str (format "%s - %s"
58 (let ((old (aref vector 0)) 56 (single-key-description (int-char first))
59 (oldpos 0) 57 (single-key-description (int-char last)))))
60 (i 1) 58 (princ str)
61 str) 59 (princ (make-string (max (- 2 (/ (length str)
62 (while (<= i 256) 60 tab-width)) 1) ?\t))))
63 (when (or (= i 256) 61 (describe-display-table-entry entry standard-output)
64 (not (equal old (aref vector i)))) 62 (terpri)))
65 (if (eq oldpos (1- i)) 63 (cond ((vectorp dt)
66 (princ (format "%s\t\t%s\n" 64 (save-excursion
67 (single-key-description (int-char oldpos)) 65 (let ((vector (make-vector 256 nil))
68 old)) 66 (i 0))
69 (setq str (format "%s - %s" 67 (while (< i 256)
70 (single-key-description (int-char oldpos)) 68 (aset vector i (aref dt i))
71 (single-key-description (int-char (1- i))))) 69 (incf i))
72 (princ str) 70 ;; FSF calls `describe-vector' here, but it is so incredibly
73 (princ (make-string (max (- 2 (/ (length str) 71 ;; lame a function for that name that I cannot bring myself
74 tab-width)) 1) ?\t)) 72 ;; to port it. Here is what `describe-vector' does:
75 (princ old) 73 (terpri)
76 (terpri)) 74 (let ((old (aref vector 0))
77 (or (= i 256) 75 (oldpos 0)
78 (setq old (aref vector i) 76 (i 1))
79 oldpos i))) 77 (while (<= i 256)
80 (incf i)))))))) 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)))))))
81 94
82 ;;;###autoload 95 ;;;###autoload
83 (defun describe-current-display-table (&optional domain) 96 (defun describe-current-display-table (&optional domain)
84 "Describe the display table in use in the selected window and buffer." 97 "Describe the display table in use in the selected window and buffer."
85 (interactive) 98 (interactive)
89 (describe-display-table disptab) 102 (describe-display-table disptab)
90 (message "No display table")))) 103 (message "No display table"))))
91 104
92 ;;;###autoload 105 ;;;###autoload
93 (defun make-display-table () 106 (defun make-display-table ()
94 "Return a new, empty display table." 107 "Return a new, empty display table.
95 (make-vector 256 nil)) 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)))
96 126
97 ;; #### we need a generic frob-specifier function. 127 ;; #### we need a generic frob-specifier function.
98 ;; #### this also needs to be redone like frob-face-property. 128 ;; #### this also needs to be redone like frob-face-property.
99 129
100 ;; Let me say one more time how much dynamic scoping sucks. 130 ;; Let me say one more time how much dynamic scoping sucks.
101 131
102 (defun frob-display-table (fdt-function fdt-locale) 132 ;; #### Need more thinking about basic primitives for modifying a specifier.
133 ;; cf `modify-specifier-instances'.
134
135 (defun frob-display-table (fdt-function fdt-locale &optional tag-set)
103 (or fdt-locale (setq fdt-locale 'global)) 136 (or fdt-locale (setq fdt-locale 'global))
104 (or (specifier-spec-list current-display-table fdt-locale) 137 (or (specifier-spec-list current-display-table fdt-locale tag-set)
105 (add-spec-to-specifier current-display-table (make-display-table) 138 (add-spec-to-specifier current-display-table (make-display-table)
106 fdt-locale)) 139 fdt-locale tag-set))
107 (add-spec-list-to-specifier 140 (add-spec-list-to-specifier
108 current-display-table 141 current-display-table
109 (list (cons fdt-locale 142 (list (cons fdt-locale
110 (mapcar 143 (mapcar
111 (lambda (fdt-x) 144 (lambda (fdt-x)
112 (funcall fdt-function (cdr fdt-x)) 145 (funcall fdt-function (cdr fdt-x))
113 fdt-x) 146 fdt-x)
114 (cdar (specifier-spec-list current-display-table 147 (cdar (specifier-spec-list current-display-table
115 fdt-locale))))))) 148 fdt-locale tag-set)))))))
149
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))))
116 200
117 (defun standard-display-8bit-1 (dt l h) 201 (defun standard-display-8bit-1 (dt l h)
118 (while (<= l h) 202 (while (<= l h)
119 (aset dt l (char-to-string l)) 203 (put-display-table l (char-to-string l) dt)
120 (setq l (1+ l)))) 204 (setq l (1+ l))))
121 205
122 ;;;###autoload 206 ;;;###autoload
123 (defun standard-display-8bit (l h &optional locale) 207 (defun standard-display-8bit (l h &optional locale)
124 "Display characters in the range L to H literally." 208 "Display characters in the range L to H literally."
127 (standard-display-8bit-1 x l h)) 211 (standard-display-8bit-1 x l h))
128 locale)) 212 locale))
129 213
130 (defun standard-display-default-1 (dt l h) 214 (defun standard-display-default-1 (dt l h)
131 (while (<= l h) 215 (while (<= l h)
132 (aset dt l nil) 216 (put-display-table l nil dt)
133 (setq l (1+ l)))) 217 (setq l (1+ l))))
134 218
135 ;;;###autoload 219 ;;;###autoload
136 (defun standard-display-default (l h &optional locale) 220 (defun standard-display-default (l h &optional locale)
137 "Display characters in the range L to H using the default notation." 221 "Display characters in the range L to H using the default notation."
143 ;;;###autoload 227 ;;;###autoload
144 (defun standard-display-ascii (c s &optional locale) 228 (defun standard-display-ascii (c s &optional locale)
145 "Display character C using printable string S." 229 "Display character C using printable string S."
146 (frob-display-table 230 (frob-display-table
147 (lambda (x) 231 (lambda (x)
148 (aset x c s)) 232 (put-display-table c s x))
149 locale)) 233 locale))
150
151
152 ;;; #### should frob in a 'tty locale.
153 234
154 ;;;###autoload 235 ;;;###autoload
155 (defun standard-display-g1 (c sc &optional locale) 236 (defun standard-display-g1 (c sc &optional locale)
156 "Display character C as character SC in the g1 character set. 237 "Display character C as character SC in the g1 character set.
157 This function assumes that your terminal uses the SO/SI characters; 238 This only has an effect on TTY devices and assumes that your terminal uses
158 it is meaningless for an X frame." 239 the SO/SI characters."
159 (frob-display-table 240 (frob-display-table
160 (lambda (x) 241 (lambda (x)
161 (aset x c (concat "\016" (char-to-string sc) "\017"))) 242 (put-display-table c (concat "\016" (char-to-string sc) "\017") x))
162 locale)) 243 locale
163 244 'tty))
164
165 ;;; #### should frob in a 'tty locale.
166 245
167 ;;;###autoload 246 ;;;###autoload
168 (defun standard-display-graphic (c gc &optional locale) 247 (defun standard-display-graphic (c gc &optional locale)
169 "Display character C as character GC in graphics character set. 248 "Display character C as character GC in graphics character set.
170 This function assumes VT100-compatible escapes; it is meaningless for an 249 This only has an effect on TTY devices and assumes VT100-compatible escapes."
171 X frame." 250 (frob-display-table
172 (frob-display-table 251 (lambda (x)
173 (lambda (x) 252 (put-display-table c (concat "\e(0" (char-to-string gc) "\e(B") x))
174 (aset x c (concat "\e(0" (char-to-string gc) "\e(B"))) 253 locale
175 locale)) 254 'tty))
176 255
177 ;;; #### should frob in a 'tty locale.
178 ;;; #### the FSF equivalent of this makes this character be displayed 256 ;;; #### the FSF equivalent of this makes this character be displayed
179 ;;; in the 'underline face. There's no current way to do this with 257 ;;; in the 'underline face. There's no current way to do this with
180 ;;; XEmacs display tables. 258 ;;; XEmacs display tables.
181 259
182 ;;;###autoload 260 ;;;###autoload
183 (defun standard-display-underline (c uc &optional locale) 261 (defun standard-display-underline (c uc &optional locale)
184 "Display character C as character UC plus underlining." 262 "Display character C as character UC plus underlining."
185 (frob-display-table 263 (frob-display-table
186 (lambda (x) 264 (lambda (x)
187 (aset x c (concat "\e[4m" (char-to-string uc) "\e[m"))) 265 (put-display-table c (concat "\e[4m" (char-to-string uc) "\e[m") x))
188 locale)) 266 locale
267 'tty))
189 268
190 ;;;###autoload 269 ;;;###autoload
191 (defun standard-display-european (arg &optional locale) 270 (defun standard-display-european (arg &optional locale)
192 "Toggle display of European characters encoded with ISO 8859. 271 "Toggle display of European characters encoded with ISO 8859.
193 When enabled, characters in the range of 160 to 255 display not 272 When enabled, characters in the range of 160 to 255 display not
196 (interactive "P") 275 (interactive "P")
197 (frob-display-table 276 (frob-display-table
198 (lambda (x) 277 (lambda (x)
199 (if (or (<= (prefix-numeric-value arg) 0) 278 (if (or (<= (prefix-numeric-value arg) 0)
200 (and (null arg) 279 (and (null arg)
201 (equal (aref x 160) (char-to-string 160)))) 280 (equal (get-display-table 160 x) (char-to-string 160))))
202 (standard-display-default-1 x 160 255) 281 (standard-display-default-1 x 160 255)
203 (standard-display-8bit-1 x 160 255))) 282 (standard-display-8bit-1 x 160 255)))
204 locale)) 283 locale))
205 284
206 (provide 'disp-table) 285 (provide 'disp-table)