X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=e16ad5528da1965b83cabb2ad147a8c4de5ee8cc;hb=60deeb7616b22ae52cf1dd8bbc2904a1a0d80ffd;hp=7cced511149fb541a34f9abf80df0e61bc4e210d;hpb=ae026fe85fef157ff42d6655e5f5e4eef74709f1;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 7cced51..e16ad55 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1441,7 +1441,9 @@
                      (declare (type (alien (* (unsigned 8))) a)
                               (type (unsigned-byte 32) i))
                      (deref a i))))
-  (compiler-note () (error "The code is not optimized.")))
+  (compiler-note (c)
+    (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c)))
+      (error "The code is not optimized."))))
 
 (handler-case
     (compile nil '(lambda (x)
@@ -4476,3 +4478,92 @@
                 (declare (inline recursed called))
                 (recursed)))))
 
+(with-test (:name :constant-fold-logtest)
+  (assert (equal (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (x)
+                                  (declare (type (mod 1024) x)
+                                           (optimize speed))
+                                  (logtest x 2048))))
+                 '(function ((unsigned-byte 10)) (values null &optional)))))
+
+;; type mismatches on LVARs with multiple potential sources used to
+;; be reported as mismatches with the value NIL.  Make sure we get
+;; a warning, but that it doesn't complain about a constant NIL ...
+;; of type FIXNUM.
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast))
+  (block nil
+    (handler-bind ((sb-int:type-warning
+                     (lambda (c)
+                       (assert
+                        (not (search "Constant "
+                                     (simple-condition-format-control
+                                      c))))
+                       (return))))
+      (compile nil `(lambda (x y z)
+                      (declare (type fixnum y z))
+                      (aref (if x y z) 0))))
+    (error "Where's my warning?")))
+
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
+  (block nil
+    (handler-bind ((style-warning
+                     (lambda (c)
+                       (assert
+                        (not (position
+                              nil
+                              (simple-condition-format-arguments c))))
+                       (return))))
+      (compile nil `(lambda (x y z f)
+                      (declare (type fixnum y z))
+                      (catch (if x y z) (funcall f)))))
+    (error "Where's my style-warning?")))
+
+;; Smoke test for rightward shifts
+(with-test (:name (:ash/right-signed))
+  (let* ((f (compile nil `(lambda (x y)
+                            (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+                                     (type sb-vm:signed-word x)
+                                     (optimize speed))
+                            (ash x (- y)))))
+         (max (ash most-positive-word -1))
+         (min (- -1 max)))
+    (flet ((test (x y)
+             (assert (= (ash x (- y))
+                        (funcall f x y)))))
+      (dotimes (x 32)
+        (dotimes (y (* 2 sb-vm:n-word-bits))
+          (test x y)
+          (test (- x) y)
+          (test (- max x) y)
+          (test (+ min x) y))))))
+
+(with-test (:name (:ash/right-unsigned))
+  (let ((f (compile nil `(lambda (x y)
+                           (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+                                    (type word x)
+                                    (optimize speed))
+                           (ash x (- y)))))
+        (max most-positive-word))
+    (flet ((test (x y)
+             (assert (= (ash x (- y))
+                        (funcall f x y)))))
+      (dotimes (x 32)
+        (dotimes (y (* 2 sb-vm:n-word-bits))
+          (test x y)
+          (test (- max x) y))))))
+
+(with-test (:name (:ash/right-fixnum))
+  (let ((f (compile nil `(lambda (x y)
+                           (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+                                    (type fixnum x)
+                                    (optimize speed))
+                           (ash x (- y))))))
+    (flet ((test (x y)
+             (assert (= (ash x (- y))
+                        (funcall f x y)))))
+      (dotimes (x 32)
+        (dotimes (y (* 2 sb-vm:n-word-bits))
+          (test x y)
+          (test (- x) y)
+          (test (- most-positive-fixnum x) y)
+          (test (+ most-negative-fixnum x) y))))))