forked from dmitryvk/sbcl-win32-threads
/
assertoid.lisp
93 lines (90 loc) · 3.21 KB
/
assertoid.lisp
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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
;;;; the ASSERTOID macro, asserting something with added generality
;;;; to help in regression tests
(cl:in-package :cl-user)
;;; EXPR is an expression to evaluate (both with EVAL and with
;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
;;; expression to be tested in other than the default optimization
;;; level(s).
;;;
;;; The messiness with the various flavors of EXPECTED stuff is
;;; to handle various issues:
;;; * Some things are expected to signal errors instead of returning
;;; ordinary values.
;;; * Some things are expected to return multiple values.
;;; * Some things can return any of several values (e.g. generalized
;;; booleans).
;;; The default is to expect a generalized boolean true.
;;;
;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are
;;; shorthand for special cases of EXPECTED-LAMBDA.
;;;
;;; Use EXPECTED-ERROR to require an error to be thrown. Use
;;; EXPECTED-ERROR-LAMBDA to require that an error be thrown and
;;; that further it satisfies the given lambda.
(defmacro assertoid (expr
&key
extra-optimizations
(expected-eql nil expected-eql-p)
(expected-equal nil expected-equal-p)
(expected-equalp nil expected-equalp-p)
(expected-lambda (cond
(expected-eql-p
(lambda (x)
(eql x (eval expected-eql))))
(expected-equal-p
(lambda (x)
(equal x (eval expected-equal))))
(expected-equalp-p
(lambda (x)
(equalp x (eval expected-equalp))))
(t
(lambda (x)
x)))
expected-lambda-p)
(expected-error-type nil expected-error-type-p)
(expected-error-lambda (if expected-error-type
(lambda (condition)
(typep condition
expected-error-type))
nil)
expected-error-lambda-p))
(when (> (count-if #'identity
(vector expected-eql-p
expected-equal-p
expected-equalp-p
expected-lambda-p
expected-error-type-p
expected-error-lambda-p))
1)
(error "multiple EXPECTED-FOO arguments"))
(when expected-error-lambda
(error "stub: expected-error functionality not supported yet"))
(let ((eval-expected-lambda (eval expected-lambda)))
(flet ((frob (evaloid)
(let ((result (funcall evaloid expr)))
(unless (funcall eval-expected-lambda result)
(error "failed assertoid" expr))))
(compile-as-evaloid (optimizations)
(lambda (expr)
(funcall (compile nil
`(lambda ()
(declare (optimize ,@optimizations))
,expr))))))
(frob #'eval)
(frob (compile-as-evaloid ()))
(dolist (i extra-optimizations)
(frob (compile-as-evaloid i))))))
;;; examples
(assertoid (= 2 (length (list 1 2))))
(assertoid (= 2 (length (list 1 2)))
:extra-optimizations (((speed 2) (space 3))
((speed 1) (space 3))))
(assertoid (cons 1 2)
:expected-lambda (lambda (x) (equal x '(1 . 2))))
(assertoid (cons (list 1 2) (list 1 2))
:expected-equal '((1 2) 1 2))
;;; not implemented yet:
#+nil (assertoid (length (eval (find-package :cl)))
:expected-error-type 'type-error)