5 |
|
|
6 |
(in-package :cl-test) |
(in-package :cl-test) |
7 |
|
|
8 |
(eval-when (:compile-toplevel :load-toplevel :execute) |
(eval-when (:compile-toplevel :load-toplevel) |
9 |
|
(compile-and-load "random-aux.lsp") |
10 |
(compile-and-load "random-int-form.lsp")) |
(compile-and-load "random-int-form.lsp")) |
11 |
|
|
12 |
(defvar *print-random-type-prop-input* nil) |
(defvar *print-random-type-prop-input* nil) |
13 |
(defparameter *random-type-prop-result* nil) |
(defparameter *random-type-prop-result* nil) |
14 |
|
|
15 |
(defgeneric make-random-type-containing (val) |
(defgeneric make-random-type-containing (val) |
16 |
(:documentation |
(:method-combination randomized) |
17 |
"Given a value, generate a random type that contains that value.")) |
(:documentation "Given a value, generate a random type that contains that value.")) |
18 |
|
|
19 |
(declaim (special *param-types* *params* *is-var?* *form*)) |
(declaim (special *param-types* *params* *is-var?* *form*)) |
20 |
|
|
233 |
;; (dolist (v vals) (describe v)) |
;; (dolist (v vals) (describe v)) |
234 |
vals)) |
vals)) |
235 |
|
|
236 |
;; Default method |
(defmacro defmethods (name &rest bodies) |
237 |
(defmethod make-random-type-containing ((val t)) t) |
`(progn |
238 |
|
,@(mapcar |
239 |
(defmethod make-random-type-containing ((val standard-class)) |
#'(lambda (body) `(defmethod ,name ,@body)) |
240 |
(random-from-seq #(standard-class class t))) |
bodies))) |
241 |
|
|
242 |
(defmethod make-random-type-containing ((val structure-class)) |
(defmethods make-random-type-containing |
243 |
(random-from-seq #(structure-class class t))) |
(4 ((val t)) |
244 |
|
(rcase |
245 |
(defmethod make-random-type-containing ((val integer)) |
(1 t) |
246 |
(rcase |
(1 (if (consp val) 'cons 'atom)) |
247 |
(2 (let ((tp (random-from-seq '(t number real rational)))) |
(1 `(eql ,val)) |
248 |
(if #-allegro (coin) #+allegro nil |
(1 (let* ((n1 (random 4)) |
249 |
(find-class tp) tp))) |
(n2 (random 4)) |
250 |
(1 (random-from-seq '(integer signed-byte atom))) |
;; Replace these calls with (make-random-element-of-type t) |
251 |
#- allegro (1 (find-class 'integer)) |
;; at some point |
252 |
(2 `(eql ,val)) |
(l1 (loop repeat n1 collect (random-leaf))) |
253 |
(2 (let* ((n1 (random 4)) |
(l2 (loop repeat n2 collect (random-leaf)))) |
254 |
(n2 (random 4)) |
`(member ,@l1 ,val ,@l2))))) |
255 |
(l1 (loop repeat n1 collect (make-random-integer))) |
|
256 |
(l2 (loop repeat n2 collect (make-random-integer)))) |
(1 ((val standard-object)) 'standard-object) |
257 |
`(member ,@l1 ,val ,@l2))) |
(1 ((val class)) 'class) |
258 |
(4 (let ((lo (abs (make-random-integer)))) |
(1 ((val standard-class)) 'standard-class) |
259 |
`(integer ,(- val lo)))) |
(1 ((val structure-class)) 'structure-class) |
260 |
(4 (let ((lo (abs (make-random-integer)))) |
(1 ((val number)) 'number) |
261 |
`(integer ,(- val lo) *))) |
(1 ((val real)) 'real) |
262 |
(4 (let ((hi (abs (make-random-integer)))) |
(1 ((val ratio)) 'ratio) |
263 |
`(integer * ,(+ val hi)))) |
|
264 |
(8 (let ((lo (abs (make-random-integer))) |
(1 ((val integer)) |
265 |
(hi (abs (make-random-integer)))) |
(rcase |
266 |
`(integer ,(- val lo) ,(+ val hi)))) |
(1 'integer) |
267 |
(2 (if (>= val 0) `unsigned-byte |
(1 'signed-byte) |
268 |
(make-random-type-containing val))))) |
(1 (let* ((n1 (random 4)) |
269 |
|
(n2 (random 4)) |
270 |
(defmethod make-random-type-containing ((val character)) |
(l1 (loop repeat n1 collect (make-random-integer))) |
271 |
(rcase |
(l2 (loop repeat n2 collect (make-random-integer)))) |
272 |
(1 `(eql ,val)) |
`(member ,@l1 ,val ,@l2))) |
273 |
(1 'character) |
(1 (let ((lo (abs (make-random-integer)))) |
274 |
(1 (if (typep val 'base-char) 'base-char (make-random-type-containing val))) |
`(integer ,(- val lo)))) |
275 |
(1 (if (typep val 'standard-char) 'standard-char (make-random-type-containing val))) |
(2 (let ((lo (abs (make-random-integer)))) |
276 |
(1 (if (typep val 'extended-char) 'extended-char (make-random-type-containing val))) |
`(integer ,(- val lo) *))) |
277 |
(1 (let* ((n1 (random 4)) |
(2 (let ((hi (abs (make-random-integer)))) |
278 |
(n2 (random 4)) |
`(integer * ,(+ val hi)))) |
279 |
(l1 (loop repeat n1 collect (make-random-character))) |
(4 (let ((lo (abs (make-random-integer))) |
280 |
(l2 (loop repeat n2 collect (make-random-character)))) |
(hi (abs (make-random-integer)))) |
281 |
`(member ,@l1 ,val ,@l2))) |
`(integer ,(- val lo) ,(+ val hi)))) |
282 |
(1 (random-from-seq #(t atom))))) |
(1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) |
283 |
|
|
284 |
(defmethod make-random-type-containing ((val symbol)) |
(2 ((val character)) |
285 |
(rcase |
(rcase |
286 |
(1 `(eql ,val)) |
(1 'character) |
287 |
(3 'symbol) |
(1 (if (typep val 'base-char) 'base-char |
288 |
(1 (if (null val) 'null (make-random-type-containing val))) |
#-sbcl 'extended-char |
289 |
(1 (if (member val '(t nil)) 'boolean (make-random-type-containing val))) |
#+sbcl (throw 'fail nil) |
290 |
(1 (if (keywordp val) 'keyword (make-random-type-containing val))) |
)) |
291 |
(1 (let* ((n1 (random 4)) |
(1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil))) |
292 |
(n2 (random 4)) |
(1 (let* ((n1 (random 4)) |
293 |
(l1 (loop repeat n1 collect (make-random-symbol))) |
(n2 (random 4)) |
294 |
(l2 (loop repeat n2 collect (make-random-symbol)))) |
(l1 (loop repeat n1 collect (make-random-character))) |
295 |
`(member ,@l1 ,val ,@l2))) |
(l2 (loop repeat n2 collect (make-random-character)))) |
296 |
(1 (random-from-seq #(t atom))))) |
`(member ,@l1 ,val ,@l2))))) |
297 |
|
|
298 |
(defmethod make-random-type-containing ((val rational)) |
(1 ((val null)) 'null) |
299 |
(rcase |
|
300 |
(1 `(eql ,val)) |
(2 ((val symbol)) |
301 |
(1 (let* ((n1 (random 4)) |
(rcase |
302 |
(n2 (random 4)) |
(1 'symbol) |
303 |
(l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) |
(1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil)))) |
304 |
(l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) |
(1 (let* ((n1 (random 4)) |
305 |
`(member ,@l1 ,val ,@l2))) |
(n2 (random 4)) |
306 |
(1 `(rational ,val)) |
(l1 (loop repeat n1 collect (make-random-symbol))) |
307 |
(1 `(rational * ,val)) |
(l2 (loop repeat n2 collect (make-random-symbol)))) |
308 |
(1 (let ((v (make-random-element-of-type 'rational))) |
`(member ,@l1 ,val ,@l2))))) |
309 |
(if (<= v val) |
|
310 |
`(rational ,v ,val) |
(1 ((val rational)) |
311 |
`(rational ,val ,v)))) |
(rcase |
312 |
)) |
(1 'rational) |
313 |
|
(1 (let* ((n1 (random 4)) |
314 |
(defmethod make-random-type-containing ((val float)) |
(n2 (random 4)) |
315 |
(let ((names (loop for tp in '(short-float single-float double-float long-float) |
(l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) |
316 |
when (typep val tp) |
(l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) |
317 |
collect tp))) |
`(member ,@l1 ,val ,@l2))) |
318 |
(rcase |
(1 `(rational ,val)) |
319 |
(1 `(eql ,val)) |
(1 `(rational * ,val)) |
320 |
(1 `(member ,val)) |
(1 (let ((v (make-random-element-of-type 'rational))) |
321 |
(1 (random-from-seq names)) |
(if (<= v val) |
322 |
(1 (if (>= val 0) |
`(rational ,v ,val) |
323 |
`(,(random-from-seq names) ,(float 0 val) ,val) |
`(rational ,val ,v)))))) |
324 |
`(,(random-from-seq names) ,val ,(float 0 val))))))) |
|
325 |
|
(1 ((val float)) |
326 |
|
(rcase |
327 |
|
(1 (let* ((n1 (random 4)) |
328 |
|
(n2 (random 4)) |
329 |
|
(l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) |
330 |
|
(l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) |
331 |
|
`(member ,@l1 ,val ,@l2))) |
332 |
|
(1 (let ((names (float-types-containing val))) |
333 |
|
(random-from-seq names))) |
334 |
|
(1 (let ((name (random-from-seq (float-types-containing val)))) |
335 |
|
(if (>= val 0) |
336 |
|
`(,name ,(coerce 0 name) ,val) |
337 |
|
`(,name ,val ,(coerce 0 name))))))) |
338 |
|
) |
339 |
|
|
340 |
|
(defun float-types-containing (val) |
341 |
|
(loop for n in '(short-float single-float double-float long-float float) |
342 |
|
when (typep val n) |
343 |
|
collect n)) |
344 |
|
|
345 |
(defun make-random-array-dimension-spec (array dim-index) |
(defun make-random-array-dimension-spec (array dim-index) |
346 |
(assert (<= 0 dim-index)) |
(assert (<= 0 dim-index)) |
348 |
(let ((dim (array-dimension array dim-index))) |
(let ((dim (array-dimension array dim-index))) |
349 |
(rcase (1 '*) (1 dim)))) |
(rcase (1 '*) (1 dim)))) |
350 |
|
|
351 |
(defmethod make-random-type-containing ((val bit-vector)) |
;;; More methods |
352 |
(rcase |
(defmethods make-random-type-containing |
353 |
(1 (let ((root (if (and (coin) |
(3 ((val bit-vector)) |
354 |
(typep val 'simple-bit-vector)) |
(let ((root (if (and (coin) |
355 |
'simple-bit-vector |
(typep val 'simple-bit-vector)) |
356 |
'bit-vector))) |
'simple-bit-vector |
357 |
(rcase (1 root) |
'bit-vector))) |
358 |
(1 `(,root)) |
(rcase (1 root) |
359 |
(3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
(1 `(,root)) |
360 |
(2 (call-next-method)))) |
(3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
361 |
|
|
362 |
(defmethod make-random-type-containing ((val vector)) |
(3 ((val vector)) |
363 |
(rcase |
(let ((root 'vector) |
|
(2 (let ((root 'vector) |
|
364 |
(alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) |
(alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) |
365 |
(etype (rcase (1 '*) |
(etype (rcase (1 '*) |
366 |
(1 (array-element-type val)) |
(1 (array-element-type val)) |
372 |
(2 (if (and (simple-vector-p val) (coin)) |
(2 (if (and (simple-vector-p val) (coin)) |
373 |
`(simple-vector ,(make-random-array-dimension-spec val 0)) |
`(simple-vector ,(make-random-array-dimension-spec val 0)) |
374 |
`(,root ,etype ,(make-random-array-dimension-spec val 0))))))) |
`(,root ,etype ,(make-random-array-dimension-spec val 0))))))) |
|
(3 (call-next-method)))) |
|
375 |
|
|
376 |
(defmethod make-random-type-containing ((val array)) |
(3 ((val array)) |
377 |
(let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) |
(let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) |
378 |
(etype (rcase (1 (array-element-type val)) (1 '*))) |
(etype (rcase (1 (array-element-type val)) (1 '*))) |
379 |
(rank (array-rank val))) |
(rank (array-rank val))) |
380 |
(rcase |
(rcase |
381 |
(1 root) |
(1 root) |
382 |
(1 `(,root)) |
(1 `(,root)) |
383 |
(1 `(,root ,etype)) |
(1 `(,root ,etype)) |
384 |
(1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) |
(1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) |
385 |
(1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) |
(1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) |
386 |
#-ecl (1 `(,root ,etype ,rank)) |
#-ecl (1 `(,root ,etype ,rank))))) |
387 |
(4 (call-next-method)) |
|
388 |
))) |
(3 ((val string)) |
389 |
|
(let ((root (cond |
390 |
(defmethod make-random-type-containing ((val string)) |
((and (coin) |
391 |
(rcase |
(typep val 'base-string)) |
392 |
(1 (let ((root (cond |
(cond |
393 |
((and (coin) |
((and (coin) (typep val 'simple-base-string)) |
394 |
(typep val 'base-string)) |
'simple-base-string) |
395 |
(cond |
(t 'base-string))) |
396 |
((and (coin) (typep val 'simple-base-string)) |
((and (coin) |
397 |
'simple-base-string) |
(typep val 'simple-string)) |
398 |
(t 'base-string))) |
'simple-string) |
399 |
((and (coin) |
(t 'string)))) |
400 |
(typep val 'simple-string)) |
(rcase (1 root) |
401 |
'simple-string) |
(1 `(,root)) |
402 |
(t 'string)))) |
(3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
403 |
(rcase (1 root) |
|
404 |
(1 `(,root)) |
(1 ((val list)) 'list) |
405 |
(3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
|
406 |
(2 (call-next-method)))) |
(1 ((val cons)) |
407 |
|
(rcase |
408 |
(defmethod make-random-type-containing ((val cons)) |
(1 'cons) |
409 |
(rcase |
(2 `(cons ,(make-random-type-containing (car val)) |
410 |
(2 'cons) |
,(make-random-type-containing (cdr val)))) |
411 |
(2 'list) |
(1 `(cons ,(make-random-type-containing (car val)) |
412 |
(1 `(cons ,(make-random-type-containing (car val)))) |
,(random-from-seq #(t *)))) |
413 |
(1 `(cons ,(make-random-type-containing (car val)) |
(1 `(cons ,(make-random-type-containing (car val)))) |
414 |
,(random-from-seq #(t *)))) |
(1 `(cons ,(random-from-seq #(t *)) |
415 |
(2 `(cons ,(random-from-seq #(t *)) |
,(make-random-type-containing (cdr val)) |
416 |
,(make-random-type-containing (cdr val)))) |
)))) |
417 |
(2 `(cons ,(make-random-type-containing (car val)) |
|
418 |
,(make-random-type-containing (cdr val)))) |
(1 ((val complex)) |
419 |
(1 t))) |
(rcase |
420 |
|
(1 'complex) |
421 |
(defmethod make-random-type-containing ((val complex)) |
#-gcl |
422 |
(rcase |
(1 (let* ((t1 (type-of (realpart val))) |
423 |
(1 'complex) |
(t2 (type-of (imagpart val))) |
424 |
(1 'number) |
(part-type |
425 |
#-gcl (1 |
(cond |
426 |
(let* ((t1 (type-of (realpart val))) |
((subtypep t1 t2) (upgraded-complex-part-type t2)) |
427 |
(t2 (type-of (imagpart val))) |
((subtypep t2 t1) (upgraded-complex-part-type t1)) |
428 |
(part-type |
((and (subtypep t1 'rational) |
429 |
(cond |
(subtypep t2 'rational)) |
430 |
((subtypep t1 t2) (upgraded-complex-part-type t2)) |
'rational) |
431 |
((subtypep t2 t1) (upgraded-complex-part-type t1)) |
(t |
432 |
((and (subtypep t1 'rational) |
(upgraded-complex-part-type `(or ,t1 ,t2)))))) |
433 |
(subtypep t2 'rational)) |
(if (subtypep 'real part-type) |
434 |
'rational) |
'(complex real) |
435 |
(t |
`(complex ,part-type)))))) |
436 |
(upgraded-complex-part-type `(or ,t1 ,t2)))))) |
|
437 |
(if (subtypep 'real part-type) |
(1 ((val generic-function)) 'generic-function) |
438 |
'(complex real) |
(1 ((val function)) |
439 |
`(complex ,part-type)))) |
(rcase |
440 |
(1 `(eql ,val)))) |
(1 'function) |
441 |
|
(1 (if (typep val 'compiled-function) |
442 |
(defmethod make-random-type-containing ((val generic-function)) |
'compiled-function |
443 |
(rcase |
'function)))) |
444 |
(1 'generic-function) |
) |
|
(1 (call-next-method)))) |
|
|
|
|
|
(defmethod make-random-type-containing ((val function)) |
|
|
(rcase |
|
|
(1 'function) |
|
|
(1 (if (typep val 'compiled-function) |
|
|
'compiled-function |
|
|
'function)) |
|
|
(1 t))) |
|
|
|
|
|
(defmethod make-random-type-containing ((val sequence)) |
|
|
(rcase |
|
|
(1 'sequence) |
|
|
(2 (call-next-method)))) |
|
445 |
|
|
446 |
;;; Macro for defining random type prop tests |
;;; Macro for defining random type prop tests |
447 |
|
|