1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
12 ;;; KLUDGE: eventually we will export NORMALIZE-STRING from somewhere.
13 ;;; Until we do, import it here so we can test it without putting ::
15 (import 'sb-impl::normalize-string)
17 (defun parse-one-line (line)
20 (end (position #\; line :start start) (position #\; line :start start))
22 ((= i 5) (nreverse result))
23 (with-input-from-string (s (subseq line start (1+ end)))
24 (let ((*read-base* 16.))
25 (push (map 'string 'code-char (read-delimited-list #\; s)) result)))))
27 (defmacro assert-all-string= (base &body others)
29 ,@(loop for test in others
30 collect `(assert (string= ,base ,test)))))
32 (defun test-line (c1 c2 c3 c4 c5)
34 (assert-all-string= c2
35 (normalize-string c1 :nfc)
36 (normalize-string c2 :nfc)
37 (normalize-string c3 :nfc))
38 (assert-all-string= c4
39 (normalize-string c4 :nfc)
40 (normalize-string c5 :nfc))
43 (assert-all-string= c3
44 (normalize-string c1 :nfd)
45 (normalize-string c2 :nfd)
46 (normalize-string c3 :nfd))
47 (assert-all-string= c5
48 (normalize-string c4 :nfd)
49 (normalize-string c5 :nfd))
52 (assert-all-string= c4
53 (normalize-string c1 :nfkc)
54 (normalize-string c2 :nfkc)
55 (normalize-string c3 :nfkc)
56 (normalize-string c4 :nfkc)
57 (normalize-string c5 :nfkc))
60 (assert-all-string= c5
61 (normalize-string c1 :nfkd)
62 (normalize-string c2 :nfkd)
63 (normalize-string c3 :nfkd)
64 (normalize-string c4 :nfkd)
65 (normalize-string c5 :nfkd)))
67 (defun test-no-normalization (string)
68 (assert-all-string= string
69 (normalize-string string :nfc)
70 (normalize-string string :nfd)
71 (normalize-string string :nfkc)
72 (normalize-string string :nfkd)))
74 (defun test-normalization ()
75 (declare (optimize (debug 2)))
76 (with-open-file (s "data/NormalizationTest.txt" :external-format :latin1)
77 (do ((line (read-line s) (read-line s)))
78 ((char/= #\# (char line 0))
79 (assert (string= "@Part0" line :end2 6))
80 (assert (char= #\# (char (read-line s) 0)))))
81 ;; Part0: specific cases
82 (with-test (:name (:unicode-normalization :part0)
83 :skipped-on '(not :sb-unicode))
84 (do ((line (read-line s) (read-line s)))
85 ((char= #\# (char line 0))
86 (assert (string= "@Part1" (read-line s) :end2 6))
87 (assert (char= #\# (char (read-line s) 0)))
88 (assert (char= #\# (char (read-line s) 0))))
89 (destructuring-bind (c1 c2 c3 c4 c5)
91 (test-line c1 c2 c3 c4 c5))))
92 ;; Part1: single characters. (Extra work to check for conformance
93 ;; on unlisted entries)
94 (with-test (:name (:unicode-normalization :part1)
95 :skipped-on '(not :sb-unicode))
96 (do ((line (read-line s) (read-line s))
98 ((char= #\# (char line 0))
99 (do ((code code (1+ code)))
101 (test-no-normalization (string (code-char code))))
102 (assert (string= "@Part2" (read-line s) :end2 6))
103 (assert (char= #\# (char (read-line s) 0))))
104 (destructuring-bind (c1 c2 c3 c4 c5)
105 (parse-one-line line)
106 (do ((c code (1+ c)))
107 ((= c (char-code (char c1 0)))
108 (test-line c1 c2 c3 c4 c5)
110 (test-no-normalization (string (code-char code)))))))
111 ;; Part2: Canonical Order Test
112 (with-test (:name (:unicode-normalization :part2)
113 :skipped-on '(not :sb-unicode))
114 (do ((line (read-line s) (read-line s)))
115 ((char= #\# (char line 0))
116 (assert (string= "@Part3" (read-line s) :end2 6))
117 (assert (char= #\# (char (read-line s) 0))))
118 (destructuring-bind (c1 c2 c3 c4 c5)
119 (parse-one-line line)
120 (test-line c1 c2 c3 c4 c5))))
121 ;; Part3: PRI #29 Test
122 (with-test (:name (:unicode-normalization :part3)
123 :skipped-on '(not :sb-unicode))
124 (do ((line (read-line s) (read-line s)))
125 ((char= #\# (char line 0))
126 (assert (char= #\# (char (read-line s) 0)))
127 (assert (null (read-line s nil nil))))
128 (destructuring-bind (c1 c2 c3 c4 c5)
129 (parse-one-line line)
130 (test-line c1 c2 c3 c4 c5))))))