28 |
(reps *default-reps*) |
(reps *default-reps*) |
29 |
(enclosing-the nil) |
(enclosing-the nil) |
30 |
(cell *default-cell*) |
(cell *default-cell*) |
31 |
|
(ignore nil) |
32 |
(test #'regression-test::equalp-with-case)) |
(test #'regression-test::equalp-with-case)) |
33 |
(assert (<= 1 minargs maxargs 20)) |
(assert (<= 1 minargs maxargs 20)) |
34 |
|
(prog1 |
35 |
(dotimes (i reps) |
(dotimes (i reps) |
36 |
again |
again |
37 |
|
(handler-bind |
38 |
|
#-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) |
39 |
|
#+lispworks () |
40 |
(let* ((param-names |
(let* ((param-names |
41 |
'(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 |
'(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 |
42 |
p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) |
p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) |
115 |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
116 |
(warning #'muffle-warning)) |
(warning #'muffle-warning)) |
117 |
(compile nil form))) |
(compile nil form))) |
118 |
(result (if store-into-cell? |
(result |
119 |
(let ((r (make-array nil :element-type upgraded-result-type))) |
(if store-into-cell? |
120 |
(apply fn r param-vals) |
(let ((r (make-array nil :element-type upgraded-result-type))) |
121 |
(aref r)) |
(apply fn r param-vals) |
122 |
(apply fn param-vals)))) |
(aref r)) |
123 |
|
(apply fn param-vals)))) |
124 |
(setq *random-type-prop-result* |
(setq *random-type-prop-result* |
125 |
(list :upgraded-result-type upgraded-result-type |
(list :upgraded-result-type upgraded-result-type |
126 |
:form form |
:form form |
128 |
:result result |
:result result |
129 |
:rval rval)) |
:rval rval)) |
130 |
(unless (funcall test result rval) |
(unless (funcall test result rval) |
131 |
(return *random-type-prop-result*)))))) |
(return *random-type-prop-result*)))) |
132 |
|
#+allegro (excl::gc t) |
133 |
|
)))) |
134 |
|
|
135 |
(defun make-random-arguments (types-or-funs) |
(defun make-random-arguments (types-or-funs) |
136 |
(let ((vals nil)) |
(let ((vals nil)) |
324 |
'compiled-function |
'compiled-function |
325 |
'function)) |
'function)) |
326 |
(1 t))) |
(1 t))) |
327 |
|
|
328 |
|
;;; Macro for defining random type prop tests |
329 |
|
|
330 |
|
(defmacro def-type-prop-test (name &body args) |
331 |
|
`(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." |
332 |
|
(string name)) |
333 |
|
(find-package :cl-test)) |
334 |
|
(do-random-type-prop-tests ,@args) |
335 |
|
nil)) |