(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-/)
(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)
(assert (eql x (funcall fun i)))
(assert (eql (- x) (funcall fun i))))))))
-(with-test (:name (load-time-value :type-derivation))
- (flet ((test (type form value-cell-p)
- (let ((derived (funcall (compile
- nil
- `(lambda ()
- (ctu:compiler-derived-type
- (load-time-value ,form)))))))
- (unless (equal type derived)
- (error "wanted ~S, got ~S" type derived)))))
- (let ((* 10))
- (test '(integer 11 11) '(+ * 1) nil))
- (let ((* "fooo"))
- (test '(integer 4 4) '(length *) t))))
-
(with-test (:name :float-division-using-exact-reciprocal)
(flet ((test (lambda-form arg res &key (check-insts t))
(let* ((fun (compile nil lambda-form))
;; 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)))))
(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)
(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))))
+
+(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)))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-a)
+ (compile nil `(lambda (i)
+ (declare (unsigned-byte i))
+ (expt 10 (expt 7 (- 2 i))))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-b)
+ (assert (equal `(FUNCTION (UNSIGNED-BYTE)
+ (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
+ (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (i)
+ (declare (unsigned-byte i))
+ (cos (expt 10 (+ 4096 i)))))))))
+
+(with-test (:name :fixed-%more-arg-values)
+ (let ((fun (compile nil `(lambda (&rest rest)
+ (declare (optimize (safety 0)))
+ (apply #'cons rest)))))
+ (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
+
+(with-test (:name :bug-826970)
+ (let ((fun (compile nil `(lambda (a b c)
+ (declare (type (member -2 1) b))
+ (array-in-bounds-p a 4 b c)))))
+ (assert (funcall fun (make-array '(5 2 2)) 1 1))))
+
+(with-test (:name :bug-826971)
+ (let* ((foo "foo")
+ (fun (compile nil `(lambda (p1 p2)
+ (schar (the (eql ,foo) p1) p2)))))
+ (assert (eql #\f (funcall fun foo 0)))))
projects / sbcl.git / blobdiff