Revert "fix sb-posix tests on OpenBSD"

[sbcl.git] / tests / compiler.pure.lisp

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 38640aa..1712620 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3954,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)))))