-
Notifications
You must be signed in to change notification settings - Fork 1
/
assert-chicken.scm
37 lines (34 loc) · 1.69 KB
/
assert-chicken.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
;;;
;;; assert-scm - Minimalist xUnit test framework for Scheme R5RS, SRFI-12 extension (e.g. Chicken 4).
;;; https://github.com/codecop/assert-scm
;;; Copyright (c) 2015, Peter Kofler, BSD 3-Clause License
;;;
(include "assert-r5rs.scm")
(define (-error->string ex)
(cond ((null? ex) "")
((string? ex) ex)
((symbol? ex) (symbol->string ex))
((list? ex) (string-append " (" (apply string-append (map -error->string ex)) ")"))
;; SRFI-12/Chicken specific code
((condition? ex) (string-append (-error->string ((condition-property-accessor 'exn 'message) ex))
(-error->string ((condition-property-accessor 'exn 'arguments) ex))))
(else (pp ex)
"<unknown exception type>")))
(define (-run-with-exception-handler handler body)
;; SRFI-12 specific code
(let ((exn-message-comparison (list)))
(handle-exceptions exn
(set! exn-message-comparison (handler exn))
(body))
exn-message-comparison))
(define (assert-raise expected-ex body)
(define (ex-handler ex)
(let ((expected-message (-error->string expected-ex))
(actual-message (-error->string ex)))
(check (-make-string-message "raise " -error->string expected-ex ex)
(string=? expected-message actual-message))))
(define (ex-body)
(body)
(error "no raise in body"))
(lambda ()
(-run-with-exception-handler ex-handler ex-body)))