15 |
(:documentation |
(:documentation |
16 |
"Given a value, generate a random type that contains that value.")) |
"Given a value, generate a random type that contains that value.")) |
17 |
|
|
18 |
(defun do-random-type-prop-tests (&key operator |
(declaim (special *param-types* *params* *is-var?* *form*)) |
19 |
(minargs 2) |
|
20 |
(maxargs minargs) |
(defun do-random-type-prop-tests |
21 |
(arg-types nil) |
(operator &key |
22 |
(rest-type 'integer) |
(minargs 2) |
23 |
(reps 1000) |
(maxargs minargs) |
24 |
(enclosing-the nil)) |
(arg-types nil) |
25 |
|
(rest-type 'integer) |
26 |
|
(reps 1000) |
27 |
|
(enclosing-the nil) |
28 |
|
(test #'regression-test::equalp-with-case)) |
29 |
(assert (<= 1 minargs maxargs 20)) |
(assert (<= 1 minargs maxargs 20)) |
30 |
(loop |
(dotimes (i reps) |
31 |
repeat reps |
again |
32 |
do |
(let* ((param-names |
|
(let* ((param-names |
|
33 |
'(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 |
'(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 |
34 |
p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) |
p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) |
35 |
(nargs (+ minargs (random (- maxargs minargs -1)))) |
(nargs (+ minargs (random (- maxargs minargs -1)))) |
36 |
(types (append arg-types |
(types (subseq |
37 |
(make-list (- nargs (length arg-types)) |
(append arg-types |
38 |
:initial-element rest-type))) |
(make-list (max 0 (- nargs (length arg-types))) |
39 |
(vals (mapcar #'make-random-element-of-type types)) |
:initial-element rest-type)) |
40 |
|
0 nargs)) |
41 |
|
; (vals (mapcar #'make-random-element-of-type types)) |
42 |
|
(vals (setq *params* |
43 |
|
(or (make-random-arguments types) (go again)))) |
44 |
(is-var? (loop repeat (length vals) collect (coin))) |
(is-var? (loop repeat (length vals) collect (coin))) |
45 |
|
(*is-var?* is-var?) |
46 |
(params (loop for x in is-var? |
(params (loop for x in is-var? |
47 |
for p in param-names |
for p in param-names |
48 |
when x collect p)) |
when x collect p)) |
49 |
(param-types (mapcar #'make-random-type-containing vals)) |
(param-types (mapcar #'make-random-type-containing vals)) |
50 |
|
(*param-types* param-types) |
51 |
(type-decls (loop for x in is-var? |
(type-decls (loop for x in is-var? |
52 |
for p in param-names |
for p in param-names |
53 |
for tp in param-types |
for tp in param-types |
56 |
(rval (cl:handler-bind |
(rval (cl:handler-bind |
57 |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
58 |
(warning #'muffle-warning)) |
(warning #'muffle-warning)) |
59 |
(eval (cons operator vals)))) |
(let ((eval-form (cons operator (loop for v in vals collect `(quote ,v))))) |
60 |
|
;; (dotimes (i 100) (eval eval-form)) |
61 |
|
(eval eval-form)))) |
62 |
(result-type (if (and enclosing-the (integerp rval)) |
(result-type (if (and enclosing-the (integerp rval)) |
63 |
(make-random-type-containing rval) |
(make-random-type-containing rval) |
64 |
t)) |
t)) |
71 |
(1 (let ((tp (make-random-type-containing v))) |
(1 (let ((tp (make-random-type-containing v))) |
72 |
`(the ,tp ,p))) |
`(the ,tp ,p))) |
73 |
(1 p)) |
(1 p)) |
74 |
v)))) |
(if (or (consp v) |
75 |
|
(and (symbolp v) (not (or (keywordp v) |
76 |
|
(member v '(nil t)))))) |
77 |
|
`(quote ,v) |
78 |
|
v))))) |
79 |
(form |
(form |
80 |
`(lambda (r ,@params) |
`(lambda (r ,@params) |
81 |
(declare (optimize speed (safety 1)) |
(declare (optimize speed (safety 1)) |
83 |
,@ type-decls) |
,@ type-decls) |
84 |
(setf (aref r) |
(setf (aref r) |
85 |
,(if enclosing-the `(the ,result-type ,expr) expr)) |
,(if enclosing-the `(the ,result-type ,expr) expr)) |
86 |
(values)))) |
(values))) |
87 |
|
(*form* form)) |
88 |
(when *print-random-type-prop-input* |
(when *print-random-type-prop-input* |
89 |
(let ((*print-pretty* t) |
(let ((*print-pretty* t) |
90 |
(*print-case* :downcase)) |
(*print-case* :downcase)) |
98 |
(warning #'muffle-warning)) |
(warning #'muffle-warning)) |
99 |
(compile nil form))) |
(compile nil form))) |
100 |
(r (make-array nil :element-type upgraded-result-type)) |
(r (make-array nil :element-type upgraded-result-type)) |
101 |
(result (progn (apply fn r param-vals) (aref r)))) |
(result (progn |
102 |
|
;; (dotimes (i 100) (apply fn r param-vals)) |
103 |
|
(apply fn r param-vals) |
104 |
|
(aref r)))) |
105 |
(setq *random-type-prop-result* |
(setq *random-type-prop-result* |
106 |
(list :upgraded-result-type upgraded-result-type |
(list :upgraded-result-type upgraded-result-type |
107 |
:form form |
:form form |
108 |
:vals vals |
:vals vals |
109 |
:result result |
:result result |
110 |
:rval rval)) |
:rval rval)) |
111 |
(unless (rt::equalp-with-case result rval) |
(unless (funcall test result rval) |
112 |
(return *random-type-prop-result*)))))) |
(return *random-type-prop-result*)))))) |
113 |
|
|
114 |
|
(defun make-random-arguments (types-or-funs) |
115 |
|
(let ((vals nil)) |
116 |
|
(loop for type-or-fun in types-or-funs |
117 |
|
for type = (or (typecase type-or-fun |
118 |
|
((and function (not symbol)) |
119 |
|
(apply type-or-fun vals)) |
120 |
|
(t type-or-fun)) |
121 |
|
(return-from make-random-arguments nil) ;; null type |
122 |
|
) |
123 |
|
for val = (make-random-element-of-type type) |
124 |
|
do (setf vals (nconc vals (list val)))) |
125 |
|
;; (dolist (v vals) (describe v)) |
126 |
|
vals)) |
127 |
|
|
128 |
(defmethod make-random-type-containing ((val integer)) |
(defmethod make-random-type-containing ((val integer)) |
129 |
(rcase |
(rcase |
130 |
(2 (let ((tp (random-from-seq '(t number real rational)))) |
(2 (let ((tp (random-from-seq '(t number real rational)))) |
178 |
`(member ,@l1 ,val ,@l2))) |
`(member ,@l1 ,val ,@l2))) |
179 |
(1 (random-from-seq #(t atom))))) |
(1 (random-from-seq #(t atom))))) |
180 |
|
|
|
(defun make-random-character () |
|
|
(rcase |
|
|
(2 (random-from-seq +standard-chars+)) |
|
|
(2 (or (code-char (random (min 256 char-code-limit))) |
|
|
(make-random-character))) |
|
|
(1 (or (code-char (random (min (ash 1 16) char-code-limit))) |
|
|
(make-random-character))) |
|
|
(1 (or (code-char (random (min (ash 1 24) char-code-limit))) |
|
|
(make-random-character))))) |
|
|
|
|
181 |
(defmethod make-random-type-containing ((val rational)) |
(defmethod make-random-type-containing ((val rational)) |
182 |
(rcase |
(rcase |
183 |
(1 `(eql ,val)) |
(1 `(eql ,val)) |
184 |
(1 (let* ((n1 (random 4)) |
(1 (let* ((n1 (random 4)) |
185 |
(n2 (random 4)) |
(n2 (random 4)) |
186 |
(l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) |
(l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) |
187 |
(l2 (loop repeat n1 collect (make-random-element-of-type 'rational)))) |
(l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) |
188 |
`(member ,@l1 ,val ,@l2))) |
`(member ,@l1 ,val ,@l2))) |
189 |
(1 `(rational ,val)) |
(1 `(rational ,val)) |
190 |
(1 `(rational * ,val)) |
(1 `(rational * ,val)) |
194 |
`(rational ,val ,v)))) |
`(rational ,val ,v)))) |
195 |
)) |
)) |
196 |
|
|
|
|
|
197 |
|
(defmethod make-random-type-containing ((val float)) |
198 |
|
(let ((names (loop for tp in '(short-float single-float double-float long-float) |
199 |
|
when (typep val tp) |
200 |
|
collect tp))) |
201 |
|
(rcase |
202 |
|
(1 `(eql ,val)) |
203 |
|
(1 `(member ,val)) |
204 |
|
(1 (random-from-seq names)) |
205 |
|
(1 (if (>= val 0) |
206 |
|
`(,(random-from-seq names) ,(float 0 val) ,val) |
207 |
|
`(,(random-from-seq names) ,val ,(float 0 val))))))) |
208 |
|
|
209 |
|
(defun make-random-array-dimension-spec (array dim-index) |
210 |
|
(assert (<= 0 dim-index)) |
211 |
|
(assert (< dim-index (array-rank array))) |
212 |
|
(let ((dim (array-dimension array dim-index))) |
213 |
|
(rcase (1 '*) (1 dim)))) |
214 |
|
|
215 |
|
(defmethod make-random-type-containing ((val bit-vector)) |
216 |
|
(rcase |
217 |
|
(1 (let ((root (if (and (coin) |
218 |
|
(typep val 'simple-bit-vector)) |
219 |
|
'simple-bit-vector |
220 |
|
'bit-vector))) |
221 |
|
(rcase (1 root) |
222 |
|
(1 `(,root)) |
223 |
|
(3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
224 |
|
(2 (call-next-method)))) |
225 |
|
|
226 |
|
(defmethod make-random-type-containing ((val vector)) |
227 |
|
(rcase |
228 |
|
(2 (let ((root 'vector) |
229 |
|
(alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) |
230 |
|
(etype (rcase (1 '*) |
231 |
|
(1 (array-element-type val)) |
232 |
|
;; Add rule for creating new element types? |
233 |
|
))) |
234 |
|
(rcase (1 alt-root) |
235 |
|
(1 `(,alt-root)) |
236 |
|
(1 `(,root ,etype)) |
237 |
|
(2 (if (and (simple-vector-p val) (coin)) |
238 |
|
`(simple-vector ,(make-random-array-dimension-spec val 0)) |
239 |
|
`(,root ,etype ,(make-random-array-dimension-spec val 0))))))) |
240 |
|
(3 (call-next-method)))) |
241 |
|
|
242 |
|
(defmethod make-random-type-containing ((val array)) |
243 |
|
(let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) |
244 |
|
(etype (rcase (1 (array-element-type val)) (1 '*))) |
245 |
|
(rank (array-rank val))) |
246 |
|
(rcase |
247 |
|
(1 root) |
248 |
|
(1 `(,root)) |
249 |
|
(1 `(,root ,etype)) |
250 |
|
(1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) |
251 |
|
(1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) |
252 |
|
(1 `(,root ,etype ,rank))))) |
253 |
|
|
254 |
|
(defmethod make-random-type-containing ((val string)) |
255 |
|
(rcase |
256 |
|
(1 (let ((root (if (and (coin) |
257 |
|
(typep val 'simple-string)) |
258 |
|
'simple-string |
259 |
|
'string))) |
260 |
|
(rcase (1 root) |
261 |
|
(1 `(,root)) |
262 |
|
(3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
263 |
|
(2 (call-next-method)))) |
264 |
|
|
265 |
|
(defmethod make-random-type-containing ((val cons)) |
266 |
|
(rcase |
267 |
|
(3 'cons) |
268 |
|
(2 'list) |
269 |
|
(1 `(cons ,(make-random-type-containing (car val)))) |
270 |
|
(1 `(cons t ,(make-random-type-containing (cdr val)))) |
271 |
|
(1 t))) |
272 |
|
|
273 |
|
(defmethod make-random-type-containing ((val complex)) |
274 |
|
(rcase |
275 |
|
(1 'complex) |
276 |
|
(1 'number) |
277 |
|
#-gcl (1 `(complex ,(upgraded-complex-part-type (type-of (realpart val))))) |
278 |
|
(1 `(eql ,val)))) |
279 |
|
|
280 |
|
(defmethod make-random-type-containing ((val generic-function)) |
281 |
|
(rcase |
282 |
|
(1 'generic-function) |
283 |
|
(1 (call-next-method)))) |
284 |
|
|
285 |
|
(defmethod make-random-type-containing ((val function)) |
286 |
|
(rcase |
287 |
|
(1 'function) |
288 |
|
(1 (if (typep val 'compiled-function) |
289 |
|
'compiled-function |
290 |
|
'function)) |
291 |
|
(1 t))) |