X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=a7118fbc946b764a181de8e2dfedf50cad4f70dc;hb=295fdbaa30b57128da30e1e5fb0c653dd20f46d1;hp=73cc33db8160c1bc380fa670e15f2103fab3f043;hpb=b2d132a93d1fb2980b296fb0ae789580eae6691c;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 73cc33d..a7118fb 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2082,6 +2082,31 @@
       (compiler-note () (throw :note nil)))
     (error "Unreachable code undetected.")))
 
+(with-test (:name (:compiler :constraint-propagation :float-bounds-3
+                   :LP-894498))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x)
+                        (declare (type (single-float 0.0) x))
+                        (when (> x 0.0)
+                          (when (zerop x)
+                            (error "This is unreachable.")))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-4
+                   :LP-894498))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x y)
+                        (declare (type (single-float 0.0) x)
+                                 (type (single-float (0.0)) y))
+                        (when (> x y)
+                          (when (zerop x)
+                            (error "This is unreachable.")))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))
+
 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
   (catch :note
     (handler-case
@@ -3690,6 +3715,7 @@
   ;; 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)
+           (gc :full t) ; let's keep GCs coming from other code out...
            (let* ((start (get-internal-run-time))
                   (fun (compile nil lambda))
                   (end (get-internal-run-time))
@@ -4028,3 +4054,69 @@
   (compile nil `(lambda (x)
                   (declare (type character x))
                   (eql x #\U0010FFFF))))
+
+;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
+(with-test (:name :bug-887220)
+  (let ((incfer (compile
+                 nil
+                 `(lambda (vector index)
+                    (declare (type (simple-array sb-ext:word (4))
+                                   vector)
+                             (type (mod 4) index))
+                    (sb-ext:atomic-incf (aref vector index) 1)
+                    vector))))
+    (assert (equalp (funcall incfer
+                             (make-array 4 :element-type 'sb-ext:word
+                                           :initial-element 0)
+                             1)
+                    #(0 1 0 0)))))
+
+(with-test (:name :catch-interferes-with-debug-names)
+  (let ((fun (funcall
+              (compile nil
+                       `(lambda ()
+                          (catch 'out
+                              (flet ((foo ()
+                                       (throw 'out (lambda () t))))
+                                (foo))))))))
+    (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
+
+(with-test (:name :interval-div-signed-zero)
+  (let ((fun (compile nil
+                      `(Lambda (a)
+                         (declare (type (member 0 -272413371076) a))
+                         (ffloor (the number a) -63243.127451934015d0)))))
+    (multiple-value-bind (q r) (funcall fun 0)
+      (assert (eql -0d0 q))
+      (assert (eql 0d0 r)))))
+
+(with-test (:name :non-constant-keyword-typecheck)
+  (let ((fun (compile nil
+                      `(lambda (p1 p3 p4)
+                         (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)))))