diff --git a/random/mutate.lsp b/random/mutate.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..3cbb46ca75e1f2656c35fa93c3feec4076715efe
--- /dev/null
+++ b/random/mutate.lsp
@@ -0,0 +1,1066 @@
+;-*- Mode:     Lisp -*-
+
+(in-package :cl-test)
+
+(defparameter *lambdas* #())
+(defparameter *dump-stream* nil)
+
+;;; Include some standard packages in CL-TEST to make randomly
+;;; read code more understandable
+
+(defparameter *standard-packages-to-include*
+  '(:alexandria :iterate :serapeum :named-readtables
+    :curry-compose-reader-macros :closer-mop
+    :cl-ppcre :split-sequence :trivial-features
+    :trivial-gray-streams :bordeaux-threads
+    :anaphora :let-plus :fiveam :lift :trivial-garbage
+    :flexi-streams :nibbles :ironclad
+    :puri :usocket :trivial-backtrace
+    :more-conditions :chunga :cl-fad
+    :cl+ssl :cl-base64 :esrap :chipz
+    :drakma :local-time
+    :parse-number :cl-json
+    ))
+
+(defun include-std-packages (&aux (cltp (find-package "CL-TEST")))
+  (assert cltp)
+  (when (find-package :ql)
+    (let ((qlfn (intern "QUICKLOAD" "QL")))
+      (funcall qlfn :named-readtables)
+      (funcall qlfn :curry-compose-reader-macros)
+      (loop for e in *standard-packages-to-include*
+            do (let ((system (if (symbolp e) e (car e)))
+                     #+nil (package-name (if (symbolp e) e (cadr e)))
+                     )
+                 (funcall qlfn system)
+                 (unless (eql (find-package "CL-TEST") cltp)
+                   (error "Reading ~a redefined CL-TEST" system))
+                 #+nil
+                 (let ((package (find-package package-name)))
+                   (if package
+                       (handler-bind
+                           ((package-error
+                              (lambda (e)
+                                (let ((r (or (find-restart 'sb-impl::shadowing-import-it e)
+                                             (find-restart 'sb-impl::take-new))))
+                                  (when r
+                                    (invoke-restart r))))))
+                         (use-package (list package) :cl-test))
+                       (warn "Could not find package ~a"
+                             (string package-name)))))))))
+  
+;;; Mutation testing of Lisp functions to find compiler bugs
+;;; Assumes we can recognize 'abnormal' errors thrown by the compiler
+
+(defun default-mutate-sexpr (sexpr &optional (point-mutate-fn #'default-point-mutate-fn))
+  ;; Finds a random point in an s-expression, then mutates it using
+  ;; point-mutate-fn
+  (let ((new-sexpr nil))
+    (loop do (setf new-sexpr (let ((random-point (find-random-point-in-sexpr sexpr)))
+                               (mutate-point-in-sexpr sexpr random-point point-mutate-fn)))
+       while (equal sexpr new-sexpr))
+    new-sexpr))
+
+(defun default-point-mutate-fn (e)
+  (declare (ignore e))
+  (rcase
+    (1 (random-from-seq '(a b c d e f g)))
+    (1 (random 1000))
+    ))
+
+(defun random-subexpr-of-random-lambda (e)
+  (declare (ignore e))
+  "Given a lambda expression E, returns a random subexpression.  May be sloppy and give a nonsense form."
+  (let* ((len (length *lambdas*))
+         (i (random len))
+         (lam (elt *lambdas* i))
+         (sexpr (cddr lam)))
+    ;; strip off docstrings and declares
+    (loop while (and (consp sexpr)
+                     (or (and (consp (car sexpr))
+                              (eql (caar sexpr) 'declare))
+                         (and (stringp (car sexpr))
+                              (cdr sexpr))))
+       do (pop sexpr))
+    ;; If it's a singleton body, just use that form
+    (when (null (cdr sexpr))
+      (setf sexpr (car sexpr)))
+    (subexpr-at-point sexpr (find-random-point-in-sexpr sexpr))))
+
+;; A size tree decorates the nodes of an s-expression with size
+;; information, so random sub-expressions can be efficiently found.
+(defstruct size-tree-node
+  (size 0 :type (integer 0))
+  (children nil :type list))
+
+;; "Points" are addresses of subexpressions.
+(defun mutate-point-in-sexpr (sexpr point point-mutate-fn)
+  "Functional replacement of a subexpression of sexpr, addressed by point,
+   with the value returned by mutating it with point-mutate-fn"
+  (if (null point)
+      (funcall point-mutate-fn sexpr)
+      (ecase (pop point)
+        (0 (let ((new-car (mutate-point-in-sexpr (car sexpr) point point-mutate-fn)))
+             (cons new-car (cdr sexpr))))
+        (1 (let ((new-cdr (mutate-point-in-sexpr (cdr sexpr) point point-mutate-fn)))
+             (cons (car sexpr) new-cdr))))))           
+
+(defun find-random-point-in-sexpr (sexpr)
+  "Returns a random subexpression of sexpr"
+  ;; Build a tree of sizes
+  (let ((size-tree (size-tree-of-sexpr sexpr)))
+    ;; size-tree is a tree of size-tree-node records
+    (let ((n (random (size-tree-node-size size-tree))))
+      (reverse
+       (find-point-in-sexpr-with-sizes sexpr size-tree n nil)))))
+
+(defun subexpr-at-point (sexpr point)
+  (if (null point)
+      sexpr
+      (ecase (pop point)
+        (0 (subexpr-at-point (car sexpr) point))
+        (1 (subexpr-at-point (cdr sexpr) point)))))
+
+(defun random-subexpr-of-sexpr (sexpr)
+  (let ((point (find-random-point-in-sexpr sexpr)))
+    (subexpr-at-point sexpr point)))
+
+(defun find-point-in-sexpr-with-sizes (sexpr size-tree n path)
+  (loop for c in (size-tree-node-children size-tree)
+       for i from 0
+     do (let ((c-n (size-tree-node-size c)))
+          (if (>= n c-n)
+              (decf n c-n)
+              (return-from find-point-in-sexpr-with-sizes
+                (find-point-in-sexpr-with-sizes
+                 (ecase i
+                   (0 (car sexpr))
+                   (1 (cdr sexpr)))
+                 c
+                 n
+                 (cons i path))))))
+  path)
+
+(defparameter *size-tree-of-sexpr-cache* (make-hash-table))
+
+(defun size-tree-of-sexpr (sexpr)
+  (let ((cache *size-tree-of-sexpr-cache*))
+    (or (gethash sexpr cache)
+        (setf (gethash sexpr cache)
+              (size-tree-of-sexpr* sexpr)))))
+
+(defun size-tree-of-sexpr-cache-clear ()
+  (clrhash *size-tree-of-sexpr-cache*))
+
+(defun size-tree-of-sexpr* (sexpr)
+  (if (consp sexpr)
+      (let ((reversed nil))
+        (loop while (consp sexpr)
+              do (push (pop sexpr) reversed))
+        (let ((node (size-tree-of-sexpr* sexpr)))
+          (loop while reversed
+                do (let ((car-node (size-tree-of-sexpr* (pop reversed))))
+                     (setf node (make-size-tree-node
+                                 :size (+ (size-tree-node-size car-node)
+                                          (size-tree-node-size node))
+                                 :children (list car-node node)))))
+          node))
+      (make-size-tree-node :size 1 :children nil)))
+
+;;; Attempt to get a SB-INT:BUG condition from mutated lambda exprs
+
+(defvar *current-lambda* nil)
+
+(defun proper-listp (x)
+  ;; doesn't work on circular lists
+  (loop while (consp x) do (pop x))
+  (null x))
+
+(defun trim-improper-lists (root)
+  "Non-destructively trim off the non-nil tail element of the improper lists under ROOT."
+  (labels ((%t (x)
+             (if (consp x)
+                 (let* ((y x)
+                        (result (loop while (consp y)
+                                   collect (%t (pop y)))))
+                   (if (or y (notevery #'eq x result))
+                       result
+                       x))
+                 x)))
+    (%t root)))
+
+(defun mutate-sexpr-fn-for-fn (fn)
+  (lambda (sexpr ignored-fn)
+    (declare (ignore ignored-fn))
+    (default-mutate-sexpr sexpr
+        #'(lambda (e)
+            (funcall fn e)))))
+
+(defun mutate-sexpr-the-nil (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr
+      #'(lambda (e)
+          `(flet ((the-nil-f () (the nil ,e))) (the-nil-f)))))
+
+(defun mutate-sexpr-throw (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr
+      #'(lambda (e) `(throw 'done ,e))))
+
+(defun mutate-sexpr-reot (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr #'(lambda (e)
+                                  (let* ((y (make-random-element-of-type t))
+                                         (x (if (and y (or (and (not (keywordp y))
+                                                                (symbolp y)))
+                                                        (consp y))
+                                                `(quote ,y)
+                                                y)))
+                                    (if (listp e) (list x) x)))))
+
+(defun mutate-sexpr-error (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr #'(lambda (e)
+                                  (declare (ignore e))
+                                  (let ((x `(error ,(format nil "~a" (random 1000)))))
+                                    x))))
+
+(defvar *cl-syms* nil)
+
+(defun compute-cl-syms ()
+  (or *cl-syms*
+      (setf *cl-syms*
+            (let ((result nil))
+              (do-external-symbols (s "COMMON-LISP")
+                (unless (has-prohibited-symbol (list nil s))
+                  (push s result)))
+              (coerce result 'vector)))))
+
+(defun mutate-sexpr-cl-sym (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (let* ((s (compute-cl-syms))
+         (l (length s)))
+    (default-mutate-sexpr sexpr
+        #'(lambda (e) (unless (listp e) (svref s (random l)))))))
+
+(defun mutate-sexpr-go (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr
+      #'(lambda (e) (declare (ignore e)) '(go 17))))
+
+(declaim (ftype (function (t t) t) mutate-sexpr-bad-floats))
+
+(let ((bad-floats
+       (let ((vals
+              (list sb-ext:double-float-negative-infinity
+                    sb-ext:double-float-positive-infinity
+                    sb-ext:single-float-negative-infinity
+                    sb-ext:single-float-positive-infinity
+                    sb-ext:long-float-negative-infinity
+                    sb-ext:long-float-positive-infinity
+                    sb-ext:short-float-negative-infinity
+                    sb-ext:short-float-positive-infinity)))
+         (coerce (remove-duplicates vals) 'vector))))
+  (defun mutate-sexpr-bad-floats (sexpr ignored-fn)
+    (declare (ignore ignored-fn))
+    (default-mutate-sexpr sexpr
+        #'(lambda (e)
+            (unless (listp e) (random-from-seq bad-floats))))))
+
+(defun mutate-sexpr-satisfies-eval (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr
+      #'(lambda (e)
+          `(the (satisfies eval) ,e))))
+
+(defun mutate-sexpr-the-simple-array-nil (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr
+      #'(lambda (e)
+          `(the (simple-array nil) ,e))))
+
+(defun mutate-sexpr-class-of (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr
+      #'(lambda (e)
+          `(class-of ,e))))
+
+(defun safe-length (e)
+  (let ((i 0))
+    (declare (fixnum i))
+    (loop while (consp e)
+       do (incf i)
+       do (pop e))
+    i))
+
+(defun mutate-sexpr-misc (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr
+      #'(lambda (e)
+          (if (consp e)
+              (if (and (eql (car e) 'quote)
+                       (consp (cadr e))
+                       (proper-listp (cadr e)))
+                  `(quote ,(append (butlast (cadr e))
+                                   (car (last (cadr e)))))
+                  (let ((len (safe-length e)))
+                    (rcase
+                      (1 (if (proper-listp e)
+                             (random-permute e)
+                             (append (random-permute (subseq e 0 len))
+                                     (cdr (last e)))))
+                      (1 (cdr e))
+                      ;; (1 (if (not (stringp (car e))) (car e) (cdr e)))
+                      (1 (list (nthcdr (1+ (random len)) e)))
+                      (1 (list (elt e (random len))))
+                      (1 (if (consp (cdr e))
+                             (list* (cadr e) (car e) (cddr e))
+                             (cdr e))))))
+              (list e)))))
+
+#|
+(let ((nan (sb-int:with-float-traps-masked (:invalid) (/ 0d0 0d0))))
+  (defun mutate-sexpr-nan (sexpr ignored-fn)
+    (declare (ignore ignored-fn))
+    (default-mutate-sexpr sexpr
+        #'(lambda (e)
+            (unless (listp e) nan)))))
+|#
+
+(defun mutate-sexpr-random-lambda (sexpr ignored-fn)
+  (declare (ignore ignored-fn))
+  (default-mutate-sexpr sexpr (lambda (e)
+                                (let ((se (random-subexpr-of-random-lambda e)))
+                                  (when (or (not (listp e))
+                                            (proper-listp se))
+                                    se)))))
+
+(defun mutate-sexpr-n-random-lambda (sexpr ignored-fn n)
+  (loop repeat n
+     do (setf sexpr (mutate-sexpr-random-lambda sexpr ignored-fn)))
+  sexpr)
+
+(defun mutation-test-lambda-expr (lambda-expr &key (n 100) (do? nil)
+                                                (reps 1)
+                                                (mutate-sexpr #'default-mutate-sexpr)
+                                                &allow-other-keys)
+  (assert (eql (car lambda-expr) 'lambda))
+  (assert (listp (cadr lambda-expr)))
+  (let ((lambda-prefix (subseq lambda-expr 0 2))
+        (lambda-body (cddr lambda-expr))
+        (*error-output* (make-broadcast-stream)))
+    (loop repeat n
+       do (let ((mutated-body lambda-body))
+            (loop repeat reps
+               do  (let* ((subexpr (if do? '(do)
+                                       (random-subexpr-of-sexpr lambda-body))))
+                     (setf mutated-body (funcall
+                                         mutate-sexpr
+                                         lambda-body
+                                         #'(lambda (e)
+                                             (when (or (not (listp e))
+                                                       (proper-listp subexpr))
+                                               subexpr))))))
+            (let ((mutated-lambda (append lambda-prefix mutated-body)))
+              (setf *current-lambda* mutated-lambda)
+              (when *dump-stream*
+                (format *dump-stream* "~A~%" mutated-lambda)
+                (finish-output *dump-stream*))
+              (unless (is-bad-mutated-form mutated-lambda)
+                (handler-case
+                    #+sbcl
+                  (sb-ext:with-timeout 10
+                    (compile nil mutated-lambda))
+                  #-sbcl
+                  (compile nil mutated-lambda)
+                  #+sbcl (sb-int:bug () (return mutated-lambda))
+                  #+sbcl (sb-ext:timeout () nil)
+                  ;; (storage-condition () nil)
+                  ;; (error () nil)
+                  #+sbcl
+                  (sb-int:simple-program-error (e)
+                    (unless (equal (car (simple-condition-format-arguments e))
+                                   "Required argument")
+                      (return mutated-lambda)))
+                  #+sbcl
+                  (sb-kernel::arg-count-error (e)
+                    (unless (or (eql (sb-kernel::defmacro-lambda-list-bind-error-kind e)
+                                     'destructuring-bind)
+                                (eql (sb-kernel::defmacro-lambda-list-bind-error-name e) 'lambda)
+                                )
+                      (return mutated-lambda)))
+                  #+sbcl
+                  (sb-sys:interactive-interrupt (c) (error c))
+                  #+sbcl
+                  (sb-sys:system-condition ()
+                    (return mutated-lambda))
+                  #+sbcl
+                  (simple-type-error (e)
+                    (unless (eql (type-error-expected-type e) 'sb-impl::function-name)
+                      (return mutated-lambda)))
+                  #|
+                  (simple-error (e)
+                  (unless (equal (simple-condition-format-arguments e)
+                  '((NOT #1=(EQL (SB-C::LAMBDA-KIND SB-C::CLAMBDA) :DELETED)) ((#1# T))))
+                  (return mutated-lambda)))
+                  |#
+                  
+                  #|
+                  (type-error (e)
+                  (unless (eql (sb-kernel::type-error-context e) 'sb-impl::x)
+                  (return mutated-lambda)))
+                  |#
+                  #+clisp
+                  (system::simple-source-program-error () nil)
+                  #+clisp
+                  (system::simple-program-error () nil)
+                  #-clisp
+                  (error () (return mutated-lambda))
+                  #+clisp
+                  (error () nil)
+                  )))))))
+
+(defparameter *results* nil)
+(defparameter *dump-stream* nil)
+
+(defmacro with-dump (&body body)
+  `(with-open-file (*dump-stream* "dump.out" :direction :output
+                                  :if-exists :supersede
+                                  :if-does-not-exist :create)
+     ,@body))
+
+(defun loop-mt (&rest args &key &allow-other-keys)
+  (size-tree-of-sexpr-cache-clear)
+  (loop
+       (let ((result (apply #'loop-mutation-test args)))
+         (print result)
+         (terpri)
+         (push result *results*))))
+
+(defun loop-mt2 (&optional (reps 1))
+  (loop-mt :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-random-lambda
+     :reps reps))
+
+#|
+(defun loop-mt2-n (&optional (n 2))
+  (loop-mt :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'(lambda (sexpr ignored-fn)
+                       (mutate-sexpr-n-random-lambda sexpr ignored-fn n))))
+|#
+
+(defun loop-mt3 (&key (size 25) (n 20) (reps 1))
+  (loop-mt :size size :n n :reps reps
+     :mutate-sexpr #'mutate-sexpr-random-lambda))
+
+(defun loop-mt4 (&optional (reps 1))
+  (loop-mt :n 20 :reps reps
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-reot))
+
+(defun loop-mt5 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-go))
+
+(defun loop-mt6 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-throw))
+
+(defun loop-mt7 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-cl-sym))
+
+(defun loop-mt8 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-bad-floats))
+
+#|
+(defun loop-mt9 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-nan))
+|#
+
+(defun loop-mt10 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-satisfies-eval))
+
+(defun loop-mt10a (&key size)
+  (loop-mt :n 20 :size size
+     :mutate-sexpr #'mutate-sexpr-satisfies-eval))
+
+(defun loop-mt11 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-the-simple-array-nil))
+
+(defun loop-mt12 ()
+  (loop-mt :n 20
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-misc))
+
+(defun loop-mt13 (&key (n 20) (reps 1))
+  (loop-mt :n n :reps reps
+     :lambda-expr-fn #'make-random-from-lambdas
+     :mutate-sexpr #'mutate-sexpr-class-of))
+
+(defun loop-mt14 (&key (n 20) (reps 1))
+  (loop-mt :n n :reps reps
+     :lambda-expr-fn #'make-random-from-lambdas
+           :mutate-sexpr #'mutate-sexpr-error))
+
+#|
+(defun loop-mt15 (&key (reps 1))
+  (loop-mt :lambda-expr-fn #'make-random-from-lambdas
+           :mutate-sexper #'mutate-sexpr-random-permute
+           :reps reps))
+|#
+
+(defun loop-mutation-test (&rest args &key (n 100) (size 50)
+                                        (reps 1)
+                                        (lambda-expr-fn #'make-random-int-lambda-expr)
+                                        cache?
+                                        &allow-other-keys)
+  (let ((*vars* nil)
+        result)
+    (loop for i from 1
+       do (setf result (let ((lambda-expr (funcall lambda-expr-fn size)))
+                         (apply #'mutation-test-lambda-expr lambda-expr :n n :reps reps args)))
+       do (when result (return result))
+       do (when (eql (mod i 10) 0)
+            (unless cache? (size-tree-of-sexpr-cache-clear))
+            (format t "~A " i)
+            (when (eql (mod i 200) 0) (terpri))
+            (finish-output)))))
+
+(defun make-random-int-lambda-expr (size)
+  (let ((form (make-random-integer-form size)))
+    `(lambda () ,form)))
+
+;;; Utility functions to read the defuns of a file
+
+(defun read-exprs-from-file (fn)
+  (handler-case
+      (with-open-file (s fn :direction :input)
+        (read-exprs-from-stream s))
+    (file-error () nil)))
+
+(defun read-exprs-from-stream (s &key (named-readtables t))
+  "Read exprs from stream until all are done or there is an irrecoverable error.  Return the list of exprs."
+  (let ((forms nil)
+        (*read-eval* nil)
+        (*readtable* *readtable*)
+        (*package* *package*))
+    (handler-case
+        (loop for x = (handler-case (read s nil s) (reader-error () nil))
+           until (eql x s)
+           do (cond
+                ((and named-readtables (consp x) (symbolp (car x))
+                      (equal (symbol-name (car x)) "IN-READTABLE"))
+                 (handler-case (eval (cons (find-symbol "IN-READTABLE"
+                                                        :named-readtables)
+                                           (cdr x)))
+                   (error () nil)))
+                ((and (consp x) (eql (car x) 'in-package))
+                 (let ((n (cadr x)))
+                   (let ((p (find-package n)))
+                     (when p (setf *package* p)))))
+                ((and (consp x) (eql (car x) 'defpackage)
+                      (not (find-package (cadr x))))
+                 ;; :LOCK was causing spurious failures in tests
+                 ;; derived from ESRAP
+                 (setf x
+                       (remove-if (lambda (c)
+                                    (and (consp c) (eql (car c) :lock)))
+                                  x))
+                 (handler-case (eval x) (error () nil)))
+                (t
+                 (push x forms))))
+      (error () nil))
+    (nreverse forms)))
+
+(defun read-defuns-from-stream (s &key (sym 'defun))
+  ;; Reads the top level DEFUNs from a stream.
+  ;; :SYM keyword allows other forms to be found instead
+  ;; Do not respect in-package forms, and if undefined
+  ;; packages are found use *package* instead (in SBCL)
+  (let ((*package* *package*)
+        (*read-eval* nil))
+    (handler-case
+        (loop for x = (handler-case
+                          ;; Recent SBCLs have been provided with a restart
+                          ;; when a package is not found.  Use *package* instead
+                          ;; for these cases.
+                          (handler-bind (#+sbcl
+                                         (sb-int:simple-reader-package-error
+                                          (lambda (e) (use-value *package* e))))
+                            (read s nil s))
+                        (reader-error () nil))
+           until (eql x s)
+           when (and (consp x) (eql (car x) sym))
+           collect (progn
+                     ;; (format t "~A~%" (cadr x))
+                     x))
+      (error () nil))))
+
+(defun read-defuns (filename &rest args)
+  "Read DEFUNS from a file, returning them.  :SYM argument allows
+forms starting with other symbols to be found instead."
+  (format t "Reading from ~A~%" filename)
+  (finish-output *standard-output*)
+  (with-open-file (s filename :direction :input)
+    (apply #'read-defuns-from-stream s args)))
+
+(defun size-of-sexpr (s)
+  (let ((tree (size-tree-of-sexpr s)))
+    (size-tree-node-size tree)))
+
+(defun lambda-of-defun (d)
+  (assert (and (consp d) (eql (car d) 'defun)))
+  (cons 'lambda (cddr d)))
+
+(defun lambda-of-defmethod (d)
+  (assert (and (consp d) (eql (car d) 'defmethod)))
+  (let ((args (mapcar
+	       (lambda (a) (etypecase a
+			     (symbol a)
+			     (cons (car a))
+			     (t (return-from lambda-of-defmethod nil))))
+	       (third d)))
+	(body (cdddr d)))
+    `(lambda ,args ,@body)))
+
+(defun files-of-dirs (dirs)
+  (reduce #'append (cons nil (mapcar #'directory dirs)) :from-end t))
+
+(defun filter-lambdas (lambda-list)
+  (remove-small-lambdas
+   (mapcar #'remove-declares-from-tree
+           (remove-if #'has-prohibited-symbol
+                      (mapcar #'trim-improper-lists
+                              (remove-if #'is-circular-tree? lambda-list))))))
+
+(defun remove-small-lambdas (ll)
+  (remove-if (lambda (x)
+               (or (not (listp (cadr x)))
+                   (and (null (cdddr x))
+                        (not (consp (caddr x))))))
+             ll))
+
+(defun lambdas-of-defuns (&optional (dirs '("**/*.lsp")))
+  (let* ((files (files-of-dirs dirs))
+         (defuns (loop for fn in files
+                    append (read-defuns fn))))
+    (filter-lambdas (mapcar #'lambda-of-defun defuns))))
+
+(defun lambda-of-deftest (dt)
+  `(lambda () ,(third dt)))
+
+(defun lambdas-of-deftests (&optional (dirs '("**/*.lsp")))
+  (let* ((files (files-of-dirs dirs))
+         (tests (loop for fn in files
+                   append (read-defuns fn :sym 'deftest))))
+    (filter-lambdas (mapcar #'lambda-of-deftest tests))))
+
+(defun lambdas-of-defs (&optional (dirs '("**/*.lsp")))
+  (let* ((files (files-of-dirs dirs))
+         (exprs (mapcan #'read-exprs-from-file files)))
+    (filter-lambdas
+     (mapcan #'lambdas-of-def-expr exprs))))
+
+(defgeneric lambdas-of-def-expr (expr)
+  (:documentation "Returns a list of lambda expressions mined from a definition expr EXPR, or NIL if none could be found."))
+
+(defmethod lambdas-of-def-expr ((expr cons))
+  (lambdas-of-def-expr-cons (car expr) expr))
+
+(defparameter *all-exprs-to-lambdas* nil
+  "When true, convert every form to a lambda")
+
+(defmethod lambdas-of-def-expr (expr) nil)
+#|
+  (if (and *all-exprs-to-lambdas*
+           (consp expr)
+           (not (eql (car expr) 'quote)))
+      `(lambda () ,expr)
+      nil)
+|#
+
+(defgeneric lambdas-of-def-expr-cons (car-of-expr expr))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'defun)) expr)
+  (list (lambda-of-defun expr)))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'deftest)) expr)
+  (list (lambda-of-deftest expr)))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'defmethod)) expr)
+  (lambdas-of-defmethod expr))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'defgeneric)) expr)
+  (lambdas-of-defgeneric expr))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'def)) expr)
+  (when (consp (cdr expr))
+    (cond
+      ((or (member (cadr expr) '(function test partial-eval-test))
+           (and (consp (cadr expr))
+                (eql (caadr expr) 'function)))
+       (lambdas-of-def-expr `(defun ,(caddr expr) ,@(cdddr expr))))
+      ((eql (cadr expr) 'method)
+       (lambdas-of-defmethod `(defmethod ,@(cddr expr)))))))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'quote)) (expr t)) nil)
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'defclass)) (expr t)) nil)
+
+;; (defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'defmacro)) expr)
+;;  (lambdas-of-defmacro expr))
+
+(defun safe-mapcan (fn arg)
+  (loop while (consp arg)
+        append (funcall fn (pop arg))))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'eval-when)) expr)
+  (when (consp (cdr expr))
+    (let ((body (cddr expr)))
+      (safe-mapcan #'lambdas-of-def-expr body))))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'let)) expr)
+  (when (consp (cdr expr))
+    (let ((body (cddr expr)))
+      (safe-mapcan #'lambdas-of-def-expr body))))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'let*)) expr)
+  (when (consp (cdr expr))
+    (let ((body (cddr expr)))
+      (safe-mapcan #'lambdas-of-def-expr body))))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'progn)) expr)
+  (let ((body (cdr expr)))
+    (safe-mapcan #'lambdas-of-def-expr body)))
+
+(defmethod lambdas-of-def-expr-cons ((car-of-expr (eql 'locally)) expr)
+  (let ((body (cdr expr)))
+    (safe-mapcan #'lambdas-of-def-expr body)))
+
+(defmethod lambdas-of-def-expr-cons ((x (eql 'in-package)) y) nil)
+(defmethod lambdas-of-def-expr-cons ((x (eql 'defconstant)) y) nil)
+(defmethod lambdas-of-def-expr-cons ((x (eql 'defparameter)) y) nil)
+(defmethod lambdas-of-def-expr-cons ((x (eql 'defvar)) y) nil)
+
+(defparameter *failed-defs* nil)
+
+(defmethod lambdas-of-def-expr-cons ((x symbol) y)
+  (cond
+    ((equal (symbol-name x) "DEF")
+     (lambdas-of-def-expr-cons 'def (cons 'def (cdr y))))
+    (t
+     `((lambda () ,y)))))
+
+(defmethod lambdas-of-def-expr-cons (x y)
+  nil) ;; default method
+
+(defun lambdas-of-defmethod (defmethod-expr)
+  (lambdas-of-defmethod-body (cdr defmethod-expr)))
+
+(defun lambdas-of-defmethod-body (rest)
+  (and (consp rest)
+       (progn
+         ;; Get rid of name and method qualifiers
+         (loop do (pop rest) while (and (consp rest) (not (listp (car rest)))))
+         (and (consp rest)
+              (let ((args (method-parameters-to-lambda-parameters (pop rest))))
+                `((lambda ,args ,@rest)))))))
+
+(defun method-parameters-to-lambda-parameters (method-parameters)
+  (let ((mp method-parameters))
+    (append
+     (loop until (or (not (consp mp))
+                     (and (symbolp (car mp))
+                          (member (car mp) lambda-list-keywords)))
+          append (let ((m (pop mp)))
+                   (typecase m
+                     (symbol (list m))
+                     (cons (if (symbolp (car m))
+                               (list (car m))
+                               nil)))))
+     mp)))
+
+(defun lambdas-of-defgeneric (expr)
+  (and (proper-listp expr)
+       (loop for x in (cdddr expr)
+          when (and (consp x) (eql (car x) :method))
+          append (lambdas-of-defmethod-body x))))
+
+(defun lambdas-of-defmacro (expr)
+  (and (proper-listp expr)
+       (let ((macro-args (caddr expr))
+             (body (cdddr expr)))
+         (let ((lambda-args (macro-args-to-lambda-args macro-args)))
+           (list `(lambda ,lambda-args ,@body))))))
+
+(defun macro-args-to-lambda-args (macro-args)
+  (labels ((%m (args)
+             (cond
+               ((null args) nil)
+               ((member args '(&whole &rest &body &key &optional &allow-other-keys))
+                nil)
+               ((symbolp args) (list args))
+               ((not (consp args)) nil)
+               (t (append (%m (car args))
+                          (%m (cdr args)))))))
+    (remove-duplicates (%m macro-args))))
+
+(defun remove-equal-dups (vals)
+  (let ((table (make-hash-table :test 'equal)))
+    (loop for e in vals
+       append (unless (gethash e table)
+                (setf (gethash e table) t)
+                (list e)))))
+
+(defun make-lambdas-from-files (&rest args)
+  (setf *lambdas*
+	(coerce (remove-equal-dups
+                 (append (coerce *lambdas* 'list)
+                         (apply #'lambdas-of-defs args)))
+                'vector))
+  #+sbcl (sb-ext:gc :full t)
+  (length *lambdas*))
+
+(defun make-lams-for-qlstems (system-stems &key (root "/pdietz/quicklisp/dists/quicklisp/software"))
+  (loop for stem in system-stems
+     do (let ((dir (format nil "~A/*~A*" root stem)))
+          (format t "~A: ~A~%" stem (make-lams dir)))))
+
+(defun lisp-paths-for-root-dir (root-dir)
+  (loop for type in '("lisp" "lsp" "cl")
+     collect (format nil "~A/**/*.~A" root-dir type)))
+
+(defun make-lams (root-dir)
+  (let ((dirs (lisp-paths-for-root-dir root-dir)))
+    (make-lambdas-from-files dirs)))
+
+(defvar *ql-dirs*
+  '("~/quicklisp/**/*.lisp"
+    "~/quicklisp/**/*.lsp"
+    "~/quicklisp/**/*.cl"
+    "~/quicklisp/**/*.l"))
+
+(defun make-ql-lams ()
+  (let ((dirs *ql-dirs*))
+    (make-lambdas-from-files dirs)))
+
+(defun make-sel-lams ()
+  (let ((dirs '("~/quicklisp/local-projects/sel/**/*.lisp"
+                "~/quicklisp/local-projects/sel/**/*.lsp"
+                "~/quicklisp/local-projects/sel/**/*.cl")))
+    (make-lambdas-from-files dirs)))
+
+(defvar *ansi-test-dirs* '("~/ansi-test/**/*.lsp"))
+
+(defvar *other-dirs* '("~/public-lisp/**/*.lisp"
+                       "~/public-lisp/**/*.lsp"
+                       "~/public-lisp/**/*.cl"
+                       "~/public-lisp/**/*.l"
+                       ))
+
+(defun make-ansi-test-lams ()
+  (let ((dirs *ansi-test-dirs*))
+    (make-lambdas-from-files dirs)))
+
+(defun make-all-lams ()
+  (make-lambdas-from-files
+   (append *ansi-test-dirs* *ql-dirs*
+           *other-dirs*)))
+
+(defun properize (x)
+  (cons (loop while (consp x)
+           collect (pop x))
+        x))
+
+(defun map-leafs (fn x)
+  (loop while (consp x)
+       do (map-leafs fn (pop x)))
+  (funcall fn x))
+
+(defun read-all-atoms-from-dir (root-dir)
+  (let (#+nil(sb-impl::*use-sane-package-on-undefined-package* t))
+    (let* ((dirs (lisp-paths-for-root-dir root-dir))
+           (files (files-of-dirs dirs))
+           (exprs (mapcan #'read-exprs-from-file files))
+           (table (make-hash-table :test #'equal))
+           (atoms nil))
+      (loop for e in exprs
+         unless (is-circular-tree? e)
+         do (map-leafs
+             (lambda (x)
+               (unless (gethash x table)
+                 (setf (gethash x table) t)
+                 (push x atoms)))
+             e))
+      atoms)))
+
+(defun make-qa-lams ()
+  (let ((dirs '("~/quicklisp/**/*.lisp"
+                "~/quicklisp/**/*.lsp"
+                "~/quicklisp/**/*.cl"
+                "~/quicklisp/**/*.l"
+                "~/ansi-test/**/*.lsp")))
+    (make-lambdas-from-files dirs)))
+
+(defun make-ccl-lams ()
+  (let ((dirs '("/pdietzccl/**/*.lisp")))
+    (make-lambdas-from-files dirs)))
+
+(defun make-acl2-lams ()
+  (let ((dirs '("/pdietz/acl2-8.0/**/*.lisp")))
+    (make-lambdas-from-files dirs)))
+
+(defun make-random-from-lambdas (s)
+  (declare (ignore s))
+  (random-from-seq *lambdas*))
+
+(defun remove-declares-from-tree (y)
+  (if (consp y)
+      (let ((front (loop while (consp y)
+                      unless (and (consp (car y)) (eql (caar y) 'declare))
+                      collect (remove-declares-from-tree (car y))
+                      do (pop y))))
+        (when y (setf (cdr (last front)) y))
+        front)
+      y))
+
+(defun is-circular-tree? (root)
+  (let ((table (make-hash-table)))
+    (labels ((%traverse (x)
+               (when (consp x)
+                 (let ((y x))
+                   (loop while (consp y)
+                      do (when (gethash y table)
+                           (return-from is-circular-tree? t))
+                      do (setf (gethash y table) t)
+                      do (%traverse (pop y))))
+                 (loop while (consp x)
+                    do (remhash x table)
+                    do (pop x)))))
+      (%traverse root)
+      nil)))
+
+(defun has-subtree-matching-pred (x pred)
+  (labels ((%r (y)
+             (or (funcall pred y)
+                 (and (consp y)
+                      (or (%r (car y))
+                          (%r (cdr y)))))))
+    (%r x)))
+
+(defun has-duplicate-docstring? (root)
+  (has-subtree-matching-pred root #'duplicate-docstring?))
+
+(defun duplicate-docstring? (x)
+  "True if the form at the root of x has a duplicate docstring.  This is used to filter
+out forms that report useless error due to this."
+  (and (consp x)
+       (symbolp (car x))
+       (case (car x)
+         ((let let* lambda dotimes dolist) (body-has-duplicate-docstring? (cddr x)))
+         ((multiple-value-bind destructuring-bind do do*)
+          (body-has-duplicate-docstring? (cdddr x)))
+         ((flet labels)
+          (or (body-has-duplicate-docstring? (cddr x))
+              (some #'(lambda (def) (body-has-duplicate-docstring? (cddr def))) (cadr x))))
+         ((locally) (body-has-duplicate-docstring? (cdr x)))
+         (t nil))))
+
+(defun body-has-duplicate-docstring? (body)
+  "True if the start of BODY as more than one docstring"
+  (let ((count 0))
+    (loop while (and (consp body)
+                     (or (stringp (car body))
+                         (and (consp (car body)) (eql (caar body) 'declare))))
+       do (when (stringp (pop body)) (incf count)))
+    (> count 1)))         
+
+(defun has-prohibited-symbol (x)
+  (has-subtree-matching-pred
+   (cdr x)
+   #'(lambda (y) (case y ((ldb
+                           deposit-byte
+                           mask-field
+                           dpb
+                           ldb
+                           ldb-test
+                           boole
+                           unsigned-byte
+                           signed-byte
+                           invoke-debugger
+                           load-time-value
+                           #+sbcl sb-int:named-lambda
+                           #+sbcl sb-sys:%primitive
+                           ;; #+sbcl sb-kernel:layout-of
+                           #+sbcl sb-kernel:widetag-of
+                           #+sbcl sb-kernel:%other-pointer-widetag
+                           #+(and sbcl (not x86)) sb-vm::swap-complex
+                           #+sbcl sb-alien:unsigned
+                           #+sbcl sb-alien:make-alien
+                           #+sbcl sb-alien:deref
+                           #+sbcl sb-alien:cast
+                           ash step symbol-macrolet
+                           macrolet defun expt defmacro)
+                          t)
+                       (t nil)))))
+
+(defun is-bad-mutated-form (x)
+  (flet ((%is-bad (y)
+           (and (consp y)
+                (or
+                 (and (eql (car y) 'aref)
+                      (>= (length (cdr y)) 8))
+                 (and (eql (car y) 'make-array)
+                      (consp (cdr y))
+                      (let ((d (second y)))
+                        (and (consp d)
+                             (eql (car d) 'quote)
+                             (consp (second d))
+                             (not (typep (car (second d)) '(integer 1))))))
+                 (and (eql (car y) 'lambda)
+                      (consp (cdr y))
+                      (consp (cddr y))
+                      (consp (cdddr y))
+                      (stringp (third y))
+                      (stringp (fourth y)))
+                 ))))
+    (has-subtree-matching-pred x #'%is-bad)))
+
+(declaim (special *current-lambda-pos*))
+
+(defun dead-code-test (&key (start 0))
+  (let* ((lm *lambdas*)
+         (len (length lm))
+         )
+    (loop for i from start below len do
+         (let ((test-lambda
+                `(lambda (x)
+                   (cond
+                     (x (,(elt lm i))
+                        (the integer nil))
+                     (t nil)))))
+           (setf *current-lambda* test-lambda)
+           (setf *current-lambda-pos* i)
+           (handler-case
+               (compile nil test-lambda))))))
+             
+(defun tree-find (val tree)
+  (cond
+    ((eql val tree) t)
+    ((consp tree)
+     (or (tree-find val (car tree))
+         (tree-find val (cdr tree))))))
+
+(defun tree-findf (val)
+  (lambda (tree) (tree-find val tree)))