mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
364 lines
16 KiB
Common Lisp
364 lines
16 KiB
Common Lisp
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
(use-package :sb-unicode)
|
|
|
|
;; Taken straight out of the common lisp cookbook
|
|
(defun replace-all (part replacement string &key (test #'char=))
|
|
"Returns a new string in which all the occurences of the part
|
|
is replaced with replacement."
|
|
(with-output-to-string (out)
|
|
(loop with part-length = (length part)
|
|
for old-pos = 0 then (+ pos part-length)
|
|
for pos = (search part string
|
|
:start2 old-pos
|
|
:test test)
|
|
do (write-string string out
|
|
:start old-pos
|
|
:end (or pos (length string)))
|
|
when pos do (write-string replacement out)
|
|
while pos)))
|
|
|
|
(defun test-line (line)
|
|
(destructuring-bind (%cp %name %gc ccc %bidi decomp-map
|
|
%decimal-digit %digit %numeric
|
|
%bidi-mirrored %old-name old-comment
|
|
simple-up simple-down simple-title)
|
|
(split-string line #\;)
|
|
(declare (ignore decomp-map old-comment simple-up
|
|
simple-down simple-title))
|
|
(let* ((cp (parse-integer %cp :radix 16))
|
|
(char #+sb-unicode (code-char cp)
|
|
#-sb-unicode
|
|
(if (< cp 256)
|
|
(code-char cp)
|
|
(return-from test-line t)))
|
|
(gc (intern (string-upcase %gc) "KEYWORD"))
|
|
(bidi (intern (string-upcase %bidi) "KEYWORD"))
|
|
;; See `normalize-character-name` in ucd.lisp for a discussion
|
|
;; of U+1F5CF (PAGE) and the attendant standards-compliance issues2
|
|
(name (unless (or (position #\< %name) (= cp #x1F5CF))
|
|
(substitute #\_ #\Space %name)))
|
|
(old-name (unless (string= %old-name "")
|
|
(substitute #\_ #\Space %old-name)))
|
|
(char-from-name (name-char name))
|
|
(char-from-old-name
|
|
;; Exclude all the renaming conflicts, including the mass-rename of Georgian
|
|
(when (and old-name
|
|
(not
|
|
(member old-name
|
|
'("BELL"
|
|
"LATIN_CAPITAL_LETTER_YOGH"
|
|
"LATIN_SMALL_LETTER_YOGH"
|
|
"CYRILLIC_CAPITAL_LETTER_E"
|
|
"CYRILLIC_CAPITAL_LETTER_I"
|
|
"CYRILLIC_SMALL_LETTER_E"
|
|
"CYRILLIC_SMALL_LETTER_I"
|
|
"DOUBLE_VERTICAL_BAR"
|
|
"HANGUL_LETTER_CIEUC"
|
|
"HANGUL_LETTER_KIYEOK"
|
|
"HANGUL_LETTER_PIEUP"
|
|
"PARENTHESIZED_HANGUL_CIEUC"
|
|
"PARENTHESIZED_HANGUL_KIYEOK"
|
|
"PARENTHESIZED_HANGUL_PIEUP"
|
|
"CIRCLED_HANGUL_CIEUC"
|
|
"CIRCLED_HANGUL_KIYEOK"
|
|
"CIRCLED_HANGUL_PIEUP"
|
|
"HALFWIDTH_HANGUL_LETTER_CIEUC"
|
|
"HALFWIDTH_HANGUL_LETTER_KIYEOK"
|
|
"HALFWIDTH_HANGUL_LETTER_PIEUP"
|
|
"SQUARED_MV")
|
|
:test #'string=))
|
|
(or (< (length old-name) 14)
|
|
(string/= old-name "GEORGIAN_SMALL" :end1 14)))
|
|
(name-char old-name)))
|
|
(decimal-digit (parse-integer %decimal-digit :junk-allowed t))
|
|
(digit (parse-integer %digit :junk-allowed t))
|
|
(numeric (if (string= %numeric "") nil (read-from-string %numeric)))
|
|
(bidi-mirrored (string= %bidi-mirrored "Y")))
|
|
(when char-from-name
|
|
(assert (char= char char-from-name)))
|
|
(when char-from-old-name
|
|
(assert (char= char char-from-old-name)))
|
|
(assert (eql gc (general-category char)))
|
|
(assert (= (parse-integer ccc) (combining-class char)))
|
|
(assert (eql bidi (bidi-class char)))
|
|
(assert (eql decimal-digit (decimal-value char)))
|
|
(assert (eql digit (digit-value char)))
|
|
(assert (eql numeric (numeric-value char)))
|
|
(assert (eql bidi-mirrored (mirrored-p char)))
|
|
(assert (string= old-name (unicode-1-name char))))))
|
|
|
|
(defun test-property-reads ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s (merge-pathnames
|
|
(make-pathname
|
|
:directory '(:relative :up "tools-for-build")
|
|
:name "UnicodeData" :type "txt")
|
|
(or *load-pathname* *compile-file-pathname*)))
|
|
(with-test (:name (:unicode-properties))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
do (test-line line)))))
|
|
|
|
(test-property-reads)
|
|
|
|
(defun codepoint-or-range (string)
|
|
(remove-if-not
|
|
#'(lambda (i)
|
|
#+sb-unicode i
|
|
#-sb-unicode (< i 256))
|
|
(flet ((parse (str) (parse-integer str :radix 16 :junk-allowed t)))
|
|
(let ((parts (remove "" (split-string string #\.) :test #'string=)))
|
|
(if (cdr parts)
|
|
(loop for i from (parse (car parts)) to (parse (cadr parts)) collect i)
|
|
(mapcar #'parse parts))))))
|
|
|
|
(defun line-codepoints (line)
|
|
(codepoint-or-range (car (split-string line #\;))))
|
|
|
|
(defun test-property-line (fn line)
|
|
(destructuring-bind (%codepoints value) (split-string line #\;)
|
|
(let* ((codepoints (codepoint-or-range %codepoints))
|
|
(property (remove #\Space value))
|
|
(expected (intern
|
|
(string-upcase
|
|
(subseq property 0 (position #\# property)))
|
|
"KEYWORD")))
|
|
(loop for i in codepoints
|
|
unless (eql expected (funcall fn (code-char i)))
|
|
do (error "Character ~S has the wrong value for the tested property. Wanted ~S, got ~S."
|
|
(code-char i) expected (funcall fn (code-char i)))))))
|
|
|
|
(defun test-unallocated-bidi-class (code class missing)
|
|
(loop for ((start . end) . expected) in missing
|
|
if (and (<= start code) (<= code end))
|
|
do (assert (eql class expected))
|
|
and do (return)))
|
|
|
|
(defun test-bidi-class ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "data/DerivedBidiClass.txt" :external-format :utf-8)
|
|
(let ((missing-prefix "# @missing: ")
|
|
(bidi-class-table
|
|
'(("Left_To_Right" . :L)
|
|
("Right_To_Left" . :R)
|
|
("Arabic_Letter" . :AL)
|
|
("European_Terminator" . :ET)))
|
|
(tested (make-array #x110000 :initial-element 0 :element-type 'bit))
|
|
missing)
|
|
(with-test (:name (:bidi-class :assigned))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'bidi-class line)
|
|
and do (loop for code in (line-codepoints line) do (setf (aref tested code) 1))
|
|
when (eql (mismatch missing-prefix line) (length missing-prefix))
|
|
do (let* ((semipos (position #\; line))
|
|
(rangetext (subseq line (length missing-prefix) semipos))
|
|
(first-dot (position #\. rangetext))
|
|
(last-dot (position #\. rangetext :from-end t))
|
|
(start (parse-integer rangetext :end first-dot :radix 16))
|
|
(end (parse-integer rangetext :start (1+ last-dot) :radix 16))
|
|
(range (cons start end))
|
|
(class-name (subseq line (+ semipos 2)))
|
|
(class (cdr (assoc class-name bidi-class-table :test 'string=))))
|
|
(push (cons range class) missing))))
|
|
(with-test (:name (:bidi-class :missing-data))
|
|
;; Consistency check: the @missing lines in the data file have
|
|
;; "Left_To_Right" first and overrides following it, and we've
|
|
;; pushed in reverse order; test (:BIDI-CLASS :MISSING)
|
|
;; depends on this order.
|
|
(let ((last (car (last missing))))
|
|
(assert (equal last '((0 . #x10FFFF) . :L)))))
|
|
(with-test (:name (:bidi-class :missing))
|
|
(loop for code from 0 to (min (1- char-code-limit) #x10FFFF)
|
|
for char = (code-char code)
|
|
if (= (aref tested code) 0)
|
|
do (test-unallocated-bidi-class code (bidi-class char) missing))))))
|
|
|
|
(test-bidi-class)
|
|
|
|
(defun test-hangul-syllable-type ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "data/HangulSyllableType.txt" :external-format :utf-8)
|
|
(with-test (:name (:hangul-syllable-type))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'hangul-syllable-type line)))))
|
|
|
|
(test-hangul-syllable-type)
|
|
|
|
(defun test-east-asian-width ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "../tools-for-build/EastAsianWidth.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:east-asian-width))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'east-asian-width line)))))
|
|
|
|
(test-east-asian-width)
|
|
|
|
(defun test-script ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "../tools-for-build/Scripts.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:script))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'script (substitute #\- #\_ line))))))
|
|
|
|
(test-script)
|
|
|
|
(defun test-block ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "../tools-for-build/Blocks.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:block))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line
|
|
#'char-block
|
|
(replace
|
|
(substitute #\- #\Space line)
|
|
"; "
|
|
:start1 (position #\; line)))))))
|
|
|
|
(test-block)
|
|
|
|
(defun test-proplist ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "../tools-for-build/PropList.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:proplist))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do
|
|
(destructuring-bind (%codepoints value) (split-string line #\;)
|
|
(let* ((codepoints (codepoint-or-range %codepoints))
|
|
(property
|
|
(intern (string-upcase
|
|
(substitute
|
|
#\- #\_
|
|
(subseq (remove #\Space value) 0
|
|
(position #\# (remove #\Space value)))))
|
|
"KEYWORD")))
|
|
(loop for i in codepoints do
|
|
(unless (proplist-p (code-char i) property)
|
|
(error "Character ~S should be ~S, but isn't."
|
|
(code-char i) property)))))))))
|
|
|
|
(test-proplist)
|
|
|
|
(defun test-bidi-mirroring-glyph ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "../tools-for-build/BidiMirroring.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:bidi-mirroring-glyph)
|
|
:skipped-on (not :sb-unicode))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do
|
|
(let* ((codepoints
|
|
(split-string (subseq line 0 (position #\# line)) #\;))
|
|
(chars
|
|
(mapcar
|
|
#'(lambda (s) (code-char (parse-integer s :radix 16)))
|
|
codepoints)))
|
|
(unless (char= (bidi-mirroring-glyph (first chars)) (second chars))
|
|
(error "The mirroring glyph of ~S is not ~S, but ~S"
|
|
(first chars) (second chars)
|
|
(bidi-mirroring-glyph (first chars)))))))))
|
|
|
|
(test-bidi-mirroring-glyph)
|
|
|
|
(defun test-age ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "../tools-for-build/DerivedAge.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:age))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do
|
|
(destructuring-bind (%codepoints %age)
|
|
(split-string (subseq line 0 (position #\# line)) #\;)
|
|
(let* ((range (codepoint-or-range %codepoints))
|
|
(expected (mapcar #'parse-integer (split-string %age #\.))))
|
|
(loop for i in range
|
|
for char = (code-char i)
|
|
do
|
|
(unless (equalp
|
|
expected
|
|
(multiple-value-list (age char)))
|
|
(error "Character ~S should have age ~S, but has ~S instead."
|
|
char expected (multiple-value-list (age char)))))))))))
|
|
|
|
(test-age)
|
|
|
|
(defun test-grapheme-break-class ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "data/GraphemeBreakProperty.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:grapheme-break-class))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'grapheme-break-class
|
|
(replace-all "SpacingMark" "SPACING-MARK"
|
|
(substitute #\- #\_ line)))))))
|
|
|
|
(test-grapheme-break-class)
|
|
|
|
(defun test-word-break-class ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "data/WordBreakProperty.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:word-break-class))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'word-break-class
|
|
(substitute #\- #\_ line))))))
|
|
|
|
(test-word-break-class)
|
|
|
|
(defun test-sentence-break-class ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "data/SentenceBreakProperty.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:sentence-break-class))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'sentence-break-class line)))))
|
|
|
|
(test-sentence-break-class)
|
|
|
|
(defun test-line-break-class ()
|
|
(declare (optimize (debug 2)))
|
|
(with-open-file (s "../tools-for-build/LineBreak.txt"
|
|
:external-format :utf-8)
|
|
(with-test (:name (:line-break-class))
|
|
(loop for line = (read-line s nil nil)
|
|
while line
|
|
unless (or (string= "" line) (eql 0 (position #\# line)))
|
|
do (test-property-line #'line-break-class line)))))
|
|
|
|
(test-line-break-class)
|