forked from samirose/sicp-compiler-project
-
Notifications
You must be signed in to change notification settings - Fork 0
/
assert.sls
41 lines (32 loc) · 1.46 KB
/
assert.sls
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
38
39
40
41
#!r6rs
(library
(assert)
(export assert-equal
install-test-compilation-error-handler! assert-raises-compilation-error)
(import (rnrs base)
(rnrs exceptions)
(compilation-error))
(define (assert-equal expected actual text)
(if (not (equal? expected actual))
(error text (list expected actual))))
(define (make-test-compilation-error message object)
(list 'test-compilation-error message object))
(define (test-compilation-error? e)
(and (list? e) (eq? (car e) 'test-compilation-error)))
(define (assert-equal-test-compilation-error expected actual)
(assert-equal (cadr expected) (cadr actual) "Error messages should be equal")
(assert-equal (caddr expected) (caddr actual) "Error objects should be equal"))
(define (error-handler message object)
(raise (make-test-compilation-error message object)))
(define (install-test-compilation-error-handler!)
(set-compilation-error-handler! error-handler))
(define (assert-raises-compilation-error action expected-message expected-object description)
(let ((expected-error (make-test-compilation-error expected-message expected-object)))
(guard (cond
((test-compilation-error? cond)
(assert-equal-test-compilation-error expected-error cond)
expected-error))
(let ((result (action)))
(if (not (eq? result expected-error))
(error description (list (cdr expected-error) result)))))))
)