X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=2388091b106f4c36dac8a50011cd4d1afe92a29b;hb=219cc40793f9c82fb943b29a1846f898f4f9de1e;hp=083a79e32933ec033d7f516f30a78268ea7126cd;hpb=7da051bf31bc6097e0096fd75df194cb1f5c6762;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 083a79e..2388091 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3715,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))
@@ -4079,3 +4080,36 @@
                                        (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))))