X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=5ef755f79d4550a0fd3d1d378e326610c0f84879;hb=d5e1f093b8ca643ce4f39554232e0a1688e85b7c;hp=34ae4a87025dad6d8be68a7d06991c3d8817a5c7;hpb=3d9b54df5e825dfb1f458d91d2bb09877f4348b2;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 34ae4a8..5ef755f 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) @@ -3331,3 +3344,161 @@ (declare (optimize speed safety)) (setf (slot-value x 'bar) y)))) (assert (= 1 notes)))) + +(with-test (:name :concatenate-string-opt) + (flet ((test (type grep) + (let* ((fun (compile nil `(lambda (a b c d e) + (concatenate ',type a b c d e)))) + (args '("foo" #(#\.) "bar" (#\-) "quux")) + (res (apply fun args))) + (assert (search grep (with-output-to-string (out) + (disassemble fun :stream out)))) + (assert (equal (apply #'concatenate type args) + res)) + (assert (typep res type))))) + (test 'string "%CONCATENATE-TO-STRING") + (test 'simple-string "%CONCATENATE-TO-STRING") + (test 'base-string "%CONCATENATE-TO-BASE-STRING") + (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING"))) + +(with-test (:name :satisfies-no-local-fun) + (let ((fun (compile nil `(lambda (arg) + (labels ((local-not-global-bug (x) + t) + (bar (x) + (typep x '(satisfies local-not-global-bug)))) + (bar arg)))))) + (assert (eq 'local-not-global-bug + (handler-case + (funcall fun 42) + (undefined-function (c) + (cell-error-name c))))))) + +;;; Prior to 1.0.32.x, dumping a fasl with a function with a default +;;; argument that is a complex structure (needing make-load-form +;;; processing) failed an AVER. The first attempt at a fix caused +;;; 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))))