From efdc9154ca3f5be5bf769459dbc5fe8b48da81ca Mon Sep 17 00:00:00 2001
From: Karsten Poeck <karsten.poeck@gmail.com>
Date: Sat, 28 May 2022 19:28:53 +0200
Subject: [PATCH] Merged with pfdietz version

---
 README                                    |    6 +-
 auxiliary/ansi-aux-macros.lsp             |    2 +-
 auxiliary/ansi-aux.lsp                    |   13 +-
 auxiliary/random-aux.lsp                  |   38 +-
 auxiliary/types-aux.lsp                   |   40 +-
 cl-test-package.lsp                       |    1 +
 clasp/ansi-setup-clasp.lisp               |    1 +
 conditions/define-condition.lsp           |    1 +
 cons/assoc.lsp                            |   15 +
 data-and-control-flow/equal.lsp           |   42 +
 data-and-control-flow/flet.lsp            |    1 +
 data-and-control-flow/labels.lsp          |    1 +
 data-and-control-flow/macrolet.lsp        |    1 +
 doit-clasp-random-tester.lsp              |    5 -
 eval-and-compile/declaration.lsp          |    4 +-
 printer/format/format-logical-block.lsp   |   11 +
 printer/format/format-t.lsp               |   14 +
 random/random-int-form.lsp                | 1514 ++++++++++++++++++---
 random/random-type-prop-tests-01.lsp      |  107 +-
 random/random-type-prop-tests-02.lsp      |   36 +
 random/random-type-prop-tests-03.lsp      |  138 +-
 random/random-type-prop-tests-04.lsp      |    2 +-
 random/random-type-prop-tests-05.lsp      |    7 +-
 random/random-type-prop-tests-07.lsp      |    4 +
 random/random-type-prop-tests-08.lsp      |  106 +-
 random/random-type-prop-tests-09.lsp      |   16 +
 random/random-type-prop-tests-10.lsp      |   73 +
 random/random-type-prop-tests-structs.lsp |   14 +
 random/random-type-prop-tests.lsp         |   14 +-
 random/random-type-prop.lsp               |  266 +++-
 random/random-types.lsp                   |  117 +-
 structures/structure-00.lsp               |    5 +
 system-construction/compile-file.lsp      |    1 +
 universe.lsp                              |    8 +-
 34 files changed, 2273 insertions(+), 351 deletions(-)

diff --git a/README b/README
index f0de4a02..95a7268b 100644
--- a/README
+++ b/README
@@ -19,7 +19,7 @@ LISP to the lisp executable to be tested, then invoking
 Please tell me when you find incorrect test cases.
 
 	Paul Dietz
-	dietz@dls.net
+	paul.f.dietz@gmail.com
 
 --------------------------------
 
@@ -36,6 +36,10 @@ please contact me and I will add code to do so.
 
 --------------------------------
 
+To run random tests, see random/README.
+
+--------------------------------
+
 NOTE!!!
 
 This test suite is not intended to rank Common Lisp implementations.
diff --git a/auxiliary/ansi-aux-macros.lsp b/auxiliary/ansi-aux-macros.lsp
index 6b4b9030..1b49e87f 100644
--- a/auxiliary/ansi-aux-macros.lsp
+++ b/auxiliary/ansi-aux-macros.lsp
@@ -3,7 +3,7 @@
 ;;;; Created:  Wed Jul  2 07:05:41 2003
 ;;;; Contains: Macros used in ansi-aux and elsewhere.
 
-
+(in-package :cl-test)
 
 (declaim (optimize (safety 3)))
 
diff --git a/auxiliary/ansi-aux.lsp b/auxiliary/ansi-aux.lsp
index 6deac06f..89daeec3 100644
--- a/auxiliary/ansi-aux.lsp
+++ b/auxiliary/ansi-aux.lsp
@@ -3,7 +3,7 @@
 ;;;; Created:  Sat Mar 28 17:10:18 1998
 ;;;; Contains: Aux. functions for CL-TEST
 
-
+(in-package :cl-test)
 
 (declaim (optimize (safety 3)))
 
@@ -1188,3 +1188,14 @@ the condition to go uncaught if it cannot be classified."
 
 (defmacro expand-in-current-env (macro-form &environment env)
   (macroexpand macro-form env))
+
+;;; LOAD does not necessarily behave correctly in some lisps.
+;;; Manually merge *default-pathname-defaults*
+
+(defun load-merge (pathspec)
+  (load (merge-pathnames (pathname pathspec) *default-pathname-defaults*)))
+
+(defun load-here (pathspec)
+  (let ((*default-pathname-defaults*
+         (make-pathname :directory (pathname-directory *load-pathname*))))
+    (load-merge pathspec)))
diff --git a/auxiliary/random-aux.lsp b/auxiliary/random-aux.lsp
index b86fbbcb..c30f519d 100644
--- a/auxiliary/random-aux.lsp
+++ b/auxiliary/random-aux.lsp
@@ -7,8 +7,12 @@
 
 (declaim (special +standard-chars+ *cl-symbols-vector*))
 
+(defun coin (&optional (n 2))
+  "Flip an n-sided coin."
+  (eql (random n) 0))
+
 (defvar *maximum-random-int-bits*
-  (max 36 (1+ (integer-length most-positive-fixnum))))
+  (max 36 (+ 4 (integer-length most-positive-fixnum))))
 
 (defun random-from-seq (seq)
   "Generate a random member of a sequence."
@@ -163,15 +167,6 @@
   (+ (random (1+ (- most-positive-fixnum most-negative-fixnum)))
      most-negative-fixnum))
 
-(defun random-thing (n)
-  (if (<= n 1)
-      (random-leaf)
-    (rcase
-     (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2))))
-     (1 (apply #'vector (mapcar #'random-thing
-                                (random-partition (1- n) (max 10 (1- n))))))
-     )))
-
 (defparameter *use-random-byte* t)
 (defparameter *random-readable* nil)
 
@@ -219,6 +214,9 @@
 
     s))
 
+(defun random-from-interval (upper &optional (lower (- upper)))
+  (+ (random (- upper lower)) lower))
+
 (defun random-leaf ()
   (rcase
    (1 (let ((k (ash 1 (1+ (random 40)))))
@@ -230,13 +228,6 @@
    (1 (make-symbol (make-random-string (random 20))))
    (1 (random-from-seq *cl-symbols-vector*))))
 
-(defun random-from-interval (upper &optional (lower (- upper)))
-  (+ (random (- upper lower)) lower))
-
-(defun coin (&optional (n 2))
-  "Flip an n-sided coin."
-  (eql (random n) 0))
-
 ;;; Randomly permute a sequence
 (defun random-permute (seq)
   (setq seq (copy-seq seq))
@@ -303,3 +294,16 @@
                          method-list)))
   `(loop (catch 'fail (return (rcase ,@clauses))))))
 
+(defun init-random-state ()
+  "Initialize random state to some arbitrary nondeterministic value, to make fresh runs of random testing different"
+  (setf *random-state* (make-random-state t))
+  (values))
+
+(defun random-thing (n)
+  (if (<= n 1)
+      (random-leaf)
+    (rcase
+     (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2))))
+     (1 (apply #'vector (mapcar #'random-thing
+                                (random-partition (1- n) (max 10 (1- n))))))
+     )))
diff --git a/auxiliary/types-aux.lsp b/auxiliary/types-aux.lsp
index 091af89e..4a389d50 100644
--- a/auxiliary/types-aux.lsp
+++ b/auxiliary/types-aux.lsp
@@ -3,16 +3,22 @@
 ;;;; Created:  Mon Jun 21 20:14:38 2004
 ;;;; Contains: Aux. functions for types tests
 
-(defun classes-are-disjoint (c1 c2)
-  "If either c1 or c2 is a builtin class or the name of a builtin
-   class, then check for disjointness.  Return a non-NIL list
-   of failed subtypep relationships, if any."
-  (and (or (is-builtin-class c1)
-           (is-builtin-class c2))
-       (check-disjointness c1 c2)))
+(in-package :cl-test)
 
 (declaim (special *subtype-table*))
 
+(defun check-subtypep (type1 type2 is-sub &optional should-be-valid)
+  (multiple-value-bind
+      (sub valid)
+      (subtypep type1 type2)
+    (unless (constantp type1) (setq type1 (list 'quote type1)))
+    (unless (constantp type2) (setq type2 (list 'quote type2)))
+    (if (or (and valid sub (not is-sub))
+            (and valid (not sub) is-sub)
+            (and (not valid) should-be-valid))
+        `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid))
+      nil)))
+
 (defun types.6-body ()
   (loop
       for p in *subtype-table*
@@ -106,18 +112,6 @@
          (condition (c) (format t "Error ~S occured: ~S~%" c tp)
                     1))))))))
 
