X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fcompiler.pure.lisp;h=19f6c962743f7979cef24fba0217d703a8c42ba3;hb=9e37bfc1ef0532a16a9ac8b1e48123ee19347f80;hp=060010b04e4adc38706aff15b9f043810d185667;hpb=dbe82b489260b2ef76e916d0aeaee8b3850f5f52;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 060010b..19f6c96 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2759,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) @@ -3600,6 +3600,7 @@ ;; Test that compile-times don't explode when quoted constants ;; get big. (labels ((time-n (n) + (gc :full t) ; Let's not confuse the issue with GC (let* ((tree (make-tree (expt 10 n) nil)) (t0 (get-internal-run-time)) (f (compile nil `(lambda (x) (eq x (quote ,tree))))) @@ -3614,7 +3615,10 @@ (max-small (reduce #'max times :end 3)) (max-big (reduce #'max times :start 3))) ;; This way is hopefully fairly CPU-performance insensitive. - (assert (> (* (+ 2 max-small) 2) max-big))))) + (unless (> (+ (truncate internal-time-units-per-second 10) + (* 2 max-small)) + max-big) + (error "Bad scaling or test? ~S" times))))) (with-test (:name :bug-309063) (let ((fun (compile nil `(lambda (x) @@ -3750,3 +3754,183 @@ (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))))) + +(with-test (:name :funcall-lambda-inlined) + (assert (not + (ctu:find-code-constants + (compile nil + `(lambda (x y) + (+ x (funcall (lambda (z) z) y)))) + :type 'function)))) + +(with-test (:name :bug-720382) + (let ((w 0)) + (let ((f + (handler-bind (((and warning (not style-warning)) + (lambda (c) (incf w)))) + (compile nil `(lambda (b) ((lambda () b) 1)))))) + (assert (= w 1)) + (assert (eq :error + (handler-case (funcall f 0) + (error () :error))))))) + +(with-test (:name :multiple-args-to-function) + (let ((form `(flet ((foo (&optional (x 13)) x)) + (funcall (function foo 42)))) + (*evaluator-mode* :interpret)) + (assert (eq :error + (handler-case (eval form) + (error () :error)))) + (multiple-value-bind (fun warn fail) + (compile nil `(lambda () ,form)) + (assert (and warn fail)) + (assert (eq :error + (handler-case (funcall fun) + (error () :error))))))) + +;;; This doesn't test LVAR-FUN-IS directly, but captures it +;;; pretty accurately anyways. +(with-test (:name :lvar-fun-is) + (dolist (fun (list + (lambda (x) (member x x :test #'eq)) + (lambda (x) (member x x :test 'eq)) + (lambda (x) (member x x :test #.#'eq)))) + (assert (equal (list #'sb-kernel:%member-eq) + (ctu:find-named-callees fun)))) + (dolist (fun (list + (lambda (x) + (declare (notinline eq)) + (member x x :test #'eq)) + (lambda (x) + (declare (notinline eq)) + (member x x :test 'eq)) + (lambda (x) + (declare (notinline eq)) + (member x x :test #.#'eq)))) + (assert (member #'sb-kernel:%member-test + (ctu:find-named-callees fun))))) + +(with-test (:name :delete-to-delq-opt) + (dolist (fun (list (lambda (x y) + (declare (list y)) + (delete x y :test #'eq)) + (lambda (x y) + (declare (fixnum x) (list y)) + (delete x y)) + (lambda (x y) + (declare (symbol x) (list y)) + (delete x y :test #'eql)))) + (assert (equal (list #'sb-int:delq) + (ctu:find-named-callees fun))))) + +(with-test (:name :bug-767959) + ;; This used to signal an error. + (compile nil `(lambda () + (declare (optimize sb-c:store-coverage-data)) + (assoc + nil + '((:ordinary . ordinary-lambda-list)))))) + +(with-test (:name :member-on-long-constant-list) + ;; This used to blow stack with a sufficiently long list. + (let ((cycle (list t))) + (nconc cycle cycle) + (compile nil `(lambda (x) + (member x ',cycle))))) + +(with-test (:name :bug-722734) + (assert (raises-error? + (funcall (compile + nil + '(lambda () + (eql (make-array 6) + (list unbound-variable-1 unbound-variable-2)))))))) + +(with-test (:name :bug-771673) + (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar)))) + ;; Make sure the compiler doesn't use THE, and check that setf-expansions + ;; work. + (let ((f (compile nil `(lambda (x y) + (setf (truly-the fixnum (car x)) y))))) + (let* ((cell (cons t t))) + (funcall f cell :ok) + (assert (equal '(:ok . t) cell))))) + +(with-test (:name (:bug-793771 +)) + (let ((f (compile nil `(lambda (x y) + (declare (type (single-float 2.0) x) + (type (single-float (0.0)) y)) + (+ x y))))) + (assert (equal `(function ((single-float 2.0) (single-float (0.0))) + (values (single-float 2.0) &optional)) + (sb-kernel:%simple-fun-type f))))) + +(with-test (:name (:bug-793771 -)) + (let ((f (compile nil `(lambda (x y) + (declare (type (single-float * 2.0) x) + (type (single-float (0.0)) y)) + (- x y))))) + (assert (equal `(function ((single-float * 2.0) (single-float (0.0))) + (values (single-float * 2.0) &optional)) + (sb-kernel:%simple-fun-type f))))) + +(with-test (:name (:bug-793771 *)) + (let ((f (compile nil `(lambda (x) + (declare (type (single-float (0.0)) x)) + (* x 0.1))))) + (assert (equal `(function ((single-float (0.0))) + (values (or (member 0.0) (single-float (0.0))) &optional)) + (sb-kernel:%simple-fun-type f))))) + +(with-test (:name (:bug-793771 /)) + (let ((f (compile nil `(lambda (x) + (declare (type (single-float (0.0)) x)) + (/ x 3.0))))) + (assert (equal `(function ((single-float (0.0))) + (values (or (member 0.0) (single-float (0.0))) &optional)) + (sb-kernel:%simple-fun-type f))))) + +(with-test (:name (:bug-486812 single-float)) + (compile nil `(lambda () + (sb-kernel:make-single-float -1)))) + +(with-test (:name (:bug-486812 double-float)) + (compile nil `(lambda () + (sb-kernel:make-double-float -1 0))))