1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Thu Dec 23 20:39:22 2004 |
---|
4 | ;;;; Contains: Randomized tests of type propagation in the compiler |
---|
5 | |
---|
6 | (in-package :cl-test) |
---|
7 | |
---|
8 | (eval-when (:compile-toplevel :load-toplevel) |
---|
9 | (compile-and-load "random-aux.lsp") |
---|
10 | (compile-and-load "random-int-form.lsp")) |
---|
11 | |
---|
12 | (defvar *print-random-type-prop-input* nil) |
---|
13 | (defparameter *random-type-prop-result* nil) |
---|
14 | |
---|
15 | (declaim (special *param-types* *params* *is-var?* *form*)) |
---|
16 | (declaim (special *replicate-type*)) |
---|
17 | |
---|
18 | (defparameter *default-reps* 1000) |
---|
19 | (defparameter *default-cell* nil) |
---|
20 | (defparameter *default-ignore* 'arithmetic-error) |
---|
21 | (defparameter *default-arg-the* t) |
---|
22 | |
---|
23 | ;;; |
---|
24 | ;;; The random type prop tester takes three required arguments: |
---|
25 | ;;; |
---|
26 | ;;; operator A lisp operator (either a symbol or a lambda form) |
---|
27 | ;;; arg-types A list consisting either of certain kinds of lisp types |
---|
28 | ;;; (that make-random-element-of-type understands) and/or |
---|
29 | ;;; functions that yield types. |
---|
30 | ;;; minargs Minimum number of arguments to be given to the operator. |
---|
31 | ;;; Must be a positive integer <= maxargs. |
---|
32 | ;;; |
---|
33 | ;;; There are also keyword arguments, some with defaults given by special |
---|
34 | ;;; variables. |
---|
35 | ;;; |
---|
36 | ;;; The random type prop tester generates between minargs and maxargs |
---|
37 | ;;; (maxargs defaults to minargs) random arguments. The type of each |
---|
38 | ;;; argument is given by the corresponding type in arg-types (or by rest-type, |
---|
39 | ;;; if there aren't enough elements of arg-types). If the element of arg-types |
---|
40 | ;;; is a function, the type for the parameter is produced by calling the function |
---|
41 | ;;; with the previously generated actual parameters as its arguments. |
---|
42 | ;;; |
---|
43 | ;;; The list of parameters is stored into the special variable *params*. |
---|
44 | ;;; |
---|
45 | ;;; The tester evaluates (operator . arguments), and also builds a lambda |
---|
46 | ;;; form to be compiled and called on (a subset of) the parameters. The lambda |
---|
47 | ;;; form is stored in the special variable *form*. |
---|
48 | ;;; |
---|
49 | ;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests |
---|
50 | ;;; in a deftest form. See random-type-prop-tests.lsp (and subfiles) for examples |
---|
51 | ;;; of its use testing CL builtin operators. To use it: |
---|
52 | ;;; |
---|
53 | ;;; (load "gclload1.lsp") |
---|
54 | ;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles |
---|
55 | ;;; (compile-and-load "random-type-prop.lsp") |
---|
56 | ;;; (in-package :cl-test) |
---|
57 | ;;; (load "random-type-prop-tests.lsp") |
---|
58 | ;;; (let (*catch-errors*) (do-test '<testname>)) |
---|
59 | ;;; or (let (*catch-errors*) (do-tests)) |
---|
60 | ;;; |
---|
61 | ;;; Running all the tests may take a while, particularly on lisps with slow compilers. |
---|
62 | ;;; |
---|
63 | ;;; |
---|
64 | ;;; Keyword arguments to do-random-type-prop-tests: |
---|
65 | ;;; |
---|
66 | ;;; Argument Default Meaning |
---|
67 | ;;; |
---|
68 | ;;; maxargs minargs Maximum number of actual parameters to generate (max 20). |
---|
69 | ;;; rest-type t Type of arguments beyond those specified in arg-types |
---|
70 | ;;; reps *default-reps* Number of repetitions to try before stopping. |
---|
71 | ;;; The default is controlled by a special variable that |
---|
72 | ;;; is initially 1000. |
---|
73 | ;;; enclosing-the nil If true, with prob 1/2 randomly generate an enclosing |
---|
74 | ;;; (THE ...) form around the form invoking the operator. |
---|
75 | ;;; arg-the *default-arg-the* If true (which is the initial value of the default |
---|
76 | ;;; special variable), with probability 1/2 randomly generate |
---|
77 | ;;; a (THE ...) form around each actual parameter. |
---|
78 | ;;; cell *default-cell* If true (default is NIL), store the result into a rank-0 |
---|
79 | ;;; array of specialized type. This enables one to test |
---|
80 | ;;; forms where the result will be unboxed. Otherwise, just |
---|
81 | ;;; return the values. |
---|
82 | ;;; ignore *default-ignore* Ignore conditions that are elements of IGNORE. Default is |
---|
83 | ;;; ARITHMETIC-ERROR. |
---|
84 | ;;; test rt::equalp-with-case The test function used to compare outputs. It's |
---|
85 | ;;; also handy to use #'approx= to handle approximate equality |
---|
86 | ;;; when testing floating point computations, where compiled code |
---|
87 | ;;; may have different roundoff errors. |
---|
88 | ;;; replicate nil Cause arguments to be copied (preserving sharing in conses |
---|
89 | ;;; and arrays) before applying the operator. This is used to test |
---|
90 | ;;; destructive operators. |
---|
91 | ;;; |
---|
92 | ;;; |
---|
93 | |
---|
94 | (defun do-random-type-prop-tests |
---|
95 | (operator arg-types minargs |
---|
96 | &key |
---|
97 | (maxargs minargs) |
---|
98 | (rest-type t) |
---|
99 | (reps *default-reps*) |
---|
100 | (enclosing-the nil) |
---|
101 | (arg-the *default-arg-the*) |
---|
102 | (cell *default-cell*) |
---|
103 | (ignore *default-ignore*) |
---|
104 | (test #'regression-test::equalp-with-case) |
---|
105 | (replicate nil replicate-p)) |
---|
106 | (assert (<= 1 minargs maxargs 20)) |
---|
107 | (prog1 |
---|
108 | (dotimes (i reps) |
---|
109 | again |
---|
110 | (handler-bind |
---|
111 | #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) |
---|
112 | #+lispworks () |
---|
113 | (let* ((param-names |
---|
114 | '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 |
---|
115 | p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) |
---|
116 | (nargs (+ minargs (random (- maxargs minargs -1)))) |
---|
117 | (types (subseq |
---|
118 | (append arg-types |
---|
119 | (make-list (max 0 (- nargs (length arg-types))) |
---|
120 | :initial-element rest-type)) |
---|
121 | 0 nargs)) |
---|
122 | (replicate (if replicate-p replicate |
---|
123 | (mapcar (constantly nil) types))) |
---|
124 | ; (vals (mapcar #'make-random-element-of-type types)) |
---|
125 | (vals (setq *params* |
---|
126 | (or (make-random-arguments types) (go again)))) |
---|
127 | (vals |
---|
128 | (if replicate |
---|
129 | (mapcar #'replicate vals) |
---|
130 | vals)) |
---|
131 | (is-var? (if (consp replicate) |
---|
132 | (progn |
---|
133 | (assert (= (length replicate) (length vals))) |
---|
134 | (loop for x in replicate collect (or x (coin)))) |
---|
135 | (loop repeat (length vals) collect (coin)))) |
---|
136 | (*is-var?* is-var?) |
---|
137 | (params (loop for x in is-var? |
---|
138 | for p in param-names |
---|
139 | when x collect p)) |
---|
140 | (param-types (mapcar #'make-random-type-containing vals replicate)) |
---|
141 | (*param-types* param-types) |
---|
142 | (type-decls (loop for x in is-var? |
---|
143 | for p in param-names |
---|
144 | for tp in param-types |
---|
145 | when x |
---|
146 | collect `(type ,tp ,p))) |
---|
147 | (rval (cl:handler-bind |
---|
148 | (#+sbcl (sb-ext::compiler-note #'muffle-warning) |
---|
149 | (warning #'muffle-warning)) |
---|
150 | (let* ((vals (if replicate (mapcar #'replicate vals) vals)) |
---|
151 | (eval-form (cons operator (loop for v in vals |
---|
152 | collect `(quote ,v))))) |
---|
153 | ;; (print eval-form) (terpri) |
---|
154 | ;; (dotimes (i 100) (eval eval-form)) |
---|
155 | (eval eval-form)))) |
---|
156 | (result-type (if (and enclosing-the (integerp rval)) |
---|
157 | (make-random-type-containing rval) |
---|
158 | t)) |
---|
159 | (expr `(,operator ,@(loop for x in is-var? |
---|
160 | for v in vals |
---|
161 | for r in replicate |
---|
162 | for p in param-names |
---|
163 | collect (if x |
---|
164 | (if (and arg-the (coin)) |
---|
165 | (let ((tp (make-random-type-containing v r))) |
---|
166 | `(the ,tp ,p)) |
---|
167 | p) |
---|
168 | (if (or (consp v) |
---|
169 | (and (symbolp v) (not (or (keywordp v) |
---|
170 | (member v '(nil t)))))) |
---|
171 | `(quote ,v) |
---|
172 | v))))) |
---|
173 | (speed (random 4)) |
---|
174 | (space (random 4)) |
---|
175 | (safety #-allegro (random 4) |
---|
176 | #+allegro (1+ (random 3))) |
---|
177 | (debug (random 4)) |
---|
178 | (store-into-cell? (and cell (coin))) |
---|
179 | (upgraded-result-type (and store-into-cell? |
---|
180 | (upgraded-array-element-type `(eql ,rval)))) |
---|
181 | (form |
---|
182 | (setq *form* |
---|
183 | `(lambda (,@(when store-into-cell? '(r)) ,@params) |
---|
184 | (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) |
---|
185 | ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) |
---|
186 | ,@ type-decls) |
---|
187 | ,(let ((result-form |
---|
188 | (if enclosing-the `(the ,result-type ,expr) expr))) |
---|
189 | (if store-into-cell? |
---|
190 | `(setf (aref r) ,result-form) |
---|
191 | result-form))))) |
---|
192 | ) |
---|
193 | (when *print-random-type-prop-input* |
---|
194 | (let ((*print-pretty* t) |
---|
195 | (*print-case* :downcase)) |
---|
196 | (print (list :form form :vals vals)))) |
---|
197 | (finish-output) |
---|
198 | (let* ((param-vals (loop for x in is-var? |
---|
199 | for v in vals |
---|
200 | when x collect v)) |
---|
201 | (fn (cl:handler-bind |
---|
202 | (#+sbcl (sb-ext::compiler-note #'muffle-warning) |
---|
203 | (warning #'muffle-warning)) |
---|
204 | (compile nil form))) |
---|
205 | (result |
---|
206 | (if store-into-cell? |
---|
207 | (let ((r (make-array nil :element-type upgraded-result-type))) |
---|
208 | (apply fn r param-vals) |
---|
209 | (aref r)) |
---|
210 | (apply fn param-vals)))) |
---|
211 | (setq *random-type-prop-result* |
---|
212 | (list :upgraded-result-type upgraded-result-type |
---|
213 | :form form |
---|
214 | :vals vals |
---|
215 | :result result |
---|
216 | :rval rval)) |
---|
217 | (unless (funcall test result rval) |
---|
218 | (return *random-type-prop-result*)))) |
---|
219 | ;; #+allegro (excl::gc t) |
---|
220 | )))) |
---|
221 | |
---|
222 | (defun make-random-arguments (types-or-funs) |
---|
223 | (let ((vals nil)) |
---|
224 | (loop for type-or-fun in types-or-funs |
---|
225 | for type = (or (typecase type-or-fun |
---|
226 | ((and function (not symbol)) |
---|
227 | (apply type-or-fun vals)) |
---|
228 | (t type-or-fun)) |
---|
229 | (return-from make-random-arguments nil) ;; null type |
---|
230 | ) |
---|
231 | for val = (make-random-element-of-type type) |
---|
232 | do (setf vals (nconc vals (list val)))) |
---|
233 | ;; (dolist (v vals) (describe v)) |
---|
234 | vals)) |
---|
235 | |
---|
236 | (defmacro defmethods (name &rest bodies) |
---|
237 | `(progn |
---|
238 | ,@(mapcar |
---|
239 | #'(lambda (body) `(defmethod ,name ,@body)) |
---|
240 | bodies))) |
---|
241 | |
---|
242 | (defgeneric make-random-type-containing* (val) |
---|
243 | (:method-combination randomized) |
---|
244 | (:documentation "Produce a random type containing VAL. If the special |
---|
245 | variable *REPLICATE-TYPE* is true, and the value is mutable, then do not |
---|
246 | use the value in MEMBER or EQL type specifiers.")) |
---|
247 | |
---|
248 | (defun make-random-type-containing (type &optional *replicate-type*) |
---|
249 | (declare (special *replicate-type*)) |
---|
250 | (make-random-type-containing* type)) |
---|
251 | |
---|
252 | (defmethods make-random-type-containing* |
---|
253 | (4 ((val t)) |
---|
254 | (declare (special *replicate-type*)) |
---|
255 | (rcase |
---|
256 | (1 t) |
---|
257 | (1 (if (consp val) 'cons 'atom)) |
---|
258 | (1 (if *replicate-type* (make-random-type-containing* val) |
---|
259 | `(eql ,val))) |
---|
260 | (1 |
---|
261 | (if *replicate-type* (make-random-type-containing* val) |
---|
262 | (let* ((n1 (random 4)) |
---|
263 | (n2 (random 4)) |
---|
264 | ;; Replace these calls with (make-random-element-of-type t) |
---|
265 | ;; at some point |
---|
266 | (l1 (loop repeat n1 collect (random-leaf))) |
---|
267 | (l2 (loop repeat n2 collect (random-leaf)))) |
---|
268 | `(member ,@l1 ,val ,@l2)))))) |
---|
269 | |
---|
270 | (1 ((val standard-object)) 'standard-object) |
---|
271 | (1 ((val structure-object)) 'structure-object) |
---|
272 | (1 ((val class)) 'class) |
---|
273 | (1 ((val standard-class)) 'standard-class) |
---|
274 | (1 ((val structure-class)) 'structure-class) |
---|
275 | (1 ((val number)) 'number) |
---|
276 | (1 ((val real)) 'real) |
---|
277 | (1 ((val ratio)) 'ratio) |
---|
278 | |
---|
279 | (1 ((val integer)) |
---|
280 | (rcase |
---|
281 | (1 'integer) |
---|
282 | (1 'signed-byte) |
---|
283 | (1 (let* ((n1 (random 4)) |
---|
284 | (n2 (random 4)) |
---|
285 | (l1 (loop repeat n1 collect (make-random-integer))) |
---|
286 | (l2 (loop repeat n2 collect (make-random-integer)))) |
---|
287 | `(member ,@l1 ,val ,@l2))) |
---|
288 | (1 (let ((lo (abs (make-random-integer)))) |
---|
289 | `(integer ,(- val lo)))) |
---|
290 | (2 (let ((lo (abs (make-random-integer)))) |
---|
291 | `(integer ,(- val lo) *))) |
---|
292 | (2 (let ((hi (abs (make-random-integer)))) |
---|
293 | `(integer * ,(+ val hi)))) |
---|
294 | (4 (let ((lo (abs (make-random-integer))) |
---|
295 | (hi (abs (make-random-integer)))) |
---|
296 | `(integer ,(- val lo) ,(+ val hi)))) |
---|
297 | (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) |
---|
298 | |
---|
299 | (2 ((val character)) |
---|
300 | (rcase |
---|
301 | (1 'character) |
---|
302 | (1 (if (typep val 'base-char) 'base-char |
---|
303 | #-sbcl 'extended-char |
---|
304 | #+sbcl (throw 'fail nil) |
---|
305 | )) |
---|
306 | (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil))) |
---|
307 | (1 (let* ((n1 (random 4)) |
---|
308 | (n2 (random 4)) |
---|
309 | (l1 (loop repeat n1 collect (make-random-character))) |
---|
310 | (l2 (loop repeat n2 collect (make-random-character)))) |
---|
311 | `(member ,@l1 ,val ,@l2))))) |
---|
312 | |
---|
313 | (1 ((val null)) 'null) |
---|
314 | |
---|
315 | (2 ((val symbol)) |
---|
316 | (rcase |
---|
317 | (1 'symbol) |
---|
318 | (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil)))) |
---|
319 | (1 (let* ((n1 (random 4)) |
---|
320 | (n2 (random 4)) |
---|
321 | (l1 (loop repeat n1 collect (make-random-symbol))) |
---|
322 | (l2 (loop repeat n2 collect (make-random-symbol)))) |
---|
323 | `(member ,@l1 ,val ,@l2))))) |
---|
324 | |
---|
325 | (1 ((val rational)) |
---|
326 | (rcase |
---|
327 | (1 'rational) |
---|
328 | (1 (let* ((n1 (random 4)) |
---|
329 | (n2 (random 4)) |
---|
330 | (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) |
---|
331 | (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) |
---|
332 | `(member ,@l1 ,val ,@l2))) |
---|
333 | (1 `(rational ,val)) |
---|
334 | (1 `(rational * ,val)) |
---|
335 | (1 (let ((v (make-random-element-of-type 'rational))) |
---|
336 | (if (<= v val) |
---|
337 | `(rational ,v ,val) |
---|
338 | `(rational ,val ,v)))))) |
---|
339 | |
---|
340 | (1 ((val float)) |
---|
341 | (rcase |
---|
342 | (1 (let* ((n1 (random 4)) |
---|
343 | (n2 (random 4)) |
---|
344 | (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) |
---|
345 | (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) |
---|
346 | `(member ,@l1 ,val ,@l2))) |
---|
347 | (1 (let ((names (float-types-containing val))) |
---|
348 | (random-from-seq names))) |
---|
349 | (1 (let ((name (random-from-seq (float-types-containing val)))) |
---|
350 | (if (>= val 0) |
---|
351 | `(,name ,(coerce 0 name) ,val) |
---|
352 | `(,name ,val ,(coerce 0 name))))))) |
---|
353 | ) |
---|
354 | |
---|
355 | (defun float-types-containing (val) |
---|
356 | (loop for n in '(short-float single-float double-float long-float float) |
---|
357 | when (typep val n) |
---|
358 | collect n)) |
---|
359 | |
---|
360 | (defun make-random-array-dimension-spec (array dim-index) |
---|
361 | (assert (<= 0 dim-index)) |
---|
362 | (assert (< dim-index (array-rank array))) |
---|
363 | (let ((dim (array-dimension array dim-index))) |
---|
364 | (rcase (1 '*) (1 dim)))) |
---|
365 | |
---|
366 | ;;; More methods |
---|
367 | (defmethods make-random-type-containing* |
---|
368 | (3 ((val bit-vector)) |
---|
369 | (let ((root (if (and (coin) |
---|
370 | (typep val 'simple-bit-vector)) |
---|
371 | 'simple-bit-vector |
---|
372 | 'bit-vector))) |
---|
373 | (rcase (1 root) |
---|
374 | (1 `(,root)) |
---|
375 | (3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
---|
376 | |
---|
377 | (3 ((val vector)) |
---|
378 | (let ((root 'vector) |
---|
379 | (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) |
---|
380 | (etype (rcase (1 '*) |
---|
381 | (1 (array-element-type val)) |
---|
382 | ;; Add rule for creating new element types? |
---|
383 | ))) |
---|
384 | (rcase (1 alt-root) |
---|
385 | (1 `(,alt-root)) |
---|
386 | (1 `(,root ,etype)) |
---|
387 | (2 (if (and (simple-vector-p val) (coin)) |
---|
388 | `(simple-vector ,(make-random-array-dimension-spec val 0)) |
---|
389 | `(,root ,etype ,(make-random-array-dimension-spec val 0))))))) |
---|
390 | |
---|
391 | (3 ((val array)) |
---|
392 | (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) |
---|
393 | (etype (rcase (1 (array-element-type val)) (1 '*))) |
---|
394 | (rank (array-rank val))) |
---|
395 | (rcase |
---|
396 | (1 root) |
---|
397 | (1 `(,root)) |
---|
398 | (1 `(,root ,etype)) |
---|
399 | (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) |
---|
400 | (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) |
---|
401 | #-ecl (1 `(,root ,etype ,rank))))) |
---|
402 | |
---|
403 | (3 ((val string)) |
---|
404 | (let ((root (cond |
---|
405 | ((and (coin) |
---|
406 | (typep val 'base-string)) |
---|
407 | (cond |
---|
408 | ((and (coin) (typep val 'simple-base-string)) |
---|
409 | 'simple-base-string) |
---|
410 | (t 'base-string))) |
---|
411 | ((and (coin) |
---|
412 | (typep val 'simple-string)) |
---|
413 | 'simple-string) |
---|
414 | (t 'string)))) |
---|
415 | (rcase (1 root) |
---|
416 | (1 `(,root)) |
---|
417 | (3 `(,root ,(make-random-array-dimension-spec val 0)))))) |
---|
418 | |
---|
419 | (1 ((val list)) 'list) |
---|
420 | |
---|
421 | (1 ((val cons)) |
---|
422 | (rcase |
---|
423 | (1 'cons) |
---|
424 | (2 `(cons ,(make-random-type-containing* (car val)) |
---|
425 | ,(make-random-type-containing* (cdr val)))) |
---|
426 | (1 `(cons ,(make-random-type-containing* (car val)) |
---|
427 | ,(random-from-seq #(t *)))) |
---|
428 | (1 `(cons ,(make-random-type-containing* (car val)))) |
---|
429 | (1 `(cons ,(random-from-seq #(t *)) |
---|
430 | ,(make-random-type-containing* (cdr val)) |
---|
431 | )))) |
---|
432 | |
---|
433 | (1 ((val complex)) |
---|
434 | (rcase |
---|
435 | (1 'complex) |
---|
436 | #-gcl |
---|
437 | (1 (let* ((t1 (type-of (realpart val))) |
---|
438 | (t2 (type-of (imagpart val))) |
---|
439 | (part-type |
---|
440 | (cond |
---|
441 | ((subtypep t1 t2) (upgraded-complex-part-type t2)) |
---|
442 | ((subtypep t2 t1) (upgraded-complex-part-type t1)) |
---|
443 | ((and (subtypep t1 'rational) |
---|
444 | (subtypep t2 'rational)) |
---|
445 | 'rational) |
---|
446 | (t |
---|
447 | (upgraded-complex-part-type `(or ,t1 ,t2)))))) |
---|
448 | (if (subtypep 'real part-type) |
---|
449 | '(complex real) |
---|
450 | `(complex ,part-type)))))) |
---|
451 | |
---|
452 | (1 ((val generic-function)) 'generic-function) |
---|
453 | (1 ((val function)) |
---|
454 | (rcase |
---|
455 | (1 'function) |
---|
456 | (1 (if (typep val 'compiled-function) |
---|
457 | 'compiled-function |
---|
458 | 'function)))) |
---|
459 | ) |
---|
460 | |
---|
461 | ;;; Macro for defining random type prop tests |
---|
462 | |
---|
463 | (defmacro def-type-prop-test (name &body args) |
---|
464 | `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." |
---|
465 | (string name)) |
---|
466 | (find-package :cl-test)) |
---|
467 | (do-random-type-prop-tests ,@args) |
---|
468 | nil)) |
---|
469 | |
---|
470 | ;;; Function used in constructing list types for some random type prop tests |
---|
471 | |
---|
472 | (defun make-list-type (length &optional (rest-type 'null) (element-type t)) |
---|
473 | (let ((result rest-type)) |
---|
474 | (loop repeat length |
---|
475 | do (setq result `(cons ,element-type ,result))) |
---|
476 | result)) |
---|
477 | |
---|
478 | (defun make-sequence-type (length &optional (element-type t)) |
---|
479 | (rcase |
---|
480 | (1 `(vector ,element-type ,length)) |
---|
481 | (1 `(array ,element-type (,length))) |
---|
482 | (1 `(simple-array ,element-type (,length))) |
---|
483 | (2 (make-list-type length 'null element-type)))) |
---|
484 | |
---|
485 | (defun make-random-sequence-type-containing (element &optional *replicate-type*) |
---|
486 | (make-sequence-type (random 10) (make-random-type-containing* element))) |
---|
487 | |
---|
488 | (defun same-set-p (set1 set2 &rest args &key key test test-not) |
---|
489 | (declare (ignorable key test test-not)) |
---|
490 | (and (apply #'subsetp set1 set2 args) |
---|
491 | (apply #'subsetp set2 set2 args) |
---|
492 | t)) |
---|
493 | |
---|
494 | (defun index-type-for-dim (dim) |
---|
495 | "Returns a function that computes integer type for valid indices |
---|
496 | of an array dimension, or NIL if there are none." |
---|
497 | #'(lambda (array &rest other) |
---|
498 | (declare (ignore other)) |
---|
499 | (let ((d (array-dimension array dim))) |
---|
500 | (and (> d 0) `(integer 0 (,d)))))) |
---|
501 | |
---|
502 | (defun index-type-for-v1 (v1 &rest other) |
---|
503 | "Computes integer type for valid indices for the first of two vectors" |
---|
504 | (declare (ignore other)) |
---|
505 | (let ((d (length v1))) `(integer 0 ,d))) |
---|
506 | |
---|
507 | (defun index-type-for-v2 (v1 v2 &rest other) |
---|
508 | "Computes integer type for valid indices for the second of two vectors" |
---|
509 | (declare (ignore v1 other)) |
---|
510 | (let ((d (length v2))) `(integer 0 ,d))) |
---|
511 | |
---|
512 | (defun end-type-for-v1 (v1 v2 &rest other) |
---|
513 | (declare (ignore v2)) |
---|
514 | (let ((d (length v1)) |
---|
515 | (start1 (or (cadr (member :start1 other)) 0))) |
---|
516 | `(integer ,start1 ,d))) |
---|
517 | |
---|
518 | (defun end-type-for-v2 (v1 v2 &rest other) |
---|
519 | (declare (ignore v1)) |
---|
520 | (let ((d (length v2)) |
---|
521 | (start2 (or (cadr (member :start2 other)) 0))) |
---|
522 | `(integer ,start2 ,d))) |
---|
523 | |
---|
524 | |
---|
525 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
526 | |
---|
527 | (defgeneric replicate (obj) |
---|
528 | (:documentation "Copies the structure of a lisp object recursively, preserving sharing.")) |
---|
529 | |
---|
530 | (defmacro replicate-with ((source-obj dest-obj copy-form) &body body) |
---|
531 | `(or (gethash ,source-obj *replicate-table*) |
---|
532 | (let ((,dest-obj ,copy-form)) |
---|
533 | (setf (gethash ,source-obj *replicate-table*) ,dest-obj) |
---|
534 | ,@body |
---|
535 | ,dest-obj))) |
---|
536 | |
---|
537 | (declaim (special *replicate-table*)) |
---|
538 | |
---|
539 | (defmethod replicate :around ((obj t)) |
---|
540 | "Wrapper to create a hash table for structure sharing, if none exists." |
---|
541 | (if (boundp '*replicate-table*) |
---|
542 | (call-next-method obj) |
---|
543 | (let ((*replicate-table* (make-hash-table))) |
---|
544 | (call-next-method obj)))) |
---|
545 | |
---|
546 | (defmethod replicate ((obj cons)) |
---|
547 | (or (gethash obj *replicate-table*) |
---|
548 | (let ((x (cons nil nil))) |
---|
549 | (setf (gethash obj *replicate-table*) x) |
---|
550 | (setf (car x) (replicate (car obj))) |
---|
551 | (setf (cdr x) (replicate (cdr obj))) |
---|
552 | x))) |
---|
553 | |
---|
554 | ;;; Default method for objects without internal structure |
---|
555 | (defmethod replicate ((obj t)) obj) |
---|
556 | |
---|
557 | (defmethod replicate ((obj array)) |
---|
558 | (multiple-value-bind |
---|
559 | (new-obj old-leaf new-leaf) |
---|
560 | (replicate-displaced-array obj) |
---|
561 | (when new-leaf |
---|
562 | (loop for i below (array-total-size new-leaf) |
---|
563 | do (setf (row-major-aref new-leaf i) |
---|
564 | (row-major-aref old-leaf i)))) |
---|
565 | new-obj)) |
---|
566 | |
---|
567 | (defun replicate-displaced-array (obj) |
---|
568 | "Replicate the non-terminal (and not already replicated) arrays |
---|
569 | in a displaced array chain. Return the new root array, the |
---|
570 | old leaf array, and the new (but empty) leaf array. The latter |
---|
571 | two are NIL if the leaf did not have to be copied again." |
---|
572 | (or (gethash obj *replicate-table*) |
---|
573 | (multiple-value-bind |
---|
574 | (displaced-to displaced-index-offset) |
---|
575 | (array-displacement obj) |
---|
576 | (let ((dims (array-dimensions obj)) |
---|
577 | (element-type (array-element-type obj)) |
---|
578 | (fill-pointer (and (array-has-fill-pointer-p obj) |
---|
579 | (fill-pointer obj))) |
---|
580 | (adj (adjustable-array-p obj))) |
---|
581 | (if displaced-to |
---|
582 | ;; The array is displaced |
---|
583 | ;; Copy recursively |
---|
584 | (multiple-value-bind |
---|
585 | (new-displaced-to old-leaf new-leaf) |
---|
586 | (replicate-displaced-array displaced-to) |
---|
587 | (let ((new-obj (make-array dims :element-type element-type |
---|
588 | :fill-pointer fill-pointer |
---|
589 | :adjustable adj |
---|
590 | :displaced-to new-displaced-to |
---|
591 | :displaced-index-offset displaced-index-offset))) |
---|
592 | (setf (gethash obj *replicate-table*) new-obj) |
---|
593 | (values new-obj old-leaf new-leaf))) |
---|
594 | ;; The array is not displaced |
---|
595 | ;; This is the leaf array |
---|
596 | (let ((new-obj (make-array dims :element-type element-type |
---|
597 | :fill-pointer fill-pointer |
---|
598 | :adjustable adj))) |
---|
599 | (setf (gethash obj *replicate-table*) new-obj) |
---|
600 | (values new-obj obj new-obj))))))) |
---|
601 | |
---|
602 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
603 | |
---|
604 | (declaim (special *isomorphism-table*)) |
---|
605 | |
---|
606 | (defun isomorphic-p (obj1 obj2) |
---|
607 | (let ((*isomorphism-table* (make-hash-table))) |
---|
608 | (isomorphic-p* obj1 obj2))) |
---|
609 | |
---|
610 | (defgeneric isomorphic-p* (obj1 obj2) |
---|
611 | (:documentation |
---|
612 | "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure, |
---|
613 | including the same leaf values and the same pattern of sharing). It should be |
---|
614 | the case that (isomorphic-p obj (replicate obj)) is true.")) |
---|
615 | |
---|
616 | (defmethod isomorphic-p* ((obj1 t) (obj2 t)) |
---|
617 | (eql obj1 obj2)) |
---|
618 | |
---|
619 | (defmethod isomorphic-p* ((obj1 cons) (obj2 cons)) |
---|
620 | (let ((previous (gethash obj1 *isomorphism-table*))) |
---|
621 | (cond |
---|
622 | (previous |
---|
623 | ;; If we've already produced a mapping from obj1 to something, |
---|
624 | ;; isomorphism requires that obj2 be that object |
---|
625 | (eq previous obj2)) |
---|
626 | ;; Otherwise, assume obj1 will map to obj2 and recurse |
---|
627 | (t |
---|
628 | (setf (gethash obj1 *isomorphism-table*) obj2) |
---|
629 | (and (isomorphic-p* (car obj1) (car obj2)) |
---|
630 | (isomorphic-p* (cdr obj1) (cdr obj2))))))) |
---|
631 | |
---|
632 | (defmethod isomorphic-p* ((obj1 array) (obj2 array)) |
---|
633 | (let ((previous (gethash obj1 *isomorphism-table*))) |
---|
634 | (cond |
---|
635 | (previous |
---|
636 | ;; If we've already produced a mapping from obj1 to something, |
---|
637 | ;; isomorphism requires that obj2 be that object |
---|
638 | (eq previous obj2)) |
---|
639 | (t |
---|
640 | (setf (gethash obj1 *isomorphism-table*) obj2) |
---|
641 | (and (equal (array-dimensions obj1) (array-dimensions obj2)) |
---|
642 | (equal (array-element-type obj1) (array-element-type obj2)) |
---|
643 | (if (array-has-fill-pointer-p obj1) |
---|
644 | (and (array-has-fill-pointer-p obj2) |
---|
645 | (eql (fill-pointer obj1) (fill-pointer obj2))) |
---|
646 | (not (array-has-fill-pointer-p obj2))) |
---|
647 | (let (to-1 (index-1 0) to-2 (index-2 0)) |
---|
648 | (multiple-value-setq (to-1 index-1) (array-displacement obj1)) |
---|
649 | (multiple-value-setq (to-2 index-2) (array-displacement obj2)) |
---|
650 | (if to-1 |
---|
651 | (and to-2 |
---|
652 | (eql index-1 index-2) |
---|
653 | (isomorphic-p* to-1 to-2)) |
---|
654 | ;; Not displaced -- recurse on elements |
---|
655 | (let ((total-size (array-total-size obj1))) |
---|
656 | (loop for i below total-size |
---|
657 | always (isomorphic-p* (row-major-aref obj1 i) |
---|
658 | (row-major-aref obj2 i))))))))))) |
---|
659 | |
---|
660 | ;;; Test that sequences have identical elements |
---|
661 | |
---|
662 | (defun equalp-and-eql-elements (s1 s2) |
---|
663 | (and (equalp s1 s2) |
---|
664 | (every #'eql s1 s2))) |
---|