Mercurial > hg > xemacs-beta

comparison lisp/disp-table.el @ 219:262b8bb4a523 r20-4b8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b8
author cvs
date Mon, 13 Aug 2007 10:09:35 +0200
parents
children e214ff9f9507 3742ea8250b5
comparison
equal deleted inserted replaced
218:c9f226976f56 219:262b8bb4a523
1 ;;; disp-table.el --- functions for dealing with char tables.
2
3 ;; Copyright (C) 1987, 1994, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Sun Microsystems.
5
6 ;; Author: Howard Gayle
7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: i18n, internal
9
10 ;; This file is part of XEmacs.
11
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26
27 ;;; Synched up with: Not synched with FSF.
28
29 ;;; Commentary:
30
31 ;; #### Need lots of work. make-display-table depends on a value
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
38 ;; Rewritten for XEmacs July 1995, Ben Wing.
39
40
41 ;;; Code:
42
43 (defun describe-display-table (dt)
44 "Describe the display table DT in a help buffer."
45 (with-displaying-help-buffer
46 (lambda ()
47 (princ "\nCharacter display glyph sequences:\n")
48 (save-excursion
49 (let ((vector (make-vector 256 nil))
50 (i 0))
51 (while (< i 256)
52 (aset vector i (aref dt i))
53 (incf i))
54 ;; FSF calls `describe-vector' here, but it is so incredibly
55 ;; lame a function for that name that I cannot bring myself
56 ;; to porting it. Here is what `describe-vector' does:
57 (terpri)
58 (let ((old (aref vector 0))
59 (oldpos 0)
60 (i 1)
61 str)
62 (while (<= i 256)
63 (when (or (= i 256)
64 (not (equal old (aref vector i))))
65 (if (eq oldpos (1- i))
66 (princ (format "%s\t\t%s\n"
67 (single-key-description (int-char oldpos))
68 old))
69 (setq str (format "%s - %s"
70 (single-key-description (int-char oldpos))
71 (single-key-description (int-char (1- i)))))
72 (princ str)
73 (princ (make-string (max (- 2 (/ (length str)
74 tab-width)) 1) ?\t))
75 (princ old)
76 (terpri))
77 (or (= i 256)
78 (setq old (aref vector i)
79 oldpos i)))
80 (incf i))))))))
81
82 ;;;###autoload
83 (defun describe-current-display-table (&optional domain)
84 "Describe the display table in use in the selected window and buffer."
85 (interactive)
86 (or domain (setq domain (selected-window)))
87 (let ((disptab (specifier-instance current-display-table domain)))
88 (if disptab
89 (describe-display-table disptab)
90 (message "No display table"))))
91
92 ;;;###autoload
93 (defun make-display-table ()
94 "Return a new, empty display table."
95 (make-vector 256 nil))
96
97 ;; #### we need a generic frob-specifier function.
98 ;; #### this also needs to be redone like frob-face-property.
99
100 ;; Let me say one more time how much dynamic scoping sucks.
101
102 (defun frob-display-table (fdt-function fdt-locale)
103 (or fdt-locale (setq fdt-locale 'global))
104 (or (specifier-spec-list current-display-table fdt-locale)
105 (add-spec-to-specifier current-display-table (make-display-table)
106 fdt-locale))
107 (add-spec-list-to-specifier
108 current-display-table
109 (list (cons fdt-locale
110 (mapcar
111 (lambda (fdt-x)
112 (funcall fdt-function (cdr fdt-x))
113 fdt-x)
114 (cdar (specifier-spec-list current-display-table
115 fdt-locale)))))))
116
117 (defun standard-display-8bit-1 (dt l h)
118 (while (<= l h)
119 (aset dt l (char-to-string l))
120 (setq l (1+ l))))
121
122 ;;;###autoload
123 (defun standard-display-8bit (l h &optional locale)
124 "Display characters in the range L to H literally."
125 (frob-display-table
126 (lambda (x)
127 (standard-display-8bit-1 x l h))
128 locale))
129
130 (defun standard-display-default-1 (dt l h)
131 (while (<= l h)
132 (aset dt l nil)
133 (setq l (1+ l))))
134
135 ;;;###autoload
136 (defun standard-display-default (l h &optional locale)
137 "Display characters in the range L to H using the default notation."
138 (frob-display-table
139 (lambda (x)
140 (standard-display-default-1 x l h))
141 locale))
142
143 ;;;###autoload
144 (defun standard-display-ascii (c s &optional locale)
145 "Display character C using printable string S."
146 (frob-display-table
147 (lambda (x)
148 (aset x c s))
149 locale))
150
151
152 ;;; #### should frob in a 'tty locale.
153
154 ;;;###autoload
155 (defun standard-display-g1 (c sc &optional locale)
156 "Display character C as character SC in the g1 character set.
157 This function assumes that your terminal uses the SO/SI characters;
158 it is meaningless for an X frame."
159 (frob-display-table
160 (lambda (x)
161 (aset x c (concat "\016" (char-to-string sc) "\017")))
162 locale))
163
164
165 ;;; #### should frob in a 'tty locale.
166
167 ;;;###autoload
168 (defun standard-display-graphic (c gc &optional locale)
169 "Display character C as character GC in graphics character set.
170 This function assumes VT100-compatible escapes; it is meaningless for an
171 X frame."
172 (frob-display-table
173 (lambda (x)
174 (aset x c (concat "\e(0" (char-to-string gc) "\e(B")))
175 locale))
176
177 ;;; #### should frob in a 'tty locale.
178 ;;; #### the FSF equivalent of this makes this character be displayed
179 ;;; in the 'underline face. There's no current way to do this with
180 ;;; XEmacs display tables.
181
182 ;;;###autoload
183 (defun standard-display-underline (c uc &optional locale)
184 "Display character C as character UC plus underlining."
185 (frob-display-table
186 (lambda (x)
187 (aset x c (concat "\e[4m" (char-to-string uc) "\e[m")))
188 locale))
189
190 ;;;###autoload
191 (defun standard-display-european (arg &optional locale)
192 "Toggle display of European characters encoded with ISO 8859.
193 When enabled, characters in the range of 160 to 255 display not
194 as octal escapes, but as accented characters.
195 With prefix argument, enable European character display iff arg is positive."
196 (interactive "P")
197 (frob-display-table
198 (lambda (x)
199 (if (or (<= (prefix-numeric-value arg) 0)
200 (and (null arg)
201 (equal (aref x 160) (char-to-string 160))))
202 (standard-display-default-1 x 160 255)
203 (standard-display-8bit-1 x 160 255)))
204 locale))
205
206 (provide 'disp-table)
207
208 ;;; disp-table.el ends here