X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=28d61915a08e04ad06c066c93533c6f9e324f2d3;hb=371577a214ce2659c271279ad48e4c42e1c0c93e;hp=1c4945009f3a503de78d5dfefa0d929a42d3a18c;hpb=2e33f2df9a6eb5a84d71726b88f06d92241e44da;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 1c49450..28d6191 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3211,3 +3211,247 @@ (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0) (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0) (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0))) + +(with-test (:name :bug-392203) + ;; Used to hit an AVER in COMVERT-MV-CALL. + (assert (zerop + (funcall + (compile nil + `(lambda () + (flet ((k (&rest x) (declare (ignore x)) 0)) + (multiple-value-call #'k #'k)))))))) + +(with-test (:name :allocate-closures-failing-aver) + (let ((f (compile nil `(lambda () + (labels ((k (&optional x) #'k))))))) + (assert (null (funcall f))))) + +(with-test (:name :flush-vector-creation) + (let ((f (compile nil `(lambda () + (dotimes (i 1024) + (vector i i i)) + t)))) + (ctu:assert-no-consing (funcall f)))) + +(with-test (:name :array-type-predicates) + (dolist (et sb-kernel::*specialized-array-element-types*) + (when et + (let* ((v (make-array 3 :element-type et)) + (fun (compile nil `(lambda () + (list + (if (typep ,v '(simple-array ,et (*))) + :good + :bad) + (if (typep (elt ,v 0) '(simple-array ,et (*))) + :bad + :good)))))) + (assert (equal '(:good :good) (funcall fun))))))) + +(with-test (:name :truncate-float) + (let ((s (compile nil `(lambda (x) + (declare (single-float x)) + (truncate x)))) + (d (compile nil `(lambda (x) + (declare (double-float 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))))) + ;; 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) + (make-array (map 'list 'length stuff)))))) + (assert (equalp #2A((0 0 0) (0 0 0)) + (funcall fun '((1 2) (1 2 3))))))) + +(with-test (:name :fp-decoding-funs-not-flushable-in-safe-code) + (dolist (name '(float-sign float-radix float-digits float-precision decode-float + integer-decode-float)) + (let ((fun (compile nil `(lambda (x) + (declare (optimize safety)) + (,name x) + nil)))) + (flet ((test (arg) + (unless (eq :error + (handler-case + (funcall fun arg) + (error () :error))) + (error "(~S ~S) did not error" + name arg)))) + ;; No error + (funcall fun 1.0) + ;; Error + (test 'not-a-float) + (when (member name '(decode-float integer-decode-float)) + (test sb-ext:single-float-positive-infinity)))))) + +(with-test (:name :sap-ref-16) + (let* ((fun (compile nil `(lambda (x y) + (declare (type sb-sys:system-area-pointer x) + (type (integer 0 100) y)) + (sb-sys:sap-ref-16 x (+ 4 y))))) + (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + '(simple-array (unsigned-byte 8) (*)))) + (sap (sb-sys:vector-sap vector)) + (ret (funcall fun sap 0))) + ;; test for either endianness + (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5)))))) + +(with-test (:name :coerce-type-warning) + (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) + (signed-byte 8) (signed-byte 16) (signed-byte 32))) + (multiple-value-bind (fun warningsp failurep) + (compile nil `(lambda (x) + (declare (type simple-vector x)) + (coerce x '(vector ,type)))) + (assert (null warningsp)) + (assert (null failurep)) + (assert (typep (funcall fun #(1)) `(simple-array ,type (*))))))) + +(with-test (:name :truncate-double-float) + (let ((fun (compile nil `(lambda (x) + (multiple-value-bind (q r) + (truncate (coerce x 'double-float)) + (declare (type unsigned-byte q) + (type double-float r)) + (list q r)))))) + (assert (equal (funcall fun 1.0d0) '(1 0.0d0))))) + +(with-test (:name :set-slot-value-no-warning) + (let ((notes 0)) + (handler-bind ((warning #'error) + (sb-ext:compiler-note (lambda (c) + (declare (ignore c)) + (incf notes)))) + (compile nil `(lambda (x y) + (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)))))