X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=a7e59e340c7e96b04dc5874632ea37226db69263;hb=1ce0ed2dc780758503d284e981768bd505564a88;hp=948d419bbc8d7b2d882a2efda56e893b4d0da6e4;hpb=c58795f37078f5900aff5dc4a3712fbadd2d432e;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 948d419..a7e59e3 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -520,3 +520,1295 @@
                                  (+ i 2)))
                 (sb-ext:compiler-note (c) (return :good))))
             :good))
+
+;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
+;;; symbol macros
+(assert (not (nth-value 1 (compile nil '(lambda (u v)
+                                         (symbol-macrolet ((x u)
+                                                           (y v))
+                                             (declare (ignore x)
+                                                      (ignorable y))
+                                           (list u v)))))))
+
+;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
+(loop for (x type) in
+      '((14 integer)
+        (14 rational)
+        (-14/3 (rational -8 11))
+        (3s0 short-float)
+        (4f0 single-float)
+        (5d0 double-float)
+        (6l0 long-float)
+        (14 real)
+        (13/2 real)
+        (2s0 real)
+        (2d0 real)
+        (#c(-3 4) (complex fixnum))
+        (#c(-3 4) (complex rational))
+        (#c(-3/7 4) (complex rational))
+        (#c(2s0 3s0) (complex short-float))
+        (#c(2f0 3f0) (complex single-float))
+        (#c(2d0 3d0) (complex double-float))
+        (#c(2l0 3l0) (complex long-float))
+        (#c(2d0 3s0) (complex float))
+        (#c(2 3f0) (complex real))
+        (#c(2 3d0) (complex real))
+        (#c(-3/7 4) (complex real))
+        (#c(-3/7 4) complex)
+        (#c(2 3l0) complex))
+      do (dolist (zero '(0 0s0 0f0 0d0 0l0))
+           (dolist (real-zero (list zero (- zero)))
+             (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
+                    (fun (compile nil src))
+                    (result (1+ (funcall (eval #'*) x real-zero))))
+               (assert (eql result (funcall fun x)))))))
+
+;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
+;;; wasn't recognized as a good type specifier.
+(let ((fun (lambda (x y)
+	     (declare (type (integer -1 0) x y) (optimize speed))
+	     (logxor x y))))
+  (assert (= (funcall fun 0 0) 0))
+  (assert (= (funcall fun 0 -1) -1))
+  (assert (= (funcall fun -1 -1) 0)))
+
+;;; from PFD's torture test, triggering a bug in our effective address
+;;; treatment.
+(compile
+ nil
+ `(lambda (a b)
+    (declare (type (integer 8 22337) b))
+    (logandc2
+     (logandc2
+      (* (logandc1 (max -29303 b) 4) b)
+      (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
+     (logeqv (max a 0) b))))
+
+;;; Alpha floating point modes weren't being reset after an exception,
+;;; leading to an exception on the second compile, below.
+(compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
+(handler-case (/ 1.0 0.0)
+  ;; provoke an exception
+  (arithmetic-error ()))
+(compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
+
+;;; bug reported by Paul Dietz: component last block does not have
+;;; start ctran
+(compile nil
+         '(lambda ()
+           (declare (notinline + logand)
+            (optimize (speed 0)))
+           (LOGAND
+            (BLOCK B5
+              (FLET ((%F1 ()
+                       (RETURN-FROM B5 -220)))
+                (LET ((V7 (%F1)))
+                  (+ 359749 35728422))))
+            -24076)))
+
+;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
+(assert (= (funcall (compile nil `(lambda (b)
+                                    (declare (optimize (speed 3))
+                                             (type (integer 2 152044363) b))
+                                    (rem b (min -16 0))))
+                    108251912)
+           8))
+
+(assert (= (funcall (compile nil `(lambda (c)
+                                    (declare (optimize (speed 3))
+                                             (type (integer 23062188 149459656) c))
+                                    (mod c (min -2 0))))
+                    95019853)
+           -1))
+
+;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
+(compile nil
+         '(LAMBDA (A B C)
+           (BLOCK B6
+             (LOGEQV (REM C -6758)
+                     (REM B (MAX 44 (RETURN-FROM B6 A)))))))
+
+(compile nil '(lambda ()
+               (block nil
+                 (flet ((foo (x y) (if (> x y) (print x) (print y))))
+                   (foo 1 2)
+                   (bar)
+                   (foo (return 14) 2)))))
+
+;;; bug in Alpha backend: not enough sanity checking of arguments to
+;;; instructions
+(assert (= (funcall (compile nil 
+			     '(lambda (x) 
+				(declare (fixnum x)) 
+				(ash x -257)))
+		    1024)
+	   0))
+
+;;; bug found by WHN and pfdietz: compiler failure while referencing
+;;; an entry point inside a deleted lambda
+(compile nil '(lambda ()
+               (let (r3533)
+                 (flet ((bbfn ()
+                          (setf r3533
+                                (progn
+                                  (flet ((truly (fn bbd)
+                                           (let (r3534)
+                                             (let ((p3537 nil))
+                                               (unwind-protect
+                                                    (multiple-value-prog1
+                                                        (progn
+                                                          (setf r3534
+                                                                (progn
+                                                                  (bubf bbd t)
+                                                                  (flet ((c-3536 ()
+                                                                           (funcall fn)))
+                                                                    (cdec #'c-3536
+                                                                          (vector bbd))))))
+                                                      (setf p3537 t))
+                                                 (unless p3537
+                                                   (error "j"))))
+                                             r3534))
+                                         (c (pd) (pdc pd)))
+                                    (let ((a (smock a))
+                                          (b (smock b))
+                                          (b (smock c)))))))))
+                   (wum #'bbfn "hc3" (list)))
+                 r3533)))
+(compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
+
+;;; the strength reduction of constant multiplication used (before
+;;; sbcl-0.8.4.x) to lie to the compiler.  This meant that, under
+;;; certain circumstances, the compiler would derive that a perfectly
+;;; reasonable multiplication never returned, causing chaos.  Fixed by
+;;; explicitly doing modular arithmetic, and relying on the backends
+;;; being smart.
+(assert (= (funcall 
+	    (compile nil 
+		     '(lambda (x)
+			(declare (type (integer 178956970 178956970) x)
+				 (optimize speed)) 
+			(* x 24)))
+	    178956970)
+	   4294967280))
+
+;;; bug in modular arithmetic and type specifiers
+(assert (= (funcall (compile nil (lambda (x) (logand x x 0)))
+		    -1)
+	   0))
+
+;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
+;;; produced wrong result for shift >=32 on X86
+(assert (= 0 (funcall
+              (compile nil
+                       '(lambda (a)
+                         (declare (type (integer 4303063 101130078) a))
+                         (mask-field (byte 18 2) (ash a 77))))
+              57132532)))
+
+;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
+;;; type check regeneration
+(assert (eql (funcall
+              (compile nil '(lambda (a c)
+                             (declare (type (integer 185501219873 303014665162) a))
+                             (declare (type (integer -160758 255724) c))
+                             (declare (optimize (speed 3)))
+                             (let ((v8
+                                    (- -554046873252388011622614991634432
+                                       (ignore-errors c)
+                                       (unwind-protect 2791485))))
+                               (max (ignore-errors a)
+                                    (let ((v6 (- v8 (restart-case 980))))
+                                      (min v8 v6))))))
+              259448422916 173715)
+             259448422916))
+(assert (eql (funcall
+              (compile nil '(lambda (a b)
+                             (min -80
+                              (abs
+                               (ignore-errors
+                                 (+
+                                  (logeqv b
+                                          (block b6
+                                            (return-from b6
+                                              (load-time-value -6876935))))
+                                  (if (logbitp 1 a) b (setq a -1522022182249))))))))
+              -1802767029877 -12374959963)
+             -80))
+
+;;; various MISC.*, related to NODEs/LVARs with derived type NIL
+(assert (eql (funcall (compile nil '(lambda (c)
+                                     (declare (type (integer -3924 1001809828) c))
+                                     (declare (optimize (speed 3)))
+                                     (min 47 (if (ldb-test (byte 2 14) c)
+                                                 -570344431
+                                                 (ignore-errors -732893970)))))
+                      705347625)
+             -570344431))
+(assert (eql (funcall
+              (compile nil '(lambda (b)
+                             (declare (type (integer -1598566306 2941) b))
+                             (declare (optimize (speed 3)))
+                             (max -148949 (ignore-errors b))))
+              0)
+             0))
+(assert (eql (funcall
+              (compile nil '(lambda (b c)
+                             (declare (type (integer -4 -3) c))
+                             (block b7
+                               (flet ((%f1 (f1-1 f1-2 f1-3)
+                                        (if (logbitp 0 (return-from b7
+                                                         (- -815145138 f1-2)))
+                                            (return-from b7 -2611670)
+                                            99345)))
+                                 (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
+                                   b)))))
+              2950453607 -4)
+             -815145134))
+(assert (eql (funcall
+              (compile nil
+                       '(lambda (b c)
+                         (declare (type (integer -29742055786 23602182204) b))
+                         (declare (type (integer -7409 -2075) c))
+                         (declare (optimize (speed 3)))
+                         (floor
+                          (labels ((%f2 ()
+                                     (block b6
+                                       (ignore-errors (return-from b6
+                                                        (if (= c 8) b 82674))))))
+                            (%f2)))))
+              22992834060 -5833)
+             82674))
+(assert (equal (multiple-value-list
+                (funcall
+                 (compile nil '(lambda (a)
+                                (declare (type (integer -944 -472) a))
+                                (declare (optimize (speed 3)))
+                                (round
+                                 (block b3
+                                   (return-from b3
+                                     (if (= 55957 a) -117 (ignore-errors
+                                                            (return-from b3 a))))))))
+                 -589))
+               '(-589 0)))
+
+;;; MISC.158
+(assert (zerop (funcall
+                (compile nil
+                         '(lambda (a b c)
+                           (declare (type (integer 79828 2625480458) a))
+                           (declare (type (integer -4363283 8171697) b))
+                           (declare (type (integer -301 0) c))
+                           (if (equal 6392154 (logxor a b))
+                               1706
+                               (let ((v5 (abs c)))
+                                 (logand v5
+                                         (logior (logandc2 c v5)
+                                                 (common-lisp:handler-case
+                                                     (ash a (min 36 22477)))))))))
+                100000 0 0)))
+
+;;; MISC.152, 153: deleted code and iteration var type inference
+(assert (eql (funcall
+              (compile nil
+                       '(lambda (a)
+                         (block b5
+                           (let ((v1 (let ((v8 (unwind-protect 9365)))
+                                       8862008)))
+                             (*
+                              (return-from b5
+                                (labels ((%f11 (f11-1) f11-1))
+                                  (%f11 87246015)))
+                              (return-from b5
+                                (setq v1
+                                      (labels ((%f6 (f6-1 f6-2 f6-3) v1))
+                                        (dpb (unwind-protect a)
+                                             (byte 18 13)
+                                             (labels ((%f4 () 27322826))
+                                               (%f6 -2 -108626545 (%f4))))))))))))
+              -6)
+             87246015))
+
+(assert (eql (funcall
+              (compile nil
+                       '(lambda (a)
+                         (if (logbitp 3
+                                      (case -2
+                                        ((-96879 -1035 -57680 -106404 -94516 -125088)
+                                         (unwind-protect 90309179))
+                                        ((-20811 -86901 -9368 -98520 -71594)
+                                         (let ((v9 (unwind-protect 136707)))
+                                           (block b3
+                                             (setq v9
+                                                   (let ((v4 (return-from b3 v9)))
+                                                     (- (ignore-errors (return-from b3 v4))))))))
+                                        (t -50)))
+                             -20343
+                             a)))
+              0)
+             -20343))
+
+;;; MISC.165
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (block b3
+                   (flet ((%f15
+                              (f15-1 f15-2 f15-3
+                                     &optional
+                                     (f15-4
+                                      (flet ((%f17
+                                                 (f17-1 f17-2 f17-3
+                                                        &optional (f17-4 185155520) (f17-5 c)
+                                                        (f17-6 37))
+                                               c))
+                                        (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
+                                     (f15-5 a) (f15-6 -40))
+                            (return-from b3 -16)))
+                     (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
+              0 0 -5)
+             -16))
+
+;;; MISC.172
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (declare (notinline list apply))
+                 (declare (optimize (safety 3)))
+                 (declare (optimize (speed 0)))
+                 (declare (optimize (debug 0)))
+                 (labels ((%f12 (f12-1 f12-2)
+                            (labels ((%f2 (f2-1 f2-2)
+                                       (flet ((%f6 ()
+						(flet ((%f18
+                                                           (f18-1
+                                                            &optional (f18-2 a)
+                                                            (f18-3 -207465075)
+                                                            (f18-4 a))
+                                                         (return-from %f12 b)))
+						  (%f18 -3489553
+							-7
+							(%f18 (%f18 150 -64 f12-1)
+							      (%f18 (%f18 -8531)
+								    11410)
+							      b)
+							56362666))))
+                                         (labels ((%f7
+                                                      (f7-1 f7-2
+                                                            &optional (f7-3 (%f6)))
+                                                    7767415))
+                                           f12-1))))
+                              (%f2 b -36582571))))
+                   (apply #'%f12 (list 774 -4413)))))
+              0 1 2)
+             774))
+
+;;; MISC.173
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (declare (notinline values))
+                 (declare (optimize (safety 3)))
+                 (declare (optimize (speed 0)))
+                 (declare (optimize (debug 0)))
+                 (flet ((%f11
+                            (f11-1 f11-2
+                                   &optional (f11-3 c) (f11-4 7947114)
+                                   (f11-5
+                                    (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
+                                             8134))
+                                      (multiple-value-call #'%f3
+                                        (values (%f3 -30637724 b) c)))))
+                          (setq c 555910)))
+                   (if (and nil (%f11 a a))
+                       (if (%f11 a 421778 4030 1)
+                           (labels ((%f7
+                                        (f7-1 f7-2
+                                              &optional
+                                              (f7-3
+                                               (%f11 -79192293
+                                                     (%f11 c a c -4 214720)
+                                                     b
+                                                     b
+                                                     (%f11 b 985)))
+                                              (f7-4 a))
+                                      b))
+                             (%f11 c b -25644))
+                           54)
+                       -32326608))))
+              1 2 3)
+             -32326608))
+
+;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
+;;; local lambda argument
+(assert
+ (equal
+  (funcall
+   (compile nil
+            '(lambda (a b c)
+              (declare (type (integer 804561 7640697) a))
+              (declare (type (integer -1 10441401) b))
+              (declare (type (integer -864634669 55189745) c))
+              (declare (ignorable a b c))
+              (declare (optimize (speed 3)))
+              (declare (optimize (safety 1)))
+              (declare (optimize (debug 1)))
+              (flet ((%f11
+                         (f11-1 f11-2)
+                       (labels ((%f4 () (round 200048 (max 99 c))))
+                         (logand
+                          f11-1
+                          (labels ((%f3 (f3-1) -162967612))
+                            (%f3 (let* ((v8 (%f4)))
+                                   (setq f11-1 (%f4)))))))))
+                (%f11 -120429363 (%f11 62362 b)))))
+   6714367 9645616 -637681868)
+  -264223548))
+
+;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
+;;; transform
+(assert (equal (multiple-value-list
+                (funcall
+                 (compile nil '(lambda ()
+                                (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
+                                (ceiling
+                                 (ceiling
+                                  (flet ((%f16 () 0)) (%f16))))))))
+               '(0 0)))
+
+;;; MISC.184
+(assert (zerop
+         (funcall
+          (compile
+           nil
+           '(lambda (a b c)
+             (declare (type (integer 867934833 3293695878) a))
+             (declare (type (integer -82111 1776797) b))
+             (declare (type (integer -1432413516 54121964) c))
+             (declare (optimize (speed 3)))
+             (declare (optimize (safety 1)))
+             (declare (optimize (debug 1)))
+             (if nil
+                 (flet ((%f15 (f15-1 &optional (f15-2 c))
+                          (labels ((%f1 (f1-1 f1-2) 0))
+                            (%f1 a 0))))
+                   (flet ((%f4 ()
+                            (multiple-value-call #'%f15
+                              (values (%f15 c 0) (%f15 0)))))
+                     (if nil (%f4)
+                         (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
+                                  f8-3))
+                           0))))
+                 0)))
+          3040851270 1664281 -1340106197)))
+
+;;; MISC.249
+(assert (zerop
+         (funcall
+          (compile
+           nil
+           '(lambda (a b)
+             (declare (notinline <=))
+             (declare (optimize (speed 2) (space 3) (safety 0)
+                       (debug 1) (compilation-speed 3)))
+             (if (if (<= 0) nil nil)
+                 (labels ((%f9 (f9-1 f9-2 f9-3)
+                            (ignore-errors 0)))
+                   (dotimes (iv4 5 a) (%f9 0 0 b)))
+                 0)))
+          1 2)))
+
+;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
+(assert
+ (= (funcall
+     (compile
+      nil
+      '(lambda (a)
+         (declare (type (integer 177547470 226026978) a))
+         (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
+                            (compilation-speed 1)))
+         (logand a (* a 438810))))
+     215067723)
+    13739018))
+
+
+;;;; Bugs in stack analysis
+;;; bug 299 (reported by PFD)
+(assert
+ (equal (funcall
+         (compile
+          nil
+          '(lambda ()
+            (declare (optimize (debug 1)))
+            (multiple-value-call #'list
+              (if (eval t) (eval '(values :a :b :c)) nil)
+              (catch 'foo (throw 'foo (values :x :y)))))))
+        '(:a :b :c :x :y)))
+;;; bug 298 (= MISC.183)
+(assert (zerop (funcall
+                (compile
+                 nil
+                 '(lambda (a b c)
+                   (declare (type (integer -368154 377964) a))
+                   (declare (type (integer 5044 14959) b))
+                   (declare (type (integer -184859815 -8066427) c))
+                   (declare (ignorable a b c))
+                   (declare (optimize (speed 3)))
+                   (declare (optimize (safety 1)))
+                   (declare (optimize (debug 1)))
+                   (block b7
+                     (flet ((%f3 (f3-1 f3-2 f3-3) 0))
+                       (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
+                0 6000 -9000000)))
+(assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
+               '(1 2)))
+(let ((f (compile
+          nil
+          '(lambda (x)
+            (block foo
+              (multiple-value-call #'list
+                :a
+                (block bar
+                  (return-from foo
+                    (multiple-value-call #'list
+                      :b
+                      (block quux
+                        (return-from bar
+                          (catch 'baz
+                            (if x
+                                (return-from quux 1)
+                                (throw 'baz 2))))))))))))))
+  (assert (equal (funcall f t) '(:b 1)))
+  (assert (equal (funcall f nil) '(:a 2))))
+
+;;; MISC.185
+(assert (equal
+         (funcall
+          (compile
+           nil
+           '(lambda (a b c)
+             (declare (type (integer 5 155656586618) a))
+             (declare (type (integer -15492 196529) b))
+             (declare (type (integer 7 10) c))
+             (declare (optimize (speed 3)))
+             (declare (optimize (safety 1)))
+             (declare (optimize (debug 1)))
+             (flet ((%f3
+                        (f3-1 f3-2 f3-3
+                              &optional (f3-4 a) (f3-5 0)
+                              (f3-6
+                               (labels ((%f10 (f10-1 f10-2 f10-3)
+                                          0))
+                                 (apply #'%f10
+                                        0
+                                        a
+                                        (- (if (equal a b) b (%f10 c a 0))
+                                           (catch 'ct2 (throw 'ct2 c)))
+                                        nil))))
+                      0))
+               (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
+         0))
+;;; MISC.186
+(assert (eq
+         (eval
+          '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
+                          (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
+                  (vars '(b c))
+                  (fn1 `(lambda ,vars
+                          (declare (type (integer -2 19) b)
+                                   (type (integer -1520 218978) c)
+                                   (optimize (speed 3) (safety 1) (debug 1)))
+                          ,form))
+                  (fn2 `(lambda ,vars
+                          (declare (notinline logeqv apply)
+                                   (optimize (safety 3) (speed 0) (debug 0)))
+                          ,form))
+                  (cf1 (compile nil fn1))
+                  (cf2 (compile nil fn2))
+                  (result1 (multiple-value-list (funcall cf1 2 18886)))
+                  (result2 (multiple-value-list (funcall cf2 2 18886))))
+            (if (equal result1 result2)
+                :good
+                (values result1 result2))))
+         :good))
+
+;;; MISC.290
+(assert (zerop
+         (funcall
+          (compile
+           nil
+           '(lambda ()
+             (declare
+              (optimize (speed 3) (space 3) (safety 1)
+               (debug 2) (compilation-speed 0)))
+             (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
+
+;;; MISC.292
+(assert (zerop (funcall
+                (compile
+                 nil
+                 '(lambda (a b)
+                   (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
+                             (compilation-speed 2)))
+                   (apply (constantly 0)
+                    a
+                    0
+                    (catch 'ct6
+                      (apply (constantly 0)
+                             0
+                             0
+                             (let* ((v1
+                                     (let ((*s7* 0))
+                                       b)))
+                               0)
+                             0
+                             nil))
+                    0
+                    nil)))
+                1 2)))
+
+;;; misc.295
+(assert (eql
+         (funcall
+          (compile
+           nil
+           '(lambda ()
+             (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
+             (multiple-value-prog1
+                 (the integer (catch 'ct8 (catch 'ct7 15867134)))
+               (catch 'ct1 (throw 'ct1 0))))))
+         15867134))
+
+;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
+;;; could transform known-values LVAR to UVL
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b c)
+       (declare (notinline boole values denominator list))
+       (declare
+	(optimize (speed 2)
+		  (space 0)
+		  (safety 1)
+		  (debug 0)
+		  (compilation-speed 2)))
+       (catch 'ct6
+	 (progv
+	     '(*s8*)
+	     (list 0)
+	   (let ((v9 (ignore-errors (throw 'ct6 0))))
+	     (denominator
+	      (progv nil nil (values (boole boole-and 0 v9)))))))))
+   1 2 3)))
+
+;;; non-continuous dead UVL blocks
+(defun non-continuous-stack-test (x)
+  (multiple-value-call #'list
+    (eval '(values 11 12))
+    (eval '(values 13 14))
+    (block ext
+      (return-from non-continuous-stack-test
+        (multiple-value-call #'list
+          (eval '(values :b1 :b2))
+          (eval '(values :b3 :b4))
+          (block int
+            (return-from ext
+              (multiple-value-call (eval #'values)
+                (eval '(values 1 2))
+                (eval '(values 3 4))
+                (block ext
+                  (return-from int
+                    (multiple-value-call (eval #'values)
+                      (eval '(values :a1 :a2))
+                      (eval '(values :a3 :a4))
+                      (block int
+                        (return-from ext
+                          (multiple-value-call (eval #'values)
+                            (eval '(values 5 6))
+                            (eval '(values 7 8))
+                            (if x
+                                :ext
+                                (return-from int :int))))))))))))))))
+(assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
+(assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
+
+;;; MISC.362: environment of UNWIND-PROTECTor is different from that
+;;; if ENTRY.
+(assert (equal (multiple-value-list (funcall
+   (compile
+    nil
+    '(lambda (b g h)
+       (declare (optimize (speed 3) (space 3) (safety 2)
+			  (debug 2) (compilation-speed 3)))
+       (catch 'ct5
+	 (unwind-protect
+	     (labels ((%f15 (f15-1 f15-2 f15-3)
+                            (rational (throw 'ct5 0))))
+	       (%f15 0
+		     (apply #'%f15
+			    0
+			    h
+			    (progn
+			      (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
+			      0)
+			    nil)
+		     0))
+	   (common-lisp:handler-case 0)))))
+   1 2 3))
+ '(0)))
+
+
+;;; MISC.275
+(assert
+ (zerop
+  (funcall
+   (compile
+    nil
+    '(lambda (b)
+      (declare (notinline funcall min coerce))
+      (declare
+       (optimize (speed 1)
+        (space 2)
+        (safety 2)
+        (debug 1)
+        (compilation-speed 1)))
+      (flet ((%f12 (f12-1)
+               (coerce
+                (min
+                 (if f12-1 (multiple-value-prog1
+                               b (return-from %f12 0))
+                     0))
+                'integer)))
+        (funcall #'%f12 0))))
+   -33)))
+
+;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
+;;; potential problem: optimizers and type derivers for MAX and MIN
+;;; were not consistent in treating EQUALP, but not EQL, arguments.
+(dolist (f '(min max))
+  (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
+        for complex-arg = `(if x ,@complex-arg-args)
+        do
+        (loop for args in `((1 ,complex-arg)
+                            (,complex-arg 1))
+              for form = `(,f ,@args)
+              for f1 = (compile nil `(lambda (x) ,form))
+              and f2 = (compile nil `(lambda (x) (declare (notinline min max))
+                                             ,form))
+              do
+              (dolist (x '(nil t))
+                (assert (eql (funcall f1 x) (funcall f2 x)))))))
+
+;;;
+(handler-case (compile nil '(lambda (x)
+                             (declare (optimize (speed 3) (safety 0)))
+                             (the double-float (sqrt (the double-float x)))))
+  (sb-ext:compiler-note ()
+    (error "Compiler does not trust result type assertion.")))
+
+(let ((f (compile nil '(lambda (x)
+                        (declare (optimize speed (safety 0)))
+                        (block nil
+                          (the double-float
+                            (multiple-value-prog1
+                                (sqrt (the double-float x))
+                              (when (< x 0)
+                                (return :minus)))))))))
+  (assert (eql (funcall f -1d0) :minus))
+  (assert (eql (funcall f 4d0) 2d0)))
+
+;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
+(handler-case
+    (compile nil '(lambda (a i)
+                   (locally
+                     (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                                        (inhibit-warnings 0)))
+                     (declare (type (alien (* (unsigned 8))) a)
+                              (type (unsigned-byte 32) i))
+                     (deref a i))))
+  (compiler-note () (error "The code is not optimized.")))
+
+(handler-case
+    (compile nil '(lambda (x)
+		   (declare (type (integer -100 100) x))
+		   (declare (optimize speed))
+		   (declare (notinline identity))
+		   (1+ (identity x))))
+  (compiler-note () (error "IDENTITY derive-type not applied.")))
+
+(assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
+
+;;; MISC.293 = easy variant of bug 303: repeated write to the same
+;;; LVAR; here the first write may be cleared before the second is
+;;; made.
+(assert
+ (zerop
+  (funcall
+   (compile
+    nil
+    '(lambda ()
+      (declare (notinline complex))
+      (declare (optimize (speed 1) (space 0) (safety 1)
+                (debug 3) (compilation-speed 3)))
+      (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
+        (complex (%f) 0)))))))
+
+;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
+(assert (zerop (funcall
+  (compile
+   nil
+   '(lambda (a c)
+     (declare (type (integer -1294746569 1640996137) a))
+     (declare (type (integer -807801310 3) c))
+     (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
+     (catch 'ct7
+       (if
+        (logbitp 0
+                 (if (/= 0 a)
+                     c
+                     (ignore-errors
+                       (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
+        0 0))))
+   391833530 -32785211)))
+
+;;; efficiency notes for ordinary code
+(macrolet ((frob (arglist &body body)
+	     `(progn
+	       (handler-case
+		   (compile nil '(lambda ,arglist ,@body))
+		 (sb-ext:compiler-note (e)
+		   (error "bad compiler note for ~S:~%  ~A" ',body e)))
+	       (catch :got-note
+		 (handler-case
+		     (compile nil '(lambda ,arglist (declare (optimize speed))
+				    ,@body))
+		   (sb-ext:compiler-note (e) (throw :got-note nil)))
+		 (error "missing compiler note for ~S" ',body)))))
+  (frob (x) (funcall x))
+  (frob (x y) (find x y))
+  (frob (x y) (find-if x y))
+  (frob (x y) (find-if-not x y))
+  (frob (x y) (position x y))
+  (frob (x y) (position-if x y))
+  (frob (x y) (position-if-not x y))
+  (frob (x) (aref x 0)))
+
+(macrolet ((frob (style-warn-p form)
+	     (if style-warn-p
+		 `(catch :got-style-warning
+		   (handler-case
+		       (eval ',form)
+		     (style-warning (e) (throw :got-style-warning nil)))
+		   (error "missing style-warning for ~S" ',form))
+		 `(handler-case
+		   (eval ',form)
+		   (style-warning (e)
+		    (error "bad style-warning for ~S: ~A" ',form e))))))
+  (frob t (lambda (x &optional y &key z) (list x y z)))
+  (frob nil (lambda (x &optional y z) (list x y z)))
+  (frob nil (lambda (x &key y z) (list x y z)))
+  (frob t (defgeneric #:foo (x &optional y &key z)))
+  (frob nil (defgeneric #:foo (x &optional y z)))
+  (frob nil (defgeneric #:foo (x &key y z)))
+  (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
+
+;;; this was a bug in the LOGXOR type deriver.  The top form gave a
+;;; note, because the system failed to derive the fact that the return
+;;; from LOGXOR was small and negative, though the bottom one worked.
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil '(lambda ()
+		 (declare (optimize speed (safety 0)))
+		 (lambda (x y)
+		   (declare (type (integer 3 6) x)
+			    (type (integer -6 -3) y))
+		   (+ (logxor x y) most-positive-fixnum)))))
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil '(lambda ()
+		 (declare (optimize speed (safety 0)))
+		 (lambda (x y)
+		   (declare (type (integer 3 6) y)
+			    (type (integer -6 -3) x))
+		   (+ (logxor x y) most-positive-fixnum)))))
+
+;;; check that modular ash gives the right answer, to protect against
+;;; possible misunderstandings about the hardware shift instruction.
+(assert (zerop (funcall
+		(compile nil '(lambda (x y)
+			       (declare (optimize speed)
+			                (type (unsigned-byte 32) x y))
+			       (logand #xffffffff (ash x y))))
+		1 257)))
+
+;;; code instrumenting problems
+(compile nil
+  '(lambda ()
+    (declare (optimize (debug 3)))
+    (list (the integer (if nil 14 t)))))
+
+(compile nil
+  '(LAMBDA (A B C D)
+    (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
+    (DECLARE
+     (OPTIMIZE (SPEED 1)
+      (SPACE 1)
+      (SAFETY 1)
+      (DEBUG 3)
+      (COMPILATION-SPEED 0)))
+    (MASK-FIELD (BYTE 7 26)
+     (PROGN
+       (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
+       B))))
+
+(compile nil
+  '(lambda (buffer i end)
+    (declare (optimize (debug 3)))
+    (loop (when (not (eql 0 end)) (return)))
+    (let ((s (make-string end)))
+      (setf (schar s i) (schar buffer i))
+      s)))
+
+;;; check that constant string prefix and suffix don't cause the
+;;; compiler to emit code deletion notes.
+(handler-bind ((sb-ext:code-deletion-note #'error))
+  (compile nil '(lambda (s x)
+                 (pprint-logical-block (s x :prefix "(")
+                   (print x s))))
+  (compile nil '(lambda (s x)
+                 (pprint-logical-block (s x :per-line-prefix ";")
+                   (print x s))))
+  (compile nil '(lambda (s x)
+                 (pprint-logical-block (s x :suffix ">")
+                   (print x s)))))
+
+;;; MISC.427: loop analysis requires complete DFO structure
+(assert (eql 17 (funcall
+  (compile
+   nil
+   '(lambda (a)
+     (declare (notinline list reduce logior))
+     (declare (optimize (safety 2) (compilation-speed 1)
+               (speed 3) (space 2) (debug 2)))
+     (logior
+      (let* ((v5 (reduce #'+ (list 0 a))))
+        (declare (dynamic-extent v5))
+        v5))))
+    17)))
+
+;;;  MISC.434
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b)
+       (declare (type (integer -8431780939320 1571817471932) a))
+       (declare (type (integer -4085 0) b))
+       (declare (ignorable a b))
+       (declare
+	(optimize (space 2)
+		  (compilation-speed 0)
+		  #+sbcl (sb-c:insert-step-conditions 0)
+		  (debug 2)
+		  (safety 0)
+		  (speed 3)))
+       (let ((*s5* 0))
+	 (dotimes (iv1 2 0)
+	   (let ((*s5*
+		  (elt '(1954479092053)
+		       (min 0
+			    (max 0
+				 (if (< iv1 iv1)
+				     (lognand iv1 (ash iv1 (min 53 iv1)))
+				   iv1))))))
+	     0)))))
+   -7639589303599 -1368)))
+
+(compile
+ nil
+ '(lambda (a b)
+   (declare (type (integer) a))
+   (declare (type (integer) b))
+   (declare (ignorable a b))
+   (declare (optimize (space 2) (compilation-speed 0)
+             (debug 0) (safety 0) (speed 3)))
+   (dotimes (iv1 2 0)
+     (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
+     (print (if (< iv1 iv1)
+                (logand (ash iv1 iv1) 1)
+                iv1)))))
+
+;;; MISC.435: lambda var substitution in a deleted code.
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b c d)
+       (declare (notinline aref logandc2 gcd make-array))
+       (declare
+	(optimize (space 0) (safety 0) (compilation-speed 3)
+		  (speed 3) (debug 1)))
+       (progn
+	 (tagbody
+	  (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
+	    (declare (dynamic-extent v2))
+	    (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
+	  tag2)
+	 0)))
+   3021871717588 -866608 -2 -17194)))
+
+;;; MISC.436, 438: lost reoptimization
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b)
+       (declare (type (integer -2917822 2783884) a))
+       (declare (type (integer 0 160159) b))
+       (declare (ignorable a b))
+       (declare
+	(optimize (compilation-speed 1)
+		  (speed 3)
+		  (safety 3)
+		  (space 0)
+		  ; #+sbcl (sb-c:insert-step-conditions 0)
+		  (debug 0)))
+       (if
+	   (oddp
+	    (loop for
+		  lv1
+		  below
+		  2
+		  count
+		  (logbitp 0
+			   (1-
+			    (ash b
+				 (min 8
+				      (count 0
+					     '(-10197561 486 430631291
+							 9674068))))))))
+	   b
+	 0)))
+   1265797 110757)))
+
+(assert (zerop (funcall
+   (compile
+    nil
+    ' (lambda (a)
+	(declare (type (integer 0 1696) a))
+	; (declare (ignorable a))
+	(declare (optimize (space 2) (debug 0) (safety 1)
+		   (compilation-speed 0) (speed 1)))
+	(if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
+   805)))
+
+;;; bug #302
+(assert (compile
+         nil
+         '(lambda (s ei x y)
+           (declare (type (simple-array function (2)) s) (type ei ei))
+           (funcall (aref s ei) x y))))
+
+;;; MISC.320: ir1-transform can create an intercomponent reference to
+;;; a DEFINED-FUN.
+(assert (eql 102 (funcall
+  (compile
+   nil
+   '(lambda ()
+     (declare (optimize (speed 3) (space 0) (safety 2)
+               (debug 2) (compilation-speed 0)))
+     (catch 'ct2
+       (elt '(102)
+            (flet ((%f12 () (rem 0 -43)))
+              (multiple-value-call #'%f12 (values))))))))))
+
+;;; MISC.437: lost reoptimization after FLUSH-DEST
+(assert (zerop (funcall
+  (compile
+   nil
+   '(lambda (a b c d e)
+     (declare (notinline values complex eql))
+     (declare
+      (optimize (compilation-speed 3)
+       (speed 3)
+       (debug 1)
+       (safety 1)
+       (space 0)))
+     (flet ((%f10
+                (f10-1 f10-2 f10-3
+                       &optional (f10-4 (ignore-errors 0)) (f10-5 0)
+                       &key &allow-other-keys)
+              (if (or (eql 0 0) t) 0 (if f10-1 0 0))))
+       (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0))))
+   80043 74953652306 33658947 -63099937105 -27842393)))
+
+;;; bug #351 -- program-error for malformed LET and LET*, including those
+;;; resulting from SETF of LET.
+(dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops)))
+                   (compile nil '(lambda () (let* :bogus-let* :oops)))
+                   (compile nil '(lambda (x) (push x (let ((y 0)) y))))))
+  (assert (functionp fun))
+  (multiple-value-bind (res err) (ignore-errors (funcall fun))
+    (assert (not res))
+    (assert (typep err 'program-error))))
+
+(let ((fun (compile nil '(lambda (x) (random (if x 10 20))))))
+  (dotimes (i 100 (error "bad RANDOM distribution"))
+    (when (> (funcall fun nil) 9)
+      (return t)))
+  (dotimes (i 100)
+    (when (> (funcall fun t) 9)
+      (error "bad RANDOM event"))))
+
+;;; 0.8.17.28-sma.1 lost derived type information.
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil
+    '(lambda (x y v)
+      (declare (optimize (speed 3) (safety 0)))
+      (declare (type (integer 0 80) x)
+       (type (integer 0 11) y)
+       (type (simple-array (unsigned-byte 32) (*)) v))
+      (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
+      nil)))
+
+;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
+;;; prevented open coding of %LISTIFY-REST-ARGS.
+(let ((f (compile nil '(lambda ()
+                        (declare (optimize (debug 3)))
+                        (with-simple-restart (blah "blah") (error "blah"))))))
+  (handler-bind ((error (lambda (c) (invoke-restart 'blah))))
+    (assert (equal (multiple-value-list (funcall f)) '(nil t)))))
+
+;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
+;;; constant index and value.
+(loop for n-bits = 1 then (* n-bits 2)
+      for type = `(unsigned-byte ,n-bits)
+      and v-max = (1- (ash 1 n-bits))
+      while (<= n-bits sb-vm:n-word-bits)
+      do
+      (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
+             (array1 (make-array n :element-type type))
+             (array2 (make-array n :element-type type)))
+        (dotimes (i n)
+          (dolist (v (list 0 v-max))
+            (let ((f (compile nil `(lambda (a)
+                                     (declare (type (simple-array ,type (,n)) a))
+                                     (setf (aref a ,i) ,v)))))
+              (fill array1 (- v-max v))
+              (fill array2 (- v-max v))
+              (funcall f array1)
+              (setf (aref array2 i) v)
+              (assert (every #'= array1 array2)))))))
+
+(let ((fn (compile nil '(lambda (x)
+			  (declare (type bit x))
+			  (declare (optimize speed))
+			  (let ((b (make-array 64 :element-type 'bit
+					       :initial-element 0)))
+			    (count x b))))))
+  (assert (= (funcall fn 0) 64))
+  (assert (= (funcall fn 1) 0)))
+
+(let ((fn (compile nil '(lambda (x y)
+			  (declare (type simple-bit-vector x y))
+			  (declare (optimize speed))
+			  (equal x y)))))
+  (assert (funcall 
+	   fn 
+	   (make-array 64 :element-type 'bit :initial-element 0)
+	   (make-array 64 :element-type 'bit :initial-element 0)))
+  (assert (not 
+	   (funcall 
+	    fn
+	    (make-array 64 :element-type 'bit :initial-element 0)
+	    (let ((b (make-array 64 :element-type 'bit :initial-element 0)))
+	      (setf (sbit b 63) 1)
+	      b)))))
+
+;;; MISC.535: compiler failure
+(let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
+    (assert (not (funcall
+     (compile
+      nil
+      `(lambda (p1 p2)
+	 (declare (optimize speed (safety 1))
+		  (type (eql ,c0) p1)
+		  (type number p2))
+	 (eql (the (complex double-float) p1) p2)))
+     c0 #c(12 612/979)))))
+
+;;; reported by Lutz Euler: we shouldn't signal a compiler note for
+;;; simple-bit-vector functions.
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil '(lambda (x)
+		 (declare (type simple-bit-vector x))
+		 (count 1 x))))
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil '(lambda (x y)
+		 (declare (type simple-bit-vector x y))
+		 (equal x y))))
+
+;;; MISC.550: CAST merging in IR1 finalization caused unexpected
+;;; code transformations.
+(assert (eql (funcall
+  (compile
+   nil
+   '(lambda (p1 p2)
+     (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
+      (type atom p1)
+      (type symbol p2))
+     (or p1 (the (eql t) p2))))
+   nil t)
+  t))
+
+;;; MISC.548: type check weakening converts required type into
+;;; optional
+(assert (eql t
+  (funcall
+   (compile
+    nil
+    '(lambda (p1)
+      (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
+      (atom (the (member f assoc-if write-line t w) p1))))
+   t)))
+
+;;; Free special bindings only apply to the body of the binding form, not
+;;; the initialization forms.
+(assert (eq :good
+	    (funcall (compile 'nil
+			      (lambda ()
+				(let ((x :bad))
+				  (declare (special x))
+				  (let ((x :good))
+				    ((lambda (&optional (y x))
+				       (declare (special x)) y)))))))))
+
+;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
+;;; a rational was zero, but didn't do the substitution, leading to a
+;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
+;;; machine's ASH instruction's immediate field) that the compiler
+;;; thought was legitimate.
+(compile 'nil
+         (LAMBDA (B)
+           (DECLARE (TYPE (INTEGER -2 14) B))
+           (DECLARE (IGNORABLE B))
+           (ASH (IMAGPART B) 57)))
+
+;;; bug reported by Eduardo Mu\~noz
+(multiple-value-bind (fun warnings failure)
+    (compile nil '(lambda (struct first)
+                   (declare (optimize speed))
+                   (let* ((nodes (nodes struct))
+                          (bars (bars struct))
+                          (length (length nodes))
+                          (new (make-array length :fill-pointer 0)))
+                     (vector-push first new)
+                     (loop with i fixnum = 0
+                           for newl fixnum = (length new)
+                           while (< newl length) do
+                           (let ((oldl (length new)))
+                             (loop for j fixnum from i below newl do
+                                   (dolist (n (node-neighbours (aref new j) bars))
+                                     (unless (find n new)
+                                       (vector-push n new))))
+                             (setq i oldl)))
+                     new)))
+  (declare (ignore fun warnings failure))
+  (assert (not failure)))