commit 5de1ee19ef3b3b7fcdb8cd5ca1d95bf72bbdb283
parent 0615124398db0f4c6dacdec9b39c5594580fc092
Author: Oto Havle <havleoto@gmail.com>
Date: Sun, 23 Oct 2011 10:16:35 +0200
Added tests of string and character features.
Diffstat:
4 files changed, 349 insertions(+), 2 deletions(-)
diff --git a/src/tests/characters.k b/src/tests/characters.k
@@ -0,0 +1,98 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of character features.
+;;
+
+;; 14.?.? char?
+
+($check-predicate (char?))
+($check-predicate (char? #\newline #\space #\0 #\A #\a #\~))
+
+($check-not-predicate (char? ""))
+($check-not-predicate (char? "a"))
+($check-not-predicate (char? 0))
+($check-not-predicate (char? #f))
+($check-not-predicate (char? ()))
+($check-not-predicate (char? #inert))
+
+;; XXX char=? char<? char<=? char>? char>=?
+
+($check-predicate (char=? #\A #\A))
+($check-not-predicate (char=? #\A #\B))
+($check-not-predicate (char=? #\a #\A))
+
+($check-predicate (char<? #\A #\B))
+($check-not-predicate (char<? #\A #\A))
+($check-not-predicate (char<? #\B #\A))
+
+($check-predicate (char<=? #\A #\A))
+($check-predicate (char<=? #\A #\B))
+($check-not-predicate (char<=? #\B #\A))
+
+($check-predicate (char>? #\B #\A))
+($check-not-predicate (char>? #\A #\A))
+($check-not-predicate (char>? #\A #\B))
+
+($check-predicate (char>=? #\A #\A))
+($check-predicate (char>=? #\B #\A))
+($check-not-predicate (char>=? #\A #\B))
+
+;; XXX char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?
+
+($check-predicate ($true-for-all-combinations? char-ci=? (#\A #\a) (#\A #\a)))
+($check-predicate ($false-for-all-combinations? char-ci=? (#\A #\a) (#\B #\b)))
+
+($check-predicate ($true-for-all-combinations? char-ci<? (#\A #\a) (#\B #\b)))
+($check-predicate ($false-for-all-combinations? char-ci<? (#\A #\a #\B #\b) (#\A #\a)))
+
+($check-predicate ($true-for-all-combinations? char-ci<=? (#\A #\a) (#\A #\a #\B #\b)))
+($check-predicate ($false-for-all-combinations? char-ci<=? (#\B #\b) (#\A #\a)))
+
+($check-predicate ($true-for-all-combinations? char-ci>? (#\B #\b) (#\A #\a)))
+($check-predicate ($false-for-all-combinations? char-ci>? (#\A #\a #\B #\b) (#\B #\b)))
+
+($check-predicate ($true-for-all-combinations? char-ci>=? (#\A #\a #\B #\b) (#\A #\a)))
+($check-predicate ($false-for-all-combinations? char-ci>=? (#\A #\a) (#\B #\b)))
+
+;; XXX char-alphabetic? char-numeric? char-whitespace?
+
+($check-predicate (char-alphabetic? #\a #\A #\b #\B #\k #\T #\y #\Y #\Z #\z))
+($check-predicate ($false-for-all? char-alphabetic? #\newline #\0 #\` #\@ #\{ #\[ #\~))
+
+($check-predicate (char-numeric? #\0 #\1 #\5 #\8 #\9))
+($check-predicate ($false-for-all? char-numeric? #\space #\/ #\: #\A))
+
+($check-predicate (char-whitespace? #\space #\newline))
+($check-predicate ($false-for-all? char-whitespace? #\0 #\a #\A #\:))
+; TODO ($check-predicate (char-whitespace? #\tab #\return ....))
+
+;; XXX char-upper-case? char-lower-case?
+
+($check-predicate (char-upper-case? #\A #\B #\R #\Y #\Z))
+($check-predicate ($false-for-all? char-upper-case? #\0 #\a #\z #\' #\@ #\{ #\[ #\~))
+($check-predicate (char-lower-case? #\a #\b #\j #\y #\z))
+($check-predicate ($false-for-all? char-lower-case? #\0 #\A #\Z #\' #\@ #\{ #\[ #\~))
+
+;; XXX char-upcase char-downcase
+
+($check equal? (char-upcase #\a) #\A)
+($check equal? (char-upcase #\z) #\Z)
+($check equal? (char-upcase #\R) #\R)
+($check equal? (char-upcase #\2) #\2)
+
+($check equal? (char-downcase #\A) #\a)
+($check equal? (char-downcase #\Z) #\z)
+($check equal? (char-downcase #\r) #\r)
+($check equal? (char-downcase #\9) #\9)
+
+;; XXX char->integer integer->char
+
+($check equal? (char->integer #\space) #x20)
+($check equal? (char->integer #\0) #x30)
+($check equal? (char->integer #\A) #x41)
+($check equal? (char->integer #\a) #x61)
+
+($check equal? (integer->char #x20) #\space)
+($check equal? (integer->char #x30) #\0)
+($check equal? (integer->char #x41) #\A)
+($check equal? (integer->char #x61) #\a)
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -0,0 +1,197 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of string features.
+;;
+
+;; XXX immutability of string constants
+
+($check-predicate (immutable-string? ""))
+($check-predicate (immutable-string? "abcd"))
+
+;; 13.?.? string?
+
+($check-predicate (string?))
+($check-predicate (string? "" "abcdef"))
+
+($check-not-predicate (string? #\a))
+($check-not-predicate (string? 0))
+($check-not-predicate (string? #f))
+($check-not-predicate (string? ()))
+($check-not-predicate (string? #inert))
+
+;; XXX string=? string<? string<=? string>? string>=?
+;; XXX string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=?
+
+($check-predicate (string=? "" ""))
+($check-predicate (string=? "abcd" "abcd"))
+($check-not-predicate (string=? "abcd" ""))
+($check-not-predicate (string=? "abcd" "ABCD"))
+($check-not-predicate (string=? "aa" "aaa"))
+
+($check-predicate (string<? "" "a"))
+($check-predicate (string<? "a" "b"))
+($check-predicate (string<? "a" "ab"))
+($check-predicate (string<? "A" "a"))
+($check-not-predicate (string<? "a" ""))
+($check-not-predicate (string<? "aaa" "a"))
+($check-not-predicate (string<? "b" "a"))
+
+($check-predicate ($true-for-all-combinations? string<=?
+ ("" "A") ("a" "A" "ab")))
+
+($check-predicate ($true-for-all-combinations? string>?
+ ("b" "c") ("" "a")))
+
+($check-predicate ($true-for-all-combinations? string>=?
+ ("b" "c") ("" "a" "b")))
+
+($check-predicate (string-ci=? "" ""))
+($check-predicate (string-ci=? "abcd" "AbCd"))
+($check-not-predicate (string-ci=? "abcd" ""))
+($check-not-predicate (string=? "aa" "AAA"))
+
+($check-predicate ($true-for-all-combinations? string-ci<?
+ ("" "a" "A") ("ab" "AB" "b" "B")))
+($check-predicate ($false-for-all-combinations? string-ci<?
+ ("b" "B") ("" "a" "A" "aa" "b" "B" "ab" "aB" "Ab" "AB")))
+
+($check-predicate ($true-for-all-combinations? string-ci<=?
+ ("" "A" "a") ("a" "A" "ab")))
+
+($check-predicate ($true-for-all-combinations? string-ci>?
+ ("b" "B" "c" "C") ("" "a" "A")))
+
+($check-predicate ($true-for-all-combinations? string-ci>=?
+ ("b" "B" "c" "C") ("" "a" "A" "b" "B")))
+
+;; XXX make-string
+
+($check-predicate (string? (make-string 0)))
+($check-predicate (string? (make-string 1)))
+($check equal? (make-string 0) "")
+($check equal? (make-string 0 #\a) "")
+($check equal? (make-string 3 #\a) "aaa")
+($check equal? (string-length (make-string 1000)) 1000)
+($check equal? (string-length (make-string 1000 #\a)) 1000)
+($check-error (make-string -1))
+($check-error (make-string -1 #\a))
+
+;; XXX string
+
+($check-predicate (string? (string)))
+($check-predicate (string? (string #\a #\b #\c)))
+($check equal? (string) "")
+($check equal? (string #\a #\b #\c) "abc")
+($check-not-predicate ($let ((x (string)) (y (string))) (eq? x y)))
+($check-not-predicate ($let ((x (string #\a)) (y (string #\a))) (eq? x y)))
+
+;; XXX string-length
+
+($check equal? (string-length "") 0)
+($check equal? (string-length "0123456789") 10)
+
+;; XXX string-ref
+
+($check equal? (string-ref "0123456789" 0) #\0)
+($check equal? (string-ref "0123456789" 9) #\9)
+($check-error (string-ref "0123456789" 10))
+($check-error (string-ref "0123456789" -1))
+($check-error (string-ref "" 0))
+
+;; XXX string-set!
+
+($check equal? ($let ((s (make-string 2 #\a))) (string-set! s 0 #\b) s) "ba")
+($check equal? ($let ((s (make-string 2 #\a))) (string-set! s 1 #\b) s) "ab")
+($check-error (string-set! (make-string 2) -1 #\a))
+($check-error (string-set! (make-string 2) 3 #\a))
+($check-error (string-set! "const" 3 #\a))
+
+;; XXX string-fill!
+
+($check equal? ($let ((s (make-string 0))) (string-fill! s #\b) s) "")
+($check equal? ($let ((s (make-string 3 #\a))) (string-fill! s #\b) s) "bbb")
+($check-error (string-fille "const" #\x))
+
+;; XXX substring
+
+($check equal? (substring "" 0 0) "")
+($check equal? (substring "abcdef" 0 0) "")
+($check equal? (substring "abcdef" 3 3) "")
+($check equal? (substring "abcdef" 5 5) "")
+($check equal? (substring "abcdef" 6 6) "")
+($check equal? (substring "abcdef" 2 5) "cde")
+($check equal? (substring "abcdef" 0 6) "abcdef")
+($check-error (substring "abcdef" -1 0))
+($check-error (substring "abcdef" 10 11))
+($check-error (substring "abcdef" 3 10))
+($check-error (substring "abcdef" 4 2))
+
+($check-not-predicate
+ ($let* ((p "abc") (q (substring p 0 3)))
+ (eq? p q)))
+
+($check-not-predicate (mutable-string? (substring "abc" 0 0)))
+($check-not-predicate (mutable-string? (substring "abc" 0 1)))
+
+;; XXX string-append
+
+($check equal? (string-append) "")
+($check equal? (string-append "") "")
+($check equal? (string-append "a") "a")
+($check equal? (string-append "a" "b") "ab")
+($check equal? (string-append "a" "b" "c") "abc")
+
+($check-not-predicate
+ ($let* ((p "abc") (q (string-append p)))
+ (eq? p q)))
+
+($check-predicate (mutable-string? (string-append)))
+($check-predicate (mutable-string? (string-append "a" "b")))
+
+;; XXX string-copy
+
+($check equal? (string-copy "") "")
+($check equal? (string-copy "abcd") "abcd")
+
+($check-not-predicate
+ ($let* ((p "abc") (q (string-copy p)))
+ (eq? p q)))
+
+($check-predicate (mutable-string? (string-copy "")))
+($check-predicate (mutable-string? (string-copy "abc")))
+
+;; XXX string->immutable-string
+
+($check equal? (string->immutable-string "") "")
+($check equal? (string->immutable-string "abcd") "abcd")
+
+($check-not-predicate
+ ($let* ((p "abc") (q (string-copy p)))
+ (eq? p q)))
+
+($check-predicate (immutable-string? (string->immutable-string "")))
+($check-predicate (immutable-string? (string->immutable-string "abc")))
+($check-predicate (immutable-string? (string->immutable-string (make-string 10))))
+
+;; XXX string->list
+
+($check equal? (string->list "") ())
+($check equal? (string->list "abc") (list #\a #\b #\c))
+
+;; XXX list->string
+
+($check equal? (list->string ()) "")
+($check equal? (list->string (list #\a #\b #\c)) "abc")
+($check-not-predicate ($let ((x (list->string ())) (y (list->string ()))) (eq? x y)))
+
+($check-not-predicate
+ ($let*
+ ( (cs (list #\a #\b #\c))
+ (x (list->string cs))
+ (y (list->string cs)))
+ (eq? x y)))
+
+($check-predicate (mutable-string? (list->string ())))
+($check-predicate (mutable-string? (list->string (list #\a #\b))))
+
+($check-error (list->string (($vau (x) #ignore x) (#\a #0=(#\a . #0#)))))
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -15,6 +15,8 @@
(load "tests/environment-mutation.k")
(load "tests/combiners.k")
(load "tests/numbers.k")
+(load "tests/strings.k")
+(load "tests/characters.k")
(load "tests/ports.k")
(check-report)
diff --git a/src/tests/test-helpers.k b/src/tests/test-helpers.k
@@ -24,4 +24,55 @@
(apply divert #f))))))))
($define! immutable-pair?
- ($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj)))))
-\ No newline at end of file
+ ($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj)))))
+
+($define! mutable-string?
+ ($lambda (obj)
+ ($and?
+ (string? obj)
+ (guard-dynamic-extent
+ ()
+ ($lambda () (string-fill! obj #\x) #t)
+ (list
+ (list error-continuation
+ ($lambda (#ignore divert) (apply divert #f))))))))
+
+($define! immutable-string?
+ ($lambda (obj) ($and? (string? obj) (not? (mutable-string? obj)))))
+
+;; ($false-for-all? P XS) evaluates to #t iff (P X) evaluates
+;; to #f for all members X of the list XS.
+;;
+($define! $false-for-all?
+ ($vau (p . xs) denv
+ (apply and?
+ (map ($lambda (x) (not? (eval (list p x) denv))) xs))))
+
+;; (cartesian-product XS YS) returns list of all pairs (X Y),
+;; where X is a member of the list XS and Y is a member of list YS.
+;;
+;; for example
+;; (cartesian-product (1 2) (3 4)) ===> ((1 3) (1 4) (2 3) (2 4))
+;;
+($define! cartesian-product
+ ($lambda (xs ys)
+ (apply append
+ (map ($lambda (x) (map ($lambda (y) (list x y)) ys)) xs))))
+
+;; ($true-for-all-combinations? BIN (X1 X2...) (Y1 Y1...))
+;; evaluates to #t, iff (BIN X Y) evaluates to #t for all X and Y.
+;;
+($define! $true-for-all-combinations?
+ ($vau (p xs ys) denv
+ (apply and?
+ (map ($lambda ((x y)) (eval (list p x y) denv))
+ (cartesian-product xs ys)))))
+
+;; ($false-for-all-combinations? BIN (X1 X2...) (Y1 Y2...))
+;; evaluates to #t, iff (BIN X Y) evaluates to #f for all X and Y.
+;;
+($define! $false-for-all-combinations?
+ ($vau (p xs ys) denv
+ (apply and?
+ (map ($lambda ((x y)) (not? (eval (list p x y) denv)))
+ (cartesian-product xs ys)))))
