X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fcompiler.pure.lisp;h=d88203eb583ccb46fbf938833d3d6f56730e2451;hb=af0f0f905a9a48360e34581563ce97acbe0a6e13;hp=3ff8d013abddd197b3e0ef1e7f3430bc9d9fb688;hpb=dd9f2ab664c9d6d7546d5f403bda5157fc4b960b;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 3ff8d01..d88203e 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-/)
@@ -3882,3 +3883,88 @@
                       '(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)))))
+
+;; Actually tests the assembly of RIP-relative operands to comparison
+;; functions (one of the few x86 instructions that have extra bytes
+;; *after* the mem operand's effective address, resulting in a wrong
+;; offset).
+(with-test (:name :cmpps)
+  (let ((foo (compile nil `(lambda (x)
+                             (= #C(2.0 3.0) (the (complex single-float) x))))))
+    (assert (funcall foo #C(2.0 3.0)))
+    (assert (not (funcall foo #C(1.0 2.0))))))
+
+(with-test (:name :cmppd)
+  (let ((foo (compile nil `(lambda (x)
+                             (= #C(2d0 3d0) (the (complex double-float) x))))))
+    (assert (funcall foo #C(2d0 3d0)))
+    (assert (not (funcall foo #C(1d0 2d0))))))
+
+(with-test (:name :lvar-externally-checkable-type-nil)
+  ;; Used to signal a BUG during compilation.
+  (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
+    (multiple-value-bind (i p) (funcall fun :start)
+      (assert (= 2321321 i))
+      (assert (= 8 p)))
+    (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
+      (assert (not i))
+      (assert (typep e 'type-error)))))