diff --git a/ansi-tests/cl-symbol-names.lsp b/ansi-tests/cl-symbol-names.lsp
index 9d7c06df0b1ce9674094ba7c9382bc53a096c6f8..e0b8acd6b152d0d7a43da33fe943d927da014412 100644
--- a/ansi-tests/cl-symbol-names.lsp
+++ b/ansi-tests/cl-symbol-names.lsp
@@ -2148,6 +2148,9 @@
 		 *cl-standard-generic-function-symbols*
 		 '(declare)))))
 
+(defparameter *cl-function-or-accessor-symbols*
+  (append *cl-function-symbols* *cl-accessor-symbols*))
+
 (defparameter *cl-non-variable-constant-symbols*
   (set-difference
    *cl-symbols*
diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp
index e48f18aa89dae010ae5e153ec52a282e784e993e..56895a90a2d55235d4ddb2147a83f07999e9080d 100644
--- a/ansi-tests/random-aux.lsp
+++ b/ansi-tests/random-aux.lsp
@@ -18,6 +18,24 @@
        ,@(loop for i from 0 for e in cases collect `(,i ,e))
        (t (error "Can't happen?! (in random-case)~%")))))
 
+(defmacro rcase (&body cases)
+  "Usage: (RCASE (<weight> <form>+)+), where <weight> is a positive real
+   indicating the relative probability of executing the associated implicit
+   progn."
+  (assert cases)
+  (let* ((weights (mapcar #'car cases))
+	 (cumulative-weights (let ((sum 0))
+			       (loop for w in weights collect (incf sum w))))
+	 (total (car (last cumulative-weights)))
+	 (r (gensym)))
+    (assert (every #'plusp weights))
+    `(let ((,r (random ,total)))
+       (cond
+	,@(loop for case in (butlast cases)
+		for cw in cumulative-weights
+		collect `((< ,r ,cw) ,@(cdr case)))
+	(t ,@(cdar (last cases)))))))
+
 (defun random-nonnegative-real ()
   (if (coin 3)
       (random-case
diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp
index 00f72747daa0280bf38bf68905556e9dd4e17206..ce9bc3c68df1f21bcc8c243c9c0b397704ccdf4f 100644
--- a/ansi-tests/random-int-form.lsp
+++ b/ansi-tests/random-int-form.lsp
@@ -32,7 +32,10 @@
 ;;; that will eventually replace this preliminary effort.
 ;;;
 
-(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*))
+(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*
+		  *opt-result* *unopt-result*))
+
+(defvar *random-int-form-blocks* nil)
 
 (defun test-random-integer-forms (size nvars n)
 
@@ -55,46 +58,20 @@
   (let* ((form (make-random-integer-form size vars))
 	 (var-ranges (mapcar #'make-random-integer-range vars))
 	 (var-types (mapcar #'(lambda (range)
-				`(integer ,(car range) ,(cadr range)))
+				(let ((lo (car range))
+				      (hi (cadr range)))
+				  (assert (>= hi lo))
+				  `(integer ,lo ,hi)))
 			    var-ranges))
-	 (optimized-fn-src
-	  `(lambda ,vars (declare ,@(mapcar #'(lambda (tp var)
-						`(type ,tp ,var))
-					    var-types vars)
-				  (ignorable ,@vars)
-				  (optimize #+cmu (extensions:inhibit-warnings 3)
-					    (speed 3) (safety 1) (debug 1)))
-	     ,form))
-	 (unoptimized-fn-src
-	  `(lambda ,vars
-	     (declare (notinline ,@(fn-symbols-in-form form))
-		      (optimize #+cmu (extensions:inhibit-warnings 3)
-				(safety 3) (speed 0) (debug 3))
-		      (ignorable ,@vars))
-	     ,form)))
-    (setq *optimized-fn-src* optimized-fn-src
-	  *unoptimized-fn-src* unoptimized-fn-src)
-    (#+sbcl handler-bind
-     #+sbcl ((sb-ext::compiler-note #'muffle-warning))
-     #-sbcl progn
-     (let ((optimized-compiled-fn (compile nil optimized-fn-src))
-	   (unoptimized-compiled-fn (compile nil unoptimized-fn-src)))
-       (dotimes (i 20 nil)
-	 (let ((vals
+	 (vals-list
+	  (loop repeat 20
+		collect
 		(mapcar #'(lambda (range)
 			    (let ((lo (car range))
 				  (hi (cadr range)))
 			      (random-from-interval (1+ hi) lo)))
-			var-ranges)))
-	   (setq *int-form-vals* vals)
-	   (let ((opt-result (apply unoptimized-compiled-fn vals))
-		 (unopt-result (apply optimized-compiled-fn vals)))
-	     (if (equal opt-result unopt-result)
-		 nil
-	       (return (list (list vars vals
-				   unoptimized-fn-src
-				   optimized-fn-src
-				   )))))))))))
+			var-ranges))))
+    (test-int-form form vars var-types vals-list)))
 
 (defun fn-symbols-in-form (form)
   "Return a list of the distinct standardized lisp function
@@ -102,7 +79,7 @@
    declaration for the unoptimized form."
   (intersection
    (remove-duplicates (fn-symbols-in-form* form) :test #'eq)
-   *cl-function-symbols*))
+   *cl-function-or-accessor-symbols*))
 
 (defun fn-symbols-in-form* (form)
   (when (consp form)
@@ -114,7 +91,7 @@
   "Generate a list (LO HI) of integers, LO <= HI.  This is used
    for generating integer types."
   (declare (ignore var))
-  (flet ((%r () (let ((r (ash 1 (1+ (random 32)))))
+  (flet ((%r () (let ((r (ash 1 (1+ (random 35)))))
 		  (- (random r) (floor (/ r 2))))))
     (let ((x (%r))
 	  (y (%r)))
@@ -130,24 +107,26 @@
 	    (- (random r) (floor (/ r 2))))
 	(random-from-seq vars))
     ;; (> size 1)
-    (ecase (random 9)
+    (rcase
      ;; Unary ops
-     ((0 1)
-      (let ((op (random-from-seq '(- abs signum 1+ 1- identity
+     (40
+      (let ((op (random-from-seq '(- abs abs signum signum 1+ 1- identity
 				     integer-length logcount))))
 	`(,op ,(make-random-integer-form (1- size) vars))))
      ;; Binary op
-     ((2 3 4 5)
+     (80
       (let* ((op (random-from-seq
-		  '(+ - * logand min max ;; gcd lcm
-		      logandc1 logandc2 logeqv logior lognand lognor logorc1
+		  '(+ - * logand min max min max ;; gcd lcm
+		      #-:allegro logandc1  ;; bug in ACL 6.2 makes this cause crashes
+		      logandc2 logeqv logior lognand lognor logorc1
 		      logorc2 logxor))))
 	(destructuring-bind (leftsize rightsize)
 	    (random-partition (1- size) 2)
-	  `(,op ,(make-random-integer-form leftsize vars)
-		,(make-random-integer-form rightsize vars)))))
+	  (let ((e1 (make-random-integer-form leftsize vars))
+		(e2 (make-random-integer-form rightsize vars)))
+	    `(,op ,e1 ,e2)))))
      ;; conditionals
-     (6
+     (20
       (let* ((cond-size (random (max 1 (floor size 2))))
 	     (then-size (random (- size cond-size)))
 	     (else-size (- size 1 cond-size then-size))
@@ -155,52 +134,86 @@
 	     (then-part (make-random-integer-form then-size vars))
 	     (else-part (make-random-integer-form else-size vars)))
 	`(if ,pred ,then-part ,else-part)))
-     (7
+     (10
       (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
 	`(,(random-from-seq '(deposit-field dpb))
 	  ,(make-random-integer-form s1 vars)
 	  ,(make-random-byte-spec-form s2 vars)
 	  ,(make-random-integer-form s3 vars))))
-     (8
+     (10
       (destructuring-bind (s1 s2) (random-partition (1- size) 2)
 	  `(,(random-from-seq '(ldb mask-field))
 	    ,(make-random-byte-spec-form s1 vars)
 	    ,(make-random-integer-form s2 vars))))
+     (20
+      (destructuring-bind (s1 s2) (random-partition (1- size) 2)
+	(let* ((var (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
+	       (e1 (make-random-integer-form s1 vars))
+	       (e2 (make-random-integer-form s2 (cons var vars))))
+	  ;; for now, avoid shadowing
+	  (if (member var vars)
+	      (make-random-integer-form size vars)
+	    `(let ((,var ,e1)) ,e2)))))
+     (10
+      (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) vars))))
+     (1
+      (if *random-int-form-blocks*
+	  (let ((name (random-from-seq *random-int-form-blocks*))
+		(form (make-random-integer-form (1- size) vars)))
+	    `(return-from ,name ,form))
+	;; No blocks -- try again
+	(make-random-integer-form size vars)))
+
+     (5
+      (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 vars))
+		  (then (make-random-integer-form s2 vars))
+		  (else (make-random-integer-form s3 vars)))
+	      `(if ,pred (return-from ,name ,then) ,else)))
+	;; No blocks -- try again
+	(make-random-integer-form size vars)))
+		
      )))
 
 (defun make-random-pred-form (size vars)
   (if (<= size 1)
-      (ecase (random 3)
-	(0 (if (coin) t nil))
-	((1 2)
+      (rcase
+	(1 (if (coin) t nil))
+	(2
 	 `(,(random-from-seq '(< <= = > >= /= eql equal))
 	   ,(make-random-integer-form size vars)
 	   ,(make-random-integer-form size vars))))
-    (ecase (random 6)
-      (0 (if (coin) t nil))
+    (rcase
+      (1 (if (coin) t nil))
       (1 `(not ,(make-random-pred-form (1- size) vars)))
       (2 (destructuring-bind (leftsize rightsize)
 	     (random-partition (1- size) 2)
 	   `(,(random-from-seq '(and or))
 	     ,(make-random-pred-form leftsize vars)
 	     ,(make-random-pred-form rightsize vars))))
-      (3 (destructuring-bind (leftsize rightsize)
+      (1 (destructuring-bind (leftsize rightsize)
 	     (random-partition (1- size) 2)
 	   `(,(random-from-seq '(< <= > >= = /= eql equal))
 	     ,(make-random-integer-form leftsize vars)
 	     ,(make-random-integer-form rightsize vars))))
-      (4 (let* ((cond-size (random (max 1 (floor size 2))))
+      (1 (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 vars))
 		(then-part (make-random-pred-form then-size vars))
 		(else-part (make-random-pred-form else-size vars)))
 	   `(if ,pred ,then-part ,else-part)))
-      (5 (destructuring-bind (s1 s2)
+      (1 (destructuring-bind (s1 s2)
 	     (random-partition (1- size) 2)
 	   `(ldb-test ,(make-random-byte-spec-form s1 vars)
 		      ,(make-random-integer-form s2 vars))))
-
+      (1 (let ((index (random (1+ (random 35))))
+	       (form (make-random-integer-form (1- size) vars)))
+	   `(logbitp ,index ,form)))
       )))
 
 (defun make-random-byte-spec-form (size vars)
@@ -218,3 +231,223 @@
    (t
     (let ((n1 (1+ (random (floor n p)))))
       (cons n1 (random-partition (- n n1) (1- p)))))))
+
+;;; Interface to the form pruner
+
+(defun test-int-form (form vars var-types vals-list)
+  ;; Try to compile FORM with associated VARS, and if it compiles
+  ;; check for equality of the two compiled forms.
+  ;; Return a non-nil list of details if a problem is found,
+  ;; NIL otherwise.
+  (let ((optimized-fn-src
+	  `(lambda ,vars
+	     (declare ,@(mapcar #'(lambda (tp var)
+				    `(type ,tp ,var))
+				var-types vars)
+		      (ignorable ,@vars)
+		      (optimize #+cmu (extensions:inhibit-warnings 3)
+				(speed 3) (safety 1) (debug 1)))
+	     ,form))
+	 (unoptimized-fn-src
+	  `(lambda ,vars
+	     (declare (notinline ,@(fn-symbols-in-form form))
+		      (optimize #+cmu (extensions:inhibit-warnings 3)
+				(safety 3) (speed 0) (debug 3))
+		      (ignorable ,@vars))
+	     ,form)))
+    (setq *int-form-vals* nil
+	  *optimized-fn-src* optimized-fn-src
+	  *unoptimized-fn-src* unoptimized-fn-src)
+    (handler-bind
+     (#+sbcl (sb-ext::compiler-note #'muffle-warning)
+	     (warning #'muffle-warning)
+	     (error #'(lambda (c)
+			(format t "Compilation failure~%")
+			(return-from test-int-form
+			  (list (list :vars vars
+				      :form form
+				      :var-types var-types
+				      :vals (first vals-list)
+				      :compiler-condition c))))))
+     (let ((optimized-compiled-fn (compile nil optimized-fn-src))
+	   (unoptimized-compiled-fn (compile nil unoptimized-fn-src)))
+       (dolist (vals vals-list)
+	 (setq *int-form-vals* vals)
+	 (let ((unopt-result (multiple-value-list
+			    (apply unoptimized-compiled-fn vals)))
+	       (opt-result (multiple-value-list
+			      (apply optimized-compiled-fn vals))))
+	   (if (equal opt-result unopt-result)
+	       nil
+	     (progn
+	       (format t "Different results: ~A, ~A~%"
+		       opt-result unopt-result)
+	       (setq *opt-result* opt-result
+		     *unopt-result* unopt-result)
+	       (return (list (list :vars vars
+				   :vals vals
+				   :form form
+				   :var-types var-types
+				   :optimized-values opt-result
+				   :unoptimized-values unopt-result
+				   )))))))))))
+
+(defun prune-int-form (form vars var-types vals-list)
+  (flet ((%try-fn (new-form)
+		  (when (test-int-form new-form vars var-types vals-list)
+		    (setf form new-form)
+		    (throw 'success nil))))
+    (loop
+     (catch 'success
+       (prune form #'%try-fn)
+       (return form)))))
+
+(defun prune-results (result-list)
+  (assert result-list)
+  (loop for result in result-list
+	collect
+	(let ((form (getf result :form))
+	      (vars (getf result :vars))
+	      (var-types (getf result :var-types))
+	      (vals-list (list (getf result :vals)))
+	      )
+	  `(:vars ,vars
+	    :var-types ,var-types
+	    :vals ,(first vals-list)
+	    :form ,(prune-int-form form vars var-types vals-list)))))
+
+;;;
+;;; The call (PRUNE form try-fn) attempts to simplify the lisp form
+;;; so that it still satisfies TRY-FN.  The function TRY-FN should
+;;; return if the substitution is a failure.  Otherwise, it should
+;;; transfer control elsewhere via GO, THROW, etc.
+;;;
+;;; The return value of PRUNE should be ignored.
+;;;
+(defun prune (form try-fn)
+  (flet ((try (x) (funcall try-fn x)))
+    (when (consp form)
+      (let ((op (car form))
+	    (args (cdr form)))
+	(case op
+	 
+	 ((signum integer-length logcount
+		  gcd lcm logandc1 logandc2 lognand lognor logorc1 logorc2)
+	  (mapc #'try args)
+	  (try 0)
+	  (try 1)
+	  (try -1)
+	  (prune-fn form try-fn))
+	 
+	 ((abs 1+ 1- identity)
+	  (mapc #'try args)
+	  (prune-fn form try-fn))
+	 
+	 ((- + * min max logand logior logxor logeqv and or not eq eql equal = < > <= >= /=)
+	  (when (every #'constantp args)
+	    (try (eval form)))
+	  (mapc #'try args)
+	  (prune-fn form try-fn))
+	 
+	 ((if)
+	  (let (;; (pred (first args))
+		(then (second args))
+		(else (third args)))
+	    (try then)
+	    (try else)
+	    (prune-fn form try-fn)))
+
+	 ((byte)
+	  (prune-fn form try-fn))
+
+	 ((deposit-field dpb)
+	  (try (first args))
+	  (try (third args))
+	  (prune-fn form try-fn))
+
+	 ((ldb mask-field)
+	  (try (second args))
+	  (prune-fn form try-fn))
+
+	 ((ldb-test)
+	  (prune-fn form try-fn))
+
+	 ((let let*)
+	  (prune-let form try-fn))
+
+	 ((block)
+	  (let ((name (second form))
+		(body (cddr form)))
+	    (when (and body (null (cdr body)))
+	      (when (not (find-in-tree name body))
+		(try (first body)))
+	      ;; Simplify the subexpression
+	      (prune (first body)
+		     #'(lambda (x)
+			 (try `(block ,name ,x)))))))
+	 
+	 (otherwise
+	  (prune-fn form try-fn))
+	 )))))
+
+(defun find-in-tree (value tree)
+  (or (eql value tree)
+      (and (consp tree)
+	   (or (find-in-tree value (car tree))
+	       (find-in-tree value (cdr tree))))))
+
+(defun prune-fn (form try-fn)
+  (let* ((i 0)
+	 (op (car form))
+	 (args (cdr form))
+	 (len (length args)))
+    (flet ((try-arg (x)
+		    (funcall
+		     try-fn
+		     (cons op
+			   (append (subseq args 0 i)
+				   (list x)
+				   (subseq args (1+ i)))))))
+      (declare (dynamic-extent (function try-arg)))
+      (loop while (< i len)
+	    do (prune (elt args i) #'try-arg)
+	       (incf i)))))
+
+(defun prune-let (form try-fn)
+  (let* ((op (car form))
+	 (binding-list (cadr form))
+	 (body (cddr form))
+	 (body-len (length body))
+	 (len (length binding-list)))
+    (when (and (eql len 1)
+	       (eql body-len 1)
+	       (eql (caar binding-list) (car body)))
+      (funcall try-fn (cadar binding-list)))
+    (let ((i 0))
+      (flet ((try-binding (x)
+			  (funcall
+			   try-fn
+			   `(,op
+			     (,@(subseq binding-list 0 i)
+				,x
+				,@(subseq binding-list (1+ i)))
+			     ,@body))))
+	(declare (dynamic-extent (function try-binding)))
+	(loop while (< i len)
+	      do (prune (elt binding-list i) #'try-binding)
+	      (incf i))))
+    (when body
+      (unless binding-list
+	(funcall try-fn (car (last body))))
+      (when (and (car binding-list)
+		 (not (cdr binding-list))
+		 (not (cdr body)))
+	(let ((binding (car binding-list)))
+	  (unless (consp (second binding))
+	    (funcall try-fn `(let ()
+			       ,@(subst (cadr binding) (car binding) body))))))
+      (prune (car (last body))
+	     #'(lambda (form2)
+		 (funcall try-fn
+			  `(,@(butlast form) ,form2)))))))
+