3 ;; we redefine the class and possibly method each time, ick.
5 (define-condition ensure-random-cases-failure
(test-condition)
6 ((total :initarg
:total
:initform
0)
7 (problems :initarg
:problems
:initform nil
))
8 (:report
(lambda (condition stream
)
9 (format stream
"Ensure-random-cases: ~d out of ~d failed. Failing values are: ~{~% ~s~^, ~}"
10 (length (slot-value condition
'problems
))
11 (slot-value condition
'total
)
12 (slot-value condition
'problems
)))))
14 (defgeneric random-instance-for-suite
(thing suite
))
16 (defmacro defrandom-instance
(instance-type suite
&body body
)
18 (defclass ,instance-type
() ())
19 (defvar ,(intern (format nil
"+~a+" instance-type
) :lift
)
20 (make-instance ',instance-type
))
21 (defmethod random-instance-for-suite
22 ((thing ,instance-type
) (suite ,(if suite suite t
)))
25 (defmacro ensure-random-cases
(count (&rest vars-and-types
)
27 (let ((problems (gensym)))
28 (flet ((intern-type (type)
29 (intern (format nil
"+~a+" type
) :lift
)))
30 `(let ((,problems nil
))
31 (loop repeat
,count do
33 (lambda (var-and-type)
34 `(,(first var-and-type
)
35 (random-instance-for-suite
36 ,(intern-type (second var-and-type
))
41 (princ #\.
*debug-io
*))
43 (declare (ignorable cond
))
44 (princ #\
* *debug-io
*)
46 (lambda (var-and-type)
47 `(list ',(first var-and-type
)
48 ,(first var-and-type
)))
49 vars-and-types
)) ,problems
)))))
51 (let ((condition (make-condition
52 'ensure-random-cases-failure
54 :problems
,problems
)))
55 (if (find-restart 'ensure-failed
)
56 (invoke-restart 'ensure-failed condition
)
57 (warn condition
))))))))
59 (defmacro ensure-random-cases
+ (count (&rest vars
) (&rest case-form
)
61 (let ((total (gensym))
63 `(let ((,problems nil
) (,total
0))
64 (loop repeat
,count do
66 (destructuring-bind ,vars
,case-form
70 (declare (ignore cond
))
71 (push (list ,@vars
) ,problems
)))))
73 (let ((condition (make-condition
74 'ensure-random-cases-failure
76 :problems
,problems
)))
77 (if (find-restart 'ensure-failed
)
78 (invoke-restart 'ensure-failed condition
)
79 (warn condition
)))))))
81 ;;; merge with deftestsuite macro
82 (pushnew :random-instance
*deftest-clauses
*)
85 :random-instance
2 :methods
86 (lambda () (def :random-instances
))
87 '((push (cleanup-parsed-parameter value
) (def :random-instances
)))
88 'build-random-instances-method
)
90 (defun build-random-instances-method ()
92 (excl:*redefinition-warnings
* nil
))
93 ,@(mapcar (lambda (instance)
94 (let ((atype (first instance
))
95 (body (second instance
)))
96 `(defrandom-instance ,atype test-mixin
,body
)))
97 (def :random-instances
))))
99 (defgeneric random-number
(suite min max
))
101 (defgeneric random-element
(suite sequence
))
103 (defmethod random-number (suite min max
)
104 (declare (ignore suite
))
105 (+ min
(random (- max min
))))
107 (defmethod random-element (suite sequence
)
108 (elt sequence
(random-number suite
0 (1- (length sequence
)))))
110 (defrandom-instance an-integer test-mixin
111 (random-number suite -
100 100))
113 (defrandom-instance a-single-float test-mixin
114 (random-number suite -
100s0
100.0s0
))
116 (defrandom-instance a-double-float test-mixin
117 (random-number suite -
100d0
100.0d0
))
119 (defrandom-instance a-symbol test-mixin
120 (random-element suite
'(a hello a-c d_f |MiXeD|