-(defun check-subtypep (type1 type2 is-sub &optional should-be-valid)
-  (multiple-value-bind
-      (sub valid)
-      (subtypep type1 type2)
-    (unless (constantp type1) (setq type1 (list 'quote type1)))
-    (unless (constantp type2) (setq type2 (list 'quote type2)))
-    (if (or (and valid sub (not is-sub))
-            (and valid (not sub) is-sub)
-            (and (not valid) should-be-valid))
-        `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid))
-      nil)))
-
 ;;; Check that the subtype relationships implied
 ;;; by disjointness are not contradicted.  Return NIL
 ;;; if ok, or a list of error messages if not.
@@ -184,3 +178,11 @@
 (deftype even-array (&optional type size)
   `(and (array ,type ,size)
         (satisfies even-size-p)))
+
+(defun classes-are-disjoint (c1 c2)
+  "If either c1 or c2 is a builtin class or the name of a builtin
+   class, then check for disjointness.  Return a non-NIL list
+   of failed subtypep relationships, if any."
+  (and (or (is-builtin-class c1)
+           (is-builtin-class c2))
+       (check-disjointness c1 c2)))
diff --git a/cl-test-package.lsp b/cl-test-package.lsp
index 7f2b7406..c0701603 100644
--- a/cl-test-package.lsp
+++ b/cl-test-package.lsp
@@ -7,6 +7,7 @@
        (pkg (find-package name)))
   (unless pkg (setq pkg (make-package name :use '(:cl :regression-test))))
   (let ((*package* pkg))
+    ;; These are shadowed to avoid annoying SBCL notes
     (shadow '(#:handler-case #:handler-bind))
     (import '(common-lisp-user::compile-and-load
               common-lisp-user::compile-and-load*)
diff --git a/clasp/ansi-setup-clasp.lisp b/clasp/ansi-setup-clasp.lisp
index c7acc5bf..ae34fe75 100644
--- a/clasp/ansi-setup-clasp.lisp
+++ b/clasp/ansi-setup-clasp.lisp
@@ -17,6 +17,7 @@
   (rt:disable-note :nil-vectors-are-strings)
   (rt:disable-note :allow-nil-arrays)
   (rt:disable-note :make-condition-with-compound-name)
+  (rt:disable-note :no-floating-point-underflow-by-default)
   #+(or)(rt:rem-test 'cl-test::sublis.error.8)
   #+(or)(rt:rem-test 'cl-test::nsublis.error.8)
   #+(or)(rt:rem-test 'cl-test::get-properties.error.4)
diff --git a/conditions/define-condition.lsp b/conditions/define-condition.lsp
index ae02b60c..54ec9d69 100644
--- a/conditions/define-condition.lsp
+++ b/conditions/define-condition.lsp
@@ -288,6 +288,7 @@
     (with-output-to-string (s) (print-object c s)))
   "The report for condition-16")
 
+(declaim (ftype (function (t) *) condition-17/s))
 (defun condition-17-report (c s)
   (format s "condition-17: ~A" (condition-17/s c)))
 
diff --git a/cons/assoc.lsp b/cons/assoc.lsp
index bbe38bb3..e76f955e 100644
--- a/cons/assoc.lsp
+++ b/cons/assoc.lsp
@@ -163,6 +163,21 @@
                  :test #'eq))
   (nil . e))
 
+
+;;; No match, but with key, test, test-not
+
+(deftest assoc.32
+  (assoc 1 (list (cons 1 2)) :key #'1+)
+  nil)
+
+(deftest assoc.33
+  (assoc 1 (list (cons 1 2)) :test #'/=)
+  nil)
+
+(deftest assoc.34
+  (assoc 1 (list (cons 1 2)) :test-not #'=)
+  nil)
+
 ;;; :test & :test-not together are harmless
 
 (defharmless assoc.test-and-test-not.1
diff --git a/data-and-control-flow/equal.lsp b/data-and-control-flow/equal.lsp
index 17260f76..40263033 100644
--- a/data-and-control-flow/equal.lsp
+++ b/data-and-control-flow/equal.lsp
@@ -113,6 +113,48 @@
     (values (equalt s "012") (equalt "012" s)))
   t t)
 
+(deftest equal.20
+    (let ((fn '(lambda (x y)
+                (declare
+                 (type (simple-array bit (*)) x)
+                 (type (and (array bit (*)) (not simple-array)) y))
+                (equal x y)))
+          (v1 (coerce #*10110 'simple-bit-vector))
+          (v2 (make-array '(5) :element-type 'bit
+                          :initial-contents '(1 0 1 1 0)
+                          :adjustable t)))
+      (values (not (not (equal v1 v2)))
+              (funcall (compile nil fn) v1 v2)))
+  t t)
+
+(deftest equal.21
+    (let ((fn '(lambda (x y)
+                (declare
+                 (type (simple-array base-char (*)) x)
+                 (type (simple-array character (*)) y))
+                (equal x y)))
+          (v1 (coerce "acndaa" 'simple-base-string))
+          (v2 (make-array '(6) :element-type 'character
+                          :initial-contents '(#\a #\c #\n #\d #\a #\a))))
+      (let ((cfn (compile nil fn)))
+        (values (not (not (equal v1 v2)))
+                (funcall cfn v1 v2))))
+  t t)
+
+(deftest equal.22
+    (let ((fn '(lambda (x y)
+                (declare
+                 (type (simple-array base-char (*)) x)
+                 (type (and base-string (not simple-array)) y))
+                (equal x y)))
+          (v1 (coerce "acndaa" 'simple-base-string))
+          (v2 (make-array '(6) :element-type 'base-char
+                          :adjustable t
+                          :initial-contents '(#\a #\c #\n #\d #\a #\a))))
+      (values (not (not (equal v1 v2)))
+              (funcall (compile nil fn) v1 v2)))
+  t t)
+
 ;;; Should add more pathname equality tests
 
 (deftest equal.order.1
diff --git a/data-and-control-flow/flet.lsp b/data-and-control-flow/flet.lsp
index f4e09120..9de0fb1e 100644
--- a/data-and-control-flow/flet.lsp
+++ b/data-and-control-flow/flet.lsp
@@ -577,6 +577,7 @@
    :good)
 
 (define-compiler-macro flet.74 (&whole form)
+  (declare (ignorable form))
    :bad)
 
 (deftest flet.74
diff --git a/data-and-control-flow/labels.lsp b/data-and-control-flow/labels.lsp
index 47ee6c9d..22d7e4f7 100644
--- a/data-and-control-flow/labels.lsp
+++ b/data-and-control-flow/labels.lsp
@@ -427,6 +427,7 @@
    :good)
 
 (define-compiler-macro labels.52 (&whole form)
+  (declare (ignorable form))
    :bad)
 
 (deftest labels.52
diff --git a/data-and-control-flow/macrolet.lsp b/data-and-control-flow/macrolet.lsp
index 3cb5d199..ceb87928 100644
--- a/data-and-control-flow/macrolet.lsp
+++ b/data-and-control-flow/macrolet.lsp
@@ -464,6 +464,7 @@
    :good)
 
 (define-compiler-macro macrolet.52 (&whole form)
+  (declare (ignorable form))
   :bad)
 
 (deftest macrolet.52
diff --git a/doit-clasp-random-tester.lsp b/doit-clasp-random-tester.lsp
index 01dc87e6..121458bb 100644
--- a/doit-clasp-random-tester.lsp
+++ b/doit-clasp-random-tester.lsp
@@ -36,11 +36,6 @@
    (handler-bind ((style-warning #'muffle-warning))
    (test-random-integer-forms 100 4 200))))
 
-#|
-(load "~/fork-ansi-test/doit-clasp-random-tester.lsp" :print t)
-(load "~/pfdietz-ansi-test/doit-clasp-random-tester.lsp" :print t)
-|#
-
 
 
 
diff --git a/eval-and-compile/declaration.lsp b/eval-and-compile/declaration.lsp
index f216e187..22f80108 100644
--- a/eval-and-compile/declaration.lsp
+++ b/eval-and-compile/declaration.lsp
@@ -30,7 +30,9 @@
 ;;; Declare these only if bad declarations produce warnings.
 
 (when (block done
-        (handler-bind ((warning #'(lambda (c) (return-from done t))))
+        (handler-bind ((warning #'(lambda (c)
+                                    (declare (ignore c))
+                                    (return-from done t))))
                       (eval `(let () (declare (,(gensym))) nil))))
 
 (deftest declaration.4
diff --git a/printer/format/format-logical-block.lsp b/printer/format/format-logical-block.lsp
index 7a55daa1..98155f11 100644
--- a/printer/format/format-logical-block.lsp
+++ b/printer/format/format-logical-block.lsp
@@ -111,6 +111,17 @@
   (signals-error-always (format nil "1~<X~<Y~:>Z~>2" nil nil nil) error)
   t t)
 
+;;; "an error is also signaled if the ~<...~:;...~> form of ~<...~> is used
+;;; in the same format string with ~W, ~_, ~<...~:>, ~I, or ~:T."
+
+(deftest format.logical-block.error.26
+  (signals-error-always (format nil "~<~:;~>~<~:>" nil nil nil) error)
+  t t)
+
+(deftest format.logical-block.error.27
+  (signals-error-always (format nil "~<~:>~<~:;~>" nil nil nil) error)
+  t t)
+
 ;;; Non-error tests
 
 (def-pprint-test format.logical-block.1
diff --git a/printer/format/format-t.lsp b/printer/format/format-t.lsp
index 3acdbd50..d1ceb4d4 100644
--- a/printer/format/format-t.lsp
+++ b/printer/format/format-t.lsp
@@ -261,6 +261,20 @@
         collect (list n1 n2 inc s2 result))
   nil)
 
+;;; see 22.3.5.2
+
+(deftest format.\:t.error.1
+  (signals-error-always (format nil "~<XXX~1,1:TYYY~>") error)
+  t t)
+
+(deftest format.\:t.error.2
+  (signals-error-always (format nil "~<XXX~:;YYY~>ZZZ~4,5:tWWW") error)
+  t t)
+
+(deftest format.\:t.error.3
+  (signals-error-always (format nil "AAAA~1,1:TBBB~<XXX~:;YYY~>ZZZ") error)
+  t t)
+
 ;;; ~:@t
 
 (def-pprint-test format.\:@t.1
diff --git a/random/random-int-form.lsp b/random/random-int-form.lsp
index ea599ff7..33764cfa 100644
--- a/random/random-int-form.lsp
+++ b/random/random-int-form.lsp
@@ -5,7 +5,7 @@
 
 (in-package :cl-test)
 
-(compile-and-load* "random-aux.lsp")
+;; (compile-and-load* "random-aux.lsp")
 
 ;;;
 ;;; This file contains a routine for generating random legal Common Lisp functions
@@ -42,21 +42,189 @@
 
 (declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*
                   *opt-result* *unopt-result* $x $y $z
-                  *compile-unoptimized-form*
+                  *compile-unoptimized-form* *require-type-passed*
+                  *default-make-random-integer-form-cdf*
                   *make-random-integer-form-cdf*))
 
+(defvar *mutex* #+sbcl (sb-thread:make-mutex) #-sbcl nil
+        "In SBCL, the mutex used to control output from loop-random-int-forms")
+
+(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 *innocuous-failures* nil)
+
+(defvar *compile-unoptimized-form*
+  #+(or allegro sbcl) t
+  #-(or allegro sbcl) nil)
+
+(declaim (special *vars*))
+
+(defparameter *random-int-form-progress-output* t
+  "When true, random int form testing prints progress output")
+
+(defparameter *fn-state* 0
+  "An integer variable that is used as state of a function in generated forms")
+
+(defun fn-with-state (x)
+  (incf *fn-state* (logand #xffff x)))
+
+(declaim (notinline fn-with-state))
+
+(defparameter *previous-constants* nil
+  "A list of constants previously generated in generating these forms")
+
+(defgeneric make-random-element-of-type (type)
+  (:documentation "Create a random element of a lisp type."))
+
+;; Structure type(s) used in tests
+
+(defparameter *int-structs* nil
+  "List of descriptors (name constructor (initarg accessor type)*) for the
+structures used in random tests.")
+
+(defmacro def-int-struct (tag type &optional (initform 0))
+  (let* ((name (intern (format nil "RIF-STRUCT-~A" tag) :cl-test))
+         (accessor (intern (format nil "~A-N" name) :cl-test))
+         (constructor (intern (format nil "MAKE-~A" name) :cl-test)))
+    `(progn
+       (eval-when (:load-toplevel)
+         (setf (get ',name 'is-int-struct-type) t)
+         (setf (get ',name 'int-struct-accessor) ',accessor)
+         (setf (get ',constructor 'int-struct-constructor-of) ',name)
+         (pushnew '(,name ,constructor (:n ,accessor ,type)) *int-structs* :test #'equal))
+       (defstruct ,name
+         (n ,initform :type ,type))
+       (defmethod make-random-element-of-type ((type (eql ',name)))
+         (,constructor :n (make-random-element-of-type ',type)))
+       )))
+
+(defmethod is-int-struct-type? ((sym symbol))
+  (get sym 'is-int-struct-type))
+
+(defmethod is-int-struct-type? (x)
+  (declare (ignorable x))
+  nil)
+
+(defun int-struct-accessor (sym)
+  (get sym 'int-struct-accessor))
+
+(defmethod is-int-struct-constructor? ((sym symbol))
+  (get sym 'int-struct-constructor-of))
+
+
+(defmethod is-int-struct-constructor? ((op cons))
+  ;; For lambda exprs
+  nil)
+
+(def-int-struct int integer)
+(progn . #.(loop for i from 1 to 64
+              collect `(def-int-struct ,i (unsigned-byte ,i))))
+(progn . #.(loop for i from 2 to 64
+              collect `(def-int-struct ,(format nil "~AS" i) (signed-byte ,i))))
+
+;;; Class used for data
+
+(defclass rif-class-1 ()
+  ((foo :initarg :foo :initform 0 :type integer))
+  (:documentation "Class used for data in random-int-form"))
+
+(defclass rif-class-2 (rif-class-1)
+  ((bar :initarg :bar :initform 0 :type integer))
+  (:documentation "Another class used for data in random-int-form"))
+
+(defclass rif-class-3 (rif-class-1)
+  ((baz :initarg :baz :initform 0 :type integer))
+  (:documentation "Yet another class used for data in random-int-form"))
+
+;;; Execution of tests in multiple threads
+
+(defparameter *threads* nil
+  "List of threads created for random testing")
+
+#+sbcl
+(defun begin-random-int-form-tests (nthreads &rest args)
+  (unless (boundp '$x) (setf $x nil))
+  (unless (boundp '$y) (setf $y nil))
+  (kill)
+  (setf *threads* nil)
+  (loop repeat nthreads
+     do (push (sb-thread:make-thread (lambda () (bind-and-call-lrif args))) *threads*)))
+
+#+sbcl
+(defun kill ()
+  (ignore-errors
+    (mapc #'sb-thread:terminate-thread *threads*))
+  (setf *threads* nil))
+
+
+(defun bind-and-call-lrif (args)
+  (bind-and-call
+   (lambda () (apply #'loop-random-int-forms args))))
+
+(defun bind-and-call (fn)
+  (let ((*random-int-form-progress-output* nil)
+        (*optimized-fn-src* nil)
+        (*unoptimized-fn-src* nil)
+        (*int-form-vals* nil)
+        (*opt-result* nil)
+        (*unopt-result* nil)
+        (*compile-unoptimized-form* *compile-unoptimized-form*)
+        (*make-random-integer-form-cdf* (copy-seq *default-make-random-integer-form-cdf*))
+        *random-int-form-blocks*
+        *random-int-form-catch-tags*
+        *go-tags*
+        (*max-compile-time* 0)
+        (*max-compile-term* nil)
+        *vars*
+        *require-type-passed*
+        )
+    (funcall fn)))
+
 ;;; 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)
 
+(declaim (special *file-lam*))
+
+(defparameter *in-file* nil
+  "When true, COMPILE* defaults to file compilation")
+
+(defun compile* (lam &key (in-file *in-file*))
+  (if in-file
+      (let ((name "tmp.lsp"))
+        (with-open-file (s name :direction :output
+                           :if-exists :supersede
+                           :if-does-not-exist :create)
+          (let ((*package* (find-package :cl-test))
+                (*print-readably* t) (*print-circle* t))
+            (format s "~s~%" '(in-package :cl-test))
+            (format s "(defparameter *file-lam* ~s)~%" lam)
+            (finish-output s)))
+        (multiple-value-bind (fasl warning-p error-p)
+            (compile-file name)
+          (declare (ignore warning-p))
+          (when error-p
+            (error "Error when file compiling ~s" lam))
+          (load fasl)
+          *file-lam*))
+      (compile nil lam)))
+
 (defun f (i) (let ((plist (elt $y i)))
-               (apply (compile nil (getf plist :optimized-lambda-form))
+               (apply (compile* (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))
+                   (apply (compile* (getf plist :unoptimized-lambda-form))
                           (getf plist :vals))
                  (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form))))
                         (getf plist :vals)))))
@@ -84,6 +252,14 @@
 (defmacro cl-handler-case (&rest args)
   `(cl:handler-case ,@args))
 
+;; Condition type for internal test failures
+
+(define-condition internal-test-failure (simple-error)
+  ()
+  (:documentation "Errors internal to the testing process,
+indicating a problem with that process rather than an error
+in the thing being tested.  Should not count as a test failure."))
+
 (eval-when
  (:compile-toplevel :load-toplevel :execute)
  (defun cumulate (vec)
@@ -91,75 +267,199 @@
          do (incf (aref vec i) (aref vec (1- i))))
    vec))
 
+(defstruct symbol-distribution
+  pdf ;; Alist of positive integers . symbols
+  symbols ;; Vector of the symbols in PDF
+  cdf ;; CDF derived from the integers in the cars of the alist pdf
+)
+
+(defun choose-from-symbol-distribution (sd)
+  (assert (typep sd 'symbol-distribution))
+  (let ((a (symbol-distribution-cdf sd)))
+    (unless a
+      (let* ((pdf (symbol-distribution-pdf sd))
+             (len (length pdf))
+             (syms (mapcar #'cdr pdf)))
+        (dolist (x pdf) (assert (typep x '(cons (integer 0) symbol))))
+        (setf a (make-array (list len) :initial-contents (mapcar #'cdr pdf)))
+        (cumulate a)
+        (setf (symbol-distribution-cdf sd) a)
+        (setf (symbol-distribution-symbols sd) syms)))
+    (let* ((len (length a))
+           (max (aref a (1- len)))
+           (r (random max)))
+      ;; Maybe do binary search, but too lazy now
+      (loop for i from 0
+         do (when (< r (aref a i))
+              (aref (symbol-distribution-symbols sd) i))))))
+
 (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))))
+  (cumulate (copy-seq #(10 ;; flet call
+                        5 ;; aref
+                        40 ;; unary ops
+                        4 ;; unwind-protect
+                        #+random-mapping-forms 5  ;; mapping forms
+                        4 ;; prog1, multiple-value-prog1
+                        2 ;; prog2
+                        2 ;;isqrt
+                        10 ;; (the integer ...)
+                        1 ;; handler-bind
+                        1 ;; restart-bind
+                        #-armedbear 1 ;; macrolet
+                        #-armedbear 1;; symbol-macrolet
+                        #-allegro 5 ;; dotimes
+                        50 ;; loop
+                        5 ;; count
+                        #-(or cclasp mutation gcl ecl armedbear) 2 ;; load-time-value
+                        2 ;; eval
+                        #-(or mutation cmu allegro poplog) 5  ;; ash
+                        4 ;; floor, ceiling, truncate, round (binary)
+                        30 ;; general binary ops
+                        4 ;; boole
+                        20 ;; n-ary ops
+                        #-mutation 3 ;; expt
+                        2 ;; coerce
+                        #-cclasp 2 ;; complex (degenerate case)
+                        1 ;; quotient (1)
+                        1 ;; quotient (-1)
+                        50 ;; tagbody
+                        60 ;; conditional
+                        #-(or mutation poplog) 5 ;; deposit-field, dpb
+                        #-(or mutation allegro poplog) 10 ;; ldb, mask-field
+                        50 ;; binding form
+                        4 ;; progv
+                        4 ;; (let () ...)
+                        10 ;; block
+                        20 ;; catch
+                        10 ;; setq and similar
+                        50 ;; case form
+                        3 ;; return-from
+                        20 ;; catch
+                        5 #-(or armedbear) 20
+                        2 2 2
+                        5 ;; identity-notinline
+                        4 ;; fn-with-state
+                        #+sbcl
+                        2 ;; Example of sb ffi call
+                        10 ;; m-v-b-if
+                        #-abcl 5 ;; inlined lambda
+                        10 ;; stacked comparisons
+                        20 ;; Non-integer forms (only when TOP? is true)
+                        ))))
 
 (defparameter *make-random-integer-form-cdf*
   (copy-seq *default-make-random-integer-form-cdf*))
 
 (eval-when
  (:compile-toplevel :load-toplevel :execute)
+  ;; Create random weight instead of using the default ones
  (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)))
+             (,vec (make-array ,len :initial-element 0)))
+        #|
         (loop for i from 0 below ,len do (setf (aref ,vec i)
                                                (1+ (min (random 100)
                                                         (random 100)))))
+        |#
+        (loop repeat 15
+           do (let ((i (random ,len)))
+                (setf (aref ,vec i) (random 100))))
         (setq ,vec (cumulate ,vec))
         (let ((*make-random-integer-form-cdf* ,vec))
           ,@forms)))))
 
+(defun identity-notinline (x) x)
+(declaim (notinline identity-notinline))
+
+;; Macro used to get values out from worker threads
+(defmacro atomic-append-to (var tail)
+  #+sbcl
+  `(sb-thread:with-mutex (*mutex*)
+     (setf ,var (append ,var ,tail)))
+  #-sbcl
+  `(setf ,var (append ,var ,tail)))
+
 ;;; Run the random tester, collecting failures into the special
 ;;; variable $y.
 
-(defun loop-random-int-forms (&optional (size 200) (nvars 3))
+(defun loop-random-int-forms (&optional (size 200) (nvars 3) (max-iter nil)
+                                (int-form-fn #'make-random-form))
   (unless (boundp '$x) (setq $x nil))
   (unless (boundp '$y) (setq $y nil))
   (loop
    for i from 1
+     while (or (null max-iter) (>= max-iter i))
    do
-   (format t "~6D | " i)
-   (finish-output *standard-output*)
+       (when *random-int-form-progress-output*
+         (format t "~:[ ~;*~]~6D | " $x i)
+         (finish-output *standard-output*))
+       ;; Under WSL, interrupts sometimes become disabled.
+       ;; Throwing and catching an error clears this.
+       #+sbcl
+       (handler-case (error "foo") (error ()))
    (let ((x (test-random-integer-forms
              size nvars *loop-random-int-form-period*
-             :index (* (1- i) *loop-random-int-form-period*))))
+                 :index (* (1- i) *loop-random-int-form-period*)
+                 :int-form-fn int-form-fn
+                 )))
      (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*))
+           (atomic-append-to $x x)
+           (let ((pruned-x (prune-results x)))
+             (terpri) (print pruned-x) (finish-output *standard-output*)
+             (atomic-append-to $y pruned-x)
+             ))
+         (when *random-int-form-progress-output*
+           (terpri)))))
 
 (defstruct var-desc
   (name nil :type symbol)
   (type t))
 
+(defmacro int-restrict (form tp)
+  (cond
+    ((member tp '(integer (integer) (integer *) (integer * *)) :test 'equal)
+     form)
+    ((and (consp tp) (eql (car tp) 'integer) (integerp (cadr tp)) (integerp (caddr tp)))
+     (let ((lo (cadr tp))
+           (hi (caddr tp)))
+       `(min ,hi (max ,lo ,form))))
+    (t (error "Cannot handle this type in int-restrict: ~A" tp))))
+
+(define-condition innocuous-failure (simple-condition) ()
+  (:documentation "Failures that, when they occur, do not indicate the test failed"))
+
+(define-condition require-failure (innocuous-failure) ()
+  (:documentation "Error signalled by REQUIRE-TYPE when the value is not of the specified
+type.  This is intended to indicate that the test is bogus, not failed."))
+
+(defparameter *require-type-passed* t
+  "Set to true when CHECK-REQUIRE-TYPE succeeded. Used to indicate that checks
+should be removed.")
+
+(defun check-require-type (v tp)
+  (if (typep v tp)
+      (setf *require-type-passed* t)
+      (signal (make-condition 'require-failure
+                              :format-control "~a not of type ~a"
+                              :format-arguments (list v tp)))))
+
+(defvar *no-require-type* nil
+  "Controls whether REQUIRE-TYPE inserts a type check or not")
+
+(defmacro require-type (form tp)
+  "When FORM is not of type TP, signal a REQUIRE-FAILURE condition that indicates
+the test was bad.  When the special variable *NO-REQUIRE-TYPE* is true, omit
+the check."
+  (if *no-require-type*
+      form
+      (let ((form-var (gensym)) (tp-var (gensym)))
+        `(let ((,form-var ,form)
+               (,tp-var ',tp))
+           (check-require-type ,form-var ,tp-var)
+           ,form-var))))
+
 (defun test-random-integer-forms
   (size nvars n
         &key ((:random-state *random-state*) (make-random-state t))
@@ -167,6 +467,7 @@
         (index 0)
         (random-size nil)
         (random-nvars nil)
+        (int-form-fn #'make-random-integer-form)
         )
 
   "Generate random integer forms of size SIZE with NVARS variables.
@@ -174,12 +475,14 @@
    is found between optimized and nonoptimize, notinlined code."
 
   (assert (integerp nvars))
-  (assert (<= 1 nvars 26))
+  (assert (<= 0 nvars 26))
+  (assert (if random-nvars (> nvars 0) t))
   (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)
+     do (when (and *random-int-form-progress-output*
+                   (= (mod i 100) 0))
               ;; #+sbcl (print "Do gc...")
               ;; #+sbcl (sb-ext::gc :full t)
               ;; #+lispworks-personal-edition (cl-user::normal-gc)
@@ -188,25 +491,56 @@
                               (if random-size (1+ (random size)) size)
                               (if random-nvars (1+ (random nvars)) nvars)
                               :index (+ index i)
-                              :file-prefix file-prefix)))
+                              :file-prefix file-prefix
+                              :int-form-fn int-form-fn
+                              )))
                  (when result
                    (let ((*print-readably* nil))
                      (format t "~%~A~%" (format nil "~S" (car result)))
                      (finish-output *standard-output*)))
                  result)))
 
+(defun widen-integer-type (type)
+  "Expand types of the form (integer lo hi) into various random supertypes"
+  (if (and (consp type)
+           (eql (car type) 'integer)
+           (integerp (cadr type))
+           (integerp (caddr type)))
+      (rcase
+        (5 t)
+        (1 'number)
+        (1 'real)
+        (1 'integer)
+        (1 `(integer ,(cadr type)))
+        (1 `(integer * ,(caddr type)))
+        (30 type))
+      type))
+
 (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))
+    (size nvars &key (index 0) (file-prefix "b")
+                  (int-form-fn #'make-random-integer-form))
+  (let* ((*previous-constants* nil)
+         (vars (make-vars nvars))
+         (var-types (make-var-types nvars))
+         #|(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 (loop repeat nvars
+                         collect #'(lambda (range)
+                                     (rcase
+                                       (1 'boolean)
+                                       (2
+                                        (let* ((range (make-random-integer-range))
+                                               (lo (car range))
                                       (hi (cadr range)))
                                   (assert (>= hi lo))
-                                  `(integer ,lo ,hi)))
-                            var-ranges))
-         (form (let ((*vars* (loop for v in vars
+                                          `(integer ,lo ,hi)))))))
+         |#
+         (widened-var-types (mapcar #'widen-integer-type var-types))
+         (form (make-form size :int-form-fn int-form-fn :vars vars :var-types var-types :nvars nvars))
+         #|
+         (let ((*vars* (loop for v in vars
                                    for tp in var-types
                                    collect (make-var-desc :name v
                                                           :type tp)))
@@ -215,21 +549,14 @@
                      (*go-tags* nil)
                      )
                  (with-random-integer-form-params
-                  (make-random-integer-form (1+ (random size))))))
+                   (funcall int-form-fn (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)))
+                collect (mapcar #'make-random-element-of-type var-types)))
          (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)
+    (labels ((%print (s &aux (*print-pretty* nil))
        (print `(defparameter *x*
                  '(:vars ,vars
                       :var-types ,var-types
@@ -239,11 +566,61 @@
                       :form ,form))
               s)
        (print '(load "c.lsp") s)
-       (finish-output s))
-       ;; (cl-user::gc)
-       ;; (make-list 1000000)
+               (force-output s))
+             (%print-to-file (name)
+               (with-open-file (s name
+                                  :direction :output :if-exists :supersede
+                                  :if-does-not-exist :create)
+                 (%print s))))
+      (case *print-immediately*
+        (:term (%print *standard-output*))
+        (:single (%print-to-file (format nil "~A.lsp" file-prefix)))
+        ((nil))
+        (t (%print-to-file (format nil "~A~A.lsp" file-prefix index)))))
+    (test-int-form form vars widened-var-types vals-list opt-decls-1 opt-decls-2)))
+
+(defun make-form (size &key (int-form-fn #'make-random-integer-form) vars var-types nvars)
+  (unless (and nvars (eql (length vars) nvars))
+    (setf vars (make-vars nvars))
+    (setf var-types (make-var-types nvars)))
+  (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)
       )
-    (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2)))
+    (with-random-integer-form-params
+      (funcall int-form-fn (1+ (random size))))))
+
+(defun make-vars (nvars)
+  (assert (typep nvars '(integer 0 25)))
+  (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))
+
+(defun make-var-types (nvars)
+  (let ((bool? (coin)))
+  (loop repeat nvars
+     collect (if (and bool? (coin 3))
+                 'boolean
+                 (let* ((range (make-random-integer-range))
+                        (lo (car range))
+                        (hi (cadr range)))
+                   (assert (>= hi lo))
+                   `(integer ,lo ,hi))))))
+
+(defun tif (result)
+  (let* ((form (getf result :form))
+         (vars (getf result :vars))
+         (var-types (getf result :var-types))
+         (vals-list (or (getf result :vals-list)
+                        (list (getf result :vals))))
+         (opt-decl-1 (getf result :decls1))
+         (opt-decl-2 (getf result :decls2))
+         (result2 (test-int-form form vars var-types
+                                 vals-list opt-decl-1 opt-decl-2)))
+    result2))
 
 (defun make-random-optimize-settings ()
   (loop for settings = (list*
@@ -280,8 +657,6 @@
 (declaim (special *flet-names*))
 (defparameter *flet-names* nil)
 
-
-
 (defun random-var-desc ()
   (loop
    (let* ((pos (random (length *vars*)))
@@ -301,20 +676,49 @@
        (or (eql (caddr type) 0)
            (null (caddr type)))))
 
-(defun make-random-integer-form (size)
-  "Generate a random legal lisp form of size SIZE (roughly)."
-
+(defparameter *make-error-forms* nil
+  "When true, cause MAKE-RANDOM-INTEGER-FORM to sometimes
+generate (COMPILE-TIME-ERROR) form.  The presence of this form
+causes the compiler to abort, so the pruner should simplify
+the form to just it.  If this does not happen, the pruner could
+be improved.  If this variable is a real in the range [0,1] then
+use it as a probability for actually generating an error
+form, multiplied by the base probability.")
+
+(defmacro compile-time-error (&rest args)
+  (declare (ignore args))
+  (error "Compile time error"))
+
+(defun make-random-form (size)
+  (make-random-integer-form size t))
+
+(defun make-random-integer-form (size &optional top?)
+  "Generate a random legal lisp form of size SIZE (roughly).
+If TOP? is true the value needn't be an integer, so relax
+the constraints a bit."
   (if (<= size 1)
       ;; Leaf node -- generate a variable, constant, or flet function call
       (loop
        when
        (rcase
-        (10 (make-random-integer))
+        ;; Generate error forms to test the pruner
+        (1 (when (and *make-error-forms*
+                      (or (not (typep *make-error-forms* '(real 0 1)))
+                          (<= (random 1.0) *make-error-forms*)))
+             '(compile-time-error)))
+         (10
+          (if (and *previous-constants* (coin 3))
+              (random-from-seq *previous-constants*)
+              (let ((i (make-random-integer)))
+                (push i *previous-constants*)
+                i)))
         (9 (if *vars*
                (let* ((desc (random-var-desc))
                       (type (var-desc-type desc))
                       (name (var-desc-name desc)))
                  (cond
+                  ((is-int-struct-type? type)
+                   `(,(int-struct-accessor type) ,name))
                   ((subtypep type 'integer) name)
                   (; (subtypep type '(array integer 0))
                    (is-zero-rank-integer-array-type type)
@@ -322,9 +726,16 @@
                   ((subtypep type '(cons integer integer))
                    (rcase (1 `(car ,name))
                           (1 `(cdr ,name))))
+                  ((subtypep type 'boolean)
+                   (let ((v1 (make-random-integer))
+                         (v2 (make-random-integer)))
+                     `(if ,name ,v1 ,v2)))
                   (t nil)))
              nil))
-        (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil))
+        (1 (if *innocuous-failures*
+               `(error 'innocuous-failure)
+               nil))
+        (5 (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))
@@ -356,32 +767,39 @@
                                      locally))))
         `(,op ,(make-random-integer-form (1- size))))
 
-     (make-random-integer-unwind-protect-form size)
+     (make-random-integer-unwind-protect-form size top?)
+
+     ;; These were causing timeouts in some large functions,
+     ;; so I've conditionalized it
+     #+random-mapping-forms
      (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))
+            (arg1 (make-random-integer-form (first sizes) top?))
+            (other-args (mapcar #'make-random-form (cdr sizes))))
+       `(,op ,arg1 ,@other-args))
 
      ;; prog2
      (let* ((nforms (random 4))
             (sizes (random-partition (1- size) (+ nforms 2)))
-            (args (mapcar #'make-random-integer-form sizes)))
-       `(prog2 ,@args))
+            (arg1 (make-random-form (first sizes)))
+            (arg2 (make-random-integer-form (second sizes) top?))
+            (other-args (mapcar #'make-random-form (cddr sizes))))
+       `(prog2 ,arg1 ,arg2 ,@other-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)))
+     `(cl:handler-bind nil ,(make-random-integer-form (1- size) top?))
+     `(restart-bind nil ,(make-random-integer-form (1- size) top?))
      #-armedbear
-     `(macrolet () ,(make-random-integer-form (1- size)))
+     `(macrolet () ,(make-random-integer-form (1- size) top?))
      #-armedbear
-     `(symbol-macrolet () ,(make-random-integer-form (1- size)))
+     `(symbol-macrolet () ,(make-random-integer-form (1- size) top?))
 
      ;; dotimes
      #-allegro
@@ -390,17 +808,17 @@
             (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))))
+                    (make-random-form (first sizes))))
+            (ret-form (make-random-integer-form (second sizes) top?)))
        (unless (consp body) (setq body `(progn ,body)))
        `(dotimes (,var ,count ,ret-form) ,body))
 
      ;; loop
-     (make-random-loop-form (1- size))
+     (make-random-loop-form (1- size) top?)
 
      (make-random-count-form size)
 
-     #-(or gcl ecl armedbear)
+     #-(or cclasp mutation gcl ecl armedbear)
      ;; load-time-value
      (let ((arg (let ((*flet-names* nil)
                       (*vars* nil)
@@ -414,9 +832,9 @@
         (2 `(load-time-value ,arg nil))))
 
      ;; eval
-     (make-random-integer-eval-form size)
+     (make-random-integer-eval-form size top?)
 
-     #-(or cmu allegro poplog)
+     #-(or mutation cmu allegro poplog)
      (destructuring-bind (s1 s2)
         (random-partition (- size 2) 2)
         `(ash ,(make-random-integer-form s1)
@@ -473,12 +891,14 @@
         `(,op ,@args))
 
      ;; expt
+     #-mutation
      `(expt ,(make-random-integer-form (1- size)) ,(random 3))
 
      ;; coerce
      `(coerce ,(make-random-integer-form (1- size)) 'integer)
 
      ;; complex (degenerate case)
+     #-cclasp
      `(complex ,(make-random-integer-form (1- size)) 0)
 
      ;; quotient (degenerate cases)
@@ -486,75 +906,75 @@
      `(/ ,(make-random-integer-form (1- size)) -1)
 
      ;; tagbody
-     (make-random-tagbody-and-progn size)
+     (make-random-tagbody-and-progn size top?)
 
      ;; 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)))
+            (then-part (make-random-integer-form then-size top?))
+            (else-part (make-random-integer-form else-size top?)))
        `(if ,pred ,then-part ,else-part))
-     #-poplog
+     #-(or poplog mutation)
       (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)
+     #-(or mutation 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)
+     (make-random-integer-binding-form size top?)
 
      ;; progv
-     (make-random-integer-progv-form size)
+     (make-random-integer-progv-form size top?)
 
      `(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))))
+       `(block ,name ,(make-random-integer-form (1- size) top?)))
 
       (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))))
+        `(catch ,tag ,(make-random-integer-form (1- size) top?)))
 
       ;; setq and similar
       (make-random-integer-setq-form size)
 
-      (make-random-integer-case-form size)
+      (make-random-integer-case-form size top?)
 
       (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))
+        (make-random-integer-form size top?))
 
       (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))
+        (make-random-integer-form size top?))
 
       (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)))
+                  (else (make-random-integer-form s3 top?)))
               `(if ,pred (return-from ,name ,then) ,else)))
         ;; No blocks -- try again
-        (make-random-integer-form size))
+        (make-random-integer-form size top?))
 
      #-(or armedbear)
-     (make-random-flet-form size)
+     (make-random-flet-form size top?)
 
       (let* ((nbits (1+ (min (random 20) (random 20))))
              (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector))
@@ -573,8 +993,39 @@
              (op 'elt))
         `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))
 
+      `(identity-notinline ,(make-random-integer-form (1- size) top?))
+
+      `(fn-with-state ,(make-random-integer-form (1- size)))
+
+      #+sbcl
+      (if (< size 3)
+          (sb-alien:alien-funcall
+           (sb-alien:extern-alien "os_get_errno" (function sb-alien:int)))
+          (make-random-integer-form size))
+
+      ;; mvb-if
+      (make-random-mvb-if-form size top?)
+
+      ;; inlined lambda
+      #-abcl
+      (make-random-inline-lambda-form size top?)
+
+      ;; Stacked comparisons
+      (make-stacked-comparison-form size top?)
+
+      ;; Non-integer forms
+      (if top? (make-possibly-non-integer-form size)
+          (make-random-integer-form size))
+
      )))
 
+(defun make-possibly-non-integer-form (size)
+  (let* ((cond-size (random (max 1 (floor size 2))))
+         (cond (make-random-pred-form cond-size))
+         (body-form (make-random-form (- size cond-size)))
+         (op (rcase (1 'when) (1 'unless))))
+    `(,op ,cond ,body-form)))
+
 (defun make-random-aref-form (size)
   (or
    (when *vars*
@@ -640,11 +1091,11 @@
          (t (make-random-integer-form size))))
     (make-random-integer-form size)))
 
-(defun make-random-integer-unwind-protect-form (size)
+(defun make-random-integer-unwind-protect-form (size top?)
   (let* ((op 'unwind-protect)
          (nforms (random 4))
          (sizes (random-partition (1- size) (1+ nforms)))
-         (arg (make-random-integer-form (first sizes)))
+         (arg (make-random-integer-form (first sizes) top?))
          (unwind-forms
           ;; We have to be careful not to generate code that will
           ;; illegally transfer control to a dead location
@@ -652,10 +1103,10 @@
                 (*go-tags* nil)
                 (*random-int-form-blocks* nil)
                 (*random-int-form-catch-tags* nil))
-            (mapcar #'make-random-integer-form (rest sizes)))))
+            (mapcar #'make-random-form (rest sizes)))))
     `(,op ,arg ,@unwind-forms)))
 
-(defun make-random-integer-eval-form (size)
+(defun make-random-integer-eval-form (size top?)
   (flet ((%arg (size)
                (let ((*flet-names* nil)
                      (*vars* (remove-if-not #'(lambda (s)
@@ -664,7 +1115,7 @@
                                             *vars*))
                      (*random-int-form-blocks* nil)
                      (*go-tags* nil))
-                 (make-random-integer-form size))))
+                 (make-random-integer-form size top?))))
     (rcase
      (2 `(eval ',(%arg (1- size))))
      (2 (let* ((nargs (1+ (random 4)))
@@ -681,10 +1132,12 @@
             (setq desc (find var *vars* :key #'var-desc-name)))
        (var-desc-type desc))
       (t (rcase
-          (4 '(integer * *))
+          (8 '(integer * *))
+          #-mutation
           (1 (setq e1 `(make-array nil :initial-element ,e1
                                    ,@(rcase (1 nil) (1 '(:adjustable t)))))
              '(array integer nil))
+          #-mutation
           (1 (let ((size (1+ (random 10))))
                (setq e1 `(make-array '(,size):initial-element ,e1
                                      ,@(rcase (1 nil) (1 '(:adjustable t)))))
@@ -696,6 +1149,25 @@
                                      ,@(rcase (1 nil) (1 '(:adjustable t)))))
                `(array integer (,size1 ,size2))))
           |#
+          #+(or)
+          (1 (setq e1 `(make-rif-struct-int :n ,e1))
+             'rif-struct-int)
+          (1 (let* ((struct-descriptor (random-from-seq *int-structs*))
+                    (name (car struct-descriptor))
+                    (constructor (cadr struct-descriptor))
+                    (fields (cddr struct-descriptor))
+                    (field (random-from-seq fields)))
+               (destructuring-bind (initarg accessor type)
+                   field
+                 (declare (ignore accessor))
+                 (let* ((value (make-random-element-of-type type))
+                        (value-form (if (or (consp value)
+                                            (and (symbolp value)
+                                                 (not (constantp value))))
+                                        `(quote ,value)
+                                        value)))
+                   (setq e1 `(,constructor ,initarg ,value-form))
+                   name))))
           (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1)))
              '(cons integer integer))
           (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1))
@@ -708,7 +1180,42 @@
 (defun random-from-seq2 (seq)
   (elt seq (random2 (length seq))))
 
-(defun make-random-integer-binding-form (size)
+(defmacro mvb-if (vars pred true-exprs false-exprs &body body)
+  (assert (listp vars))
+  (assert (every #'symbolp vars))
+  (assert (listp true-exprs))
+  (assert (listp false-exprs))
+  (assert (= (length vars) (length true-exprs) (length false-exprs)))
+  `(multiple-value-bind ,vars
+       (if ,pred
+           (values ,@true-exprs)
+           (values ,@false-exprs))
+     ,@body))
+
+(defun make-random-mvb-if-form (size top?)
+  (let* ((nvars (+ 2 (random 3)))
+         (vars (let ((var-list '(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
+                 (loop repeat nvars
+                    collect (let ((v (random-from-seq var-list)))
+                              (setq var-list (remove v var-list))
+                              v)))))
+    (destructuring-bind (sh sb)
+        (random-partition (1- size) 2)
+      (destructuring-bind (sp s1 s2)
+          (random-partition sh 3)
+        (let* ((true-sizes (random-partition s1 nvars))
+               (false-sizes (random-partition s2 nvars))
+               (pred (make-random-pred-form sp))
+               (true-exprs (mapcar #'make-random-integer-form true-sizes))
+               (false-exprs (mapcar #'make-random-integer-form false-sizes))
+               (body-expr (let ((*vars* (append
+                                         (loop for v in vars
+                                            collect (make-var-desc :name v :type 'integer))
+                                         *vars*)))
+                            (make-random-integer-form sb top?))))
+          `(mvb-if ,vars ,pred ,true-exprs ,false-exprs ,body-expr))))))
+
+(defun make-random-integer-binding-form (size top?)
   (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))
@@ -721,7 +1228,7 @@
                    type2))
            (e2 (let ((*vars* (cons (make-var-desc :name var :type type)
                                    *vars*)))
-                 (make-random-integer-form s2)))
+                 (make-random-integer-form s2 top?)))
            (op (random-from-seq #(let let*))))
       ;; for now, avoid shadowing
       (if (member var *vars* :key #'var-desc-name)
@@ -733,7 +1240,65 @@
                   ,e2))
          (2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
 
-(defun make-random-integer-progv-form (size)
+(defun make-random-inline-lambda-form (size top?)
+  (destructuring-bind (sform svars) (random-partition (1- size) 2)
+    (let* ((nvars (random 4))
+           (vars (let ((seq '(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
+                   (assert (<= nvars (length seq)))
+                   (loop repeat nvars
+                      collect (let ((x (random-from-seq seq)))
+                                (setf seq (remove x seq))
+                                x))))
+           (var-sizes (when (> nvars 0) (random-partition svars nvars)))
+           (arg-exprs (mapcar #'make-random-integer-form var-sizes))
+           (e1 (let ((*vars*
+                      (append (mapcar (lambda (v) (make-var-desc :name v :type 'integer)) vars)
+                              *vars*)))
+                 (make-random-integer-form sform top?)))
+           (rest? (coin 2)))
+      `((lambda (,@vars ,@(when rest? '(&rest args)))
+          ,e1)
+        ,@arg-exprs))))
+
+(defun make-stacked-comparison-form (size top?)
+  "This exercises compiler optimizations that remove redundant comparisons
+of the same values"
+  (let* ((sizes (random-partition (max 5 (1- size)) 5))
+         (vars '#(v1 v2 v3 v4 v5 v6 v7 v8 v9))
+         (v1 (random-from-seq vars))
+         (v2 (loop (let ((x (random-from-seq vars)))
+                     (unless (eql v1 x) (return x)))))
+         (op1 (random-from-seq #(= /= < <= > >=)))
+         (op2 (random-from-seq #(= /= < <= > >=)))
+         (f1 (make-random-integer-form (car sizes)))
+         (f2 (make-random-integer-form (cadr sizes)))
+         (forms (let ((*vars*
+                       (list* (make-var-desc :name v1 :type 'integer)
+                              (make-var-desc :name v2 :type 'integer)
+                              *vars*)))
+                  (mapcar (lambda (s) (make-random-integer-form s top?))
+                          (cddr sizes)))))
+    (flet ((%c (op)
+             (if (coin)
+                 `(,op ,v1 ,v2)
+                 `(,op ,v2 ,v1))))
+      (destructuring-bind (f3 f4 f5)
+          forms
+        (if (coin 2)
+            `(let ((,v1 ,f1)
+                   (,v2 ,f2))
+               (if ,(%c op1)
+                   (if ,(%c op2)
+                       ,f3 ,f4)
+                   ,f5))
+            `(let ((,v1 ,f1)
+                   (,v2 ,f2))
+               (if ,(%c op1)
+                   ,f3
+                   (if ,(%c op2)
+                       ,f4 ,f5))))))))
+
+(defun make-random-integer-progv-form (size top?)
   (let* ((num-vars (random 4))
          (possible-vars *random-special-vars*)
          (vars nil))
@@ -753,7 +1318,7 @@
                (*vars* (append (loop for v in vars collect
                                      (make-var-desc :name v :type '(integer * *)))
                                *vars*))
-               (body-form (make-random-integer-form s2)))
+               (body-form (make-random-integer-form s2 top?)))
           `(progv ',vars (list ,@var-forms) ,body-form))))))
 
 (defun make-random-integer-mapping-form (size)
@@ -828,7 +1393,11 @@
            (1 (setq op 'multiple-value-setq)
               (setq var (list var)))
            (5 nil))
-          `(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
+          (rcase
+            (1 `(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
+            (1 `(,op ,var (int-restrict ,(make-random-integer-form (1- size)) ,type)))
+            (1 `(,op ,var (require-type ,(make-random-integer-form (1- size)) ,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)
@@ -859,8 +1428,11 @@
     (make-random-integer-form size)))
 
 
-(defun make-random-integer-case-form (size)
-  (let ((ncases (1+ (random 10))))
+(defun make-random-integer-case-form (size top?)
+  (let ((ncases (1+ (random 10)))
+        (non-int-rate  (rcase (1 0.0) (1 (min (random 1.0) (random 1.0)))))
+        (non-int-type (random-from-seq #(base-char character symbol float complex
+                                         (or base-char character symbol float complex)))))
     (if (< (+ size size) (+ ncases 2))
         ;; Too small, give up
         (make-random-integer-form size)
@@ -874,21 +1446,29 @@
               (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)
+                             collect (if (>= (random 1.0) non-int-rate)
+                                         (random-from-interval
+                                          upper-bound lower-bound)
+                                         (make-random-element-of-type
+                                          non-int-type)))
+               for result = (make-random-integer-form case-size top?)
                repeat ncases
                collect `(,vals ,result)))
              (expr (make-random-integer-form (first sizes))))
         `(case ,expr
            ,@cases
-           (t ,(make-random-integer-form (second sizes))))))))
+           (t ,(make-random-integer-form (second sizes) top?)))))))
 
-(defun make-random-flet-form (size)
+(defparameter +flet-symbols+ #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10
+                               %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))
+
+(defun is-flet-symbol (sym)
+  (find sym +flet-symbols+))
+
+(defun make-random-flet-form (size top?)
   "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))))
+  (let ((fname (random-from-seq +flet-symbols+)))
     (if (assoc fname *flet-names*)
         ;; Fail if the name is in use
         (make-random-integer-form size)
@@ -923,7 +1503,18 @@
                     (make-random-integer-form s1)))
                  (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p)
                                                   *flet-names*)))
-                          (make-random-integer-form s2)))
+                          (make-random-integer-form s2 top?)))
+                 (decl-forms
+                  (append
+                   (rcase
+                     (2 nil)
+                     (1 `((declare (notinline ,fname))))
+                     (1 (when (<= (count-in-tree fname form2) 1)
+                          `((declare (inline ,fname))))))
+                   #-gcl
+                   (rcase
+                     (2 nil)
+                     (1 `((declare (dynamic-extent (function ,fname))))))))
                  (opt-forms (mapcar #'make-random-integer-form opt-sizes)
                             ))
             (if opt-forms
@@ -940,6 +1531,7 @@
                                               (when allow-other-keys '(&allow-other-keys))
                                               )))
                                ,form1))
+                      ,@decl-forms
                       ,form2)
               `(,op ((,fname (,@arg-names
                               ,@(when keyarg-p
@@ -950,10 +1542,11 @@
                                           (when allow-other-keys '(&allow-other-keys))
                                           )))
                              ,form1))
+                    ,@decl-forms
                     ,form2))))))))
 
 (defun make-random-tagbody (size)
-  (let* ((num-forms (random 6))
+  (let* ((num-forms (random 12))
          (tags nil))
     (loop for i below num-forms
           do (loop for tag = (rcase
@@ -970,16 +1563,16 @@
                   for i below num-forms
                   for size in sizes
                   collect (let ((*go-tags* (append tag-list *go-tags*)))
-                            (make-random-integer-form size)))))
+                            (make-random-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)
+(defun make-random-tagbody-and-progn (size top?)
   (let* ((final-size (random (max 1 (floor size 5))))
          (tagbody-size (- size final-size)))
-    (let ((final-form (make-random-integer-form final-size))
+    (let ((final-form (make-random-integer-form final-size top?))
           (tagbody-form (make-random-tagbody tagbody-size)))
       `(progn ,tagbody-form ,final-form))))
 
@@ -988,6 +1581,11 @@
   (if (<= size 1)
       (rcase
         (1 (if (coin) t nil))
+        (1 (let ((bool-vars (remove 'boolean *vars* :key #'var-desc-type
+                                    :test-not #'eql)))
+             (if bool-vars
+                 (var-desc-name (random-from-seq bool-vars))
+                 (make-random-pred-form size))))
         (2
          `(,(random-from-seq '(< <= = > >= /= eql equal))
            ,(make-random-integer-form size)
@@ -1012,7 +1610,7 @@
                 (then-part (make-random-pred-form then-size))
                 (else-part (make-random-pred-form else-size)))
            `(if ,pred ,then-part ,else-part)))
-      #-poplog
+      #-(or mutation poplog)
       (1 (destructuring-bind (s1 s2)
              (random-partition (1- size) 2)
            `(ldb-test ,(make-random-byte-spec-form s1)
@@ -1060,9 +1658,9 @@
          `(typep ,subform ',type)))
       )))
 
-(defun make-random-loop-form (size)
+(defun make-random-loop-form (size top?)
   (if (<= size 2)
-      (make-random-integer-form size)
+      (make-random-integer-form size top?)
     (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4)))
            (count (random 4))
            (*vars* (cons (make-var-desc :name var :type nil)
@@ -1078,22 +1676,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 'satisfies)) type-args)
+    (assert (= (length type-args) 1))
+    (ecase (car type-args)
+      (eval (make-random-element-of-type '(and t (not list))))
+      (identity (make-random-element-of-type '(and t (not null))))
+      (null nil)
+      (t (make-random-element-of-type `(and t (satisfies ,(car 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))
+    (let ((len (length type-args)))
+      (block done
+        (loop for i from 0 below len
+           do (let ((tp (elt type-args i))
+                    (rest (remove-nth type-args i)))
+                (loop for x = (make-random-element-of-type tp)
              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))))
+                   do (when (typep x (cons 'and rest))
+                        (return-from done x))))
+           finally (let ((e (make-condition 'internal-test-failure
+                                            :format-control "Cannot generate random element of ~A"
+                                            :format-arguments (list (cons type-op type-args)))))
+                     (error e))))))
   (:method ((type-op (eql 'not)) type-args)
            (assert (eql (length type-args) 1))
            (make-random-element-of-type `(and t (not ,(car type-args)))))
@@ -1131,7 +1740,8 @@
                     (hi (cadr type-args))
                     lo= hi=)
                 (cond
-                 ((consp lo) nil)
+                  ((consp lo)
+                   (setq lo (car lo)))
                  ((member lo '(* nil))
                   (setq lo nil)
                   (setq lo= nil))
@@ -1139,7 +1749,8 @@
                   (assert (typep lo 'rational))
                   (setq lo= t)))
                 (cond
-                 ((consp hi) nil)
+                  ((consp hi)
+                   (setq hi (car hi)))
                  ((member hi '(* nil))
                   (setq hi nil)
                   (setq hi= nil))
@@ -1148,6 +1759,7 @@
                   (setq hi= t)))
                 (assert (or (null lo) (null hi) (<= lo hi)))
                 (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=)))
+                (let ((result
                 (cond
                  ((null lo)
                   (cond
@@ -1159,7 +1771,10 @@
                    (lo= (+ lo (make-random-nonnegative-rational)))
                    (t (+ lo (make-random-positive-rational)))))
                  (t
-                  (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))))
+                           (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))
+                  (if (typep result `(rational ,@type-args))
+                      result
+                      (make-random-element-of-compound-type type-op type-args)))))))
 
   (:method ((type-op (eql 'ratio)) type-args)
            (let ((r 0))
@@ -1217,7 +1832,7 @@
            (apply #'make-random-element-of-float-type type-op type-args))
 
   (:method ((type-op (eql 'mod)) type-args)
-           (let ((modulus (second type-args)))
+    (let ((modulus (first type-args)))
              (assert (integerp modulus))
              (assert (plusp modulus))
              (make-random-element-of-compound-type 'integer `(0 (,modulus)))))
@@ -1260,7 +1875,7 @@
                  (size-spec (if (cdr type-args) (cadr type-args) '*)))
              (make-random-vector etype-spec size-spec)))
 
-  (:method ((type-op (eql 'aimple-vector)) type-args)
+  (:method ((type-op (eql 'simple-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)))
@@ -1332,7 +1947,9 @@
 (defun make-random-element-of-float-type (type-op &optional lo hi)
   (let (lo= hi=)
     (cond
-     ((consp lo) nil)
+      ((consp lo)
+       (setf lo (car lo))
+       (assert (realp lo)))
      ((member lo '(* nil))
       (setq lo (most-negative-float type-op))
       (setq lo= t))
@@ -1340,7 +1957,9 @@
       (assert (typep lo type-op))
       (setq lo= t)))
     (cond
-     ((consp hi) nil)
+      ((consp hi)
+       (setf hi (car hi))
+       (assert (realp hi)))
      ((member hi '(* nil))
       (setq hi (most-positive-float type-op))
       (setq hi= t))
@@ -1591,6 +2210,8 @@
 (defmethod make-random-element-of-type ((type class))
   (make-random-element-of-type (class-name type)))
 
+(defmethod make-random-element-of-type ((type (eql 'package)))
+  (find-package (random-from-seq #(:keyword :cl-user :cl :cl-test))))
 (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)))
@@ -1649,6 +2270,11 @@
 (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 'bignum)))
+  (let ((m (ash 1 (random 32))))
+    (if (coin)
+        (+ most-positive-fixnum 1 (random m))
+        (- most-negative-fixnum 1 (random m)))))
 (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)))
@@ -1680,6 +2306,58 @@
    (t (call-next-method type))
    ))
 
+(defmethod make-random-element-of-type ((type (eql 'structure-object)))
+  (make-random-element-of-type (car (random-from-seq *int-structs*))))
+
+(defmethod make-random-element-of-type ((type (eql t)))
+  (make-random-element-of-type
+   (rcase
+     (10 'real)
+     (10 'symbol)
+     (10 'boolean)
+     (10 (rcase
+          (1 'integer)
+          (1 '(integer 0))
+          (1 `(unsigned-byte ,(1+ (random 32))))
+          (1 `(signed-byte ,(1+ (random 32))))))
+     #-ecl
+     (3 (rcase
+          (1 'complex)
+          (1 '(complex single-float))
+          (1 '(complex double-float))))
+     (3 'base-char)
+     (2 'character)
+     (3 `(base-string ,(random 10)))
+     (2 `(string ,(random 10)))
+     (5 `(bit-vector ,(random 10)))
+     (10 '(or (cons t null)
+           (cons t (cons t null))
+           (cons t (cons t (cons t null)))))
+     (5 '(vector t 1))
+     (2 'package)
+     (3 (car (random-from-seq *int-structs*))))))
+
+#+sbcl
+(progn
+  (defmethod make-random-element-of-type ((type (eql 'sb-kernel:simple-character-string)))
+    (make-random-element-of-type 'simple-string))
+  (defmethod make-random-element-of-type ((type (eql 'sb-kernel:complex-single-float)))
+    (make-random-element-of-type '(complex single-float)))
+  (defmethod make-random-element-of-type ((type (eql 'sb-kernel:complex-double-float)))
+    (make-random-element-of-type '(complex double-float)))
+  (defmethod make-random-element-of-type ((type (eql 'sb-kernel::character-string)))
+    (make-random-element-of-type 'string)))
+
+#+ccl
+(progn
+  (defmethod make-random-element-of-type ((type (eql 'ccl::complex-single-float)))
+    (make-random-element-of-type '(complex single-float)))
+  (defmethod make-random-element-of-type ((type (eql 'ccl::complex-double-float)))
+    (make-random-element-of-type '(complex double-float)))
+  (defmethod make-random-element-of-type ((type (eql 'ccl::general-vector)))
+    (make-random-vector '* '*)))
+
+
 (defun make-random-character ()
   (loop
    when (rcase
@@ -1820,7 +2498,8 @@
             (cl:handler-bind
              (#+sbcl (sb-ext::compiler-note #'muffle-warning)
                      (warning #'muffle-warning)
-                     ((or error serious-condition)
+                  ((and (or error serious-condition)
+                        #+sbcl (not sb-sys:interactive-interrupt))
                       #'(lambda (c)
                                 (format t "Compilation failure~%~A~%"
                                         (format nil "~S" form))
@@ -1853,7 +2532,7 @@
                               ,@(cdr clf)))
                      (compile opt-defun-name)
                      (symbol-function opt-defun-name))
-                    (t (compile nil lambda-form)))
+                       (t (compile* lambda-form)))
                  (let* ((stop-time (get-universal-time))
                         (total-time (- stop-time start-time)))
                    (when (> total-time *max-compile-time*)
@@ -1864,9 +2543,26 @@
       (let ((optimized-compiled-fn (%compile optimized-fn-src
                                              *name-to-use-in-optimized-defun*))
             (unoptimized-compiled-fn
+              (cl:handler-case 
              (if *compile-unoptimized-form*
                  (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*)
-               (eval `(function ,unoptimized-fn-src)))))
+                      (cl:handler-bind
+                          (#+sbcl (sb-ext::compiler-note #'muffle-warning)
+                           (warning #'muffle-warning))
+                        (eval `(function ,unoptimized-fn-src))))
+                (error (e)
+                  (format t "Eval unoptimized-compiled-fn Error~A~%" unoptimized-fn-src)
+                  (return-from test-int-form
+                    (list (list :vars vars
+                                :vals nil
+                                :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 e)))
+                  ))))
         (declare (type function optimized-compiled-fn unoptimized-compiled-fn))
         (dolist (vals vals-list)
           (setq *int-form-vals* vals)
@@ -1892,7 +2588,12 @@
                      (#+sbcl (sb-ext::compiler-note #'muffle-warning)
                              (warning #'muffle-warning))
                      (identity ;; multiple-value-list
-                      (apply unoptimized-compiled-fn vals)))
+                       (let ((*fn-state* 0))
+                         (apply unoptimized-compiled-fn vals))))
+                     #+sbcl
+                     (sb-sys:interactive-interrupt (e) (error e))
+                     (innocuous-failure () :bogus)
+                     ;; (require-failure () :bogus)
                     ((or error serious-condition)
                      (c)
                      (%eval-error (list :unoptimized-form-error
@@ -1904,7 +2605,12 @@
                      (#+sbcl (sb-ext::compiler-note #'muffle-warning)
                              (warning #'muffle-warning))
                      (identity ;; multiple-value-list
-                      (apply optimized-compiled-fn vals)))
+                       (let ((*fn-state* 0))
+                         (apply optimized-compiled-fn vals))))
+                     #+sbcl
+                     (sb-sys:interactive-interrupt (e) (error e))
+                     (innocuous-failure () :bogus)
+                     ;; (require-failure () :bogus)
                     ((or error serious-condition)
                      (c)
                      (%eval-error (list :optimized-form-error
@@ -1921,24 +2627,41 @@
                                      opt-result
                                      unopt-result)))))))))))
 
+(defun remove-nth (seq n)
+  (assert (listp seq) () "remove-nth only handles lists for now")
+  (assert (<= 0 n))
+  (assert (< n (length seq)))
+  (append (subseq seq 0 n)
+          (subseq seq (1+ n))))
+
+(defun replace-nth (seq val n)
+  (assert (listp seq) () "replace-nth only handles lists for now")
+  (assert (<= 0 n))
+  (assert (< n (length seq)))
+  (append (subseq seq 0 n)
+          (list val)
+          (subseq seq (1+ n))))
+
 ;;; 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)
+(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2
+                       &key (test-fn #'test-int-form))
   "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
+                   (when (funcall test-fn
+                                  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)
+                 (prune form #'%try-fn t)
                  (return form)))))
           (when (equal form input-form) (return form))
           (setq input-form form))))
@@ -1967,6 +2690,70 @@
               :optimized-lambda-form ,optimized-lambda-form
               :unoptimized-lambda-form ,unoptimized-lambda-form))))
 
+(defun prune-boolean (form try-fn &optional top?)
+  (declare (ignorable top?))
+   (when (gethash form *prune-table*)
+     (return-from prune-boolean nil))
+   (flet ((try (x)
+            ;; (format t "try ~A~%" x)
+            (funcall try-fn x)))
+     (typecase form
+       ((member nil t) nil)
+       (cons
+        (try t)
+        (try nil)
+        (let* ((op (car form))
+               (args (cdr form))
+               (nargs (length args)))
+          (case op
+            ((and or)
+             (mapc #'try args)
+             (loop for i from 0 below nargs
+                do (let ((s (remove-nth args i)))
+                     (try `(,op ,@s))))
+             (loop for i from 0 below nargs
+                  for e in args
+                do (prune-boolean e
+                                  (lambda (form)
+                                    (try `(,op ,@(replace-nth args form i)
+                                           ))))))
+            ((not)
+             (try (car args))
+             (prune-boolean (car args) (lambda (form) (try `(not ,form)))))
+            ((if)
+             (prune-fn form try-fn nil #'prune-boolean)
+             (dolist (e (cdr form))
+               (try `(not ,e))))
+            ((case)
+             (prune-case form try-fn))
+            ((= /= < > <= >= evenp oddp minusp logbitp zerop equal eql eq
+                min max fn-with-state)
+             (mapc #'try args)
+             (prune-fn form try-fn))
+            ((block)
+             (assert (>= nargs 1))
+             (when (> nargs 1)
+               (let ((tag (car args)))
+                 (unless (find-in-tree tag (cdr args))
+                   (try (cadr args)))
+                 (prune (cadr args)
+                        (lambda (form) `(block ,tag ,form))))))
+            (typep
+             (try (car args))
+             (prune (car args)
+                    #'(lambda (form) (try `(,op ,form ,@(cdr args))))))
+            (position
+             (assert (>= nargs 2))
+             (try (car args))
+             (prune (car args) (lambda (form) (try `(,op ,form ,@(cdr args))))))
+            (otherwise
+             (when (and (consp (car form)) (eql (caar form) 'lambda))
+               (prune-inline-lambda-form form try-fn)))
+            )))
+       (otherwise
+        (try t)
+        (try nil)))))
+
 ;;;
 ;;; The call (PRUNE form try-fn) attempts to simplify the lisp form
 ;;; so that it still satisfies TRY-FN.  The function TRY-FN should
@@ -1975,11 +2762,13 @@
 ;;;
 ;;; The return value of PRUNE should be ignored.
 ;;;
-(defun prune (form try-fn)
+(defun prune (form try-fn &optional top?)
   (declare (type function try-fn))
   (when (gethash form *prune-table*)
     (return-from prune nil))
-  (flet ((try (x) (funcall try-fn x)))
+  (flet ((try (x)
+           ;; (format t "try ~A~%" x)
+           (funcall try-fn x)))
     (cond
      ((keywordp form) nil)
      ((integerp form)
@@ -1988,20 +2777,92 @@
       (let* ((op (car form))
              (args (cdr form))
              (nargs (length args)))
+        ;; (format t "OP: ~A~%" op)
         (case op
 
+          #+sbcl
+          ((sb-alien:alien-funcall)
+           (try 0))
+
+          ((count)
+           (assert (>= nargs 2))
+           (try 0)
+           (try (car args))
+           (prune (car args)
+                  (lambda (form)
+                    (try `(,op ,form ,@(cdr args))))))
+
+          ((mvb-if)
+           (try 0)
+           (destructuring-bind (vars pred true-exprs false-exprs body-expr)
+               args
+             (try `(let* ,(mapcar #'list vars true-exprs) ,body-expr))
+             (try `(let* ,(mapcar #'list vars false-exprs) ,body-expr))
+             (prune-boolean pred
+                            #'(lambda (p) (try `(mvb-if ,vars ,p
+                                                    ,true-exprs ,false-exprs
+                                                  ,body-expr))))
+             (unless (find-any-in-tree vars pred)
+               (try `(if ,pred 0 0)))
+             (prune body-expr
+                    #'(lambda (form)
+                        (try `(mvb-if ,vars ,pred ,true-exprs ,false-exprs ,form))))
+             (loop for i from 0
+                for e in false-exprs
+                do (prune e
+                          #'(lambda (form)
+                              (try `(mvb-if ,vars ,pred
+                                        ,true-exprs
+                                        ,(replace-nth false-exprs form i)
+                                      ,body-expr)))))
+             (loop for i from 0
+                for e in true-exprs
+                do (prune e
+                          #'(lambda (form)
+                              (try `(mvb-if ,vars ,pred
+                                        ,(replace-nth true-exprs form i)
+                                        ,false-exprs
+                                      ,body-expr)))))
+             ))
+
+
          ((quote) nil)
 
+          ((dxf) nil)
+
+          ((make-rif-struct)
+           (when (and (= nargs 2) (eql (car args) :n))
+             (prune (cadr args)
+                    #'(lambda (form) (try `(make-rif-struct :n ,form))))))
+
          ((go)
           (try 0))
 
          ((signum integer-length logcount
                   logandc1 logandc2 lognand lognor logorc1 logorc2
-                  realpart imagpart)
+                  realpart imagpart identity-notinline identity)
           (try 0)
           (mapc try-fn args)
           (prune-fn form try-fn))
 
+         ((int-restrict require-type)
+          (assert (= nargs 2))
+          (let ((form (car args))
+                (tp (cadr args)))
+            (when (typep 0 tp) (try 0))
+            (cond
+              ((or top? (member tp '(integer (integer) (integer *) (integer * *)) :test 'equal))
+               (try form))
+              ((and (integerp form) (typep form tp))
+               (try form))
+              ((and (consp tp) (eql (car tp) 'integer) (integerp (cadr tp)) (integerp (caddr tp)))
+               (let ((lo (cadr tp))
+                     (hi (caddr tp)))
+                 (try lo)
+                 (when (< lo hi)
+                   (try hi)))))
+            (prune form #'(lambda (form) (try `(,op ,form ,tp))))))
+
          ((make-array)
           (when (and (eq (car args) nil)
                      (eq (cadr args) ':initial-element)
@@ -2012,8 +2873,8 @@
               (try `(make-array nil :initial-element ,(caddr args))))
             ))
 
-         ((cons)
-          (prune-fn form try-fn))
+         ((cons list vector)
+          (prune-fn form try-fn top?))
 
          ((dotimes)
           (try 0)
@@ -2028,23 +2889,37 @@
             (prune result #'(lambda (form)
                               (try `(dotimes (,var ,count-form ,form) ,@body))))
             (when (= (length body) 1)
+              (unless (find-in-tree var (car body))
+                (try (car body)))
               (prune (first body)
                      #'(lambda (form)
                          (when (consp form)
                            (try `(dotimes (,var ,count-form ,result) ,form))))))))
 
-         ((abs 1+ 1-)
+         ((abs 1+ 1- fn-with-state)
           (try 0)
           (mapc try-fn args)
           (prune-fn form try-fn))
 
-         ((identity  ignore-errors cl:handler-case restart-case locally)
+         ((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))
 
+         ((symbol-macrolet)
+          (when (and (consp args)
+                     (null (car args)))
+            (mapc try-fn (cdr args)))
+          #+nil
+          (let ((len (length args)))
+            (loop for i from 1 below len
+               do (prune (elt args i)
+                         #'(lambda (form) (try `(symbol-macrolet
+                                                    ,@(replace-nth args form i)
+                                                    )))))))
+
          ((boole)
           (try (second args))
           (try (third args))
@@ -2055,6 +2930,7 @@
 
          ((unwind-protect prog1 multiple-value-prog1)
           (try (first args))
+          ;; (when top? (mapc try-fn (rest args)))
           (let ((val (first args))
                 (rest (rest args)))
             (when rest
@@ -2063,30 +2939,34 @@
                 (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))
+                             ,@(remove-nth rest i)
+                              ))))))
+          (prune-fn form try-fn top?))
 
          ((prog2)
-          (assert (>= (length args) 2))
+          (assert (>= nargs 2))
           (let ((val1 (first args))
                 (arg2 (second args))
                 (rest (cddr args)))
             (try arg2)
+            (when top?
+              (try val1)
+              (mapc try-fn rest))
             (prune-fn form try-fn)
             (when rest
               (try `(prog2 ,val1 ,arg2))
+              (mapc #'try rest)
               (when (cdr rest)
                 (loop for i from 0 below (length rest)
                       do
                       (try `(prog2 ,val1 ,arg2
-                              ,@(subseq rest 0 i)
-                              ,@(subseq rest (1+ i)))))))))
+                             ,@(remove-nth rest i)
+                             )))))))
 
          ((typep)
           (try (car args))
           (prune (car args)
-                 #'(lambda (form) `(,op ,form ,@(cdr args)))))
+                 #'(lambda (form) (try `(,op ,form ,@(cdr args))))))
 
          ((load-time-value)
           (let ((arg (first args)))
@@ -2109,10 +2989,11 @@
              ((consp arg)
               (cond
                ((eql (car arg) 'quote)
+                 (try (cadr arg))
                 (prune (cadr arg) #'(lambda (form) (try `(eval ',form)))))
                (t
                 (try arg)
-                (prune arg #'(lambda (form) `(eval ,form))))))
+                (prune arg #'(lambda (form) (try `(eval ,form)))))))
              (t (try arg)))))
 
          ((the macrolet cl:handler-bind restart-bind)
@@ -2138,6 +3019,10 @@
           (prune-nary-fn form try-fn)
           (prune-fn form try-fn))
 
+         ((complex conjugate)
+          (when args
+            (try (car args))))
+
          ((- + * min max logand logior logxor logeqv gcd lcm values)
           (when (every #'constantp args)
             (try (eval form)))
@@ -2151,10 +3036,10 @@
             (try (eval form)))
           (try 0)
           (try (car args))
-          (when (cddr args)
+          (when (cadr args)
             (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args)))))))
 
-         ((expt rationalize rational numberator denominator)
+         ((expt rationalize rational numerator denominator)
           (try 0)
           (mapc try-fn args)
           (prune-fn form try-fn))
@@ -2189,9 +3074,16 @@
           (when (= (length args) 2)
             (let ((arg1 (car args))
                   (arg2 (cadr args)))
+              (when (vectorp arg1)
+                (map nil try-fn arg1))
+              (when (and (consp arg1)
+                         (eql (car arg1) 'quote)
+                         (listp (cadr arg1)))
+                (mapc try-fn (cadr arg1)))
               (when (and (consp arg2)
                          (eql (car arg2) 'min)
                          (integerp (cadr arg2)))
+                (try (cadr arg2))
                 (let ((arg2.2 (caddr arg2)))
                   (try arg2.2)
                   (when (and (consp arg2.2)
@@ -2207,14 +3099,24 @@
           (try 1))
 
          ((if)
-          (let (;; (pred (first args))
+          ;; (format t "prune if~%")
+          (let ((pred (first args))
                 (then (second args))
                 (else (third args)))
+            (when top? (try pred))
+            ;; (format t "prune if then~%")
             (try then)
+            ;; (format t "prune if else~%")
             (try else)
             (when (every #'constantp args)
               (try (eval form)))
-            (prune-fn form try-fn)))
+            ;; (format t "prune if pred~%")
+            (prune-boolean pred
+                           #'(lambda (e)
+                              (try `(if ,e ,then ,else))))
+            (prune then #'(lambda (e) (try `(if ,pred ,e ,else))))
+            (prune else #'(lambda (e) (try `(if ,pred ,then ,e))))
+            ))
 
          ((incf decf)
           (try 0)
@@ -2325,6 +3227,13 @@
                        #'(lambda (x)
                            (try `(block ,name ,x))))))))
 
+         ((return-from)
+          (try 0)
+          (when (= nargs 2)
+            (try (second args))
+            (prune (second args) (lambda (form) `(return-from ,(first args) ,form)))))
+
+
          ((catch)
           (let* ((tag (second form))
                  (name (if (consp tag) (cadr tag) tag))
@@ -2359,7 +3268,7 @@
 
          ((flet labels)
           (try 0)
-          (prune-flet form try-fn))
+          (prune-flet form try-fn top?))
 
          ((case)
           (prune-case form try-fn))
@@ -2369,6 +3278,7 @@
             (assert (null (cddr form)))
             (assert (consp arg))
             (assert (eq (first arg) 'abs))
+            ;; (format t "Trying...~%")
             (let ((arg2 (second arg)))
               (try arg2)
               ;; Try to fold
@@ -2402,6 +3312,7 @@
 
          ((floor ceiling truncate round mod rem)
           (try 0)
+          ;; (fn form1 form2)
           (let ((form1 (second form))
                 (form2 (third form)))
             (try form1)
@@ -2417,6 +3328,7 @@
                          (member (first form2) '(max min))
                          (every #'integerp (cdr form2)))
                 (try (eval form)))
+              ;; (fn form1 (fn2 form2.2 form3))
               (let ((form3 (third form2)))
                 (prune form3
                        #'(lambda (form)
@@ -2509,11 +3421,12 @@
 
          ((progn)
           (when (null args) (try nil))
-          (try (car (last args)))
+          (if top?
+              (mapc try-fn args)
+              (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 (try `(progn ,@(remove-nth args i)))
                 do (when (and (consp a)
                               (or
                                (eq (car a) 'progn)
@@ -2540,6 +3453,8 @@
                                  (try `(loop for ,var below ,count sum ,form)))))
                 (count
                  (unless (or (eql form t) (eql form nil))
+                   (when (and top? (not (find-in-tree var form)))
+                     (try form))
                    (try `(loop for ,var below ,count count t))
                    (try `(loop for ,var below ,count count nil))
                    (prune form
@@ -2548,20 +3463,93 @@
                 ))))
 
          (otherwise
+          (cond
+            ((is-int-struct-constructor? op)
+             (when (and (= nargs 2) (eql (car args) :n))
+               (unless (eql (cadr args) 0)
+                 (try `(,op ,(car args) 0)))
+               (prune (cadr args)
+                      #'(lambda (form) (try `(,op ,(car args) ,form))))))
+            ((is-flet-symbol op)
+             (dolist (e args)
+               (unless (keywordp e) (try e))))
+            ((and (consp op) (eql (car op) 'lambda))
+             (prune-inline-lambda-form form try-fn))
+            (t
           (try 0)
-          (prune-fn form try-fn))
-
+             (prune-fn form try-fn top?))))
          )))))
   (setf (gethash form *prune-table*) t)
   nil)
 
-(defun find-in-tree (value tree)
+(defun prune-inline-lambda-form (form try-fn)
+  (prune-fn form try-fn)
+  (flet ((try (x) (funcall try-fn x)))
+    (let* ((lam (car form))
+           (args (cdr form))
+           (lam-list (cadr lam))
+           (lam-list-vars
+            (loop for v in lam-list
+               when (and (symbolp v) (not (member v lambda-list-keywords)))
+               collect v
+               when (and (consp v)
+                         (symbolp (car v)))
+               collect (car v)
+               when (and (consp v) (consp (cdr v)) (consp (cddr v))
+                         (third v) (symbolp (third v)))
+               collect (third v)))
+           (lam-expr (caddr lam)))
+      (assert (eql (car lam) 'lambda))
+      ;; If the body of the lambda does not use any argument, try
+      ;; to eliminate the call
+      (mapc try-fn args)
+      (let ((e (third lam)))
+        (when (and e (not (stringp e))
+                   (not (and (consp e) (eql (car e) 'declare)))
+                   (not (find-any-in-tree lam-list-vars e)))
+          (try `(progn ,@args ,e))))
+      ;; Argument prunes are handled by the call to prune-fn
+      ;; Here, attempt prunes inside the lambda form
+      (when (and (>= (length lam-list) 2)
+                 (eql (car (last lam-list 2)) '&rest))
+        (try `((lambda ,(butlast lam-list 2) ,lam-expr) ,@args)))
+      (loop for i from 0 below (length args)
+         for v in lam-list
+         for lam-rest on lam-list
+         do (unless (or (not (symbolp v))
+                        (find-in-tree v (cdr lam-rest))
+                        (find-in-tree v lam-expr))
+              (try `((lambda ,(remove-nth lam-list i)
+                       ,lam-expr)
+                     ,@(remove-nth args i)
+                     ))))
+      (prune lam-expr (lambda (x) (try `((lambda ,lam-list ,x) ,@args)))))))
+
+(defun find-in-tree (value tree &key (test #'eql))
   "Return true if VALUE is eql to a node in TREE."
-  (or (eql value tree)
+  (or (funcall test value tree)
       (and (consp tree)
            (or (find-in-tree value (car tree))
                (find-in-tree value (cdr tree))))))
 
+(defun find-any-in-tree (vals tree)
+  "Return true if any element of the list VALS is EQL to a node in TREE"
+  (or (member tree vals)
+      (and (consp tree)
+           (or (find-any-in-tree vals (car tree))
+               (find-any-in-tree vals (cdr tree))))))
+
+(defun count-in-tree (value tree)
+  "Return the number of occurrence of things EQL to VALUE in TREE.
+   Assumes VALUE is not a CONS"
+  (cond
+    ((eql value tree) 1)
+    (t
+     (+
+      (loop while (consp tree)
+         sum (count-in-tree value (pop tree)))
+      (if (eql value tree) 1 0)))))
+
 (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."
@@ -2571,37 +3559,56 @@
                       e
                       #'(lambda (form)
                           (funcall list-try-fn
-                                   (append (subseq list 0 i)
-                                           (list form)
-                                           (subseq list (1+ i))))))))
+                              (replace-nth list form i)
+                              )))))
+#|
+(defun prune-eval (args try-fn)
+  (flet ((try (e) (funcall try-fn e)))
+    (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))))))
+|#
 
 (defun prune-case (form try-fn)
   (declare (type function try-fn))
-  (flet ((try (e) (funcall try-fn e)))
+  (flet ((try (e)
+           ;; (format t "prune-case try ~a~%" e)
+           (funcall try-fn e)))
     (let* ((op (first form))
            (expr (second form))
            (cases (cddr form)))
 
       ;; Try just the top expression
+      ;; (format t "prune-case just top expr~%")
       (try expr)
 
       ;; Try simplifying the expr
+      ;; (format t "prune-case simplify top expr~%")
       (prune expr
              #'(lambda (form)
                  (try `(,op ,form ,@cases))))
 
       ;; Try individual cases
+      ;; (format t "prune-case individual cases~%")
       (loop for case in cases
             do (try (first (last (rest case)))))
 
       ;; Try deleting individual cases
+      ;; (format t "prune-case deleting cases~%")
       (loop for i from 0 below (1- (length cases))
-            do (try `(,op ,expr
-                          ,@(subseq cases 0 i)
-                          ,@(subseq cases (1+ i)))))
+         do (try `(,op ,expr ,@(remove-nth cases i))))
 
       ;; Try simplifying the cases
       ;; Assume each case has a single form
+      ;; (format t "prune-case simplifying cases~%")
       (prune-list cases
                   #'(lambda (case try-fn)
                       (declare (type function try-fn))
@@ -2609,9 +3616,9 @@
                                  (> (length (car case)) 1))
                         ;; try removing constants
                         (loop for i below (length (car case))
+                           ;; do (format t "prune-case remove ~a~%" (elt (car case) i))
                               do (funcall try-fn
-                                          `((,@(subseq (car case) 0 i)
-                                             ,@(subseq (car case) (1+ i)))
+                                       `((,@(remove-nth (car case) i))
                                             ,@(cdr case)))))
                       (when (eql (length case) 2)
                         (prune (cadr case)
@@ -2623,30 +3630,33 @@
 
 (defun prune-tagbody (form try-fn)
   (declare (type function try-fn))
-  (let (;; (op (car form))
-        (body (cdr form)))
+  (let* (;; (op (car form))
+         (body (cdr form))
+         (tags (remove-if-not #'atom body)))
     (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))))))
+            (unless (find-in-tree `(go ,e) (subseq body 0 i)
+                                  :test #'equal)
+              (funcall try-fn `(tagbody ,@(remove-nth body i)
+                                  ))))
            (t
+            (unless (find-any-in-tree tags e)
+              (funcall try-fn e))
             (funcall try-fn
-                     `(tagbody ,@(subseq body 0 i)
-                               ,@(subseq body (1+ i))))
+                     `(tagbody ,@(remove-nth body 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))))))))))))
+                          `(tagbody ,@(replace-nth body form i)
+                              ))))))))))
 
 (defun prune-progv (form try-fn)
   (declare (type function try-fn))
@@ -2687,20 +3697,22 @@
          (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)))))))
+      (loop for i from 0 below nargs
+         do (funcall try-fn `(,op ,@(remove-nth args i)))))))
 
-(defun prune-fn (form try-fn)
+(defun prune-fn (form try-fn &optional top? (prune-fn #'prune))
   "Attempt to simplify a function call form.  It is considered
-   acceptable to replace the call by one of its argument forms."
+   acceptable to replace the call by one of its argument forms.
+   If TOP? is true this is a top level form, so the pruned
+   form can return any type"
   (declare (type function try-fn))
+  (when top? (mapc try-fn (cdr form)))
   (prune-list (cdr form)
-              #'prune
+              prune-fn
               #'(lambda (args)
                   (funcall try-fn (cons (car form) args)))))
 
-(defun prune-let (form try-fn)
+(defun prune-let (form try-fn &optional top?)
   "Attempt to simplify a LET form."
   (declare (type function try-fn))
   (let* ((op (car form))
@@ -2708,8 +3720,14 @@
          (body (cddr form))
          (body-len (length body))
          (len (length binding-list))
+         (vars (mapcar (lambda (b) (if (consp b) (car b) b)) binding-list))
          )
 
+    (when top?
+      (dolist (binding binding-list)
+        (when (consp binding)
+          (funcall try-fn (cadr binding)))))
+
     (when (> body-len 1)
       (funcall try-fn `(,op ,binding-list ,@(cdr body))))
 
@@ -2724,10 +3742,14 @@
                      (eql (car val-form) 'make-array))
           (funcall try-fn val-form))))
     |#
+    (when (and (>= len 1)
+               (= body-len 1)
+               (not (find-any-in-tree vars (car body))))
+      (funcall try-fn (car body)))
 
     (when (>= len 1)
       (let ((val-form (cadar binding-list)))
-        (when (consp val-form)
+        (if (consp val-form)
           (case (car val-form)
             ((make-array)
              (let ((init (getf (cddr val-form) :initial-element)))
@@ -2735,7 +3757,21 @@
                  (funcall try-fn init))))
             ((cons)
              (funcall try-fn (cadr val-form))
-             (funcall try-fn (caddr val-form)))))))
+             (funcall try-fn (caddr val-form)))
+            (t
+             (funcall try-fn val-form)))
+          (funcall try-fn val-form))))
+
+    ;; Try to split into multiple bindings
+    (when (and (> len 1) body)
+      (let ((body body))
+        (loop while (and (cdr body)
+                         (consp (car body))
+                         (eql (caar body) 'declare))
+           do (pop body))
+        (loop for binding in (reverse binding-list)
+           do (setf body `((let (,binding) ,@body))))
+        (funcall try-fn (car body))))
 
     ;; Try to simplify the forms in the RHS of the bindings
     (prune-list binding-list
@@ -2749,15 +3785,26 @@
                 #'(lambda (bindings)
                     (funcall try-fn `(,op ,bindings ,@body))))
 
-    ;; Prune off unused variable
+    ;; Prune off unused variable -- just one binding
+    #+(or)
     (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)))))
+                      (not (find-if-subtree (lambda (x) (eq x name)) body)))))
       (funcall try-fn `(progn ,@body)))
 
+    ;; Prune off unused variable -- more than one binding
+    (when (and binding-list
+               ;; (rest binding-list)
+               (let ((name (caar binding-list)))
+                 (and (symbolp name)
+                      (not (find-if-subtree (lambda (x) (eq x name))
+                                            (cons (cdr binding-list) body))))))
+        (funcall try-fn `(let ,(rest binding-list) ,@body)))
+
     ;; Try to simplify the body of the LET form
+    ;; Bug in this?
     (when body
       (unless binding-list
         (funcall try-fn (car (last body))))
@@ -2769,17 +3816,28 @@
                       (has-binding-to-var (first binding) body)
                       (has-assignment-to-var (first binding) body)
                       )
-            (funcall try-fn `(let ()
-                               ,@(subst (second binding)
+            (let ((newbody
+                   (subst-except-for-eval
+                    (second binding)
                                         (first binding)
                                         (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare)))
-                                                   body)
-                                        ))))))
+                               body))))
+              (unless (find-in-tree (first binding) newbody)
+                (funcall try-fn `(let () ,@newbody)))))))
+
       (prune (car (last body))
              #'(lambda (form2)
                  (funcall try-fn
                           `(,@(butlast form) ,form2)))))))
 
+(defun subst-except-for-eval (e var body)
+  "Like SUBST, but don't descend into EVAL forms"
+  (cond
+    ((eql body var) e)
+    ((not (consp body)) body)
+    ((eql (car body) 'eval) body)
+    (t (mapcar #'(lambda (b) (subst-except-for-eval e var b)) body))))
+
 (defun has-assignment-to-var (var form)
   (find-if-subtree
    #'(lambda (form)
@@ -2796,14 +3854,30 @@
    #'(lambda (form)
        (and (consp form)
             (case (car form)
+              ((lambda)
+               (loop for b in (cadr form)
+                  thereis (or (eql b var)
+                              (and (consp b)
+                                   (or (eql (car b) var)
+                                       (and (consp (cdr b))
+                                            (consp (cddr b))
+                                            (eql var (caddr b))))))))
+
               ((let let*)
                (loop for binding in (cadr form)
                      thereis (eq (car binding) var)))
+              ((for)
+               (find-if-subtree (lambda (x) (eq x var)) (cadr form)))
               ((progv)
                (and (consp (cadr form))
                     (eq (caadr form) 'quote)
                     (consp (second (cadr form)))
                     (member var (second (cadr form)))))
+              ((loop)
+               (loop for e on (cdr form)
+                   thereis (and (eql (car e) 'for) (eql (cadr e) var))))
+              ((mvb-if)
+               (find-in-tree var (second form)))
               (t nil))))
    form))
 
@@ -2816,7 +3890,7 @@
         (find-if-subtree pred (cdr tree))))
    (t nil)))
 
-(defun prune-flet (form try-fn)
+(defun prune-flet (form try-fn top?)
   "Attempt to simplify a FLET form."
   (declare (type function try-fn))
 
@@ -2899,12 +3973,12 @@
             (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)))))))
+                          `(,@(butlast form) ,form2)))
+             top?))))
 
 ;;; Routine to walk form, applying a function at each form
 ;;; The fn is applied in preorder.  When it returns :stop, do
@@ -2959,8 +4033,8 @@
                (let* ((fn1 ',optimized-lambda-form)
                       (fn2 ',unoptimized-lambda-form)
                       (vals ',vals)
-                      (v1 (apply (compile nil fn1) vals))
-                      (v2 (apply (compile nil fn2) vals)))
+                      (v1 (apply (compile* fn1) vals))
+                      (v2 (apply (compile* fn2) vals)))
                  (if (eql v1 v2)
                      :good
                    (list v1 v2)))
diff --git a/random/random-type-prop-tests-01.lsp b/random/random-type-prop-tests-01.lsp
index da3a53e4..8c8a129e 100644
--- a/random/random-type-prop-tests-01.lsp
+++ b/random/random-type-prop-tests-01.lsp
@@ -13,6 +13,15 @@
               (let ((type (make-random-type-containing x)))
                 `(eql ,type))))
   2)
+(def-type-prop-test typep.3 'typep
+  (list t #'(lambda (x) (declare (ignore x))
+                    (let ((type (make-random-type-containing
+                                 (make-random-element-of-type t))))
+                      `(eql ,type))))
+  2)
+(def-type-prop-test typep.4 'typep
+  (list 'integer #'(lambda (x) (let ((type (make-random-type-containing 0))) `(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)
@@ -26,13 +35,107 @@
                                            (1 `(eql ,x))
                                            (1 '(and t (not number) (not character))))))
   2)
+(def-type-prop-test eq.2 'eq '(t (and (not number) (not character))) 2)
+(def-type-prop-test eq.3 'eq '((and (not number) (not character)) t) 2)
+(def-type-prop-test eq.4 '(lambda (x y) (if (eq x y) :a :b))
+                    (list
+                     '(and t (not number) (not character))
+                     #'(lambda (x) (rcase
+                                     (1 `(eql ,x))
+                                     (1 t))))
+                    2)
+(def-type-prop-test eq.5 '(lambda (x y) (if (eq x y) (if (eq y x) t)))
+                    (list
+                     '(and t (not number) (not character))
+                     #'(lambda (x) (rcase
+                                     (1 `(eql ,x))
+                                     (1 t))))
+                    2)
+(def-type-prop-test eq.6 '(lambda (x y) (if (eq x y) (if (eq x y) :a :b) :c))
+                    (list
+                     '(and t (not number) (not character))
+                     #'(lambda (x) (rcase
+                                     (1 `(eql ,x))
+                                     (1 t))))
+                    2)
+(def-type-prop-test eq.7 '(lambda (x y z) (if (eq x y) (if (eq x z) :a :b) :c))
+                    (list
+                     '(and t (not number) (not character))
+                     #'(lambda (x) (rcase
+                                     (1 `(eql ,x))
+                                     (1 t)))
+                     #'(lambda (x y) (rcase
+                                       (1 `(eql ,x))
+                                       (1 `(eql ,y))
+                                       (1 t))))
+                    3)
+(def-type-prop-test eq.8 '(lambda (x y z) (if (eq x y) :a (if (eq x z) :b :c)))
+                    (list
+                     '(and t (not number) (not character))
+                     #'(lambda (x) (rcase
+                                     (1 `(eql ,x))
+                                     (1 t)))
+                     #'(lambda (x y) (rcase
+                                       (1 `(eql ,x))
+                                       (1 `(eql ,y))
+                                       (1 t))))
+                    3)
 (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 equal.3 '(lambda (x y) (if (equal x y) :a :b)) '(t t) 2)
+(def-type-prop-test equal.4 '(lambda (x y) (if (equal x y) :a :b))
+                    (list t #'(lambda (x) `(eql ,x)))
+                    2)
+(def-type-prop-test equal.5 '(lambda (x y z)
+                              (if (equal x y) (if (equal x z) :a :b) :c))
+                    '(t t t)
+                    3)
+(def-type-prop-test equal.6 '(lambda (x y z)
+                              (if (equal x y) (if (equal x z) :a :b) :c))
+                    (list t
+                          #'(lambda (x) `(or (eql ,x) t))
+                          #'(lambda (x y) `(eql ,(if (coin) x y))))
+                    3)
+(def-type-prop-test equal.7 '(lambda (x y z)
+                              (if (equal x y) :a (if (equal x z) :b :c)))
+                    '(t t t)
+                    3)
+(def-type-prop-test equal.8 '(lambda (x y z)
+                              (if (equal x y) :a (if (equal x z) :b :c)))
+                    (list t
+                          #'(lambda (x) `(or (eql ,x) t))
+                          #'(lambda (x y) `(member ,x ,y)))
+                    3)
 (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 equalp.3 '(lambda (x y) (if (equalp x y) :a :b)) '(t t) 2)
+(def-type-prop-test equalp.4 '(lambda (x y) (if (equalp x y) :a :b))
+                    (list t #'(lambda (x) `(eql ,x)))
+                    2)
+(def-type-prop-test equalp.5 '(lambda (x y z)
+                              (if (equalp x y) (if (equalp x z) :a :b) :c))
+                    '(t t t)
+                    3)
+(def-type-prop-test equalp.6 '(lambda (x y z)
+                              (if (equalp x y) (if (equalp x z) :a :b) :c))
+                    (list t
+                          #'(lambda (x) `(or (eql ,x) t))
+                          #'(lambda (x y) `(eql ,(if (coin) x y))))
+                    3)
+(def-type-prop-test equalp.7 '(lambda (x y z)
+                              (if (equalp x y) :a (if (equalp x z) :b :c)))
+                    '(t t t)
+                    3)
+(def-type-prop-test equalp.8 '(lambda (x y z)
+                              (if (equalp x y) :a (if (equalp x z) :b :c)))
+                    (list t
+                          #'(lambda (x) `(or (eql ,x) t))
+                          #'(lambda (x y) `(member ,x ,y)))
+                    3)
+(def-type-prop-test identity.1 'identity '(t) 1)
+(def-type-prop-test identity.2 'identity '(number) 1)
 (def-type-prop-test complement
  '(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2)
 (def-type-prop-test constantly
@@ -50,6 +153,8 @@
   '(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 if.7 '(lambda (x y) (if x y nil))
+                    (list 'boolean  #'(lambda (x) x)) 2)
 (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)
diff --git a/random/random-type-prop-tests-02.lsp b/random/random-type-prop-tests-02.lsp
index 458aa8fc..bd25d5eb 100644
--- a/random/random-type-prop-tests-02.lsp
+++ b/random/random-type-prop-tests-02.lsp
@@ -78,6 +78,28 @@
                                                     (1 `(eql ,y)))))
   3)
 
+(def-type-prop-test comparisons.1 '(lambda (c x y) (funcall c x y))
+  (list '(member = /= < > <= >=)
+        'integer
+        #'(lambda (c x)
+            (declare (ignore c))
+            (rcase (10 'integer)
+              (1 `(eql ,(1- x)))
+              (1 `(eql ,x))
+              (1 `(eql ,(1+ x))))))
+  3)
+(def-type-prop-test comparisons.2 '(lambda (c x y) (when (funcall c x y) (- x y)))
+  (list '(member = /= < > <= >=)
+        'integer
+        #'(lambda (c x)
+            (declare (ignore c))
+            (rcase (10 'integer)
+              (1 `(eql ,(1- x)))
+              (1 `(eql ,x))
+              (1 `(eql ,(1+ x))))))
+  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)
@@ -113,3 +135,17 @@
 (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)
+
+(def-type-prop-test floor/first-value.1 '(lambda (x y) (values (floor x y))) '(integer (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test floor/first-value.2 '(lambda (x y) (values (floor x y))) '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test floor/first-value.3 '(lambda (x y) (values (floor x y))) '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test floor/second-value.1 '(lambda (x y) (nth-value 1 (floor x y))) '(integer (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test floor/second-value.2 '(lambda (x y) (nth-value 1 (floor x y))) '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test floor/second-value.3 '(lambda (x y) (nth-value 1 (floor x y))) '(real (and real (not (satisfies zerop)))) 2)
+
+(def-type-prop-test truncate/first-value.1 '(lambda (x y) (values (truncate x y))) '(integer (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test truncate/first-value.2 '(lambda (x y) (values (truncate x y))) '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test truncate/first-value.3 '(lambda (x y) (values (truncate x y))) '(real (and real (not (satisfies zerop)))) 2)
+(def-type-prop-test truncate/second-value.1 '(lambda (x y) (nth-value 1 (truncate x y))) '(integer (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test truncate/second-value.2 '(lambda (x y) (nth-value 1 (truncate x y))) '(real (and integer (not (satisfies zerop)))) 2)
+(def-type-prop-test truncate/second-value.3 '(lambda (x y) (nth-value 1 (truncate x y))) '(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
index a564c214..6db5eae4 100644
--- a/random/random-type-prop-tests-03.lsp
+++ b/random/random-type-prop-tests-03.lsp
@@ -36,10 +36,12 @@
 (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)
+  :test #'(lambda (x y) (approx= x y (* 100 (epsilon x)))) :ignore 'arithmetic-error)
+|#
 
 (def-type-prop-test 1+.1 '1+ '(integer) 1)
 (def-type-prop-test 1+.2 '1+ '(rational) 1)
@@ -61,6 +63,16 @@
 
 ;;; exp, expt here
 
+(def-type-prop-test exp.1 'exp '((integer -100 100)) 1)
+(def-type-prop-test exp.2 'exp '((real -100 100)) 1)
+(def-type-prop-test exp.3 'exp '((complex (real -100 100))) 1)
+
+(def-type-prop-test expt.1 'expt '((integer 1 1000) (integer -1000 1000)) 2)
+(def-type-prop-test expt.2 'expt '((integer -1000 -1) (integer -1000 1000)) 2)
+(def-type-prop-test expt.3 'expt '((rational (0) 1000) (integer -1000 1000)) 2)
+(def-type-prop-test expt.4 'expt '((real -1000 (0)) (real -100 100)) 2)
+(def-type-prop-test expt.5 'expt '((real -1000 (0)) (eql 1/2)) 2)
+
 (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)
 
@@ -93,6 +105,8 @@
 (def-type-prop-test complex.5 'complex '(real real) 2)
 
 (def-type-prop-test complexp 'complexp '(t) 1)
+(def-type-prop-test complexp.2 '(lambda (x y) (complexp (complex x y)))
+  '(real real) 2)
 
 (def-type-prop-test conjugate 'conjugate '(number) 1)
 
@@ -143,6 +157,30 @@
 
 (def-type-prop-test lognot 'lognot '(integer) 1)
 
+;; Combined integer tests
+(def-type-prop-test logand.lognot.1 '(lambda (x y) (logand x (lognot y))) '(integer integer) 2)
+(def-type-prop-test logand.lognot.2 '(lambda (x y) (logand (lognot x) y)) '(integer integer) 2)
+(def-type-prop-test logand.lognot.3 '(lambda (x y) (logand (lognot x) (lognot y))) '(integer integer) 2)
+(def-type-prop-test logand.lognot.4 '(lambda (x y) (lognot (logand x y))) '(integer integer) 2)
+
+(def-type-prop-test logior.lognot.1 '(lambda (x y) (logior x (lognot y))) '(integer integer) 2)
+(def-type-prop-test logior.lognot.2 '(lambda (x y) (logior (lognot x) y)) '(integer integer) 2)
+(def-type-prop-test logior.lognot.3 '(lambda (x y) (logior (lognot x) (lognot y))) '(integer integer) 2)
+(def-type-prop-test logior.lognot.4 '(lambda (x y) (lognot (logior x y))) '(integer integer) 2)
+
+(def-type-prop-test logxor.lognot.1 '(lambda (x y) (logxor x (lognot y))) '(integer integer) 2)
+(def-type-prop-test logxor.lognot.2 '(lambda (x y) (logxor (lognot x) y)) '(integer integer) 2)
+(def-type-prop-test logxor.lognot.3 '(lambda (x y) (logxor (lognot x) (lognot y))) '(integer integer) 2)
+(def-type-prop-test logxor.lognot.4 '(lambda (x y) (lognot (logxor x y))) '(integer integer) 2)
+
+(def-type-prop-test logand.logior.1 '(lambda (x y z) (logand x (logior y z))) '(integer integer integer) 3)
+(def-type-prop-test logand.logior.2 '(lambda (x y z) (logand (logior x y) z)) '(integer integer integer) 3)
+(def-type-prop-test logand.logior.3 '(lambda (x y z w) (logand (logior x y) (logior z w))) '(integer integer integer integer) 4)
+
+(def-type-prop-test logior.logand.1 '(lambda (x y z) (logior x (logand y z))) '(integer integer integer) 3)
+(def-type-prop-test logior.logand.2 '(lambda (x y z) (logior (logand x y) z)) '(integer integer integer) 3)
+(def-type-prop-test logior.logand.3 '(lambda (x y z w) (logior (logand x y) (logand z w))) '(integer integer integer integer) 4)
+
 (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)
@@ -183,4 +221,102 @@
          `(integer 0 (,(length x)))))
   3)
 
+(def-type-prop-test parse-integer.3 'parse-integer
+  `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+         (satisfies has-nonzero-length))
+    (eql :end)
+    ,#'(lambda (x &rest rest) (declare (ignore rest))
+         `(integer 1 ,(length x))))
+  3)
+
+(def-type-prop-test parse-integer.4 'parse-integer
+  `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+         (satisfies has-nonzero-length))
+    (eql :junk-allowed)
+    (member nil t))
+  3)
+
+(def-type-prop-test parse-integer.5 'parse-integer
+  `(string (eql :junk-allowed) (and t (not null)))
+  3)
+
+(def-type-prop-test parse-integer.6 'parse-integer
+  `((and (vector (member #\0 #\1))
+         (satisfies has-nonzero-length))
+    (eql :radix)
+    (integer 2 36))
+  3)
+
+(def-type-prop-test parse-integer.7 'parse-integer
+  `((and (vector (member #\0 #\1 #\2 #\3))
+         (satisfies has-nonzero-length))
+    (eql :radix)
+    (integer 4 36))
+  3)
+
+(def-type-prop-test parse-integer.8 'parse-integer
+  `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5))
+         (satisfies has-nonzero-length))
+    (eql :radix)
+    (integer 6 36))
+  3)
+
+(def-type-prop-test parse-integer.9 'parse-integer
+  `((and (vector (member ,@(map 'list #'identity
+                                "0123456789abcdefghijklmnopqrstuvwxyz")))
+         (satisfies has-nonzero-length))
+    (eql :radix)
+    (integer 36 36))
+  3)
+
 (def-type-prop-test sxhash 'sxhash '(t) 1)
+(def-type-prop-test sxhash.2 'sxhash '(string) 1)
+(def-type-prop-test sxhash.3 '(lambda (s) (unless (= (sxhash s) (sxhash (map 'string #'identity s))) (error "Bad sxhash: ~a" s))) '(string) 1)
+
+(def-type-prop-test boole.1 'boole `(,(list 'member boole-1 boole-2 boole-andc1
+                                      boole-andc2 boole-and boole-c1 boole-c2
+                                      boole-clr boole-eqv boole-ior
+                                      boole-nand boole-nor boole-orc1
+                                      boole-orc2 boole-set boole-xor)
+                                     integer integer) 3)
+
+;; (def-type-prop-test byte.1 'byte '((integer 0) (integer 0)) 2)
+;; (def-type-prop-test byte.2 'byte '((integer 0 10) (integer 0)) 2)
+
+(def-type-prop-test byte.3 'byte '((integer 0 1000) (integer 0 1000)) 2)
+(def-type-prop-test deposit-field.1
+  '(lambda (m s p n)
+    (deposit-field m (byte s p) n))
+  '(integer (integer 0 100) (integer 0 100) integer)
+  4)
+(def-type-prop-test dpb.1
+  '(lambda (m s p n)
+    (dpb m (byte s p) n))
+  '(integer (integer 0 100) (integer 0 100) integer)
+  4)
+(def-type-prop-test ldb.1
+  '(lambda (s p n)
+    (ldb (byte s p) n))
+  '((integer 0 100) (integer 0 100) integer)
+  3)
+(def-type-prop-test ldb.2
+  '(lambda (s p n x)
+    (values (setf (ldb (byte s p) n) x)
+     n))
+  '((integer 0 100) (integer 0 100) integer integer)
+  4)
+(def-type-prop-test ldb-test.1
+  '(lambda (s p n) (ldb-test (byte s p) n))
+  '((integer 0 100) (integer 0 100) integer)
+  3)
+(def-type-prop-test mask-field.1
+  '(lambda (s p n)
+    (mask-field (byte s p) n))
+  '((integer 0 100) (integer 0 100) integer)
+  3)
+(def-type-prop-test mask-field.2
+  '(lambda (s p n x)
+    (values (setf (mask-field (byte s p) n) x)
+     n))
+  '((integer 0 100) (integer 0 100) integer integer)
+  4)
diff --git a/random/random-type-prop-tests-04.lsp b/random/random-type-prop-tests-04.lsp
index b12aae40..ff28eca3 100644
--- a/random/random-type-prop-tests-04.lsp
+++ b/random/random-type-prop-tests-04.lsp
@@ -101,7 +101,7 @@
 (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 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
index 5ef8ee93..90bcd5b4 100644
--- a/random/random-type-prop-tests-05.lsp
+++ b/random/random-type-prop-tests-05.lsp
@@ -6,6 +6,7 @@
 (in-package :cl-test)
 
 (def-type-prop-test list.1 'list nil 1 :rest-type 't :maxargs 10)
+(def-type-prop-test list.1a 'list nil 1 :rest-type 't :maxargs 20)
 (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)
@@ -488,18 +489,18 @@
   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.1 'set-exclusive-or '(list list) 2 :test #'bag-equal)
 (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)
+  4 :test #'bag-equal)
 (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)
+                    4 :test #'bag-equal)
 (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))
diff --git a/random/random-type-prop-tests-07.lsp b/random/random-type-prop-tests-07.lsp
index efe6f59b..4c10f076 100644
--- a/random/random-type-prop-tests-07.lsp
+++ b/random/random-type-prop-tests-07.lsp
@@ -14,6 +14,10 @@
 (def-type-prop-test string-downcase 'string-downcase '(string) 1)
 (def-type-prop-test string-capitalize 'string-capitalize '(string) 1)
 
+(def-type-prop-test nstring-upcase 'nstring-upcase '(string) 1 :replicate '(t))
+(def-type-prop-test nstring-downcase 'nstring-downcase '(string) 1 :replicate '(t))
+(def-type-prop-test nstring-capitalize 'nstring-capitalize '(string) 1 :replicate '(t))
+
 (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)
diff --git a/random/random-type-prop-tests-08.lsp b/random/random-type-prop-tests-08.lsp
index 9f8c938c..7d891b93 100644
--- a/random/random-type-prop-tests-08.lsp
+++ b/random/random-type-prop-tests-08.lsp
@@ -58,6 +58,95 @@
 
 ;;; make-sequence tests here
 
+(def-type-prop-test make-sequence.1 'make-sequence
+  (list '(member list vector) '(integer 0 10))
+  2)
+
+(def-type-prop-test make-sequence.2 'make-sequence
+  (list '(member list vector) '(integer 0 10)
+        '(eql :initial-element) t)
+  4)
+
+(def-type-prop-test make-sequence.3 'make-sequence
+  (list '(cons (eql vector)
+          (cons (cons (eql unsigned-byte) (cons (integer 1 64) null))
+           null))
+        '(integer 0 10))
+  2)
+
+(def-type-prop-test make-sequence.4 'make-sequence
+  (list '(cons (eql vector)
+          (cons (cons (eql unsigned-byte) (cons (integer 1 64) null))
+           null))
+        '(integer 0 10)
+        '(eql :initial-element)
+        #'(lambda (tp size k) (declare (ignore size k))
+                  (cadr tp)))
+  4)
+
+(def-type-prop-test make-sequence.5 'make-sequence
+  (list '(cons (eql vector)
+          (cons (member base-char character) null)) '(integer 0 10))
+  2)
+
+(def-type-prop-test make-sequence.6 'make-sequence
+  (list '(cons (eql vector) (cons (member base-char character) null))
+        '(integer 0 10)
+        '(eql :initial-element)
+        #'(lambda (tp size k) (declare (ignore size k)) (cadr tp)))
+  4)
+
+(def-type-prop-test make-sequence.7 'make-sequence
+  (list '(eql simple-vector)
+        '(integer 0 10))
+  2)
+
+(def-type-prop-test make-sequence.8 'make-sequence
+  (list '(eql simple-vector)
+        '(integer 0 10)
+        '(eql :initial-element)
+        t)
+  4)
+
+(def-type-prop-test make-sequence.9 'make-sequence
+  (list '(cons (eql simple-vector) (cons (integer 0 10) null))
+        #'(lambda (tp) `(eql ,(cadr tp))))
+  2)
+
+(def-type-prop-test make-sequence.10 'make-sequence
+  (list '(cons (eql simple-vector) (cons (integer 0 10) null))
+        #'(lambda (tp) `(eql ,(cadr tp)))
+        '(eql :initial-element)
+        t)
+  4)
+
+(def-type-prop-test make-sequence.11 'make-sequence
+  (list '(cons (eql vector) (cons (member * t) (cons (integer 0 10) null)))
+        #'(lambda (tp) `(eql ,(caddr tp))))
+  2)
+
+(def-type-prop-test make-sequence.12 'make-sequence
+  (list '(cons (eql vector) (cons (member * t) (cons (integer 0 10) null)))
+        #'(lambda (tp) `(eql ,(caddr tp)))
+        '(eql :initial-element)
+        t)
+  4)
+
+(def-type-prop-test make-sequence.13 'make-sequence
+  (list '(cons (eql vector) (cons (member base-char character)
+                             (cons (integer 0 10) null)))
+        #'(lambda (tp) `(eql ,(caddr tp))))
+  2)
+
+(def-type-prop-test make-sequence.14 'make-sequence
+  (list '(cons (eql vector) (cons (member base-char character)
+                             (cons (integer 0 10) null)))
+        #'(lambda (tp) `(eql ,(caddr tp)))
+        '(eql :initial-element)
+        #'(lambda (tp size k) (declare (ignore size k))
+                  `(eql ,(make-random-element-of-type (cadr tp)))))
+  4)
+
 (def-type-prop-test subseq.1 'subseq
   (list 'sequence #'(lambda (s) `(integer 0 ,(length s))))
   2)
@@ -67,6 +156,16 @@
         #'(lambda (s start) `(integer ,start ,(length s))))
   3)
 
+(def-type-prop-test length.subseq.1 '(lambda (s pos) (length (subseq s pos)))
+  (list 'sequence #'(lambda (s) `(integer 0 ,(length s))))
+  2)
+
+(def-type-prop-test length.subseq.2 '(lambda (s pos len) (length (subseq s pos len)))
+  (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
@@ -102,7 +201,7 @@
         #'(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))))))))
+              `(or ,@(loop for j from 1 to i collect `(vector (integer 0 ,(min (1- (ash 1 j)) (- (ash 1 i) 2)))))))))
   3)
 
 
@@ -197,6 +296,11 @@
 
 
 (def-type-prop-test length.1 'length '(sequence) 1)
+(def-type-prop-test length.2 '(lambda (s l) (<= (length s) l)) '(sequence integer) 2)
+(def-type-prop-test length.3 '(lambda (s l) (< (length s) l)) '(sequence integer) 2)
+(def-type-prop-test length.4 '(lambda (s l) (= (length s) l)) '(sequence integer) 2)
+(def-type-prop-test length.5 '(lambda (s l) (> (length s) l)) '(sequence integer) 2)
+(def-type-prop-test length.6 '(lambda (s l) (>= (length s) l)) '(sequence integer) 2)
 
 (def-type-prop-test reverse.1 'reverse '(sequence) 1)
 (def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t))
diff --git a/random/random-type-prop-tests-09.lsp b/random/random-type-prop-tests-09.lsp
index 46270c31..d71196a8 100644
--- a/random/random-type-prop-tests-09.lsp
+++ b/random/random-type-prop-tests-09.lsp
@@ -450,6 +450,22 @@
               'equal #'equal 'eql #'eql))
   6)
 
+(def-type-prop-test position.11 'position
+  (list 'bit #'make-random-sequence-type-containing)
+  2)
+
+(def-type-prop-test position.12 'position
+  (list 'symbol '(vector symbol))
+  2)
+
+(def-type-prop-test position.13 'position
+  (list 'base-char 'base-string)
+  2)
+
+(def-type-prop-test position.14 'position
+  (list 'character 'string)
+  2)
+
 ;;; POSITION-IF
 
 (def-type-prop-test position-if.1 'position-if
diff --git a/random/random-type-prop-tests-10.lsp b/random/random-type-prop-tests-10.lsp
index 71d23474..cd375e67 100644
--- a/random/random-type-prop-tests-10.lsp
+++ b/random/random-type-prop-tests-10.lsp
@@ -112,3 +112,76 @@
             (let ((len (length s2)))
               `(integer 0 ,len))))
   4)
+
+(def-type-prop-test search.13 '(lambda (seq1 seq2 s1 e1)
+                                (search seq1 seq2 :start1 s1 :end1 e1))
+  (list 'sequence 'sequence
+        #'(lambda (seq1 seq2)
+            (declare (ignore seq2))
+            `(integer 0 ,(length seq1)))
+        #'(lambda (seq1 seq2 s1)
+            (declare (ignore seq2))
+            `(or null (integer ,s1 ,(length seq1)))))
+  4)
+
+(def-type-prop-test search.14 '(lambda (seq1 seq2 s1 e1 s2)
+                                (search seq1 seq2 :start1 s1 :end1 e1 :start2 s2))
+  (list 'sequence 'sequence
+        #'(lambda (seq1 seq2)
+            (declare (ignore seq2))
+            `(integer 0 ,(length seq1)))
+        #'(lambda (seq1 seq2 s1)
+            (declare (ignore seq2))
+            `(or null (integer ,s1 ,(length seq1))))
+        #'(lambda (seq1 seq2 s1 e1)
+            (declare (ignore seq1 s1 e1))
+            `(integer 0 ,(length seq2))))
+  5)
+
+(def-type-prop-test search.15 '(lambda (seq1 seq2 s1 e1 s2 e2)
+                                (search seq1 seq2 :start1 s1 :end1 e1 :start2 s2 :end2 e2))
+  (list 'sequence 'sequence
+        #'(lambda (seq1 seq2)
+            (declare (ignore seq2))
+            `(integer 0 ,(length seq1)))
+        #'(lambda (seq1 seq2 s1)
+            (declare (ignore seq2))
+            `(or null (integer ,s1 ,(length seq1))))
+        #'(lambda (seq1 seq2 s1 e1)
+            (declare (ignore seq1 s1 e1))
+            `(integer 0 ,(length seq2)))
+        #'(lambda (seq1 seq2 s1 e1 s2)
+            (declare (ignore seq1 s1 e1))
+            `(or null (integer ,s2 ,(length seq2)))))
+  6)
+
+(def-type-prop-test search.16 '(lambda (seq1 seq2 s1 s2 e2)
+                                (search seq1 seq2 :start1 s1 :start2 s2 :end2 e2))
+  (list 'sequence 'sequence
+        #'(lambda (seq1 seq2)
+            (declare (ignore seq2))
+            `(integer 0 ,(length seq1)))
+        #'(lambda (seq1 seq2 s1)
+            (declare (ignore seq1 s1))
+            `(integer 0 ,(length seq2)))
+        #'(lambda (seq1 seq2 s1 s2)
+            (declare (ignore seq1 s1))
+            `(or null (integer ,s2 ,(length seq2)))))
+  5)
+
+(def-type-prop-test search.17 '(lambda (seq1 seq2 e1 s2 e2)
+                                (search seq1 seq2 :end1 e1 :start2 s2 :end2 e2))
+  (list 'sequence 'sequence
+        #'(lambda (seq1 seq2)
+            (declare (ignore seq2))
+            `(integer 0 ,(length seq1)))
+        #'(lambda (seq1 seq2 e1)
+            (declare (ignore seq1 e1))
+            `(integer 0 ,(length seq2)))
+        #'(lambda (seq1 seq2 e1 s2)
+            (declare (ignore seq1 e1))
+            `(or null (integer ,s2 ,(length seq2)))))
+  5)
+
+
+     
diff --git a/random/random-type-prop-tests-structs.lsp b/random/random-type-prop-tests-structs.lsp
index 9a4423ad..f0e353e9 100644
--- a/random/random-type-prop-tests-structs.lsp
+++ b/random/random-type-prop-tests-structs.lsp
@@ -70,3 +70,17 @@
 
 (def-type-prop-test structure-ref.2 'rtpt-2-a '(rtpt-2) 1)
 
+;;; Structures with typed fields
+
+(defstruct rtpt-3
+  (n 0 :type fixnum))
+
+(defmethod make-random-element-of-type ((type (eql 'rtpt-3)))
+  (let ((n (make-random-element-of-type 'fixnum)))
+    (make-rtpt-3 :n n)))
+
+(defmethod replicate ((obj rtpt-3))
+  (replicate-with (obj x (make-rtpt-3 :n (rtpt-3-n obj)))))
+
+(def-type-prop-test structure-ref.3 'rtpt-3-n '(rtpt-3) 1)
+(def-type-prop-test structure-assign.3 '(lambda (obj x) (setf (rtpt-3-n obj) x) (values obj (rtpt-3-n obj)))  '(rtpt-3 fixnum) 2)
diff --git a/random/random-type-prop-tests.lsp b/random/random-type-prop-tests.lsp
index 6f86d1c7..c7247b55 100644
--- a/random/random-type-prop-tests.lsp
+++ b/random/random-type-prop-tests.lsp
@@ -7,16 +7,8 @@
 
 (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")
+(loop for i from 1 to 17
+   do (load (format nil "random/random-type-prop-tests-~2,vD.lsp" #\0 i)))
 
-(load "random-type-prop-tests-structs.lsp")
+(load "random/random-type-prop-tests-structs.lsp")
 
diff --git a/random/random-type-prop.lsp b/random/random-type-prop.lsp
index dfb195df..e57fb5fc 100644
--- a/random/random-type-prop.lsp
+++ b/random/random-type-prop.lsp
@@ -6,19 +6,101 @@
 (in-package :cl-test)
 
 (eval-when (:compile-toplevel :load-toplevel)
-  (compile-and-load "ANSI-TESTS:AUX;random-aux.lsp")
-  (compile-and-load "random/random-int-form.lsp"))
+  ;; (compile-and-load "ANSI-TESTS:AUX;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 *param-types* *params* *is-var?* *form* *eval-form*))
 (declaim (special *replicate-type*))
 
 (defparameter *default-reps* 1000)
+(defparameter *default-test-reps* 1)
+(defparameter *default-enclosing-the* nil)
 (defparameter *default-cell* nil)
-(defparameter *default-ignore* 'arithmetic-error)
+(defparameter *default-ignore* '(or arithmetic-error internal-test-failure))
 (defparameter *default-arg-the* t)
+(defparameter *with-satisfies-eval* nil) ;; when true, can generate (satisfies eval) types in make-random-type-containing
+
+(defparameter *default-special-param-fn* #'(lambda (p v) (declare (ignore v)) p)
+  "Function called on parameter names to possibly enrich them before
+using them as actual parameters to the function call")
+
+(defparameter *spfg* 0 "Dummy variable for SPECIAL-PARAM-FN1 code")
+
+(declaim (notinline my-identity))
+(defun my-identity (x) x)
+
+(defun special-param-fn1 (p v)
+  (if (coin)
+      p
+      (let ((tp (make-random-type-containing v)))
+        `(labels ((%f () (the ,tp ,p))) ;; (my-identity ,p))))
+           (declare (dynamic-extent (function %f)))
+           (multiple-value-call #'%f (values))))))
+
+(defparameter *spf1a-counter* 0)
+
+(defun special-param-fn1a (p v)
+  (if (eql (mod (incf *spf1a-counter*) 2) 0)
+      (if (coin)
+          p
+          (let ((tp (make-random-type-containing v)))
+            `(labels ((%f () (the ,tp ,p))) ;; (my-identity ,p))))
+               (declare (dynamic-extent (function %f)))
+               (multiple-value-call #'%f (values)))))
+      p))
+
+(defparameter *spf2* t)
+
+(defun special-param-fn2 (p v)
+  (if (coin)
+      p
+      (let* ((tp (make-random-type-containing v))
+             (z (handler-case (make-random-element-of-type tp)
+                  (error () nil))))
+        (if (typep z tp)
+            `(flet ((%f (x) (the ,tp x)))
+               (if *spf2* (%f ,p) (%f ',z)))
+            p))))
+
+(defun special-param-fn3 (p v)
+  (if (coin)
+      p
+      (let ((z (make-random-element-of-type (type-of v)))
+            (tp (make-random-type-containing v)))
+        (if (typep z (type-of p))
+            `(flet ((%f (x) ,(if (coin) 'x `(the ,tp x))))
+               (if *spf2* (%f ,p) (%f ',z)))
+            p))))
+
+(defparameter *spf3* 0)
+
+(defun special-param-fn4 (p v)
+  (if (coin)
+      p
+      (let ((z1 (make-random-element-of-type (type-of v)))
+            (z2 (make-random-element-of-type (type-of v)))
+            (tp (make-random-type-containing v)))
+        (if (and (typep z1 (type-of p))
+                 (typep z2 (type-of p)))
+            `(flet ((%f (x) ,(if (coin) 'x `(the ,tp x))))
+               (case *spf3*
+                 (0 (%f ,p))
+                 (1 (%f ',z1))
+                 (t (%f ',z2))))
+            p))))
+
+(defun special-param-fn5 (p v)
+  (if (coin)
+      p
+      (let ((tp1 (make-random-type-containing v))
+            (tp2 (make-random-type-containing v)))
+        `(labels ((%f () (the ,tp1 (the ,tp2 ,p))))
+           (declare (dynamic-extent (function %f)))
+           (multiple-value-call #'%f (values))))))
 
 ;;;
 ;;; The random type prop tester takes three required arguments:
@@ -70,6 +152,11 @@
 ;;;  reps        *default-reps*  Number of repetitions to try before stopping.
 ;;;                              The default is controlled by a special variable that
 ;;;                              is initially 1000.
+;;;  test-reps   *default-test-reps*
+;;;                              Execute each test TEST-REPS times (default 1).
+;;;                              This is intended to help track down failures due to
+;;;                              insideous memory corruption that show up some time
+;;;                              after the actual bad input.
 ;;;  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
@@ -94,16 +181,19 @@
 (defun do-random-type-prop-tests
   (operator arg-types minargs
             &key
+            (special-param-fn *default-special-param-fn*)
             (maxargs minargs)
             (rest-type t)
             (reps *default-reps*)
-            (enclosing-the nil)
+            (test-reps *default-test-reps*)
+            (enclosing-the *default-enclosing-the*)
             (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))
+  (assert (typep test-reps '(integer 1)))
 (prog1
   (dotimes (i reps)
     again
@@ -124,11 +214,9 @@
           ; (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))
+          (vals (mapcar #'(lambda (r v) (if r (replicate v) v)) replicate vals))
           (is-var? (if (consp replicate)
+                        ;; Do not directly include values that are to be replicated
                        (progn
                          (assert (= (length replicate) (length vals)))
                          (loop for x in replicate collect (or x (coin))))
@@ -138,7 +226,8 @@
                         for p in param-names
                         when x collect p))
           (param-types (mapcar #'make-random-type-containing vals replicate))
-          (*param-types* param-types)
+          (*param-types* (progn (finish-output *trace-output*)
+                                 param-types))
           (type-decls (loop for x in is-var?
                             for p in param-names
                             for tp in param-types
@@ -147,12 +236,15 @@
           (rval (cl:handler-bind
                  (#+sbcl (sb-ext::compiler-note #'muffle-warning)
                          (warning #'muffle-warning))
-                 (let* ((vals (if replicate (mapcar #'replicate vals) vals))
+                  (let* ((vals (mapcar #'(lambda (r v) (if r (replicate v) v)) replicate vals))
                         (eval-form (cons operator (loop for v in vals
                                                         collect `(quote ,v)))))
                    ;; (print eval-form) (terpri)
                    ;; (dotimes (i 100) (eval eval-form))
+                    (setf *eval-form* eval-form)
+                    ;; (format t "Calling EVAL on ~s~%" eval-form)
                    (eval eval-form))))
+           ;; (_ (format t "EVAL returned ~s~%" rval))
           (result-type (if (and enclosing-the (integerp rval))
                            (make-random-type-containing rval)
                          t))
@@ -160,11 +252,12 @@
                                     for v in vals
                                     for r in replicate
                                     for p in param-names
+                                    for p-arg = (if r p (funcall special-param-fn p v))
                                     collect (if x
                                                 (if (and arg-the (coin))
                                                     (let ((tp (make-random-type-containing v r)))
-                                                      `(the ,tp ,p))
-                                                  p)
+                                                      `(the ,tp ,p-arg))
+                                                  p-arg)
                                               (if (or (consp v)
                                                       (and (symbolp v) (not (or (keywordp v)
                                                                                 (member v '(nil t))))))
@@ -195,19 +288,36 @@
              (*print-case* :downcase))
          (print (list :form form :vals vals))))
      (finish-output)
-     (let* ((param-vals (loop for x in is-var?
+     (let ((result nil))
+       (loop repeat test-reps
+            do (when *print-random-type-prop-input* (princ #\.))
+            do (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?
+                                     (warning #'muffle-warning)
+                                     (error
+                                      (lambda (e)
+                                        (declare (special *error-lambda*)
+                                                 (ignore e))
+                                        (setf *error-lambda* form))))
+                           ;; (format t "Compiling...") (finish-output)
+                           (multiple-value-bind (fn warning-p failure-p)
+                               (compile nil form)
+                             (declare (ignore warning-p))
+                             ;; (format t "...done~%") (finish-output)
+                             (when failure-p
+                               (return
+                                 (setf *random-type-prop-result*
+                                       (list :form form
+                                             :compile-error t))))
+                             fn))))
+                 (setf 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))))
+                                  (apply fn param-vals)))))
        (setq *random-type-prop-result*
              (list :upgraded-result-type upgraded-result-type
                    :form form
@@ -215,7 +325,9 @@
                    :result result
                    :rval rval))
        (unless (funcall test result rval)
-         (return *random-type-prop-result*))))
+         (return *random-type-prop-result*))
+       ;; (format t "p") (finish-output)
+       ))
     ;; #+allegro (excl::gc t)
   ))))
 
@@ -245,7 +357,11 @@
 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*)
+(defvar *replicate-type* nil
+  "When true, the type is for a parameter that will be replicated, so don't
+generate types that depend on its object identity like EQL or MEMBER")
+
+(defun make-random-type-containing (type &optional (*replicate-type* *replicate-type*))
   (declare (special *replicate-type*))
   (make-random-type-containing* type))
 
@@ -254,9 +370,32 @@ use the value in MEMBER or EQL type specifiers."))
      (declare (special *replicate-type*))
      (rcase
       (1 t)
+      (1 (if (and *with-satisfies-eval* (not (or (symbolp val)
+                                                 (listp val))))
+             '(satisfies eval)
+             (throw 'fail nil)))
       (1 (if (consp val) 'cons 'atom))
       (1 (if *replicate-type* (make-random-type-containing* val)
            `(eql ,val)))
+      (1 ; (when (or (listp val) (symbolp val)) (throw 'fail nil))
+         (let* ((e (make-random-element-of-type t)) ;; '(and t (not list) (not symbol))))
+                (t2 (make-random-type-containing e))
+                (t1 (make-random-type-containing val)))
+           (rcase
+             (1 `(or ,t1 ,t2))
+             (1 `(or ,t2 ,t1)))))
+      (1 (let* ((e1 (make-random-element-of-type t))
+                (e2 (make-random-element-of-type t))
+                (t1 (make-random-type-containing e1))
+                (t2 (make-random-type-containing e2))
+                (t3 (make-random-type-containing val))
+                (t4 (make-random-type-containing val)))
+           (rcase
+             (1 `(and (or ,t1 ,t3) (or ,t2 ,t4)))
+             (1 `(and (or ,t1 ,t3) (or ,t4 ,t2)))
+             (1 `(and (or ,t3 ,t1) (or ,t2 ,t4)))
+             (1 `(and (or ,t3 ,t1) (or ,t4 ,t2))))))
+      (1 (class-of val))
       (1
        (if *replicate-type* (make-random-type-containing* val)
          (let* ((n1 (random 4))
@@ -294,6 +433,11 @@ use the value in MEMBER or EQL type specifiers."))
       (4 (let ((lo (abs (make-random-integer)))
                (hi (abs (make-random-integer))))
            `(integer ,(- val lo) ,(+ val hi))))
+      (1 (let ((len (max 1 (integer-length val)))
+               (r (min (random 80) (random 80))))
+           (if (and (>= val 0) (coin))
+               `(unsigned-byte ,(+ len r))
+               `(signed-byte ,(+ len (max 1 r))))))
       (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil)))))
 
   (2 ((val character))
@@ -352,6 +496,8 @@ use the value in MEMBER or EQL type specifiers."))
              `(,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)
@@ -461,8 +607,7 @@ use the value in MEMBER or EQL type specifiers."))
 ;;; Macro for defining random type prop tests
 
 (defmacro def-type-prop-test (name &body args)
-  `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP."
-                                  (string name))
+  `(deftest ,(intern (concatenate 'string "RTP." (string name))
                      (find-package :cl-test))
      (do-random-type-prop-tests ,@args)
      nil))
@@ -482,8 +627,15 @@ use the value in MEMBER or EQL type specifiers."))
    (1 `(simple-array ,element-type (,length)))
    (2 (make-list-type length 'null element-type))))
 
+(defvar *random-sequence-type* nil)
+
+(defvar *random-sequence-type-size* 10
+  "(Exclusive) upper bound on size for randomly generated sequences.")
+
 (defun make-random-sequence-type-containing (element &optional *replicate-type*)
-  (make-sequence-type (random 10) (make-random-type-containing* element)))
+  (setf *random-sequence-type*
+        (make-sequence-type (random *random-sequence-type-size*)
+                            (make-random-type-containing* element))))
 
 (defun same-set-p (set1 set2 &rest args &key key test test-not)
   (declare (ignorable key test test-not))
@@ -509,6 +661,28 @@ use the value in MEMBER or EQL type specifiers."))
   (declare (ignore v1 other))
   (let ((d (length v2))) `(integer 0 ,d)))
 
+(defun start-type-for-v (v &rest other)
+  (let* ((d (length v))
+         (end (or (cadr (member :end other)) d)))
+    `(integer 0 ,end)))
+
+(defun start-type-for-v1 (v1 v2 &rest other)
+  (declare (ignore v2))
+  (let* ((d (length v1))
+         (end1 (or (cadr (member :end1 other)) d)))
+    `(integer 0 ,end1)))
+
+(defun start-type-for-v2 (v1 v2 &rest other)
+  (declare (ignore v1))
+  (let* ((d (length v2))
+         (end2 (or (cadr (member :end2 other)) d)))
+    `(integer 0 ,end2)))
+
+(defun end-type-for-v (v &rest other)
+  (let ((d (length v))
+        (start (or (cadr (member :start other)) 0)))
+    `(integer ,start ,d)))
+
 (defun end-type-for-v1 (v1 v2 &rest other)
   (declare (ignore v2))
   (let ((d (length v1))
@@ -521,6 +695,18 @@ use the value in MEMBER or EQL type specifiers."))
         (start2 (or (cadr (member :start2 other)) 0)))
     `(integer ,start2 ,d)))
 
+(defun start-end-type (v1 v2 &rest other)
+  ;; General case of the above
+  (assert other)
+  (let ((s (car (last other))))
+    (apply
+     (ecase s
+       (:start1 #'start-type-for-v1)
+       (:start2 #'start-type-for-v2)
+       (:end1 #'end-type-for-v1)
+       (:end2 #'end-type-for-v2))
+     v1 v2 other)))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -662,3 +848,35 @@ use the value in MEMBER or EQL type specifiers."))
 (defun equalp-and-eql-elements (s1 s2)
   (and (equalp s1 s2)
        (every #'eql s1 s2)))
+
+;;; Bag equality of lists
+(defun bag-equal (b1 b2 &key (test #'eql))
+  (and
+   (= (length b1) (length b2))
+   (cond
+     ((or (member test '(eq eql equal equalp))
+          (member test (mapcar #'symbol-function '(eq eql equal equalp))))
+      (let ((tab (make-hash-table :test test)))
+        (dolist (x b1) (incf (gethash x tab 0)))
+        (dolist (x b2) (decf (gethash x tab 0)))
+        (maphash (lambda (k v) (declare (ignore k))
+                         (unless (eql v 0)
+                           (return-from bag-equal nil)))
+                 tab)
+        t))
+     (t
+      ;; Cannot use hash tables
+      ;; Be quadratically slow
+      (setf b2 (copy-list b2))
+      (loop for x in b1
+         always (cond
+                  ((funcall test x (car b2))
+                   (pop b2)
+                   t)
+                  (t
+                   (loop for e on b2
+                      do (when (and (cdr e)
+                                (funcall test x (cadr e)))
+                           (setf (cdr e) (cddr e))
+                           (return t))
+                      finally (return nil)))))))))
diff --git a/random/random-types.lsp b/random/random-types.lsp
index fa9b061d..7f047312 100644
--- a/random/random-types.lsp
+++ b/random/random-types.lsp
@@ -5,12 +5,29 @@
 
 (in-package :cl-test)
 
-(compile-and-load "types-aux.lsp")
-(compile-and-load "random-aux.lsp")
-(compile-and-load "random-int-form.lsp")
+;; (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-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-type (size)
   (if (<= size 1)
       (rcase
@@ -30,6 +47,25 @@
                (lo (min x y))
                (hi (max x y)))
           `(integer ,lo ,hi)))
+       (1 ;; sequences and arrays
+        (rcase
+          (1 'sequence)
+          (1 'list)
+          (1 'array)
+          (1 (let ((tp (make-random-type 1)))
+               (if (coin 3)
+                   `(and (array ,tp) (not simple-array))
+                   `(array ,tp))))
+          (1 'simple-array)
+          (1 (let ((tp (make-random-type 1)))
+               `(simple-array ,tp)))
+          (1 (rcase
+               (1 'string)
+               (1 '(and string (not simple-string)))
+               (1 'simple-string)
+               (1 'base-string)
+               (1 '(and base-string (not simple-base-string)))
+               (1 'simple-base-string)))))
        (1 (make-random-real-type))
        ;; (1 (make-random-complex-type))
        )
@@ -43,23 +79,6 @@
      ; (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)))
 
@@ -74,7 +93,6 @@
         (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))
@@ -162,6 +180,23 @@
 
             (t (%f)))))))
 
+(defun test-types (t1 t2)
+  "Return true if a bug in subtypep has been found related
+to types T1 and T2."
+  (handler-case
+      (multiple-value-bind (sub success)
+          (subtypep t1 t2)
+        (when success
+          (if sub
+              (check-all-subtypep t1 t2)
+              (let ((nt1 `(not ,t1))
+                    (nt2 `(not ,t2)))
+                ;; Here, subtypep thinks t1 is not a subtype of t1,
+                ;; so confirm subtypep does not also think
+                ;; (not t2) is a subtype of (not t1)
+                (subtypep nt2 nt1)))))
+    (error (e) e)))
+
 (defun test-random-types (n size)
   (loop for t1 = (make-random-type size)
         for t2 = (make-random-type size)
@@ -176,8 +211,10 @@
 
 (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 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))
@@ -187,16 +224,6 @@
         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)))
@@ -273,10 +300,16 @@
   (values))
 
 (defun prune-type-pair (pair &optional (fn #'test-types))
+  "PAIR is a list of two types, and FN is a function that,
+when called on two types, returns T if the pair succeeds
+at demonstrating some bug.  Reduce the pair to a minimal
+pair that still shows the bug."
   (declare (type function fn))
+  (assert (typep pair '(cons t (cons t null))))
   (let ((t1 (first pair))
         (t2 (second pair))
         changed)
+    (assert (funcall fn t1 t2))
     (loop
      do (flet ((%try2 (new-tp)
                       (when (funcall fn t1 new-tp)
@@ -302,7 +335,8 @@
 
 (defun test-type-triple (t1 t2 t3)
   ;; Returns non-nil if a problem is found
-  (catch 'problem
+  (handler-case
+      (catch 'problem  ;; why
     (multiple-value-bind (sub1 success1)
         (subtypep t1 t2)
       (when success1
@@ -311,7 +345,8 @@
              (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))))))))
+                    (subtypep t1 `(and ,t2 ,t3)))))))
+    (error (e) e)))
 
 (defun test-random-types3 (n size)
   (loop for t1 = (make-random-type (1+ (random size)))
@@ -326,12 +361,14 @@
         collect (list t1 t2 t3)
         finally (terpri)))
 
-(defun prune-type-triple (pair &optional (fn #'test-type-triple))
+(defun prune-type-triple (triple &optional (fn #'test-type-triple))
   (declare (type function fn))
-  (let ((t1 (first pair))
-        (t2 (second pair))
-        (t3 (third pair))
+  (assert (typep triple '(cons t (cons t (cons t null)))))
+  (let ((t1 (first triple))
+        (t2 (second triple))
+        (t3 (third triple))
         changed)
+    (assert (funcall fn t1 t2 t3))
     (loop
      do (flet ((%try2 (new-tp)
                       (when (funcall fn t1 new-tp t3)
@@ -353,7 +390,7 @@
             (prune-type t1 #'%try1)))
      do (flet ((%try3 (new-tp)
                       (when (funcall fn t1 t2 new-tp)
-                        (print "Success in second loop")
+                        (print "Success in third loop")
                         (print new-tp)
                         (setq t3 new-tp
                               changed t)
diff --git a/structures/structure-00.lsp b/structures/structure-00.lsp
index b0b26ac0..1f393c0d 100644
--- a/structures/structure-00.lsp
+++ b/structures/structure-00.lsp
@@ -140,6 +140,11 @@
 ;; structure definition and the tests.
 ;;
 
+(declaim (ftype (function (t t) (values cons &optional))
+                defstruct-with-tests-fun)
+         (ftype (function (t t &optional t) (values t t &optional))
+                defstruct-maketemp))
+
 (defmacro defstruct-with-tests
     (name-and-options &body slot-descriptions-and-documentation)
 "Construct standardized tests for a defstruct, and also
diff --git a/system-construction/compile-file.lsp b/system-construction/compile-file.lsp
index 7a60efa6..1e6f972e 100644
--- a/system-construction/compile-file.lsp
+++ b/system-construction/compile-file.lsp
@@ -18,6 +18,7 @@
                               (compile-file-pathname file)))
          (actual-warnings-p nil)
          (actual-style-warnings-p nil))
+    (declare (ignorable actual-style-warnings-p))
     (when (probe-file target-pathname)
       (delete-file target-pathname))
     (fmakunbound funname)
diff --git a/universe.lsp b/universe.lsp
index 4e6bbdc1..f9212ac7 100644
--- a/universe.lsp
+++ b/universe.lsp
@@ -42,7 +42,7 @@
 (defparameter *condition-objects*
   (locally (declare (optimize safety))
            (loop for tp in *condition-types* append
-                 (handler-case (list (make-condition tp))
+                 (cl:handler-case (list (make-condition tp))
                                (error () nil)))))
 
 (defparameter *standard-package-names*
@@ -51,7 +51,7 @@
 (defparameter *package-objects*
   (locally (declare (optimize safety))
            (loop for pname in *standard-package-names* append
-                 (handler-case (let ((pkg (find-package pname)))
+                 (cl:handler-case (let ((pkg (find-package pname)))
                                  (and pkg (list pkg)))
                                (error () nil)))))
 
@@ -160,7 +160,7 @@
   (declare (optimize safety))
   (loop
     for name in namelist append
-        (handler-case
+        (cl:handler-case
             (list (read-from-string
                    (concatenate 'string "\#\\" name)))
           (error () nil))))
@@ -357,7 +357,7 @@
 
      ;; The ever-popular NIL array
      (locally (declare (optimize safety))
-              (handler-case
+              (cl:handler-case
                (list (make-array '(0) :element-type nil))
                (error () nil)))
 
-- 
GitLab