From: Chris Hanson Date: Sun, 19 Feb 2017 01:42:37 +0000 (-0800) Subject: Add a bunch of unit tests swiped from Larceny. X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~71 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eb6ed73c6b803368a81e35a8b58bf5cdd91867b6;p=mit-scheme.git Add a bunch of unit tests swiped from Larceny. --- diff --git a/tests/runtime/test-char.scm b/tests/runtime/test-char.scm index 43c72ccb8..7ec3a112b 100644 --- a/tests/runtime/test-char.scm +++ b/tests/runtime/test-char.scm @@ -45,8 +45,8 @@ USA. (for-each (lambda (entry) (let ((char (car entry)) (code (cadr entry))) - (assert-= code (char->integer char)) - (assert-eq char (integer->char code)))) + (assert-= (char->integer char) code) + (assert-eq (integer->char code) char))) named-chars))) (define ascii-chars @@ -69,8 +69,184 @@ USA. (define (basic-char-tests char code) (assert-true (char? char)) - (assert-eq char (integer->char code)) - (assert-= code (char->integer char))) + (assert-eq (integer->char code) char) + (assert-= (char->integer char) code)) + +;;;; Tests adapted from the Larceny R7RS test suite: + +(define-test 'larceny-char-spot-checks + (lambda () + (assert-eqv (char-upcase #\i) #\I) + (assert-eqv (char-downcase #\i) #\i) + (assert-eqv (char-foldcase #\i) #\i) + + (assert-false (char-ci? #\z #\Z)) + (assert-false (char-ci>? #\Z #\z)) + (assert-false (char-ci>? #\a #\Z)) + (assert-true (char-ci>? #\Z #\a)) + (assert-true (char-ci>=? #\Z #\z)) + (assert-true (char-ci>=? #\z #\Z)) + (assert-true (char-ci>=? #\z #\Z)) + (assert-false (char-ci>=? #\a #\z)) + + (assert-true (char-alphabetic? #\a)) + (assert-false (char-alphabetic? #\1)) + (assert-true (char-numeric? #\1)) + (assert-false (char-numeric? #\a)) + (assert-true (char-whitespace? #\space)) + (assert-false (char-whitespace? #\a)) + (assert-false (char-upper-case? #\a)) + (assert-true (char-upper-case? #\A)) + (assert-true (char-lower-case? #\a)) + (assert-false (char-lower-case? #\A)))) + +(define-test 'larceny-char-spot-checks-2 + (lambda () + (let* ((w #\a) + (x #\N) + (y #\z) + (z (integer->char (+ 13 (char->integer w))))) + + ;; (assert-false (char-ci=? x y z)) + ;; (assert-true (char-ci=? x x z)) + ;; (assert-false (char-ci=? w x y)) + ;; (assert-false (char-ci=? y x w)) + + ;; (assert-false (char-ci? x y z)) + ;; (assert-false (char-ci>? x x z)) + ;; (assert-false (char-ci>? w x y)) + ;; (assert-true (char-ci>? y x w)) + + ;; (assert-false (char-ci<=? x y z)) + ;; (assert-true (char-ci<=? x x z)) + ;; (assert-true (char-ci<=? w x y)) + ;; (assert-false (char-ci<=? y x w)) + + ;; (assert-false (char-ci>=? x y z)) + ;; (assert-true (char-ci>=? x x z)) + ;; (assert-false (char-ci>=? w x y)) + ;; (assert-true (char-ci>=? y x w)) + + (assert-true (char-ci=? x x)) + (assert-false (char-ci=? w x)) + (assert-false (char-ci=? y x)) + + (assert-false (char-ci? x x)) + (assert-false (char-ci>? w x)) + (assert-true (char-ci>? y x)) + + (assert-true (char-ci<=? x x)) + (assert-true (char-ci<=? w x)) + (assert-false (char-ci<=? y x)) + + (assert-true (char-ci>=? x x)) + (assert-false (char-ci>=? w x)) + (assert-true (char-ci>=? y x))))) + +(define-test 'larceny-unicode-spot-checks + (lambda () + (assert-eqv (char-upcase #\xDF) #\xDF) + (assert-eqv (char-downcase #\xDF) #\xDF) + (assert-eqv (char-foldcase #\xDF) #\xDF) + + (assert-eqv (char-upcase #\x3A3) #\x3A3) + (assert-eqv (char-downcase #\x3A3) #\x3C3) + (assert-eqv (char-foldcase #\x3A3) #\x3C3) + + (assert-eqv (char-upcase #\x3C2) #\x3A3) + (assert-eqv (char-downcase #\x3C2) #\x3C2) + (assert-eqv (char-foldcase #\x3C2) #\x3C3) + + (assert-char-ci= #\x3C3 #\x3C2) + + (assert-true (char-whitespace? #\x00A0)) + (assert-true (char-upper-case? #\x3A3)) + (assert-true (char-lower-case? #\x3C3)) + (assert-true (char-lower-case? #\x00AA)))) + +;; Systematic testing on every Unicode character. +;; The counts are believed to be correct for Unicode 5.0, +;; except for char-whitespace? (which has dropped to 25 in Unicode 7.0). +;; The counts are likely to increase monotonically (if at all) in later +;; versions, but that's not a given. + +(define-test 'larceny-unicode-systematic + (lambda () + + (define (count-all-chars predicate) + (do ((i 0 (fix:+ i 1)) + (m 0 + (if (and (or (fix:< i #xD800) (fix:>= i #xE000)) + (predicate (integer->char i))) + (fix:+ m 1) + m))) + ((not (fix:< i #x110000)) m))) + + (assert-= (count-all-chars + (lambda (c) + (and (char? c) + (char? (char-upcase c)) + (char? (char-downcase c)) + (char? (char-foldcase c)) + (char=? c (integer->char (char->integer c)))))) + 1112064) + + (assert->= (count-all-chars char-alphabetic?) 93217) + (assert->= (count-all-chars char-numeric?) 282) + (assert->= (count-all-chars char-whitespace?) 25) + (assert->= (count-all-chars char-upper-case?) 1362) + (assert->= (count-all-chars char-lower-case?) 1791))) + +(define-test 'larceny-digit-value + (lambda () + + (define (filter-all-chars predicate) + (do ((i 0 (fix:+ i 1)) + (chars '() + (if (or (fix:< i #xD800) (fix:>= i #xE000)) + (let ((char (integer->char i))) + (if (predicate char) + (cons char chars) + chars)) + chars))) + ((not (fix:< i #x110000)) (reverse! chars)))) + + (for-each (lambda (expected char) + (assert-eqv (digit-value char) expected)) + '(0 1 2 3 4 5 6 7 8 9 #f #f #f #f #f #f) + (string->list "0123456789abcDEF")) + + (assert-null + (remove! (lambda (char) + (let ((n (digit-value char))) + (and (exact-integer? n) + (<= 0 n 9)))) + (filter-all-chars char-numeric?))) + + (assert-null + (filter! digit-value + (filter-all-chars + (lambda (c) + (not (char-numeric? c)))))))) (define-test 'valid-utf8-sequences (lambda () @@ -78,18 +254,18 @@ USA. (let ((bytes (car entry)) (char (cadr entry))) (let ((n (bytevector-length bytes))) - (assert-= n - (initial-byte->utf8-char-length - (bytevector-u8-ref bytes 0))) - (assert-= n - (char-utf8-byte-length char)) - (assert-eq char (decode-utf8-char bytes 0)) + (assert-= (initial-byte->utf8-char-length + (bytevector-u8-ref bytes 0)) + n) + (assert-= (char-utf8-byte-length char) + n) + (assert-eq (decode-utf8-char bytes 0) char) (do ((offset 0 (+ offset 1))) ((not (< offset 8))) (let ((bv (make-bytevector 16)) (m (+ offset n))) - (assert-= m (encode-utf8-char! bv offset char)) - (assert-equal bytes (bytevector-copy bv offset m))))))) + (assert-= (encode-utf8-char! bv offset char) m) + (assert-equal (bytevector-copy bv offset m) bytes)))))) valid-utf8-sequences))) (define valid-utf8-sequences @@ -129,11 +305,11 @@ USA. (if (memv b invalid-utf8-initial-bytes) (assert-error (lambda () (initial-byte->utf8-char-length b))) - (assert-= (cond ((< b #x80) 1) + (assert-= (initial-byte->utf8-char-length b) + (cond ((< b #x80) 1) ((< b #xE0) 2) ((< b #xF0) 3) - (else 4)) - (initial-byte->utf8-char-length b)))) + (else 4))))) (iota #x100)))) (define invalid-utf8-initial-bytes @@ -147,8 +323,8 @@ USA. (length (cadr entry))) (let ((b0 (bytevector-u8-ref bytes 0))) (if (not (memv b0 invalid-utf8-initial-bytes)) - (assert-= length - (initial-byte->utf8-char-length b0)))) + (assert-= (initial-byte->utf8-char-length b0) + length))) (assert-error (lambda () (decode-utf8-char bytes 0))))) invalid-known-length-sequences))) diff --git a/tests/runtime/test-string.scm b/tests/runtime/test-string.scm index 66586efbd..597def903 100644 --- a/tests/runtime/test-string.scm +++ b/tests/runtime/test-string.scm @@ -71,7 +71,7 @@ USA. "D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF" "E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF" "F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF")) - + (define-test 'HEXADECIMAL->VECTOR-8B/LOWERCASE (lambda () (assert-equal (allbytes) (hexadecimal->vector-8b (allbytes:lower))))) @@ -110,3 +110,75 @@ USA. (assert-equal v (hexadecimal->vector-8b (string-upcase (vector-8b->hexadecimal v)))))))) + +;;;; Tests adapted from the Larceny R7RS test suite: + +(define-test 'larceny-string + (lambda () + + (assert-string-ci< "A" "z") + (assert-string-ci< "A" "z") + (assert-string-ci< "a" "Z") + (assert-string-ci< "a" "Z") + (assert-string-ci<= "A" "z") + (assert-string-ci<= "A" "z") + (assert-string-ci<= "Z" "z") + (assert-string-ci<= "Z" "z") + (assert-string-ci<= "a" "Z") + (assert-string-ci<= "a" "Z") + (assert-string-ci<= "z" "Z") + (assert-string-ci<= "z" "Z") + (assert-string-ci= "z" "Z") + (assert-string-ci!= "z" "a") + (assert-string-ci> "Z" "a") + (assert-string-ci> "Z" "a") + (assert-string-ci> "z" "A") + (assert-string-ci> "z" "A") + (assert-string-ci>= "Z" "a") + (assert-string-ci>= "Z" "a") + (assert-string-ci>= "Z" "z") + (assert-string-ci>= "Z" "z") + (assert-string-ci>= "z" "A") + (assert-string-ci>= "z" "A") + (assert-string-ci>= "z" "Z") + (assert-string-ci>= "z" "Z") + + (assert-string= (string-upcase "Hi") "HI") + (assert-string= (string-upcase "HI") "HI") + (assert-string= (string-downcase "Hi") "hi") + (assert-string= (string-downcase "hi") "hi") + (assert-string= (string-foldcase "Hi") "hi") + (assert-string= (string-foldcase "HI") "hi") + (assert-string= (string-foldcase "hi") "hi") + (assert-string= (string-downcase "STRASSE") "strasse") + + (assert-string= (string-upcase "Stra\xDF;e") "STRASSE") + (assert-string= (string-downcase "Stra\xDF;e") "stra\xDF;e") + (assert-string= (string-foldcase "Stra\xDF;e") "strasse") + (assert-string= (string-downcase "\x3A3;") "\x3C3;") + + (assert-string= (string-upcase "\x39E;\x391;\x39F;\x3A3;") + "\x39E;\x391;\x39F;\x3A3;") + ;; Would be "\x3BE;\x3B1;\x3BF;\x3C2;" with final sigma + (assert-string= (string-downcase "\x39E;\x391;\x39F;\x3A3;") + "\x3BE;\x3B1;\x3BF;\x3C3;") + ;; Would be "\x3BE;\x3B1;\x3BF;\x3C3;\x3C2;" with final sigma + (assert-string= (string-downcase "\x39E;\x391;\x39F;\x3A3;\x3A3;") + "\x3BE;\x3B1;\x3BF;\x3C3;\x3C3;") + ;; Would be "\x3BE;\x3B1;\x3BF;\x3C2; \x3C3;" with final sigma + (assert-string= (string-downcase "\x39E;\x391;\x39F;\x3A3; \x3A3;") + "\x3BE;\x3B1;\x3BF;\x3C3; \x3C3;") + (assert-string= (string-foldcase "\x39E;\x391;\x39F;\x3A3;") + "\x3BE;\x3B1;\x3BF;\x3C3;") + (assert-string= (string-upcase "\x3BE;\x3B1;\x3BF;\x3C3;") + "\x39E;\x391;\x39F;\x3A3;") + (assert-string= (string-upcase "\x3BE;\x3B1;\x3BF;\x3C2;") + "\x39E;\x391;\x39F;\x3A3;") + + (assert-string= (string-downcase "A\x3A3;'x") ; ' is a MidLetter + "a\x3C3;'x") + + (assert-string-ci= "Strasse" "Stra\xDF;e") + (assert-string-ci= "STRASSE" "Stra\xDF;e") + (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C2;" "\x39E;\x391;\x39F;\x3A3;") + (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C3;" "\x39E;\x391;\x39F;\x3A3;"))) \ No newline at end of file diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index c894abcc6..d1c4dfee6 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -443,14 +443,10 @@ USA. (set! set-comparator-metadata! (table 'put!)) unspecific) -(define-for-tests (define-comparator comparator name relation) +(define-for-tests (define-comparator comparator name) (guarantee binary-procedure? comparator 'define-comparator) (guarantee symbol? name 'define-comparator) - (guarantee string? relation 'define-comparator) - (set-comparator-metadata! comparator (cons name relation))) - -(define-for-tests (define-equality equality name) - (define-comparator equality name (string name " to"))) + (set-comparator-metadata! comparator (cons name (string name " to")))) (define (name-of comparator) (car (comparator-metadata comparator))) @@ -458,18 +454,40 @@ USA. (define (text-of comparator) (cdr (comparator-metadata comparator))) -(define-equality eq? 'eq?) -(define-equality eqv? 'eqv?) -(define-equality equal? 'equal?) -(define-equality = '=) -(define-comparator < '< "less than") -(define-comparator <= '<= "less than or equal to") -(define-comparator > '> "greater than") -(define-comparator >= '>= "greater than or equal to") -(define-equality boolean=? 'boolean=?) -(define-equality char=? 'char=?) -(define-equality string=? 'string=?) - +(define-comparator eq? 'eq?) +(define-comparator eqv? 'eqv?) +(define-comparator equal? 'equal?) +(define-comparator < '<) +(define-comparator <= '<=) +(define-comparator = '=) +(define-comparator > '>) +(define-comparator >= '>=) +(define-comparator boolean=? 'boolean=?) + +(define-comparator char<=? 'char<=) +(define-comparator char=? 'char>=) +(define-comparator char>? 'char>) + +(define-comparator char-ci<=? 'char-ci<=) +(define-comparator char-ci=? 'char-ci>=) +(define-comparator char-ci>? 'char-ci>) + +(define-comparator string<=? 'string<=) +(define-comparator string=? 'string>=) +(define-comparator string>? 'string>) + +(define-comparator string-ci<=? 'string-ci<=) +(define-comparator string-ci=? 'string-ci>=) +(define-comparator string-ci>? 'string-ci>) + (define (binary-assertion negate? test pattern) (let ((test (if negate? (negate-test test) test)) (pattern (expand-pattern negate? pattern))) @@ -530,11 +548,35 @@ USA. (define-for-tests assert-boolean= (simple-binary-assertion boolean=? #f)) (define-for-tests assert-boolean!= (simple-binary-assertion boolean=? #t)) + (define-for-tests assert-char= (simple-binary-assertion char=? #f)) (define-for-tests assert-char!= (simple-binary-assertion char=? #t)) +(define-for-tests assert-char< (simple-binary-assertion char (simple-binary-assertion char>? #f)) +(define-for-tests assert-char>= (simple-binary-assertion char>=? #f)) + +(define-for-tests assert-char-ci= (simple-binary-assertion char-ci=? #f)) +(define-for-tests assert-char-ci!= (simple-binary-assertion char-ci=? #t)) +(define-for-tests assert-char-ci< (simple-binary-assertion char-ci (simple-binary-assertion char-ci>? #f)) +(define-for-tests assert-char-ci>= (simple-binary-assertion char-ci>=? #f)) + (define-for-tests assert-string= (simple-binary-assertion string=? #f)) (define-for-tests assert-string!= (simple-binary-assertion string=? #t)) - +(define-for-tests assert-string< (simple-binary-assertion string (simple-binary-assertion string>? #f)) +(define-for-tests assert-string>= (simple-binary-assertion string>=? #f)) + +(define-for-tests assert-string-ci= (simple-binary-assertion string-ci=? #f)) +(define-for-tests assert-string-ci!= (simple-binary-assertion string-ci=? #t)) +(define-for-tests assert-string-ci< (simple-binary-assertion string-ci (simple-binary-assertion string-ci>? #f)) +(define-for-tests assert-string-ci>= (simple-binary-assertion string-ci>=? #f)) + (define-for-tests (member-assertion comparator negate?) (binary-assertion negate? (lambda (value expected)