X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fcompiler.pure.lisp;h=0cd2fac3de93c9b8cfe663f9a40c03b63fd815f5;hb=a51d83191034919bc76367268929e234d62164db;hp=074ef9a75c7eb1a8fe0877b6d206a67744211fea;hpb=d7f0f5bdba142f9b41c269e2f8ccb07a96cc7d5b;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 074ef9a..0cd2fac 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2684,10 +2684,32 @@ (assert (eq 'list type)) (assert derivedp))) +(with-test (:name :rest-list-type-derivation3) + (multiple-value-bind (type derivedp) + (funcall (funcall (compile nil `(lambda () + (lambda (&optional x &rest args) + (unless x (error "oops")) + (ctu:compiler-derived-type args))))) + t) + (assert (eq 'list type)) + (assert derivedp))) + +(with-test (:name :rest-list-type-derivation4) + (multiple-value-bind (type derivedp) + (funcall (funcall (compile nil `(lambda () + (lambda (&optional x &rest args) + (declare (type (or null integer) x)) + (when x (setf args x)) + (ctu:compiler-derived-type args))))) + 42) + (assert (equal '(or cons null integer) type)) + (assert derivedp))) + (with-test (:name :base-char-typep-elimination) - (assert (eq (funcall (lambda (ch) - (declare (type base-char ch) (optimize (speed 3) (safety 0))) - (typep ch 'base-char)) + (assert (eq (funcall (compile nil + `(lambda (ch) + (declare (type base-char ch) (optimize (speed 3) (safety 0))) + (typep ch 'base-char))) t) t))) @@ -3599,3 +3621,147 @@ (declare (type (integer 0 0) x)) (ash x 100))))) (assert (zerop (funcall fun 0))))) + +(with-test (:name :bug-655872) + (let ((f (compile nil `(lambda (x) + (declare (optimize (safety 3))) + (aref (locally (declare (optimize (safety 0))) + (coerce x '(simple-vector 128))) + 60)))) + (long (make-array 100 :element-type 'fixnum))) + (dotimes (i 100) + (setf (aref long i) i)) + ;; 1. COERCE doesn't check the length in unsafe code. + (assert (eql 60 (funcall f long))) + ;; 2. The compiler doesn't trust the length from COERCE + (assert (eq :caught + (handler-case + (funcall f (list 1 2 3)) + (sb-int:invalid-array-index-error (e) + (assert (eql 60 (type-error-datum e))) + (assert (equal '(integer 0 (3)) (type-error-expected-type e))) + :caught)))))) + +(with-test (:name :bug-655203-regression) + (let ((fun (compile nil + `(LAMBDA (VARIABLE) + (LET ((CONTINUATION + (LAMBDA + (&OPTIONAL DUMMY &REST OTHER) + (DECLARE (IGNORE OTHER)) + (PRIN1 DUMMY) + (PRIN1 VARIABLE)))) + (FUNCALL CONTINUATION (LIST 1 2))))))) + ;; This used to signal a bogus type-error. + (assert (equal (with-output-to-string (*standard-output*) + (funcall fun t)) + "(1 2)T")))) + +(with-test (:name :constant-concatenate-compile-time) + (flet ((make-lambda (n) + `(lambda (x) + (declare (optimize (speed 3) (space 0))) + (concatenate 'string x ,(make-string n))))) + (let* ((l0 (make-lambda 1)) + (l1 (make-lambda 10)) + (l2 (make-lambda 100)) + (l3 (make-lambda 1000)) + (t0 (get-internal-run-time)) + (f0 (compile nil l0)) + (t1 (get-internal-run-time)) + (f1 (compile nil l1)) + (t2 (get-internal-run-time)) + (f2 (compile nil l2)) + (t3 (get-internal-run-time)) + (f3 (compile nil l3)) + (t4 (get-internal-run-time)) + (d0 (- t1 t0)) + (d1 (- t2 t1)) + (d2 (- t3 t2)) + (d3 (- t4 t3)) + (short-avg (/ (+ d0 d1 d2) 3))) + (assert (and f1 f2 f3)) + (assert (< d3 (* 10 short-avg)))))) + +(with-test (:name :bug-384892) + (assert (equal + '(function (fixnum fixnum &key (:k1 (member nil t))) + (values (member t) &optional)) + (sb-kernel:%simple-fun-type + (compile nil `(lambda (x y &key k1) + (declare (fixnum x y)) + (declare (boolean k1)) + (declare (ignore x y k1)) + t)))))) + +(with-test (:name :bug-309448) + ;; Like all tests trying to verify that something doesn't blow up + ;; 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) + (let* ((start (get-internal-run-time)) + (fun (compile nil lambda)) + (end (get-internal-run-time)) + (got (funcall fun))) + (unless (eql want got) + (error "wanted ~S, got ~S" want got)) + (- end start)))) + (let ((time-1/simple + ;; This is mostly identical as the next one, but doesn't create + ;; hairy unions of numeric types. + (time-it `(lambda () + (labels ((bar (baz bim) + (let ((n (+ baz bim))) + (* n (+ n 1) bim)))) + (let ((a (bar 1 1)) + (b (bar 1 1)) + (c (bar 1 1))) + (- (+ a b) c)))) + 6)) + (time-1/hairy + (time-it `(lambda () + (labels ((bar (baz bim) + (let ((n (+ baz bim))) + (* n (+ n 1) bim)))) + (let ((a (bar 1 1)) + (b (bar 1 5)) + (c (bar 1 15))) + (- (+ a b) c)))) + -3864))) + (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy))) + (let ((time-2/simple + ;; This is mostly identical as the next one, but doesn't create + ;; hairy unions of numeric types. + (time-it `(lambda () + (labels ((sum-d (n) + (let ((m (truncate 999 n))) + (/ (* n m (1+ m)) 2)))) + (- (+ (sum-d 3) + (sum-d 3)) + (sum-d 3)))) + 166833)) + (time-2/hairy + (time-it `(lambda () + (labels ((sum-d (n) + (let ((m (truncate 999 n))) + (/ (* n m (1+ m)) 2)))) + (- (+ (sum-d 3) + (sum-d 5)) + (sum-d 15)))) + 233168))) + (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy))))) + +(with-test (:name :regression-1.0.44.34) + (compile nil '(lambda (z &rest args) + (declare (dynamic-extent args)) + (flet ((foo (w v) (list v w))) + (setq z 0) + (flet ((foo () + (foo z args))) + (declare (sb-int:truly-dynamic-extent #'foo)) + (call #'foo nil)))))) + +(with-test (:name :bug-713626) + (let ((f (eval '(constantly 42)))) + (handler-bind ((warning #'error)) + (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))