5 |
|
|
6 |
(in-package :cl-test) |
(in-package :cl-test) |
7 |
|
|
8 |
(eval-when (load eval compile) |
(eval-when (:compile-toplevel :load-toplevel :execute) |
9 |
(compile-and-load "random-int-form.lsp")) |
(compile-and-load "random-int-form.lsp")) |
10 |
|
|
11 |
(defvar *print-random-type-prop-input* nil) |
(defvar *print-random-type-prop-input* nil) |
56 |
;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles |
;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles |
57 |
;;; (compile-and-load "random-type-prop.lsp") |
;;; (compile-and-load "random-type-prop.lsp") |
58 |
;;; (in-package :cl-test) |
;;; (in-package :cl-test) |
|
;;; #+sbcl (setq *default-arg-the* nil) ;; This reduces the rate at which the sbcl IR2 type check bug occurs |
|
59 |
;;; (load "random-type-prop-tests.lsp") |
;;; (load "random-type-prop-tests.lsp") |
60 |
;;; (let (*catch-errors*) (do-test '<testname>)) |
;;; (let (*catch-errors*) (do-test '<testname>)) |
61 |
;;; or (let (*catch-errors*) (do-tests)) |
;;; or (let (*catch-errors*) (do-tests)) |
81 |
;;; array of specialized type. This enables one to test |
;;; array of specialized type. This enables one to test |
82 |
;;; forms where the result will be unboxed. Otherwise, just |
;;; forms where the result will be unboxed. Otherwise, just |
83 |
;;; return the values. |
;;; return the values. |
84 |
;;; ignore nil Ignore conditions that are elements of IGNORE. For example, |
;;; ignore *default-ignore* Ignore conditions that are elements of IGNORE. Default is |
85 |
;;; one might bind this to ARITHMETIC-ERROR if you want to |
;;; ARITHMETIC-ERROR. |
|
;;; ignore possible floating errors (say). |
|
86 |
;;; test rt::equalp-with-case The test function used to compare outputs. It's |
;;; test rt::equalp-with-case The test function used to compare outputs. It's |
87 |
;;; also handy to use #'approx= to handle approximate equality |
;;; also handy to use #'approx= to handle approximate equality |
88 |
;;; when testing floating point computations, where compiled code |
;;; when testing floating point computations, where compiled code |
124 |
; (vals (mapcar #'make-random-element-of-type types)) |
; (vals (mapcar #'make-random-element-of-type types)) |
125 |
(vals (setq *params* |
(vals (setq *params* |
126 |
(or (make-random-arguments types) (go again)))) |
(or (make-random-arguments types) (go again)))) |
127 |
(vals (if replicate (mapcar #'replicate vals) vals)) |
(vals |
128 |
(is-var? (loop repeat (length vals) collect (coin))) |
(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?) |
(*is-var?* is-var?) |
137 |
(params (loop for x in is-var? |
(params (loop for x in is-var? |
138 |
for p in param-names |
for p in param-names |
365 |
(1 `(,root ,etype)) |
(1 `(,root ,etype)) |
366 |
(1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) |
(1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) |
367 |
(1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) |
(1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) |
368 |
(1 `(,root ,etype ,rank))))) |
#-ecl (1 `(,root ,etype ,rank)) |
369 |
|
))) |
370 |
|
|
371 |
(defmethod make-random-type-containing ((val string)) |
(defmethod make-random-type-containing ((val string)) |
372 |
(rcase |
(rcase |
397 |
(1 'complex) |
(1 'complex) |
398 |
(1 'number) |
(1 'number) |
399 |
#-gcl (1 |
#-gcl (1 |
400 |
(let ((t1 (type-of (realpart val))) |
(let* ((t1 (type-of (realpart val))) |
401 |
(t2 (type-of (imagpart val)))) |
(t2 (type-of (imagpart val))) |
402 |
(cond |
(part-type |
403 |
((subtypep t1 t2) `(complex ,(upgraded-complex-part-type t2))) |
(cond |
404 |
((subtypep t2 t1) `(complex ,(upgraded-complex-part-type t1))) |
((subtypep t1 t2) (upgraded-complex-part-type t2)) |
405 |
((and (subtypep t1 'rational) |
((subtypep t2 t1) (upgraded-complex-part-type t1)) |
406 |
(subtypep t2 'rational)) |
((and (subtypep t1 'rational) |
407 |
`(complex rational)) |
(subtypep t2 'rational)) |
408 |
(t |
'rational) |
409 |
`(complex ,(upgraded-complex-part-type `(or ,t1 ,t2))))))) |
(t |
410 |
|
(upgraded-complex-part-type `(or ,t1 ,t2)))))) |
411 |
|
(if (subtypep 'real part-type) |
412 |
|
'(complex real) |
413 |
|
`(complex ,part-type)))) |
414 |
(1 `(eql ,val)))) |
(1 `(eql ,val)))) |
415 |
|
|
416 |
(defmethod make-random-type-containing ((val generic-function)) |
(defmethod make-random-type-containing ((val generic-function)) |
443 |
do (setq result `(cons ,element-type ,result))) |
do (setq result `(cons ,element-type ,result))) |
444 |
result)) |
result)) |
445 |
|
|
446 |
|
(defun make-sequence-type (length &optional (element-type t)) |
447 |
|
(rcase |
448 |
|
(1 `(vector ,element-type ,length)) |
449 |
|
(1 (make-list-type length 'null element-type)))) |
450 |
|
|
451 |
|
(defun make-random-sequence-type-containing (element) |
452 |
|
(make-sequence-type (random 10) (make-random-type-containing element))) |
453 |
|
|
454 |
(defun same-set-p (set1 set2 &rest args &key key test test-not) |
(defun same-set-p (set1 set2 &rest args &key key test test-not) |
455 |
(declare (ignorable key test test-not)) |
(declare (ignorable key test test-not)) |
456 |
(and (apply #'subsetp set1 set2 args) |
(and (apply #'subsetp set1 set2 args) |
557 |
:adjustable adj))) |
:adjustable adj))) |
558 |
(setf (gethash obj *replicate-table*) new-obj) |
(setf (gethash obj *replicate-table*) new-obj) |
559 |
(values new-obj obj new-obj))))))) |
(values new-obj obj new-obj))))))) |
560 |
|
|
561 |
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
562 |
|
|
563 |
|
(declaim (special *isomorphism-table*)) |
564 |
|
|
565 |
|
(defun isomorphic-p (obj1 obj2) |
566 |
|
(let ((*isomorphism-table* (make-hash-table))) |
567 |
|
(isomorphic-p* obj1 obj2))) |
568 |
|
|
569 |
|
(defgeneric isomorphic-p* (obj1 obj2) |
570 |
|
(:documentation |
571 |
|
"Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure, |
572 |
|
including the same leaf values and the same pattern of sharing). It should be |
573 |
|
the case that (isomorphic-p obj (replicate obj)) is true.")) |
574 |
|
|
575 |
|
(defmethod isomorphic-p* ((obj1 t) (obj2 t)) |
576 |
|
(eql obj1 obj2)) |
577 |
|
|
578 |
|
(defmethod isomorphic-p* ((obj1 cons) (obj2 cons)) |
579 |
|
(let ((previous (gethash obj1 *isomorphism-table*))) |
580 |
|
(cond |
581 |
|
(previous |
582 |
|
;; If we've already produced a mapping from obj1 to something, |
583 |
|
;; isomorphism requires that obj2 be that object |
584 |
|
(eq previous obj2)) |
585 |
|
;; Otherwise, assume obj1 will map to obj2 and recurse |
586 |
|
(t |
587 |
|
(setf (gethash obj1 *isomorphism-table*) obj2) |
588 |
|
(and (isomorphic-p* (car obj1) (car obj2)) |
589 |
|
(isomorphic-p* (cdr obj1) (cdr obj2))))))) |
590 |
|
|
591 |
|
(defmethod isomorphic-p* ((obj1 array) (obj2 array)) |
592 |
|
(let ((previous (gethash obj1 *isomorphism-table*))) |
593 |
|
(cond |
594 |
|
(previous |
595 |
|
;; If we've already produced a mapping from obj1 to something, |
596 |
|
;; isomorphism requires that obj2 be that object |
597 |
|
(eq previous obj2)) |
598 |
|
(t |
599 |
|
(setf (gethash obj1 *isomorphism-table*) obj2) |
600 |
|
(and (equal (array-dimensions obj1) (array-dimensions obj2)) |
601 |
|
(equal (array-element-type obj1) (array-element-type obj2)) |
602 |
|
(if (array-has-fill-pointer-p obj1) |
603 |
|
(and (array-has-fill-pointer-p obj2) |
604 |
|
(eql (fill-pointer obj1) (fill-pointer obj2))) |
605 |
|
(not (array-has-fill-pointer-p obj2))) |
606 |
|
(let (to-1 (index-1 0) to-2 (index-2 0)) |
607 |
|
(multiple-value-setq (to-1 index-1) (array-displacement obj1)) |
608 |
|
(multiple-value-setq (to-2 index-2) (array-displacement obj2)) |
609 |
|
(if to-1 |
610 |
|
(and to-2 |
611 |
|
(eql index-1 index-2) |
612 |
|
(isomorphic-p* to-1 to-2)) |
613 |
|
;; Not displaced -- recurse on elements |
614 |
|
(let ((total-size (array-total-size obj1))) |
615 |
|
(loop for i below total-size |
616 |
|
always (isomorphic-p* (row-major-aref obj1 i) |
617 |
|
(row-major-aref obj2 i))))))))))) |
618 |
|
|
619 |
|
|