diff --git a/random/make-random-element-of.lsp b/random/make-random-element-of.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..dcbea8a92ca70f2668e6fd51c6c8b25ebf1cdb05
--- /dev/null
+++ b/random/make-random-element-of.lsp
@@ -0,0 +1,274 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Dec 28 20:28:03 2004
+;;;; Contains: Code to make random elements of types
+
+(in-package :cl-test)
+
+(defgeneric make-random-element-of (type)
+  (:documentation
+   "Create a random element of TYPE, or throw an error if it can't figure out how to do it."))
+
+(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys)
+  (:documentation
+   "Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it."))
+
+(defmethod make-random-element-of ((type cons))
+  (make-random-element-of-compound-type (car type) (cdr type)))
+
+(defmethod make-random-element-of ((type (eql bit))) (random 2))
+
+(defmethod make-random-element-of ((type (eql boolean)))
+  (random-from-seq #(nil t)))
+
+(defmethod make-random-elememt-of ((type (eql symbol)))
+  (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
+
+(defmethod make-random-element-of ((type (eql unsigned-byte)))
+  (random-from-interval
+   (1+ (ash 1 (random *maximum-random-int-bits*)))))
+
+(defmethod make-random-elememt-of ((type (eql signed-byte)))
+  (random-from-interval
+   (1+ (ash 1 (random *maximum-random-int-bits*)))
+   (- (ash 1 (random *maximum-random-int-bits*)))))
+
+(defmethod make-random-element-of ((type (eql rational)))
+  (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
+         (n (random r))
+         (d (loop for x = (random r) unless (zerop x) do (return x))))
+    (if (coin) (/ n d) (- (/ n d)))))
+
+(defmethod make-random-element-of ((type (eql integer)))
+  (let* ((b (random *maximum-random-int-bits*))
+         (x (ash 1 b)))
+    (rcase
+     (1 (+ x (make-random-element-of 'integer)))
+     (1 (- (make-random-element-of 'integer) x))
+     (6 (random-from-interval (1+ x) (- x))))))
+
+(defmethod make-random-element-of ((type (eql short-float)))
+  (make-random-element-of (list type)))
+
+(defmethod make-random-element-of ((type (eql single-float)))
+  (make-random-element-of (list type)))
+
+(defmethod make-random-element-of ((type (eql double-float)))
+  (make-random-element-of (list type)))
+
+(defmethod make-random-element-of ((type (eql long-float)))
+  (make-random-element-of (list type)))
+
+(defmethod make-random-element-of ((type (eql float)))
+  (make-random-element-of
+   (list (random-from-seq #'(short-float single-float double-float long-float)))))
+
+(defmethod make-random-element-of ((type (eql real)))
+  (make-random-element-of (random-from-seq #(integer rational float))))
+
+(defmethod make-random-element-of ((type (eql ratio)))
+  (loop for x = (make-random-element-of 'rational)
+        unless (integerp x) return x))
+
+(defmethod make-random-element-of ((type complex))
+  (make-random-element-of '(complex real)))
+
+(defmethod make-random-element-of ((type fixnum))
+  (make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum)))
+
+(defmethod make-random-element-of ((type bignum))
+  (make-random-element-of `(or (integer * (,most-negative-fixnum))
+                               (integer (,most-positive-fixnum)))))
+
+(defmethod make-random-element-of ((type (eql number)))
+  (make-random-element-of (random-from-seq #(integer rational float complex))))
+
+(defmethod make-random-element-of ((type (eql character)))
+  (rcase
+   (3 (random-from-seq +standard-chars+))
+   (2 (let ((r (random 256)))
+        (or (code-char r) (make-random-element-of 'character))))
+   (1 (let ((r (random #.(ash 1 16))))
+        (or (code-char r) (make-random-element-of 'character))))
+   (1 (let ((r (random #.(ash 1 24))))
+        (or (code-char r) (make-random-element-of 'character))))))
+
+(defmethod make-random-element-of ((type 'base-char))
+  (random-from-seq +standard-chars+))
+
+(defmethod make-random-element-of ((type 'standard-char))
+  (random-from-seq +standard-chars+))
+
+(defmethod make-random-element-of ((type (eql bit-vector)))
+  (make-random-vector 'bit '*))
+
+(defmethod make-random-element-of ((type (eql simple-bit-vector)))
+  (make-random-vector 'bit '* :simple t))
+
+(defmethod make-random-element-of ((type (eql vector)))
+  (make-random-vector '* '*))
+
+(defmethod make-random-element-of ((type (eql simple-vector)))
+  (make-random-vector 't '* :simple t))
+
+(defmethod make-random-elemnt-of ((type (eql array)))
+  (make-random-array '* '*))
+
+(defmethod make-random-elemnt-of ((type (eql simple-array)))
+  (make-random-array '* '* :simple t))
+
+(defmethod make-random-elememt-of ((type (eql string)))
+  (make-random-string '*))
+
+(defmethod make-random-elememt-of ((type (eql simple-string)))
+  (make-random-string '* :simple t))
+
+(defmethod make-random-element-of ((type (eql base-string)))
+  (make-random-vector 'base-char '*))
+
+(defmethod make-random-element-of ((type (eql simple-base-string)))
+  (make-random-vector 'base-char '* :simple t))
+
+(defmethod make-random-element-of ((type (eql cons)))
+  (make-random-element-of '(cons t t)))
+
+(defmethod make-random-element-of ((type (eql null))) nil)
+
+(defmethod make-random-elememt-of ((type (eql list)))
+  (let ((len (min (random 10) (random 10))))
+    (loop repeat len collect (make-random-element-of-type t))))
+
+(defmethod make-random-element-of ((type (eql sequence)))
+  (make-random-element-of '(or list vector)))
+
+;;;;
+
+(defun make-random-vector (length &key simple (element-type '*))
+  (setq element-type (make-random-array-element-type element-type))
+  (make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length)))
+
+(defun make-random-array (dimensions &key simple (element-type '*))
+  (setq element-type (make-random-array-element-type element-type))
+  (make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length)))
+
+(defun make-random-array-element-type (elememt-type)
+  (if (eq element-type '*)
+    (rcase
+     (1 'bit)
+     (1 `(unsigned-byte (1+ (random *maximum-random-int-bits*))))
+     (1 `(signed-byte (1+ (random *maximum-random-int-bits*))))
+     (2 (random-from-seq #(character base-char standard-char)))
+     ;; Put float, complex types here also
+     (4 t))
+    element-type))
+
+;;;;
+
+(defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons))
+  (make-random-element-of (random-from-seq args)))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons))
+  (loop for e = (make-random-element-of (car args))
+        repeat 100
+        when (or (null (cdr args)) (typep e (cons 'and (cdr args))))
+        return x
+        finally (error "Cannot generate a random element of ~A"
+                       (cons 'and args))))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t))
+  (let ((lo (let ((lo (car args)))
+              (cond
+               ((consp lo) (1+ (car lo)))
+               ((eq lo nil) '*)
+               (t lo))))
+        (hi (let ((hi (cadr args)))
+              (cond
+               ((consp hi) (1- (car hi)))
+               ((eq hi nil) '*)
+               (t hi)))))
+    (if (eq lo '*)
+        (if (eq hi '*)
+            (let ((x (ash 1 (random *maximum-random-int-bits*))))
+              (random-from-interval x (- x)))
+          (random-from-interval (1+ hi)
+                                (- hi (random (ash 1 *maximum-random-int-bits*)))))
+
+      (if (eq hi '*)
+          (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
+                                lo)
+        ;; May generalize the next case to increase odds
+        ;; of certain integers (near 0, near endpoints, near
+        ;; powers of 2...)
+        (random-from-interval (1+ hi) lo)))))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t))
+  (make-random-element-of-float-type type args))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t))
+  (make-random-element-of-float-type type args))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t))
+  (make-random-element-of-float-type type args))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t))
+  (make-random-element-of-float-type type args))
+
+(defun make-random-element-of-float-type (type-op args)
+  (let ((lo (car args))
+        (hi (cadr args))
+        lo= hi=)
+    (cond
+     ((consp lo) nil)
+     ((member lo '(* nil))
+      (setq lo (most-negative-float type-op))
+      (setq lo= t))
+     (t
+      (assert (typep lo type-op))
+      (setq lo= t)))
+    (cond
+     ((consp hi) nil)
+     ((member hi '(* nil))
+      (setq hi (most-positive-float type-op))
+      (setq hi= t))
+     (t
+      (assert (typep hi type-op))
+      (setq hi= t)))
+    (assert (<= lo hi))
+    (assert (or (< lo hi) (and lo= hi=)))
+    (let ((limit 100000))
+      (cond
+       ((or (<= hi 0)
+            (>= lo 0)
+            (and (<= (- limit) hi limit) (<= (- limit) lo limit)))
+        (loop for x = (+ (random (- hi lo)) lo)
+              do (when (or lo= (/= x lo)) (return x))))
+       (t
+        (rcase
+         (1 (random (min hi (float limit hi))))
+         (1 (- (random (min (float limit lo) (- lo)))))))))))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons))
+  (let ((modulus (car args)))
+    (assert (integerp modulus))
+    (assert (plusp modulus))
+    (make-random-element-of `(integer 0 (,modulus)))))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t))
+  (if (null args)
+      (make-random-element-of '(integer 0 *))
+    (let ((bits (car args)))
+      (if (eq bits'*)
+          (make-random-element-of '(integer 0 *))
+        (progn
+          (assert (and (integerp bits) (>= bits 1)))
+          (make-random-element-of `(integer 0 ,(1- (ash 1 bits)))))))))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons))
+  (assert (null (cdr args)))
+  (car args))
+
+(defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons))
+  (random-from-seq args))
+
+
+
diff --git a/random/random-class.lsp b/random/random-class.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..1453fdd222d03c80d8559212fbc90d643cb74143
--- /dev/null
+++ b/random/random-class.lsp
@@ -0,0 +1,9 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Oct 10 07:13:47 2004
+;;;; Contains: Randomized tests on classes
+
+(in-package :cl-test)
+
+(compile-and-load "random-class-aux.lsp")
+
diff --git a/random/random-int-form.lsp b/random/random-int-form.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..7c18b164891ab851edb6135051f5f5e95d4e584d
--- /dev/null
+++ b/random/random-int-form.lsp
@@ -0,0 +1,2971 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Wed Sep 10 18:03:52 2003
+;;;; Contains: Simple randon form generator/tester
+
+(in-package :cl-test)
+
+(compile-and-load "random-aux.lsp")
+
+;;;
+;;; This file contains a routine for generating random legal Common Lisp functions
+;;; for differential testing.
+;;;
+;;; To run the random tests by themselves, start a lisp in the ansi-tests directory
+;;; and do the following:
+;;;   (load "gclload1.lsp")
+;;;   (compile-and-load "random-int-form.lsp")
+;;;   (in-package :cl-test)
+;;;   (let ((*random-state* (make-random-state t)))
+;;;      (test-random-integer-forms 100 4 10000)) ;; or other parameters
+;;;
+;;; If a test breaks during testing the variables *optimized-fn-src*,
+;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source
+;;; of the optimized/unoptimized lambda forms being compiled, and the arguments
+;;; on which they are called.
+;;;
+;;; If a difference is found between optimized/unoptimized functions the forms,
+;;; values, and results are collected.  A list of all these discrepancies is returned
+;;; after testing finishes (assuming nothing breaks).
+;;;
+;;; The variable *compile-unoptimized-form* controls whether the low optimization
+;;; form is compiled, or if a form funcalling it is EVALed.  The latter is often
+;;; faster, and may find more problems since an interpreter and compiler may evaluate
+;;; forms in very different ways.
+;;;
+;;; The rctest/ subdirectory contains fragments of a more OO random form generator
+;;; that will eventually replace this preliminary effort.
+;;;
+;;; The file misc.lsp contains tests that were mostly for bugs found by this
+;;; random tester in various Common Lisp implementations.
+;;;
+
+(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*
+                  *opt-result* *unopt-result* $x $y $z
+                  *compile-unoptimized-form*
+                  *make-random-integer-form-cdf*))
+
+;;; Little functions used to run collected tests.
+;;; (f i) runs the ith collected optimized test
+;;; (g i) runs the ith collected unoptimized test
+;;; (p i) prints the ith test (forms, input values, and other information)
+
+(defun f (i) (let ((plist (elt $y i)))
+               (apply (compile nil (getf plist :optimized-lambda-form))
+                      (getf plist :vals))))
+
+(defun g (i) (let ((plist (elt $y i)))
+               (if *compile-unoptimized-form*
+                   (apply (compile nil (getf plist :unoptimized-lambda-form))
+                          (getf plist :vals))
+                 (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form))))
+                        (getf plist :vals)))))
+
+(defun p (i) (write (elt $y i) :pretty t :escape t) (values))
+
+(defun load-failures (&key (pathname "failures.lsp"))
+  (length (setq $y (with-open-file (s pathname :direction :input)
+                                   (loop for x = (read s nil)
+                                         while x collect x)))))
+
+(defun tn (n &optional (size 100))
+  (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n))))))
+
+(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
+
+(defparameter *random-special-vars*
+  #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
+
+(defparameter *loop-random-int-form-period* 2000)
+
+(defmacro cl-handler-bind (&rest args)
+  `(cl:handler-bind ,@args))
+
+(defmacro cl-handler-case (&rest args)
+  `(cl:handler-case ,@args))
+
+(eval-when
+ (:compile-toplevel :load-toplevel :execute)
+ (defun cumulate (vec)
+   (loop for i from 1 below (length vec)
+         do (incf (aref vec i) (aref vec (1- i))))
+   vec))
+
+(defparameter *default-make-random-integer-form-cdf*
+  (cumulate (copy-seq #(10 5 40 4 5 4 2 2 10 1 1 #-armedbead 1 #-armedbear 1
+                       #-allegro 5 5 5 #-(or gcl ecl armedbear) 2
+                       2 #-(or cmu allegro poplog) 5 4 30
+                       4 20 3 2 2 1 1 5 30 #-poplog 5
+                       #-(or allegro poplog) 10
+                       50 4 4 10 20 10 10 3
+                       20 5 #-(or armedbear) 20
+                       2 2 2))))
+
+(defparameter *make-random-integer-form-cdf*
+  (copy-seq *default-make-random-integer-form-cdf*))
+
+(eval-when
+ (:compile-toplevel :load-toplevel :execute)
+ (defmacro with-random-integer-form-params (&body forms)
+   (let ((len (gensym "LEN"))
+         (vec (gensym "VEC")))
+     `(let* ((,len (length *default-make-random-integer-form-cdf*))
+             (,vec (make-array ,len)))
+        (loop for i from 0 below ,len do (setf (aref ,vec i)
+                                               (1+ (min (random 100)
+                                                        (random 100)))))
+        (setq ,vec (cumulate ,vec))
+        (let ((*make-random-integer-form-cdf* ,vec))
+          ,@forms)))))
+
+;;; Run the random tester, collecting failures into the special
+;;; variable $y.
+
+(defun loop-random-int-forms (&optional (size 200) (nvars 3))
+  (unless (boundp '$x) (setq $x nil))
+  (unless (boundp '$y) (setq $y nil))
+  (loop
+   for i from 1
+   do
+   (format t "~6D | " i)
+   (finish-output *standard-output*)
+   (let ((x (test-random-integer-forms
+             size nvars *loop-random-int-form-period*
+             :index (* (1- i) *loop-random-int-form-period*))))
+     (when x
+       (setq $x (append $x x))
+       (setq x (prune-results x))
+       (terpri) (print x) (finish-output *standard-output*)
+       (setq $y (append $y x)))
+     (terpri))))
+
+(defvar *random-int-form-blocks* nil)
+(defvar *random-int-form-catch-tags* nil)
+(defvar *go-tags* nil)
+
+(defvar *random-vals-list-bound* 10)
+
+(defvar *max-compile-time* 0)
+(defvar *max-compile-term* nil)
+
+(defvar *print-immediately* nil)
+
+(defvar *compile-unoptimized-form*
+  #+(or allegro sbcl) t
+  #-(or allegro sbcl) nil)
+
+(declaim (special *vars*))
+
+(defstruct var-desc
+  (name nil :type symbol)
+  (type t))
+
+(defun test-random-integer-forms
+  (size nvars n
+        &key ((:random-state *random-state*) (make-random-state t))
+        (file-prefix "b")
+        (index 0)
+        (random-size nil)
+        (random-nvars nil)
+        )
+
+  "Generate random integer forms of size SIZE with NVARS variables.
+   Do this N times, returning all those on which a discrepancy
+   is found between optimized and nonoptimize, notinlined code."
+
+  (assert (integerp nvars))
+  (assert (<= 1 nvars 26))
+  (assert (and (integerp n) (plusp n)))
+  (assert (and (integerp n) (plusp size)))
+
+  (loop for i from 1 to n
+        do (when (= (mod i 100) 0)
+              ;; #+sbcl (print "Do gc...")
+              ;; #+sbcl (sb-ext::gc :full t)
+              ;; #+lispworks-personal-edition (cl-user::normal-gc)
+              (prin1 i) (princ " ") (finish-output *standard-output*))
+         nconc (let ((result (test-random-integer-form
+                              (if random-size (1+ (random size)) size)
+                              (if random-nvars (1+ (random nvars)) nvars)
+                              :index (+ index i)
+                              :file-prefix file-prefix)))
+                 (when result
+                   (let ((*print-readably* nil))
+                     (format t "~%~A~%" (format nil "~S" (car result)))
+                     (finish-output *standard-output*)))
+                 result)))
+
+(defun test-random-integer-form
+  (size nvars &key (index 0) (file-prefix "b"))
+  (let* ((vars (subseq '(a b c d e f g h i j k l m
+                           n o p q r s u v w x y z) 0 nvars))
+         (var-ranges (mapcar #'make-random-integer-range vars))
+         (var-types (mapcar #'(lambda (range)
+                                (let ((lo (car range))
+                                      (hi (cadr range)))
+                                  (assert (>= hi lo))
+                                  `(integer ,lo ,hi)))
+                            var-ranges))
+         (form (let ((*vars* (loop for v in vars
+                                   for tp in var-types
+                                   collect (make-var-desc :name v
+                                                          :type tp)))
+                     (*random-int-form-blocks* nil)
+                     (*random-int-form-catch-tags* nil)
+                     (*go-tags* nil)
+                     )
+                 (with-random-integer-form-params
+                  (make-random-integer-form (1+ (random size))))))
+         (vals-list
+          (loop repeat *random-vals-list-bound*
+                collect
+                (mapcar #'(lambda (range)
+                            (let ((lo (car range))
+                                  (hi (cadr range)))
+                              (random-from-interval (1+ hi) lo)))
+                        var-ranges)))
+         (opt-decls-1 (make-random-optimize-settings))
+         (opt-decls-2 (make-random-optimize-settings)))
+    (when *print-immediately*
+      (with-open-file
+       (s (format nil "~A~A.lsp" file-prefix index)
+          :direction :output :if-exists :error)
+       (print `(defparameter *x*
+                 '(:vars ,vars
+                      :var-types ,var-types
+                      :vals-list ,vals-list
+                      :decls1 ,opt-decls-1
+                      :decls2 ,opt-decls-2
+                      :form ,form))
+              s)
+       (print '(load "c.lsp") s)
+       (finish-output s))
+       ;; (cl-user::gc)
+       ;; (make-list 1000000)
+      )
+    (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2)))
+
+(defun make-random-optimize-settings ()
+  (loop for settings = (list*
+                        (list 'speed (random 4))
+                        #+sbcl '(sb-c:insert-step-conditions 0)
+                        (loop for s in '(space safety debug compilation-speed)
+                              for n = (random 4)
+                              collect (list s n)))
+        while
+        #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal)
+        #-allegro nil
+        finally (return (random-permute settings))))
+
+(defun fn-symbols-in-form (form)
+  "Return a list of the distinct standardized lisp function
+   symbols occuring ing FORM.  These are used to generate a NOTINLINE
+   declaration for the unoptimized form."
+  (intersection
+   (remove-duplicates (fn-symbols-in-form* form) :test #'eq)
+   *cl-function-or-accessor-symbols*))
+
+(defun fn-symbols-in-form* (form)
+  (when (consp form)
+    (if (symbolp (car form))
+        (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form)))
+      (mapcan #'fn-symbols-in-form* form))))
+
+(defun fn-arg-name (fn-name arg-index)
+  (intern (concatenate 'string
+                       (subseq (symbol-name fn-name) 1)
+                       (format nil "-~D" arg-index))
+          (symbol-package fn-name)))
+
+(declaim (special *flet-names*))
+(defparameter *flet-names* nil)
+
+
+
+(defun random-var-desc ()
+  (loop
+   (let* ((pos (random (length *vars*)))
+          (desc (elt *vars* pos)))
+     (when (= pos (position (var-desc-name desc) (the list *vars*)
+                            :key #'var-desc-name))
+       (return desc)))))
+
+(defun is-zero-rank-integer-array-type (type)
+  "This function was introduced because of a bug in ACL 6.2"
+  ; (subtypep type '(array integer 0))
+  (and (consp type)
+       (eq (car type) 'array)
+       (cddr type)
+       (or (eq (cadr type) '*)
+           (subtypep (cadr type) 'integer))
+       (or (eql (caddr type) 0)
+           (null (caddr type)))))
+
+(defun make-random-integer-form (size)
+  "Generate a random legal lisp form of size SIZE (roughly)."
+
+  (if (<= size 1)
+      ;; Leaf node -- generate a variable, constant, or flet function call
+      (loop
+       when
+       (rcase
+        (10 (make-random-integer))
+        (9 (if *vars*
+               (let* ((desc (random-var-desc))
+                      (type (var-desc-type desc))
+                      (name (var-desc-name desc)))
+                 (cond
+                  ((subtypep type 'integer) name)
+                  (; (subtypep type '(array integer 0))
+                   (is-zero-rank-integer-array-type type)
+                   `(aref ,name))
+                  ((subtypep type '(cons integer integer))
+                   (rcase (1 `(car ,name))
+                          (1 `(cdr ,name))))
+                  (t nil)))
+             nil))
+        (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil))
+        (2 (if *flet-names*
+               (let* ((flet-entry (random-from-seq *flet-names*))
+                      (flet-name (car flet-entry))
+                      (flet-minargs (cadr flet-entry))
+                      (flet-maxargs (caddr flet-entry))
+                      (nargs (random-from-interval (1+ flet-maxargs) flet-minargs))
+                      (args (loop repeat nargs
+                                  collect (make-random-integer-form 1))))
+                 `(,flet-name ,@args))
+             nil)))
+       return it)
+    ;; (> size 1)
+    (rselect *make-random-integer-form-cdf*
+
+     ;; flet call
+     (make-random-integer-flet-call-form size)
+     (make-random-aref-form size)
+     ;; Unary ops
+     (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate
+                                     rational rationalize
+                                     numerator denominator
+                                     identity progn floor
+                                     ;; #-(or armedbear)
+                                     ignore-errors
+                                     cl:handler-case
+                                     restart-case
+                                     ceiling truncate round realpart imagpart
+                                     integer-length logcount values
+                                     locally))))
+        `(,op ,(make-random-integer-form (1- size))))
+
+     (make-random-integer-unwind-protect-form size)
+     (make-random-integer-mapping-form size)
+
+     ;; prog1, multiple-value-prog1
+     (let* ((op (random-from-seq #(prog1 multiple-value-prog1)))
+            (nforms (random 4))
+            (sizes (random-partition (1- size) (1+ nforms)))
+            (args (mapcar #'make-random-integer-form sizes)))
+       `(,op ,@args))
+
+     ;; prog2
+     (let* ((nforms (random 4))
+            (sizes (random-partition (1- size) (+ nforms 2)))
+            (args (mapcar #'make-random-integer-form sizes)))
+       `(prog2 ,@args))
+
+     `(isqrt (abs ,(make-random-integer-form (- size 2))))
+
+     `(the integer ,(make-random-integer-form (1- size)))
+
+     `(cl:handler-bind nil ,(make-random-integer-form (1- size)))
+     `(restart-bind nil ,(make-random-integer-form (1- size)))
+     #-armedbear
+     `(macrolet () ,(make-random-integer-form (1- size)))
+     #-armedbear
+     `(symbol-macrolet () ,(make-random-integer-form (1- size)))
+
+     ;; dotimes
+     #-allegro
+     (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4)))
+            (count (random 4))
+            (sizes (random-partition (1- size) 2))
+            (body (let ((*vars* (cons (make-var-desc :name var :type nil)
+                                      *vars*)))
+                    (make-random-integer-form (first sizes))))
+            (ret-form (make-random-integer-form (second sizes))))
+       (unless (consp body) (setq body `(progn ,body)))
+       `(dotimes (,var ,count ,ret-form) ,body))
+
+     ;; loop
+     (make-random-loop-form (1- size))
+
+     (make-random-count-form size)
+
+     #-(or gcl ecl armedbear)
+     ;; load-time-value
+     (let ((arg (let ((*flet-names* nil)
+                      (*vars* nil)
+                      (*random-int-form-blocks* nil)
+                      (*random-int-form-catch-tags* nil)
+                      (*go-tags* nil))
+                  (make-random-integer-form (1- size)))))
+       (rcase
+        (4 `(load-time-value ,arg t))
+        (2 `(load-time-value ,arg))
+        (2 `(load-time-value ,arg nil))))
+
+     ;; eval
+     (make-random-integer-eval-form size)
+
+     #-(or cmu allegro poplog)
+     (destructuring-bind (s1 s2)
+        (random-partition (- size 2) 2)
+        `(ash ,(make-random-integer-form s1)
+              (min ,(random 100)
+                   ,(make-random-integer-form s2))))
+
+     ;; binary floor, ceiling, truncate, round
+     (let ((op (random-from-seq #(floor ceiling truncate round mod rem)))
+           (op2 (random-from-seq #(max min))))
+       (destructuring-bind (s1 s2)
+          (random-partition (- size 2) 2)
+          `(,op  ,(make-random-integer-form s1)
+                 (,op2  ,(if (eq op2 'max)
+                             (1+ (random 100))
+                           (- (1+ (random 100))))
+                        ,(make-random-integer-form s2)))))
+
+     ;; Binary op
+     (let* ((op (random-from-seq
+                  '(+ - *  logand min max gcd
+                      lcm
+                      #-:allegro
+                      logandc1
+                      logandc2 logeqv logior lognand lognor
+                      #-:allegro
+                      logorc1
+                      logorc2
+                      logxor
+                      ))))
+        (destructuring-bind (leftsize rightsize)
+            (random-partition (1- size) 2)
+          (let ((e1 (make-random-integer-form leftsize))
+                (e2 (make-random-integer-form rightsize)))
+            `(,op ,e1 ,e2))))
+
+     ;; boole
+     (let* ((op (random-from-seq
+                  #(boole-1 boole-2 boole-and boole-andc1 boole-andc2
+                    boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand
+                    boole-nor boole-orc1 boole-orc2 boole-set boole-xor))))
+        (destructuring-bind (leftsize rightsize)
+            (random-partition (- size 2) 2)
+          (let ((e1 (make-random-integer-form leftsize))
+                (e2 (make-random-integer-form rightsize)))
+            `(boole ,op ,e1 ,e2))))
+
+     ;; n-ary ops
+     (let* ((op (random-from-seq #(+ - * logand min max
+                                      logior values lcm gcd logxor)))
+             (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40)))))
+             (nargs (1+ (min (random nmax) (random nmax))))
+             (sizes (random-partition (1- size) nargs))
+             (args (mapcar #'make-random-integer-form sizes)))
+        `(,op ,@args))
+
+     ;; expt
+     `(expt ,(make-random-integer-form (1- size)) ,(random 3))
+
+     ;; coerce
+     `(coerce ,(make-random-integer-form (1- size)) 'integer)
+
+     ;; complex (degenerate case)
+     `(complex ,(make-random-integer-form (1- size)) 0)
+
+     ;; quotient (degenerate cases)
+     `(/ ,(make-random-integer-form (1- size)) 1)
+     `(/ ,(make-random-integer-form (1- size)) -1)
+
+     ;; tagbody
+     (make-random-tagbody-and-progn size)
+
+     ;; conditionals
+     (let* ((cond-size (random (max 1 (floor size 2))))
+            (then-size (random (- size cond-size)))
+            (else-size (- size 1 cond-size then-size))
+            (pred (make-random-pred-form cond-size))
+            (then-part (make-random-integer-form then-size))
+            (else-part (make-random-integer-form else-size)))
+       `(if ,pred ,then-part ,else-part))
+     #-poplog
+      (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
+        `(,(random-from-seq '(deposit-field dpb))
+          ,(make-random-integer-form s1)
+          ,(make-random-byte-spec-form s2)
+          ,(make-random-integer-form s3)))
+
+     #-(or allegro poplog)
+      (destructuring-bind (s1 s2) (random-partition (1- size) 2)
+          `(,(random-from-seq '(ldb mask-field))
+            ,(make-random-byte-spec-form s1)
+            ,(make-random-integer-form s2)))
+
+     (make-random-integer-binding-form size)
+
+     ;; progv
+     (make-random-integer-progv-form size)
+
+     `(let () ,(make-random-integer-form (1- size)))
+
+      (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8)))
+             (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
+        `(block ,name ,(make-random-integer-form (1- size))))
+
+      (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))
+             (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
+        `(catch ,tag ,(make-random-integer-form (1- size))))
+
+      ;; setq and similar
+      (make-random-integer-setq-form size)
+
+      (make-random-integer-case-form size)
+
+      (if *random-int-form-blocks*
+          (let ((name (random-from-seq *random-int-form-blocks*))
+                (form (make-random-integer-form (1- size))))
+            `(return-from ,name ,form))
+        ;; No blocks -- try again
+        (make-random-integer-form size))
+
+      (if *random-int-form-catch-tags*
+          (let ((tag (random-from-seq *random-int-form-catch-tags*))
+                (form (make-random-integer-form (1- size))))
+            `(throw ,tag ,form))
+        ;; No catch tags -- try again
+        (make-random-integer-form size))
+
+      (if *random-int-form-blocks*
+          (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
+            (let ((name (random-from-seq *random-int-form-blocks*))
+                  (pred (make-random-pred-form s1))
+                  (then (make-random-integer-form s2))
+                  (else (make-random-integer-form s3)))
+              `(if ,pred (return-from ,name ,then) ,else)))
+        ;; No blocks -- try again
+        (make-random-integer-form size))
+
+     #-(or armedbear)
+     (make-random-flet-form size)
+
+      (let* ((nbits (1+ (min (random 20) (random 20))))
+             (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector))
+             (op (random-from-seq #(bit sbit))))
+        `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits))))))
+
+      (let* ((nvals (1+ (min (random 20) (random 20))))
+             (lim (ash 1 (+ 3 (random 40))))
+             (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector))
+             (op (random-from-seq #(aref svref elt))))
+        `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))
+
+      (let* ((nvals (1+ (min (random 20) (random 20))))
+             (lim (ash 1 (+ 3 (random 40))))
+             (vals (loop repeat nvals collect (random lim)))
+             (op 'elt))
+        `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))
+
+     )))
+
+(defun make-random-aref-form (size)
+  (or
+   (when *vars*
+     (let* ((desc (random-var-desc))
+            (type (var-desc-type desc))
+            (name (var-desc-name desc)))
+       (cond
+        ((null type) nil)
+        ((subtypep type '(array integer (*)))
+         `(aref ,name (min ,(1- (first (third type)))
+                           (max 0 ,(make-random-integer-form (- size 2))))))
+        ((subtypep type '(array integer (* *)))
+         (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
+           `(aref ,name
+                  (min ,(1- (first (third type)))
+                       (max 0 ,(make-random-integer-form s1)))
+                  (min ,(1- (second (third type)))
+                       (max 0 ,(make-random-integer-form s2))))))
+        (t nil))))
+   (make-random-integer-form size)))
+
+(defun make-random-count-form (size)
+  (destructuring-bind (s1 s2)
+      (random-partition (1- size) 2)
+    (let ((arg1 (make-random-integer-form s1))
+          (arg2-args (loop repeat s2 collect (make-random-integer))))
+      (let ((op 'count)
+            (test (random-from-seq #(eql = /= < > <= >=)))
+            (arg2 (rcase
+                   (1 (make-array (list s2) :initial-contents arg2-args))
+                   (1
+                    (let* ((mask (1- (ash 1 (1+ (random 32))))))
+                      (make-array (list s2)
+                                  :initial-contents
+                                  (mapcar #'(lambda (x) (logand x mask)) arg2-args)
+                                  :element-type `(integer 0 ,mask))))
+                   (1 `(quote ,arg2-args)))))
+        `(,op ,arg1 ,arg2 ,@(rcase
+                                    (2 nil)
+                                    (1 (list :test `(quote ,test)))
+                                    (1 (list :test-not `(quote ,test)))))))))
+
+(defun make-random-integer-flet-call-form (size)
+  (if *flet-names*
+      (let* ((flet-entry (random-from-seq *flet-names*))
+             (flet-name (car flet-entry))
+             (flet-minargs (cadr flet-entry))
+             (flet-maxargs (caddr flet-entry))
+             (nargs (random-from-interval (1+ flet-maxargs) flet-minargs))
+             )
+        (cond
+         ((> nargs 0)
+          (let* ((arg-sizes (random-partition (1- size) nargs))
+                 (args (mapcar #'make-random-integer-form arg-sizes)))
+            (rcase
+             (1 `(,flet-name ,@args))
+             (1 `(multiple-value-call #',flet-name (values ,@args)))
+             (1 `(funcall (function ,flet-name) ,@args))
+             (1 (let ((r (random (1+ (length args)))))
+                  `(apply (function ,flet-name)
+                          ,@(subseq args 0 r)
+                          (list ,@(subseq args r))))))))
+         (t (make-random-integer-form size))))
+    (make-random-integer-form size)))
+
+(defun make-random-integer-unwind-protect-form (size)
+  (let* ((op 'unwind-protect)
+         (nforms (random 4))
+         (sizes (random-partition (1- size) (1+ nforms)))
+         (arg (make-random-integer-form (first sizes)))
+         (unwind-forms
+          ;; We have to be careful not to generate code that will
+          ;; illegally transfer control to a dead location
+          (let ((*flet-names* nil)
+                (*go-tags* nil)
+                (*random-int-form-blocks* nil)
+                (*random-int-form-catch-tags* nil))
+            (mapcar #'make-random-integer-form (rest sizes)))))
+    `(,op ,arg ,@unwind-forms)))
+
+(defun make-random-integer-eval-form (size)
+  (flet ((%arg (size)
+               (let ((*flet-names* nil)
+                     (*vars* (remove-if-not #'(lambda (s)
+                                                (find (var-desc-name s)
+                                                      *random-special-vars*))
+                                            *vars*))
+                     (*random-int-form-blocks* nil)
+                     (*go-tags* nil))
+                 (make-random-integer-form size))))
+    (rcase
+     (2 `(eval ',(%arg (1- size))))
+     (2 (let* ((nargs (1+ (random 4)))
+               (sizes (random-partition (1- size) nargs))
+               (args (mapcar #'%arg sizes)))
+          `(eval (values ,@args))))
+     )))
+
+(defun make-random-type-for-var (var e1)
+  (let (desc)
+    (values
+     (cond
+      ((and (find var *random-special-vars*)
+            (setq desc (find var *vars* :key #'var-desc-name)))
+       (var-desc-type desc))
+      (t (rcase
+          (4 '(integer * *))
+          (1 (setq e1 `(make-array nil :initial-element ,e1
+                                   ,@(rcase (1 nil) (1 '(:adjustable t)))))
+             '(array integer nil))
+          (1 (let ((size (1+ (random 10))))
+               (setq e1 `(make-array '(,size):initial-element ,e1
+                                     ,@(rcase (1 nil) (1 '(:adjustable t)))))
+               `(array integer (,size))))
+          #|
+          (1 (let ((size1 (1+ (random 10)))
+                   (size2 (1+ (random 10))))
+               (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1
+                                     ,@(rcase (1 nil) (1 '(:adjustable t)))))
+               `(array integer (,size1 ,size2))))
+          |#
+          (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1)))
+             '(cons integer integer))
+          (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1))
+             '(cons integer integer)))))
+     e1)))
+
+(defun random2 (n)
+  (min (random n) (random n)))
+
+(defun random-from-seq2 (seq)
+  (elt seq (random2 (length seq))))
+
+(defun make-random-integer-binding-form (size)
+  (destructuring-bind (s1 s2) (random-partition (1- size) 2)
+    (let* ((var (random-from-seq2 (rcase
+                                   (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))
+                                   #-ecl (2 *random-special-vars*)
+                                   )))
+           (e1 (make-random-integer-form s1))
+           (type (multiple-value-bind (type2 e)
+                     (make-random-type-for-var var e1)
+                   (setq e1 e)
+                   type2))
+           (e2 (let ((*vars* (cons (make-var-desc :name var :type type)
+                                   *vars*)))
+                 (make-random-integer-form s2)))
+           (op (random-from-seq #(let let*))))
+      ;; for now, avoid shadowing
+      (if (member var *vars* :key #'var-desc-name)
+          (make-random-integer-form size)
+        (rcase
+         (8 `(,op ((,var ,e1))
+                  ,@(rcase (1 `((declare (dynamic-extent ,var))))
+                           (3 nil))
+                  ,e2))
+         (2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
+
+(defun make-random-integer-progv-form (size)
+  (let* ((num-vars (random 4))
+         (possible-vars *random-special-vars*)
+         (vars nil))
+    (loop repeat num-vars
+          do (loop for r = (elt possible-vars (random (length possible-vars)))
+                   while (member r vars)
+                   finally (push r vars)))
+    (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name)))
+                                            (and desc (not (subtypep (var-desc-type desc) 'integer)))))
+                          vars)
+          num-vars (length vars))
+    (if (null vars)
+        `(progv nil nil ,(make-random-integer-form (1- size)))
+      (destructuring-bind (s1 s2) (random-partition (1- size) 2)
+        (let* ((var-sizes (random-partition s1 num-vars))
+               (var-forms (mapcar #'make-random-integer-form var-sizes))
+               (*vars* (append (loop for v in vars collect
+                                     (make-var-desc :name v :type '(integer * *)))
+                               *vars*))
+               (body-form (make-random-integer-form s2)))
+          `(progv ',vars (list ,@var-forms) ,body-form))))))
+
+(defun make-random-integer-mapping-form (size)
+  ;; reduce
+  (let ((keyargs nil)
+        (nargs (1+ (random (min 10 (max 1 size)))))
+        (sequence-op (random-from-seq '(vector list))))
+    (when (coin 2) (setq keyargs '(:from-end t)))
+    (cond
+     ((coin 2)
+      (let ((start (random nargs)))
+        (setq keyargs `(:start ,start ,@keyargs))
+        (when (coin 2)
+          (let ((end (+ start 1 (random (- nargs start)))))
+            (setq keyargs `(:end ,end ,@keyargs))))))
+     (t
+      (when (coin 2)
+        (let ((end (1+ (random nargs))))
+          (setq keyargs `(:end ,end ,@keyargs))))))
+    (rcase
+     (1
+      (let ((sizes (random-partition (1- size) nargs))
+            (op (random-from-seq #(+ - * logand logxor logior max min))))
+        `(reduce ,(rcase (1 `(function ,op))
+                         (1 `(quote ,op)))
+                 (,sequence-op
+                  ,@(mapcar #'make-random-integer-form sizes))
+                 ,@keyargs)))
+     #-(or armedbear)
+     (1
+      (destructuring-bind (size1 size2) (random-partition (1- size) 2)
+        (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6))
+               (var1 (random-from-seq vars))
+               (var2 (random-from-seq (remove var1 vars)))
+               (form (let ((*vars* (list*
+                                    (make-var-desc :name var1 :type '(integer * *))
+                                    (make-var-desc :name var2 :type '(integer * *))
+                                    *vars*)))
+                       (make-random-integer-form size1)))
+               (sizes (random-partition size2 nargs))
+               (args (mapcar #'make-random-integer-form sizes)))
+          `(reduce (function (lambda (,var1 ,var2) ,form))
+                   (,sequence-op ,@args)
+                   ,@keyargs)))))))
+
+(defun make-random-integer-setq-form (size)
+  (if *vars*
+      (let* ((vdesc (random-from-seq *vars*))
+             (var (var-desc-name vdesc))
+             (type (var-desc-type vdesc))
+             (op (random-from-seq #(setq setf shiftf))))
+        (cond
+         ((subtypep '(integer * *) type)
+          (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
+          (rcase
+           (1 (when (find var *random-special-vars*)
+                (setq op (random-from-seq #(setf shiftf))
+                      var `(symbol-value ',var))))
+           (1 (setq op 'multiple-value-setq)
+              (setq var (list var)))
+           (5 (setf op (random-from-seq #(setq setf shiftf incf decf)))))
+          `(,op ,var ,(make-random-integer-form (1- size))))
+         ((and (consp type)
+               (eq (car type) 'integer)
+               (integerp (second type))
+               (integerp (third type)))
+          (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
+          (rcase
+           (1 (when (find var *random-special-vars*)
+                (setq op (random-from-seq #(setf shiftf))
+                      var `(symbol-value ',var))))
+           (1 (setq op 'multiple-value-setq)
+              (setq var (list var)))
+           (5 nil))
+          `(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
+         ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil))
+          (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
+          (when (eq op 'setq)
+            (setq op (random-from-seq #(setf shiftf))))
+          `(,op (aref ,var) ,(make-random-integer-form (- size 2))))
+         ((and type (subtypep type '(array integer (*))))
+          (when (eq op 'setq)
+            (setq op (random-from-seq #(setf shiftf))))
+          (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
+            `(,op (aref ,var (min ,(1- (first (third type)))
+                                  (max 0
+                                       ,(make-random-integer-form s1))))
+                  ,(make-random-integer-form s2))))
+         ((and type (subtypep type '(array integer (* *))))
+          (when (eq op 'setq)
+            (setq op (random-from-seq #(setf shiftf))))
+          (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3)
+            `(,op (aref ,var
+                        (min ,(1- (first (third type)))
+                             (max 0
+                                  ,(make-random-integer-form s1)))
+                        (min ,(1- (second (third type)))
+                             (max 0
+                                  ,(make-random-integer-form s2))))
+                  ,(make-random-integer-form s3))))
+         ;; Abort -- can't assign
+         (t (make-random-integer-form size))))
+    (make-random-integer-form size)))
+
+
+(defun make-random-integer-case-form (size)
+  (let ((ncases (1+ (random 10))))
+    (if (< (+ size size) (+ ncases 2))
+        ;; Too small, give up
+        (make-random-integer-form size)
+      (let* ((sizes (random-partition (1- size) (+ ncases 2)))
+             (bound (ash 1 (+ 2 (random 16))))
+             (lower-bound (if (coin 3) 0 (- bound)))
+             (upper-bound (if (and (< lower-bound 0) (coin 3))
+                              1
+                            (1+ bound)))
+             (cases
+              (loop
+               for case-size in (cddr sizes)
+               for vals = (loop repeat (1+ (min (random 10) (random 10)))
+                                collect (random-from-interval
+                                         upper-bound lower-bound))
+               for result = (make-random-integer-form case-size)
+               repeat ncases
+               collect `(,vals ,result)))
+             (expr (make-random-integer-form (first sizes))))
+        `(case ,expr
+           ,@cases
+           (t ,(make-random-integer-form (second sizes))))))))
+
+(defun make-random-flet-form (size)
+  "Generate random flet, labels forms, for now with no arguments
+   and a single binding per form."
+  (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10
+                                  %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))))
+    (if (assoc fname *flet-names*)
+        ;; Fail if the name is in use
+        (make-random-integer-form size)
+      (let* ((op (random-from-seq #(flet labels)))
+             (minargs (random 4))
+             (maxargs #+:allegro minargs
+                      #-:allegro
+                      (rcase
+                       (1 minargs)
+                       (1 (+ minargs (random 4)))))
+             (keyarg-p (coin 2))
+             (keyarg-n (if keyarg-p (random 3) 0))
+             (arg-names (loop for i from 1 to maxargs
+                              collect (fn-arg-name fname i)))
+             (key-arg-names (loop for i from 1 to keyarg-n
+                                  collect (intern (format nil "KEY~A" i)
+                                                  (find-package "CL-TEST"))))
+             (allow-other-keys (and keyarg-p (coin 3)))
+             )
+        (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs))))
+               (s1 (car sizes))
+               (s2 (cadr sizes))
+               (opt-sizes (cddr sizes)))
+          (let* ((form1
+                  ;; Allow return-from of the flet/labels function
+                  (let ((*random-int-form-blocks*
+                         (cons fname *random-int-form-blocks*))
+                        (*vars* (nconc (loop for var in (append arg-names key-arg-names)
+                                             collect (make-var-desc :name var
+                                                                    :type '(integer * *)))
+                                       *vars*)))
+                    (make-random-integer-form s1)))
+                 (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p)
+                                                  *flet-names*)))
+                          (make-random-integer-form s2)))
+                 (opt-forms (mapcar #'make-random-integer-form opt-sizes)
+                            ))
+            (if opt-forms
+                `(,op ((,fname (,@(subseq arg-names 0 minargs)
+                                  &optional
+                                  ,@(mapcar #'list
+                                            (subseq arg-names minargs)
+                                            opt-forms)
+                                  ,@(when keyarg-p
+                                      (append '(&key)
+                                              (mapcar #'list
+                                                      key-arg-names
+                                                      (subseq opt-forms (- maxargs minargs)))
+                                              (when allow-other-keys '(&allow-other-keys))
+                                              )))
+                               ,form1))
+                      ,form2)
+              `(,op ((,fname (,@arg-names
+                              ,@(when keyarg-p
+                                  (append '(&key)
+                                          (mapcar #'list
+                                                  key-arg-names
+                                                  opt-forms )
+                                          (when allow-other-keys '(&allow-other-keys))
+                                          )))
+                             ,form1))
+                    ,form2))))))))
+
+(defun make-random-tagbody (size)
+  (let* ((num-forms (random 6))
+         (tags nil))
+    (loop for i below num-forms
+          do (loop for tag = (rcase
+                              #-allegro (1 (random 8))
+                              (1 (random-from-seq #(tag1 tag2 tag3 tag4
+                                                         tag5 tag6 tag7 tag8))))
+                   while (member tag tags)
+                   finally (push tag tags)))
+    (assert (= (length (remove-duplicates tags)) (length tags)))
+    (let* ((*go-tags* (set-difference *go-tags* tags))
+           (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil))
+           (forms
+            (loop for tag-list on tags
+                  for i below num-forms
+                  for size in sizes
+                  collect (let ((*go-tags* (append tag-list *go-tags*)))
+                            (make-random-integer-form size)))))
+      `(tagbody ,@(loop for tag in tags
+                        for form in forms
+                        when (atom form) do (setq form `(progn ,form))
+                        append `(,form ,tag))))))
+
+(defun make-random-tagbody-and-progn (size)
+  (let* ((final-size (random (max 1 (floor size 5))))
+         (tagbody-size (- size final-size)))
+    (let ((final-form (make-random-integer-form final-size))
+          (tagbody-form (make-random-tagbody tagbody-size)))
+      `(progn ,tagbody-form ,final-form))))
+
+(defun make-random-pred-form (size)
+  "Make a random form whose value is to be used as a generalized boolean."
+  (if (<= size 1)
+      (rcase
+        (1 (if (coin) t nil))
+        (2
+         `(,(random-from-seq '(< <= = > >= /= eql equal))
+           ,(make-random-integer-form size)
+           ,(make-random-integer-form size))))
+    (rcase
+      (1 (if (coin) t nil))
+      (3 `(not ,(make-random-pred-form (1- size))))
+      (12 (destructuring-bind (leftsize rightsize)
+             (random-partition (1- size) 2)
+           `(,(random-from-seq '(and or))
+             ,(make-random-pred-form leftsize)
+             ,(make-random-pred-form rightsize))))
+      (1 (let* ((nsizes (+ 1 (random 3)))
+                (sizes (random-partition (1- size) nsizes)))
+           `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal)
+                                 #(< <= > >= = /=)))
+             ,@(mapcar #'make-random-integer-form sizes))))
+      (3 (let* ((cond-size (random (max 1 (floor size 2))))
+                (then-size (random (- size cond-size)))
+                (else-size (- size 1 cond-size then-size))
+                (pred (make-random-pred-form cond-size))
+                (then-part (make-random-pred-form then-size))
+                (else-part (make-random-pred-form else-size)))
+           `(if ,pred ,then-part ,else-part)))
+      #-poplog
+      (1 (destructuring-bind (s1 s2)
+             (random-partition (1- size) 2)
+           `(ldb-test ,(make-random-byte-spec-form s1)
+                      ,(make-random-integer-form s2))))
+      (2 (let ((form (make-random-integer-form (1- size)))
+               (op (random-from-seq #(evenp oddp minusp plusp zerop))))
+           `(,op ,form)))
+      (2 (destructuring-bind (s1 s2)
+             (random-partition (1- size) 2)
+           (let ((arg1 (make-random-integer-form s1))
+                 (arg2-args (loop repeat s2 collect (make-random-integer))))
+             (let ((op (random-from-seq #(find position)))
+                   (test (random-from-seq #(eql = /= < > <= >=)))
+                   (arg2 (rcase
+                          (1 (make-array (list s2) :initial-contents arg2-args))
+                          (1
+                           (let* ((mask (1- (ash 1 (1+ (random 32))))))
+                             (make-array (list s2)
+                                         :initial-contents
+                                         (mapcar #'(lambda (x) (logand x mask)) arg2-args)
+                                        :element-type `(integer 0 ,mask))))
+                          (1 `(quote ,arg2-args)))))
+               `(,op ,arg1 ,arg2 ,@(rcase
+                                    (2 nil)
+                                    (1 (list :test `(quote ,test)))
+                                    (1 (list :test-not `(quote ,test)))))))))
+
+      (1 (let ((index (random (1+ (random *maximum-random-int-bits*))))
+               (form (make-random-integer-form (1- size))))
+           `(logbitp ,index ,form)))
+      (1 ;; typep form
+       (let ((subform (make-random-integer-form (- size 2)))
+             (type
+              (rcase
+               (1 `(real ,@(make-random-integer-range)))
+               (1 `(rational ,@(make-random-integer-range)))
+               (1 `(rational ,(+ 1/2 (make-random-integer))))
+               (1 `(rational * ,(+ 1/2 (make-random-integer))))
+               (1 `(integer ,@(make-random-integer-range)))
+               (1 `(integer ,(make-random-integer)))
+               (1 `(integer * ,(make-random-integer)))
+               (1 'fixnum)
+               (1 'bignum)
+               (1 `(integer)))))
+         `(typep ,subform ',type)))
+      )))
+
+(defun make-random-loop-form (size)
+  (if (<= size 2)
+      (make-random-integer-form size)
+    (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4)))
+           (count (random 4))
+           (*vars* (cons (make-var-desc :name var :type nil)
+                         *vars*)))
+      (rcase
+       (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2))))
+       (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2))))
+       ))))
+
+(defun make-random-byte-spec-form (size)
+  (declare (ignore size))
+  (let* ((pform (random 33))
+         (sform (1+ (random 33))))
+    `(byte ,sform ,pform)))
+
+(defgeneric make-random-element-of-type (type)
+  (:documentation "Create a random element of a lisp type."))
+
+(defgeneric make-random-element-of-compound-type (type-op type-args)
+  (:documentation "Create a random element of type `(,TYPE-OP ,@TYPE-ARGS)")
+  (:method ((type-op (eql 'or)) type-args)
+           (assert type-args)
+           (make-random-element-of-type (random-from-seq type-args)))
+  (:method ((type-op (eql 'and)) type-args)
+           (assert type-args)
+           (loop for x = (make-random-element-of-type (car type-args))
+             repeat 100
+             when (typep x (cons 'and (cdr type-args)))
+             return x
+             finally (error "Cannot generate random element of ~A"
+                            (cons type-op type-args))))
+  (:method ((type-op (eql 'not)) type-args)
+           (assert (eql (length type-args) 1))
+           (make-random-element-of-type `(and t (not ,(car type-args)))))
+  (:method ((type-op (eql 'integer)) type-args)
+           (let ((lo (let ((lo (car type-args)))
+                       (cond
+                        ((consp lo) (1+ (car lo)))
+                        ((eq lo nil) '*)
+                        (t lo))))
+                 (hi (let ((hi (cadr type-args)))
+                       (cond
+                        ((consp hi) (1- (car hi)))
+                        ((eq hi nil) '*)
+                        (t hi)))))
+             (if (eq lo '*)
+                 (if (eq hi '*)
+                     (let ((x (ash 1 (random *maximum-random-int-bits*))))
+                       (random-from-interval x (- x)))
+                   (random-from-interval (1+ hi)
+                                         (- hi (random (ash 1 *maximum-random-int-bits*)))))
+
+               (if (eq hi '*)
+                   (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
+                                         lo)
+                 ;; May generalize the next case to increase odds
+                 ;; of certain integers (near 0, near endpoints, near
+                 ;; powers of 2...)
+                 (random-from-interval (1+ hi) lo)))))
+  (:method ((type-op (eql 'rational)) type-args)
+           (let ((type (cons type-op type-args)))
+             (or
+              (let ((r (make-random-element-of-type 'rational)))
+                (and (typep r type) r))
+              (let ((lo (car type-args))
+                    (hi (cadr type-args))
+                    lo= hi=)
+                (cond
+                 ((consp lo) nil)
+                 ((member lo '(* nil))
+                  (setq lo nil)
+                  (setq lo= nil))
+                 (t
+                  (assert (typep lo 'rational))
+                  (setq lo= t)))
+                (cond
+                 ((consp hi) nil)
+                 ((member hi '(* nil))
+                  (setq hi nil)
+                  (setq hi= nil))
+                 (t
+                  (assert (typep hi 'rational))
+                  (setq hi= t)))
+                (assert (or (null lo) (null hi) (<= lo hi)))
+                (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=)))
+                (cond
+                 ((null lo)
+                  (cond
+                   ((null hi) (make-random-rational))
+                   (hi= (- hi (make-random-nonnegative-rational)))
+                   (t (- hi (make-random-positive-rational)))))
+                 ((null hi)
+                  (cond
+                   (lo= (+ lo (make-random-nonnegative-rational)))
+                   (t (+ lo (make-random-positive-rational)))))
+                 (t
+                  (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))))
+
+  (:method ((type-op (eql 'ratio)) type-args)
+           (let ((r 0))
+             (loop
+              do (setq r (make-random-element-of-compound-type 'rational type-args))
+              while (integerp r))
+             r))
+
+  (:method ((type-op (eql 'real)) type-args)
+           (rcase
+            (1 (let ((lo (and (numberp (car type-args))
+                              (rational (car type-args))))
+                     (hi (and (numberp (cadr type-args))
+                              (rational (cadr type-args)))))
+                 (make-random-element-of-compound-type 'rational
+                                                       `(,(or lo '*)
+                                                         ,(or hi '*)))))
+            (1 (make-random-element-of-compound-type 'float
+                                                     `(,(or (car type-args) '*)
+                                                       ,(or (cadr type-args) '*))))))
+
+  (:method ((type-op (eql 'float)) type-args)
+           (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float)))
+                  (lo (car type-args))
+                  (hi (cadr type-args))
+                  (most-neg (most-negative-float new-type-op))
+                  (most-pos (most-positive-float new-type-op)))
+             (cond
+              ((or (and (realp lo) (< lo most-neg))
+                   (and (realp hi) (> hi most-pos)))
+               ;; try again
+               (make-random-element-of-compound-type type-op type-args))
+              (t
+               (when (and (realp lo) (not (typep lo new-type-op)))
+                 (cond
+                  ((< lo most-neg) (setq lo '*))
+                  (t (setq lo (coerce lo new-type-op)))))
+               (when (and (realp hi) (not (typep hi new-type-op)))
+                 (cond
+                  ((> hi most-pos) (setq hi '*))
+                  (t (setq hi (coerce hi new-type-op)))))
+               (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*)))))))
+
+  (:method ((type-op (eql 'short-float)) type-args)
+           (assert (<= (length type-args) 2))
+           (apply #'make-random-element-of-float-type type-op type-args))
+  (:method ((type-op (eql 'single-float)) type-args)
+           (assert (<= (length type-args) 2))
+           (apply #'make-random-element-of-float-type type-op type-args))
+  (:method ((type-op (eql 'double-float)) type-args)
+           (assert (<= (length type-args) 2))
+           (apply #'make-random-element-of-float-type type-op type-args))
+  (:method ((type-op (eql 'long-float)) type-args)
+           (assert (<= (length type-args) 2))
+           (apply #'make-random-element-of-float-type type-op type-args))
+
+  (:method ((type-op (eql 'mod)) type-args)
+           (let ((modulus (second type-args)))
+             (assert (integerp modulus))
+             (assert (plusp modulus))
+             (make-random-element-of-compound-type 'integer `(0 (,modulus)))))
+
+  (:method ((type-op (eql 'unsigned-byte)) type-args)
+           (assert (<= (length type-args) 1))
+           (if (null type-args)
+               (make-random-element-of-type '(integer 0 *))
+             (let ((bits (first type-args)))
+               (if (eq bits '*)
+                   (make-random-element-of-type '(integer 0 *))
+                 (progn
+                   (assert (and (integerp bits) (>= bits 1)))
+                   (make-random-element-of-type
+                    `(integer 0 ,(1- (ash 1 bits)))))))))
+
+  (:method ((type-op (eql 'signed-byte)) type-args)
+           (assert (<= (length type-args) 1))
+           (if (null type-args)
+               (make-random-element-of-type 'integer)
+             (let ((bits (car type-args)))
+               (if (eq bits'*)
+                   (make-random-element-of-type 'integer)
+                 (progn
+                   (assert (and (integerp bits) (>= bits 1)))
+                   (make-random-element-of-type
+                    `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits))))))))))
+
+  (:method ((type-op (eql 'eql)) type-args)
+           (assert (= (length type-args) 1))
+           (car type-args))
+
+  (:method ((type-op (eql 'member)) type-args)
+           (assert type-args)
+           (random-from-seq type-args))
+
+  (:method ((type-op (eql 'vector)) type-args)
+           (assert (<= (length type-args) 2))
+           (let ((etype-spec (if type-args (car type-args) '*))
+                 (size-spec (if (cdr type-args) (cadr type-args) '*)))
+             (make-random-vector etype-spec size-spec)))
+
+  (:method ((type-op (eql 'aimple-vector)) type-args)
+           (assert (<= (length type-args) 1))
+           (let ((size-spec (if type-args (car type-args) '*)))
+             (make-random-vector t size-spec :simple t)))
+
+  (:method ((type-op (eql 'array)) type-args)
+           (assert (<= (length type-args) 2))
+           (let ((etype-spec (if type-args (car type-args) '*))
+                 (size-spec (if (cdr type-args) (cadr type-args) '*)))
+             (make-random-array etype-spec size-spec)))
+
+  (:method ((type-op (eql 'simple-array)) type-args)
+           (assert (<= (length type-args) 2))
+           (let ((etype-spec (if type-args (car type-args) '*))
+                 (size-spec (if (cdr type-args) (cadr type-args) '*)))
+             (make-random-array etype-spec size-spec :simple t)))
+
+  (:method ((type-op (eql 'string)) type-args)
+           (assert (<= (length type-args) 1))
+           (let ((size-spec (if type-args (car type-args) '*)))
+             (make-random-string size-spec)))
+
+  (:method ((type-op (eql 'simple-string)) type-args)
+           (assert (<= (length type-args) 1))
+           (let ((size-spec (if type-args (car type-args) '*)))
+             (make-random-string size-spec :simple t)))
+
+  (:method ((type-op (eql 'base-string)) type-args)
+           (assert (<= (length type-args) 1))
+           (let ((size-spec (if type-args (car type-args) '*)))
+             (make-random-vector 'base-char size-spec)))
+
+  (:method ((type-op (eql 'simple-base-string)) type-args)
+           (assert (<= (length type-args) 1))
+           (let ((size-spec (if type-args (car type-args) '*)))
+             (make-random-vector 'base-char size-spec :simple t)))
+
+  (:method ((type-op (eql 'bit-vector)) type-args)
+           (assert (<= (length type-args) 1))
+           (let ((size-spec (if type-args (car type-args) '*)))
+             (make-random-vector 'bit size-spec)))
+
+  (:method ((type-op (eql 'simple-bit-vector)) type-args)
+           (assert (<= (length type-args) 1))
+           (let ((size-spec (if type-args (car type-args) '*)))
+             (make-random-vector 'bit size-spec :simple t)))
+
+  (:method ((type-op (eql 'cons)) type-args)
+           (assert (<= (length type-args) 2))
+           (cons (make-random-element-of-type (if type-args (car type-args) t))
+                 (make-random-element-of-type (if (cdr type-args) (cadr type-args) t))))
+
+  (:method ((type-op (eql 'complex)) type-args)
+           (cond
+            ((null type-args)
+             (make-random-element-of-type 'complex))
+            (t
+             (assert (null (cdr type-args)))
+             (let ((etype (car type-args)))
+               (loop for v1 = (make-random-element-of-type etype)
+                     for v2 = (make-random-element-of-type etype)
+                     for c = (complex v1 v2)
+                     when (typep c (cons 'complex type-args))
+                     return c)))))
+  )
+
+(defmethod make-random-element-of-type ((type cons))
+  (make-random-element-of-compound-type (car type) (cdr type)))
+
+(defun make-random-element-of-float-type (type-op &optional lo hi)
+  (let (lo= hi=)
+    (cond
+     ((consp lo) nil)
+     ((member lo '(* nil))
+      (setq lo (most-negative-float type-op))
+      (setq lo= t))
+     (t
+      (assert (typep lo type-op))
+      (setq lo= t)))
+    (cond
+     ((consp hi) nil)
+     ((member hi '(* nil))
+      (setq hi (most-positive-float type-op))
+      (setq hi= t))
+     (t
+      (assert (typep hi type-op))
+      (setq hi= t)))
+    (assert (<= lo hi))
+    (assert (or (< lo hi) (and lo= hi=)))
+    (let ((limit 100000))
+      (cond
+       ((or (<= hi 0)
+            (>= lo 0)
+            (and (<= (- limit) hi limit) (<= (- limit) lo limit)))
+        (loop for x = (+ (random (- hi lo)) lo)
+              do (when (or lo= (/= x lo)) (return x))))
+       (t
+        (rcase
+         (1 (random (min hi (float limit hi))))
+         (1 (- (random (min (float limit lo) (- lo)))))))))))
+
+#|
+(defmethod make-random-element-of-type ((type cons))
+  (let ((type-op (first type)))
+    (ecase type-op
+      (or
+       (assert (cdr type))
+       (make-random-element-of-type (random-from-seq (cdr type))))
+      (and
+       (assert (cdr type))
+       (loop for x = (make-random-element-of-type (cadr type))
+             repeat 100
+             when (typep x (cons 'and (cddr type)))
+             return x
+             finally (error "Cannot generate random element of ~A" type)))
+      (not
+       (assert (cdr type))
+       (assert (not (cddr type)))
+       (make-random-element-of-type `(and t ,type)))
+      (integer
+       (let ((lo (let ((lo (cadr type)))
+                   (cond
+                    ((consp lo) (1+ (car lo)))
+                    ((eq lo nil) '*)
+                    (t lo))))
+             (hi (let ((hi (caddr type)))
+                   (cond
+                    ((consp hi) (1- (car hi)))
+                    ((eq hi nil) '*)
+                    (t hi)))))
+         (if (eq lo '*)
+             (if (eq hi '*)
+                 (let ((x (ash 1 (random *maximum-random-int-bits*))))
+                   (random-from-interval x (- x)))
+               (random-from-interval (1+ hi)
+                                     (- hi (random (ash 1 *maximum-random-int-bits*)))))
+
+           (if (eq hi '*)
+               (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
+                                     lo)
+             ;; May generalize the next case to increase odds
+             ;; of certain integers (near 0, near endpoints, near
+             ;; powers of 2...)
+             (random-from-interval (1+ hi) lo)))))
+
+      (rational
+       (or
+        (let ((r (make-random-element-of-type 'rational)))
+          (and (typep r type) r))
+        (let ((lo (cadr type))
+              (hi (caddr type))
+              lo= hi=)
+          (cond
+           ((consp lo) nil)
+           ((member lo '(* nil))
+            (setq lo nil)
+            (setq lo= nil))
+           (t
+            (assert (typep lo 'rational))
+            (setq lo= t)))
+          (cond
+           ((consp hi) nil)
+           ((member hi '(* nil))
+            (setq hi nil)
+            (setq hi= nil))
+           (t
+            (assert (typep hi 'rational))
+            (setq hi= t)))
+          (assert (or (null lo) (null hi) (<= lo hi)))
+          (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=)))
+          (cond
+           ((null lo)
+            (cond
+             ((null hi) (make-random-rational))
+             (hi= (- hi (make-random-nonnegative-rational)))
+             (t (- hi (make-random-positive-rational)))))
+           ((null hi)
+            (cond
+             (lo= (+ lo (make-random-nonnegative-rational)))
+             (t (+ lo (make-random-positive-rational)))))
+           (t
+            (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))
+
+      (ratio
+       (let ((r 0))
+         (loop
+          do (setq r (make-random-element-of-type `(rational ,@(cdr type))))
+          while (integerp r))
+         r))
+
+      (real
+       (rcase
+        (1 (let ((lo (and (numberp (cadr type))
+                          (rational (cadr type))))
+                 (hi (and (numberp (caddr type))
+                          (rational (caddr type)))))
+             (make-random-element-of-type `(rational ,(or lo '*)
+                                                     ,(or hi '*)))))
+        (1 (make-random-element-of-type `(float ,(or (cadr type) '*)
+                                                ,(or (caddr type) '*))))))
+
+      ((float)
+       (let* ((new-type-op (random-from-seq #(single-float double-float
+                                                           long-float short-float)))
+              (lo (cadr type))
+              (hi (caddr type))
+              (most-neg (most-negative-float new-type-op))
+              (most-pos (most-positive-float new-type-op)))
+         (cond
+          ((or (and (realp lo) (< lo most-neg))
+               (and (realp hi) (> hi most-pos)))
+           ;; try again
+           (make-random-element-of-type type))
+          (t
+           (when (and (realp lo) (not (typep lo new-type-op)))
+             (cond
+              ((< lo most-neg) (setq lo '*))
+              (t (setq lo (coerce lo new-type-op)))))
+           (when (and (realp hi) (not (typep hi new-type-op)))
+             (cond
+              ((> hi most-pos) (setq hi '*))
+              (t (setq hi (coerce hi new-type-op)))))
+           (make-random-element-of-type
+            `(,new-type-op ,(or lo '*) ,(or hi '*)))))))
+
+      ((single-float double-float long-float short-float)
+       (let ((lo (cadr type))
+             (hi (caddr type))
+             lo= hi=)
+         (cond
+          ((consp lo) nil)
+          ((member lo '(* nil))
+           (setq lo (most-negative-float type-op))
+           (setq lo= t))
+          (t
+           (assert (typep lo type-op))
+           (setq lo= t)))
+         (cond
+          ((consp hi) nil)
+          ((member hi '(* nil))
+           (setq hi (most-positive-float type-op))
+           (setq hi= t))
+          (t
+           (assert (typep hi type-op))
+           (setq hi= t)))
+         (assert (<= lo hi))
+         (assert (or (< lo hi) (and lo= hi=)))
+         (let ((limit 100000))
+           (cond
+            ((or (<= hi 0)
+                 (>= lo 0)
+                 (and (<= (- limit) hi limit) (<= (- limit) lo limit)))
+             (loop for x = (+ (random (- hi lo)) lo)
+                   do (when (or lo= (/= x lo)) (return x))))
+            (t
+             (rcase
+              (1 (random (min hi (float limit hi))))
+              (1 (- (random (min (float limit lo) (- lo)))))))))))
+
+      (mod
+       (let ((modulus (second type)))
+         (assert (and (integerp modulus)
+                      (plusp modulus)))
+         (make-random-element-of-type `(integer 0 (,modulus)))))
+      (unsigned-byte
+       (if (null (cdr type))
+           (make-random-element-of-type '(integer 0 *))
+         (let ((bits (second type)))
+           (if (eq bits'*)
+               (make-random-element-of-type '(integer 0 *))
+             (progn
+               (assert (and (integerp bits) (>= bits 1)))
+               (make-random-element-of-type
+                `(integer 0 ,(1- (ash 1 bits)))))))))
+      (signed-byte
+       (if (null (cdr type))
+           (make-random-element-of-type 'integer)
+         (let ((bits (second type)))
+           (if (eq bits'*)
+               (make-random-element-of-type 'integer)
+             (progn
+               (assert (and (integerp bits) (>= bits 1)))
+               (make-random-element-of-type
+                `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits))))))))))
+      (eql
+       (assert (= (length type) 2))
+       (cadr type))
+      (member
+       (assert (cdr type))
+       (random-from-seq (cdr type)))
+      ((vector)
+       (let ((etype-spec (if (cdr type) (cadr type) '*))
+             (size-spec (if (cddr type) (caddr type) '*)))
+         (make-random-vector etype-spec size-spec)))
+      ((simple-vector)
+       (let ((size-spec (if (cdr type) (cadr type) '*)))
+         (make-random-vector t size-spec :simple t)))
+      ((array simple-array)
+       (let ((etype-spec (if (cdr type) (cadr type) '*))
+             (size-spec (if (cddr type) (caddr type) '*)))
+         (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array))))
+      ((string simple-string)
+       (let ((size-spec (if (cdr type) (cadr type) '*)))
+         (make-random-string size-spec :simple (eql (car type) 'simple-string))))
+      ((base-string simple-base-string)
+       (let ((size-spec (if (cdr type) (cadr type) '*)))
+         (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string))))
+      ((bit-vector simple-bit-vector)
+       (let ((size-spec (if (cdr type) (cadr type) '*)))
+         (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector))))
+      ((cons)
+       (cons (make-random-element-of-type (if (cdr type) (cadr type) t))
+             (make-random-element-of-type (if (cddr type) (caddr type) t))))
+      ((complex)
+       (cond
+        ((null (cdr type))
+         (make-random-element-of-type 'complex))
+        (t
+         (assert (null (cddr type)))
+         (let ((etype (cadr type)))
+           (loop for v1 = (make-random-element-of-type etype)
+                 for v2 = (make-random-element-of-type etype)
+                 for c = (complex v1 v2)
+                 when (typep c type)
+                 return c)))))
+      )))
+|#
+
+(defmethod make-random-element-of-type ((type class))
+  (make-random-element-of-type (class-name type)))
+
+(defmethod make-random-element-of-type ((type (eql 'bit))) (random 2))
+(defmethod make-random-element-of-type ((type (eql 'boolean)))
+  (random-from-seq #(nil t)))
+(defmethod make-random-element-of-type ((type (eql 'symbol)))
+  (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
+(defmethod make-random-element-of-type ((type (eql 'keyword)))
+  (random-from-seq #(:a :b :c :d :e :f :g :h :i :j)))
+(defmethod make-random-element-of-type ((type (eql 'unsigned-byte)))
+  (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0))
+(defmethod make-random-element-of-type ((type (eql 'signed-byte)))
+  (random-from-interval
+   (1+ (ash 1 (random *maximum-random-int-bits*)))
+   (- (ash 1 (random *maximum-random-int-bits*)))))
+(defmethod make-random-element-of-type ((type (eql 'rational)))
+  (make-random-rational))
+(defmethod make-random-element-of-type ((type (eql 'ratio)))
+  (let ((r 0))
+    (loop do (setq r (make-random-element-of-type 'rational))
+          while (integerp r))
+    r))
+(defmethod make-random-element-of-type ((type (eql 'integer)))
+  (let ((x (ash 1 (random *maximum-random-int-bits*))))
+    (random-from-interval (1+ x) (- x))))
+(defmethod make-random-element-of-type ((type (eql 'float)))
+  (make-random-element-of-type
+   (random-from-seq #(short-float single-float double-float long-float))))
+(defmethod make-random-element-of-type ((type (eql 'real)))
+  (make-random-element-of-type (random-from-seq #(integer rational float))))
+(defmethod make-random-element-of-type ((type (eql 'number)))
+  (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex))))
+(defmethod make-random-element-of-type ((type (eql 'bit-vector)))
+  (make-random-vector 'bit '*))
+(defmethod make-random-element-of-type ((type (eql 'simple-bit-vector)))
+  (make-random-vector 'bit '* :simple t))
+(defmethod make-random-element-of-type ((type (eql 'vector)))
+  (make-random-vector '* '*))
+(defmethod make-random-element-of-type ((type (eql 'simple-vector)))
+  (make-random-vector 't '* :simple t))
+(defmethod make-random-element-of-type ((type (eql 'array)))
+  (make-random-array '* '*))
+(defmethod make-random-element-of-type ((type (eql 'simple-array)))
+  (make-random-array '* '* :simple t))
+(defmethod make-random-element-of-type ((type (eql 'string)))
+  (make-random-string '*))
+(defmethod make-random-element-of-type ((type (eql 'simple-string)))
+  (make-random-string '* :simple t))
+(defmethod make-random-element-of-type ((type (eql 'base-string)))
+  (make-random-vector 'base-char '*))
+(defmethod make-random-element-of-type ((type (eql 'simple-base-string)))
+  (make-random-vector 'base-char '* :simple t))
+(defmethod make-random-element-of-type ((type (eql 'character)))
+  (make-random-character))
+(defmethod make-random-element-of-type ((type (eql 'extended-char)))
+  (loop for x = (make-random-character)
+        when (typep x 'extended-char) return x))
+(defmethod make-random-element-of-type ((type (eql 'null))) nil)
+(defmethod make-random-element-of-type ((type (eql 'fixnum)))
+  (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum))
+(defmethod make-random-element-of-type ((type (eql 'complex)))
+  (make-random-element-of-type '(complex real)))
+(defmethod make-random-element-of-type ((type (eql 'cons)))
+  (make-random-element-of-type '(cons t t)))
+(defmethod make-random-element-of-type ((type (eql 'list)))
+  ;; Should modify this to allow non-proper lists?
+  (let ((len (min (random 10) (random 10))))
+    (loop repeat len collect (make-random-element-of-type t))))
+(defmethod make-random-element-of-type ((type (eql 'sequence)))
+  (make-random-element-of-type '(or list vector)))
+(defmethod make-random-element-of-type ((type (eql 'function)))
+  (rcase
+   (5 (symbol-function (random-from-seq *cl-function-symbols*)))
+   (5 (symbol-function (random-from-seq *cl-accessor-symbols*)))
+   (1 #'(lambda (x) (cons x x)))
+   (1 (eval '#'(lambda (x) (cons x x))))))
+
+(defmethod make-random-element-of-type ((type symbol))
+  (case type
+   ((single-float short-float double-float long-float)
+    (make-random-element-of-type (list type)))
+   ((base-char standard-char)
+    (random-from-seq +standard-chars+))
+   ;; Default
+   ((atom t *) (make-random-element-of-type
+                (random-from-seq #(real symbol boolean integer unsigned-byte
+                                        #-ecl complex character
+                                        (string 1) (bit-vector 1)))))
+   (t (call-next-method type))
+   ))
+
+(defun make-random-character ()
+  (loop
+   when (rcase
+         (3 (random-from-seq +standard-chars+))
+         (3 (code-char (random (min 256 char-code-limit))))
+         (1 (code-char (random (min (ash 1 16) char-code-limit))))
+         (1 (code-char (random (min (ash 1 24) char-code-limit))))
+         (1 (code-char (random char-code-limit))))
+   return it))
+
+(defun make-random-array-element-type ()
+  ;; Create random types for array elements
+  (let ((bits 40))
+    (rcase
+     (2 t)
+     (1 'symbol)
+     (1 `(unsigned-byte ,(1+ (random bits))))
+     (1 `(signed-byte ,(1+ (random bits))))
+     (1 'character)
+     (1 'base-char)
+     (1 'bit)
+     (1 (random-from-seq #(short-float single-float double-float long-float))))))
+
+(defun make-random-vector (etype-spec size-spec &key simple)
+  (let* ((etype (if (eql etype-spec '*)
+                    (make-random-array-element-type)
+                  etype-spec))
+         (size (if (eql size-spec '*)
+                   (random (ash 1 (+ 2 (random 8))))
+                 size-spec))
+         (displaced? (and (not simple) (coin 4)))
+         (displaced-size (+ size (random (max 6 size))))
+         (displacement (random (1+ (- displaced-size size))))
+         (adjustable (and (not simple) (coin 3)))
+         (fill-pointer (and (not simple)
+                            (rcase (3 nil) (1 t) (1 (random (1+ size)))))))
+    (assert (<= size 1000000))
+    (if displaced?
+        (let ((displaced-vector (make-array displaced-size :element-type etype
+                                            :initial-contents (loop repeat displaced-size
+                                                                    collect (make-random-element-of-type etype)))))
+          (make-array size :element-type etype :adjustable adjustable
+                      :fill-pointer fill-pointer
+                      :displaced-to displaced-vector
+                      :displaced-index-offset displacement))
+      (make-array size
+                  :element-type etype
+                  :initial-contents (loop repeat size
+                                          collect (make-random-element-of-type etype))
+                  :adjustable adjustable
+                  :fill-pointer fill-pointer
+                  ))))
+
+(defun make-random-array (etype-spec dim-specs &key simple)
+  (when (eql dim-specs '*)
+    (setq dim-specs (random 10)))
+  (when (numberp dim-specs)
+    (setq dim-specs (make-list dim-specs :initial-element '*)))
+  (let* ((etype (if (eql etype-spec '*) t etype-spec))
+         (rank (length dim-specs))
+         (dims (loop for dim in dim-specs
+                     collect (if (eql dim '*)
+                                 (1+ (random (ash 1 (floor 9 rank))))
+                               dim))))
+    (assert (<= (reduce '* dims :initial-value 1) 1000000))
+    (assert (<= (reduce 'max dims :initial-value 1) 1000000))
+    (make-array dims
+                :element-type etype
+                :initial-contents
+                (labels ((%init (dims)
+                                (if (null dims)
+                                    (make-random-element-of-type etype)
+                                  (loop repeat (car dims)
+                                        collect (%init (cdr dims))))))
+                  (%init dims))
+                :adjustable (and (not simple) (coin))
+                ;; Do displacements later
+                )))
+
+(defun most-negative-float (float-type-symbol)
+  (ecase float-type-symbol
+    (short-float most-negative-short-float)
+    (single-float most-negative-single-float)
+    (double-float most-negative-double-float)
+    (long-float most-negative-long-float)
+    (float (min most-negative-short-float most-negative-single-float
+                most-negative-double-float most-negative-long-float))))
+
+(defun most-positive-float (float-type-symbol)
+  (ecase float-type-symbol
+    (short-float most-positive-short-float)
+    (single-float most-positive-single-float)
+    (double-float most-positive-double-float)
+    (long-float most-positive-long-float)
+    (float (max most-positive-short-float most-positive-single-float
+                most-positive-double-float most-positive-long-float))))
+
+(defun make-optimized-lambda-form (form vars var-types opt-decls)
+  `(lambda ,vars
+     ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var)))
+               var-types vars)
+     (declare (ignorable ,@vars))
+     #+cmu (declare (optimize (extensions:inhibit-warnings 3)))
+     (declare (optimize ,@opt-decls))
+     ,form))
+
+(defun make-unoptimized-lambda-form (form vars var-types opt-decls)
+  (declare (ignore var-types))
+  `(lambda ,vars
+     (declare (notinline ,@(fn-symbols-in-form form)))
+     #+cmu (declare (optimize (extensions:inhibit-warnings 3)))
+     (declare (optimize ,@opt-decls))
+     ,form))
+
+(defvar *compile-using-defun*
+  #-(or allegro lispworks) nil
+  #+(or allegro lispworks) t)
+
+(defvar *compile-using-defgeneric* nil
+  "If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form
+   for the function and compile that.")
+
+(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1)
+(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2)
+
+(defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2)
+  ;; Try to compile FORM with associated VARS, and if it compiles
+  ;; check for equality of the two compiled forms.
+  ;; Return a non-nil list of details if a problem is found,
+  ;; NIL otherwise.
+  (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1))
+        (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2)))
+    (setq *int-form-vals* nil
+          *optimized-fn-src* optimized-fn-src
+          *unoptimized-fn-src* unoptimized-fn-src)
+    (flet ((%compile
+            (lambda-form opt-defun-name)
+            (cl:handler-bind
+             (#+sbcl (sb-ext::compiler-note #'muffle-warning)
+                     (warning #'muffle-warning)
+                     ((or error serious-condition)
+                      #'(lambda (c)
+                                (format t "Compilation failure~%~A~%"
+                                        (format nil "~S" form))
+                                (finish-output *standard-output*)
+                                (return-from test-int-form
+                                  (list (list :vars vars
+                                              :form form
+                                              :var-types var-types
+                                              :vals (first vals-list)
+                                              :lambda-form lambda-form
+                                              :decls1 opt-decls-1
+                                              :decls2 opt-decls-2
+                                              :compiler-condition
+                                              (with-output-to-string
+                                                (s)
+                                                (prin1 c s))))))))
+             (let ((start-time (get-universal-time))
+                   (clf (cdr lambda-form)))
+               (prog1
+                   (cond
+                    (*compile-using-defun*
+                     (fmakunbound opt-defun-name)
+                     (eval `(defun ,opt-defun-name ,@clf))
+                     (compile opt-defun-name)
+                     (symbol-function opt-defun-name))
+                    (*compile-using-defgeneric*
+                     (fmakunbound opt-defun-name)
+                     (eval `(defgeneric ,opt-defun-name ,(car clf)))
+                     (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf))
+                              ,@(cdr clf)))
+                     (compile opt-defun-name)
+                     (symbol-function opt-defun-name))
+                    (t (compile nil lambda-form)))
+                 (let* ((stop-time (get-universal-time))
+                        (total-time (- stop-time start-time)))
+                   (when (> total-time *max-compile-time*)
+                     (setf *max-compile-time* total-time)
+                     (setf *max-compile-term* lambda-form)))
+                 ;; #+:ecl (si:gc t)
+                 )))))
+      (let ((optimized-compiled-fn (%compile optimized-fn-src
+                                             *name-to-use-in-optimized-defun*))
+            (unoptimized-compiled-fn
+             (if *compile-unoptimized-form*
+                 (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*)
+               (eval `(function ,unoptimized-fn-src)))))
+        (declare (type function optimized-compiled-fn unoptimized-compiled-fn))
+        (dolist (vals vals-list)
+          (setq *int-form-vals* vals)
+          (flet ((%eval-error
+                  (kind)
+                  (let ((*print-circle* t))
+                    (format t "~A~%" (format nil "~S" form)))
+                  (finish-output *standard-output*)
+                  (return
+                   (list (list :vars vars
+                               :vals vals
+                               :form form
+                               :var-types var-types
+                               :decls1 opt-decls-1
+                               :decls2 opt-decls-2
+                               :optimized-lambda-form optimized-fn-src
+                               :unoptimized-lambda-form unoptimized-fn-src
+                               :kind kind)))))
+
+            (let ((unopt-result
+                   (cl-handler-case
+                    (cl-handler-bind
+                     (#+sbcl (sb-ext::compiler-note #'muffle-warning)
+                             (warning #'muffle-warning))
+                     (identity ;; multiple-value-list
+                      (apply unoptimized-compiled-fn vals)))
+                    ((or error serious-condition)
+                     (c)
+                     (%eval-error (list :unoptimized-form-error
+                                        (with-output-to-string
+                                          (s) (prin1 c s)))))))
+                  (opt-result
+                   (cl-handler-case
+                    (cl-handler-bind
+                     (#+sbcl (sb-ext::compiler-note #'muffle-warning)
+                             (warning #'muffle-warning))
+                     (identity ;; multiple-value-list
+                      (apply optimized-compiled-fn vals)))
+                    ((or error serious-condition)
+                     (c)
+                     (%eval-error (list :optimized-form-error
+                                        (with-output-to-string
+                                          (s) (prin1 c s))))))))
+              (if (equal opt-result unopt-result)
+                  nil
+                (progn
+                  (format t "Different results: ~A, ~A~%"
+                          opt-result unopt-result)
+                  (setq *opt-result* opt-result
+                        *unopt-result* unopt-result)
+                  (%eval-error (list :different-results
+                                     opt-result
+                                     unopt-result)))))))))))
+
+;;; Interface to the form pruner
+
+(declaim (special *prune-table*))
+
+(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2)
+  "Conduct tests on selected simplified versions of INPUT-FORM.  Return the
+   minimal form that still causes some kind of failure."
+  (loop do
+        (let ((form input-form))
+          (flet ((%try-fn (new-form)
+                          (when (test-int-form new-form vars var-types vals-list
+                                               opt-decls-1 opt-decls-2)
+                            (setf form new-form)
+                            (throw 'success nil))))
+            (let ((*prune-table* (make-hash-table :test #'eq)))
+              (loop
+               (catch 'success
+                 (prune form #'%try-fn)
+                 (return form)))))
+          (when (equal form input-form) (return form))
+          (setq input-form form))))
+
+(defun prune-results (result-list)
+  "Given a list of test results, prune their forms down to a minimal set."
+  (loop for result in result-list
+        collect
+        (let* ((form (getf result :form))
+               (vars (getf result :vars))
+               (var-types (getf result :var-types))
+               (vals-list (list (getf result :vals)))
+               (opt-decl-1 (getf result :decls1))
+               (opt-decl-2 (getf result :decls2))
+               (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2))
+               (optimized-lambda-form (make-optimized-lambda-form
+                                       pruned-form vars var-types opt-decl-1))
+               (unoptimized-lambda-form (make-unoptimized-lambda-form
+                                         pruned-form vars var-types opt-decl-2)))
+            `(:vars ,vars
+              :var-types ,var-types
+              :vals ,(first vals-list)
+              :form ,pruned-form
+              :decls1 ,opt-decl-1
+              :decls2 ,opt-decl-2
+              :optimized-lambda-form ,optimized-lambda-form
+              :unoptimized-lambda-form ,unoptimized-lambda-form))))
+
+;;;
+;;; The call (PRUNE form try-fn) attempts to simplify the lisp form
+;;; so that it still satisfies TRY-FN.  The function TRY-FN should
+;;; return if the substitution is a failure.  Otherwise, it should
+;;; transfer control elsewhere via GO, THROW, etc.
+;;;
+;;; The return value of PRUNE should be ignored.
+;;;
+(defun prune (form try-fn)
+  (declare (type function try-fn))
+  (when (gethash form *prune-table*)
+    (return-from prune nil))
+  (flet ((try (x) (funcall try-fn x)))
+    (cond
+     ((keywordp form) nil)
+     ((integerp form)
+      (unless (zerop form) (try 0)))
+     ((consp form)
+      (let* ((op (car form))
+             (args (cdr form))
+             (nargs (length args)))
+        (case op
+
+         ((quote) nil)
+
+         ((go)
+          (try 0))
+
+         ((signum integer-length logcount
+                  logandc1 logandc2 lognand lognor logorc1 logorc2
+                  realpart imagpart)
+          (try 0)
+          (mapc try-fn args)
+          (prune-fn form try-fn))
+
+         ((make-array)
+          (when (and (eq (car args) nil)
+                     (eq (cadr args) ':initial-element)
+                     ; (null (cdddr args))
+                     )
+            (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args)))))
+            (when (cdddr args)
+              (try `(make-array nil :initial-element ,(caddr args))))
+            ))
+
+         ((cons)
+          (prune-fn form try-fn))
+
+         ((dotimes)
+          (try 0)
+          (let* ((binding-form (first args))
+                 (body (rest args))
+                 (var (first binding-form))
+                 (count-form (second binding-form))
+                 (result (third binding-form)))
+            (try result)
+            (unless (eql count-form 0)
+              (try `(dotimes (,var 0 ,result) ,@body)))
+            (prune result #'(lambda (form)
+                              (try `(dotimes (,var ,count-form ,form) ,@body))))
+            (when (= (length body) 1)
+              (prune (first body)
+                     #'(lambda (form)
+                         (when (consp form)
+                           (try `(dotimes (,var ,count-form ,result) ,form))))))))
+
+         ((abs 1+ 1-)
+          (try 0)
+          (mapc try-fn args)
+          (prune-fn form try-fn))
+
+         ((identity  ignore-errors cl:handler-case restart-case locally)
+          (unless (and (consp args)
+                       (consp (car args))
+                       (eql (caar args) 'tagbody))
+            (mapc try-fn args))
+          (prune-fn form try-fn))
+
+         ((boole)
+          (try (second args))
+          (try (third args))
+          (prune (second args)
+                 #'(lambda (form) (try `(boole ,(first args) ,form ,(third args)))))
+          (prune (third args)
+                 #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form)))))
+
+         ((unwind-protect prog1 multiple-value-prog1)
+          (try (first args))
+          (let ((val (first args))
+                (rest (rest args)))
+            (when rest
+              (try `(unwind-protect ,val))
+              (when (cdr rest)
+                (loop for i from 0 below (length rest)
+                      do
+                      (try `(unwind-protect ,val
+                              ,@(subseq rest 0 i)
+                              ,@(subseq rest (1+ i))))))))
+          (prune-fn form try-fn))
+
+         ((prog2)
+          (assert (>= (length args) 2))
+          (let ((val1 (first args))
+                (arg2 (second args))
+                (rest (cddr args)))
+            (try arg2)
+            (prune-fn form try-fn)
+            (when rest
+              (try `(prog2 ,val1 ,arg2))
+              (when (cdr rest)
+                (loop for i from 0 below (length rest)
+                      do
+                      (try `(prog2 ,val1 ,arg2
+                              ,@(subseq rest 0 i)
+                              ,@(subseq rest (1+ i)))))))))
+
+         ((typep)
+          (try (car args))
+          (prune (car args)
+                 #'(lambda (form) `(,op ,form ,@(cdr args)))))
+
+         ((load-time-value)
+          (let ((arg (first args)))
+            (try arg)
+            (cond
+             ((cdr args)
+              (try `(load-time-value ,arg))
+              (prune arg
+                     #'(lambda (form)
+                         (try `(load-time-value ,form ,(second args))))))
+             (t
+              (prune arg
+                     #'(lambda (form)
+                         (try `(load-time-value ,form))))))))
+
+         ((eval)
+          (try 0)
+          (let ((arg (first args)))
+            (cond
+             ((consp arg)
+              (cond
+               ((eql (car arg) 'quote)
+                (prune (cadr arg) #'(lambda (form) (try `(eval ',form)))))
+               (t
+                (try arg)
+                (prune arg #'(lambda (form) `(eval ,form))))))
+             (t (try arg)))))
+
+         ((the macrolet cl:handler-bind restart-bind)
+          (assert (= (length args) 2))
+          (try (second args))
+          (prune (second args) try-fn))
+
+         ((not eq eql equal)
+          (when (every #'constantp args)
+            (try (eval form)))
+          (try t)
+          (try nil)
+          (mapc try-fn args)
+          (prune-fn form try-fn)
+          )
+
+         ((and or = < > <= >= /=)
+          (when (every #'constantp args)
+            (try (eval form)))
+          (try t)
+          (try nil)
+          (mapc try-fn args)
+          (prune-nary-fn form try-fn)
+          (prune-fn form try-fn))
+
+         ((- + * min max logand logior logxor logeqv gcd lcm values)
+          (when (every #'constantp args)
+            (try (eval form)))
+          (try 0)
+          (mapc try-fn args)
+          (prune-nary-fn form try-fn)
+          (prune-fn form try-fn))
+
+         ((/)
+          (when (every #'constantp args)
+            (try (eval form)))
+          (try 0)
+          (try (car args))
+          (when (cddr args)
+            (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args)))))))
+
+         ((expt rationalize rational numberator denominator)
+          (try 0)
+          (mapc try-fn args)
+          (prune-fn form try-fn))
+
+         ((coerce)
+          (try 0)
+          (try (car args))
+          (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args))))))
+
+
+         ((multiple-value-call)
+          ;; Simplify usual case
+          (when (= nargs 2)
+            (destructuring-bind (arg1 arg2) args
+              (when (and (consp arg1) (consp arg2)
+                         (eql (first arg1) 'function)
+                         (eql (first arg2) 'values))
+                (mapc try-fn (rest arg2))
+                (let ((fn (second arg1)))
+                  (when (symbolp fn)
+                    (try `(,fn ,@(rest arg2)))))
+                ;; Prune the VALUES form
+                (prune-list (rest arg2)
+                            #'prune
+                            #'(lambda (args)
+                                (try `(multiple-value-call ,arg1 (values ,@args)))))
+                )))
+          (mapc try-fn (rest args)))
+
+         ((bit sbit elt aref svref)
+          (try 0)
+          (when (= (length args) 2)
+            (let ((arg1 (car args))
+                  (arg2 (cadr args)))
+              (when (and (consp arg2)
+                         (eql (car arg2) 'min)
+                         (integerp (cadr arg2)))
+                (let ((arg2.2 (caddr arg2)))
+                  (try arg2.2)
+                  (when (and (consp arg2.2)
+                             (eql (car arg2.2) 'max)
+                             (integerp (cadr arg2.2)))
+                    (prune (caddr arg2.2)
+                           #'(lambda (form)
+                               (try `(,op ,arg1 (min ,(cadr arg2)
+                                                     (max ,(cadr arg2.2) ,form))))))))))))
+
+         ((car cdr)
+          (try 0)
+          (try 1))
+
+         ((if)
+          (let (;; (pred (first args))
+                (then (second args))
+                (else (third args)))
+            (try then)
+            (try else)
+            (when (every #'constantp args)
+              (try (eval form)))
+            (prune-fn form try-fn)))
+
+         ((incf decf)
+          (try 0)
+          (assert (member (length form) '(2 3)))
+          (try (first args))
+          (when (> (length args) 1)
+            (try (second args))
+            (try `(,op ,(first args)))
+            (unless (integerp (second args))
+              (prune (second args)
+                     #'(lambda (form)
+                         (try `(,op ,(first args) ,form)))))))
+
+         ((setq setf shiftf)
+          (try 0)
+          ;; Assumes only one assignment
+          (assert (= (length form) 3))
+          (try (first args))
+          (try (second args))
+          (unless (integerp (second args))
+            (prune (second args)
+                   #'(lambda (form)
+                       (try `(,op ,(first args) ,form))))))
+
+         ((rotatef)
+          (try 0)
+          (mapc try-fn (cdr form)))
+
+         ((multiple-value-setq)
+          (try 0)
+          ;; Assumes only one assignment, and one variable
+          (assert (= (length form) 3))
+          (assert (= (length (first args)) 1))
+          (try `(setq ,(caar args) ,(cadr args)))
+          (unless (integerp (second args))
+            (prune (second args)
+                   #'(lambda (form)
+                       (try `(,op ,(first args) ,form))))))
+
+         ((byte)
+          (prune-fn form try-fn))
+
+         ((deposit-field dpb)
+          (try 0)
+          (destructuring-bind (a1 a2 a3)
+              args
+            (try a1)
+            (try a3)
+            (when (and (integerp a1)
+                       (integerp a3)
+                       (and (consp a2)
+                            (eq (first a2) 'byte)
+                            (integerp (second a2))
+                            (integerp (third a2))))
+              (try (eval form))))
+          (prune-fn form try-fn))
+
+         ((ldb mask-field)
+          (try 0)
+          (try (second args))
+          (when (and (consp (first args))
+                     (eq 'byte (first (first args)))
+                     (every #'numberp (cdr (first args)))
+                     (numberp (second args)))
+            (try (eval form)))
+          (prune-fn form try-fn))
+
+         ((ldb-test)
+          (try t)
+          (try nil)
+          (prune-fn form try-fn))
+
+         ((let let*)
+          (prune-let form try-fn))
+
+         ((multiple-value-bind)
+          (assert (= (length args) 3))
+          (let ((arg1 (first args))
+                (arg2 (second args))
+                (body (caddr args)))
+            (when (= (length arg1) 1)
+              (try `(let ((,(first arg1) ,arg2)) ,body)))
+            (prune arg2 #'(lambda (form)
+                            (try `(multiple-value-bind ,arg1 ,form ,body))))
+            (prune body #'(lambda (form)
+                            (try `(multiple-value-bind ,arg1 ,arg2 ,form))))))
+
+         ((block)
+          (let ((name (second form))
+                (body (cddr form)))
+            (when (and body (null (cdr body)))
+              (let ((form1 (first body)))
+
+                ;; Try removing the block entirely if it is not in use
+                (when (not (find-in-tree name body))
+                  (try form1))
+
+                ;; Try removing the block if its only use is an immediately
+                ;; enclosed return-from: (block <n> (return-from <n> <e>))
+                (when (and (consp form1)
+                           (eq (first form1) 'return-from)
+                           (eq (second form1) name)
+                           (not (find-in-tree name (third form1))))
+                  (try (third form1)))
+
+                ;; Otherwise, try to simplify the subexpression
+                (prune form1
+                       #'(lambda (x)
+                           (try `(block ,name ,x))))))))
+
+         ((catch)
+          (let* ((tag (second form))
+                 (name (if (consp tag) (cadr tag) tag))
+                 (body (cddr form)))
+            (when (and body (null (cdr body)))
+              (let ((form1 (first body)))
+
+                ;; Try removing the catch entirely if it is not in use
+                ;; We make assumptions here about what throws can
+                ;; be present.
+                (when (or (not (find-in-tree 'throw body))
+                          (not (find-in-tree name body)))
+                  (try form1))
+
+                ;; Try removing the block if its only use is an immediately
+                ;; enclosed return-from: (block <n> (return-from <n> <e>))
+                (when (and (consp form1)
+                           (eq (first form1) 'throw)
+                           (equal (second form1) name)
+                           (not (find-in-tree name (third form1))))
+                  (try (third form1)))
+
+                ;; Otherwise, try to simplify the subexpression
+                (prune form1
+                       #'(lambda (x)
+                           (try `(catch ,tag ,x))))))))
+
+         ((throw)
+          (try (second args))
+          (prune (second args)
+                 #'(lambda (x) (try `(throw ,(first args) ,x)))))
+
+         ((flet labels)
+          (try 0)
+          (prune-flet form try-fn))
+
+         ((case)
+          (prune-case form try-fn))
+
+         ((isqrt)
+          (let ((arg (second form)))
+            (assert (null (cddr form)))
+            (assert (consp arg))
+            (assert (eq (first arg) 'abs))
+            (let ((arg2 (second arg)))
+              (try arg2)
+              ;; Try to fold
+              (when (integerp arg2)
+                (try (isqrt (abs arg2))))
+              ;; Otherwise, simplify arg2
+              (prune arg2 #'(lambda (form)
+                              (try `(isqrt (abs ,form))))))))
+
+         ((ash)
+          (try 0)
+          (let ((form1 (second form))
+                (form2 (third form)))
+            (try form1)
+            (try form2)
+            (prune form1
+                   #'(lambda (form)
+                       (try `(ash ,form ,form2))))
+            (when (and (consp form2)
+                       (= (length form2) 3))
+              (when (and (integerp form1)
+                         (eq (first form2) 'min)
+                         (every #'integerp (cdr form2)))
+                (try (eval form)))
+              (let ((form3 (third form2)))
+                (prune form3
+                       #'(lambda (form)
+                           (try
+                            `(ash ,form1 (,(first form2) ,(second form2)
+                                          ,form)))))))))
+
+         ((floor ceiling truncate round mod rem)
+          (try 0)
+          (let ((form1 (second form))
+                (form2 (third form)))
+            (try form1)
+            (when (cddr form) (try form2))
+            (prune form1
+                   (if (cddr form)
+                       #'(lambda (form)
+                           (try `(,op ,form ,form2)))
+                     #'(lambda (form) (try `(,op ,form)))))
+            (when (and (consp form2)
+                       (= (length form2) 3))
+              (when (and (integerp form1)
+                         (member (first form2) '(max min))
+                         (every #'integerp (cdr form2)))
+                (try (eval form)))
+              (let ((form3 (third form2)))
+                (prune form3
+                       #'(lambda (form)
+                           (try
+                            `(,op ,form1 (,(first form2) ,(second form2)
+                                          ,form)))))))))
+
+         ((constantly)
+          (unless (eql (car args) 0)
+            (prune (car args)
+                   #'(lambda (arg) (try `(constantly ,arg))))))
+
+         ((funcall)
+          (try 0)
+          (let ((fn (second form))
+                (fn-args (cddr form)))
+            (mapc try-fn fn-args)
+            (unless (equal fn '(constantly 0))
+              (try `(funcall (constantly 0) ,@fn-args)))
+            (when (and (consp fn)
+                       (eql (car fn) 'function)
+                       (symbolp (cadr fn)))
+              (try `(,(cadr fn) ,@fn-args)))
+            (prune-list fn-args
+                        #'prune
+                        #'(lambda (args)
+                            (try `(funcall ,fn ,@args))))))
+
+         ((reduce)
+          (try 0)
+          (let ((arg1 (car args))
+                (arg2 (cadr args))
+                (rest (cddr args)))
+            (when (and ;; (null (cddr args))
+                       (consp arg1)
+                       (eql (car arg1) 'function))
+              (let ((arg1.2 (cadr arg1)))
+                (when (and (consp arg1.2)
+                           (eql (car arg1.2) 'lambda))
+                  (let ((largs (cadr arg1.2))
+                        (body (cddr arg1.2)))
+                    (when (null (cdr body))
+                      (prune (car body)
+                             #'(lambda (bform)
+                                 (try `(reduce (function (lambda ,largs ,bform))
+                                               ,arg2 ,@rest)))))))))
+            (when (consp arg2)
+              (case (car arg2)
+                ((list vector)
+                 (let ((arg2.rest (cdr arg2)))
+                   (mapc try-fn arg2.rest)
+                   (prune-list arg2.rest
+                               #'prune
+                               #'(lambda (args)
+                                   (try `(reduce ,arg1
+                                                 (,(car arg2) ,@args)
+                                                 ,@rest))))))))))
+
+         ((apply)
+          (try 0)
+          (let ((fn (second form))
+                (fn-args (butlast (cddr form)))
+                (list-arg (car (last form))))
+            (mapc try-fn fn-args)
+            (unless (equal fn '(constantly 0))
+              (try `(apply (constantly 0) ,@(cddr form))))
+            (when (and (consp list-arg)
+                       (eq (car list-arg) 'list))
+              (mapc try-fn (cdr list-arg)))
+            (prune-list fn-args
+                        #'prune
+                        #'(lambda (args)
+                            (try `(apply ,fn ,@args ,list-arg))))
+            (when (and (consp list-arg)
+                       (eq (car list-arg) 'list))
+              (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil))
+              (prune-list (cdr list-arg)
+                        #'prune
+                        #'(lambda (args)
+                            (try `(apply ,fn ,@fn-args
+                                         (list ,@args))))))))
+
+         ((progv)
+          (try 0)
+          (prune-progv form try-fn))
+
+         ((tagbody)
+          (try 0)
+          (prune-tagbody form try-fn))
+
+         ((progn)
+          (when (null args) (try nil))
+          (try (car (last args)))
+          (loop for i from 0 below (1- (length args))
+                for a in args
+                do (try `(progn ,@(subseq args 0 i)
+                                ,@(subseq args (1+ i))))
+                do (when (and (consp a)
+                              (or
+                               (eq (car a) 'progn)
+                               (and (eq (car a) 'tagbody)
+                                    (every #'consp (cdr a)))))
+                     (try `(progn ,@(subseq args 0 i)
+                                  ,@(copy-list (cdr a))
+                                  ,@(subseq args (1+ i))))))
+          (prune-fn form try-fn))
+
+         ((loop)
+          (try 0)
+          (when (and (eql (length args) 6)
+                     (eql (elt args 0) 'for)
+                     (eql (elt args 2) 'below))
+            (let ((var (elt args 1))
+                  (count (elt args 3))
+                  (form (elt args 5)))
+              (unless (eql count 0) (try count))
+              (case (elt args 4)
+                (sum
+                 (try `(let ((,(elt args 1) 0)) ,(elt args 5)))
+                 (prune form #'(lambda (form)
+                                 (try `(loop for ,var below ,count sum ,form)))))
+                (count
+                 (unless (or (eql form t) (eql form nil))
+                   (try `(loop for ,var below ,count count t))
+                   (try `(loop for ,var below ,count count nil))
+                   (prune form
+                          #'(lambda (form)
+                              (try `(loop for ,var below ,count count ,form))))))
+                ))))
+
+         (otherwise
+          (try 0)
+          (prune-fn form try-fn))
+
+         )))))
+  (setf (gethash form *prune-table*) t)
+  nil)
+
+(defun find-in-tree (value tree)
+  "Return true if VALUE is eql to a node in TREE."
+  (or (eql value tree)
+      (and (consp tree)
+           (or (find-in-tree value (car tree))
+               (find-in-tree value (cdr tree))))))
+
+(defun prune-list (list element-prune-fn list-try-fn)
+  (declare (type function element-prune-fn list-try-fn))
+  "Utility function for pruning in a list."
+    (loop for i from 0
+          for e in list
+          do (funcall element-prune-fn
+                      e
+                      #'(lambda (form)
+                          (funcall list-try-fn
+                                   (append (subseq list 0 i)
+                                           (list form)
+                                           (subseq list (1+ i))))))))
+
+(defun prune-case (form try-fn)
+  (declare (type function try-fn))
+  (flet ((try (e) (funcall try-fn e)))
+    (let* ((op (first form))
+           (expr (second form))
+           (cases (cddr form)))
+
+      ;; Try just the top expression
+      (try expr)
+
+      ;; Try simplifying the expr
+      (prune expr
+             #'(lambda (form)
+                 (try `(,op ,form ,@cases))))
+
+      ;; Try individual cases
+      (loop for case in cases
+            do (try (first (last (rest case)))))
+
+      ;; Try deleting individual cases
+      (loop for i from 0 below (1- (length cases))
+            do (try `(,op ,expr
+                          ,@(subseq cases 0 i)
+                          ,@(subseq cases (1+ i)))))
+
+      ;; Try simplifying the cases
+      ;; Assume each case has a single form
+      (prune-list cases
+                  #'(lambda (case try-fn)
+                      (declare (type function try-fn))
+                      (when (and (listp (car case))
+                                 (> (length (car case)) 1))
+                        ;; try removing constants
+                        (loop for i below (length (car case))
+                              do (funcall try-fn
+                                          `((,@(subseq (car case) 0 i)
+                                             ,@(subseq (car case) (1+ i)))
+                                            ,@(cdr case)))))
+                      (when (eql (length case) 2)
+                        (prune (cadr case)
+                               #'(lambda (form)
+                                   (funcall try-fn
+                                            (list (car case) form))))))
+                  #'(lambda (cases)
+                      (try `(,op ,expr ,@cases)))))))
+
+(defun prune-tagbody (form try-fn)
+  (declare (type function try-fn))
+  (let (;; (op (car form))
+        (body (cdr form)))
+    (loop for i from 0
+          for e in body
+          do
+          (cond
+           ((atom e)
+            ;; A tag
+            (unless (find-in-tree e (subseq body 0 i))
+              (funcall try-fn `(tagbody ,@(subseq body 0 i)
+                                        ,@(subseq body (1+ i))))))
+           (t
+            (funcall try-fn
+                     `(tagbody ,@(subseq body 0 i)
+                               ,@(subseq body (1+ i))))
+            (prune e
+                   #'(lambda (form)
+                       ;; Don't put an atom here.
+                       (when (consp form)
+                         (funcall
+                          try-fn
+                          `(tagbody ,@(subseq body 0 i)
+                                    ,form
+                                    ,@(subseq body (1+ i))))))))))))
+
+(defun prune-progv (form try-fn)
+  (declare (type function try-fn))
+  (let (;; (op (car form))
+        (vars-form (cadr form))
+        (vals-form (caddr form))
+        (body-list (cdddr form)))
+    (when (and (null vars-form) (null vals-form))
+      (funcall try-fn `(let () ,@body-list)))
+    (when (and (consp vals-form) (eql (car vals-form) 'list))
+      (when (and (consp vars-form) (eql (car vars-form) 'quote))
+        (let ((vars (cadr vars-form))
+              (vals (cdr vals-form)))
+          (when (eql (length vars) (length vals))
+            (let ((let-form `(let () ,@body-list)))
+              (mapc #'(lambda (var val)
+                        (setq let-form `(let ((,var ,val)) ,let-form)))
+                    vars vals)
+              (funcall try-fn let-form)))
+          ;; Try simplifying the vals forms
+          (prune-list vals
+                      #'prune
+                      #'(lambda (vals)
+                          (funcall try-fn
+                                   `(progv ,vars-form (list ,@vals) ,@body-list)))))))
+    ;; Try simplifying the body
+    (when (eql (length body-list) 1)
+      (prune (car body-list)
+             #'(lambda (form)
+                 (funcall try-fn
+                          `(progv ,vars-form ,vals-form ,form)))))))
+
+(defun prune-nary-fn (form try-fn)
+  ;; Attempt to reduce the number of arguments to the fn
+  ;; Do not reduce below 1
+  (declare (type function try-fn))
+  (let* ((op (car form))
+         (args (cdr form))
+         (nargs (length args)))
+    (when (> nargs 1)
+      (loop for i from 1 to nargs
+            do (funcall try-fn `(,op ,@(subseq args 0 (1- i))
+                                     ,@(subseq args i)))))))
+
+(defun prune-fn (form try-fn)
+  "Attempt to simplify a function call form.  It is considered
+   acceptable to replace the call by one of its argument forms."
+  (declare (type function try-fn))
+  (prune-list (cdr form)
+              #'prune
+              #'(lambda (args)
+                  (funcall try-fn (cons (car form) args)))))
+
+(defun prune-let (form try-fn)
+  "Attempt to simplify a LET form."
+  (declare (type function try-fn))
+  (let* ((op (car form))
+         (binding-list (cadr form))
+         (body (cddr form))
+         (body-len (length body))
+         (len (length binding-list))
+         )
+
+    (when (> body-len 1)
+      (funcall try-fn `(,op ,binding-list ,@(cdr body))))
+
+    ;; Try to simplify (let ((<name> <form>)) ...) to <form>
+    #|
+    (when (and (>= len 1)
+               ;; (eql body-len 1)
+               ;; (eql (caar binding-list) (car body))
+               )
+      (let ((val-form (cadar binding-list)))
+        (unless (and (consp val-form)
+                     (eql (car val-form) 'make-array))
+          (funcall try-fn val-form))))
+    |#
+
+    (when (>= len 1)
+      (let ((val-form (cadar binding-list)))
+        (when (consp val-form)
+          (case (car val-form)
+            ((make-array)
+             (let ((init (getf (cddr val-form) :initial-element)))
+               (when init
+                 (funcall try-fn init))))
+            ((cons)
+             (funcall try-fn (cadr val-form))
+             (funcall try-fn (caddr val-form)))))))
+
+    ;; Try to simplify the forms in the RHS of the bindings
+    (prune-list binding-list
+                #'(lambda (binding try-fn)
+                    (declare (type function try-fn))
+                    (prune (cadr binding)
+                           #'(lambda (form)
+                               (funcall try-fn
+                                        (list (car binding)
+                                              form)))))
+                #'(lambda (bindings)
+                    (funcall try-fn `(,op ,bindings ,@body))))
+
+    ;; Prune off unused variable
+    (when (and binding-list
+               (not (rest binding-list))
+               (let ((name (caar binding-list)))
+                 (and (symbolp name)
+                      (not (find-if-subtree #'(lambda (x) (eq x name)) body)))))
+      (funcall try-fn `(progn ,@body)))
+
+    ;; Try to simplify the body of the LET form
+    (when body
+      (unless binding-list
+        (funcall try-fn (car (last body))))
+      (when (and (first binding-list)
+                 (not (rest binding-list))
+                 (not (rest body)))
+        (let ((binding (first binding-list)))
+          (unless (or (consp (second binding))
+                      (has-binding-to-var (first binding) body)
+                      (has-assignment-to-var (first binding) body)
+                      )
+            (funcall try-fn `(let ()
+                               ,@(subst (second binding)
+                                        (first binding)
+                                        (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare)))
+                                                   body)
+                                        ))))))
+      (prune (car (last body))
+             #'(lambda (form2)
+                 (funcall try-fn
+                          `(,@(butlast form) ,form2)))))))
+
+(defun has-assignment-to-var (var form)
+  (find-if-subtree
+   #'(lambda (form)
+       (and (consp form)
+            (or
+             (and (member (car form) '(setq setf shiftf incf decf) :test #'eq)
+                  (eq (cadr form) var))
+             (and (eql (car form) 'multiple-value-setq)
+                  (member var (cadr form))))))
+   form))
+
+(defun has-binding-to-var (var form)
+  (find-if-subtree
+   #'(lambda (form)
+       (and (consp form)
+            (case (car form)
+              ((let let*)
+               (loop for binding in (cadr form)
+                     thereis (eq (car binding) var)))
+              ((progv)
+               (and (consp (cadr form))
+                    (eq (caadr form) 'quote)
+                    (consp (second (cadr form)))
+                    (member var (second (cadr form)))))
+              (t nil))))
+   form))
+
+(defun find-if-subtree (pred tree)
+  (declare (type function pred))
+  (cond
+   ((funcall pred tree) tree)
+   ((consp tree)
+    (or (find-if-subtree pred (car tree))
+        (find-if-subtree pred (cdr tree))))
+   (t nil)))
+
+(defun prune-flet (form try-fn)
+  "Attempt to simplify a FLET form."
+  (declare (type function try-fn))
+
+  (let* ((op (car form))
+         (binding-list (cadr form))
+         (body (cddr form)))
+
+    ;; Remove a declaration, if any
+    (when (and (consp body)
+               (consp (car body))
+               (eq (caar body) 'declare))
+      (funcall try-fn `(,op ,binding-list ,@(cdr body))))
+
+    ;; Try to prune optional arguments
+    (prune-list binding-list
+                #'(lambda (binding try-fn)
+                    (declare (type function try-fn))
+                    (let* ((name (car binding))
+                           (args (cadr binding))
+                           (body (cddr binding))
+                           (opt-pos (position-if #'(lambda (e) (member e '(&key &optional)))
+                                                 (the list args))))
+                      (when opt-pos
+                        (incf opt-pos)
+                        (let ((normal-args (subseq args 0 (1- opt-pos)))
+                              (optionals (subseq args opt-pos)))
+                          (prune-list optionals
+                                      #'(lambda (opt-lambda-arg try-fn)
+                                          (declare (type function try-fn))
+                                          (when (consp opt-lambda-arg)
+                                            (let ((name (first opt-lambda-arg))
+                                                  (form (second opt-lambda-arg)))
+                                              (prune form
+                                                     #'(lambda (form)
+                                                         (funcall try-fn (list name form)))))))
+                                      #'(lambda (opt-args)
+                                          (funcall try-fn
+                                                   `(,name (,@normal-args
+                                                              &optional
+                                                              ,@opt-args)
+                                                           ,@body))))))))
+                #'(lambda (bindings)
+                    (funcall try-fn `(,op ,bindings ,@body))))
+
+
+    ;; Try to simplify the forms in the RHS of the bindings
+    (prune-list binding-list
+                #'(lambda (binding try-fn)
+                    (declare (type function try-fn))
+
+                    ;; Prune body of a binding
+                    (prune (third binding)
+                           #'(lambda (form)
+                               (funcall try-fn
+                                        (list (first binding)
+                                              (second binding)
+                                              form)))))
+                #'(lambda (bindings)
+                    (funcall try-fn `(,op ,bindings ,@body))))
+
+    ;; ;; Try to simplify the body of the FLET form
+    (when body
+
+      ;; No bindings -- try to simplify to the last form in the body
+      (unless binding-list
+        (funcall try-fn (first (last body))))
+
+      (when (and (consp binding-list)
+                 (null (rest binding-list)))
+        (let ((binding (first binding-list)))
+          ;; One binding -- match on (flet ((<name> () <body>)) (<name>))
+          (when (and (symbolp (first binding))
+                     (not (find-in-tree (first binding) (rest binding)))
+                     (null (second binding))
+                     (equal body (list (list (first binding)))))
+            (funcall try-fn `(,op () ,@(cddr binding))))
+          ;; One binding -- try to remove it if not used
+          (when (and (symbolp (first binding))
+                     (not (find-in-tree (first binding) body)))
+            (funcall try-fn (first (last body))))
+        ))
+
+
+      ;; Try to simplify (the last form in) the body.
+      (prune (first (last body))
+             #'(lambda (form2)
+                 (funcall try-fn
+                          `(,@(butlast form) ,form2)))))))
+
+;;; Routine to walk form, applying a function at each form
+;;; The fn is applied in preorder.  When it returns :stop, do
+;;; not descend into subforms
+
+#|
+(defun walk (form fn)
+  (declare (type function fn))
+  (unless (eq (funcall fn form) :stop)
+    (when (consp form)
+      (let ((op (car form)))
+        (case op
+          ((let let*)
+           (walk-let form fn))
+          ((cond)
+           (dolist (clause (cdr form))
+             (walk-implicit-progn clause fn)))
+          ((multiple-value-bind)
+              (walk (third form) fn)
+              (walk-body (cdddr form) fn))
+          ((function quote declare) nil)
+          ((block the return-from)
+           (walk-implicit-progn (cddr form) fn))
+          ((case typecase)
+           (walk (cadr form) fn)
+           (dolist (clause (cddr form))
+             (walk-implicit-progn (cdr clause) fn)))
+          ((flet labels)
+
+
+
+
+|#
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; Convert pruned results to test cases
+
+(defun produce-test-cases (instances &key
+                                     (stream *standard-output*)
+                                     (prefix "MISC.")
+                                     (index 1))
+  (dolist (inst instances)
+    (let* (;; (vars (getf inst :vars))
+           (vals (getf inst :vals))
+           (optimized-lambda-form (getf inst :optimized-lambda-form))
+           (unoptimized-lambda-form (getf inst :unoptimized-lambda-form))
+           (name (intern
+                  (concatenate 'string prefix (format nil "~D" index))
+                  "CL-TEST"))
+           (test-form
+            `(deftest ,name
+               (let* ((fn1 ',optimized-lambda-form)
+                      (fn2 ',unoptimized-lambda-form)
+                      (vals ',vals)
+                      (v1 (apply (compile nil fn1) vals))
+                      (v2 (apply (compile nil fn2) vals)))
+                 (if (eql v1 v2)
+                     :good
+                   (list v1 v2)))
+               :good)))
+      (print test-form stream)
+      (terpri stream)
+      (incf index)))
+  (values))
diff --git a/random/random-intern.lsp b/random/random-intern.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..5041b984197cb1b1b35bf8156def59a176fcce88
--- /dev/null
+++ b/random/random-intern.lsp
@@ -0,0 +1,72 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Contains: Code to randomly intern and unintern random strings
+;;;;           in a package.  Exercises package and hash table routines
+
+(in-package :cl-test)
+
+(defconstant +max-len-random-symbol+ 63)
+
+(defun make-random-symbol (package)
+  (declare (optimize (speed 3) (safety 3)))
+  (loop
+   (let* ((len (random (1+ +max-len-random-symbol+)))
+          (str (make-string len)))
+     (declare (type (integer 0 #.+max-len-random-symbol+) len))
+     (loop
+      for i from 0 to (1- len) do
+      (setf (schar str i)
+            (schar +base-chars+
+                   (random +num-base-chars+))))
+     (multiple-value-bind
+      (symbol status)
+      (intern (copy-seq str) package)
+      (unless (equal str (symbol-name symbol))
+              (error "Intern gave bad symbol: ~A, ~A~%" str symbol))
+      (unless status (return symbol))))))
+
+(defun queue-insert (q x)
+  (declare (type cons q))
+  (push x (cdr q)))
+
+(defun queue-remove (q)
+  (declare (type cons q))
+  (when (null (car q))
+        (when (null (cdr q))
+              (error "Attempty to remove from empty queue.~%"))
+        (setf (car q) (nreverse (cdr q)))
+        (setf (cdr q) nil))
+  (pop (car q)))
+
+(defun queue-empty (q)
+  (and (null (car q))
+       (null (cdr q))))
+
+(defun random-intern (n)
+  (declare (fixnum n))
+  (let ((q (list nil))
+        (xp (defpackage "X" (:use))))
+    (declare (type cons q))
+    (loop
+     for i from 1 to n do
+     (if (and
+          (= (random 2) 0)
+          (not (queue-empty q)))
+         (unintern (queue-remove q) xp)
+       (queue-insert q (make-random-symbol xp))))))
+
+(defun fill-intern (n)
+  (declare (fixnum n))
+  (let ((xp (defpackage "X" (:use))))
+    (loop
+     for i from 1 to n do
+     (make-random-symbol xp))))
+
+
+
+
+
+
+
+
+
diff --git a/random/random-type-prop-tests-01.lsp b/random/random-type-prop-tests-01.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..da3a53e44b7e80b2957c6e032fa9886dd224b29a
--- /dev/null
+++ b/random/random-type-prop-tests-01.lsp
@@ -0,0 +1,73 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Mar  6 20:36:56 2005
+;;;; Contains: Test that invoke the random type prop infrastructure, part 1
+
+(in-package :cl-test)
+
+(def-type-prop-test special-operator-p 'special-operator-p '(symbol) 1)
+(def-type-prop-test type-of 'type-of '(t) 1)
+(def-type-prop-test typep.1 '(lambda (x y) (typep x (type-of y))) '(t t) 2)
+(def-type-prop-test typep.2 'typep
+  (list t #'(lambda (x)
+              (let ((type (make-random-type-containing x)))
+                `(eql ,type))))
+  2)
+(def-type-prop-test subtypep
+  '(lambda (x y) (subtypep (type-of x) (type-of y))) '(t t) 2)
+(def-type-prop-test fboundp.1 'fboundp '(symbol) 1)
+(def-type-prop-test fboundp.2 'fboundp '((cons (eql setf) (cons symbol null))) 1)
+(def-type-prop-test functionp 'functionp '(t) 1)
+(def-type-prop-test compiled-function-p 'compiled-function-p '(t) 1)
+(def-type-prop-test not 'not '(t) 1)
+(def-type-prop-test eq 'eq (list
+                            '(and t (not number) (not character))
+                            #'(lambda (x) (rcase
+                                           (1 `(eql ,x))
+                                           (1 '(and t (not number) (not character))))))
+  2)
+(def-type-prop-test eql.1 'eql '(t t) 2)
+(def-type-prop-test eql.2 'eql (list t #'(lambda (x) `(eql ,x))) 2)
+(def-type-prop-test equal.1 'equal '(t t) 2)
+(def-type-prop-test equal.2 'equal (list t #'(lambda (x) `(eql ,x))) 2)
+(def-type-prop-test equalp.1 'equalp '(t t) 2)
+(def-type-prop-test equalp.2 'equalp (list t #'(lambda (x) `(eql ,x))) 2)
+(def-type-prop-test identity 'identity '(t) 1)
+(def-type-prop-test complement
+ '(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2)
+(def-type-prop-test constantly
+  '(lambda (x) (funcall (constantly x))) '(t) 1)
+(def-type-prop-test and.1 'and '(t) 1)
+(def-type-prop-test and.2 'and '((or null t) t) 2)
+(def-type-prop-test and.3 'and '((or null t) (or null t) t) 3)
+(def-type-prop-test if.1 'if '(boolean t) 2)
+(def-type-prop-test if.2 'if '(boolean t t) 3)
+(def-type-prop-test if.3 '(lambda (p q x y z) (if p (if q x y) z))
+  '(boolean boolean t t t) 5)
+(def-type-prop-test if.4 '(lambda (p q x y z) (if p x (if q y z)))
+  '(boolean boolean t t t) 5)
+(def-type-prop-test if.5 '(lambda (p q x y) (if (or p q) x y))
+  '(boolean boolean t t) 4)
+(def-type-prop-test if.6 '(lambda (p q x y) (if (and p q) x y))
+  '(boolean boolean t t) 4)
+(def-type-prop-test cond.1 '(lambda (p x y) (cond (p x) (t y))) '(boolean t t) 3)
+(def-type-prop-test cond.2 '(lambda (p x y) (cond (p x) (t y))) '((or null t) t t) 3)
+(def-type-prop-test or.1 'or '(t) 1)
+(def-type-prop-test or.2 'or '((or null t) t) 2)
+(def-type-prop-test or.3 'or '((or null null t) (or null t) t) 3)
+(def-type-prop-test when 'when '((or null t) t) 2)
+(def-type-prop-test unless 'unless '((or null t) t) 2)
+(def-type-prop-test slot-exists-p 'slot-exists-p '(t symbol) 2)
+(def-type-prop-test find-class 'find-class '(symbol null) 2)
+(def-type-prop-test class-of 'class-of '(t) 1)
+(def-type-prop-test find-restart 'find-restart '((and symbol (not null))) 1)
+(def-type-prop-test symbolp 'symbolp '(t) 1)
+(def-type-prop-test keywordp 'keywordp '(t) 1)
+(def-type-prop-test make-symbol 'make-symbol '(string) 1
+  :test #'(lambda (x y) (string= (symbol-name x) (symbol-name y))))
+(def-type-prop-test symbol-name 'symbol-name '(symbol) 1)
+(def-type-prop-test symbol-package 'symbol-package '(symbol) 1)
+(def-type-prop-test boundp 'boundp '(symbol) 1)
+(def-type-prop-test find-symbol 'find-symbol '(string) 1)
+(def-type-prop-test find-package 'find-package '((or string symbol character)) 1)
+
diff --git a/random/random-type-prop-tests-02.lsp b/random/random-type-prop-tests-02.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..458aa8fcd5acbc35556386a6f4d07a6c9c42f8d5
--- /dev/null
+++ b/random/random-type-prop-tests-02.lsp
@@ -0,0 +1,115 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Mar  6 20:37:57 2005
+;;;; Contains: Tests that invoke the random type prop infrastructure, part 2
+
+(in-package :cl-test)
+
+(def-type-prop-test =.1 '= '(number number) 2)
+(def-type-prop-test =.2 '= '(number number number) 3)
+(def-type-prop-test =.3 '= nil 4 :maxargs 10 :rest-type 'number)
+(def-type-prop-test =.4 '= '(integer integer) 2)
+(def-type-prop-test =.5 '= (list 'number #'(lambda (x) (if (coin) 'number
+                                                        `(eql ,x)))) 2)
+(def-type-prop-test =.6 '= (list 'number 'number
+                                 #'(lambda (x y) (rcase
+                                                  (2 'number)
+                                                  (1 `(eql ,x))
+                                                  (1 `(eql ,y)))))
+  3)
+(def-type-prop-test /=.1 '/= '(number number) 2)
+(def-type-prop-test /=.2 '/= '(number number number) 3)
+(def-type-prop-test /=.3 '/= nil 4 :maxargs 10 :rest-type 'number)
+(def-type-prop-test /=.4 '/= '(integer integer) 2)
+(def-type-prop-test /=.5 '/= (list 'number #'(lambda (x) (if (coin) 'number
+                                                           `(eql ,x)))) 2)
+(def-type-prop-test /=.6 '/= (list 'number 'number
+                                   #'(lambda (x y) (rcase
+                                                    (2 'number)
+                                                    (1 `(eql ,x))
+                                                    (1 `(eql ,y)))))
+  3)
+(def-type-prop-test <.1 '< '(real real) 2)
+(def-type-prop-test <.2 '< '(real real real) 3)
+(def-type-prop-test <.3 '< nil 4 :maxargs 10 :rest-type 'real)
+(def-type-prop-test <.4 '< '(integer integer) 2)
+(def-type-prop-test <.5 '< (list 'real #'(lambda (x) (if (coin) 'real
+                                                        `(eql ,x)))) 2)
+(def-type-prop-test <.6 '< (list 'real 'real
+                                 #'(lambda (x y) (rcase
+                                                  (2 'real)
+                                                  (1 `(eql ,x))
+                                                  (1 `(eql ,y)))))
+  3)
+(def-type-prop-test >.1 '> '(real real) 2)
+(def-type-prop-test >.2 '> '(real real real) 3)
+(def-type-prop-test >.3 '> nil 4 :maxargs 10 :rest-type 'real)
+(def-type-prop-test >.4 '> '(integer integer) 2)
+(def-type-prop-test >.5 '> (list 'real #'(lambda (x) (if (coin) 'real
+                                                        `(eql ,x)))) 2)
+(def-type-prop-test >.6 '> (list 'real 'real
+                                 #'(lambda (x y) (rcase
+                                                  (2 'real)
+                                                  (1 `(eql ,x))
+                                                  (1 `(eql ,y)))))
+  3)
+(def-type-prop-test <=.1 '<= '(real real) 2)
+(def-type-prop-test <=.2 '<= '(real real real) 3)
+(def-type-prop-test <=.3 '<= nil 4 :maxargs 10 :rest-type 'real)
+(def-type-prop-test <=.4 '<= '(integer integer) 2)
+(def-type-prop-test <=.5 '<= (list 'real #'(lambda (x) (if (coin) 'real
+                                                         `(eql ,x)))) 2)
+(def-type-prop-test <=.6 '<= (list 'real 'real
+                                   #'(lambda (x y) (rcase
+                                                    (2 'real)
+                                                    (1 `(eql ,x))
+                                                    (1 `(eql ,y)))))
+  3)
+(def-type-prop-test >=.1 '>= '(real real) 2)
+(def-type-prop-test >=.2 '>= '(real real real) 3)
+(def-type-prop-test >=.3 '>= nil 4 :maxargs 10 :rest-type 'real)
+(def-type-prop-test >=.4 '>= '(integer integer) 2)
+(def-type-prop-test >=.5 '>= (list 'real #'(lambda (x) (if (coin) 'real
+                                                         `(eql ,x)))) 2)
+(def-type-prop-test >=.6 '>= (list 'real 'real
+                                   #'(lambda (x y) (rcase
+                                                    (2 'real)
+                                                    (1 `(eql ,x))
+                                                    (1 `(eql ,y)))))
+  3)
+
+(def-type-prop-test min.1 'min nil 2 :maxargs 6 :rest-type 'integer)
+(def-type-prop-test min.2 'min nil 2 :maxargs 6 :rest-type 'rational)
+(def-type-prop-test min.3 'min nil 2 :maxargs 6 :rest-type 'real)
+(def-type-prop-test max.1 'max nil 2 :maxargs 6 :rest-type 'integer)
+(def-type-prop-test max.2 'max nil 2 :maxargs 6 :rest-type 'rational)
+(def-type-prop-test max.3 'max nil 2 :maxargs 6 :rest-type 'real)
+
+(def-type-prop-test minusp 'minusp '(real) 1)
+(def-type-prop-test plusp 'plusp '(real) 1)
+(def-type-prop-test zerop 'zerop '(number) 1)
+
+(def-type-prop-test floor.1 'floor '(real) 1)
+(def-type-prop-test floor.2 'floor '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test floor.3 'floor '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test ffloor.1 'ffloor '(real) 1)
+(def-type-prop-test ffloor.2 'ffloor '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test ffloor.3 'ffloor '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test ceiling.1 'ceiling '(real) 1)
+(def-type-prop-test ceiling.2 'ceiling '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test ceiling.3 'ceiling '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test fceiling.1 'fceiling '(real) 1)
+(def-type-prop-test fceiling.2 'fceiling '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test fceiling.3 'fceiling '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test truncate.1 'truncate '(real) 1)
+(def-type-prop-test truncate.2 'truncate '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test truncate.3 'truncate '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test ftruncate.1 'ftruncate '(real) 1)
+(def-type-prop-test ftruncate.2 'ftruncate '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test ftruncate.3 'ftruncate '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test round.1 'round '(real) 1)
+(def-type-prop-test round.2 'round '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test round.3 'round '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test fround.1 'fround '(real) 1)
+(def-type-prop-test fround.2 'fround '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test fround.3 'fround '(real (and real (not (satisfies zerop)))) 2)
diff --git a/random/random-type-prop-tests-03.lsp b/random/random-type-prop-tests-03.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..a564c2149995b22582a99d8466e46819fe08ad2a
--- /dev/null
+++ b/random/random-type-prop-tests-03.lsp
@@ -0,0 +1,186 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Mar  6 20:39:10 2005
+;;;; Contains:  Tests that invoke the random type prop infrastructure, part 3
+
+(in-package :cl-test)
+
+;;; trig, hyperbolic functions here
+
+;;; WARNING -- these tests may cause floating point overflow/underflow
+;;; Ignore those failures
+(def-type-prop-test *.1 '* '(integer integer) 2)
+(def-type-prop-test *.2 '* nil 1 :rest-type 'integer :maxargs 4)
+(def-type-prop-test *.3 '* nil 2 :rest-type 'integer :maxargs 10)
+(def-type-prop-test *.4 '* '(real real) 2  :test #'approx=)
+(def-type-prop-test *.5 '* '(number number) 2 :test #'approx=)
+
+(def-type-prop-test \+.1 '+ '(integer integer) 2)
+(def-type-prop-test \+.2 '+ nil 1 :rest-type 'integer :maxargs 4)
+(def-type-prop-test \+.3 '+ nil 2 :rest-type 'integer :maxargs 10)
+(def-type-prop-test \+.4 '+ '(real real) 2 :test #'approx=)
+(def-type-prop-test \+.5 '+ '(number number) 2 :test #'approx=)
+
+(def-type-prop-test \-.1 '- '(integer integer) 2)
+(def-type-prop-test \-.2 '- nil 1 :rest-type 'integer :maxargs 4)
+(def-type-prop-test \-.3 '- nil 2 :rest-type 'integer :maxargs 10)
+(def-type-prop-test \-.4 '- '(real real) 2 :test #'approx=)
+(def-type-prop-test \-.5 '- '(number number) 2 :test #'approx=)
+(def-type-prop-test \-.6 '- '(number) 1)
+
+;;; WARNING -- these tests may cause floating point overflow/underflow
+;;; Ignore those failures
+(def-type-prop-test /.1 '/ '((and integer (not (satisfies zerop)))) 1)
+(def-type-prop-test /.2 '/ '((and rational (not (satisfies zerop)))) 1)
+(def-type-prop-test /.3 '/ '((and real (not (satisfies zerop)))) 1 :ignore 'arithmetic-error)
+(def-type-prop-test /.4 '/ '((and complex (not (satisfies zerop)))) 1 :ignore 'arithmetic-error)
+(def-type-prop-test /.5 '/ '(integer) 2 :maxargs 6 :rest-type '(and integer (not (satisfies zerop))))
+(def-type-prop-test /.6 '/ '(rational) 2 :maxargs 6 :rest-type '(and rational (not (satisfies zerop))))
+(def-type-prop-test /.7 '/ '(real) 2 :maxargs 6 :rest-type '(and real (not (satisfies zerop)))
+ :test #'approx= :ignore 'arithmetic-error)
+(def-type-prop-test /.8 '/ '(number) 2 :maxargs 6 :rest-type '(and number (not (satisfies zerop)))
+  :test #'approx= :ignore 'arithmetic-error)
+
+(def-type-prop-test 1+.1 '1+ '(integer) 1)
+(def-type-prop-test 1+.2 '1+ '(rational) 1)
+(def-type-prop-test 1+.3 '1+ '(real) 1)
+(def-type-prop-test 1+.4 '1+ '(number) 1)
+
+(def-type-prop-test 1-.1 '1- '(integer) 1)
+(def-type-prop-test 1-.2 '1- '(rational) 1)
+(def-type-prop-test 1-.3 '1- '(real) 1)
+(def-type-prop-test 1-.4 '1- '(number) 1)
+
+(def-type-prop-test abs.1 'abs '(integer) 1)
+(def-type-prop-test abs.2 'abs '(rational) 1)
+(def-type-prop-test abs.3 'abs '(real) 1)
+(def-type-prop-test abs.4 'abs '(number) 1)
+
+(def-type-prop-test evenp 'evenp '(integer) 1)
+(def-type-prop-test oddp 'oddp '(integer) 1)
+
+;;; exp, expt here
+
+(def-type-prop-test gcd 'gcd nil 1 :maxargs 6 :rest-type 'integer)
+(def-type-prop-test lcm 'lcm nil 1 :maxargs 6 :rest-type 'integer)
+
+(def-type-prop-test log.1 'log '((and real (not (satisfies zerop)))) 1 :test #'approx=)
+(def-type-prop-test log.2 'log '((and number (not (satisfies zerop)))) 1 :test #'approx=)
+
+(def-type-prop-test mod.1 'mod '(integer (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test mod.2 'mod '(real (and real (not (satisfies zerop)))) 2 :test #'approx=)
+(def-type-prop-test rem.1 'rem '(integer (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test rem.2 'rem '(real (and real (not (satisfies zerop)))) 2 :test #'approx=)
+
+(def-type-prop-test signum.1 'signum '(integer) 1)
+(def-type-prop-test signum.2 'signum '(rational) 1)
+(def-type-prop-test signum.3 'signum '(real) 1)
+(def-type-prop-test signum.4 'signum '(number) 1)
+
+(def-type-prop-test sqrt.1 'sqrt '(integer) 1 :test #'approx=)
+(def-type-prop-test sqrt.2 'sqrt '(rational) 1 :test #'approx=)
+(def-type-prop-test sqrt.3 'sqrt '(real) 1 :test #'approx=)
+(def-type-prop-test sqrt.4 'sqrt '(number) 1 :test #'approx=)
+
+(def-type-prop-test isqrt 'isqrt '((integer 0)) 1)
+
+(def-type-prop-test numberp 'numberp '(t) 1)
+
+(def-type-prop-test complex.1 'complex '(integer) 1)
+(def-type-prop-test complex.2 'complex '(rational) 1)
+(def-type-prop-test complex.3 'complex '(real) 1)
+(def-type-prop-test complex.4 'complex '(rational rational) 2)
+(def-type-prop-test complex.5 'complex '(real real) 2)
+
+(def-type-prop-test complexp 'complexp '(t) 1)
+
+(def-type-prop-test conjugate 'conjugate '(number) 1)
+
+(def-type-prop-test phase.1 'phase '(real) 1)
+(def-type-prop-test phase.2 'phase '(number) 1 :test #'approx=)
+
+(def-type-prop-test realpart.1 'realpart '(real) 1)
+(def-type-prop-test realpart.2 'realpart '(number) 1)
+(def-type-prop-test imagpart.1 'imagpart '(real) 1)
+(def-type-prop-test imagpart.2 'imagpart '(number) 1)
+
+(def-type-prop-test realp 'realp '(t) 1)
+
+(def-type-prop-test numerator 'numerator '(rational) 1)
+(def-type-prop-test denominator 'denominator '(rational) 1)
+
+(def-type-prop-test rational 'rational '(real) 1)
+(def-type-prop-test rationalize 'rationalize '(real) 1)
+
+(def-type-prop-test rationalp 'rationalp '(t) 1)
+
+(def-type-prop-test ash.1 'ash '(integer (integer -32 32)) 2)
+(def-type-prop-test ash.2 'ash '(integer (integer -100 100)) 2)
+
+(def-type-prop-test integer-length 'integer-length '(integer) 1)
+(def-type-prop-test integerp 'integerp '(t) 1)
+
+(def-type-prop-test logand.1 'logand '(integer integer) 2)
+(def-type-prop-test logand.2 'logand nil 2 :rest-type 'integer :maxargs 6)
+
+(def-type-prop-test logandc1 'logandc1 '(integer integer) 2)
+(def-type-prop-test logandc2 'logandc2 '(integer integer) 2)
+
+(def-type-prop-test lognand 'lognand '(integer integer) 2)
+(def-type-prop-test lognor 'lognor '(integer integer) 2)
+
+(def-type-prop-test logeqv.1 'logeqv '(integer integer) 2)
+(def-type-prop-test logeqv.2 'logeqv nil 2 :rest-type 'integer :maxargs 6)
+
+(def-type-prop-test logior.1 'logior '(integer integer) 2)
+(def-type-prop-test logior.2 'logior nil 2 :rest-type 'integer :maxargs 6)
+
+(def-type-prop-test logxor.1 'logxor '(integer integer) 2)
+(def-type-prop-test logxor.2 'logxor nil 2 :rest-type 'integer :maxargs 6)
+
+(def-type-prop-test logorc1 'logorc1 '(integer integer) 2)
+(def-type-prop-test logorc2 'logorc2 '(integer integer) 2)
+
+(def-type-prop-test lognot 'lognot '(integer) 1)
+
+(def-type-prop-test logbitp.1 'logbitp '((integer 0 32) integer) 2)
+(def-type-prop-test logbitp.2 'logbitp '((integer 0 100) integer) 2)
+; (def-type-prop-test logbitp.3 'logbitp '((integer 0) integer) 2)
+
+(def-type-prop-test logcount 'logcount '(integer) 1)
+(def-type-prop-test logtest 'logtest '(integer integer) 2)
+
+(def-type-prop-test decode-float.1 'decode-float '(float) 1)
+(def-type-prop-test decode-float.2 '(lambda (x) (nth-value 1 (decode-float x))) '(float) 1)
+(def-type-prop-test decode-float.3 '(lambda (x) (nth-value 2 (decode-float x))) '(float) 1)
+(def-type-prop-test float-radix 'float-radix '(float) 1)
+(def-type-prop-test scale-float 'scale-float '(float (integer -30 30)) 2 :ignore 'arithmetic-error :test #'approx=)
+(def-type-prop-test float-sign.1 'float-sign '(float) 1)
+(def-type-prop-test float-sign.2 'float-sign '(float float) 2)
+(def-type-prop-test float-digits 'float-digits '(float) 1)
+(def-type-prop-test float-precision 'float-precision '(float) 1)
+(def-type-prop-test integer-decode-float.1 'integer-decode-float '(float) 1)
+(def-type-prop-test integer-decode-float.2 '(lambda (x) (nth-value 1 (integer-decode-float x))) '(float) 1)
+(def-type-prop-test integer-decode-float.3 '(lambda (x) (nth-value 2 (integer-decode-float x))) '(float) 1)
+
+
+(def-type-prop-test float.1 'float '(real) 1)
+(def-type-prop-test float.2 'float '(real float) 2)
+(def-type-prop-test floatp 'floatp '(t) 1)
+
+(defun has-nonzero-length (x) (> (length x) 0))
+
+(def-type-prop-test parse-integer.1 'parse-integer
+  '((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+         (satisfies has-nonzero-length)))
+  1)
+
+(def-type-prop-test parse-integer.2 'parse-integer
+  `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+         (satisfies has-nonzero-length))
+    (eql :start)
+    ,#'(lambda (x &rest rest) (declare (ignore rest))
+         `(integer 0 (,(length x)))))
+  3)
+
+(def-type-prop-test sxhash 'sxhash '(t) 1)
diff --git a/random/random-type-prop-tests-04.lsp b/random/random-type-prop-tests-04.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..b12aae407e0e8b6810d371e297df427da2e6060e
--- /dev/null
+++ b/random/random-type-prop-tests-04.lsp
@@ -0,0 +1,107 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Mar  6 21:44:41 2005
+;;;; Contains: Test that invoke the random type prop infrastructure, part 4
+
+(in-package :cl-test)
+
+(defun char-or-same (c &rest args)
+  (declare (ignore args))
+  (if (coin) `(eql ,c) 'character))
+
+(eval-when (:load-toplevel :execute) (compile 'char-or-same))
+
+(def-type-prop-test char=.1 'char= nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char=.2 'char= '(character character) 2)
+(def-type-prop-test char=.3 'char= (list 'character #'char-or-same) 2)
+(def-type-prop-test char=.4 'char= (list 'character #'char-or-same #'char-or-same) 3)
+(def-type-prop-test char=.5 'char= '(character) 3 :rest-type #'char-or-same :maxargs 6)
+
+(def-type-prop-test char/=.1 'char/= nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char/=.2 'char/= '(character character) 2)
+(def-type-prop-test char/=.3 'char/= (list 'character #'char-or-same) 2)
+(def-type-prop-test char/=.4 'char/= (list 'character 'character #'char-or-same) 3)
+(def-type-prop-test char/=.5 'char/= nil 2 :rest-type 'character :maxargs 6)
+
+(def-type-prop-test char<=.1 'char<= nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char<=.2 'char<= '(character character) 2)
+(def-type-prop-test char<=.3 'char<= (list 'character #'char-or-same) 2)
+(def-type-prop-test char<=.4 'char<= (list 'character #'char-or-same #'char-or-same) 3)
+(def-type-prop-test char<=.5 'char<= '(character) 3 :rest-type #'char-or-same :maxargs 6)
+
+(def-type-prop-test char>=.1 'char>= nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char>=.2 'char>= '(character character) 2)
+(def-type-prop-test char>=.3 'char>= (list 'character #'char-or-same) 2)
+(def-type-prop-test char>=.4 'char>= (list 'character #'char-or-same #'char-or-same) 3)
+(def-type-prop-test char>=.5 'char>= '(character) 3 :rest-type #'char-or-same :maxargs 6)
+
+(def-type-prop-test char<.1 'char< nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char<.2 'char< '(character character) 2)
+(def-type-prop-test char<.3 'char< (list 'character #'char-or-same) 2)
+(def-type-prop-test char<.4 'char< (list 'character 'character #'char-or-same) 3)
+(def-type-prop-test char<.5 'char< nil 2 :rest-type 'character :maxargs 6)
+
+(def-type-prop-test char>.1 'char> nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char>.2 'char> '(character character) 2)
+(def-type-prop-test char>.3 'char> (list 'character #'char-or-same) 2)
+(def-type-prop-test char>.4 'char> (list 'character 'character #'char-or-same) 3)
+(def-type-prop-test char>.5 'char> nil 2 :rest-type 'character :maxargs 6)
+
+
+(def-type-prop-test char-equal.1 'char-equal nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char-equal.2 'char-equal '(character character) 2)
+(def-type-prop-test char-equal.3 'char-equal (list 'character #'char-or-same) 2)
+(def-type-prop-test char-equal.4 'char-equal (list 'character #'char-or-same #'char-or-same) 3)
+(def-type-prop-test char-equal.5 'char-equal '(character) 3 :rest-type #'char-or-same :maxargs 6)
+
+(def-type-prop-test char-not-equal.1 'char-not-equal nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char-not-equal.2 'char-not-equal '(character character) 2)
+(def-type-prop-test char-not-equal.3 'char-not-equal (list 'character #'char-or-same) 2)
+(def-type-prop-test char-not-equal.4 'char-not-equal (list 'character 'character #'char-or-same) 3)
+(def-type-prop-test char-not-equal.5 'char-not-equal nil 2 :rest-type 'character :maxargs 6)
+
+(def-type-prop-test char-not-greaterp.1 'char-not-greaterp nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char-not-greaterp.2 'char-not-greaterp '(character character) 2)
+(def-type-prop-test char-not-greaterp.3 'char-not-greaterp (list 'character #'char-or-same) 2)
+(def-type-prop-test char-not-greaterp.4 'char-not-greaterp (list 'character #'char-or-same #'char-or-same) 3)
+(def-type-prop-test char-not-greaterp.5 'char-not-greaterp '(character) 3 :rest-type #'char-or-same :maxargs 6)
+
+(def-type-prop-test char-not-lessp.1 'char-not-lessp nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char-not-lessp.2 'char-not-lessp '(character character) 2)
+(def-type-prop-test char-not-lessp.3 'char-not-lessp (list 'character #'char-or-same) 2)
+(def-type-prop-test char-not-lessp.4 'char-not-lessp (list 'character #'char-or-same #'char-or-same) 3)
+(def-type-prop-test char-not-lessp.5 'char-not-lessp '(character) 3 :rest-type #'char-or-same :maxargs 6)
+
+(def-type-prop-test char-lessp.1 'char-lessp nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char-lessp.2 'char-lessp '(character character) 2)
+(def-type-prop-test char-lessp.3 'char-lessp (list 'character #'char-or-same) 2)
+(def-type-prop-test char-lessp.4 'char-lessp (list 'character 'character #'char-or-same) 3)
+(def-type-prop-test char-lessp.5 'char-lessp nil 2 :rest-type 'character :maxargs 6)
+
+(def-type-prop-test char-greaterp.1 'char-greaterp nil 2 :rest-type 'base-char :maxargs 5)
+(def-type-prop-test char-greaterp.2 'char-greaterp '(character character) 2)
+(def-type-prop-test char-greaterp.3 'char-greaterp (list 'character #'char-or-same) 2)
+(def-type-prop-test char-greaterp.4 'char-greaterp (list 'character 'character #'char-or-same) 3)
+(def-type-prop-test char-greaterp.5 'char-greaterp nil 2 :rest-type 'character :maxargs 6)
+
+(defun length1-p (seq) (= (length seq) 1))
+  
+(def-type-prop-test character 'character '((or character (and (string 1) (satisfies length1-p)))) 1)
+(def-type-prop-test characterp 'characterp '(t) 1)
+(def-type-prop-test alpha-char-p 'alpha-char-p '(character) 1)
+(def-type-prop-test alphanumericp 'alphanumericp '(character) 1)
+(def-type-prop-test digit-char 'digit-char '((or (integer 0 36) (integer 0)) (integer 2 36)) 1 :maxargs 2)
+(def-type-prop-test digit-char-p 'digit-char-p '(character) 1)
+(def-type-prop-test graphic-char-p 'graphic-char-p '(character) 1)
+(def-type-prop-test standard-char-p 'standard-char-p '(character) 1)
+(def-type-prop-test char-upcase 'char-upcase '(character) 1)
+(def-type-prop-test char-downcase 'char-downcase '(character) 1)
+(def-type-prop-test upper-case-p 'upper-case-p '(character) 1)
+(def-type-prop-test lower-case-p 'lower-case-p '(character) 1)
+(def-type-prop-test both-case-p 'both-case-p '(character) 1)
+(def-type-prop-test char-code 'char-code '(character) 1)
+(def-type-prop-test char-int 'char-int '(character) 1)
+(def-type-prop-test code-char 'code-char '((integer 0 #.char-code-limit)) 1)
+(def-type-prop-test char-name 'char-name '(character) 1)
+(def-type-prop-test name-char 'name-char '(string) 1)
+
diff --git a/random/random-type-prop-tests-05.lsp b/random/random-type-prop-tests-05.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..5ef8ee93554a63e4e82e918e8b472f245b188f3c
--- /dev/null
+++ b/random/random-type-prop-tests-05.lsp
@@ -0,0 +1,528 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Mar  8 20:31:08 2005
+;;;; Contains: Random type prop tests, part 5 (Cons)
+
+(in-package :cl-test)
+
+(def-type-prop-test list.1 'list nil 1 :rest-type 't :maxargs 10)
+(def-type-prop-test list.2 '(lambda (x) (car (list x))) '(t) 1)
+(def-type-prop-test list.3 '(lambda (x y) (cdr (list x y))) '(t t) 2)
+(def-type-prop-test list.4 '(lambda (x y z) (cadr (list x y z))) '(t t t) 3)
+(def-type-prop-test list.5 '(lambda (x) (let ((z (list x))) (declare (dynamic-extent z)) (car z)))  '(t) 1)
+
+(def-type-prop-test list* 'list* () 1 :rest-type t :maxargs 10)
+
+(def-type-prop-test null 'null '(t) 1)
+(def-type-prop-test cons.1 'cons '(t t) 2)
+(def-type-prop-test cons.2 '(lambda (x y) (car (cons y x))) '(t t) 2)
+(def-type-prop-test cons.3 '(lambda (x y) (cdr (cons x y))) '(t t) 2)
+
+(def-type-prop-test consp 'consp '(t) 1)
+(def-type-prop-test atom 'atom '(t) 1)
+
+(def-type-prop-test rplaca 'rplaca '(cons t) 2 :replicate '(t nil))
+(def-type-prop-test rplacd 'rplacd '(cons t) 2 :replicate '(t nil))
+
+(def-type-prop-test car 'car '((cons t t)) 1)
+(def-type-prop-test first 'first '((cons t t)) 1)
+(def-type-prop-test cdr 'cdr '((cons t t)) 1)
+(def-type-prop-test rest 'rest '((cons t t)) 1)
+(def-type-prop-test caar 'caar '((cons (cons t t) t)) 1)
+(def-type-prop-test cdar 'cdar '((cons (cons t t) t)) 1)
+(def-type-prop-test cadr 'cadr '((cons t (cons t t))) 1)
+(def-type-prop-test second 'second '((cons t (cons t t))) 1)
+(def-type-prop-test cddr 'cddr '((cons t (cons t t))) 1)
+(def-type-prop-test caaar 'caaar '((cons (cons (cons t t) t) t)) 1)
+(def-type-prop-test cdaar 'cdaar '((cons (cons (cons t t) t) t)) 1)
+(def-type-prop-test cadar 'cadar '((cons (cons t (cons t t)) t)) 1)
+(def-type-prop-test cddar 'cddar '((cons (cons t (cons t t)) t)) 1)
+(def-type-prop-test caadr 'caadr '((cons t (cons (cons t t) t))) 1)
+(def-type-prop-test cdadr 'cdadr '((cons t (cons (cons t t) t))) 1)
+(def-type-prop-test caddr 'caddr '((cons t (cons t (cons t t)))) 1)
+(def-type-prop-test third 'third '((cons t (cons t (cons t t)))) 1)
+(def-type-prop-test cdddr 'cdddr '((cons t (cons t (cons t t)))) 1)
+
+(def-type-prop-test caaaar'caaaar '((cons (cons (cons (cons t t) t) t) t)) 1)
+(def-type-prop-test cdaaar 'cdaaar '((cons (cons (cons (cons t t) t) t) t)) 1)
+(def-type-prop-test cadaar 'cadaar '((cons (cons (cons t (cons t t)) t) t)) 1)
+(def-type-prop-test cddaar 'cddaar '((cons (cons (cons t (cons t t)) t) t)) 1)
+(def-type-prop-test caadar 'caadar '((cons (cons t (cons (cons t t) t)) t)) 1)
+(def-type-prop-test cdadar 'cdadar '((cons (cons t (cons (cons t t) t)) t)) 1)
+(def-type-prop-test caddar 'caddar '((cons (cons t (cons t (cons t t))) t)) 1)
+(def-type-prop-test cdddar 'cdddar '((cons (cons t (cons t (cons t t))) t)) 1)
+(def-type-prop-test caaadr 'caaadr '((cons t (cons (cons (cons t t) t) t))) 1)
+(def-type-prop-test cdaadr 'cdaadr '((cons t (cons (cons (cons t t) t) t))) 1)
+(def-type-prop-test cadadr 'cadadr '((cons t (cons (cons t (cons t t)) t))) 1)
+(def-type-prop-test cddadr 'cddadr '((cons t (cons (cons t (cons t t)) t))) 1)
+(def-type-prop-test caaddr 'caaddr '((cons t (cons t (cons (cons t t) t)))) 1)
+(def-type-prop-test cdaddr 'cdaddr '((cons t (cons t (cons (cons t t) t)))) 1)
+(def-type-prop-test cadddr 'cadddr '((cons t (cons t (cons t (cons t t))))) 1)
+(def-type-prop-test fourth 'fourth '((cons t (cons t (cons t (cons t t))))) 1)
+(def-type-prop-test cddddr 'cddddr '((cons t (cons t (cons t (cons t t))))) 1)
+
+(def-type-prop-test fifth 'fifth '((cons t (cons t (cons t (cons t (cons t t)))))) 1)
+(def-type-prop-test sixth 'sixth '((cons t (cons t (cons t (cons t (cons t (cons t t))))))) 1)
+(def-type-prop-test seventh 'seventh '((cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))) 1)
+(def-type-prop-test eighth 'eighth
+  '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))))
+  1)
+(def-type-prop-test ninth 'ninth
+  '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))))
+  1)
+(def-type-prop-test tenth 'tenth
+  '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))))))
+  1)
+
+(def-type-prop-test pop '(lambda (x) (list (pop x) x)) '((cons t t)) 1)
+(def-type-prop-test push '(lambda (x y) (list (push x y) x y)) '(t t) 2)
+
+(def-type-prop-test copy-tree.1 'copy-tree '((cons t t)) 1)
+(def-type-prop-test copy-tree.2 'copy-tree '((cons (cons t t) (cons t t))) 1)
+(def-type-prop-test copy-tree.3 'copy-tree '((cons t (cons (cons t (cons t t)) t))) 1)
+(def-type-prop-test copy-tree.4 'copy-tree '(list) 1)
+
+(def-type-prop-test sublis.1 'sublis '((cons (cons symbol t) null) list) 2)
+(def-type-prop-test sublis.2 'sublis '((cons (cons (integer 0 7) t) null) list) 2)
+(def-type-prop-test sublis.3 'sublis '(null list) 2)
+(def-type-prop-test sublis.4 'sublis `((cons (cons boolean t) null) list
+                                       (eql :key)
+                                       (or null (eql not) (eql ,#'not))) 4)
+(def-type-prop-test sublis.5 'sublis `((cons (cons t t) null) list (eql :test) (or (eql equal) (eql ,#'equal))) 4)
+(def-type-prop-test sublis.6 'sublis `((cons (cons t t) null) list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4)
+
+(def-type-prop-test subst.1 'subst '(t t t) 3)
+(def-type-prop-test subst.2 'subst '(t t (cons t t)) 3)
+(def-type-prop-test subst.3 'subst '(t t list) 3)
+(def-type-prop-test subst.4 'subst '(t t (cons (cons t t) (cons t t))) 3)
+(def-type-prop-test subst.5 'subst `(boolean t (cons (cons t t) (cons t t))
+                                             (eql :key)
+                                             (or null (eql not) (eql ,#'not))) 5)
+(def-type-prop-test subst.6 'subst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5)
+(def-type-prop-test subst.7 'subst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5)
+(def-type-prop-test subst.8 'subst `(t t (cons (cons t t) (cons t t))
+                                       (eql :key) (or null (eql not) (eql ,#'not))
+                                       (eql :test) (or (eql equal) (eql ,#'equal))) 7)
+
+(def-type-prop-test nsubst.1 'nsubst '(t t t) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst.2 'nsubst '(t t (cons t t)) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst.3 'nsubst '(t t list) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst.4 'nsubst '(t t (cons (cons t t) (cons t t))) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst.5 'nsubst `(boolean t (cons (cons t t) (cons t t))
+                                               (eql :key)
+                                               (or null (eql not) (eql ,#'not))) 5
+                                               :replicate '(nil nil t nil nil))
+(def-type-prop-test nsubst.6 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil))
+(def-type-prop-test nsubst.7 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil))
+(def-type-prop-test nsubst.8 'nsubst `(t t (cons (cons t t) (cons t t))
+                                         (eql :key) (or null (eql not) (eql ,#'not))
+                                         (eql :test) (or (eql equal) (eql ,#'equal))) 7
+                                         :replicate '(nil nil t nil nil nil nil))
+
+
+(def-type-prop-test subst-if.1 'subst-if `(t (or (eql not) (eql ,#'not)) list) 3)
+(def-type-prop-test subst-if.2 'subst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3)
+(def-type-prop-test subst-if.3 'subst-if `(t (eql identity)
+                                             (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
+                                             (eql :key) (or null (eql not) (eql ,#'not))) 5)
+
+(def-type-prop-test nsubst-if.1 'nsubst-if `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst-if.2 'nsubst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst-if.3 'nsubst-if `(t (eql identity)
+                                               (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
+                                               (eql :key) (or null (eql not) (eql ,#'not))) 5
+                                               :replicate '(nil nil t nil nil))
+
+(def-type-prop-test subst-if-not.1 'subst-if-not `(t (or (eql not) (eql ,#'not)) list) 3)
+(def-type-prop-test subst-if-not.2 'subst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3)
+(def-type-prop-test subst-if-not.3 'subst-if-not `(t (eql identity)
+                                                     (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
+                                                     (eql :key) (or null (eql not) (eql ,#'not))) 5)
+
+(def-type-prop-test nsubst-if-not.1 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst-if-not.2 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t))
+(def-type-prop-test nsubst-if-not.3 'nsubst-if-not `(t (eql identity)
+                                                       (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
+                                                       (eql :key) (or null (eql not) (eql ,#'not))) 5
+                                                       :replicate '(nil nil t nil nil))
+
+(def-type-prop-test tree-equal.1 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x))))) 2)
+(def-type-prop-test tree-equal.2 'tree-equal (list 'list #'(lambda (x) `(or list (eql ,(copy-tree t))))) 2)
+(def-type-prop-test tree-equal.3 'tree-equal (list '(cons t t)
+                                                   #'(lambda (x) `(or (cons t t) (eql ,(copy-tree x))))
+                                                   '(eql :test)
+                                                   `(or (eql equal) (eql ,#'equal)))
+  4)
+(def-type-prop-test tree-equal.4 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x))))
+                                                   '(eql :test-not) '(eql eql))
+  4)
+
+(def-type-prop-test copy-list.1 'copy-list '(list) 1)
+(def-type-prop-test copy-list.2 'copy-list '((cons t t)) 1)
+(def-type-prop-test copy-list.3 'copy-list '((cons t (cons t (or t (cons t (or t (cons t t))))))) 1)
+
+(def-type-prop-test list-length.1 'list-length '(list) 1)
+(def-type-prop-test list-length.2 'list-length '((cons t list)) 1)
+
+(def-type-prop-test listp 'listp '(t) 1)
+
+(def-type-prop-test make-list.1 'make-list '((integer 0 100)) 1)
+(def-type-prop-test make-list.2 '(lambda (x) (length (make-list x))) '((integer 0 100)) 1)
+(def-type-prop-test make-list.3 'make-list '((integer 0 100) (eql :initial-element) t) 3)
+
+(def-type-prop-test nth.1 'nth '((integer 0 12) list) 2)
+
+(def-type-prop-test endp.1 'endp '((or null (cons t t))) 1)
+
+(def-type-prop-test append.1 'append nil 1 :maxargs 10 :rest-type 'list)
+(def-type-prop-test append.2 'append '(list t) 2)
+(def-type-prop-test append.3 'append '(list list t) 3)
+(def-type-prop-test append.4 'append '(list list list t) 4)
+
+(def-type-prop-test nconc.1 'nconc '(list) 1)
+(def-type-prop-test nconc.2 'nconc '(list list) 2 :replicate '(t nil))
+(def-type-prop-test nconc.3 'nconc '(list list list) 3 :replicate '(t t nil))
+(def-type-prop-test nconc.4 'nconc '(list list list list) 4 :replicate '(t t t nil))
+
+(def-type-prop-test revappend 'revappend '(list t) 2)
+(def-type-prop-test nreconc 'nreconc '(list t) 2 :replicate '(t nil))
+
+(def-type-prop-test butlast.1 'butlast '(list) 1)
+(def-type-prop-test butlast.2 'butlast '(list (integer 0 20)) 2)
+
+(def-type-prop-test nbutlast.1 'nbutlast '(list) 1 :replicate '(t))
+(def-type-prop-test nbutlast.2 'nbutlast '(list (integer 0 20)) 2 :replicate '(t nil))
+
+(def-type-prop-test last.1 'last '(list) 1)
+(def-type-prop-test last.2 'last '(list (integer 0 15)) 2)
+(def-type-prop-test last.3 'last '((cons t (or t (cons t (or t (cons t t)))))) 1)
+(def-type-prop-test last.4 'last '((cons t (or t (cons t (or t (cons t t))))) (integer 0 5)) 2)
+
+(def-type-prop-test ldiff.1 'ldiff '(list t) 2)
+(def-type-prop-test ldiff.2 'ldiff (list 'list
+                                         #'(lambda (x)
+                                             (if (consp x)
+                                                 `(or t (eql ,(nthcdr (random (length x)) x)))
+                                               t)))
+  2)
+
+(def-type-prop-test tailp.1 'tailp '(t list) 2)
+(def-type-prop-test tailp.2 'tailp (list t #'(lambda (x) (make-list-type (1+ (random 10)) `(eql ,x)))) 2)
+
+(def-type-prop-test nthcdr 'nthcdr '((integer 0 20) list) 2)
+
+(def-type-prop-test member.1 'member '(t list) 2)
+(def-type-prop-test member.2 'member
+  (list t #'(lambda (x) (make-list-type (random 5) `(cons (eql ,x) ,(make-list-type (random 5))))))
+  2)
+(def-type-prop-test member.3 'member `(t list (eql :key) (or (eql not) (eql ,#'not))) 4)
+(def-type-prop-test member.4 'member `(t list (eql :test) (or (eql equalp) (eql ,#'equalp))) 4)
+(def-type-prop-test member.5 'member `(t list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4)
+(def-type-prop-test member.6 'member `(t list (eql :allow-other-keys) (and t (not null)) (eql :foo) t) 6)
+
+(def-type-prop-test member-if.1 'member-if `((or (eql symbolp) (eql ,#'symbolp)) list) 2)
+(def-type-prop-test member-if.2 'member-if
+  (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))))
+  2)
+(def-type-prop-test member-if.3 'member-if
+  (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))
+        '(eql :key)`(or (eql 1-) (eql ,#'1-)))
+  4)
+
+(def-type-prop-test member-if-not.1 'member-if-not `((or (eql symbolp) (eql ,#'symbolp)) list) 2)
+(def-type-prop-test member-if-not.2 'member-if-not
+  (list '(eql plusp) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))))
+  2)
+(def-type-prop-test member-if-not.3 'member-if-not
+  (list '(eql plusp)
+        #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))
+        '(eql :key)
+        `(or (eql 1-) (eql ,#'1-)))
+  4)
+(def-type-prop-test member-if-not.4 'member-if-not
+  `((eql identity) list
+    (eql :allow-other-keys) (and t (not null))
+    (member :foo :bar #:xyz) t)
+  6)
+
+(def-type-prop-test mapc.1 'mapc '((eql list)) 2 :rest-type 'list :maxargs 10)
+(def-type-prop-test mapc.2 'mapc `((eql ,#'values)) 2 :rest-type 'list :maxargs 10)
+
+(def-type-prop-test mapcar.1 'mapcar '((eql list)) 2 :rest-type 'list :maxargs 10)
+(def-type-prop-test mapcar.2 'mapcar `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10)
+
+(def-type-prop-test maplist.1 'maplist '((eql list)) 2 :rest-type 'list :maxargs 10)
+(def-type-prop-test maplist.2 'maplist `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10)
+
+(def-type-prop-test mapl.1 'mapl '((eql list)) 2 :rest-type 'list :maxargs 10)
+(def-type-prop-test mapl.2 'mapl `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10)
+
+(def-type-prop-test mapcan.1 'mapcan '((eql list)) 2 :rest-type 'list :maxargs 10)
+
+(def-type-prop-test mapcon.1 'mapcon '((eql copy-list) list) 2)
+
+(def-type-prop-test acons 'acons
+  (list t t #'(lambda (x y) (make-list-type (random 5) 'null '(or null (cons t t)))))
+  3)
+
+(def-type-prop-test assoc.1 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2)
+(def-type-prop-test assoc.2 'assoc
+  (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t)))))
+  2)
+(def-type-prop-test assoc.3 'assoc
+  (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t))))
+        '(eql :key) `(or (eql not) (eql ,#'not)))
+  4)
+(def-type-prop-test assoc.4 'assoc
+  (list 'real
+        #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons real t) (cons (eql ,x) t))))
+        `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=))
+  4)
+
+(def-type-prop-test assoc-if.1 'assoc-if
+  (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp)
+        (make-list-type (random 8) 'null '(or null (cons t t))))
+  2)
+(def-type-prop-test assoc-if.2 'assoc-if
+  (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop)
+        (make-list-type (random 8) 'null '(or null (cons real t)))
+        '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum))
+  2)
+
+(def-type-prop-test assoc-if-not.1 'assoc-if-not
+  (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp)
+        (make-list-type (random 8) 'null '(or null (cons t t))))
+  2)
+(def-type-prop-test assoc-if-not.2 'assoc-if-not
+  (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop)
+        (make-list-type (random 8) 'null '(or null (cons real t)))
+        '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum))
+  2)
+
+(def-type-prop-test copy-alist 'copy-alist
+  (list #'(lambda () (make-list-type (random 10) 'null '(or null (cons t t)))))
+  1)
+
+(def-type-prop-test pairlis.1 'pairlis
+  (list 'list #'(lambda (x) (make-list-type (length x) 'null t)))
+  2)
+
+(def-type-prop-test pairlis.2 'pairlis
+  (list 'list #'(lambda (x) (make-list-type (length x) 'null t))
+        #'(lambda (x y) (make-list-type (random 6) 'null '(or null (cons t t)))))
+  3)
+
+(def-type-prop-test rassoc.1 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2)
+(def-type-prop-test rassoc.2 'rassoc
+  (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x))))))
+  2)
+(def-type-prop-test rassoc.3 'rassoc
+  (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x)))))
+        '(eql :key) `(or (eql not) (eql ,#'not)))
+  4)
+(def-type-prop-test rassoc.4 'rassoc
+  (list 'real
+        #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t real) (cons t (eql ,x)))))
+        `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=))
+  4)
+
+(def-type-prop-test rassoc-if.1 'rassoc-if
+  (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp)
+        (make-list-type (random 8) 'null '(or null (cons t t))))
+  2)
+(def-type-prop-test rassoc-if.2 'rassoc-if
+  (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop)
+        (make-list-type (random 8) 'null '(or null (cons t real)))
+        '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum))
+  2)
+
+(def-type-prop-test rassoc-if-not.1 'rassoc-if-not
+  (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp)
+        (make-list-type (random 8) 'null '(or null (cons t t))))
+  2)
+(def-type-prop-test rassoc-if-not.2 'rassoc-if-not
+  (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop)
+        (make-list-type (random 8) 'null '(or null (cons t real)))
+        '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum))
+  2)
+
+;;; We don't use numbers or characters as indicators, since the test is EQ,
+;;; which is not well-behaved on these types.
+
+(def-type-prop-test get-properties.1 'get-properties
+  (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) 'list)
+  2)
+(def-type-prop-test get-properties.2 'get-properties
+  (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character))))
+        #'(lambda (plist) (let ((len (length plist)))
+                            (if (= len 0) '(cons t null)
+                              (let ((ind (elt plist (* 2 (random (floor len 2))))))
+                                `(cons (eql ,ind) null))))))
+  2)
+
+(def-type-prop-test getf.1 'getf
+  (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) t)
+  2)
+(def-type-prop-test getf.2 'getf
+  (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character))))
+        #'(lambda (plist) (let ((len (length plist)))
+                            (if (= len 0) t
+                              (let ((ind (elt plist (* 2 (random (floor len 2))))))
+                                `(eql ,ind))))))
+  2)
+(def-type-prop-test getf.3 'getf
+  (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character))))
+        t t)
+  3)
+
+(def-type-prop-test intersection.1 'intersection '(list list) 2 :test #'same-set-p)
+(def-type-prop-test intersection.2 'intersection '(list list (eql :key) (eql identity))  4 :test #'same-set-p)
+(def-type-prop-test intersection.3 'intersection
+  (list #'(lambda () (make-list-type (random 10) 'null 'integer))
+        #'(lambda (x) (make-list-type (random 10) 'null 'integer))
+        '(eql :key)
+        `(member 1+ ,#'1+))
+  4
+  :test #'same-set-p)
+(def-type-prop-test intersection.4 'intersection
+  (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null)))
+        #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null)))
+        '(eql :key)
+        `(member car ,#'car))
+  4
+  :test #'(lambda (x y) (same-set-p x y :key #'car)))
+(def-type-prop-test intersection.5 'intersection
+  (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null)))
+        #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null)))
+        '(eql :test)
+        `(member equal ,#'equal))
+  4
+  :test #'(lambda (x y) (same-set-p x y :key #'car)))
+
+(def-type-prop-test nintersection.1 'nintersection '(list list) 2 :test #'same-set-p :replicate '(t t))
+(def-type-prop-test nintersection.2 'nintersection '(list list (eql :key) (eql identity))  4 :test #'same-set-p :replicate '(t t nil nil))
+(def-type-prop-test nintersection.3 'nintersection
+  (list #'(lambda () (make-list-type (random 10) 'null 'integer))
+        #'(lambda (x) (make-list-type (random 10) 'null 'integer))
+        '(eql :key)
+        `(member 1+ ,#'1+))
+  4
+  :test #'same-set-p
+  :replicate '(t t nil nil))
+(def-type-prop-test nintersection.4 'nintersection
+  (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null)))
+        #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null)))
+        '(eql :key)
+        `(member car ,#'car))
+  4
+  :test #'(lambda (x y) (same-set-p x y :key #'car))
+  :replicate '(t t nil nil))
+(def-type-prop-test nintersection.5 'nintersection
+  (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null)))
+        #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null)))
+        '(eql :test)
+        `(member equal ,#'equal))
+  4
+  :test #'(lambda (x y) (same-set-p x y :key #'car))
+  :replicate '(t t nil nil))
+
+
+(def-type-prop-test adjoin.1 'adjoin '(t list) 2)
+(def-type-prop-test adjoin.2 'adjoin '((integer 0 1) list) 2)
+(def-type-prop-test adjoin.3 'adjoin `((integer 0 10) (cons number (cons number (cons number null)))
+                                       (eql :test) (or (eql =) (eql ,#'=)))
+  4)
+(def-type-prop-test adjoin.4 'adjoin `(number
+                                       (cons number (cons number (cons number (cons number null))))
+                                       (eql :test-not) (or (eql /=) (eql ,#'/=)))
+  4)
+(def-type-prop-test adjoin.5 'adjoin `(number
+                                       (cons number (cons number (cons number (cons number null))))
+                                       (eql :key) (or (member 1+ 1- ,#'1+ ,#'1-)))
+  4)
+
+(def-type-prop-test pushnew.1 '(lambda (x y) (list (pushnew x y) y)) '(t list) 2)
+(def-type-prop-test pushnew.2 '(lambda (x y) (list (pushnew x y) y)) '((integer 0 1) list) 2)
+(def-type-prop-test pushnew.3 '(lambda (x y) (list (pushnew x y :test #'=) y))
+  `((integer 0 10) (cons number (cons number (cons number null))))
+  2)
+(def-type-prop-test pushnew.4 '(lambda (x y) (list (pushnew x y :test-not #'/=) y))
+  `((integer 0 10) (cons number (cons number (cons number null))))
+  2)
+(def-type-prop-test pushnew.5 '(lambda (x y) (list (pushnew x y :key #'1+) y))
+  `(number (cons number (cons number (cons number (cons number null)))))
+  2)
+
+(def-type-prop-test set-difference.1 'set-difference '(list list) 2)
+(def-type-prop-test set-difference.2 'set-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))))
+  2)
+(def-type-prop-test set-difference.3 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test) (member = ,#'=))
+  4)
+(def-type-prop-test set-difference.4 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test-not) (member /= ,#'/=))
+  4)
+(def-type-prop-test set-difference.5 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (eql :key) (member evenp oddp ,#'evenp ,#'oddp))
+  4)
+
+(def-type-prop-test nset-difference.1 'nset-difference '(list list) 2 :replicate '(t t))
+(def-type-prop-test nset-difference.2 'nset-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))))
+  2 :replicate '(t t))
+(def-type-prop-test nset-difference.3 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test) (member = ,#'=))
+  4 :replicate '(t t nil nil))
+(def-type-prop-test nset-difference.4 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test-not) (member /= ,#'/=))
+  4 :replicate '(t t nil nil))
+(def-type-prop-test nset-difference.5 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (eql :key) (member evenp oddp ,#'evenp ,#'oddp))
+  4 :replicate '(t t nil nil))
+
+
+(def-type-prop-test set-exclusive-or.1 'set-exclusive-or '(list list) 2)
+(def-type-prop-test set-exclusive-or.2 'set-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))))
+  2)
+(def-type-prop-test set-exclusive-or.3 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test) (member = ,#'=))
+  4)
+(def-type-prop-test set-exclusive-or.4 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test-not) (member /= ,#'/=))
+  4)
+(def-type-prop-test set-exclusive-or.5 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (eql :key) (member evenp oddp ,#'evenp ,#'oddp))
+  4)
+
+(def-type-prop-test nset-exclusive-or.1 'nset-exclusive-or '(list list) 2 :replicate '(t t))
+(def-type-prop-test nset-exclusive-or.2 'nset-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))))
+  2 :replicate '(t t))
+(def-type-prop-test nset-exclusive-or.3 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test) (member = ,#'=))
+  4 :replicate '(t t nil nil))
+(def-type-prop-test nset-exclusive-or.4 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
+                                                       (eql :test-not) (member /= ,#'/=))
+  4 :replicate '(t t nil nil))
+(def-type-prop-test nset-exclusive-or.5 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
+                                                       (eql :key) (member evenp oddp ,#'evenp ,#'oddp))
+  4 :replicate '(t t nil nil))
+
+(def-type-prop-test subsetp.1 'subsetp '(list list) 2)
+(def-type-prop-test subsetp.2 'subsetp '((cons integer null)
+                                         (cons integer (cons integer (cons integer (cons integer null)))))
+  2)
diff --git a/random/random-type-prop-tests-06.lsp b/random/random-type-prop-tests-06.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..b90f9d05fc4b831e9eafd114e32049fc5b079f3f
--- /dev/null
+++ b/random/random-type-prop-tests-06.lsp
@@ -0,0 +1,146 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Mar 13 15:33:55 2005
+;;;; Contains: Random type prop tests, part 6 (arrays)
+
+(in-package :cl-test)
+
+(def-type-prop-test adjustable-array-p 'adjustable-array-p '(array) 1)
+
+(def-type-prop-test aref.0 'aref '((array * nil)) 1)
+(def-type-prop-test aref.1 'aref (list '(array * (*)) (index-type-for-dim 0)) 2)
+(def-type-prop-test aref.2 'aref (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
+(def-type-prop-test aref.3 'aref (list '(array * (* * *))
+                                       (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
+  4)
+
+(def-type-prop-test array-dimension 'array-dimension
+  (list 'array #'(lambda (x) (let ((r (array-rank x))) (and (> r 0) `(integer 0 (,r))))))
+  2)
+(def-type-prop-test array-dimensions 'array-dimensions '(array) 1)
+(def-type-prop-test array-element-type 'array-element-type '(array) 1)
+(def-type-prop-test array-has-fill-pointer-p.1 'array-has-fill-pointer-p '(array) 1)
+(def-type-prop-test array-has-fill-pointer-p.2 'array-has-fill-pointer-p '(vector) 1)
+(def-type-prop-test array-displacement.1 'array-displacement '(array) 1)
+(def-type-prop-test array-displacement.2 'array-displacement '(vector) 1)
+
+(def-type-prop-test array-in-bounds-p.0 'array-in-bounds-p '((array * nil)) 1)
+(def-type-prop-test array-in-bounds-p.1 'array-in-bounds-p (list '(array * (*)) (index-type-for-dim 0)) 2)
+(def-type-prop-test array-in-bounds-p.2 'array-in-bounds-p
+  (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
+(def-type-prop-test array-in-bounds-p.3 'array-in-bounds-p
+  (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
+  4)
+(def-type-prop-test array-in-bounds-p.4 'array-in-bounds-p '((array * (*)) integer) 2)
+(def-type-prop-test array-in-bounds-p.5 'array-in-bounds-p '((array * (* *)) integer integer) 3)
+(def-type-prop-test array-in-bounds-p.6 'array-in-bounds-p '((array * (* * *)) integer integer integer) 4)
+(def-type-prop-test array-rank 'array-rank '(array) 1)
+
+(def-type-prop-test array-row-major-index.0 'array-row-major-index '((array * nil)) 1)
+(def-type-prop-test array-row-major-index.1 'array-row-major-index (list '(array * (*)) (index-type-for-dim 0)) 2)
+(def-type-prop-test array-row-major-index.2 'array-row-major-index
+  (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
+(def-type-prop-test array-row-major-index.3 'array-row-major-index
+  (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
+  4)
+(def-type-prop-test array-total-size 'array-total-size '(array) 1)
+
+(def-type-prop-test arrayp 'arrayp '(t) 1)
+
+(def-type-prop-test fill-pointer '(lambda (x) (and (array-has-fill-pointer-p x) (fill-pointer x))) '(vector) 1)
+
+(def-type-prop-test row-major-aref 'row-major-aref
+  (list 'array #'(lambda (a) (let ((s (array-total-size a))) (and (> s 0) `(integer 0 (,s))))))
+  2)
+
+(def-type-prop-test upgraded-array-element-type 'upgraded-array-element-type
+  (list #'(lambda () (let ((x (make-random-element-of-type t)))
+                       `(eql ,(make-random-type-containing x)))))
+  1)
+
+(def-type-prop-test simple-vector-p.1 'simple-vector-p '(t) 1)
+(def-type-prop-test simple-vector-p.2 'simple-vector-p '(vector) 1)
+
+(def-type-prop-test svref 'svref (list 'simple-vector (index-type-for-dim 0)) 2)
+(def-type-prop-test vector 'vector nil 1 :rest-type t :maxargs 10)
+(def-type-prop-test vectorp.1 'vectorp '(t) 1)
+(def-type-prop-test vectorp.2 'vectorp '(array) 1)
+
+(def-type-prop-test bit.1 'bit (list '(array bit (*)) (index-type-for-dim 0)) 2)
+(def-type-prop-test bit.2 'bit (list '(array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
+(def-type-prop-test bit.3 'bit
+  (list '(array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
+  4)
+
+(def-type-prop-test sbit.1 'sbit (list '(simple-array bit (*)) (index-type-for-dim 0)) 2)
+(def-type-prop-test sbit.2 'sbit (list '(simple-array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
+(def-type-prop-test sbit.3 'sbit
+  (list '(simple-array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
+  4)
+
+
+(def-type-prop-test bit-and.1 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-and.2 'bit-and
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-andc1.1 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-andc1.2 'bit-andc1
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-andc2.1 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-andc2.2 'bit-andc2
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-ior.1 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-ior.2 'bit-ior
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-orc1.1 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-orc1.2 'bit-orc1
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-orc2.1 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-orc2.2 'bit-orc2
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-eqv.1 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-eqv.2 'bit-eqv
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-xor.1 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-xor.2 'bit-xor
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-nand.1 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-nand.2 'bit-nand
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-nor.1 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
+                                                                          `(array bit ,dims))))
+  2)
+(def-type-prop-test bit-nor.2 'bit-nor
+  (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
+  3)
+(def-type-prop-test bit-not.1 'bit-not '((array bit)) 1)
+(def-type-prop-test bit-not.2 'bit-not '((array bit) null) 2)
+
+(def-type-prop-test bit-vector-p 'bit-vector-p '(t) 1)
+(def-type-prop-test simple-bit-vector-p 'simple-bit-vector-p '(t) 1)
diff --git a/random/random-type-prop-tests-07.lsp b/random/random-type-prop-tests-07.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..efe6f59b1e92cf91e2f91d854e8f0a436e6e9756
--- /dev/null
+++ b/random/random-type-prop-tests-07.lsp
@@ -0,0 +1,121 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Mar 13 17:03:52 2005
+;;;; Contains: Random type prop tests, part 7 (strings)
+
+(in-package :cl-test)
+
+(def-type-prop-test simple-string-p 'simple-string-p '(t) 1)
+(def-type-prop-test char 'char (list 'string (index-type-for-dim 0)) 2)
+(def-type-prop-test schar 'schar (list 'simple-string (index-type-for-dim 0)) 2)
+
+(def-type-prop-test string 'string '((or string symbol character)) 1)
+(def-type-prop-test string-upcase 'string-upcase '(string) 1)
+(def-type-prop-test string-downcase 'string-downcase '(string) 1)
+(def-type-prop-test string-capitalize 'string-capitalize '(string) 1)
+
+(def-type-prop-test string-trim.1 'string-trim '(string string) 2)
+(def-type-prop-test string-trim.2 'string-trim (list #'(lambda () (make-list-type (random 10) 'null 'character))
+                                                     'string)
+  2)
+(def-type-prop-test string-left-trim.1 'string-left-trim '(string string) 2)
+(def-type-prop-test string-left-trim.2 'string-left-trim (list #'(lambda () (make-list-type (random 10) 'null 'character))
+                                                               'string)
+  2)
+(def-type-prop-test string-right-trim.1 'string-right-trim '(string string) 2)
+(def-type-prop-test string-right-trim.2 'string-right-trim
+  (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string)
+  2)
+
+(defmacro def-string-comparison-type-prop-test (op)
+  (flet ((%makename (n) (intern (format nil "~A.~A" op n) :cl-test)))
+    `(progn
+       (def-type-prop-test ,(%makename 1) ',op '(string string) 2)
+       (def-type-prop-test ,(%makename 2) ',op
+         `(string string (eql :start1) ,#'index-type-for-v1)
+         4)
+       (def-type-prop-test ,(%makename 3) ',op
+         `(string string (eql :start2) ,#'index-type-for-v2)
+         4)
+       (def-type-prop-test ,(%makename 4) ',op
+         `(string string (eql :end1) ,#'end-type-for-v1)
+         4)
+       (def-type-prop-test ,(%makename 5) ',op
+         `(string string (eql :end2) ,#'end-type-for-v2)
+         4)
+       (def-type-prop-test ,(%makename 6) ',op
+         `(string string
+                  (eql :start1) ,#'index-type-for-v1
+                  (eql :end1) ,#'end-type-for-v1)
+         6)
+       (def-type-prop-test ,(%makename 7) ',op
+         `(string string
+                  (eql :start1) ,#'index-type-for-v1
+                  (eql :end2) ,#'end-type-for-v2)
+         6)
+       (def-type-prop-test ,(%makename 8) ',op
+         `(string string
+                  (eql :start2) ,#'index-type-for-v2
+                  (eql :end1) ,#'end-type-for-v1)
+         6)
+       (def-type-prop-test ,(%makename 9) ',op
+         `(string string
+                  (eql :start2) ,#'index-type-for-v2
+                  (eql :end2) ,#'end-type-for-v2)
+         6)
+       (def-type-prop-test ,(%makename 10) ',op
+         `(string string
+                  (eql :start1) ,#'index-type-for-v1
+                  (eql :start2) ,#'index-type-for-v2
+                  (eql :end1) ,#'end-type-for-v1)
+         8)
+       (def-type-prop-test ,(%makename 11) ',op
+         `(string string
+                  (eql :start1) ,#'index-type-for-v1
+                  (eql :start2) ,#'index-type-for-v2
+                  (eql :end2) ,#'end-type-for-v2)
+         8)
+       (def-type-prop-test ,(%makename 12) ',op
+         `(string string
+                  (eql :start1) ,#'index-type-for-v1
+                  (eql :end2) ,#'end-type-for-v2
+                  (eql :end1) ,#'end-type-for-v1)
+         8)
+       (def-type-prop-test ,(%makename 13) ',op
+         `(string string
+                  (eql :start2) ,#'index-type-for-v2
+                  (eql :end2) ,#'end-type-for-v2
+                  (eql :end1) ,#'end-type-for-v1)
+         8)
+       (def-type-prop-test ,(%makename 14) ',op
+         `(string string
+                  (eql :start1) ,#'index-type-for-v1
+                  (eql :start2) ,#'index-type-for-v2
+                  (eql :end2) ,#'end-type-for-v2
+                  (eql :end1) ,#'end-type-for-v1)
+         10)
+       )))
+
+(def-string-comparison-type-prop-test string=)
+(def-string-comparison-type-prop-test string/=)
+(def-string-comparison-type-prop-test string<)
+(def-string-comparison-type-prop-test string<=)
+(def-string-comparison-type-prop-test string>)
+(def-string-comparison-type-prop-test string>=)
+
+(def-string-comparison-type-prop-test string-equal)
+(def-string-comparison-type-prop-test string-not-equal)
+(def-string-comparison-type-prop-test string-lessp)
+(def-string-comparison-type-prop-test string-greaterp)
+(def-string-comparison-type-prop-test string-not-lessp)
+(def-string-comparison-type-prop-test string-not-greaterp)
+
+(def-type-prop-test stringp 'stringp '(t) 1)
+
+(def-type-prop-test make-string.1 'make-string '((integer 0 100) (eql :initial-element) character) 3)
+(def-type-prop-test make-string.2 'make-string `((integer 0 100) (eql :initial-element) character
+                                                 (eql :element-type)
+                                                 ,#'(lambda (&rest args)
+                                                      `(eql (and character
+                                                                 ,(make-random-type-containing (third args))))))
+  5)
diff --git a/random/random-type-prop-tests-08.lsp b/random/random-type-prop-tests-08.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..9f8c938cd7fbc40bc17f6bb70515fa3d973e6bdc
--- /dev/null
+++ b/random/random-type-prop-tests-08.lsp
@@ -0,0 +1,348 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Mar 13 18:31:57 2005
+;;;; Contains: Random type prop tests, part 8 (sequences)
+
+(in-package :cl-test)
+
+(def-type-prop-test copy-seq 'copy-seq '((or vector list)) 1)
+
+(def-type-prop-test elt 'elt (list '(or vector list)
+                                   #'(lambda (x) (let ((len (length x)))
+                                                   (and (> len 0) `(integer 0 (,len))))))
+  2)
+
+(defmacro rfill (x y &rest other-args)
+  `(fill ,y ,x ,@other-args))
+
+(def-type-prop-test fill.1 'rfill
+  (list t #'make-random-sequence-type-containing)
+  2 :replicate '(nil t))
+
+(def-type-prop-test fill.2 'rfill
+  (list 'integer #'make-random-sequence-type-containing)
+  2 :replicate '(nil t))
+
+(def-type-prop-test fill.3 'rfill
+  (list 'character #'make-random-sequence-type-containing)
+  2 :replicate '(nil t))
+
+(def-type-prop-test fill.4 'rfill
+  (list t #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len))))
+  4 :replicate '(nil t nil nil))
+
+(def-type-prop-test fill.5 'rfill
+  (list t #'make-random-sequence-type-containing
+        '(eql :end)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len))))
+  4 :replicate '(nil t nil nil))
+
+(def-type-prop-test fill.6 'rfill
+  (list t #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len)))
+        '(eql :end)
+        #'(lambda (v s k1 start k2)
+            (declare (ignore v k1 k2))
+            (let ((len (length s)))
+              `(integer ,start ,len))))
+  6 :replicate '(nil t nil nil nil nil))
+
+;;; make-sequence tests here
+
+(def-type-prop-test subseq.1 'subseq
+  (list 'sequence #'(lambda (s) `(integer 0 ,(length s))))
+  2)
+
+(def-type-prop-test subseq.2 'subseq
+  (list 'sequence #'(lambda (s) `(integer 0 ,(length s)))
+        #'(lambda (s start) `(integer ,start ,(length s))))
+  3)
+
+;;; map tests here
+
+(def-type-prop-test map.1 'map
+  (list '(member list vector)
+        '(member list #.#'list)
+        '(or list vector))
+  3)
+
+(def-type-prop-test map.2 'map
+  (list '(member list vector)
+        '(member list #.#'list)
+        '(or list vector)
+        '(or list vector))
+  4)
+
+(def-type-prop-test map.3 'map
+  (list '(member list vector)
+        '(member list #.#'list)
+        '(or list vector)
+        '(or list vector)
+        '(or list vector))
+  5)
+
+(def-type-prop-test map.4 'map
+  (list '(member list vector (vector (unsigned-byte 32)))
+        '(member 1+ #.#'1+)
+        `(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i)))))
+  3)
+
+(def-type-prop-test map.5 'map
+  (list `(member ,@(loop for i from 1 to 32 collect `(vector (unsigned-byte ,i))))
+        '(member 1+ #.#'1+)
+        #'(lambda (type fun)
+            (declare (ignore fun))
+            (let ((i (cadadr type)))
+              `(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2))))))))
+  3)
+
+
+
+;;; map-into tests here
+
+(def-type-prop-test map-into.1 'map-into
+  (list '(or list (vector t))
+        '(member list #.#'list)
+        '(or list vector))
+  3 :replicate '(t nil nil))
+
+(def-type-prop-test map-into.2 'map-into
+  (list '(or list (vector t))
+        '(member list #.#'list)
+        '(or list vector)
+        '(or list vector))
+  4 :replicate '(t nil nil nil))
+
+;;; reduce tests here
+
+(def-type-prop-test count.1 'count '(t sequence) 2)
+(def-type-prop-test count.2 'count
+  (list t #'make-random-sequence-type-containing)
+  2)
+(def-type-prop-test count.3 'count
+  (list t #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (x s k1) (declare (ignore x k1))
+            `(integer 0 ,(length s))))
+  4)
+(def-type-prop-test count.4 'count
+  (list t #'make-random-sequence-type-containing
+        '(eql :end)
+        #'(lambda (x s k1) (declare (ignore x k1))
+            `(integer 0 ,(length s))))
+  4)
+(def-type-prop-test count.5 'count
+  (list t #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (x s k1) (declare (ignore x k1))
+            `(integer 0 ,(length s)))
+        '(eql :end)
+        #'(lambda (x s k1 start k2) (declare (ignore x k1 k2))
+            `(integer ,start ,(length s))))
+  6)
+
+(def-type-prop-test count.6 'count
+  (list '(or short-float single-float double-float long-float)
+        #'(lambda (f) `(vector (or ,(typecase f
+                                      (short-float 'short-float)
+                                      (single-float 'single-float)
+                                      (double-float 'double-float)
+                                      (long-float 'long-float)
+                                      (t 'float))
+                                   (eql ,f)))))
+  2)
+
+(def-type-prop-test count.7 'count '(bit (vector bit)) 2)
+(def-type-prop-test count.8 'count '((unsigned-byte 2) (vector (unsigned-byte 2))) 2)
+(def-type-prop-test count.9 'count '((unsigned-byte 4) (vector (unsigned-byte 4))) 2)
+(def-type-prop-test count.10 'count '((unsigned-byte 8) (vector (unsigned-byte 8))) 2)
+
+
+;;; count-if tests
+
+(def-type-prop-test count-if.1 'count-if
+  (list (let ((funs '(numberp rationalp realp floatp complexp
+                      symbolp identity null functionp listp consp
+                      arrayp vectorp simple-vector-p
+                      stringp simple-string-p
+                      bit-vector-p simple-bit-vector-p)))
+          `(member ,@funs ,@(mapcar #'symbol-function funs)))
+        '(or list vector))
+  2)
+
+(def-type-prop-test count-if.2 'count-if
+  (list (let ((funs '(numberp rationalp realp floatp complexp
+                      symbolp identity null functionp listp consp
+                      arrayp vectorp simple-vector-p
+                      stringp simple-string-p
+                      bit-vector-p simple-bit-vector-p)))
+          `(member ,@funs ,@(mapcar #'symbol-function funs)))
+        '(or list vector)
+        '(eql :key)
+        (let ((key-funs '(identity not null)))
+          `(member ,@key-funs ,@(mapcar #'symbol-function key-funs))))
+  4)
+
+
+;;; Put count-if-not tests here
+
+
+(def-type-prop-test length.1 'length '(sequence) 1)
+
+(def-type-prop-test reverse.1 'reverse '(sequence) 1)
+(def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t))
+
+(def-type-prop-test sort.1 'sort
+  `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2
+  :replicate '(t nil))
+
+(def-type-prop-test sort.2 'sort
+  `((or (vector (unsigned-byte 2))
+        (vector (unsigned-byte 3))
+        (vector (unsigned-byte 4))
+        (vector (unsigned-byte 5))
+        (vector (unsigned-byte 6))
+        (vector (unsigned-byte 7))
+        (vector (unsigned-byte 8)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test sort.3 'sort
+  `((or (vector (unsigned-byte 10))
+        (vector (unsigned-byte 13))
+        (vector (unsigned-byte 15))
+        (vector (unsigned-byte 16)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test sort.4 'sort
+  `((or (vector (unsigned-byte 20))
+        (vector (unsigned-byte 24))
+        (vector (unsigned-byte 28))
+        (vector (unsigned-byte 31))
+        (vector (unsigned-byte 32)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test sort.5 'sort
+  `((or (vector (signed-byte 2))
+        (vector (signed-byte 3))
+        (vector (signed-byte 4))
+        (vector (signed-byte 5))
+        (vector (signed-byte 6))
+        (vector (signed-byte 7))
+        (vector (signed-byte 8)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test sort.6 'sort
+  `((or (vector (signed-byte 10))
+        (vector (signed-byte 13))
+        (vector (signed-byte 15))
+        (vector (signed-byte 16)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test sort.7 'sort
+  `((or (vector (signed-byte 20))
+        (vector (signed-byte 24))
+        (vector (signed-byte 28))
+        (vector (signed-byte 31))
+        (vector (signed-byte 32)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test sort.8 'sort
+  `((or (vector short-float)
+        (vector single-float)
+        (vector double-float)
+        (vector long-float))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+;;; Stable sort
+
+(def-type-prop-test stable-sort.1 'stable-sort
+  `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2
+  :replicate '(t nil))
+
+(def-type-prop-test stable-sort.2 'stable-sort
+  `((or (vector (unsigned-byte 2))
+        (vector (unsigned-byte 3))
+        (vector (unsigned-byte 4))
+        (vector (unsigned-byte 5))
+        (vector (unsigned-byte 6))
+        (vector (unsigned-byte 7))
+        (vector (unsigned-byte 8)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test stable-sort.3 'stable-sort
+  `((or (vector (unsigned-byte 10))
+        (vector (unsigned-byte 13))
+        (vector (unsigned-byte 15))
+        (vector (unsigned-byte 16)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test stable-sort.4 'stable-sort
+  `((or (vector (unsigned-byte 20))
+        (vector (unsigned-byte 24))
+        (vector (unsigned-byte 28))
+        (vector (unsigned-byte 31))
+        (vector (unsigned-byte 32)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test stable-sort.5 'stable-sort
+  `((or (vector (signed-byte 2))
+        (vector (signed-byte 3))
+        (vector (signed-byte 4))
+        (vector (signed-byte 5))
+        (vector (signed-byte 6))
+        (vector (signed-byte 7))
+        (vector (signed-byte 8)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test stable-sort.6 'stable-sort
+  `((or (vector (signed-byte 10))
+        (vector (signed-byte 13))
+        (vector (signed-byte 15))
+        (vector (signed-byte 16)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test stable-sort.7 'stable-sort
+  `((or (vector (signed-byte 20))
+        (vector (signed-byte 24))
+        (vector (signed-byte 28))
+        (vector (signed-byte 31))
+        (vector (signed-byte 32)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test stable-sort.8 'stable-sort
+  `((or (vector short-float)
+        (vector single-float)
+        (vector double-float)
+        (vector long-float))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
+  2 :replicate '(t nil))
+
+(def-type-prop-test stable-sort.9 'stable-sort
+  `((vector (cons (integer 0 4) (eql nil)))
+    (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)
+    (eql :key)
+    (member car ,#'car))
+  4 :replicate '(t nil nil nil)
+  :test #'equalp-and-eql-elements)
diff --git a/random/random-type-prop-tests-09.lsp b/random/random-type-prop-tests-09.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..46270c318e133c091ca73a0ece40c94eebb6df36
--- /dev/null
+++ b/random/random-type-prop-tests-09.lsp
@@ -0,0 +1,717 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Contains: Random type prop tests, part 9 (sequences)
+
+(in-package :cl-test)
+
+;;; FIND
+
+(def-type-prop-test find.1 'find
+  (list t #'make-random-sequence-type-containing)
+  2)
+
+(def-type-prop-test find.2 'find
+  (list 'integer #'make-random-sequence-type-containing)
+  2)
+
+(def-type-prop-test find.3 'find
+  (list 'character #'make-random-sequence-type-containing)
+  2)
+
+(def-type-prop-test find.4 'find
+  (list t
+        #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test find.5 'find
+  (list t
+        #'make-random-sequence-type-containing
+        '(eql :end)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test find.6 'find
+  (list t #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len)))
+        '(eql :end)
+        #'(lambda (v s k1 start k2)
+            (declare (ignore v k1 k2))
+            (let ((len (length s)))
+              `(integer ,start ,len))))
+  6)
+
+(def-type-prop-test find.7 'find
+  (list 'integer #'(lambda (x) (declare (ignore x))
+                     (make-sequence-type
+                      (random 10)
+                      (random-from-seq #(bit integer float rational real number))))
+        '(eql :key)
+        '(member 1+ #.#'1+ 1- #.#'1- - #.#'-))
+  4)
+
+(def-type-prop-test find.8 'find
+  (list 'character
+        #'(lambda (x) (declare (ignore x))
+            (make-sequence-type
+             (random 10)
+             (random-from-seq #(character base-char standard-char))))
+        '(eql :key)
+        '(member char-upcase #.#'char-upcase
+                 char-downcase #.#'char-downcase
+                 upper-case-p #.#'upper-case-p
+                 lower-case-p #.#'lower-case-p
+                 both-case-p #.#'both-case-p
+                 char-code #.#'char-code
+                 char-int #.#'char-int
+                 alpha-char-p #.#'alpha-char-p
+                 digit-char-p #.#'digit-char-p
+                 alphanumericp #.#'alphanumericp))
+  4)
+
+(def-type-prop-test find.9 'find
+  (list t #'make-random-sequence-type-containing
+        '(eql :from-end)
+        '(or null t))
+  4)
+
+(def-type-prop-test find.10 'find
+  (list 'real #'(lambda (x) (make-sequence-type
+                             (random 10)
+                             (random-from-seq #(bit integer float rational real))))
+        '(eql :from-end)
+        '(or null t)
+        '(member :test :test-not)
+        (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/=
+              'equal #'equal 'eql #'eql))
+  6)
+
+;;; FIND-IF
+
+(def-type-prop-test find-if.1 'find-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence)
+  2)
+
+(def-type-prop-test find-if.2 'find-if
+  (list
+   (let ((char-predicates
+          '(alpha-char-p digit-char-p upper-case-p lower-case-p
+            both-case-p alphanumericp graphic-char-p
+            standard-char-p)))
+     (append '(member) char-predicates
+             (mapcar #'symbol-function char-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           '(or standard-char base-char character))))
+  2)
+
+(def-type-prop-test find-if.3 'find-if
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x))))))
+  2)
+
+(def-type-prop-test find-if.4 'find-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test find-if.5 'find-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test find-if.6 'find-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :end)
+   #'(lambda (f s k1 start k2)
+       (declare (ignore f k1 k2))
+       (let ((len (length s)))
+         `(integer ,start ,len))))
+  6)
+
+(def-type-prop-test find-if.7 'find-if
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :key)
+   (list 'member '1+ '1- 'identity '-
+         #'1+ #'1- #'identity #'-))
+  4)
+
+(def-type-prop-test find-if.8 'find-if
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :from-end)
+   '(or null t))
+  4)
+
+(def-type-prop-test find-if.9 'find-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
+
+(def-type-prop-test find-if.10 'find-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
+
+;;; FIND-IF-NOT
+
+(def-type-prop-test find-if-not.1 'find-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence)
+  2)
+
+(def-type-prop-test find-if-not.2 'find-if-not
+  (list
+   (let ((char-predicates
+          '(alpha-char-p digit-char-p upper-case-p lower-case-p
+            both-case-p alphanumericp graphic-char-p
+            standard-char-p)))
+     (append '(member) char-predicates
+             (mapcar #'symbol-function char-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           '(or standard-char base-char character))))
+  2)
+
+(def-type-prop-test find-if-not.3 'find-if-not
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x))))))
+  2)
+
+(def-type-prop-test find-if-not.4 'find-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test find-if-not.5 'find-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test find-if-not.6 'find-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :end)
+   #'(lambda (f s k1 start k2)
+       (declare (ignore f k1 k2))
+       (let ((len (length s)))
+         `(integer ,start ,len))))
+  6)
+
+(def-type-prop-test find-if-not.7 'find-if-not
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :key)
+   (list 'member '1+ '1- 'identity '-
+         #'1+ #'1- #'identity #'-))
+  4)
+
+(def-type-prop-test find-if-not.8 'find-if-not
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :from-end)
+   '(or null t))
+  4)
+
+(def-type-prop-test find-if-not.9 'find-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
+
+(def-type-prop-test find-if-not.10 'find-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
+
+;;; POSITION
+
+(def-type-prop-test position.1 'position
+  (list t #'make-random-sequence-type-containing)
+  2)
+
+(def-type-prop-test position.2 'position
+  (list 'integer #'make-random-sequence-type-containing)
+  2)
+
+(def-type-prop-test position.3 'position
+  (list 'character #'make-random-sequence-type-containing)
+  2)
+
+(def-type-prop-test position.4 'position
+  (list t
+        #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test position.5 'position
+  (list t
+        #'make-random-sequence-type-containing
+        '(eql :end)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test position.6 'position
+  (list t #'make-random-sequence-type-containing
+        '(eql :start)
+        #'(lambda (v s k1) (declare (ignore v k1))
+            (let ((len (length s)))
+              `(integer 0 ,len)))
+        '(eql :end)
+        #'(lambda (v s k1 start k2)
+            (declare (ignore v k1 k2))
+            (let ((len (length s)))
+              `(integer ,start ,len))))
+  6)
+
+(def-type-prop-test position.7 'position
+  (list 'integer #'(lambda (x) (declare (ignore x))
+                     (make-sequence-type
+                      (random 10)
+                      (random-from-seq #(bit integer float rational real number))))
+        '(eql :key)
+        '(member 1+ #.#'1+ 1- #.#'1- - #.#'-))
+  4)
+
+(def-type-prop-test position.8 'position
+  (list 'character
+        #'(lambda (x) (declare (ignore x))
+            (make-sequence-type
+             (random 10)
+             (random-from-seq #(character base-char standard-char))))
+        '(eql :key)
+        '(member char-upcase #.#'char-upcase
+                 char-downcase #.#'char-downcase
+                 upper-case-p #.#'upper-case-p
+                 lower-case-p #.#'lower-case-p
+                 both-case-p #.#'both-case-p
+                 char-code #.#'char-code
+                 char-int #.#'char-int
+                 alpha-char-p #.#'alpha-char-p
+                 digit-char-p #.#'digit-char-p
+                 alphanumericp #.#'alphanumericp))
+  4)
+
+(def-type-prop-test position.9 'position
+  (list t #'make-random-sequence-type-containing
+        '(eql :from-end)
+        '(or null t))
+  4)
+
+(def-type-prop-test position.10 'position
+  (list 'real #'(lambda (x) (make-sequence-type
+                             (random 10)
+                             (random-from-seq #(bit integer float rational real))))
+        '(eql :from-end)
+        '(or null t)
+        '(member :test :test-not)
+        (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/=
+              'equal #'equal 'eql #'eql))
+  6)
+
+;;; POSITION-IF
+
+(def-type-prop-test position-if.1 'position-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence)
+  2)
+
+(def-type-prop-test position-if.2 'position-if
+  (list
+   (let ((char-predicates
+          '(alpha-char-p digit-char-p upper-case-p lower-case-p
+            both-case-p alphanumericp graphic-char-p
+            standard-char-p)))
+     (append '(member) char-predicates
+             (mapcar #'symbol-function char-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           '(or standard-char base-char character))))
+  2)
+
+(def-type-prop-test position-if.3 'position-if
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x))))))
+  2)
+
+(def-type-prop-test position-if.4 'position-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test position-if.5 'position-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test position-if.6 'position-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :end)
+   #'(lambda (f s k1 start k2)
+       (declare (ignore f k1 k2))
+       (let ((len (length s)))
+         `(integer ,start ,len))))
+  6)
+
+(def-type-prop-test position-if.7 'position-if
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :key)
+   (list 'member '1+ '1- 'identity '-
+         #'1+ #'1- #'identity #'-))
+  4)
+
+(def-type-prop-test position-if.8 'position-if
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :from-end)
+   '(or null t))
+  4)
+
+(def-type-prop-test position-if.9 'position-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
+
+(def-type-prop-test position-if.10 'position-if
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
+
+;;; POSITION-IF-NOT
+
+(def-type-prop-test position-if-not.1 'position-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence)
+  2)
+
+(def-type-prop-test position-if-not.2 'position-if-not
+  (list
+   (let ((char-predicates
+          '(alpha-char-p digit-char-p upper-case-p lower-case-p
+            both-case-p alphanumericp graphic-char-p
+            standard-char-p)))
+     (append '(member) char-predicates
+             (mapcar #'symbol-function char-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           '(or standard-char base-char character))))
+  2)
+
+(def-type-prop-test position-if-not.3 'position-if-not
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x))))))
+  2)
+
+(def-type-prop-test position-if-not.4 'position-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test position-if-not.5 'position-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test position-if-not.6 'position-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :end)
+   #'(lambda (f s k1 start k2)
+       (declare (ignore f k1 k2))
+       (let ((len (length s)))
+         `(integer ,start ,len))))
+  6)
+
+(def-type-prop-test position-if-not.7 'position-if-not
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :key)
+   (list 'member '1+ '1- 'identity '-
+         #'1+ #'1- #'identity #'-))
+  4)
+
+(def-type-prop-test position-if-not.8 'position-if-not
+  (list
+   (let ((integer-predicates '(zerop plusp minusp evenp oddp)))
+     (append '(member) integer-predicates
+             (mapcar #'symbol-function integer-predicates)))
+   #'(lambda (x) (declare (ignore x))
+       (make-sequence-type (random 10)
+                           `(or bit bit bit bit bit bit bit
+                                ,@(loop for x from 2 to 32
+                                        collect `(unsigned-byte ,x))
+                                ,@(loop for x from 2 to 32
+                                        collect `(signed-byte ,x)))))
+   '(eql :from-end)
+   '(or null t))
+  4)
+
+(def-type-prop-test position-if-not.9 'position-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :start)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
+
+(def-type-prop-test position-if-not.10 'position-if-not
+  (list
+   (append '(member) *cl-safe-predicates*
+           (mapcar 'symbol-function *cl-safe-predicates*))
+   'sequence
+   '(eql :end)
+   #'(lambda (f s k1) (declare (ignore f k1))
+       (let ((len (length s)))
+         `(integer 0 ,len)))
+   '(eql :from-end)
+   '(or null t))
+  6)
diff --git a/random/random-type-prop-tests-10.lsp b/random/random-type-prop-tests-10.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..71d23474ad7e02084b378c457ac2b8eb904b7f5e
--- /dev/null
+++ b/random/random-type-prop-tests-10.lsp
@@ -0,0 +1,114 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Contains: Random type prop tests, part 10 (sequences, cont.)
+
+(in-package :cl-test)
+
+;;; SEARCH
+
+(def-type-prop-test search.1 'search
+  (list 'sequence 'sequence)
+  2)
+
+(def-type-prop-test search.2 'search
+  (list 'bit-vector 'bit-vector)
+  2)
+
+(def-type-prop-test search.3 'search
+  (list '(vector * 1) 'sequence)
+  2)
+
+(def-type-prop-test search.4 'search
+  (list '(vector * 2) 'sequence '(eql :from-end) '(or null t))
+  4)
+
+(def-type-prop-test search.5 'search
+  (list 'sequence 'sequence '(eql :key)
+        (list 'member 'identity nil #'identity 'not #'not))
+  4)
+
+(def-type-prop-test search.6 'search
+  (list #'(lambda () (make-sequence-type
+                      (random 10)
+                      (let ((i1 (make-random-integer))
+                            (i2 (make-random-integer)))
+                        `(integer ,(min i1 i2) ,(max i1 i2)))))
+        #'(lambda (s)
+            (declare (ignore s))
+            (make-sequence-type
+             (random 10)
+             (let ((i1 (make-random-integer))
+                   (i2 (make-random-integer)))
+               `(integer ,(min i1 i2) ,(max i1 i2))))))
+  2)
+
+(def-type-prop-test search.7 'search
+  (list #'(lambda () (make-sequence-type
+                      (random 10)
+                      (let ((i1 (make-random-integer))
+                            (i2 (make-random-integer)))
+                        `(integer ,(min i1 i2) ,(max i1 i2)))))
+        #'(lambda (s)
+            (declare (ignore s))
+            (make-sequence-type
+             (random 10)
+             (let ((i1 (make-random-integer))
+                   (i2 (make-random-integer)))
+               `(integer ,(min i1 i2) ,(max i1 i2)))))
+        '(eql :test)
+        (list 'member 'eql #'eql 'equal #'equal '= #'=
+              '/= #'/= #'(lambda (x y) (= (logand x 1) (logand y 1)))))
+  4)
+
+(def-type-prop-test search.8 'search
+  (labels ((%random-char-type () (random-from-seq #(base-char standard-char character)))
+           (%random-char-sequence-type (&rest ignored)
+              (declare (ignore ignored))
+              (make-sequence-type (random 10) (%random-char-type))))
+
+          (list #'%random-char-sequence-type
+                #'%random-char-sequence-type
+                '(member :test :test-not)
+                (let ((char-compare-funs
+                       '(char= char/= char< char> char<= char>=
+                         char-equal char-not-equal char-lessp char-greaterp
+                         char-not-lessp char-not-greaterp)))
+                  `(member ,@char-compare-funs
+                           ,@(mapcar #'symbol-function char-compare-funs)))))
+  4)
+
+(def-type-prop-test search.9 'search
+  (list 'sequence 'sequence
+        '(eql :start1)
+        #'(lambda (s1 s2 k)
+            (declare (ignore s2 k))
+            (let ((len (length s1)))
+              `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test search.10 'search
+  (list 'sequence 'sequence
+        '(eql :end1)
+        #'(lambda (s1 s2 k)
+            (declare (ignore s2 k))
+            (let ((len (length s1)))
+              `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test search.11 'search
+  (list 'sequence 'sequence
+        '(eql :start2)
+        #'(lambda (s1 s2 k)
+            (declare (ignore s1 k))
+            (let ((len (length s2)))
+              `(integer 0 ,len))))
+  4)
+
+(def-type-prop-test search.12 'search
+  (list 'sequence 'sequence
+        '(eql :end2)
+        #'(lambda (s1 s2 k)
+            (declare (ignore s1 k))
+            (let ((len (length s2)))
+              `(integer 0 ,len))))
+  4)
diff --git a/random/random-type-prop-tests-structs.lsp b/random/random-type-prop-tests-structs.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..9a4423ad968c6274baff3fb505d98f4a87c9a611
--- /dev/null
+++ b/random/random-type-prop-tests-structs.lsp
@@ -0,0 +1,72 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Contains: Random type prop tests: structures
+
+(in-package :cl-test)
+
+(defstruct rtpt-1 a b)
+
+(defmethod make-random-element-of-type ((type (eql 'rtpt-1)))
+  (make-rtpt-1 :a (make-random-element-of-type t)
+               :b (make-random-element-of-type t)))
+
+(defmethod replicate ((obj rtpt-1))
+  (or (gethash obj *replicate-table*)
+      (let ((x (make-rtpt-1)))
+        (setf (gethash obj *replicate-table*) x)
+        (setf (rtpt-1-a x) (replicate (rtpt-1-a obj)))
+        (setf (rtpt-1-b x) (replicate (rtpt-1-b obj)))
+        x)))
+
+(defmethods make-random-type-containing*
+  (1 ((val rtpt-1)) 'rtpt-1))
+
+(def-type-prop-test structure-ref.1 'rtpt-1-a '(rtpt-1) 1)
+
+(def-type-prop-test copy-structure.1 'copy-structure '(rtpt-1) 1
+  :test #'equalp)
+
+
+(defstruct rtpt-2 a)
+(defstruct (rtpt-2.1 (:include rtpt-2)) c d)
+(defstruct (rtpt-2.2 (:include rtpt-2)) d e)
+
+(defmethod make-random-element-of-type ((type (eql 'rtpt-2)))
+  (rcase
+   (1 (make-rtpt-2 :a (make-random-element-of-type t)))
+   (1 (make-random-element-of-type 'rtpt-2.1))
+   (1 (make-random-element-of-type 'rtpt-2.2))))
+
+(defmethod make-random-element-of-type ((type (eql 'rtpt-2.1)))
+  (make-rtpt-2.1 :a (make-random-element-of-type t)
+                 :c (make-random-element-of-type t)
+                 :d (make-random-element-of-type t)))
+
+(defmethod make-random-element-of-type ((type (eql 'rtpt-2.2)))
+  (make-rtpt-2.2 :a (make-random-element-of-type t)
+                 :d (make-random-element-of-type t)
+                 :e (make-random-element-of-type t)))
+
+(defmethod replicate ((obj rtpt-2))
+  (replicate-with (obj x (make-rtpt-2))
+                  (setf (rtpt-2-a x) (replicate (rtpt-2-a obj)))))
+
+(defmethod replicate ((obj rtpt-2.1))
+  (replicate-with (obj x (make-rtpt-2.1))
+                  (setf (rtpt-2.1-a x) (replicate (rtpt-2.1-a obj)))
+                  (setf (rtpt-2.1-c x) (replicate (rtpt-2.1-c obj)))
+                  (setf (rtpt-2.1-d x) (replicate (rtpt-2.1-d obj)))))
+
+(defmethod replicate ((obj rtpt-2.2))
+  (replicate-with (obj x (make-rtpt-2.2))
+                  (setf (rtpt-2.2-a x) (replicate (rtpt-2.2-a obj)))
+                  (setf (rtpt-2.2-d x) (replicate (rtpt-2.2-d obj)))
+                  (setf (rtpt-2.2-e x) (replicate (rtpt-2.2-e obj)))))
+
+(defmethods make-random-type-containing*
+  (1 ((val rtpt-2)) 'rtpt-2)
+  (1 ((val rtpt-2.1)) 'rtpt-2.1)
+  (1 ((val rtpt-2.2)) 'rtpt-2.2))
+
+(def-type-prop-test structure-ref.2 'rtpt-2-a '(rtpt-2) 1)
+
diff --git a/random/random-type-prop-tests.lsp b/random/random-type-prop-tests.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..6f86d1c75ed07c5fefb033221637f4ee79255678
--- /dev/null
+++ b/random/random-type-prop-tests.lsp
@@ -0,0 +1,22 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Sun Feb 20 11:50:26 2005
+;;;; Contains: Randomized tests of type propagation during compilation
+
+(compile-and-load "random-type-prop.lsp")
+
+(in-package :cl-test)
+
+(load "random-type-prop-tests-01.lsp")
+(load "random-type-prop-tests-02.lsp")
+(load "random-type-prop-tests-03.lsp")
+(load "random-type-prop-tests-04.lsp")
+(load "random-type-prop-tests-05.lsp")
+(load "random-type-prop-tests-06.lsp")
+(load "random-type-prop-tests-07.lsp")
+(load "random-type-prop-tests-08.lsp")
+(load "random-type-prop-tests-09.lsp")
+(load "random-type-prop-tests-10.lsp")
+
+(load "random-type-prop-tests-structs.lsp")
+
diff --git a/random/random-type-prop.lsp b/random/random-type-prop.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..bacb02cf00065a4de6a01f621aa58c95202191ec
--- /dev/null
+++ b/random/random-type-prop.lsp
@@ -0,0 +1,664 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Thu Dec 23 20:39:22 2004
+;;;; Contains: Randomized tests of type propagation in the compiler
+
+(in-package :cl-test)
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (compile-and-load "random-aux.lsp")
+  (compile-and-load "random-int-form.lsp"))
+
+(defvar *print-random-type-prop-input* nil)
+(defparameter *random-type-prop-result* nil)
+
+(declaim (special *param-types* *params* *is-var?* *form*))
+(declaim (special *replicate-type*))
+
+(defparameter *default-reps* 1000)
+(defparameter *default-cell* nil)
+(defparameter *default-ignore* 'arithmetic-error)
+(defparameter *default-arg-the* t)
+
+;;;
+;;; The random type prop tester takes three required arguments:
+;;;
+;;;  operator  A lisp operator (either a symbol or a lambda form)
+;;;  arg-types A list consisting either of certain kinds of lisp types
+;;;            (that make-random-element-of-type understands) and/or
+;;;            functions that yield types.
+;;;  minargs   Minimum number of arguments to be given to the operator.
+;;;            Must be a positive integer <= maxargs.
+;;;
+;;; There are also keyword arguments, some with defaults given by special
+;;; variables.
+;;;
+;;; The random type prop tester generates between minargs and maxargs
+;;; (maxargs defaults to minargs) random arguments.  The type of each
+;;; argument is given by the corresponding type in arg-types (or by rest-type,
+;;; if there aren't enough elements of arg-types).  If the element of arg-types
+;;; is a function, the type for the parameter is produced by calling the function
+;;; with the previously generated actual parameters as its arguments.
+;;;
+;;; The list of parameters is stored into the special variable *params*.
+;;;
+;;; The tester evaluates (operator . arguments), and also builds a lambda
+;;; form to be compiled and called on (a subset of) the parameters.  The lambda
+;;; form is stored in the special variable *form*.
+;;;
+;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests
+;;; in a deftest form.  See random-type-prop-tests.lsp (and subfiles) for examples
+;;; of its use testing CL builtin operators.  To use it:
+;;;
+;;; (load "gclload1.lsp")
+;;; (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)
+;;; (load "random-type-prop-tests.lsp")
+;;; (let (*catch-errors*) (do-test '<testname>))
+;;; or (let (*catch-errors*) (do-tests))
+;;;
+;;; Running all the tests may take a while, particularly on lisps with slow compilers.
+;;;
+;;;
+;;; Keyword arguments to do-random-type-prop-tests:
+;;;
+;;;  Argument    Default         Meaning
+;;;
+;;;  maxargs     minargs         Maximum number of actual parameters to generate (max 20).
+;;;  rest-type   t               Type of arguments beyond those specified in arg-types
+;;;  reps        *default-reps*  Number of repetitions to try before stopping.
+;;;                              The default is controlled by a special variable that
+;;;                              is initially 1000.
+;;;  enclosing-the nil           If true, with prob 1/2 randomly generate an enclosing
+;;;                              (THE ...) form around the form invoking the operator.
+;;;  arg-the     *default-arg-the*   If true (which is the initial value of the default
+;;;                              special variable), with probability 1/2 randomly generate
+;;;                              a (THE ...) form around each actual parameter.
+;;;  cell        *default-cell*  If true (default is NIL), store the result into a rank-0
+;;;                              array of specialized type.  This enables one to test
+;;;                              forms where the result will be unboxed.  Otherwise, just
+;;;                              return the values.
+;;;  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
+;;;                              may have different roundoff errors.
+;;;  replicate   nil             Cause arguments to be copied (preserving sharing in conses
+;;;                              and arrays) before applying the operator.  This is used to test
+;;;                              destructive operators.
+;;;
+;;;
+
+(defun do-random-type-prop-tests
+  (operator arg-types minargs
+            &key
+            (maxargs minargs)
+            (rest-type t)
+            (reps *default-reps*)
+            (enclosing-the nil)
+            (arg-the *default-arg-the*)
+            (cell *default-cell*)
+            (ignore *default-ignore*)
+            (test #'regression-test::equalp-with-case)
+            (replicate nil replicate-p))
+  (assert (<= 1 minargs maxargs 20))
+(prog1
+  (dotimes (i reps)
+    again
+    (handler-bind
+     #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again)))))
+     #+lispworks ()
+    (let* ((param-names
+           '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10
+             p11 p12 p13 p14 p15 p16 p17 p18 p19 p20))
+          (nargs (+ minargs (random (- maxargs minargs -1))))
+          (types (subseq
+                  (append arg-types
+                          (make-list (max 0 (- nargs (length arg-types)))
+                                     :initial-element rest-type))
+                  0 nargs))
+          (replicate (if replicate-p replicate
+                       (mapcar (constantly nil) types)))
+          ; (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? (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
+                        when x collect p))
+          (param-types (mapcar #'make-random-type-containing vals replicate))
+          (*param-types* param-types)
+          (type-decls (loop for x in is-var?
+                            for p in param-names
+                            for tp in param-types
+                            when x
+                            collect `(type ,tp ,p)))
+          (rval (cl:handler-bind
+                 (#+sbcl (sb-ext::compiler-note #'muffle-warning)
+                         (warning #'muffle-warning))
+                 (let* ((vals (if replicate (mapcar #'replicate vals) vals))
+                        (eval-form (cons operator (loop for v in vals
+                                                        collect `(quote ,v)))))
+                   ;; (print eval-form) (terpri)
+                   ;; (dotimes (i 100) (eval eval-form))
+                   (eval eval-form))))
+          (result-type (if (and enclosing-the (integerp rval))
+                           (make-random-type-containing rval)
+                         t))
+          (expr `(,operator ,@(loop for x in is-var?
+                                    for v in vals
+                                    for r in replicate
+                                    for p in param-names
+                                    collect (if x
+                                                (if (and arg-the (coin))
+                                                    (let ((tp (make-random-type-containing v r)))
+                                                      `(the ,tp ,p))
+                                                  p)
+                                              (if (or (consp v)
+                                                      (and (symbolp v) (not (or (keywordp v)
+                                                                                (member v '(nil t))))))
+                                                  `(quote ,v)
+                                                  v)))))
+          (speed (random 4))
+          (space (random 4))
+          (safety #-allegro (random 4)
+                  #+allegro (1+ (random 3)))
+          (debug (random 4))
+          (store-into-cell? (and cell (coin)))
+          (upgraded-result-type (and store-into-cell?
+                                     (upgraded-array-element-type `(eql ,rval))))
+          (form
+           (setq *form*
+                 `(lambda (,@(when store-into-cell? '(r)) ,@params)
+                    (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space))
+                             ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r)))
+                             ,@ type-decls)
+                    ,(let ((result-form
+                            (if enclosing-the `(the ,result-type ,expr) expr)))
+                       (if store-into-cell?
+                           `(setf (aref r) ,result-form)
+                         result-form)))))
+          )
+     (when *print-random-type-prop-input*
+       (let ((*print-pretty* t)
+             (*print-case* :downcase))
+         (print (list :form form :vals vals))))
+     (finish-output)
+     (let* ((param-vals (loop for x in is-var?
+                              for v in vals
+                              when x collect v))
+            (fn (cl:handler-bind
+                 (#+sbcl (sb-ext::compiler-note #'muffle-warning)
+                         (warning #'muffle-warning))
+                 (compile nil form)))
+            (result
+             (if store-into-cell?
+                 (let ((r (make-array nil :element-type upgraded-result-type)))
+                   (apply fn r param-vals)
+                   (aref r))
+               (apply fn param-vals))))
+       (setq *random-type-prop-result*
+             (list :upgraded-result-type upgraded-result-type
+                   :form form
+                   :vals vals
+                   :result result
+                   :rval rval))
+       (unless (funcall test result rval)
+         (return *random-type-prop-result*))))
+    ;; #+allegro (excl::gc t)
+  ))))
+
+(defun make-random-arguments (types-or-funs)
+  (let ((vals nil))
+    (loop for type-or-fun in types-or-funs
+          for type = (or (typecase type-or-fun
+                           ((and function (not symbol))
+                            (apply type-or-fun vals))
+                           (t type-or-fun))
+                         (return-from make-random-arguments nil) ;; null type
+                         )
+          for val = (make-random-element-of-type type)
+          do (setf vals (nconc vals (list val))))
+    ;; (dolist (v vals) (describe v))
+    vals))
+
+(defmacro defmethods (name &rest bodies)
+  `(progn
+     ,@(mapcar
+        #'(lambda (body) `(defmethod ,name ,@body))
+        bodies)))
+
+(defgeneric make-random-type-containing* (val)
+  (:method-combination randomized)
+  (:documentation "Produce a random type containing VAL.  If the special
+variable *REPLICATE-TYPE* is true, and the value is mutable, then do not
+use the value in MEMBER or EQL type specifiers."))
+
+(defun make-random-type-containing (type &optional *replicate-type*)
+  (declare (special *replicate-type*))
+  (make-random-type-containing* type))
+
+(defmethods make-random-type-containing*
+  (4 ((val t))
+     (declare (special *replicate-type*))
+     (rcase
+      (1 t)
+      (1 (if (consp val) 'cons 'atom))
+      (1 (if *replicate-type* (make-random-type-containing* val)
+           `(eql ,val)))
+      (1
+       (if *replicate-type* (make-random-type-containing* val)
+         (let* ((n1 (random 4))
+                (n2 (random 4))
+                ;; Replace these calls with (make-random-element-of-type t)
+                ;; at some point
+                (l1 (loop repeat n1 collect (random-leaf)))
+                (l2 (loop repeat n2 collect (random-leaf))))
+           `(member ,@l1 ,val ,@l2))))))
+
+  (1 ((val standard-object)) 'standard-object)
+  (1 ((val structure-object)) 'structure-object)
+  (1 ((val class)) 'class)
+  (1 ((val standard-class)) 'standard-class)
+  (1 ((val structure-class)) 'structure-class)
+  (1 ((val number)) 'number)
+  (1 ((val real)) 'real)
+  (1 ((val ratio)) 'ratio)
+
+  (1 ((val integer))
+     (rcase
+      (1 'integer)
+      (1 'signed-byte)
+      (1 (let* ((n1 (random 4))
+                (n2 (random 4))
+                (l1 (loop repeat n1 collect (make-random-integer)))
+                (l2 (loop repeat n2 collect (make-random-integer))))
+           `(member ,@l1 ,val ,@l2)))
+      (1 (let ((lo (abs (make-random-integer))))
+           `(integer ,(- val lo))))
+      (2 (let ((lo (abs (make-random-integer))))
+           `(integer ,(- val lo) *)))
+      (2 (let ((hi (abs (make-random-integer))))
+           `(integer * ,(+ val hi))))
+      (4 (let ((lo (abs (make-random-integer)))
+               (hi (abs (make-random-integer))))
+           `(integer ,(- val lo) ,(+ val hi))))
+      (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil)))))
+
+  (2 ((val character))
+     (rcase
+      (1 'character)
+      (1 (if (typep val 'base-char) 'base-char
+           #-sbcl 'extended-char
+           #+sbcl (throw 'fail nil)
+           ))
+      (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil)))
+      (1 (let* ((n1 (random 4))
+                (n2 (random 4))
+                (l1 (loop repeat n1 collect (make-random-character)))
+                (l2 (loop repeat n2 collect (make-random-character))))
+           `(member ,@l1 ,val ,@l2)))))
+
+  (1 ((val null)) 'null)
+
+  (2 ((val symbol))
+     (rcase
+      (1 'symbol)
+      (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil))))
+      (1 (let* ((n1 (random 4))
+                (n2 (random 4))
+                (l1 (loop repeat n1 collect (make-random-symbol)))
+                (l2 (loop repeat n2 collect (make-random-symbol))))
+           `(member ,@l1 ,val ,@l2)))))
+
+  (1 ((val rational))
+     (rcase
+      (1 'rational)
+      (1 (let* ((n1 (random 4))
+                (n2 (random 4))
+                (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))
+                (l2 (loop repeat n2 collect (make-random-element-of-type 'rational))))
+           `(member ,@l1 ,val ,@l2)))
+      (1 `(rational ,val))
+      (1 `(rational * ,val))
+      (1 (let ((v (make-random-element-of-type 'rational)))
+           (if (<= v val)
+               `(rational ,v ,val)
+             `(rational ,val ,v))))))
+
+  (1 ((val float))
+     (rcase
+      (1 (let* ((n1 (random 4))
+                (n2 (random 4))
+                (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val)))))
+                (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val))))))
+           `(member ,@l1 ,val ,@l2)))
+      (1 (let ((names (float-types-containing val)))
+           (random-from-seq names)))
+      (1 (let ((name (random-from-seq (float-types-containing val))))
+           (if (>= val 0)
+               `(,name ,(coerce 0 name) ,val)
+             `(,name ,val ,(coerce 0 name)))))))
+  )
+
+(defun float-types-containing (val)
+  (loop for n in '(short-float single-float double-float long-float float)
+        when (typep val n)
+        collect n))
+
+(defun make-random-array-dimension-spec (array dim-index)
+  (assert (<= 0 dim-index))
+  (assert (< dim-index (array-rank array)))
+  (let ((dim (array-dimension array dim-index)))
+    (rcase (1 '*) (1 dim))))
+
+;;; More methods
+(defmethods make-random-type-containing*
+  (3 ((val bit-vector))
+     (let ((root (if (and (coin)
+                          (typep val 'simple-bit-vector))
+                     'simple-bit-vector
+                   'bit-vector)))
+       (rcase (1 root)
+              (1 `(,root))
+              (3 `(,root ,(make-random-array-dimension-spec val 0))))))
+
+  (3 ((val vector))
+     (let ((root 'vector)
+            (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector))
+            (etype (rcase (1 '*)
+                          (1 (array-element-type val))
+                          ;; Add rule for creating new element types?
+                          )))
+        (rcase (1 alt-root)
+               (1 `(,alt-root))
+               (1 `(,root ,etype))
+               (2 (if (and (simple-vector-p val) (coin))
+                      `(simple-vector ,(make-random-array-dimension-spec val 0))
+                    `(,root ,etype ,(make-random-array-dimension-spec val 0)))))))
+
+  (3 ((val array))
+     (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array))
+        (etype (rcase (1 (array-element-type val)) (1 '*)))
+        (rank (array-rank val)))
+       (rcase
+        (1 root)
+        (1 `(,root))
+        (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))))
+        #-ecl (1 `(,root ,etype ,rank)))))
+
+  (3 ((val string))
+     (let ((root (cond
+                  ((and (coin)
+                        (typep val 'base-string))
+                   (cond
+                    ((and (coin) (typep val 'simple-base-string))
+                     'simple-base-string)
+                    (t 'base-string)))
+                  ((and (coin)
+                        (typep val 'simple-string))
+                   'simple-string)
+                  (t 'string))))
+       (rcase (1 root)
+              (1 `(,root))
+              (3 `(,root ,(make-random-array-dimension-spec val 0))))))
+
+  (1 ((val list)) 'list)
+
+  (1 ((val cons))
+     (rcase
+      (1 'cons)
+      (2 `(cons ,(make-random-type-containing* (car val))
+                ,(make-random-type-containing* (cdr val))))
+      (1 `(cons ,(make-random-type-containing* (car val))
+                ,(random-from-seq #(t *))))
+      (1 `(cons ,(make-random-type-containing* (car val))))
+      (1 `(cons ,(random-from-seq #(t *))
+                ,(make-random-type-containing* (cdr val))
+                ))))
+
+  (1 ((val complex))
+     (rcase
+      (1 'complex)
+      #-gcl
+      (1 (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 ((val generic-function)) 'generic-function)
+  (1 ((val function))
+     (rcase
+      (1 'function)
+      (1 (if (typep val 'compiled-function)
+             'compiled-function
+           'function))))
+  )
+
+;;; Macro for defining random type prop tests
+
+(defmacro def-type-prop-test (name &body args)
+  `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP."
+                                  (string name))
+                     (find-package :cl-test))
+     (do-random-type-prop-tests ,@args)
+     nil))
+
+;;; Function used in constructing list types for some random type prop tests
+
+(defun make-list-type (length &optional (rest-type 'null) (element-type t))
+  (let ((result rest-type))
+    (loop repeat length
+          do (setq result `(cons ,element-type ,result)))
+    result))
+
+(defun make-sequence-type (length &optional (element-type t))
+  (rcase
+   (1 `(vector ,element-type ,length))
+   (1 `(array ,element-type (,length)))
+   (1 `(simple-array ,element-type (,length)))
+   (2 (make-list-type length 'null element-type))))
+
+(defun make-random-sequence-type-containing (element &optional *replicate-type*)
+  (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)
+       (apply #'subsetp set2 set2 args)
+       t))
+
+(defun index-type-for-dim (dim)
+  "Returns a function that computes integer type for valid indices
+   of an array dimension, or NIL if there are none."
+  #'(lambda (array &rest other)
+      (declare (ignore other))
+      (let ((d (array-dimension array dim)))
+        (and (> d 0) `(integer 0 (,d))))))
+
+(defun index-type-for-v1 (v1 &rest other)
+  "Computes integer type for valid indices for the first of two vectors"
+  (declare (ignore other))
+  (let ((d (length v1))) `(integer 0 ,d)))
+
+(defun index-type-for-v2 (v1 v2 &rest other)
+  "Computes integer type for valid indices for the second of two vectors"
+  (declare (ignore v1 other))
+  (let ((d (length v2))) `(integer 0 ,d)))
+
+(defun end-type-for-v1 (v1 v2 &rest other)
+  (declare (ignore v2))
+  (let ((d (length v1))
+        (start1 (or (cadr (member :start1 other)) 0)))
+    `(integer ,start1 ,d)))
+
+(defun end-type-for-v2 (v1 v2 &rest other)
+  (declare (ignore v1))
+  (let ((d (length v2))
+        (start2 (or (cadr (member :start2 other)) 0)))
+    `(integer ,start2 ,d)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgeneric replicate (obj)
+  (:documentation "Copies the structure of a lisp object recursively, preserving sharing."))
+
+(defmacro replicate-with ((source-obj dest-obj copy-form) &body body)
+  `(or (gethash ,source-obj *replicate-table*)
+       (let ((,dest-obj ,copy-form))
+         (setf (gethash ,source-obj *replicate-table*) ,dest-obj)
+         ,@body
+         ,dest-obj)))
+
+(declaim (special *replicate-table*))
+
+(defmethod replicate :around ((obj t))
+  "Wrapper to create a hash table for structure sharing, if none exists."
+  (if (boundp '*replicate-table*)
+      (call-next-method obj)
+    (let ((*replicate-table* (make-hash-table)))
+      (call-next-method obj))))
+
+(defmethod replicate ((obj cons))
+  (or (gethash obj *replicate-table*)
+      (let ((x (cons nil nil)))
+        (setf (gethash obj *replicate-table*) x)
+        (setf (car x) (replicate (car obj)))
+        (setf (cdr x) (replicate (cdr obj)))
+        x)))
+
+;;; Default method for objects without internal structure
+(defmethod replicate ((obj t)) obj)
+
+(defmethod replicate ((obj array))
+  (multiple-value-bind
+      (new-obj old-leaf new-leaf)
+      (replicate-displaced-array obj)
+    (when new-leaf
+      (loop for i below (array-total-size new-leaf)
+            do (setf (row-major-aref new-leaf i)
+                     (row-major-aref old-leaf i))))
+    new-obj))
+
+(defun replicate-displaced-array (obj)
+  "Replicate the non-terminal (and not already replicated) arrays
+   in a displaced array chain.  Return the new root array, the
+   old leaf array, and the new (but empty) leaf array.  The latter
+   two are NIL if the leaf did not have to be copied again."
+  (or (gethash obj *replicate-table*)
+      (multiple-value-bind
+          (displaced-to displaced-index-offset)
+          (array-displacement obj)
+        (let ((dims (array-dimensions obj))
+              (element-type (array-element-type obj))
+              (fill-pointer (and (array-has-fill-pointer-p obj)
+                                 (fill-pointer obj)))
+              (adj (adjustable-array-p obj)))
+          (if displaced-to
+              ;; The array is displaced
+              ;; Copy recursively
+              (multiple-value-bind
+                  (new-displaced-to old-leaf new-leaf)
+                  (replicate-displaced-array displaced-to)
+                (let ((new-obj (make-array dims :element-type element-type
+                                           :fill-pointer fill-pointer
+                                           :adjustable adj
+                                           :displaced-to new-displaced-to
+                                           :displaced-index-offset displaced-index-offset)))
+                  (setf (gethash obj *replicate-table*) new-obj)
+                  (values new-obj old-leaf new-leaf)))
+            ;; The array is not displaced
+            ;; This is the leaf array
+            (let ((new-obj (make-array dims :element-type element-type
+                                       :fill-pointer fill-pointer
+                                       :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)))))))))))
+
+;;; Test that sequences have identical elements
+
+(defun equalp-and-eql-elements (s1 s2)
+  (and (equalp s1 s2)
+       (every #'eql s1 s2)))
diff --git a/random/random-types.lsp b/random/random-types.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..fa9b061d3ee3b0f5496b2e504d945321654ba60a
--- /dev/null
+++ b/random/random-types.lsp
@@ -0,0 +1,369 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Mon Oct  6 05:04:45 2003
+;;;; Contains: Generating random types and testing relationships on them
+
+(in-package :cl-test)
+
+(compile-and-load "types-aux.lsp")
+(compile-and-load "random-aux.lsp")
+(compile-and-load "random-int-form.lsp")
+
+(defparameter *random-types* nil)
+
+(defun make-random-type (size)
+  (if (<= size 1)
+      (rcase
+       (1 nil)
+       (1 t)
+       (1 `(eql ,(let ((r (ash 1 (random 45))))
+                   (random-from-interval r (- r)))))
+       (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))
+               (r2 (+ r1 r1))
+               (x (- (random r2) r1))
+               (y (- (random r2) r1))
+               (lo (min x y))
+               (hi (max x y)))
+          `(integer ,lo ,hi)))
+       (1 (make-random-real-type))
+       ;; (1 (make-random-complex-type))
+       )
+    (rcase
+     (2 (let* ((op (random-from-seq #(cons cons and or)))
+               (nargs (if (eq op 'cons) 2
+                        (1+ (random (min size 4)))))
+               (sizes (random-partition (1- size) nargs)))
+          `(,op ,@(mapcar #'make-random-type sizes))))
+     (1 `(not ,(make-random-type (1- size))))
+     ; (1 (make-random-function-type size))
+     )))
+
+(defun make-random-real-type ()
+  (rcase
+   (1 (random-from-seq '(integer unsigned-byte short-float single-float
+                                 double-float long-float rational real)))
+   (1 (destructuring-bind (lo hi)
+          (make-random-integer-range)
+        (rcase
+         (4 `(integer ,lo ,hi))
+         (1 `(integer ,lo))
+         (1 `(integer ,lo *))
+         (2 `(integer * ,hi)))))
+   (1 (let ((r1 (random-real))
+            (r2 (random-real)))
+        `(real ,(min r1 r2) ,(max r2 r2))))
+   ;;; Add more cases here
+   ))
+
+(defun make-random-complex-type ()
+  `(complex ,(make-random-real-type)))
+
+(defun make-random-function-type (size)
+  (let* ((sizes (random-partition (1- size) 2))
+         (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)
+        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-random-mutated-types (n size &key (reps 1))
+  (loop for t1 = (make-random-type size)
+        for t2 = (let ((x t1)) (loop repeat reps
+                                     do (setq x (mutate-type x))) x)
+        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)
+      (subtypep t1 t2)
+    (when success
+      (if sub
+          (check-all-subtypep t1 t2)
+        (let ((nt1 `(not ,t1))
+              (nt2 `(not ,t2)))
+          (subtypep nt2 nt1))))))
+
+(defun prune-type (tp try-fn)
+  (declare (type function try-fn))
+  (flet ((try (x) (funcall try-fn x)))
+    (cond
+     ((member tp '(nil t)))
+     ((symbolp tp)
+      (try nil)
+      (try t))
+     ((consp tp)
+      (try nil)
+      (try t)
+      (let ((op (first tp))
+            (args (rest tp)))
+        (case op
+          ((cons)
+           (try 'cons)
+           (prune-list args
+                       #'prune-type
+                       #'(lambda (args) (try `(cons ,@args)))))
+          ((integer)
+           (try op)
+           (try '(eql 0))
+           (when (= (length args) 2)
+             (let ((arg1 (first args))
+                   (arg2 (second args)))
+               (when (and (integerp arg1) (integerp arg2))
+                 (try `(eql ,arg1))
+                 (try `(eql ,arg2))
+                 (when (and (< arg1 0) (<= 0 arg2))
+                   (try `(integer 0 ,arg2)))
+                 (when (and (<= arg1 0) (< 0 arg2))
+                   (try `(integer ,arg1 0)))
+                 (when (> (- arg2 arg1) 1)
+                   (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2))
+                   (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2)))))))))
+
+          ((real float ratio single-float double-float short-float long-float)
+           (try op))
+
+          ((or and)
+           (mapc try-fn args)
+           (loop for i from 0 below (length args)
+                 do (try `(,op ,@(subseq args 0 i)
+                               ,@(subseq args (1+ i)))))
+           (prune-list args
+                       #'prune-type
+                       #'(lambda (args) (try (cons op args)))))
+          ((not)
+           (let ((arg (first args)))
+             (try arg)
+             (when (and (consp arg)
+                        (eq (car arg) 'not))
+               (try (second arg)))
+             (prune-type arg #'(lambda (arg) (try `(not ,arg))))))
+
+          ((member)
+           (dolist (arg (cdr tp))
+             (try `(eql ,arg)))
+           (when (cddr tp)
+           (try `(member ,@(cddr tp)))))
+
+          ((eql)
+           (assert (= (length args) 1))
+           (let ((arg (first args)))
+             (unless (= arg 0)
+               (try `(eql 0))
+               (cond
+                ((< arg -1)
+                 (try `(eql ,(ceiling arg 2))))
+                ((> arg 1)
+                 (try `(eql ,(floor arg 2))))))))
+
+          )))))
+  (values))
+
+(defun prune-type-pair (pair &optional (fn #'test-types))
+  (declare (type function fn))
+  (let ((t1 (first pair))
+        (t2 (second pair))
+        changed)
+    (loop
+     do (flet ((%try2 (new-tp)
+                      (when (funcall fn t1 new-tp)
+                        (print "Success in first loop")
+                        (print new-tp)
+                        (setq t2 new-tp
+                              changed t)
+                        (throw 'success nil))))
+          (catch 'success
+            (prune-type t2 #'%try2)))
+     do (flet ((%try1 (new-tp)
+                      (when (funcall fn new-tp t2)
+                        (print "Success in second loop")
+                        (print new-tp)
+                        (setq t1 new-tp
+                              changed t)
+                        (throw 'success nil))))
+          (catch 'success
+            (prune-type t1 #'%try1)))
+     while changed
+     do (setq changed nil))
+    (list t1 t2)))
+
+(defun test-type-triple (t1 t2 t3)
+  ;; Returns non-nil if a problem is found
+  (catch 'problem
+    (multiple-value-bind (sub1 success1)
+        (subtypep t1 t2)
+      (when success1
+        (if sub1
+            (append
+             (check-all-subtypep t1 `(or ,t2 ,t3))
+             (check-all-subtypep `(and ,t1 ,t3) t2))
+            (or (subtypep `(or ,t1 ,t3) t2)
+                (subtypep t1 `(and ,t2 ,t3))))))))
+
+(defun test-random-types3 (n size)
+  (loop for t1 = (make-random-type (1+ (random size)))
+        for t2 = (make-random-type (1+ (random size)))
+        for t3 = (make-random-type (1+ (random size)))
+        for i from 1 to n
+        ;; do (print (list t1 t2))
+        do (setf *random-types* (list t1 t2 t3))
+        do (when (and (= (mod i 100) 0) (> i 0))
+             (format t "~A " i) (finish-output *standard-output*))
+        when (test-type-triple t1 t2 t3)
+        collect (list t1 t2 t3)
+        finally (terpri)))
+
+(defun prune-type-triple (pair &optional (fn #'test-type-triple))
+  (declare (type function fn))
+  (let ((t1 (first pair))
+        (t2 (second pair))
+        (t3 (third pair))
+        changed)
+    (loop
+     do (flet ((%try2 (new-tp)
+                      (when (funcall fn t1 new-tp t3)
+                        (print "Success in first loop")
+                        (print new-tp)
+                        (setq t2 new-tp
+                              changed t)
+                        (throw 'success nil))))
+          (catch 'success
+            (prune-type t2 #'%try2)))
+     do (flet ((%try1 (new-tp)
+                      (when (funcall fn new-tp t2 t3)
+                        (print "Success in second loop")
+                        (print new-tp)
+                        (setq t1 new-tp
+                              changed t)
+                        (throw 'success nil))))
+          (catch 'success
+            (prune-type t1 #'%try1)))
+     do (flet ((%try3 (new-tp)
+                      (when (funcall fn t1 t2 new-tp)
+                        (print "Success in second loop")
+                        (print new-tp)
+                        (setq t3 new-tp
+                              changed t)
+                        (throw 'success nil))))
+          (catch 'success
+            (prune-type t3 #'%try3)))
+     while changed
+     do (setq changed nil))
+    (list t1 t2 t3)))
+
+
+
+