From 8c60effd2f99e9ae55d8a8442f49a706a7b06848 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sat, 23 Apr 2005 14:17:20 +0000
Subject: [PATCH] Enhance the :replicate facility to enable replication of a
 subset of the arguments.  Add ISOMORPHIC-P predicate, which is true for
 replicated values.

---
 ansi-tests/random-type-prop.lsp | 114 +++++++++++++++++++++++++++-----
 1 file changed, 96 insertions(+), 18 deletions(-)

diff --git a/ansi-tests/random-type-prop.lsp b/ansi-tests/random-type-prop.lsp
index e6fc12a5..e279f655 100644
--- a/ansi-tests/random-type-prop.lsp
+++ b/ansi-tests/random-type-prop.lsp
@@ -5,7 +5,7 @@
 
 (in-package :cl-test)
 
-(eval-when (load eval compile)
+(eval-when (:compile-toplevel :load-toplevel :execute)
   (compile-and-load "random-int-form.lsp"))
 
 (defvar *print-random-type-prop-input* nil)
@@ -56,7 +56,6 @@
 ;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles
 ;;; (compile-and-load "random-type-prop.lsp")
 ;;; (in-package :cl-test)
-;;; #+sbcl (setq *default-arg-the* nil)   ;; This reduces the rate at which the sbcl IR2 type check bug occurs
 ;;; (load "random-type-prop-tests.lsp")
 ;;; (let (*catch-errors*) (do-test '<testname>))
 ;;; or (let (*catch-errors*) (do-tests))
@@ -82,9 +81,8 @@
 ;;;                              array of specialized type.  This enables one to test
 ;;;                              forms where the result will be unboxed.  Otherwise, just
 ;;;                              return the values.
-;;;  ignore      nil             Ignore conditions that are elements of IGNORE.  For example,
-;;;                              one might bind this to ARITHMETIC-ERROR if you want to
-;;;                              ignore possible floating errors (say).
+;;;  ignore      *default-ignore*  Ignore conditions that are elements of IGNORE.  Default is
+;;;                              ARITHMETIC-ERROR.
 ;;;  test        rt::equalp-with-case   The test function used to compare outputs.  It's
 ;;;                              also handy to use #'approx= to handle approximate equality
 ;;;                              when testing floating point computations, where compiled code
@@ -126,8 +124,15 @@
 	  ; (vals (mapcar #'make-random-element-of-type types))
 	  (vals (setq *params*
 		      (or (make-random-arguments types) (go again))))
-	  (vals (if replicate (mapcar #'replicate vals) vals))
-	  (is-var? (loop repeat (length vals) collect (coin)))
+	  (vals
+	   (if replicate
+	       (mapcar #'replicate vals)
+	     vals))
+	  (is-var? (if (consp replicate)
+		       (progn
+			 (assert (= (length replicate) (length vals)))
+			 (loop for x in replicate collect (or x (coin))))
+		     (loop repeat (length vals) collect (coin))))
 	  (*is-var?* is-var?)
 	  (params (loop for x in is-var?
 			for p in param-names
@@ -360,7 +365,8 @@
      (1 `(,root ,etype))
      (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 (array-dimension val i))))
-     (1 `(,root ,etype ,rank)))))
+     #-ecl (1 `(,root ,etype ,rank))
+     )))
 
 (defmethod make-random-type-containing ((val string))
   (rcase
@@ -391,16 +397,20 @@
    (1 'complex)
    (1 'number)
    #-gcl (1 
-	  (let ((t1 (type-of (realpart val)))
-		(t2 (type-of (imagpart val))))
-	    (cond
-	     ((subtypep t1 t2) `(complex ,(upgraded-complex-part-type t2)))
-	     ((subtypep t2 t1) `(complex ,(upgraded-complex-part-type t1)))
-	     ((and (subtypep t1 'rational)
-		   (subtypep t2 'rational))
-	      `(complex rational))
-	     (t
-	      `(complex ,(upgraded-complex-part-type `(or ,t1 ,t2)))))))
+	  (let* ((t1 (type-of (realpart val)))
+		 (t2 (type-of (imagpart val)))
+		 (part-type
+		  (cond
+		   ((subtypep t1 t2) (upgraded-complex-part-type t2))
+		   ((subtypep t2 t1) (upgraded-complex-part-type t1))
+		   ((and (subtypep t1 'rational)
+			 (subtypep t2 'rational))
+		    'rational)
+		   (t
+		    (upgraded-complex-part-type `(or ,t1 ,t2))))))
+	    (if (subtypep 'real part-type)
+		'(complex real)
+	      `(complex ,part-type))))
    (1 `(eql ,val))))
 
 (defmethod make-random-type-containing ((val generic-function))
@@ -433,6 +443,14 @@
 	  do (setq result `(cons ,element-type ,result)))
     result))
 
+(defun make-sequence-type (length &optional (element-type t))
+  (rcase
+   (1 `(vector ,element-type ,length))
+   (1 (make-list-type length 'null element-type))))
+
+(defun make-random-sequence-type-containing (element)
+  (make-sequence-type (random 10) (make-random-type-containing element)))
+
 (defun same-set-p (set1 set2 &rest args &key key test test-not)
   (declare (ignorable key test test-not))
   (and (apply #'subsetp set1 set2 args)
@@ -539,3 +557,63 @@
 				       :adjustable adj)))
 	      (setf (gethash obj *replicate-table*) new-obj)
 	      (values new-obj obj new-obj)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declaim (special *isomorphism-table*))
+
+(defun isomorphic-p (obj1 obj2)
+  (let ((*isomorphism-table* (make-hash-table)))
+    (isomorphic-p* obj1 obj2)))
+
+(defgeneric isomorphic-p* (obj1 obj2)
+  (:documentation
+   "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure,
+    including the same leaf values and the same pattern of sharing).  It should be
+    the case that (isomorphic-p obj (replicate obj)) is true."))
+
+(defmethod isomorphic-p* ((obj1 t) (obj2 t))
+  (eql obj1 obj2))
+
+(defmethod isomorphic-p* ((obj1 cons) (obj2 cons))
+  (let ((previous (gethash obj1 *isomorphism-table*)))
+    (cond
+     (previous
+      ;; If we've already produced a mapping from obj1 to something,
+      ;; isomorphism requires that obj2 be that object
+      (eq previous obj2))
+     ;; Otherwise, assume obj1 will map to obj2 and recurse
+     (t
+      (setf (gethash obj1  *isomorphism-table*) obj2)
+      (and (isomorphic-p* (car obj1) (car obj2))
+	   (isomorphic-p* (cdr obj1) (cdr obj2)))))))
+
+(defmethod isomorphic-p* ((obj1 array) (obj2 array))
+  (let ((previous (gethash obj1 *isomorphism-table*)))
+    (cond
+     (previous
+      ;; If we've already produced a mapping from obj1 to something,
+      ;; isomorphism requires that obj2 be that object
+      (eq previous obj2))
+     (t
+      (setf (gethash obj1 *isomorphism-table*) obj2)
+      (and (equal (array-dimensions obj1) (array-dimensions obj2))
+	   (equal (array-element-type obj1) (array-element-type obj2))
+	   (if (array-has-fill-pointer-p obj1)
+	       (and (array-has-fill-pointer-p obj2)
+		    (eql (fill-pointer obj1) (fill-pointer obj2)))
+	     (not (array-has-fill-pointer-p obj2)))
+	   (let (to-1 (index-1 0) to-2 (index-2 0))
+	     (multiple-value-setq (to-1 index-1) (array-displacement obj1))
+	     (multiple-value-setq (to-2 index-2) (array-displacement obj2))
+	     (if to-1
+		 (and to-2
+		      (eql index-1 index-2)
+		      (isomorphic-p* to-1 to-2))
+	       ;; Not displaced -- recurse on elements
+	       (let ((total-size (array-total-size obj1)))
+		 (loop for i below total-size
+		       always (isomorphic-p* (row-major-aref obj1 i)
+					     (row-major-aref obj2 i)))))))))))
+
+
-- 
GitLab