201 lines
7 KiB
Scheme
201 lines
7 KiB
Scheme
|
;;;; check-errors-test.scm -*- Scheme -*-
|
||
|
|
;;;; Kon Lovett, Jul '18
|
||
|
|
|
||
|
|
(import test)
|
||
|
|
(import (only (chicken format) format) (test-utils gloss))
|
||
|
|
|
||
|
|
(test-begin "Check Errors (strict-types)")
|
||
|
|
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(import type-checks-basic)
|
||
|
|
(import type-checks-atoms)
|
||
|
|
(import type-checks-structured)
|
||
|
|
(import (type-checks-numbers bignum))
|
||
|
|
(import (type-checks-numbers cplxnum))
|
||
|
|
(import (type-checks-numbers fixnum))
|
||
|
|
(import (type-checks-numbers flonum))
|
||
|
|
(import (type-checks-numbers integer))
|
||
|
|
(import (type-checks-numbers interval))
|
||
|
|
(import (type-checks-numbers number))
|
||
|
|
(import (type-checks-numbers ratnum))
|
||
|
|
(import (type-checks-numbers scheme))
|
||
|
|
(import srfi-4-checks)
|
||
|
|
|
||
|
|
(import type-errors srfi-4-errors)
|
||
|
|
|
||
|
|
(import (only (chicken condition) condition-property-accessor))
|
||
|
|
(import srfi-4)
|
||
|
|
|
||
|
|
;;
|
||
|
|
|
||
|
|
(define-syntax test-check
|
||
|
|
(syntax-rules ()
|
||
|
|
((test-check ?check ?expt ?arg0 ...)
|
||
|
|
(test (symbol->string '?check)
|
||
|
|
?expt (?check 'test ?expt ?arg0 ...)) ) ) )
|
||
|
|
|
||
|
|
(define-syntax capture-error
|
||
|
|
(syntax-rules ()
|
||
|
|
((capture-error ?body ...)
|
||
|
|
(handle-exceptions exp
|
||
|
|
(map (lambda (p) ((condition-property-accessor 'exn p) exp))
|
||
|
|
'(location message arguments))
|
||
|
|
?body ... ) ) ) )
|
||
|
|
|
||
|
|
;; Basic
|
||
|
|
|
||
|
|
(cond-expand
|
||
|
|
(compiling
|
||
|
|
(gloss)
|
||
|
|
(gloss "!-------------------")
|
||
|
|
(gloss "! EXPECT TYPE ERRORS")
|
||
|
|
(gloss "! (runtime tests)")
|
||
|
|
(gloss "!-------------------") )
|
||
|
|
(else) )
|
||
|
|
|
||
|
|
(test-group "define-check+error-type"
|
||
|
|
(define (foo? obj) #t)
|
||
|
|
(define-check+error-type foo)
|
||
|
|
(test-assert error-foo)
|
||
|
|
(test-assert check-foo)
|
||
|
|
(define-check+error-type foo1 foo?)
|
||
|
|
(test-assert error-foo1)
|
||
|
|
(test-assert check-foo1)
|
||
|
|
(define-check+error-type foo2 foo? "foodie")
|
||
|
|
(test-assert error-foo2)
|
||
|
|
(test-assert check-foo2)
|
||
|
|
)
|
||
|
|
|
||
|
|
(define-syntax unbound-value
|
||
|
|
(syntax-rules ()
|
||
|
|
((unbound-value)
|
||
|
|
(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )
|
||
|
|
|
||
|
|
(test-group "for failure"
|
||
|
|
(test-error (check-defined-value (void))) ;too few arguments
|
||
|
|
(test-error (check-bound-value (unbound-value))) ;too few arguments
|
||
|
|
(test-error (check-defined-value 'test (void))) ;cannot check type
|
||
|
|
(test-error (check-bound-value 'test (unbound-value))) ;cannot check type
|
||
|
|
(test-error (check-fixnum 'test 1.0))
|
||
|
|
(test-error (check-positive-fixnum 'test 0))
|
||
|
|
(test-error (check-negative-fixnum 'test 0))
|
||
|
|
(test-error (check-natural-fixnum 'test -1))
|
||
|
|
(test-error (check-non-positive-fixnum 'test 1))
|
||
|
|
(test-error (check-flonum 'test 1))
|
||
|
|
(test-error (check-integer 'test 0.1))
|
||
|
|
(test-error (check-positive-integer 'test 0.0))
|
||
|
|
(test-error (check-natural-integer 'test -1.0))
|
||
|
|
(test-error (check-number 'test 'x))
|
||
|
|
(test-error (check-positive-number 'test -0.1))
|
||
|
|
(test-error (check-natural-number 'test -0.1))
|
||
|
|
(test-error (check-procedure 'test 'x))
|
||
|
|
(test-error (check-input-port 'test 'x))
|
||
|
|
(test-error (check-output-port 'test 'x))
|
||
|
|
(test-error (check-list 'test 'x))
|
||
|
|
(test-error (check-pair 'test 'x))
|
||
|
|
(test-error (check-vector 'test 'x))
|
||
|
|
(test-error (check-structure 'test 'x))
|
||
|
|
(test-error (check-symbol 'test 1))
|
||
|
|
(test-error (check-keyword 'test 'x))
|
||
|
|
(test-error (check-string 'test 'x))
|
||
|
|
(test-error (check-char 'test 'x))
|
||
|
|
(test-error (check-boolean 'test 'x))
|
||
|
|
(test-error (check-alist 'test 'x))
|
||
|
|
(test-error (check-alist 'test '(23)))
|
||
|
|
(test-error (check-alist 'test '((a . 1) ())))
|
||
|
|
(test-error (check-minimum-argument-count 'test 0 1))
|
||
|
|
(test-error (check-argument-count 'test 1 0))
|
||
|
|
(test-error (check-open-interval 'test 1.1 1.1 1.2))
|
||
|
|
(test-error (check-open-interval 'test 1.2 1.1 1.2))
|
||
|
|
(test-error (check-closed-interval 'test 1.0 1.1 1.2))
|
||
|
|
(test-error (check-closed-interval 'test 1.3 1.1 1.2))
|
||
|
|
(test-error (check-half-open-interval 'test 1.1 1.1 1.2))
|
||
|
|
(test-error (check-half-open-interval 'test 1.3 1.1 1.2))
|
||
|
|
(test-error (check-half-closed-interval 'test 1.2 1.1 1.2))
|
||
|
|
(test-error (check-half-closed-interval 'test 1.3 1.1 1.2))
|
||
|
|
(test-error (check-range 'test 0 -1))
|
||
|
|
(test-error (check-u16vector 'test 23))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "for success"
|
||
|
|
(test-check check-defined-value 1)
|
||
|
|
(test-check check-bound-value 1)
|
||
|
|
(test-check check-fixnum 1)
|
||
|
|
(test-check check-positive-fixnum 1)
|
||
|
|
(test-check check-negative-fixnum -1)
|
||
|
|
(test-check check-natural-fixnum 0)
|
||
|
|
(test-check check-non-positive-fixnum 0)
|
||
|
|
(test-check check-flonum 1.0)
|
||
|
|
(test-check check-integer 1.0)
|
||
|
|
(test-check check-integer 1)
|
||
|
|
(test-check check-positive-integer 1.0)
|
||
|
|
(test-check check-positive-integer 1)
|
||
|
|
(test-check check-natural-integer 0.0)
|
||
|
|
(test-check check-natural-integer 0)
|
||
|
|
(test-check check-number 1.0)
|
||
|
|
(test-check check-number 1)
|
||
|
|
(test-check check-positive-number 1.0)
|
||
|
|
(test-check check-positive-number 1)
|
||
|
|
(test-check check-natural-number 0.0)
|
||
|
|
(test-check check-natural-number 0)
|
||
|
|
(test-check check-procedure check-procedure)
|
||
|
|
(test-check check-input-port (current-input-port))
|
||
|
|
(test-check check-output-port (current-output-port))
|
||
|
|
(test-check check-list '(x))
|
||
|
|
(test-check check-pair '(x . y))
|
||
|
|
(test-check check-vector '#(x))
|
||
|
|
(test-check check-structure (##sys#make-structure 'x) 'x)
|
||
|
|
(test-check check-symbol 'x)
|
||
|
|
(test-check check-keyword #:x)
|
||
|
|
(test-check check-string "x")
|
||
|
|
(test-check check-char #\x)
|
||
|
|
(test-check check-boolean #t)
|
||
|
|
(test-check check-alist '())
|
||
|
|
(test-check check-alist '((a . 1)))
|
||
|
|
(test-check check-alist '((a . 1) (b . 2)))
|
||
|
|
(test-check check-minimum-argument-count 1 1)
|
||
|
|
(test-check check-argument-count 1 1)
|
||
|
|
(test-check check-open-interval 1.11 1.1 1.2)
|
||
|
|
(test-check check-closed-interval 1.1 1.1 1.2)
|
||
|
|
(test-check check-half-open-interval 1.11 1.1 1.2)
|
||
|
|
(test-check check-half-closed-interval 1.11 1.1 1.2)
|
||
|
|
(test-check check-range 0 1)
|
||
|
|
(test-check check-s8vector (make-s8vector 2 0))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "error message"
|
||
|
|
(test '(test "bad argument type - not a fixnum" (#f))
|
||
|
|
(capture-error (check-fixnum 'test #f)))
|
||
|
|
(test '(test "bad `num' argument type - not a fixnum" (#f))
|
||
|
|
(capture-error (check-fixnum 'test #f 'num)))
|
||
|
|
(test '(test "bad argument must be in (1.1 1.2)" (1.1))
|
||
|
|
(capture-error (check-open-interval 'test 1.1 1.1 1.2)))
|
||
|
|
(test '(test "bad argument must be in [1.1 1.2]" (1.0))
|
||
|
|
(capture-error (check-closed-interval 'test 1.0 1.1 1.2)))
|
||
|
|
(test '(test "bad argument must be in (1.1 1.2]" (1.1))
|
||
|
|
(capture-error (check-half-open-interval 'test 1.1 1.1 1.2)))
|
||
|
|
(test '(test "bad argument must be in [1.1 1.2)" (1.2))
|
||
|
|
(capture-error (check-half-closed-interval 'test 1.2 1.1 1.2)))
|
||
|
|
(test '(test "bad argument" (0 -1))
|
||
|
|
(capture-error (check-range 'test 0 -1)))
|
||
|
|
(test '(test "bad argument count - received 3 but expected 2" ())
|
||
|
|
(capture-error (check-argument-count 'test 3 2)))
|
||
|
|
(test '(test "too few arguments - received 1 but expected 2" ())
|
||
|
|
(capture-error (check-minimum-argument-count 'test 1 2)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "define-check-structure"
|
||
|
|
(define-record-type <foo-t> (make-foo-t x) foo-t? (x foo-t-x))
|
||
|
|
(define-check-structure <foo-t>)
|
||
|
|
(test-assert check-<foo-t>)
|
||
|
|
(test-error (check-<foo-t> 'test #f))
|
||
|
|
(test-assert (check-<foo-t> 'test (##sys#make-structure <foo-t>)))
|
||
|
|
)
|
||
|
|
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(test-end "Check Errors (strict-types)")
|
||
|
|
|
||
|
|
(test-exit)
|