X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=531acc1325ac8e4e461e343004d6f4079cfcef59;hb=0c0d8909984b5b33bb6b59b350b2d5cee6dc1715;hp=6bf6dfd439ce692c978f54e6fb52b01802a8c12b;hpb=86db706477784d7ac24a320ba3f7a399cccf5dd3;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 6bf6dfd..531acc1 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3253,14 +3253,27 @@ (truncate x)))) (d (compile nil `(lambda (x) (declare (double-float x)) - (truncate x))))) + (truncate x)))) + (s-inlined (compile nil '(lambda (x) + (declare (type (single-float 0.0s0 1.0s0) x)) + (truncate x)))) + (d-inlined (compile nil '(lambda (x) + (declare (type (double-float 0.0d0 1.0d0) x)) + (truncate x))))) ;; Check that there is no generic arithmetic (assert (not (search "GENERIC" (with-output-to-string (out) (disassemble s :stream out))))) (assert (not (search "GENERIC" (with-output-to-string (out) - (disassemble d :stream out))))))) + (disassemble d :stream out))))) + ;; Check that we actually inlined the call when we were supposed to. + (assert (not (search "UNARY-TRUNCATE" + (with-output-to-string (out) + (disassemble s-inlined :stream out))))) + (assert (not (search "UNARY-TRUNCATE" + (with-output-to-string (out) + (disassemble d-inlined :stream out))))))) (with-test (:name :make-array-unnamed-dimension-leaf) (let ((fun (compile nil `(lambda (stuff) @@ -3367,3 +3380,181 @@ ;;; doing the same in-core to break. (with-test (:name :bug-310132) (compile nil '(lambda (&optional (foo #p"foo/bar"))))) + +(with-test (:name :bug-309129) + (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v)))) + (warningp nil) + (fun (handler-bind ((warning (lambda (c) + (setf warningp t) (muffle-warning c)))) + (compile nil src)))) + (assert warningp) + (handler-case (funcall fun #(1)) + (type-error (c) + ;; we used to put simply VECTOR into EXPECTED-TYPE, rather + ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY)) + (assert (not (typep (type-error-datum c) (type-error-expected-type c))))) + (:no-error (&rest values) + (declare (ignore values)) + (error "no error"))))) + +(with-test (:name :unary-round-type-derivation) + (let* ((src '(lambda (zone) + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + (declare (ignore h)) + (round (* 60.0 m))))) + (fun (compile nil src))) + (assert (= (funcall fun 0.5) 30)))) + +(with-test (:name :bug-525949) + (let* ((src '(lambda () + (labels ((always-one () 1) + (f (z) + (let ((n (funcall z))) + (declare (fixnum n)) + (the double-float (expt n 1.0d0))))) + (f #'always-one)))) + (warningp nil) + (fun (handler-bind ((warning (lambda (c) + (setf warningp t) (muffle-warning c)))) + (compile nil src)))) + (assert (not warningp)) + (assert (= 1.0d0 (funcall fun))))) + +(with-test (:name :%array-data-vector-type-derivation) + (let* ((f (compile nil + `(lambda (ary) + (declare (type (simple-array (unsigned-byte 32) (3 3)) ary)) + (setf (aref ary 0 0) 0)))) + (text (with-output-to-string (s) + (disassemble f :stream s)))) + (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text))))) + +(with-test (:name :array-storage-vector-type-derivation) + (let ((f (compile nil + `(lambda (ary) + (declare (type (simple-array (unsigned-byte 32) (3 3)) ary)) + (ctu:compiler-derived-type (array-storage-vector ary)))))) + (assert (equal '(simple-array (unsigned-byte 32) (9)) + (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32))))))) + +(with-test (:name :bug-523612) + (let ((fun + (compile nil + `(lambda (&key toff) + (make-array 3 :element-type 'double-float + :initial-contents + (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0))))))) + (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil))) + (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0))))) + +(with-test (:name :bug-309788) + (let ((fun + (compile nil + `(lambda (x) + (declare (optimize speed)) + (let ((env nil)) + (typep x 'fixnum env)))))) + (assert (not (ctu:find-named-callees fun))))) + +(with-test (:name :bug-309124) + (let ((fun + (compile nil + `(lambda (x) + (declare (integer x)) + (declare (optimize speed)) + (cond ((typep x 'fixnum) + "hala") + ((typep x 'fixnum) + "buba") + ((typep x 'bignum) + "hip") + (t + "zuz")))))) + (assert (equal (list "hala" "hip") + (sort (ctu:find-code-constants fun :type 'string) + #'string<))))) + +(with-test (:name :bug-316078) + (let ((fun + (compile nil + `(lambda (x) + (declare (type (and simple-bit-vector (satisfies bar)) x) + (optimize speed)) + (elt x 5))))) + (assert (not (ctu:find-named-callees fun))) + (assert (= 1 (funcall fun #*000001))) + (assert (= 0 (funcall fun #*000010))))) + +(with-test (:name :mult-by-one-in-float-acc-zero) + (assert (eql 1.0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x 1.0))) + 1))) + (assert (eql -1.0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x -1.0))) + 1))) + (assert (eql 1.0d0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x 1.0d0))) + 1))) + (assert (eql -1.0d0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x -1.0d0))) + 1)))) + +(with-test (:name :dotimes-non-integer-counter-value) + (assert (raises-error? (dotimes (i 8.6)) type-error))) + +(with-test (:name :bug-454681) + ;; This used to break due to reference to a dead lambda-var during + ;; inline expansion. + (assert (compile nil + `(lambda () + (multiple-value-bind (iterator+977 getter+978) + (does-not-exist-but-does-not-matter) + (flet ((iterator+976 () + (funcall iterator+977))) + (declare (inline iterator+976)) + (let ((iterator+976 #'iterator+976)) + (funcall iterator+976)))))))) + +(with-test (:name :complex-float-local-fun-args) + ;; As of 1.0.27.14, the lambda below failed to compile due to the + ;; compiler attempting to pass unboxed complex floats to Z and the + ;; MOVE-ARG method not expecting the register being used as a + ;; temporary frame pointer. Reported by sykopomp in #lispgames, + ;; reduced test case provided by _3b`. + (compile nil '(lambda (a) + (labels ((z (b c) + (declare ((complex double-float) b c)) + (* b (z b c)))) + (loop for i below 10 do + (setf a (z a a))))))) + +(with-test (:name :bug-309130) + (assert (eq :warning + (handler-case + (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (declare (optimize (debug 0))) + (declare (type vector x)) + (list (fill-pointer x) (svref x 1)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push-extend (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning)))))