X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=1712620e1525bebc900411e88f07779ab65ab424;hb=d94c1b4a8c534bde146823f56558faf37cd4c4d7;hp=d88203eb583ccb46fbf938833d3d6f56730e2451;hpb=7f52216bc52c9ef90e08049f235bca0c34943690;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index d88203e..1712620 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3071,20 +3071,6 @@
             (assert (eql x (funcall fun i)))
             (assert (eql (- x) (funcall fun i))))))))
 
-(with-test (:name (load-time-value :type-derivation))
-  (flet ((test (type form value-cell-p)
-           (let ((derived (funcall (compile
-                                    nil
-                                    `(lambda ()
-                                       (ctu:compiler-derived-type
-                                        (load-time-value ,form)))))))
-             (unless (equal type derived)
-              (error "wanted ~S, got ~S" type derived)))))
-    (let ((* 10))
-      (test '(integer 11 11) '(+ * 1) nil))
-    (let ((* "fooo"))
-      (test '(integer 4 4) '(length *) t))))
-
 (with-test (:name :float-division-using-exact-reciprocal)
   (flet ((test (lambda-form arg res &key (check-insts t))
            (let* ((fun (compile nil lambda-form))
@@ -3968,3 +3954,93 @@
     (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
       (assert (not i))
       (assert (typep e 'type-error)))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-a)
+  (compile nil `(lambda (i)
+                  (declare (unsigned-byte i))
+                  (expt 10 (expt 7 (- 2 i))))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-b)
+  (assert (equal `(FUNCTION (UNSIGNED-BYTE)
+                            (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
+                 (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (i)
+                                  (declare (unsigned-byte i))
+                                  (cos (expt 10 (+ 4096 i)))))))))
+
+(with-test (:name :fixed-%more-arg-values)
+  (let ((fun (compile nil `(lambda (&rest rest)
+                             (declare (optimize (safety 0)))
+                             (apply #'cons rest)))))
+    (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
+
+(with-test (:name :bug-826970)
+  (let ((fun (compile nil `(lambda (a b c)
+                             (declare (type (member -2 1) b))
+                             (array-in-bounds-p a 4 b c)))))
+    (assert (funcall fun (make-array '(5 2 2)) 1 1))))
+
+(with-test (:name :bug-826971)
+  (let* ((foo "foo")
+         (fun (compile nil `(lambda (p1 p2)
+                              (schar (the (eql ,foo) p1) p2)))))
+    (assert (eql #\f (funcall fun foo 0)))))
+
+(with-test (:name :bug-738464)
+  (multiple-value-bind (fun warn fail)
+      (compile nil `(lambda ()
+                      (flet ((foo () 42))
+                        (declare (ftype non-function-type foo))
+                        (foo))))
+    (assert (eql 42 (funcall fun)))
+    (assert (and warn (not fail)))))
+
+(with-test (:name :bug-832005)
+  (let ((fun (compile nil `(lambda (x)
+                             (declare (type (complex single-float) x))
+                             (+ #C(0.0 1.0) x)))))
+    (assert (= (funcall fun #C(1.0 2.0))
+               #C(1.0 3.0)))))
+
+;; A refactoring  1.0.12.18 caused lossy computation of primitive
+;; types for member types.
+(with-test (:name :member-type-primitive-type)
+  (let ((fun (compile nil `(lambda (p1 p2 p3)
+                             (if p1
+                                 (the (member #c(1.2d0 1d0)) p2)
+                                 (the (eql #c(1.0 1.0)) p3))))))
+    (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
+                 #c(1.2d0 1.0d0)))))
+
+;; Fall-through jump elimination made control flow fall through to trampolines.
+;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
+;; reproduced below (triggered a corruption warning and a memory fault).
+(with-test (:name :bug-883500)
+  (funcall (compile nil `(lambda (a)
+                           (declare (type (integer -50 50) a))
+                           (declare (optimize (speed 0)))
+                           (mod (mod a (min -5 a)) 5)))
+           1))
+
+;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
+#+sb-unicode
+(with-test (:name :bug-883519)
+  (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)))))