95 lines
2.6 KiB
Scheme
95 lines
2.6 KiB
Scheme
|
;;;; buitins-test.scm -*- Scheme -*-
|
||
|
|
|
||
|
|
(import test)
|
||
|
|
(import (only (chicken format) format) (test-utils gloss))
|
||
|
|
|
||
|
|
(test-begin "Sys")
|
||
|
|
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(import (check-errors sys))
|
||
|
|
(import (only (chicken condition) condition-property-accessor))
|
||
|
|
|
||
|
|
;;
|
||
|
|
|
||
|
|
(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 "for failure"
|
||
|
|
(test-error (check-fixnum 'test 1.0))
|
||
|
|
(test-error (check-inexact 'test 1))
|
||
|
|
(test-error (check-integer 'test 0.1))
|
||
|
|
(test-error (check-number 'test 'x))
|
||
|
|
(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 3 '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-fixnum-in-range 'test 1 0 1))
|
||
|
|
(test-error (check-fixnum-in-range 'test #f 0 1))
|
||
|
|
(test-error (check-fixnum-in-range 'test -1 0 4))
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "for success"
|
||
|
|
(test-check check-fixnum 1)
|
||
|
|
(test-check check-inexact 1.0)
|
||
|
|
(test-check check-integer 1.0)
|
||
|
|
(test-check check-integer 1)
|
||
|
|
(test-check check-number 1.0)
|
||
|
|
(test-check check-number 1)
|
||
|
|
(test-check check-procedure current-input-port)
|
||
|
|
(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-fixnum-in-range 1 0 2)
|
||
|
|
(test-check check-fixnum-in-range 0 0 2)
|
||
|
|
)
|
||
|
|
|
||
|
|
(test-group "error message"
|
||
|
|
(test '(test "bad argument type - not a fixnum" (#f))
|
||
|
|
(capture-error (check-fixnum 'test #f)))
|
||
|
|
)
|
||
|
|
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(test-end "Sys")
|
||
|
|
|
||
|
|
(test-exit)
|