mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
2d6559efdb
On failure, display the line, its number in the file, the expected result, and the actual result.
137 lines
5.3 KiB
Common Lisp
137 lines
5.3 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)
|
|
|
|
(defconstant +mul+ #+sb-unicode (code-char 215) #-sb-unicode #\*)
|
|
(defconstant +div+ #+sb-unicode (code-char 247) #-sb-unicode #\/)
|
|
|
|
(defun line-to-clusters (line)
|
|
(let ((codepoints
|
|
(remove "" (split-string (substitute #\Space +div+ line) #\Space)
|
|
:test #'string=))
|
|
clusters cluster (nobreak t))
|
|
(loop for i in codepoints do
|
|
(if (string= i (string +mul+)) (setf nobreak t)
|
|
(progn
|
|
(unless nobreak
|
|
(push (nreverse cluster) clusters)
|
|
(setf cluster nil))
|
|
(push (code-char (parse-integer i :radix 16)) cluster)
|
|
(setf nobreak nil))))
|
|
(when cluster (push (nreverse cluster) clusters))
|
|
(setf clusters (nreverse (mapcar #'(lambda (x) (coerce x 'string)) clusters)))
|
|
clusters))
|
|
|
|
(defun parse-codepoints (string &key (singleton-list t))
|
|
(let ((list (mapcar
|
|
(lambda (s) (parse-integer s :radix 16))
|
|
(remove "" (split-string string #\Space) :test #'string=))))
|
|
(if (not (or (cdr list) singleton-list)) (car list) list)))
|
|
|
|
(defun test-line (fn line n)
|
|
(let ((relevant-portion (subseq line 0 (position #\# line))))
|
|
(when (string/= relevant-portion "")
|
|
(let* ((string
|
|
(coerce (mapcar
|
|
#'code-char
|
|
(parse-codepoints
|
|
(remove +mul+ (remove +div+ relevant-portion))))
|
|
'string))
|
|
(actual (funcall fn string))
|
|
(expected (line-to-clusters relevant-portion)))
|
|
(assert (equalp actual expected)
|
|
()
|
|
"~@<line ~D: ~S - expected: ~S, actual: ~S~@:>"
|
|
n line expected actual)))))
|
|
|
|
(defun test-graphemes ()
|
|
(declare (optimize (debug 2)))
|
|
(with-test (:name (:grapheme-breaking)
|
|
:skipped-on (not :sb-unicode))
|
|
(with-open-file (s "data/GraphemeBreakTest.txt" :external-format :utf8)
|
|
(loop for line = (read-line s nil nil)
|
|
for n from 0
|
|
while line
|
|
do (test-line #'graphemes (remove #\Tab line) n)))))
|
|
|
|
(test-graphemes)
|
|
|
|
(defun test-words ()
|
|
(declare (optimize (debug 2)))
|
|
(with-test (:name (:word-breaking)
|
|
:skipped-on (not :sb-unicode))
|
|
(with-open-file (s "data/WordBreakTest.txt" :external-format :utf8)
|
|
(loop for line = (read-line s nil nil)
|
|
for n from 0
|
|
while line
|
|
do (test-line #'words (remove #\Tab line) n)))))
|
|
|
|
(test-words)
|
|
|
|
(defun test-sentences ()
|
|
(declare (optimize (debug 2)))
|
|
(with-test (:name (:sentence-breaking)
|
|
:skipped-on (not :sb-unicode))
|
|
(with-open-file (s "data/SentenceBreakTest.txt" :external-format :utf8)
|
|
(loop for line = (read-line s nil nil)
|
|
for n from 0
|
|
while line
|
|
do (test-line #'sentences (remove #\Tab line) n)))))
|
|
|
|
(test-sentences)
|
|
|
|
(defun process-line-break-line (line)
|
|
(let ((elements (split-string line #\Space)))
|
|
(mapcar #'(lambda (e)
|
|
(cond
|
|
((eql (char e 0) +mul+) :cant)
|
|
((eql (char e 0) +div+) :can)
|
|
(t (code-char (parse-integer e :radix 16)))))
|
|
elements)))
|
|
|
|
(defun string-from-line-break-line (string)
|
|
(coerce
|
|
(mapcar
|
|
#'(lambda (s) (code-char (parse-integer s :radix 16)))
|
|
(remove
|
|
""
|
|
(split-string (remove +mul+ (remove +div+ string)) #\Space)
|
|
:test #'string=)) 'string))
|
|
|
|
(with-test (:name (:line-breaking)
|
|
:skipped-on (not :sb-unicode))
|
|
(let* ((line-break-exceptions (make-hash-table :test 'equal))
|
|
(strings
|
|
(with-open-file (s "data/line-break-exceptions.lisp-expr" :external-format :utf-8)
|
|
(read s))))
|
|
(dolist (s strings)
|
|
(setf (gethash s line-break-exceptions) t))
|
|
(with-open-file (s "data/LineBreakTest.txt" :external-format :utf8)
|
|
(loop for line = (read-line s nil nil)
|
|
for n from 0
|
|
while line
|
|
do (let ((string (subseq line 0 (max 0 (1- (or (position #\# line) 1))))))
|
|
(unless (string= string "")
|
|
(let* ((expected (process-line-break-line string))
|
|
(annotated (sb-unicode::line-break-annotate
|
|
(string-from-line-break-line string)))
|
|
(actual (substitute :can :must annotated)))
|
|
(if (gethash string line-break-exceptions)
|
|
(assert (not (equal expected actual))
|
|
()
|
|
"~@<line ~D: ~S - expected: ~S, actual; ~S~:@>"
|
|
n string expected actual)
|
|
(assert (equal expected actual)
|
|
()
|
|
"~@<line ~D: ~S - expected: ~S, actual; ~S~:@>"
|
|
n string expected actual)))))))))
|