X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=a7fd779e3af1ecee6e97bc342d51c9416fb54271;hb=fd79e33e6b6dacdc52cf6668a5bb7adf75aad6c1;hp=e9f23d8cda54647be773c5201a389af9bcff43d4;hpb=26839b3799e0687e8df96282aea0368ce12c1e95;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index e9f23d8..a7fd779 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2834,3 +2834,92 @@
       (test-comparison >   double-float (/ 0d0 0d0) 0d0)
       (test-comparison >   double-float 0d0 (/ 0d0 0d0)))))
 
+(with-test (:name :car-and-cdr-type-derivation-conservative)
+  (let ((f1 (compile nil
+                     `(lambda (y)
+                        (declare (optimize speed))
+                        (let ((x (the (cons fixnum fixnum) (cons 1 2))))
+                          (declare (type (cons t fixnum) x))
+                          (rplaca x y)
+                          (+ (car x) (cdr x))))))
+        (f2 (compile nil
+                     `(lambda (y)
+                        (declare (optimize speed))
+                        (let ((x (the (cons fixnum fixnum) (cons 1 2))))
+                          (setf (cdr x) y)
+                          (+ (car x) (cdr x)))))))
+    (flet ((test-error (e value)
+             (assert (typep e 'type-error))
+             (assert (eq 'number (type-error-expected-type e)))
+             (assert (eq value (type-error-datum e)))))
+      (let ((v1 "foo")
+            (v2 "bar"))
+        (multiple-value-bind (res err) (ignore-errors (funcall f1 v1))
+          (assert (not res))
+          (test-error err v1))
+        (multiple-value-bind (res err) (ignore-errors (funcall f2 v2))
+          (assert (not res))
+          (test-error err v2))))))
+
+(with-test (:name :array-dimension-derivation-conservative)
+  (let ((f (compile nil
+                    `(lambda (x)
+                       (declare (optimize speed))
+                       (declare (type (array * (4 4)) x))
+                       (let ((y x))
+                         (setq x (make-array '(4 4)))
+                         (adjust-array y '(3 5))
+                         (array-dimension y 0))))))
+    (assert (= 3 (funcall f (make-array '(4 4) :adjustable t))))))
+
+(with-test (:name :with-timeout-code-deletion-note)
+  (handler-bind ((sb-ext:code-deletion-note #'error))
+    (compile nil `(lambda ()
+                    (sb-ext:with-timeout 0
+                      (sleep 1))))))
+
+(with-test (:name :full-warning-for-undefined-type-in-cl)
+  (assert (eq :full
+              (handler-case
+                  (compile nil `(lambda (x) (the replace x)))
+                (style-warning ()
+                  :style)
+                (warning ()
+                  :full)))))
+
+(with-test (:name :single-warning-for-single-undefined-type)
+  (let ((n 0))
+    (handler-bind ((warning (lambda (c)
+                              (declare (ignore c))
+                              (incf n))))
+      (compile nil `(lambda (x) (the #:no-type x)))
+      (assert (= 1 n))
+      (compile nil `(lambda (x) (the 'fixnum x)))
+      (assert (= 2 n)))))
+
+(with-test (:name :complex-subtype-dumping-in-xc)
+  (assert
+   (= sb-vm:complex-single-float-widetag
+      (sb-kernel:widetag-of
+       (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float))))))
+  (assert
+   (= sb-vm:complex-double-float-widetag
+      (sb-kernel:widetag-of
+       (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
+
+(with-test (:name :complex-single-float-fill)
+  (assert (every (lambda (x) (= #c(1.0 2.0) x))
+                 (funcall
+                  (compile nil
+                           `(lambda (n x)
+                              (make-array (list n)
+                                          :element-type '(complex single-float)
+                                          :initial-element x)))
+                  10
+                  #c(1.0 2.0)))))
+
+(with-test (:name :regression-1.0.28.21)
+  (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1))))))
+    (assert (funcall fun (vector 1 2 3)))
+    (assert (funcall fun "abc"))
+    (assert (not (funcall fun (make-array '(2 2)))))))