Really restore clisp cross-compilation.
[sbcl.git] / tests / unicode-normalization.impure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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
6 ;;;; from CMU CL.
7 ;;;;
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.
11
12 ;;; KLUDGE: eventually we will export NORMALIZE-STRING from somewhere.
13 ;;; Until we do, import it here so we can test it without putting ::
14 ;;; everywhere.
15 (import 'sb-impl::normalize-string)
16
17 (defun parse-one-line (line)
18   (do* ((i 0 (1+ i))
19         (start 0 (1+ end))
20         (end (position #\; line :start start) (position #\; line :start start))
21         result)
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)))))
26
27 (defmacro assert-all-string= (base &body others)
28   `(progn
29      ,@(loop for test in others
30           collect `(assert (string= ,base ,test)))))
31
32 (defun test-line (c1 c2 c3 c4 c5)
33   ;; NFC
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))
41
42   ;; NFD
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))
50
51   ;; NFKC
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))
58
59   ;; NFKD
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)))
66
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)))
73
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)
90             (parse-one-line line)
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))
97            (code 0))
98           ((char= #\# (char line 0))
99            (do ((code code (1+ code)))
100                ((= code #x110000))
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)
109                (setf code (1+ c)))
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))))))
131
132 (test-normalization)