428
+ − 1 ;; Copyright (C) 1999 Free Software Foundation, Inc.
+ − 2
+ − 3 ;; Author: Hrvoje Niksic <hniksic@xemacs.org>
440
+ − 4 ;; Maintainers: Hrvoje Niksic <hniksic@xemacs.org>,
+ − 5 ;; Martin Buchholz <martin@xemacs.org>
428
+ − 6 ;; Created: 1999
+ − 7 ;; Keywords: tests
+ − 8
+ − 9 ;; This file is part of XEmacs.
+ − 10
+ − 11 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 12 ;; under the terms of the GNU General Public License as published by
+ − 13 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 14 ;; any later version.
+ − 15
+ − 16 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 19 ;; General Public License for more details.
+ − 20
+ − 21 ;; You should have received a copy of the GNU General Public License
+ − 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
+ − 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+ − 24 ;; 02111-1307, USA.
+ − 25
+ − 26 ;;; Synched up with: Not in FSF.
+ − 27
+ − 28 ;;; Commentary:
+ − 29
+ − 30 ;; Test some Mule functionality (most of these remain to be written) .
+ − 31 ;; See test-harness.el for instructions on how to run these tests.
+ − 32
434
+ − 33 ;; This file will be (read)ed by a non-mule XEmacs, so don't use
+ − 34 ;; literal non-Latin1 characters. Use (make-char) instead.
+ − 35
428
+ − 36 ;;-----------------------------------------------------------------
+ − 37 ;; Test whether all legal chars may be safely inserted to a buffer.
+ − 38 ;;-----------------------------------------------------------------
+ − 39
+ − 40 (defun test-chars (&optional for-test-harness)
+ − 41 "Insert all characters in a buffer, to see if XEmacs will crash.
+ − 42 This is done by creating a string with all the legal characters
+ − 43 in [0, 2^19) range, inserting it into the buffer, and checking
+ − 44 that the buffer's contents are equivalent to the string.
+ − 45
+ − 46 If FOR-TEST-HARNESS is specified, a temporary buffer is used, and
+ − 47 the Assert macro checks for correctness."
+ − 48 (let ((max (expt 2 (if (featurep 'mule) 19 8)))
+ − 49 (list nil)
+ − 50 (i 0))
+ − 51 (while (< i max)
+ − 52 (and (not for-test-harness)
+ − 53 (zerop (% i 1000))
+ − 54 (message "%d" i))
+ − 55 (and (int-char i)
+ − 56 ;; Don't aset to a string directly because random string
+ − 57 ;; access is O(n) under Mule.
+ − 58 (setq list (cons (int-char i) list)))
+ − 59 (setq i (1+ i)))
+ − 60 (let ((string (apply #'string (nreverse list))))
+ − 61 (if for-test-harness
+ − 62 ;; For use with test-harness, use Assert and a temporary
+ − 63 ;; buffer.
+ − 64 (with-temp-buffer
+ − 65 (insert string)
+ − 66 (Assert (equal (buffer-string) string)))
+ − 67 ;; For use without test harness: use a normal buffer, so that
+ − 68 ;; you can also test whether redisplay works.
+ − 69 (switch-to-buffer (get-buffer-create "test"))
+ − 70 (erase-buffer)
+ − 71 (buffer-disable-undo)
+ − 72 (insert string)
+ − 73 (assert (equal (buffer-string) string))))))
+ − 74
+ − 75 ;; It would be really *really* nice if test-harness allowed a way to
+ − 76 ;; run a test in byte-compiled mode only. It's tedious to have
+ − 77 ;; time-consuming tests like this one run twice, once interpreted and
+ − 78 ;; once compiled, for no good reason.
+ − 79 (test-chars t)
434
+ − 80
3439
+ − 81 (defun unicode-code-point-to-utf-8-string (code-point)
+ − 82 "Convert a Unicode code point to the equivalent UTF-8 string.
+ − 83 This is a naive implementation in Lisp. "
+ − 84 (check-argument-type 'natnump code-point)
+ − 85 (check-argument-range code-point 0 #x1fffff)
+ − 86 (if (< code-point #x80)
+ − 87 (format "%c" code-point)
+ − 88 (if (< code-point #x800)
+ − 89 (format "%c%c"
+ − 90 ;; ochars[0] = 0xC0 | (input & ~(0xFFFFF83F)) >> 6;
+ − 91 (logior #xc0 (lsh (logand code-point #x7c0) -6))
+ − 92 ;; ochars[1] = 0x80 | input & ~(0xFFFFFFC0);
+ − 93 (logior #x80 (logand code-point #x3f)))
+ − 94 (if (< code-point #x00010000)
+ − 95 (format "%c%c%c"
+ − 96 ;; ochars[0] = 0xE0 | (input >> 12) & ~(0xFFFFFFF0);
+ − 97 (logior #xe0 (logand (lsh code-point -12) #x0f))
+ − 98 ;; ochars[1] = 0x80 | (input >> 6) & ~(0xFFFFFFC0);
+ − 99 (logior #x80 (logand (lsh code-point -6) #x3f))
+ − 100 ;; ochars[2] = 0x80 | input & ~(0xFFFFFFC0);
+ − 101 (logior #x80 (logand code-point #x3f)))
+ − 102 (if (< code-point #x200000)
+ − 103 (format "%c%c%c%c"
+ − 104 ;; ochars[0] = 0xF0 | (input >> 18) & ~(0xFFFFFFF8)
+ − 105 (logior #xF0 (logand (lsh code-point -18) #x7))
+ − 106 ;; ochars[1] = 0x80 | (input >> 12) & ~(0xFFFFFFC0);
+ − 107 (logior #x80 (logand (lsh code-point -12) #x3f))
+ − 108 ;; ochars[2] = 0x80 | (input >> 6) & ~(0xFFFFFFC0);
+ − 109 (logior #x80 (logand (lsh code-point -6) #x3f))
+ − 110 ;; ochars[3] = 0x80 | input & ~(0xFFFFFFC0);
+ − 111 (logior #x80 (logand code-point #x3f))))))))
+ − 112
434
+ − 113 ;;-----------------------------------------------------------------
+ − 114 ;; Test string modification functions that modify the length of a char.
+ − 115 ;;-----------------------------------------------------------------
+ − 116
+ − 117 (when (featurep 'mule)
442
+ − 118 ;;---------------------------------------------------------------
434
+ − 119 ;; Test fillarray
442
+ − 120 ;;---------------------------------------------------------------
434
+ − 121 (macrolet
+ − 122 ((fillarray-test
+ − 123 (charset1 charset2)
+ − 124 (let ((char1 (make-char charset1 69))
+ − 125 (char2 (make-char charset2 69)))
+ − 126 `(let ((string (make-string 1000 ,char1)))
+ − 127 (fillarray string ,char2)
+ − 128 (Assert (eq (aref string 0) ,char2))
+ − 129 (Assert (eq (aref string (1- (length string))) ,char2))
+ − 130 (Assert (eq (length string) 1000))))))
+ − 131 (fillarray-test ascii latin-iso8859-1)
+ − 132 (fillarray-test ascii latin-iso8859-2)
+ − 133 (fillarray-test latin-iso8859-1 ascii)
+ − 134 (fillarray-test latin-iso8859-2 ascii))
+ − 135
+ − 136 ;; Test aset
+ − 137 (let ((string (string (make-char 'ascii 69) (make-char 'latin-iso8859-2 69))))
+ − 138 (aset string 0 (make-char 'latin-iso8859-2 42))
+ − 139 (Assert (eq (aref string 1) (make-char 'latin-iso8859-2 69))))
+ − 140
442
+ − 141 ;;---------------------------------------------------------------
440
+ − 142 ;; Test coding system functions
442
+ − 143 ;;---------------------------------------------------------------
440
+ − 144
+ − 145 ;; Create alias for coding system without subsidiaries
+ − 146 (Assert (coding-system-p (find-coding-system 'binary)))
+ − 147 (Assert (coding-system-canonical-name-p 'binary))
+ − 148 (Assert (not (coding-system-alias-p 'binary)))
+ − 149 (Assert (not (coding-system-alias-p 'mule-tests-alias)))
+ − 150 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ − 151 (Check-Error-Message
+ − 152 error "Symbol is the canonical name of a coding system and cannot be redefined"
+ − 153 (define-coding-system-alias 'binary 'iso8859-2))
+ − 154 (Check-Error-Message
+ − 155 error "Symbol is not a coding system alias"
+ − 156 (coding-system-aliasee 'binary))
+ − 157
+ − 158 (define-coding-system-alias 'mule-tests-alias 'binary)
+ − 159 (Assert (coding-system-alias-p 'mule-tests-alias))
+ − 160 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ − 161 (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)))
+ − 162 (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias)))
+ − 163 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
+ − 164 (Assert (not (coding-system-alias-p 'mule-tests-alias-dos)))
+ − 165 (Assert (not (coding-system-alias-p 'mule-tests-alias-mac)))
+ − 166
+ − 167 (define-coding-system-alias 'mule-tests-alias (get-coding-system 'binary))
+ − 168 (Assert (coding-system-alias-p 'mule-tests-alias))
+ − 169 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ − 170 (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)))
+ − 171 (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias)))
+ − 172 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
+ − 173 (Assert (not (coding-system-alias-p 'mule-tests-alias-dos)))
+ − 174 (Assert (not (coding-system-alias-p 'mule-tests-alias-mac)))
+ − 175
+ − 176 (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias)
+ − 177 (Assert (coding-system-alias-p 'nested-mule-tests-alias))
+ − 178 (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias)))
+ − 179 (Assert (eq (get-coding-system 'binary) (get-coding-system 'nested-mule-tests-alias)))
+ − 180 (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias))
+ − 181 (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)))
+ − 182 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-unix)))
+ − 183 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos)))
+ − 184 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-mac)))
+ − 185
+ − 186 (Check-Error-Message
+ − 187 error "Attempt to create a coding system alias loop"
+ − 188 (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
+ − 189 (Check-Error-Message
+ − 190 error "No such coding system"
+ − 191 (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
+ − 192 (Check-Error-Message
+ − 193 error "Attempt to create a coding system alias loop"
+ − 194 (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
+ − 195
+ − 196 (define-coding-system-alias 'nested-mule-tests-alias nil)
+ − 197 (define-coding-system-alias 'mule-tests-alias nil)
+ − 198 (Assert (coding-system-p (find-coding-system 'binary)))
+ − 199 (Assert (coding-system-canonical-name-p 'binary))
+ − 200 (Assert (not (coding-system-alias-p 'binary)))
+ − 201 (Assert (not (coding-system-alias-p 'mule-tests-alias)))
+ − 202 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ − 203 (Check-Error-Message
+ − 204 error "Symbol is the canonical name of a coding system and cannot be redefined"
+ − 205 (define-coding-system-alias 'binary 'iso8859-2))
+ − 206 (Check-Error-Message
+ − 207 error "Symbol is not a coding system alias"
+ − 208 (coding-system-aliasee 'binary))
+ − 209
+ − 210 (define-coding-system-alias 'nested-mule-tests-alias nil)
+ − 211 (define-coding-system-alias 'mule-tests-alias nil)
+ − 212
+ − 213 ;; Create alias for coding system with subsidiaries
+ − 214 (define-coding-system-alias 'mule-tests-alias 'iso-8859-7)
+ − 215 (Assert (coding-system-alias-p 'mule-tests-alias))
+ − 216 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ − 217 (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)))
+ − 218 (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)))
+ − 219 (Assert (coding-system-alias-p 'mule-tests-alias-unix))
+ − 220 (Assert (coding-system-alias-p 'mule-tests-alias-dos))
+ − 221 (Assert (coding-system-alias-p 'mule-tests-alias-mac))
+ − 222
+ − 223 (define-coding-system-alias 'mule-tests-alias (get-coding-system 'iso-8859-7))
+ − 224 (Assert (coding-system-alias-p 'mule-tests-alias))
+ − 225 (Assert (not (coding-system-canonical-name-p 'mule-tests-alias)))
+ − 226 (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)))
+ − 227 (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)))
+ − 228 (Assert (coding-system-alias-p 'mule-tests-alias-unix))
+ − 229 (Assert (coding-system-alias-p 'mule-tests-alias-dos))
+ − 230 (Assert (coding-system-alias-p 'mule-tests-alias-mac))
+ − 231 (Assert (eq (find-coding-system 'mule-tests-alias-mac)
+ − 232 (find-coding-system 'iso-8859-7-mac)))
+ − 233
+ − 234 (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias)
+ − 235 (Assert (coding-system-alias-p 'nested-mule-tests-alias))
+ − 236 (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias)))
+ − 237 (Assert (eq (get-coding-system 'iso-8859-7)
+ − 238 (get-coding-system 'nested-mule-tests-alias)))
+ − 239 (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias))
+ − 240 (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)))
+ − 241 (Assert (coding-system-alias-p 'nested-mule-tests-alias-unix))
+ − 242 (Assert (coding-system-alias-p 'nested-mule-tests-alias-dos))
+ − 243 (Assert (coding-system-alias-p 'nested-mule-tests-alias-mac))
+ − 244 (Assert (eq (find-coding-system 'nested-mule-tests-alias-unix)
+ − 245 (find-coding-system 'iso-8859-7-unix)))
+ − 246
+ − 247 (Check-Error-Message
+ − 248 error "Attempt to create a coding system alias loop"
+ − 249 (define-coding-system-alias 'mule-tests-alias 'nested-mule-tests-alias))
+ − 250 (Check-Error-Message
+ − 251 error "No such coding system"
+ − 252 (define-coding-system-alias 'no-such-coding-system 'no-such-coding-system))
+ − 253 (Check-Error-Message
+ − 254 error "Attempt to create a coding system alias loop"
+ − 255 (define-coding-system-alias 'mule-tests-alias 'mule-tests-alias))
+ − 256
+ − 257 ;; Test dangling alias deletion
+ − 258 (define-coding-system-alias 'mule-tests-alias nil)
+ − 259 (Assert (not (coding-system-alias-p 'mule-tests-alias)))
+ − 260 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
+ − 261 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias)))
+ − 262 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos)))
+ − 263
442
+ − 264 ;;---------------------------------------------------------------
438
+ − 265 ;; Test strings waxing and waning across the 8k BIG_STRING limit (see alloc.c)
442
+ − 266 ;;---------------------------------------------------------------
438
+ − 267 (defun charset-char-string (charset)
2026
+ − 268 (let (lo hi string n (gc-cons-threshold most-positive-fixnum))
438
+ − 269 (if (= (charset-chars charset) 94)
+ − 270 (setq lo 33 hi 126)
+ − 271 (setq lo 32 hi 127))
+ − 272 (if (= (charset-dimension charset) 1)
+ − 273 (progn
+ − 274 (setq string (make-string (1+ (- hi lo)) ??))
+ − 275 (setq n 0)
+ − 276 (loop for j from lo to hi do
+ − 277 (progn
+ − 278 (aset string n (make-char charset j))
+ − 279 (incf n)))
2026
+ − 280 (garbage-collect)
438
+ − 281 string)
+ − 282 (progn
+ − 283 (setq string (make-string (* (1+ (- hi lo)) (1+ (- hi lo))) ??))
+ − 284 (setq n 0)
+ − 285 (loop for j from lo to hi do
+ − 286 (loop for k from lo to hi do
+ − 287 (progn
+ − 288 (aset string n (make-char charset j k))
+ − 289 (incf n))))
2026
+ − 290 (garbage-collect)
438
+ − 291 string))))
+ − 292
+ − 293 ;; The following two used to crash xemacs!
+ − 294 (Assert (charset-char-string 'japanese-jisx0208))
+ − 295 (aset (make-string 9003 ??) 1 (make-char 'latin-iso8859-1 77))
+ − 296
+ − 297 (let ((greek-string (charset-char-string 'greek-iso8859-7))
+ − 298 (string (make-string (* 96 60) ??)))
+ − 299 (loop for j from 0 below (length string) do
+ − 300 (aset string j (aref greek-string (mod j 96))))
+ − 301 (loop for k in '(0 1 58 59) do
+ − 302 (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))))
+ − 303
+ − 304 (let ((greek-string (charset-char-string 'greek-iso8859-7))
+ − 305 (string (make-string (* 96 60) ??)))
+ − 306 (loop for j from (1- (length string)) downto 0 do
+ − 307 (aset string j (aref greek-string (mod j 96))))
+ − 308 (loop for k in '(0 1 58 59) do
+ − 309 (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))))
+ − 310
+ − 311 (let ((ascii-string (charset-char-string 'ascii))
+ − 312 (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57))))
+ − 313 (loop for j from 0 below (length string) do
+ − 314 (aset string j (aref ascii-string (mod j 94))))
+ − 315 (loop for k in '(0 1 58 59) do
+ − 316 (Assert (equal (substring string (* 94 k) (+ 94 (* 94 k))) ascii-string))))
+ − 317
+ − 318 (let ((ascii-string (charset-char-string 'ascii))
+ − 319 (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57))))
+ − 320 (loop for j from (1- (length string)) downto 0 do
+ − 321 (aset string j (aref ascii-string (mod j 94))))
+ − 322 (loop for k in '(0 1 58 59) do
+ − 323 (Assert (equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string))))
+ − 324
442
+ − 325 ;;---------------------------------------------------------------
+ − 326 ;; Test file-system character conversion (and, en passant, file ops)
+ − 327 ;;---------------------------------------------------------------
+ − 328 (let* ((scaron (make-char 'latin-iso8859-2 57))
+ − 329 (latin2-string (make-string 4 scaron))
597
+ − 330 (prefix (concat (file-name-as-directory
+ − 331 (file-truename (temp-directory)))
+ − 332 latin2-string))
442
+ − 333 (name1 (make-temp-name prefix))
+ − 334 (name2 (make-temp-name prefix))
2026
+ − 335 (file-name-coding-system
+ − 336 ;; 'iso-8859-X doesn't work on darwin (as of "Panther" 10.3), it
+ − 337 ;; seems to know that file-name-coding-system is definitely utf-8
+ − 338 (if (string-match "darwin" system-configuration)
+ − 339 'utf-8
+ − 340 'iso-8859-2))
+ − 341 )
442
+ − 342 ;; This is how you suppress output from `message', called by `write-region'
3472
+ − 343 (Assert (not (equal name1 name2)))
+ − 344 (Assert (not (file-exists-p name1)))
+ − 345 (Silence-Message
+ − 346 (write-region (point-min) (point-max) name1))
+ − 347 (Assert (file-exists-p name1))
+ − 348 (when (fboundp 'make-symbolic-link)
+ − 349 (make-symbolic-link name1 name2)
+ − 350 (Assert (file-exists-p name2))
+ − 351 (Assert (equal (file-truename name2) name1))
+ − 352 (Assert (equal (file-truename name1) name1)))
442
+ − 353
3472
+ − 354 (ignore-file-errors (delete-file name1) (delete-file name2)))
442
+ − 355
+ − 356 ;; Add many more file operation tests here...
+ − 357
+ − 358 ;;---------------------------------------------------------------
+ − 359 ;; Test Unicode-related functions
+ − 360 ;;---------------------------------------------------------------
+ − 361 (let* ((scaron (make-char 'latin-iso8859-2 57)))
875
+ − 362 ;; Used to try #x0000, but you can't change ASCII or Latin-1
+ − 363 (loop for code in '(#x0100 #x2222 #x4444 #xffff) do
442
+ − 364 (progn
800
+ − 365 (set-unicode-conversion scaron code)
+ − 366 (Assert (eq code (char-to-unicode scaron)))
+ − 367 (Assert (eq scaron (unicode-to-char code '(latin-iso8859-2))))))
442
+ − 368
800
+ − 369 (Check-Error wrong-type-argument (set-unicode-conversion scaron -10000)))
1195
+ − 370
3439
+ − 371 (dolist (utf-8-char
+ − 372 '("\xc6\x92" ;; U+0192 LATIN SMALL LETTER F WITH HOOK
+ − 373 "\xe2\x81\x8a" ;; U+204A TIRONIAN SIGN ET
+ − 374 "\xe2\x82\xae" ;; U+20AE TUGRIK SIGN
+ − 375 "\xf0\x9d\x92\xbd" ;; U+1D4BD MATHEMATICAL SCRIPT SMALL H
+ − 376 "\xf0\x9d\x96\x93" ;; U+1D593 MATHEMATICAL BOLD FRAKTUR SMALL N
+ − 377 "\xf0\xaf\xa8\x88" ;; U+2FA08 CJK COMPATIBILITY FOR U+4BCE
+ − 378 "\xf4\x8f\xbf\xbd")) ;; U+10FFFD <Plane 16 Private Use, Last>
+ − 379 (let* ((xemacs-character (car (append
+ − 380 (decode-coding-string utf-8-char 'utf-8)
+ − 381 nil)))
+ − 382 (xemacs-charset (car (split-char xemacs-character))))
+ − 383
+ − 384 ;; Trivial test of the UTF-8 support of the escape-quoted character set.
+ − 385 (Assert (equal (decode-coding-string utf-8-char 'utf-8)
+ − 386 (decode-coding-string (concat "\033%G" utf-8-char)
+ − 387 'escape-quoted)))
+ − 388
+ − 389 ;; Check that the reverse mapping holds.
+ − 390 (Assert (equal (unicode-code-point-to-utf-8-string
+ − 391 (encode-char xemacs-character 'ucs))
+ − 392 utf-8-char))
+ − 393
+ − 394 ;; Check that, if this character has been JIT-allocated, it is encoded
+ − 395 ;; in escape-quoted using the corresponding UTF-8 escape.
+ − 396 (when (charset-property xemacs-charset 'encode-as-utf-8)
+ − 397 (Assert (equal (concat "\033%G" utf-8-char)
+ − 398 (encode-coding-string xemacs-character 'escape-quoted)))
+ − 399 (Assert (equal (concat "\033%G" utf-8-char)
+ − 400 (encode-coding-string xemacs-character 'ctext))))))
+ − 401
1195
+ − 402 ;;---------------------------------------------------------------
3690
+ − 403 ;; Regression test for a couple of CCL-related bugs.
+ − 404 ;;---------------------------------------------------------------
+ − 405
+ − 406 (let ((ccl-vector [0 0 0 0 0 0 0 0 0]))
+ − 407 (define-ccl-program ccl-write-two-control-1-chars
+ − 408 `(1
+ − 409 ((r0 = ,(charset-id 'control-1))
+ − 410 (r1 = 0)
+ − 411 (write-multibyte-character r0 r1)
+ − 412 (r1 = 31)
+ − 413 (write-multibyte-character r0 r1)))
+ − 414 "CCL program that writes two control-1 multibyte characters.")
+ − 415
+ − 416 (Assert (equal
+ − 417 (ccl-execute-on-string 'ccl-write-two-control-1-chars
+ − 418 ccl-vector "")
+ − 419 (format "%c%c" (make-char 'control-1 0)
+ − 420 (make-char 'control-1 31))))
+ − 421
+ − 422 (define-ccl-program ccl-unicode-two-control-1-chars
+ − 423 `(1
+ − 424 ((r0 = ,(charset-id 'control-1))
+ − 425 (r1 = 31)
+ − 426 (mule-to-unicode r0 r1)
+ − 427 (r4 = r0)
+ − 428 (r3 = ,(charset-id 'control-1))
+ − 429 (r2 = 0)
+ − 430 (mule-to-unicode r3 r2)))
+ − 431 "CCL program that writes two control-1 UCS code points in r3 and r4")
+ − 432
+ − 433 ;; Re-initialise the vector, mainly to clear the instruction counter,
+ − 434 ;; which is its last element.
+ − 435 (setq ccl-vector [0 0 0 0 0 0 0 0 0])
+ − 436
+ − 437 (ccl-execute-on-string 'ccl-unicode-two-control-1-chars ccl-vector "")
+ − 438
+ − 439 (Assert (and (eq (aref ccl-vector 3)
+ − 440 (encode-char (make-char 'control-1 0) 'ucs))
+ − 441 (eq (aref ccl-vector 4)
+ − 442 (encode-char (make-char 'control-1 31) 'ucs)))))
+ − 443
+ − 444 ;;---------------------------------------------------------------
1195
+ − 445 ;; Test charset-in-* functions
+ − 446 ;;---------------------------------------------------------------
+ − 447 (with-temp-buffer
+ − 448 (insert-file-contents (locate-data-file "HELLO"))
+ − 449 ;; #### rewrite robustly, both assume that the tested implementation
+ − 450 ;; uses the same algorithm as was used by the version current at time
+ − 451 ;; this test was written
1316
+ − 452 (Assert (equal (charsets-in-region (point-min) (point-max))
+ − 453 '(korean-ksc5601 chinese-big5-1 chinese-gb2312
+ − 454 japanese-jisx0212 katakana-jisx0201 japanese-jisx0208
+ − 455 vietnamese-viscii-lower thai-xtis cyrillic-iso8859-5
+ − 456 hebrew-iso8859-8 greek-iso8859-7 latin-iso8859-1
+ − 457 latin-iso8859-2 arabic-2-column arabic-1-column
+ − 458 ethiopic ascii)))
+ − 459 (Assert (equal (charsets-in-string (buffer-substring (point-min)
+ − 460 (point-max)))
+ − 461 '(korean-ksc5601 chinese-big5-1 chinese-gb2312
+ − 462 japanese-jisx0212 katakana-jisx0201 japanese-jisx0208
+ − 463 vietnamese-viscii-lower thai-xtis cyrillic-iso8859-5
+ − 464 hebrew-iso8859-8 greek-iso8859-7 latin-iso8859-1
+ − 465 latin-iso8859-2 arabic-2-column arabic-1-column
+ − 466 ethiopic ascii))))
434
+ − 467 )