X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=c8d09acdded3a910c9d7a4134ae86f8f330c02f1;hb=f42877dcb11f1db580c76c37ae86541b901ac281;hp=c74f9b4ee1248a6d2702a961295b5d05b823789a;hpb=7619132f587e6d30935a38cd19da7d0d80dbc7a3;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index c74f9b4..c8d09ac 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))) @@ -2737,7 +2759,7 @@ (eval '(,lambda ,@args)))))))) (sb-vm::with-float-traps-masked (:divide-by-zero :overflow :inexact :invalid) - (let ((sb-ext:*evaluator-mode* :interpret)) + (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret)) (declare (sb-ext:muffle-conditions style-warning)) (test-comparison eql t t nil) (test-comparison eql t t t) @@ -3620,3 +3642,148 @@ (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))))))))) + +(with-test (:name :known-fun-allows-other-keys) + (handler-bind ((warning #'error)) + (funcall (compile nil '(lambda () (directory "." :allow-other-keys t)))) + (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t)))))) + +(with-test (:name :bug-551227) + ;; This function causes constraint analysis to perform a + ;; ref-substitution that alters the A referred to in (G A) at in the + ;; consequent of the IF to refer to be NUMBER, from the + ;; LET-converted inline-expansion of MOD. This leads to attempting + ;; to CLOSE-OVER a variable that simply isn't in scope when it is + ;; referenced. + (compile nil '(lambda (a) + (if (let ((s a)) + (block :block + (map nil + (lambda (e) + (return-from :block + (f (mod a e)))) + s))) + (g a)))))