Add a bunch of unit tests swiped from Larceny.

diff --git a/tests/runtime/test-char.scm b/tests/runtime/test-char.scm
index 43c72ccb83afa937854c5b2ba2ead45ebc5386ca..7ec3a112b4d4727ac87ac2c16f0eb59cfcd9858b 100644 (file)
--- 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))
+\f
+;;;; 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-true  (char-ci<? #\a #\Z))
+    (assert-false (char-ci<? #\Z #\a))
+    (assert-true  (char-ci<=? #\z #\Z))
+    (assert-true  (char-ci<=? #\Z #\z))
+    (assert-true  (char-ci<=? #\a #\Z))
+    (assert-false (char-ci<=? #\Z #\a))
+    (assert-false (char-ci=? #\z #\a))
+    (assert-true  (char-ci=? #\z #\Z))
+    (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))))
+\f
+(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-true  (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-true  (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)))))
+\f
+(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)))
+\f
+(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))))))))
 \f
 (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 66586efbd9189024e993bb425db400b8ff4bd5e1..597def90375e97fafe63689a779c468e174f843c 100644 (file)
--- a/tests/runtime/test-string.scm
+++ b/tests/runtime/test-string.scm
@@ -71,7 +71,7 @@ USA.
    "D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF"
    "E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF"
    "F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF"))
-
+\f
 (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))))))))
+\f
+;;;; 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 c894abcc651db15ef141c6cd438137ce057da721..d1c4dfee6a30b9530f46e3905607ae9d7ba90036 100644 (file)
--- 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>=? '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 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>=? 'string>=)
+(define-comparator string>? 'string>)
+
+(define-comparator string-ci<=? 'string-ci<=)
+(define-comparator string-ci<? 'string-ci<)
+(define-comparator string-ci=? 'string-ci=)
+(define-comparator string-ci>=? 'string-ci>=)
+(define-comparator string-ci>? 'string-ci>)
+\f
 (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<? #f))
+(define-for-tests assert-char<= (simple-binary-assertion char<=? #f))
+(define-for-tests assert-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<? #f))
+(define-for-tests assert-char-ci<= (simple-binary-assertion char-ci<=? #f))
+(define-for-tests assert-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<? #f))
+(define-for-tests assert-string<= (simple-binary-assertion string<=? #f))
+(define-for-tests assert-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<? #f))
+(define-for-tests assert-string-ci<= (simple-binary-assertion string-ci<=? #f))
+(define-for-tests assert-string-ci> (simple-binary-assertion string-ci>? #f))
+(define-for-tests assert-string-ci>= (simple-binary-assertion string-ci>=? #f))
+\f
 (define-for-tests (member-assertion comparator negate?)
   (binary-assertion negate?
                    (lambda (value expected)