;;;; 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)