X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=fe4bd644e7d1e1625b58b71b56e3da65908c479c;hb=52b1041d3a14eaa4e45f6d8edfbdc0dec4292239;hp=eb60efd035ca42058ee0d69ab479e29976a4fafc;hpb=930e3879538d196aeb8c08e9d1b223f641f533d6;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index eb60efd..fe4bd64 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4096,3 +4096,143 @@
                          (declare (type keyword p3))
                          (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
     (assert (funcall fun (cons 1.0 2.0) :test '=))))
+
+(with-test (:name :truncate-wild-values)
+  (multiple-value-bind (q r)
+      (handler-bind ((warning #'error))
+        (let ((sb-c::*check-consistency* t))
+          (funcall (compile nil
+                            `(lambda (a)
+                               (declare (type (member 1d0 2d0) a))
+                               (block return-value-tag
+                                 (funcall
+                                  (the function
+                                       (catch 'debug-catch-tag
+                                         (return-from return-value-tag
+                                           (progn (truncate a)))))))))
+                   2d0)))
+    (assert (eql 2 q))
+    (assert (eql 0d0 r))))
+
+(with-test (:name :boxed-fp-constant-for-full-call)
+  (let ((fun (compile nil
+                      `(lambda (x)
+                         (declare (double-float x))
+                         (unknown-fun 1.0d0 (+ 1.0d0 x))))))
+    (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
+
+(with-test (:name :only-one-boxed-constant-for-multiple-uses)
+  (let* ((big (1+ most-positive-fixnum))
+         (fun (compile nil
+                       `(lambda (x)
+                          (unknown-fun ,big (+ ,big x))))))
+    (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
+
+(with-test (:name :fixnum+float-coerces-fixnum
+            :skipped-on :x86)
+  (let ((fun (compile nil
+                      `(lambda (x y)
+                         (declare (fixnum x)
+                                  (single-float y))
+                         (+ x y)))))
+    (assert (not (ctu:find-named-callees fun)))
+    (assert (not (search "GENERIC"
+                         (with-output-to-string (s)
+                           (disassemble fun :stream s)))))))
+
+(with-test (:name :bug-803508)
+  (compile nil `(lambda ()
+                  (print
+                   (lambda (bar)
+                     (declare (dynamic-extent bar))
+                     (foo bar))))))
+
+(with-test (:name :bug-803508-b)
+  (compile nil `(lambda ()
+                  (list
+                   (lambda (bar)
+                     (declare (dynamic-extent bar))
+                     (foo bar))))))
+
+(with-test (:name :bug-803508-c)
+  (compile nil `(lambda ()
+                  (list
+                   (lambda (bar &optional quux)
+                     (declare (dynamic-extent bar quux))
+                     (foo bar quux))))))
+
+(with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
+  (compile nil `(lambda (b c d)
+                  (declare (type (integer -20545789 207590862) c))
+                  (declare (type (integer -1 -1) d))
+                  (let ((i (unwind-protect 32 (shiftf d -1))))
+                    (or (if (= d c)  2 (= 3 b)) 4)))))
+
+(with-test (:name :bug-913232)
+  (compile nil `(lambda (x)
+                  (declare (optimize speed)
+                           (type (or (and (or (integer -100 -50)
+                                              (integer 100 200)) (satisfies foo))
+                                     (and (or (integer 0 10) (integer 20 30)) a)) x))
+                  x))
+  (compile nil `(lambda (x)
+                  (declare (optimize speed)
+                           (type (and fixnum a) x))
+                  x)))
+
+(with-test (:name :bug-959687)
+  (multiple-value-bind (fun warn fail)
+      (compile nil `(lambda (x)
+                      (case x
+                        (t
+                         :its-a-t)
+                        (otherwise
+                         :somethign-else))))
+    (assert (and warn fail))
+    (assert (not (ignore-errors (funcall fun t)))))
+  (multiple-value-bind (fun warn fail)
+      (compile nil `(lambda (x)
+                      (case x
+                        (otherwise
+                         :its-an-otherwise)
+                        (t
+                         :somethign-else))))
+    (assert (and warn fail))
+    (assert (not (ignore-errors (funcall fun t))))))
+
+(with-test (:name :bug-924276)
+  (assert (eq :style-warning
+              (handler-case
+                  (compile nil `(lambda (a)
+                                  (cons a (symbol-macrolet ((b 1))
+                                            (declare (ignorable a))
+                                            :c))))
+                (style-warning ()
+                  :style-warning)))))
+
+(with-test (:name :bug-974406)
+  (let ((fun32 (compile nil `(lambda (x)
+                               (declare (optimize speed (safety 0)))
+                               (declare (type (integer 53 86) x))
+                               (logand (+ x 1032791128) 11007078467))))
+        (fun64 (compile nil `(lambda (x)
+                               (declare (optimize speed (safety 0)))
+                               (declare (type (integer 53 86) x))
+                               (logand (+ x 1152921504606846975)
+                                       38046409652025950207)))))
+    (assert (= (funcall fun32 61) 268574721))
+    (assert (= (funcall fun64 61) 60)))
+  (let (result)
+    (do ((width 5 (1+ width)))
+        ((= width 130))
+      (dotimes (extra 4)
+        (let ((fun (compile nil `(lambda (x)
+                                   (declare (optimize speed (safety 0)))
+                                   (declare (type (integer 1 16) x))
+                                   (logand
+                                    (+ x ,(1- (ash 1 width)))
+                                    ,(logior (ash 1 (+ width 1 extra))
+                                             (1- (ash 1 width))))))))
+          (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
+            (push (cons width extra) result)))))
+    (assert (null result))))