Mercurial > hg > xemacs-beta

comparison tests/automated/mule-tests.el @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents 8de8e3f6228a
children ce085c4b3999
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
81 ;;----------------------------------------------------------------- 81 ;;-----------------------------------------------------------------
82 ;; Test string modification functions that modify the length of a char. 82 ;; Test string modification functions that modify the length of a char.
83 ;;----------------------------------------------------------------- 83 ;;-----------------------------------------------------------------
84 84
85 (when (featurep 'mule) 85 (when (featurep 'mule)
86 ;;---------------------------------------------------------------
86 ;; Test fillarray 87 ;; Test fillarray
88 ;;---------------------------------------------------------------
87 (macrolet 89 (macrolet
88 ((fillarray-test 90 ((fillarray-test
89 (charset1 charset2) 91 (charset1 charset2)
90 (let ((char1 (make-char charset1 69)) 92 (let ((char1 (make-char charset1 69))
91 (char2 (make-char charset2 69))) 93 (char2 (make-char charset2 69)))
102 ;; Test aset 104 ;; Test aset
103 (let ((string (string (make-char 'ascii 69) (make-char 'latin-iso8859-2 69)))) 105 (let ((string (string (make-char 'ascii 69) (make-char 'latin-iso8859-2 69))))
104 (aset string 0 (make-char 'latin-iso8859-2 42)) 106 (aset string 0 (make-char 'latin-iso8859-2 42))
105 (Assert (eq (aref string 1) (make-char 'latin-iso8859-2 69)))) 107 (Assert (eq (aref string 1) (make-char 'latin-iso8859-2 69))))
106 108
109 ;;---------------------------------------------------------------
107 ;; Test coding system functions 110 ;; Test coding system functions
111 ;;---------------------------------------------------------------
108 112
109 ;; Create alias for coding system without subsidiaries 113 ;; Create alias for coding system without subsidiaries
110 (Assert (coding-system-p (find-coding-system 'binary))) 114 (Assert (coding-system-p (find-coding-system 'binary)))
111 (Assert (coding-system-canonical-name-p 'binary)) 115 (Assert (coding-system-canonical-name-p 'binary))
112 (Assert (not (coding-system-alias-p 'binary))) 116 (Assert (not (coding-system-alias-p 'binary)))
223 (Assert (not (coding-system-alias-p 'mule-tests-alias))) 227 (Assert (not (coding-system-alias-p 'mule-tests-alias)))
224 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix))) 228 (Assert (not (coding-system-alias-p 'mule-tests-alias-unix)))
225 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias))) 229 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias)))
226 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos))) 230 (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos)))
227 231
232 ;;---------------------------------------------------------------
228 ;; Test strings waxing and waning across the 8k BIG_STRING limit (see alloc.c) 233 ;; Test strings waxing and waning across the 8k BIG_STRING limit (see alloc.c)
234 ;;---------------------------------------------------------------
229 (defun charset-char-string (charset) 235 (defun charset-char-string (charset)
230 (let (lo hi string n) 236 (let (lo hi string n)
231 (if (= (charset-chars charset) 94) 237 (if (= (charset-chars charset) 94)
232 (setq lo 33 hi 126) 238 (setq lo 33 hi 126)
233 (setq lo 32 hi 127)) 239 (setq lo 32 hi 127))
280 (loop for j from (1- (length string)) downto 0 do 286 (loop for j from (1- (length string)) downto 0 do
281 (aset string j (aref ascii-string (mod j 94)))) 287 (aset string j (aref ascii-string (mod j 94))))
282 (loop for k in '(0 1 58 59) do 288 (loop for k in '(0 1 58 59) do
283 (Assert (equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string)))) 289 (Assert (equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string))))
284 290
291 ;;---------------------------------------------------------------
292 ;; Test file-system character conversion (and, en passant, file ops)
293 ;;---------------------------------------------------------------
294 (let* ((scaron (make-char 'latin-iso8859-2 57))
295 (latin2-string (make-string 4 scaron))
296 (prefix (concat (file-name-as-directory (temp-directory)) latin2-string))
297 (name1 (make-temp-name prefix))
298 (name2 (make-temp-name prefix))
299 (file-name-coding-system 'iso-8859-2))
300 ;; This is how you suppress output from `message', called by `write-region'
301 (flet ((append-message (&rest args) ()))
302 (Assert (not (equal name1 name2)))
303 (Assert (not (file-exists-p name1)))
304 (write-region (point-min) (point-max) name1)
305 (Assert (file-exists-p name1))
306 (when (fboundp 'make-symbolic-link)
307 (make-symbolic-link name1 name2)
308 (Assert (file-exists-p name2))
309 (Assert (equal (file-truename name2) name1))
310 (Assert (equal (file-truename name1) name1)))
311
312 (ignore-file-errors (delete-file name1) (delete-file name2))))
313
314 ;; Add many more file operation tests here...
315
316 ;;---------------------------------------------------------------
317 ;; Test Unicode-related functions
318 ;;---------------------------------------------------------------
319 (let* ((scaron (make-char 'latin-iso8859-2 57)))
320 (loop for code in '(#x0000 #x2222 #x4444 #xffff) do
321 (progn
322 (set-ucs-char code scaron)
323 (Assert (eq scaron (ucs-char code)))))
324
325 (Assert (eq nil (set-ucs-char #x1ffff scaron)))
326 (Check-Error wrong-type-argument (set-ucs-char -10000 scaron)))
327
285 ) 328 )