(module assert-base mzscheme
(provide (all-defined))
(define-struct assertion-info (name value) (current-inspector))
(define (make-assertion-name name)
(make-assertion-info 'name name))
(define (make-assertion-params params)
(make-assertion-info 'params params))
(define (make-assertion-location loc)
(make-assertion-info 'location loc))
(define (make-assertion-expression msg)
(make-assertion-info 'expression msg))
(define (make-assertion-message msg)
(make-assertion-info 'message msg))
(define (assertion-name? info)
(eq? (assertion-info-name info) 'name))
(define (assertion-params? info)
(eq? (assertion-info-name info) 'params))
(define (assertion-location? info)
(eq? (assertion-info-name info) 'location))
(define (assertion-expression? info)
(eq? (assertion-info-name info) 'expression))
(define (assertion-message? info)
(eq? (assertion-info-name info) 'message))
(define assertion-stack
(make-parameter
(list)
(lambda (v)
(if (list? v)
v
(raise-type-error 'assertion-stack "list" v)))))
(define (with-assertion-info* info thunk)
(parameterize
((assertion-stack (append info (assertion-stack))))
(thunk)))
(define-syntax with-assertion-info
(syntax-rules ()
((_ ((name val) ...) body ...)
(with-assertion-info*
(list (make-assertion-info name val) ...)
(lambda ()
body ...)))))
(define-struct (exn:test exn) ())
(define-struct (exn:test:assertion exn:test) (stack))
(define-struct (exn:test:assertion:internal exn:test:assertion)
())
(define-syntax fail-assertion
(syntax-rules ()
((_)
(raise
(make-exn:test:assertion
"Assertion failure"
(current-continuation-marks)
(assertion-stack))))))
(define-syntax fail-internal
(syntax-rules ()
((_)
(raise
(make-exn:test:assertion:internal
"Internal failure"
(current-continuation-marks)
(assertion-stack))))))
(define (refail-assertion exn)
(raise
(make-exn:test:assertion "Assertion failure"
(exn-continuation-marks exn)
(exn:test:assertion-stack exn))))
)