tests/unicode-collation.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 (use-package :sb-unicode)
  13
  14 (defun split-string (string delimiter)
  15   (loop for begin = 0 then (1+ end)
  16         for end = (position delimiter string) then (position delimiter string :start begin)
  17         collect (subseq string begin end)
  18         while end))
  19
  20 (defun parse-codepoints (string &key (singleton-list t))
  21   (let ((list (mapcar
  22               (lambda (s) (parse-integer s :radix 16))
  23               (remove "" (split-string string #\Space) :test #'string=))))
  24     (if (not (or (cdr list) singleton-list)) (car list) list)))
  25
  26 (defun parse-string (codepoints)
  27   (coerce (mapcar #'code-char (parse-codepoints codepoints)) 'string))
  28
  29 (defun test-collation ()
  30   (declare (optimize (debug 2)))
  31   (with-test (:name (:collation)
  32                     :skipped-on (not :sb-unicode))
  33     (with-open-file (s "data/CollationTest_SHIFTED_SHORT.txt" :external-format :utf8)
  34       (loop with previous-string = ""
  35          for line = (read-line s nil nil)
  36          while line
  37          unless (or (eql 0 (position #\# line)) (string= line ""))
  38          do (let ((string (parse-string (subseq line 0 (position #\; line)))))
  39               (assert (unicode<= previous-string string))
  40               (setf previous-string string))))))
  41
  42 (test-collation)