comparison lisp/mule/mule-charset.el @ 788:026c5bf9c134

[xemacs-hg @ 2002-03-21 07:29:57 by ben] chartab.c: Fix bugs in implementation and doc strings. config.h.in: Add foo_checking_assert_at_line() macros. Not clear whether these are actually useful, though; I'll take them out if not. symsinit.h, emacs.c: Some improvements to the timeline. Rearrange a bit the init calls. Add call for reinit_vars_of_object_mswindows() and declare in symsinit.h. event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, event-tty.c, events.c, events.h: Introduce new event methods for printing, comparing, and hashing magic events, to avoid event-type-specific stuff that had crept into events.c. (And was crashing, since the channel in MS Windows magic events may be nil.) Implement the methods in event-{tty,gtk,Xt,mswindows}.c. Make wrapping functions event_stream_{compare,hash,format}_magic_event() to check if everything's OK and call the actual callback. Fix events.c to use the new methods. Add a new event-stream-operation EVENT_STREAM_NOTHING -- event stream not actually required to be able to do anything, just be open. (#### This event-stream-operation stuff needs to be rethought.) Fixed describe_event() in event-Xt.c to print its output to a stream, not always to stderr, so it can be used elsewhere. (e.g. in print-event when a magic event is encountered?) lisp.h, lrecord.h: Define new assert_at_line(), for use in asserts inside of inline functions. The assert will report the line and file of the inline function, which is almost certainly not what you want as it's useless. what you want to see is where the pseudo-macro was called from. So, when error-checking is on, we pass in the line and file into the macros, for accurate printout using assert_at_line(). Happens only when error-checking is defined so doesn't slow down non-error-checking builds. Fix XCHAR, XINT, XCHAR_OR_INT, XFOO, and wrap_foo() in this fashion. lstream.c, lstream.h: Add resizing_buffer_to_lisp_string(). objects-gtk.c: Fix typo. objects-msw.c: Implement a smarter way of determining whether a font matches a charset. Formerly we just looked at the "script" element of the font spec, converted it to a code page, and compared it with the code page derived from the charset. Now, as well as doing this, we ask the font for the list of unicode ranges it supports, see what range the charset falls into (#### bogus! need to do this char-by-char), and see if any of the font's supported ranges include the charset's range. also do some caching in Vfont_signature_data of previous inquiries. charset.h, text.c, mule-charset.c: New fun; extracted out of Fmake_char() and declare prototype in charset.h. text.h: introduce assert_by_line() to make REP_BYTES_BY_FIRST_BYTE report the file and line more accurately in an assertion failure. unicode.c: make non-static (used in objects-msw.c), declare in charset.h. mule\mule-category.el: Start implementing a category API compatible with FSF. Not there yet. We need improvements to char-tables. mule\mule-charset.el: Copy translation table code from FSF 21.1 and fix up. Eventually we'll have them in XEmacs. (used in ccl) Not here quite yet, and we need some improvements to char-tables. mule\cyril-util.el, mule\cyrillic.el, mule\devan-util.el, mule\ethio-util.el, mule\korea-util.el, mule\mule-tty-init.el, mule\tibet-util.el, mule\viet-util.el, mule\vietnamese.el: Fix numerous compilation warnings. Fix up code related to translation tables and other types of char-tables. menubar-items.el: Move the frame commands from the View menu to the File menu, to be consistent with how most other programs do things. Move less-used revert/recover items to a submenu. Make "recover" not prompt for a file, but recover the current buffer. TODO.ben-mule-21-5: Create bug list for latest problems.
author ben
date Thu, 21 Mar 2002 07:31:30 +0000
parents 2923009caf47
children accc481aef34
comparison
equal deleted inserted replaced
787:242b62e9fc59 788:026c5bf9c134
1 ;;; mule-charset.el --- Charset functions for Mule. -*- coding: iso-2022-7bit; -*- 1 ;;; mule-charset.el --- Charset functions for Mule. -*- coding: iso-2022-7bit; -*-
2 2
3 ;; Copyright (C) 1992 Free Software Foundation, Inc. 3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
4 ;; Copyright (C) 1992, 2001 Free Software Foundation, Inc.
5 ;; Licensed to the Free Software Foundation.
4 ;; Copyright (C) 1995 Amdahl Corporation. 6 ;; Copyright (C) 1995 Amdahl Corporation.
5 ;; Copyright (C) 1996 Sun Microsystems. 7 ;; Copyright (C) 1996 Sun Microsystems.
6 ;; Copyright (C) 2002 Ben Wing. 8 ;; Copyright (C) 2002 Ben Wing.
7 9
8 ;; Author: Unknown 10 ;; Author: Unknown
152 154
153 (defalias 'get-charset-property 'get) 155 (defalias 'get-charset-property 'get)
154 (defalias 'put-charset-property 'put) 156 (defalias 'put-charset-property 'put)
155 (defalias 'charset-plist 'object-plist) 157 (defalias 'charset-plist 'object-plist)
156 (defalias 'set-charset-plist 'setplist) 158 (defalias 'set-charset-plist 'setplist)
159
160
161 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
162 ; translation tables ;
163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
164
165 (defstruct (translation-table (:constructor internal-make-translation-table))
166 forward
167 reverse)
168
169 (defun make-translation-table (&rest args)
170 "Make a translation table from arguments.
171 A translation table is a char table intended for for character
172 translation in CCL programs.
173
174 Each argument is a list of elemnts of the form (FROM . TO), where FROM
175 is a character to be translated to TO.
176
177 FROM can be a generic character (see `make-char'). In this case, TO is
178 a generic character containing the same number of characters, or a
179 ordinary character. If FROM and TO are both generic characters, all
180 characters belonging to FROM are translated to characters belonging to TO
181 without changing their position code(s).
182
183 The arguments and forms in each argument are processed in the given
184 order, and if a previous form already translates TO to some other
185 character, say TO-ALT, FROM is also translated to TO-ALT."
186 (let ((table (internal-make-translation-table
187 :forward (make-char-table 'generic)))
188 revlist)
189 (while args
190 (let ((elts (car args)))
191 (while elts
192 (let* ((from (car (car elts)))
193 (from-i 0) ; degree of freedom of FROM
194 (from-rev (nreverse (split-char from)))
195 (to (cdr (car elts)))
196 (to-i 0) ; degree of freedom of TO
197 (to-rev (nreverse (split-char to))))
198 ;; Check numbers of heading 0s in FROM-REV and TO-REV.
199 (while (eq (car from-rev) 0)
200 (setq from-i (1+ from-i) from-rev (cdr from-rev)))
201 (while (eq (car to-rev) 0)
202 (setq to-i (1+ to-i) to-rev (cdr to-rev)))
203 (if (and (/= from-i to-i) (/= to-i 0))
204 (error "Invalid character pair (%d . %d)" from to))
205 ;; If we have already translated TO to TO-ALT, FROM should
206 ;; also be translated to TO-ALT. But, this is only if TO
207 ;; is a generic character or TO-ALT is not a generic
208 ;; character.
209 (let ((to-alt (get-char-table to table)))
210 (if (and to-alt
211 (or (> to-i 0) (not (find-charset to-alt))))
212 (setq to to-alt)))
213 (if (> from-i 0)
214 (set-char-table-default table from to)
215 (put-char-table from to table))
216 ;; If we have already translated some chars to FROM, they
217 ;; should also be translated to TO.
218 (let ((l (assq from revlist)))
219 (if l
220 (let ((ch (car l)))
221 (setcar l to)
222 (setq l (cdr l))
223 (while l
224 (put-char-table ch to table)
225 (setq l (cdr l)) ))))
226 ;; Now update REVLIST.
227 (let ((l (assq to revlist)))
228 (if l
229 (setcdr l (cons from (cdr l)))
230 (setq revlist (cons (list to from) revlist)))))
231 (setq elts (cdr elts))))
232 (setq args (cdr args)))
233 ;; Return TABLE just created.
234 table))
235
236 ;; Do we really need this?
237 ; (defun make-translation-table-from-vector (vec)
238 ; "Make translation table from decoding vector VEC.
239 ; VEC is an array of 256 elements to map unibyte codes to multibyte characters.
240 ; See also the variable `nonascii-translation-table'."
241 ; (let ((table (make-char-table 'translation-table))
242 ; (rev-table (make-char-table 'translation-table))
243 ; (i 0)
244 ; ch)
245 ; (while (< i 256)
246 ; (setq ch (aref vec i))
247 ; (aset table i ch)
248 ; (if (>= ch 256)
249 ; (aset rev-table ch i))
250 ; (setq i (1+ i)))
251 ; (set-char-table-extra-slot table 0 rev-table)
252 ; table))
253
254 (defvar named-translation-table-hash-table (make-hash-table))
255
256 (defun define-translation-table (symbol &rest args)
257 "Define SYMBOL as the name of translation table made by ARGS.
258 This sets up information so that the table can be used for
259 translations in a CCL program.
260
261 If the first element of ARGS is a translation table, just define SYMBOL to
262 name it. (Note that this function does not bind SYMBOL.)
263
264 Any other ARGS should be suitable as arguments of the function
265 `make-translation-table' (which see).
266
267 Look up a named translation table using `find-translation-table' or
268 `get-translation-table'."
269 (let ((table (if (translation-table-p (car args))
270 (car args)
271 (apply 'make-translation-table args))))
272 (puthash symbol table named-translation-table-hash-table)))
273
274 (defun find-translation-table (table-or-name)
275 "Retrieve the translation table of the given name.
276 If TABLE-OR-NAME is a translation table object, it is simply returned.
277 Otherwise, TABLE-OR-NAME should be a symbol. If there is no such
278 translation table, nil is returned. Otherwise the associated translation
279 table object is returned."
280 (if (translation-table-p table-or-name)
281 table-or-name
282 (check-argument-type 'symbolp table-or-name)
283 (gethash table-or-name named-translation-table-hash-table)))
284
285 (defun get-translation-table (table-or-name)
286 "Retrieve the translation table of the given name.
287 Same as `find-translation-table' except an error is signalled if there is
288 no such translation table instead of returning nil."
289 (or (find-translation-table table-or-name)
290 (error 'invalid-argument "No such translation table" table-or-name)))
157 291
158 292
159 ;; Setup auto-fill-chars for charsets that should invoke auto-filling. 293 ;; Setup auto-fill-chars for charsets that should invoke auto-filling.
160 ;; SPACE and NEWLINE are already set. 294 ;; SPACE and NEWLINE are already set.
161 (let ((l '(katakana-jisx0201 295 (let ((l '(katakana-jisx0201