diff --git a/ansi-tests/random-types.lsp b/ansi-tests/random-types.lsp
index 7db80b378630d74ddf615a4894872af801f8afd5..b1d6b8231fe4ff53242db6e2152edbd06280252b 100644
--- a/ansi-tests/random-types.lsp
+++ b/ansi-tests/random-types.lsp
@@ -21,7 +21,6 @@
        (1 (random-from-seq #(integer unsigned-byte ratio rational real float
 			     short-float single-float double-float
 			     long-float complex symbol cons function)))
-       #|
        (1
 	(let* ((len (random *maximum-random-int-bits*))
 	       (r1 (ash 1 len))
@@ -31,9 +30,8 @@
 	       (lo (min x y))
 	       (hi (max x y)))
 	  `(integer ,lo ,hi)))
-       |#
        (1 (make-random-real-type))
-       (1 (make-random-complex-type))
+       ;; (1 (make-random-complex-type))
        )
     (rcase
      (2 (let* ((op (random-from-seq #(cons cons and or)))
@@ -70,6 +68,100 @@
 	 (types (mapcar #'make-random-type sizes)))
     `(function (,(car types)) ,(cadr types))))
 
+(defun size-of-type (type)
+  (if (consp type)
+      (case (car type)
+	(complex (1+ (size-of-type (cadr type))))
+	((array simple-array) (1+ (size-of-type (cadr type))))
+	(vector (1+ (size-of-type (cadr type))))
+	(complex (1+ (size-of-type (cadr type))))
+	((cons or and not) (reduce #'+ (cdr type) :initial-value 1
+				   :key #'size-of-type))
+	(t 1))
+      1))
+
+(defun mutate-type (type)
+  (let* ((size (size-of-type type))
+	 (r (random size)))
+    (flet ((%f ()
+	     (rcase
+	      (6 (make-random-type (random (1+ size))))
+	      (2 `(not ,type))
+	      (1 `(and ,(make-random-type 1) ,type))
+	      (1 `(and ,type ,(make-random-type 1)))
+	      (1 `(or ,(make-random-type 1) ,type))
+	      (1 `(or ,type ,(make-random-type 1)))))
+	   (%random-int ()
+	     (let ((bits (1+ (min (random 20) (random 20)))))
+	       (- (ash 1 bits) (random (ash 1 (1+ bits)))))))
+      (if (or (and (= r 0) (coin)) (not (consp type)))
+	  (%f)
+	  (case (car type)
+	    ((and or not cons complex)
+	     (let ((sizes (mapcar #'size-of-type (cdr type))))
+	       (loop with sum = 0
+		  for e on sizes
+		  for ctype in (cdr type)
+		  for i from 0
+		  do (setf sum (incf (car e) sum))
+		  when (>= sum r)
+		  return (rcase
+			  (1 ctype) ;; replace with component type
+			  (1 (cons (car type)
+				   (append (subseq (cdr type) 0 i)
+					   (list (mutate-type ctype))
+					   (subseq (cdr type) (1+ i)))))))))
+	    ((array simple-array vector)
+	     (let ((ctype (if (cdr type) (cadr type) t)))
+	       (rcase
+		(1 (if (eql ctype *) t ctype))
+		(1 (cons (car type)
+			 (cons (mutate-type ctype)
+			       (cddr type)))))))
+	    ((unsigned-byte)
+	     (if (integerp (cadr type))
+		 (rcase
+		  (1 'unsigned-byte)
+		  (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20))))))
+		 (%f)))
+
+	    ((integer)
+	     (let ((lo-delta (%random-int))
+		   (hi-delta (%random-int))
+		   (old-lo (or (cadr type) '*))
+		   (old-hi (or (caddr type) '*)))
+	       (flet ((%inc (old delta)
+			(if (or (coin) (not (integerp old)))
+			    delta
+			    (+ old delta))))
+		 (rcase
+		  (1 `(integer ,old-lo *))
+		  (1 `(integer * ,old-hi))
+		  (1 (let ((new-lo (%inc old-lo lo-delta)))
+		       (if (or (null (cdr type))
+			       (null (cddr type))
+			       (not (integerp old-hi)))
+			   `(integer ,new-lo ,@(cddr type))
+			   ;; caddr is integer
+			   (if (<= new-lo old-hi)
+			       `(integer ,new-lo ,old-hi)
+			       `(integer ,old-hi ,new-lo)))))
+		  (1 (let ((new-hi (%inc old-hi hi-delta)))
+		       (if (or (null (cdr type))
+			       (null (cddr type))
+			       (not (integerp old-lo)))
+			   `(integer ,old-lo ,new-hi)
+			   (if (<= old-lo new-hi)
+			       `(integer ,old-lo ,new-hi)
+			       `(integer ,new-hi ,old-lo)))))
+		  (1 (let ((new-lo (%inc old-lo lo-delta))
+			   (new-hi (%inc old-hi hi-delta)))
+		       (if (<= new-lo new-hi)
+			   `(integer ,new-lo ,new-hi)
+			   `(integer ,new-hi ,new-lo))))))))
+		       
+	    (t (%f)))))))
+
 (defun test-random-types (n size)
   (loop for t1 = (make-random-type size)
 	for t2 = (make-random-type size)
@@ -81,7 +173,18 @@
 	when (test-types t1 t2)
 	collect (list t1 t2)
 	finally (terpri)))
-  
+
+(defun test-random-mutated-types (n size)
+  (loop for t1 = (make-random-type size)
+	for t2 = (mutate-type t1)
+	for i from 0 below n
+	;; do (print (list t1 t2))
+        do (setf *random-types* (list t1 t2))
+	do (when (and (= (mod i 100) 0) (> i 0))
+	     (format t "~A " i) (finish-output *standard-output*))
+	when (test-types t1 t2)
+	collect (list t1 t2)
+	finally (terpri)))  
 
 (defun test-types (t1 t2)
   (multiple-value-bind (sub success)
diff --git a/ansi-tests/subtypep-cons.lsp b/ansi-tests/subtypep-cons.lsp
index cbf9352c44b1f13005d60faad4df320e801a6aa8..a8baee36e6ef9059d330cbcba64e2de1ceb35729 100644
--- a/ansi-tests/subtypep-cons.lsp
+++ b/ansi-tests/subtypep-cons.lsp
@@ -334,7 +334,7 @@
      (subtypep* `(not ,type2) `(not ,type1))))
   nil nil)
 
-;;; From SBCL
+;;; From sbcl 0.9.5.31
 
 (deftest subtypep.cons.41
   (let ((type1 '(cons t (complex (real -10 -4))))
@@ -348,3 +348,12 @@
 	    nil))))
   nil)
 
+(deftest subtypep.cons.42
+    (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) (integer -234496 215373))
+		integer))
+	  (t2 '(cons (cons (cons integer integer) (integer -234496 215373)) t)))
+      (values (subtypep `(not ,t2) `(not ,t1))))
+  nil)
+
+  
+