(compiler-note () (throw :note nil)))
(error "Unreachable code undetected.")))
+(with-test (:name (:compiler :constraint-propagation :float-bounds-3
+ :LP-894498))
+ (catch :note
+ (handler-case
+ (compile nil '(lambda (x)
+ (declare (type (single-float 0.0) x))
+ (when (> x 0.0)
+ (when (zerop x)
+ (error "This is unreachable.")))))
+ (compiler-note () (throw :note nil)))
+ (error "Unreachable code undetected.")))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-4
+ :LP-894498))
+ (catch :note
+ (handler-case
+ (compile nil '(lambda (x y)
+ (declare (type (single-float 0.0) x)
+ (type (single-float (0.0)) y))
+ (when (> x y)
+ (when (zerop x)
+ (error "This is unreachable.")))))
+ (compiler-note () (throw :note nil)))
+ (error "Unreachable code undetected.")))
+
(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
(catch :note
(handler-case
;; compile-times this is bound to be a bit brittle, but at least
;; here we try to establish a decent baseline.
(flet ((time-it (lambda want)
+ (gc :full t) ; let's keep GCs coming from other code out...
(let* ((start (get-internal-run-time))
(fun (compile nil lambda))
(end (get-internal-run-time))
(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)))))
+
+(with-test (:name :catch-interferes-with-debug-names)
+ (let ((fun (funcall
+ (compile nil
+ `(lambda ()
+ (catch 'out
+ (flet ((foo ()
+ (throw 'out (lambda () t))))
+ (foo))))))))
+ (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
+
+(with-test (:name :interval-div-signed-zero)
+ (let ((fun (compile nil
+ `(Lambda (a)
+ (declare (type (member 0 -272413371076) a))
+ (ffloor (the number a) -63243.127451934015d0)))))
+ (multiple-value-bind (q r) (funcall fun 0)
+ (assert (eql -0d0 q))
+ (assert (eql 0d0 r)))))
+
+(with-test (:name :non-constant-keyword-typecheck)
+ (let ((fun (compile nil
+ `(lambda (p1 p3 p4)
+ (declare (type keyword p3))
+ (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
+ (assert (funcall fun (cons 1.0 2.0) :test '=))))
+
+(with-test (:name :truncate-wild-values)
+ (multiple-value-bind (q r)
+ (handler-bind ((warning #'error))
+ (let ((sb-c::*check-consistency* t))
+ (funcall (compile nil
+ `(lambda (a)
+ (declare (type (member 1d0 2d0) a))
+ (block return-value-tag
+ (funcall
+ (the function
+ (catch 'debug-catch-tag
+ (return-from return-value-tag
+ (progn (truncate a)))))))))
+ 2d0)))
+ (assert (eql 2 q))
+ (assert (eql 0d0 r))))
projects / sbcl.git / blobdiff