~ chicken-core (chicken-5) 23c684ef311f19471f4a5ce6e7de83c9cdf51353
commit 23c684ef311f19471f4a5ce6e7de83c9cdf51353
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Jun 30 22:35:28 2016 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Jul 9 16:26:41 2016 +0200
Add scrutinizer test suite
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/distribution/manifest b/distribution/manifest
index 663ca0cf..95331178 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -158,6 +158,7 @@ tests/test-finalizers.scm
tests/test-finalizers-2.scm
tests/test-find-files.scm
tests/module-tests-compiled.scm
+tests/scrutinizer-tests.scm
tests/scrutiny-tests.scm
tests/scrutiny-tests-strict.scm
tests/typematch-tests.scm
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 3cd6dc82..07ec3b6d 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -55,6 +55,7 @@ a.out
if errorlevel 1 exit /b 1
echo ======================================== scrutiny tests ...
+%compile% scrutinizer-tests.scm -analyze-only
%compile% typematch-tests.scm -specialize -w
if errorlevel 1 exit /b 1
a.out
diff --git a/tests/runtests.sh b/tests/runtests.sh
index dc9ca87f..e108c3c7 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -114,6 +114,7 @@ $compile null.scm -profile -profile-name TEST.profile
$CHICKEN_PROFILE TEST.profile
echo "======================================== scrutiny tests ..."
+$compile scrutinizer-tests.scm -analyze-only
$compile typematch-tests.scm -specialize -no-warnings
./a.out
diff --git a/tests/scrutinizer-tests.scm b/tests/scrutinizer-tests.scm
new file mode 100644
index 00000000..ed313a49
--- /dev/null
+++ b/tests/scrutinizer-tests.scm
@@ -0,0 +1,294 @@
+;;; scrutinizer unit tests
+
+(import-for-syntax
+ (chicken format)
+ (chicken compiler scrutinizer))
+
+(define-for-syntax success #t)
+
+(define-syntax test
+ (er-macro-transformer
+ (lambda (expr rename _)
+ (define pass
+ (let loop ((e (cadr expr)))
+ (case (car e)
+ ;; invert test
+ ((not) (not (loop (cadr e))))
+ ;; subtype or type equality
+ ((<=) (and (type<=? (cadr e) (caddr e))
+ (match-types (caddr e) (cadr e))))
+ ;; subtype
+ ((<) (and (type<=? (cadr e) (caddr e))
+ (match-types (caddr e) (cadr e))
+ (not (type<=? (caddr e) (cadr e)))))
+ ;; type equality
+ ((=) (and (type<=? (cadr e) (caddr e))
+ (type<=? (caddr e) (cadr e))))
+ ;; fuzzy match (both directions)
+ ((?) (and (match-types (cadr e) (caddr e))
+ (match-types (caddr e) (cadr e))))
+ ;; fuzzy non-match (both directions)
+ ((!) (and (not (match-types (cadr e) (caddr e)))
+ (not (match-types (caddr e) (cadr e)))))
+ ;; strict non-match (both directions)
+ ((><) (and (not (type<=? (cadr e) (caddr e)))
+ (not (type<=? (caddr e) (cadr e)))))
+ ;; A refined with B gives C
+ ((~>) (equal? (refine-types (cadr e) (caddr e))
+ (cadddr e))))))
+ (printf "[~a] ~a~n" (if pass " OK " "FAIL") (cadr expr))
+ (when (not pass) (set! success #f))
+ (rename '(void)))))
+
+;;; wildcards
+
+(test (= * *))
+(test (< x *))
+
+;;; structs
+
+(test (= (struct x) (struct x)))
+(test (! (struct x) (struct y)))
+
+;;; undefined
+
+(test (= undefined undefined))
+(test (< undefined *))
+
+;;; noreturn
+
+(test (= noreturn noreturn))
+(test (< noreturn *))
+(test (! undefined noreturn))
+
+;;; booleans
+
+(test (= boolean boolean))
+(test (< true boolean))
+(test (< false boolean))
+(test (= (or true false) boolean))
+
+;;; numbers
+
+(test (= number number))
+(test (< fixnum number))
+(test (< float number))
+(test (< bignum number))
+(test (< ratnum number))
+(test (< cplxnum number))
+(test (< integer number))
+(test (= (or fixnum float bignum ratnum cplxnum) number))
+
+(test (= integer integer))
+(test (< fixnum integer))
+(test (< bignum integer))
+(test (not (<= float integer)))
+(test (not (<= ratnum integer)))
+(test (not (<= cplxnum integer)))
+(test (= (or fixnum bignum) integer))
+
+;;; vectors
+
+(test (= vector vector))
+(test (= vector (vector-of *)))
+(test (< (vector-of x) (vector-of *)))
+
+(test (= (vector *) (vector *)))
+(test (= (vector x) (vector x)))
+(test (< (vector x) (vector *)))
+(test (< (vector *) (vector-of *)))
+(test (< (vector x) (vector-of *)))
+(test (< (vector x) (vector-of x)))
+
+(test (? (vector *) (vector-of x)))
+(test (>< (vector *) (vector-of x)))
+
+(test (>< (vector *) (vector * *)))
+(test (>< (vector x) (vector * *)))
+(test (>< (vector *) (vector x x)))
+(test (>< (vector x) (vector x x)))
+
+;;; pairs
+
+(test (= pair pair))
+(test (= pair (pair * *)))
+(test (< (pair x *) pair))
+(test (< (pair * x) pair))
+(test (< (pair x x) pair))
+
+;;; lists
+
+(test (= null null))
+(test (? null list))
+(test (? null (list-of x)))
+(test (! null (list x)))
+(test (! null pair))
+
+(test (= list list))
+(test (= list (list-of *)))
+(test (< (list-of x) (list-of *)))
+
+(test (= (list *) (list *)))
+(test (= (list x) (list x)))
+(test (< (list x) (list *)))
+(test (< (list *) (list-of *)))
+(test (< (list x) (list-of *)))
+(test (< (list x) (list-of x)))
+
+(test (? (list *) (list-of x)))
+(test (>< (list *) (list-of x)))
+
+(test (>< (list *) (list * *)))
+(test (>< (list x) (list * *)))
+(test (>< (list *) (list x x)))
+(test (>< (list x) (list x x)))
+
+(test (? (pair * *) (list-of *)))
+(test (? (pair x *) (list-of *)))
+(test (! (pair * x) (list-of *)))
+(test (! (pair x x) (list-of *)))
+(test (? (pair * *) (list-of x)))
+(test (? (pair x *) (list-of x)))
+(test (! (pair * x) (list-of x)))
+(test (! (pair x x) (list-of x)))
+
+;;; ports
+
+(test (= port port))
+(test (= (refine (input) port) (refine (input) port)))
+(test (= (refine (input output) port) (refine (input output) port)))
+(test (= (refine (output) port) (refine (output) port)))
+
+(test (< (refine (input) port) port))
+(test (< (refine (input output) port) port))
+(test (< (refine (output) port) port))
+(test (< (refine (input output) port) (refine (input) port)))
+(test (< (refine (input output) port) (refine (output) port)))
+(test (? (refine (input) port) (refine (output) port)))
+
+;;; unions
+
+(test (< x (or x y)))
+(test (< y (or x y)))
+
+(test (= (or x number) (or x number)))
+(test (< (or x number) (or x number string)))
+(test (>< (or x number) (or y string)))
+
+;;; negative types
+
+(test (< (not x) *))
+(test (! (not x) x))
+
+(test (< x (not y)))
+(test (< x (not (not x))))
+(test (< x (not (not (not y)))))
+
+(test (< x (or (not x) x)))
+(test (< x (or (not x) (not y))))
+
+(test (! x (not x)))
+(test (! x (not (not y))))
+(test (! x (not (not (not x)))))
+(test (! x (not (or x y))))
+(test (! x (or (not x) y)))
+(test (! x (not (not (not x)))))
+
+(test (? (not x) (not y)))
+(test (? (not x) (or x y)))
+(test (? (not x) (or (not x) x)))
+(test (? (not x) (or (not y) x)))
+(test (? (not x) (or (not x) (not y))))
+(test (>< (not x) (not y)))
+(test (>< (not x) (or x y)))
+(test (>< (not x) (or (not x) x)))
+(test (>< (not x) (or (not y) x)))
+(test (>< (not x) (or (not x) (not y))))
+
+(test (< (or (not x) y) (not x)))
+(test (< (not (or x y)) (not x)))
+
+;;; negative wildcards (a bit weird...)
+
+(test (< (not *) *))
+(test (< (not (not *)) *))
+(test (< (not (not (not *))) *))
+
+(test (! (not *) x))
+(test (< (not *) (not x)))
+
+;;; procedures
+
+(test (= (procedure ()) (procedure ())))
+(test (= (procedure (x)) (procedure (x))))
+(test (= (procedure (#!rest x)) (procedure (#!rest x))))
+
+(test (= (procedure ()) (procedure ())))
+(test (= (procedure () x) (procedure () x)))
+;; FIXME
+;(test (= (procedure () . x) (procedure () . x)))
+
+(test (>< (procedure (x)) (procedure (y))))
+(test (>< (procedure () x) (procedure () y)))
+
+(test (? (procedure (x)) (procedure (*))))
+(test (? (procedure () x) (procedure () *)))
+
+(test (! (procedure (x)) (procedure ())))
+(test (! (procedure (x)) (procedure (x y))))
+(test (? (procedure (x)) (procedure (x #!rest y))))
+
+(test (! (procedure () x) (procedure ())))
+(test (! (procedure () x) (procedure () x y)))
+;; s.a.
+;(test (? (procedure () x) (procedure () x . y)))
+
+;;; refinements
+
+(test (= (refine (a) x) (refine (a) x)))
+(test (< (refine (a b) x) (refine (a) x)))
+(test (= (refine (a b) x) (refine (a b) x)))
+
+(test (? (refine (a) x) (refine (b) x)))
+(test (>< (refine (a) x) (refine (b) x)))
+
+(test (~> x y y))
+(test (~> x (or x y) x))
+(test (~> (or x y) x x))
+(test (~> (or x y) (or y z) y))
+
+(test (~> * (refine (a) x) (refine (a) x)))
+(test (~> (refine (a) *) x (refine (a) x)))
+(test (~> x (refine (a) *) (refine (a) x)))
+(test (~> (refine (a) x) * (refine (a) x)))
+(test (~> (refine (a) x) (refine (b) *) (refine (a b) x)))
+(test (~> (refine (a) x) (refine (b) *) (refine (a b) x)))
+
+(test (~> (refine (a) x) y y))
+(test (~> x (refine (a) y) (refine (a) y)))
+(test (~> (refine (a) x) (refine (b) y) (refine (b) y)))
+
+(test (~> (list fixnum number)
+ (list number fixnum)
+ (list fixnum fixnum)))
+(test (~> (vector x)
+ (vector (refine (a) x))
+ (vector (refine (a) x))))
+(test (~> (list x)
+ (list (refine (a) x))
+ (list (refine (a) x))))
+(test (~> (list x (list x))
+ (list (refine (a) *) (list (refine (b) *)))
+ (list (refine (a) x) (list (refine (b) x)))))
+(test (~> (list * (list *))
+ (list (refine (a) x) (list (refine (b) x)))
+ (list (refine (a) x) (list (refine (b) x)))))
+(test (~> (list (refine (a) x))
+ (refine (a) (list (refine (b) x)))
+ (refine (a) (list (refine (a b) x)))))
+(test (~> (list (refine (a) x))
+ (refine (a) (list (refine (b) y)))
+ (refine (a) (list (refine (b) y)))))
+
+(begin-for-syntax
+ (when (not success) (exit 1)))
Trap