X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=f6dcabf80c520798fe21c76324050de7d6c673d8;hb=fa2c3ba871c9818e5768fd8f6092ddda83a93a1f;hp=fd89794e6aea2a0bfdf15ccabbb562c19b1a007e;hpb=d5b2c7d4ea394fe94bab07e4a1a9d6f4320b822a;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index fd89794..f6dcabf 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2676,10 +2676,40 @@
     (assert (eq 'list type))
     (assert derivedp)))
 
+(with-test (:name :rest-list-type-derivation2)
+  (multiple-value-bind (type derivedp)
+      (funcall (funcall (compile nil `(lambda ()
+                                        (lambda (&rest args)
+                                          (ctu:compiler-derived-type args))))))
+    (assert (eq 'list type))
+    (assert derivedp)))
+
+(with-test (:name :rest-list-type-derivation3)
+  (multiple-value-bind (type derivedp)
+      (funcall (funcall (compile nil `(lambda ()
+                                        (lambda (&optional x &rest args)
+                                          (unless x (error "oops"))
+                                          (ctu:compiler-derived-type args)))))
+               t)
+    (assert (eq 'list type))
+    (assert derivedp)))
+
+(with-test (:name :rest-list-type-derivation4)
+  (multiple-value-bind (type derivedp)
+      (funcall (funcall (compile nil `(lambda ()
+                                        (lambda (&optional x &rest args)
+                                          (declare (type (or null integer) x))
+                                          (when x (setf args x))
+                                          (ctu:compiler-derived-type args)))))
+               42)
+    (assert (equal '(or cons null integer) type))
+    (assert derivedp)))
+
 (with-test (:name :base-char-typep-elimination)
-  (assert (eq (funcall (lambda (ch)
-                         (declare (type base-char ch) (optimize (speed 3) (safety 0)))
-                         (typep ch 'base-char))
+  (assert (eq (funcall (compile nil
+                                `(lambda (ch)
+                                   (declare (type base-char ch) (optimize (speed 3) (safety 0)))
+                                   (typep ch 'base-char)))
                        t)
               t)))
 
@@ -2729,7 +2759,7 @@
                           (eval '(,lambda ,@args))))))))
   (sb-vm::with-float-traps-masked
       (:divide-by-zero :overflow :inexact :invalid)
-    (let ((sb-ext:*evaluator-mode* :interpret))
+    (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret))
       (declare (sb-ext:muffle-conditions style-warning))
       (test-comparison eql t t nil)
       (test-comparison eql t t t)
@@ -3253,14 +3283,27 @@
                            (truncate x))))
         (d (compile nil `(lambda (x)
                            (declare (double-float x))
-                           (truncate x)))))
+                           (truncate x))))
+        (s-inlined (compile nil '(lambda (x)
+                                  (declare (type (single-float 0.0s0 1.0s0) x))
+                                  (truncate x))))
+        (d-inlined (compile nil '(lambda (x)
+                                  (declare (type (double-float 0.0d0 1.0d0) x))
+                                  (truncate x)))))
     ;; Check that there is no generic arithmetic
     (assert (not (search "GENERIC"
                          (with-output-to-string (out)
                            (disassemble s :stream out)))))
     (assert (not (search "GENERIC"
                          (with-output-to-string (out)
-                           (disassemble d :stream out)))))))
+                           (disassemble d :stream out)))))
+    ;; Check that we actually inlined the call when we were supposed to.
+    (assert (not (search "UNARY-TRUNCATE"
+                         (with-output-to-string (out)
+                           (disassemble s-inlined :stream out)))))
+    (assert (not (search "UNARY-TRUNCATE"
+                         (with-output-to-string (out)
+                           (disassemble d-inlined :stream out)))))))
 
 (with-test (:name :make-array-unnamed-dimension-leaf)
   (let ((fun (compile nil `(lambda (stuff)
@@ -3302,7 +3345,7 @@
     (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
 
 (with-test (:name :coerce-type-warning)
-  (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) 
+  (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
                   (signed-byte 8) (signed-byte 16) (signed-byte 32)))
     (multiple-value-bind (fun warningsp failurep)
         (compile nil `(lambda (x)
@@ -3311,3 +3354,523 @@
       (assert (null warningsp))
       (assert (null failurep))
       (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
+
+(with-test (:name :truncate-double-float)
+  (let ((fun (compile nil `(lambda (x)
+                             (multiple-value-bind (q r)
+                                 (truncate (coerce x 'double-float))
+                               (declare (type unsigned-byte q)
+                                        (type double-float r))
+                               (list q r))))))
+    (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
+
+(with-test (:name :set-slot-value-no-warning)
+  (let ((notes 0))
+    (handler-bind ((warning #'error)
+                   (sb-ext:compiler-note (lambda (c)
+                                           (declare (ignore c))
+                                           (incf notes))))
+      (compile nil `(lambda (x y)
+                      (declare (optimize speed safety))
+                      (setf (slot-value x 'bar) y))))
+    (assert (= 1 notes))))
+
+(with-test (:name :concatenate-string-opt)
+  (flet ((test (type grep)
+           (let* ((fun (compile nil `(lambda (a b c d e)
+                                      (concatenate ',type a b c d e))))
+                  (args '("foo" #(#\.) "bar" (#\-) "quux"))
+                  (res (apply fun args)))
+             (assert (search grep (with-output-to-string (out)
+                                    (disassemble fun :stream out))))
+             (assert (equal (apply #'concatenate type args)
+                            res))
+             (assert (typep res type)))))
+    (test 'string "%CONCATENATE-TO-STRING")
+    (test 'simple-string "%CONCATENATE-TO-STRING")
+    (test 'base-string "%CONCATENATE-TO-BASE-STRING")
+    (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
+
+(with-test (:name :satisfies-no-local-fun)
+  (let ((fun (compile nil `(lambda (arg)
+                             (labels ((local-not-global-bug (x)
+                                        t)
+                                      (bar (x)
+                                        (typep x '(satisfies local-not-global-bug))))
+                               (bar arg))))))
+    (assert (eq 'local-not-global-bug
+                (handler-case
+                    (funcall fun 42)
+                  (undefined-function (c)
+                    (cell-error-name c)))))))
+
+;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
+;;; argument that is a complex structure (needing make-load-form
+;;; processing) failed an AVER.  The first attempt at a fix caused
+;;; doing the same in-core to break.
+(with-test (:name :bug-310132)
+  (compile nil '(lambda (&optional (foo #p"foo/bar")))))
+
+(with-test (:name :bug-309129)
+  (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
+         (warningp nil)
+         (fun (handler-bind ((warning (lambda (c)
+                                        (setf warningp t) (muffle-warning c))))
+                (compile nil src))))
+    (assert warningp)
+    (handler-case (funcall fun #(1))
+      (type-error (c)
+        ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
+        ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
+        (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
+      (:no-error (&rest values)
+        (declare (ignore values))
+        (error "no error")))))
+
+(with-test (:name :unary-round-type-derivation)
+  (let* ((src '(lambda (zone)
+                (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+                  (declare (ignore h))
+                  (round (* 60.0 m)))))
+         (fun (compile nil src)))
+    (assert (= (funcall fun 0.5) 30))))
+
+(with-test (:name :bug-525949)
+  (let* ((src '(lambda ()
+                (labels ((always-one () 1)
+                         (f (z)
+                           (let ((n (funcall z)))
+                             (declare (fixnum n))
+                             (the double-float (expt n 1.0d0)))))
+                  (f #'always-one))))
+         (warningp nil)
+         (fun (handler-bind ((warning (lambda (c)
+                                        (setf warningp t) (muffle-warning c))))
+                (compile nil src))))
+    (assert (not warningp))
+    (assert (= 1.0d0 (funcall fun)))))
+
+(with-test (:name :%array-data-vector-type-derivation)
+  (let* ((f (compile nil
+                     `(lambda (ary)
+                        (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+                        (setf (aref ary 0 0) 0))))
+         (text (with-output-to-string (s)
+                 (disassemble f :stream s))))
+    (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
+
+(with-test (:name :array-storage-vector-type-derivation)
+  (let ((f (compile nil
+                    `(lambda (ary)
+                       (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+                       (ctu:compiler-derived-type (array-storage-vector ary))))))
+    (assert (equal '(simple-array (unsigned-byte 32) (9))
+                   (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
+
+(with-test (:name :bug-523612)
+  (let ((fun
+         (compile nil
+                  `(lambda (&key toff)
+                     (make-array 3 :element-type 'double-float
+                                 :initial-contents
+                                 (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
+    (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
+    (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
+
+(with-test (:name :bug-309788)
+  (let ((fun
+         (compile nil
+                  `(lambda (x)
+                     (declare (optimize speed))
+                     (let ((env nil))
+                       (typep x 'fixnum env))))))
+    (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :bug-309124)
+  (let ((fun
+         (compile nil
+                  `(lambda (x)
+                     (declare (integer x))
+                     (declare (optimize speed))
+                     (cond ((typep x 'fixnum)
+                            "hala")
+                           ((typep x 'fixnum)
+                            "buba")
+                           ((typep x 'bignum)
+                            "hip")
+                           (t
+                            "zuz"))))))
+    (assert (equal (list "hala" "hip")
+                   (sort (ctu:find-code-constants fun :type 'string)
+                         #'string<)))))
+
+(with-test (:name :bug-316078)
+  (let ((fun
+         (compile nil
+                  `(lambda (x)
+                     (declare (type (and simple-bit-vector (satisfies bar)) x)
+                              (optimize speed))
+                     (elt x 5)))))
+    (assert (not (ctu:find-named-callees fun)))
+    (assert (= 1 (funcall fun #*000001)))
+    (assert (= 0 (funcall fun #*000010)))))
+
+(with-test (:name :mult-by-one-in-float-acc-zero)
+  (assert (eql 1.0 (funcall (compile nil `(lambda (x)
+                                            (declare (optimize (sb-c::float-accuracy 0)))
+                                            (* x 1.0)))
+                            1)))
+  (assert (eql -1.0 (funcall (compile nil `(lambda (x)
+                                             (declare (optimize (sb-c::float-accuracy 0)))
+                                             (* x -1.0)))
+                             1)))
+  (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
+                                              (declare (optimize (sb-c::float-accuracy 0)))
+                                              (* x 1.0d0)))
+                              1)))
+  (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
+                                               (declare (optimize (sb-c::float-accuracy 0)))
+                                               (* x -1.0d0)))
+                               1))))
+
+(with-test (:name :dotimes-non-integer-counter-value)
+  (assert (raises-error? (dotimes (i 8.6)) type-error)))
+
+(with-test (:name :bug-454681)
+  ;; This used to break due to reference to a dead lambda-var during
+  ;; inline expansion.
+  (assert (compile nil
+                   `(lambda ()
+                      (multiple-value-bind (iterator+977 getter+978)
+                          (does-not-exist-but-does-not-matter)
+                        (flet ((iterator+976 ()
+                                 (funcall iterator+977)))
+                          (declare (inline iterator+976))
+                          (let ((iterator+976 #'iterator+976))
+                            (funcall iterator+976))))))))
+
+(with-test (:name :complex-float-local-fun-args)
+  ;; As of 1.0.27.14, the lambda below failed to compile due to the
+  ;; compiler attempting to pass unboxed complex floats to Z and the
+  ;; MOVE-ARG method not expecting the register being used as a
+  ;; temporary frame pointer.  Reported by sykopomp in #lispgames,
+  ;; reduced test case provided by _3b`.
+  (compile nil '(lambda (a)
+                  (labels ((z (b c)
+                              (declare ((complex double-float) b c))
+                              (* b (z b c))))
+                          (loop for i below 10 do
+                                (setf a (z a a)))))))
+
+(with-test (:name :bug-309130)
+  (assert (eq :warning
+              (handler-case
+                  (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
+                ((and warning (not style-warning)) ()
+                  :warning))))
+  (assert (eq :warning
+              (handler-case
+                  (compile nil `(lambda (x)
+                                  (declare (optimize (debug 0)))
+                                  (declare (type vector x))
+                                  (list (fill-pointer x) (svref x 1))))
+                ((and warning (not style-warning)) ()
+                  :warning))))
+  (assert (eq :warning
+              (handler-case
+                  (compile nil `(lambda (x)
+                                  (list (vector-push (svref x 0) x))))
+                ((and warning (not style-warning)) ()
+                  :warning))))
+  (assert (eq :warning
+              (handler-case
+                  (compile nil `(lambda (x)
+                                  (list (vector-push-extend (svref x 0) x))))
+                ((and warning (not style-warning)) ()
+                  :warning)))))
+
+(with-test (:name :bug-646796)
+  (assert 42
+          (funcall
+           (compile nil
+                    `(lambda ()
+                       (load-time-value (the (values fixnum) 42)))))))
+
+(with-test (:name :bug-654289)
+  ;; Test that compile-times don't explode when quoted constants
+  ;; get big.
+  (labels ((time-n (n)
+             (gc :full t) ; Let's not confuse the issue with GC
+             (let* ((tree (make-tree (expt 10 n) nil))
+                    (t0 (get-internal-run-time))
+                    (f (compile nil `(lambda (x) (eq x (quote ,tree)))))
+                    (t1 (get-internal-run-time)))
+               (assert (funcall f tree))
+               (- t1 t0)))
+           (make-tree (n acc)
+             (cond ((zerop n) acc)
+                   (t (make-tree (1- n) (cons acc acc))))))
+    (let* ((times (loop for i from 0 upto 4
+                        collect (time-n i)))
+           (max-small (reduce #'max times :end 3))
+           (max-big (reduce #'max times :start 3)))
+      ;; This way is hopefully fairly CPU-performance insensitive.
+      (unless (> (+ (truncate internal-time-units-per-second 10)
+                    (* 2 max-small))
+                 max-big)
+        (error "Bad scaling or test? ~S" times)))))
+
+(with-test (:name :bug-309063)
+  (let ((fun (compile nil `(lambda (x)
+                             (declare (type (integer 0 0) x))
+                             (ash x 100)))))
+    (assert (zerop (funcall fun 0)))))
+
+(with-test (:name :bug-655872)
+  (let ((f (compile nil `(lambda (x)
+                           (declare (optimize (safety 3)))
+                           (aref (locally (declare (optimize (safety 0)))
+                                   (coerce x '(simple-vector 128)))
+                                 60))))
+        (long (make-array 100 :element-type 'fixnum)))
+    (dotimes (i 100)
+      (setf (aref long i) i))
+    ;; 1. COERCE doesn't check the length in unsafe code.
+    (assert (eql 60 (funcall f long)))
+    ;; 2. The compiler doesn't trust the length from COERCE
+    (assert (eq :caught
+                (handler-case
+                    (funcall f (list 1 2 3))
+                  (sb-int:invalid-array-index-error (e)
+                    (assert (eql 60 (type-error-datum e)))
+                    (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
+                    :caught))))))
+
+(with-test (:name :bug-655203-regression)
+  (let ((fun (compile nil
+                      `(LAMBDA (VARIABLE)
+                         (LET ((CONTINUATION
+                                (LAMBDA
+                                    (&OPTIONAL DUMMY &REST OTHER)
+                                  (DECLARE (IGNORE OTHER))
+                                  (PRIN1 DUMMY)
+                                  (PRIN1 VARIABLE))))
+                           (FUNCALL CONTINUATION (LIST 1 2)))))))
+    ;; This used to signal a bogus type-error.
+    (assert (equal (with-output-to-string (*standard-output*)
+                     (funcall fun t))
+                   "(1 2)T"))))
+
+(with-test (:name :constant-concatenate-compile-time)
+  (flet ((make-lambda (n)
+           `(lambda (x)
+              (declare (optimize (speed 3) (space 0)))
+              (concatenate 'string x ,(make-string n)))))
+    (let* ((l0 (make-lambda 1))
+           (l1 (make-lambda 10))
+           (l2 (make-lambda 100))
+           (l3 (make-lambda 1000))
+           (t0 (get-internal-run-time))
+           (f0 (compile nil l0))
+           (t1 (get-internal-run-time))
+           (f1 (compile nil l1))
+           (t2 (get-internal-run-time))
+           (f2 (compile nil l2))
+           (t3 (get-internal-run-time))
+           (f3 (compile nil l3))
+           (t4 (get-internal-run-time))
+           (d0 (- t1 t0))
+           (d1 (- t2 t1))
+           (d2 (- t3 t2))
+           (d3 (- t4 t3))
+           (short-avg (/ (+ d0 d1 d2) 3)))
+      (assert (and f1 f2 f3))
+      (assert (< d3 (* 10 short-avg))))))
+
+(with-test (:name :bug-384892)
+  (assert (equal
+           '(function (fixnum fixnum &key (:k1 (member nil t)))
+             (values (member t) &optional))
+           (sb-kernel:%simple-fun-type
+            (compile nil `(lambda (x y &key k1)
+                            (declare (fixnum x y))
+                            (declare (boolean k1))
+                            (declare (ignore x y k1))
+                            t))))))
+
+(with-test (:name :bug-309448)
+  ;; Like all tests trying to verify that something doesn't blow up
+  ;; compile-times this is bound to be a bit brittle, but at least
+  ;; here we try to establish a decent baseline.
+  (flet ((time-it (lambda want)
+           (let* ((start (get-internal-run-time))
+                  (fun (compile nil lambda))
+                  (end (get-internal-run-time))
+                  (got (funcall fun)))
+             (unless (eql want got)
+               (error "wanted ~S, got ~S" want got))
+             (- end start))))
+    (let ((time-1/simple
+           ;; This is mostly identical as the next one, but doesn't create
+           ;; hairy unions of numeric types.
+           (time-it `(lambda ()
+                       (labels ((bar (baz bim)
+                                  (let ((n (+ baz bim)))
+                                 (* n (+ n 1) bim))))
+                      (let ((a (bar 1 1))
+                            (b (bar 1 1))
+                            (c (bar 1 1)))
+                        (- (+ a b) c))))
+                    6))
+          (time-1/hairy
+           (time-it `(lambda ()
+                       (labels ((bar (baz bim)
+                                  (let ((n (+ baz bim)))
+                                 (* n (+ n 1) bim))))
+                      (let ((a (bar 1 1))
+                            (b (bar 1 5))
+                            (c (bar 1 15)))
+                        (- (+ a b) c))))
+                    -3864)))
+      (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy)))
+    (let ((time-2/simple
+           ;; This is mostly identical as the next one, but doesn't create
+           ;; hairy unions of numeric types.
+           (time-it `(lambda ()
+                       (labels ((sum-d (n)
+                                  (let ((m (truncate 999 n)))
+                                    (/ (* n m (1+ m)) 2))))
+                         (- (+ (sum-d 3)
+                               (sum-d 3))
+                            (sum-d 3))))
+                    166833))
+          (time-2/hairy
+           (time-it `(lambda ()
+                       (labels ((sum-d (n)
+                                  (let ((m (truncate 999 n)))
+                                    (/ (* n m (1+ m)) 2))))
+                         (- (+ (sum-d 3)
+                               (sum-d 5))
+                            (sum-d 15))))
+                    233168)))
+      (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy)))))
+
+(with-test (:name :regression-1.0.44.34)
+  (compile nil '(lambda (z &rest args)
+                 (declare (dynamic-extent args))
+                 (flet ((foo (w v) (list v w)))
+                   (setq z 0)
+                   (flet ((foo ()
+                            (foo z args)))
+                     (declare (sb-int:truly-dynamic-extent #'foo))
+                     (call #'foo nil))))))
+
+(with-test (:name :bug-713626)
+  (let ((f (eval '(constantly 42))))
+    (handler-bind ((warning #'error))
+      (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
+
+(with-test (:name :known-fun-allows-other-keys)
+  (handler-bind ((warning #'error))
+    (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
+    (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
+
+(with-test (:name :bug-551227)
+  ;; This function causes constraint analysis to perform a
+  ;; ref-substitution that alters the A referred to in (G A) at in the
+  ;; consequent of the IF to refer to be NUMBER, from the
+  ;; LET-converted inline-expansion of MOD.  This leads to attempting
+  ;; to CLOSE-OVER a variable that simply isn't in scope when it is
+  ;; referenced.
+  (compile nil '(lambda (a)
+                  (if (let ((s a))
+                        (block :block
+                          (map nil
+                               (lambda (e)
+                                 (return-from :block
+                                   (f (mod a e))))
+                               s)))
+                      (g a)))))
+
+(with-test (:name :funcall-lambda-inlined)
+  (assert (not
+           (ctu:find-code-constants
+            (compile nil
+                     `(lambda (x y)
+                        (+ x (funcall (lambda (z) z) y))))
+            :type 'function))))
+
+(with-test (:name :bug-720382)
+  (let ((w 0))
+    (let ((f
+           (handler-bind (((and warning (not style-warning))
+                           (lambda (c) (incf w))))
+             (compile nil `(lambda (b) ((lambda () b) 1))))))
+      (assert (= w 1))
+      (assert (eq :error
+                  (handler-case (funcall f 0)
+                    (error () :error)))))))
+
+(with-test (:name :multiple-args-to-function)
+  (let ((form `(flet ((foo (&optional (x 13)) x))
+                 (funcall (function foo 42))))
+        (*evaluator-mode* :interpret))
+    (assert (eq :error
+                (handler-case (eval form)
+                  (error () :error))))
+    (multiple-value-bind (fun warn fail)
+        (compile nil `(lambda () ,form))
+      (assert (and warn fail))
+          (assert (eq :error
+                      (handler-case (funcall fun)
+                        (error () :error)))))))
+
+;;; This doesn't test LVAR-FUN-IS directly, but captures it
+;;; pretty accurately anyways.
+(with-test (:name :lvar-fun-is)
+  (dolist (fun (list
+                (lambda (x) (member x x :test #'eq))
+                (lambda (x) (member x x :test 'eq))
+                (lambda (x) (member x x :test #.#'eq))))
+    (assert (equal (list #'sb-kernel:%member-eq)
+                   (ctu:find-named-callees fun))))
+  (dolist (fun (list
+                (lambda (x)
+                  (declare (notinline eq))
+                  (member x x :test #'eq))
+                (lambda (x)
+                  (declare (notinline eq))
+                  (member x x :test 'eq))
+                (lambda (x)
+                  (declare (notinline eq))
+                  (member x x :test #.#'eq))))
+    (assert (member #'sb-kernel:%member-test
+                    (ctu:find-named-callees fun)))))
+
+(with-test (:name :delete-to-delq-opt)
+  (dolist (fun (list (lambda (x y)
+                       (declare (list y))
+                       (delete x y :test #'eq))
+                     (lambda (x y)
+                       (declare (fixnum x) (list y))
+                       (delete x y))
+                     (lambda (x y)
+                       (declare (symbol x) (list y))
+                       (delete x y :test #'eql))))
+    (assert (equal (list #'sb-int:delq)
+                   (ctu:find-named-callees fun)))))
+
+(with-test (:name :bug-767959)
+  ;; This used to signal an error.
+  (compile nil `(lambda ()
+                  (declare (optimize sb-c:store-coverage-data))
+                  (assoc
+                   nil
+                   '((:ordinary . ordinary-lambda-list))))))
+
+(with-test (:name :member-on-long-constant-list)
+  ;; This used to blow stack with a sufficiently long list.
+  (let ((cycle (list t)))
+    (nconc cycle cycle)
+    (compile nil `(lambda (x)
+                    (member x ',cycle)))))