X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=b3c9c0e4efee3f2129d320e02f9f733738f9670b;hb=6596b18b95780986ff4eb511ab384da138adbb58;hp=f6dcabf80c520798fe21c76324050de7d6c673d8;hpb=fa2c3ba871c9818e5768fd8f6092ddda83a93a1f;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index f6dcabf..b3c9c0e 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2231,15 +2231,16 @@
                (logand most-positive-fixnum (* x most-positive-fixnum))))
 
 ;;; bug 256.b
-(assert (let (warned-p)
+(with-test (:name :propagate-type-through-error-and-binding)
+  (assert (let (warned-p)
             (handler-bind ((warning (lambda (w) (setf warned-p t))))
               (compile nil
-                         '(lambda (x)
-                           (list (let ((y (the real x)))
-                                   (unless (floatp y) (error ""))
-                                   y)
-                                 (integer-length x)))))
-            warned-p))
+                       '(lambda (x)
+                         (list (let ((y (the real x)))
+                                 (unless (floatp y) (error ""))
+                                 y)
+                          (integer-length x)))))
+            warned-p)))
 
 ;; Dead / in safe code
 (with-test (:name :safe-dead-/)
@@ -3874,3 +3875,70 @@
     (nconc cycle cycle)
     (compile nil `(lambda (x)
                     (member x ',cycle)))))
+
+(with-test (:name :bug-722734)
+  (assert (raises-error?
+            (funcall (compile
+                      nil
+                      '(lambda ()
+                        (eql (make-array 6)
+                         (list unbound-variable-1 unbound-variable-2))))))))
+
+(with-test (:name :bug-771673)
+  (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar))))
+  ;; Make sure the compiler doesn't use THE, and check that setf-expansions
+  ;; work.
+  (let ((f (compile nil `(lambda (x y)
+                           (setf (truly-the fixnum (car x)) y)))))
+    (let* ((cell (cons t t)))
+      (funcall f cell :ok)
+      (assert (equal '(:ok . t) cell)))))
+
+(with-test (:name (:bug-793771 +))
+  (let ((f (compile nil `(lambda (x y)
+                            (declare (type (single-float 2.0) x)
+                                     (type (single-float (0.0)) y))
+                           (+ x y)))))
+    (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
+                              (values (single-float 2.0) &optional))
+                   (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 -))
+  (let ((f (compile nil `(lambda (x y)
+                            (declare (type (single-float * 2.0) x)
+                                     (type (single-float (0.0)) y))
+                           (- x y)))))
+    (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
+                              (values (single-float * 2.0) &optional))
+                   (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 *))
+  (let ((f (compile nil `(lambda (x)
+                            (declare (type (single-float (0.0)) x))
+                           (* x 0.1)))))
+    (assert (equal `(function ((single-float (0.0)))
+                              (values (or (member 0.0) (single-float (0.0))) &optional))
+                   (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 /))
+  (let ((f (compile nil `(lambda (x)
+                            (declare (type (single-float (0.0)) x))
+                           (/ x 3.0)))))
+    (assert (equal `(function ((single-float (0.0)))
+                              (values (or (member 0.0) (single-float (0.0))) &optional))
+                   (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-486812 single-float))
+  (compile nil `(lambda ()
+                  (sb-kernel:make-single-float -1))))
+
+(with-test (:name (:bug-486812 double-float))
+  (compile nil `(lambda ()
+                  (sb-kernel:make-double-float -1 0))))
+
+(with-test (:name :bug-729765)
+  (compile nil `(lambda (a b)
+                  (declare ((integer 1 1) a)
+                           ((integer 0 1) b)
+                           (optimize debug))
+                  (lambda () (< b a)))))