44 |
for tp in param-types |
for tp in param-types |
45 |
when x |
when x |
46 |
collect `(type ,tp ,p))) |
collect `(type ,tp ,p))) |
47 |
(rval (apply operator vals)) |
(rval (cl:handler-bind |
48 |
|
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
49 |
|
(warning #'muffle-warning)) |
50 |
|
(eval (cons operator vals)))) |
51 |
(result-type (if (and enclosing-the (integerp rval)) |
(result-type (if (and enclosing-the (integerp rval)) |
52 |
(make-random-type-containing rval) |
(make-random-type-containing rval) |
53 |
t)) |
t)) |
89 |
:vals vals |
:vals vals |
90 |
:result result |
:result result |
91 |
:rval rval)) |
:rval rval)) |
92 |
(unless (equal result rval) |
(unless (rt::equalp-with-case result rval) |
93 |
(return *random-type-prop-result*)))))) |
(return *random-type-prop-result*)))))) |
94 |
|
|
95 |
(defmethod make-random-type-containing ((val integer)) |
(defmethod make-random-type-containing ((val integer)) |
97 |
(2 (let ((tp (random-from-seq '(t number real rational)))) |
(2 (let ((tp (random-from-seq '(t number real rational)))) |
98 |
(if #-allegro (coin) #+allegro nil |
(if #-allegro (coin) #+allegro nil |
99 |
(find-class tp) tp))) |
(find-class tp) tp))) |
100 |
(1 (random-from-seq '(integer signed-byte))) |
(1 (random-from-seq '(integer signed-byte atom))) |
101 |
#- allegro (1 (find-class 'integer)) |
#- allegro (1 (find-class 'integer)) |
102 |
(2 `(eql ,val)) |
(2 `(eql ,val)) |
103 |
(2 (let* ((n1 (random 4)) |
(2 (let* ((n1 (random 4)) |
117 |
(2 (if (>= val 0) `unsigned-byte |
(2 (if (>= val 0) `unsigned-byte |
118 |
(make-random-type-containing val))))) |
(make-random-type-containing val))))) |
119 |
|
|
120 |
|
(defmethod make-random-type-containing ((val character)) |
121 |
|
(rcase |
122 |
|
(1 `(eql ,val)) |
123 |
|
(1 'character) |
124 |
|
(1 (if (typep val 'base-char) 'base-char (make-random-type-containing val))) |
125 |
|
(1 (if (typep val 'standard-char) 'standard-char (make-random-type-containing val))) |
126 |
|
(1 (if (typep val 'extended-char) 'extended-char (make-random-type-containing val))) |
127 |
|
(1 (let* ((n1 (random 4)) |
128 |
|
(n2 (random 4)) |
129 |
|
(l1 (loop repeat n1 collect (make-random-character))) |
130 |
|
(l2 (loop repeat n2 collect (make-random-character)))) |
131 |
|
`(member ,@l1 ,val ,@l2))) |
132 |
|
(1 (random-from-seq #(t atom))))) |
133 |
|
|
134 |
|
(defmethod make-random-type-containing ((val symbol)) |
135 |
|
(rcase |
136 |
|
(1 `(eql ,val)) |
137 |
|
(3 'symbol) |
138 |
|
(1 (if (null val) 'null (make-random-type-containing val))) |
139 |
|
(1 (if (member val '(t nil)) 'boolean (make-random-type-containing val))) |
140 |
|
(1 (if (keywordp val) 'keyword (make-random-type-containing val))) |
141 |
|
(1 (let* ((n1 (random 4)) |
142 |
|
(n2 (random 4)) |
143 |
|
(l1 (loop repeat n1 collect (make-random-symbol))) |
144 |
|
(l2 (loop repeat n2 collect (make-random-symbol)))) |
145 |
|
`(member ,@l1 ,val ,@l2))) |
146 |
|
(1 (random-from-seq #(t atom))))) |
147 |
|
|
148 |
|
(defun make-random-character () |
149 |
|
(rcase |
150 |
|
(2 (random-from-seq +standard-chars+)) |
151 |
|
(2 (or (code-char (random (min 256 char-code-limit))) |
152 |
|
(make-random-character))) |
153 |
|
(1 (or (code-char (random (min (ash 1 16) char-code-limit))) |
154 |
|
(make-random-character))) |
155 |
|
(1 (or (code-char (random (min (ash 1 24) char-code-limit))) |
156 |
|
(make-random-character))))) |
157 |
|
|
158 |
|
(defmethod make-random-type-containing ((val rational)) |
159 |
|
(rcase |
160 |
|
(1 `(eql ,val)) |
161 |
|
(1 (let* ((n1 (random 4)) |
162 |
|
(n2 (random 4)) |
163 |
|
(l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) |
164 |
|
(l2 (loop repeat n1 collect (make-random-element-of-type 'rational)))) |
165 |
|
`(member ,@l1 ,val ,@l2))) |
166 |
|
(1 `(rational ,val)) |
167 |
|
(1 `(rational * ,val)) |
168 |
|
(1 (let ((v (make-random-element-of-type 'rational))) |
169 |
|
(if (<= v val) |
170 |
|
`(rational ,v ,val) |
171 |
|
`(rational ,val ,v)))) |
172 |
|
)) |
173 |
|
|
174 |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|