X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=1712620e1525bebc900411e88f07779ab65ab424;hb=f3491f128307938cc56367f739b8fbf9e5d503b6;hp=3ff8d013abddd197b3e0ef1e7f3430bc9d9fb688;hpb=dd9f2ab664c9d6d7546d5f403bda5157fc4b960b;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 3ff8d01..1712620 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-/) @@ -3070,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)) @@ -3882,3 +3869,178 @@ '(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))))) + +(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)))))