(assert (eq 'list type))
(assert derivedp)))
+(with-test (:name :rest-list-type-derivation2)
+ (multiple-value-bind (type derivedp)
+ (funcall (funcall (compile nil `(lambda ()
+ (lambda (&rest args)
+ (ctu:compiler-derived-type args))))))
+ (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)))
(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)
(* x -1.0d0)))
1))))
-(with-test (:name :data-vector-ref-with-offset-neg-index)
- (let ((fun (compile nil
- `(lambda ()
- (let ((table (make-array 7
- :element-type 'fixnum
- :initial-contents '(0 1 2 3 4 5 6))))
- (loop for n from -3 upto 3
- collect (aref table (+ 3 n))))))))
- (assert (equal '(0 1 2 3 4 5 6) (funcall fun)))))
-
-(with-test (:name :aref-bignum-offset-and-index)
- ;; These don't get the data-vector-ref-with-offset vop.
- (let ((fun (compile nil
- `(lambda ()
- (let ((table (make-array 7
- :element-type 'fixnum
- :initial-contents '(0 1 2 3 4 5 6))))
- (loop for n from most-negative-fixnum upto (+ most-negative-fixnum 6)
- collect (aref table (+ #.(1+ most-positive-fixnum) n))))))))
- (assert (equal '(0 1 2 3 4 5 6) (funcall fun))))
+(with-test (:name :dotimes-non-integer-counter-value)
+ (assert (raises-error? (dotimes (i 8.6)) type-error)))
+
+(with-test (:name :bug-454681)
+ ;; This used to break due to reference to a dead lambda-var during
+ ;; inline expansion.
+ (assert (compile nil
+ `(lambda ()
+ (multiple-value-bind (iterator+977 getter+978)
+ (does-not-exist-but-does-not-matter)
+ (flet ((iterator+976 ()
+ (funcall iterator+977)))
+ (declare (inline iterator+976))
+ (let ((iterator+976 #'iterator+976))
+ (funcall iterator+976))))))))
+
+(with-test (:name :complex-float-local-fun-args)
+ ;; As of 1.0.27.14, the lambda below failed to compile due to the
+ ;; compiler attempting to pass unboxed complex floats to Z and the
+ ;; MOVE-ARG method not expecting the register being used as a
+ ;; temporary frame pointer. Reported by sykopomp in #lispgames,
+ ;; reduced test case provided by _3b`.
+ (compile nil '(lambda (a)
+ (labels ((z (b c)
+ (declare ((complex double-float) b c))
+ (* b (z b c))))
+ (loop for i below 10 do
+ (setf a (z a a)))))))
+
+(with-test (:name :bug-309130)
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
+ ((and warning (not style-warning)) ()
+ :warning))))
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda (x)
+ (declare (optimize (debug 0)))
+ (declare (type vector x))
+ (list (fill-pointer x) (svref x 1))))
+ ((and warning (not style-warning)) ()
+ :warning))))
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda (x)
+ (list (vector-push (svref x 0) x))))
+ ((and warning (not style-warning)) ()
+ :warning))))
+ (assert (eq :warning
+ (handler-case
+ (compile nil `(lambda (x)
+ (list (vector-push-extend (svref x 0) x))))
+ ((and warning (not style-warning)) ()
+ :warning)))))
+
+(with-test (:name :bug-646796)
+ (assert 42
+ (funcall
+ (compile nil
+ `(lambda ()
+ (load-time-value (the (values fixnum) 42)))))))
+
+(with-test (:name :bug-654289)
+ ;; 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)))))
+ (t1 (get-internal-run-time)))
+ (assert (funcall f tree))
+ (- t1 t0)))
+ (make-tree (n acc)
+ (cond ((zerop n) acc)
+ (t (make-tree (1- n) (cons acc acc))))))
+ (let* ((times (loop for i from 0 upto 4
+ collect (time-n i)))
+ (max-small (reduce #'max times :end 3))
+ (max-big (reduce #'max times :start 3)))
+ ;; This way is hopefully fairly CPU-performance insensitive.
+ (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)
+ (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 ()
- (let ((table (make-array 7
- :element-type 'fixnum
- :initial-contents '(0 1 2 3 4 5 6))))
- (loop for n from (+ most-positive-fixnum 1) upto (+ most-positive-fixnum 7)
- collect (aref table (- n (+ most-positive-fixnum 1)))))))))
- (assert (equal '(0 1 2 3 4 5 6) (funcall fun)))))
+ `(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)))))
+
+(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)))))