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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
;;;; testiere.lisp
(in-package #:testiere)
(defun build-test (name spec)
(match spec
((list :fails inputs)
`(assert
(handler-case (progn (,name ,@inputs) nil)
(error (e) (declare (ignore e)) t))))
((list :signals inputs condition)
`(assert
(handler-case (progn (,name ,@inputs) nil)
(,condition (c) (declare (ignore c)) t)
(condition (c) (declare (ignore c)) nil))))
((list* :program function-name args)
`(when (fboundp ',function-name)
(funcall ',function-name ,@args)))
((list* :with-stubs redefs more-specs)
(let* ((assoc-vars
(loop for (stub-name . more) in redefs
collect (list stub-name (gensym (symbol-name stub-name)))))
(cache-binding-forms
(loop for (stub-name tmp-var) in assoc-vars
collect `(,tmp-var (fdefinition ',stub-name))))
(redef-forms
(loop for (stub-name lambda-list . body) in redefs
collect `(setf (fdefinition ',stub-name)
(function (lambda ,lambda-list ,@body)))))
(clean-up
(loop for (stub-name . more) in redefs
for binding = (assoc stub-name assoc-vars)
collect `(setf (fdefinition ',stub-name) ,(second binding)))))
`(let ,cache-binding-forms
(unwind-protect
(progn
,@redef-forms
,@(mapcar (lambda (s) (build-test name s)) more-specs))
,@clean-up))))
((list* :let bindings more-specs)
`(let ,bindings
,@(mapcar (lambda (s) (build-test name s)) more-specs)))
((list :afterp inputs thunk-test)
`(progn (,name ,@inputs)
(assert (funcall ,thunk-test))))
((list :outputp inputs output-test)
`(assert (funcall ,output-test (,name ,@inputs))))
((list comparator-function inputs expected-output)
`(assert (,comparator-function (,name ,@inputs) ,expected-output)))))
(defun extract-tests (name body)
(let ((end-pos (position :end body))
(start-pos (position :tests body)))
(when (and end-pos start-pos)
(let ((specs (subseq body (1+ start-pos) end-pos))
(before (subseq body 0 start-pos))
(after (nthcdr (1+ end-pos) body)))
(list (mapcar (lambda (spec) (build-test name spec)) specs)
(append before after))))))
(defmacro with-stub ((name lambda-list &body body) &body forms)
"Runs forms in a context where NAME is temporarily rebound to a
different function. If NAME is not FBOUNDP then it is temporarily
defined."
(let ((cached (gensym)))
`(let ((,cached
(when (fboundp ',name)
(fdefinition ',name))))
(unwind-protect
(progn
(setf (fdefinition ',name)
(lambda ,lambda-list ,@body))
,@forms)
(if ,cached
(setf (fdefinition ',name)
,cached)
(fmakunbound ',name))))))
(defmacro with-stubs (redefinitions &body forms)
"Like WITH-STUB, but REDEFINITIONS is a list of (NAME LAMBDA-LIST
. BODY) list, suitable for defining a function."
(loop
with inner = `(progn ,@forms)
for (name lambda-list . body) in (reverse redefinitions)
do (setf inner `(with-stub (,name ,lambda-list ,@body)
,inner))
finally (return inner)))
(defmacro defun/t (name lambda-list &body body)
"Like regular DEFUN, but with embedded unit tests. If those tests
would fail, the function fails to be defined. "
(destructuring-bind (tests function-body) (extract-tests name body)
(let ((cached (gensym)))
`(let ((,cached
(when (fboundp ',name)
(fdefinition ',name))))
(restart-case
(eval-when (:compile-toplevel :load-toplevel :execute)
(progn
(defun ,name ,lambda-list ,@function-body)
,@tests))
(make-unbound () (fmakunbound ',name))
(revert-to-last-good-version ()
(if ,cached
(setf (symbol-function ',name)
,cached)
(fmakunbound ',name))))))))
|
