19 |
|
|
20 |
(defparameter *default-reps* 1000) |
(defparameter *default-reps* 1000) |
21 |
(defparameter *default-cell* nil) |
(defparameter *default-cell* nil) |
22 |
|
(defparameter *default-ignore* 'arithmetic-error) |
23 |
|
(defparameter *default-arg-the* t) |
24 |
|
|
25 |
|
;;; |
26 |
|
;;; The random type prop tester takes three required arguments: |
27 |
|
;;; |
28 |
|
;;; operator A lisp operator (either a symbol or a lambda form) |
29 |
|
;;; arg-types A list consisting either of certain kinds of lisp types |
30 |
|
;;; (that make-random-element-of-type understands) and/or |
31 |
|
;;; functions that yield types. |
32 |
|
;;; minargs Minimum number of arguments to be given to the operator. |
33 |
|
;;; Must be a positive integer <= maxargs. |
34 |
|
;;; |
35 |
|
;;; There are also keyword arguments, some with defaults given by special |
36 |
|
;;; variables. |
37 |
|
;;; |
38 |
|
;;; The random type prop tester generates between minargs and maxargs |
39 |
|
;;; (maxargs defaults to minargs) random arguments. The type of each |
40 |
|
;;; argument is given by the corresponding type in arg-types (or by rest-type, |
41 |
|
;;; if there aren't enough elements of arg-types). If the element of arg-types |
42 |
|
;;; is a function, the type for the parameter is produced by calling the function |
43 |
|
;;; with the previously generated actual parameters as its arguments. |
44 |
|
;;; |
45 |
|
;;; The list of parameters is stored into the special variable *params*. |
46 |
|
;;; |
47 |
|
;;; The tester evaluates (operator . arguments), and also builds a lambda |
48 |
|
;;; form to be compiled and called on (a subset of) the parameters. The lambda |
49 |
|
;;; form is stored in the special variable *form*. |
50 |
|
;;; |
51 |
|
;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests |
52 |
|
;;; in a deftest form. See random-type-prop-tests.lsp (and subfiles) for examples |
53 |
|
;;; of its use testing CL builtin operators. To use it: |
54 |
|
;;; |
55 |
|
;;; (load "gclload1.lsp") |
56 |
|
;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles |
57 |
|
;;; (compile-and-load "random-type-prop.lsp") |
58 |
|
;;; (in-package :cl-test) |
59 |
|
;;; #+sbcl (setq *default-arg-the* nil) ;; This reduces the rate at which the sbcl IR2 type check bug occurs |
60 |
|
;;; (let (*catch-errors*) (do-test '<testname>)) |
61 |
|
;;; or (let (*catch-errors*) (do-tests)) |
62 |
|
;;; |
63 |
|
;;; Running all the tests may take a while, particularly on lisps with slow compilers. |
64 |
|
;;; |
65 |
|
;;; |
66 |
|
;;; Keyword arguments to do-random-type-prop-tests: |
67 |
|
;;; |
68 |
|
;;; Argument Default Meaning |
69 |
|
;;; |
70 |
|
;;; maxargs minargs Maximum number of actual parameters to generate (max 20). |
71 |
|
;;; rest-type t Type of arguments beyond those specified in arg-types |
72 |
|
;;; reps *default-reps* Number of repetitions to try before stopping. |
73 |
|
;;; The default is controlled by a special variable that |
74 |
|
;;; is initially 1000. |
75 |
|
;;; enclosing-the nil If true, with prob 1/2 randomly generate an enclosing |
76 |
|
;;; (THE ...) form around the form invoking the operator. |
77 |
|
;;; arg-the *default-arg-the* If true (which is the initial value of the default |
78 |
|
;;; special variable), with probability 1/2 randomly generate |
79 |
|
;;; a (THE ...) form around each actual parameter. |
80 |
|
;;; cell *default-cell* If true (default is NIL), store the result into a rank-0 |
81 |
|
;;; array of specialized type. This enables one to test |
82 |
|
;;; forms where the result will be unboxed. Otherwise, just |
83 |
|
;;; return the values. |
84 |
|
;;; ignore nil Ignore conditions that are elements of IGNORE. For example, |
85 |
|
;;; one might bind this to ARITHMETIC-ERROR if you want to |
86 |
|
;;; ignore possible floating errors (say). |
87 |
|
;;; test rt::equalp-with-case The test function used to compare outputs. It's |
88 |
|
;;; also handy to use #'approx= to handle approximate equality |
89 |
|
;;; when testing floating point computations, where compiled code |
90 |
|
;;; may have different roundoff errors. |
91 |
|
;;; replicate nil Cause arguments to be copied (preserving sharing in conses |
92 |
|
;;; and arrays) before applying the operator. This is used to test |
93 |
|
;;; destructive operators. |
94 |
|
;;; |
95 |
|
;;; |
96 |
|
|
97 |
(defun do-random-type-prop-tests |
(defun do-random-type-prop-tests |
98 |
(operator arg-types minargs |
(operator arg-types minargs |
99 |
&key |
&key |
101 |
(rest-type t) |
(rest-type t) |
102 |
(reps *default-reps*) |
(reps *default-reps*) |
103 |
(enclosing-the nil) |
(enclosing-the nil) |
104 |
|
(arg-the *default-arg-the*) |
105 |
(cell *default-cell*) |
(cell *default-cell*) |
106 |
(ignore nil) |
(ignore *default-ignore*) |
107 |
(test #'regression-test::equalp-with-case)) |
(test #'regression-test::equalp-with-case) |
108 |
|
(replicate nil)) |
109 |
(assert (<= 1 minargs maxargs 20)) |
(assert (<= 1 minargs maxargs 20)) |
110 |
(prog1 |
(prog1 |
111 |
(dotimes (i reps) |
(dotimes (i reps) |
125 |
; (vals (mapcar #'make-random-element-of-type types)) |
; (vals (mapcar #'make-random-element-of-type types)) |
126 |
(vals (setq *params* |
(vals (setq *params* |
127 |
(or (make-random-arguments types) (go again)))) |
(or (make-random-arguments types) (go again)))) |
128 |
|
(vals (if replicate (mapcar #'replicate vals) vals)) |
129 |
(is-var? (loop repeat (length vals) collect (coin))) |
(is-var? (loop repeat (length vals) collect (coin))) |
130 |
(*is-var?* is-var?) |
(*is-var?* is-var?) |
131 |
(params (loop for x in is-var? |
(params (loop for x in is-var? |
141 |
(rval (cl:handler-bind |
(rval (cl:handler-bind |
142 |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
143 |
(warning #'muffle-warning)) |
(warning #'muffle-warning)) |
144 |
(let ((eval-form (cons operator (loop for v in vals collect `(quote ,v))))) |
(let* ((vals (if replicate (mapcar #'replicate vals) vals)) |
145 |
|
(eval-form (cons operator (loop for v in vals |
146 |
|
collect `(quote ,v))))) |
147 |
;; (print eval-form) (terpri) |
;; (print eval-form) (terpri) |
148 |
;; (dotimes (i 100) (eval eval-form)) |
;; (dotimes (i 100) (eval eval-form)) |
149 |
(eval eval-form)))) |
(eval eval-form)))) |
154 |
for v in vals |
for v in vals |
155 |
for p in param-names |
for p in param-names |
156 |
collect (if x |
collect (if x |
157 |
(rcase |
(if (and arg-the (coin)) |
158 |
(1 (let ((tp (make-random-type-containing v))) |
(let ((tp (make-random-type-containing v))) |
159 |
`(the ,tp ,p))) |
`(the ,tp ,p)) |
160 |
(1 p)) |
p) |
161 |
(if (or (consp v) |
(if (or (consp v) |
162 |
(and (symbolp v) (not (or (keywordp v) |
(and (symbolp v) (not (or (keywordp v) |
163 |
(member v '(nil t)))))) |
(member v '(nil t)))))) |
172 |
(upgraded-result-type (and store-into-cell? |
(upgraded-result-type (and store-into-cell? |
173 |
(upgraded-array-element-type `(eql ,rval)))) |
(upgraded-array-element-type `(eql ,rval)))) |
174 |
(form |
(form |
175 |
`(lambda (,@(when store-into-cell? '(r)) ,@params) |
(setq *form* |
176 |
(declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) |
`(lambda (,@(when store-into-cell? '(r)) ,@params) |
177 |
,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) |
(declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) |
178 |
,@ type-decls) |
,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) |
179 |
,(let ((result-form |
,@ type-decls) |
180 |
(if enclosing-the `(the ,result-type ,expr) expr))) |
,(let ((result-form |
181 |
(if store-into-cell? |
(if enclosing-the `(the ,result-type ,expr) expr))) |
182 |
`(setf (aref r) ,result-form) |
(if store-into-cell? |
183 |
result-form)))) |
`(setf (aref r) ,result-form) |
184 |
(*form* form)) |
result-form))))) |
185 |
|
) |
186 |
(when *print-random-type-prop-input* |
(when *print-random-type-prop-input* |
187 |
(let ((*print-pretty* t) |
(let ((*print-pretty* t) |
188 |
(*print-case* :downcase)) |
(*print-case* :downcase)) |
395 |
(cond |
(cond |
396 |
((subtypep t1 t2) `(complex ,(upgraded-complex-part-type t2))) |
((subtypep t1 t2) `(complex ,(upgraded-complex-part-type t2))) |
397 |
((subtypep t2 t1) `(complex ,(upgraded-complex-part-type t1))) |
((subtypep t2 t1) `(complex ,(upgraded-complex-part-type t1))) |
398 |
|
((and (subtypep t1 'rational) |
399 |
|
(subtypep t2 'rational)) |
400 |
|
`(complex rational)) |
401 |
(t |
(t |
402 |
`(complex ,(upgraded-complex-part-type `(or ,t1 ,t2))))))) |
`(complex ,(upgraded-complex-part-type `(or ,t1 ,t2))))))) |
403 |
(1 `(eql ,val)))) |
(1 `(eql ,val)))) |
469 |
`(integer ,start2 ,d))) |
`(integer ,start2 ,d))) |
470 |
|
|
471 |
|
|
472 |
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
473 |
|
|
474 |
|
(defgeneric replicate (obj) |
475 |
|
(:documentation "Copies the structure of a lisp object recursively, preserving sharing.")) |
476 |
|
|
477 |
|
(declaim (special *replicate-table*)) |
478 |
|
|
479 |
|
(defmethod replicate :around ((obj t)) |
480 |
|
"Wrapper to create a hash table for structure sharing, if none exists." |
481 |
|
(if (boundp '*replicate-table*) |
482 |
|
(call-next-method obj) |
483 |
|
(let ((*replicate-table* (make-hash-table))) |
484 |
|
(call-next-method obj)))) |
485 |
|
|
486 |
|
(defmethod replicate ((obj cons)) |
487 |
|
(or (gethash obj *replicate-table*) |
488 |
|
(let ((x (cons nil nil))) |
489 |
|
(setf (gethash obj *replicate-table*) x) |
490 |
|
(setf (car x) (replicate (car obj))) |
491 |
|
(setf (cdr x) (replicate (cdr obj))) |
492 |
|
x))) |
493 |
|
|
494 |
|
;;; Default method for objects without internal structure |
495 |
|
(defmethod replicate ((obj t)) obj) |
496 |
|
|
497 |
|
(defmethod replicate ((obj array)) |
498 |
|
(multiple-value-bind |
499 |
|
(new-obj old-leaf new-leaf) |
500 |
|
(replicate-displaced-array obj) |
501 |
|
(when new-leaf |
502 |
|
(loop for i below (array-total-size new-leaf) |
503 |
|
do (setf (row-major-aref new-leaf i) |
504 |
|
(row-major-aref old-leaf i)))) |
505 |
|
new-obj)) |
506 |
|
|
507 |
|
(defun replicate-displaced-array (obj) |
508 |
|
"Replicate the non-terminal (and not already replicated) arrays |
509 |
|
in a displaced array chain. Return the new root array, the |
510 |
|
old leaf array, and the new (but empty) leaf array. The latter |
511 |
|
two are NIL if the leaf did not have to be copied again." |
512 |
|
(or (gethash obj *replicate-table*) |
513 |
|
(multiple-value-bind |
514 |
|
(displaced-to displaced-index-offset) |
515 |
|
(array-displacement obj) |
516 |
|
(let ((dims (array-dimensions obj)) |
517 |
|
(element-type (array-element-type obj)) |
518 |
|
(fill-pointer (and (array-has-fill-pointer-p obj) |
519 |
|
(fill-pointer obj))) |
520 |
|
(adj (adjustable-array-p obj))) |
521 |
|
(if displaced-to |
522 |
|
;; The array is displaced |
523 |
|
;; Copy recursively |
524 |
|
(multiple-value-bind |
525 |
|
(new-displaced-to old-leaf new-leaf) |
526 |
|
(replicate-displaced-array displaced-to) |
527 |
|
(let ((new-obj (make-array dims :element-type element-type |
528 |
|
:fill-pointer fill-pointer |
529 |
|
:adjustable adj |
530 |
|
:displaced-to new-displaced-to |
531 |
|
:displaced-index-offset displaced-index-offset))) |
532 |
|
(setf (gethash obj *replicate-table*) new-obj) |
533 |
|
(values new-obj old-leaf new-leaf))) |
534 |
|
;; The array is not displaced |
535 |
|
;; This is the leaf array |
536 |
|
(let ((new-obj (make-array dims :element-type element-type |
537 |
|
:fill-pointer fill-pointer |
538 |
|
:adjustable adj))) |
539 |
|
(setf (gethash obj *replicate-table*) new-obj) |
540 |
|
(values new-obj obj new-obj))))))) |