From 42047cda90fb96e9ca2bb32891c9f69860880e98 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sun, 16 Jan 2005 03:26:58 +0000 Subject: [PATCH] Extend make-random-type-containing to additional types --- ansi-tests/random-type-prop.lsp | 69 ++++++++++++++++++++++++++++----- 1 file changed, 60 insertions(+), 9 deletions(-) diff --git a/ansi-tests/random-type-prop.lsp b/ansi-tests/random-type-prop.lsp index 5e14f1a4..2db0ac3a 100644 --- a/ansi-tests/random-type-prop.lsp +++ b/ansi-tests/random-type-prop.lsp @@ -44,7 +44,10 @@ for tp in param-types when x collect `(type ,tp ,p))) - (rval (apply operator vals)) + (rval (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (eval (cons operator vals)))) (result-type (if (and enclosing-the (integerp rval)) (make-random-type-containing rval) t)) @@ -86,7 +89,7 @@ :vals vals :result result :rval rval)) - (unless (equal result rval) + (unless (rt::equalp-with-case result rval) (return *random-type-prop-result*)))))) (defmethod make-random-type-containing ((val integer)) @@ -94,7 +97,7 @@ (2 (let ((tp (random-from-seq '(t number real rational)))) (if #-allegro (coin) #+allegro nil (find-class tp) tp))) - (1 (random-from-seq '(integer signed-byte))) + (1 (random-from-seq '(integer signed-byte atom))) #- allegro (1 (find-class 'integer)) (2 `(eql ,val)) (2 (let* ((n1 (random 4)) @@ -114,10 +117,58 @@ (2 (if (>= val 0) `unsigned-byte (make-random-type-containing val))))) +(defmethod make-random-type-containing ((val character)) + (rcase + (1 `(eql ,val)) + (1 'character) + (1 (if (typep val 'base-char) 'base-char (make-random-type-containing val))) + (1 (if (typep val 'standard-char) 'standard-char (make-random-type-containing val))) + (1 (if (typep val 'extended-char) 'extended-char (make-random-type-containing val))) + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-character))) + (l2 (loop repeat n2 collect (make-random-character)))) + `(member ,@l1 ,val ,@l2))) + (1 (random-from-seq #(t atom))))) + +(defmethod make-random-type-containing ((val symbol)) + (rcase + (1 `(eql ,val)) + (3 'symbol) + (1 (if (null val) 'null (make-random-type-containing val))) + (1 (if (member val '(t nil)) 'boolean (make-random-type-containing val))) + (1 (if (keywordp val) 'keyword (make-random-type-containing val))) + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-symbol))) + (l2 (loop repeat n2 collect (make-random-symbol)))) + `(member ,@l1 ,val ,@l2))) + (1 (random-from-seq #(t atom))))) + +(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))))) + +(defmethod make-random-type-containing ((val rational)) + (rcase + (1 `(eql ,val)) + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) + (l2 (loop repeat n1 collect (make-random-element-of-type 'rational)))) + `(member ,@l1 ,val ,@l2))) + (1 `(rational ,val)) + (1 `(rational * ,val)) + (1 (let ((v (make-random-element-of-type 'rational))) + (if (<= v val) + `(rational ,v ,val) + `(rational ,val ,v)))) + )) - - - - - - + \ No newline at end of file -- GitLab