X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=d88203eb583ccb46fbf938833d3d6f56730e2451;hb=af0f0f905a9a48360e34581563ce97acbe0a6e13;hp=57191fc3fbc3d5a6f4cd6111f3920f0f4e6093cf;hpb=7a5b7991c107edab3c79ec1fb88c649090b6f25b;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 57191fc..d88203e 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2231,15 +2231,16 @@ (logand most-positive-fixnum (* x most-positive-fixnum)))) ;;; bug 256.b -(assert (let (warned-p) +(with-test (:name :propagate-type-through-error-and-binding) + (assert (let (warned-p) (handler-bind ((warning (lambda (w) (setf warned-p t)))) (compile nil - '(lambda (x) - (list (let ((y (the real x))) - (unless (floatp y) (error "")) - y) - (integer-length x))))) - warned-p)) + '(lambda (x) + (list (let ((y (the real x))) + (unless (floatp y) (error "")) + y) + (integer-length x))))) + warned-p))) ;; Dead / in safe code (with-test (:name :safe-dead-/) @@ -3600,7 +3601,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 + (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))))) @@ -3791,3 +3792,179 @@ (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)))) + +(with-test (:name :bug-729765) + (compile nil `(lambda (a b) + (declare ((integer 1 1) a) + ((integer 0 1) b) + (optimize debug)) + (lambda () (< b a))))) + +;; Actually tests the assembly of RIP-relative operands to comparison +;; functions (one of the few x86 instructions that have extra bytes +;; *after* the mem operand's effective address, resulting in a wrong +;; offset). +(with-test (:name :cmpps) + (let ((foo (compile nil `(lambda (x) + (= #C(2.0 3.0) (the (complex single-float) x)))))) + (assert (funcall foo #C(2.0 3.0))) + (assert (not (funcall foo #C(1.0 2.0)))))) + +(with-test (:name :cmppd) + (let ((foo (compile nil `(lambda (x) + (= #C(2d0 3d0) (the (complex double-float) x)))))) + (assert (funcall foo #C(2d0 3d0))) + (assert (not (funcall foo #C(1d0 2d0)))))) + +(with-test (:name :lvar-externally-checkable-type-nil) + ;; Used to signal a BUG during compilation. + (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1))))) + (multiple-value-bind (i p) (funcall fun :start) + (assert (= 2321321 i)) + (assert (= 8 p))) + (multiple-value-bind (i e) (ignore-errors (funcall fun :end)) + (assert (not i)) + (assert (typep e 'type-error)))))