From 56668abf17810cbb41a12afb8a5546c5ec542727 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Wed, 9 Mar 2005 02:27:06 +0000 Subject: [PATCH] Add an :ignore parameter, giving a condition type of errors to be ignored during testing --- ansi-tests/random-type-prop.lsp | 29 +++++++++++++++++++++++------ 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/ansi-tests/random-type-prop.lsp b/ansi-tests/random-type-prop.lsp index b675b206..f5a781c4 100644 --- a/ansi-tests/random-type-prop.lsp +++ b/ansi-tests/random-type-prop.lsp @@ -28,10 +28,15 @@ (reps *default-reps*) (enclosing-the nil) (cell *default-cell*) + (ignore nil) (test #'regression-test::equalp-with-case)) (assert (<= 1 minargs maxargs 20)) +(prog1 (dotimes (i reps) again + (handler-bind + #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) + #+lispworks () (let* ((param-names '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) @@ -110,11 +115,12 @@ (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (compile nil form))) - (result (if store-into-cell? - (let ((r (make-array nil :element-type upgraded-result-type))) - (apply fn r param-vals) - (aref r)) - (apply fn param-vals)))) + (result + (if store-into-cell? + (let ((r (make-array nil :element-type upgraded-result-type))) + (apply fn r param-vals) + (aref r)) + (apply fn param-vals)))) (setq *random-type-prop-result* (list :upgraded-result-type upgraded-result-type :form form @@ -122,7 +128,9 @@ :result result :rval rval)) (unless (funcall test result rval) - (return *random-type-prop-result*)))))) + (return *random-type-prop-result*)))) + #+allegro (excl::gc t) + )))) (defun make-random-arguments (types-or-funs) (let ((vals nil)) @@ -316,3 +324,12 @@ 'compiled-function 'function)) (1 t))) + +;;; Macro for defining random type prop tests + +(defmacro def-type-prop-test (name &body args) + `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." + (string name)) + (find-package :cl-test)) + (do-random-type-prop-tests ,@args) + nil)) -- GitLab