(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)))
`(lambda (x y z)
(make-array '3 :initial-contents `(,x ,y ,z))))))))
+;;; optimizing array-in-bounds-p
+(with-test (:name :optimize-array-in-bounds-p)
+ (locally
+ (macrolet ((find-callees (&body body)
+ `(ctu:find-named-callees
+ (compile nil
+ '(lambda ()
+ ,@body))
+ :name 'array-in-bounds-p))
+ (must-optimize (&body exprs)
+ `(progn
+ ,@(loop for expr in exprs
+ collect `(assert (not (find-callees
+ ,expr))))))
+ (must-not-optimize (&body exprs)
+ `(progn
+ ,@(loop for expr in exprs
+ collect `(assert (find-callees
+ ,expr))))))
+ (must-optimize
+ ;; in bounds
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a 0))
+ ;; exceeds upper bound (constant)
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a 1))
+ ;; exceeds upper bound (interval)
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a (+ 1 (random 2))))
+ ;; negative lower bound (constant)
+ (let ((a (make-array '(1))))
+ (array-in-bounds-p a -1))
+ ;; negative lower bound (interval)
+ (let ((a (make-array 3))
+ (i (- (random 1) 20)))
+ (array-in-bounds-p a i))
+ ;; multiple known dimensions
+ (let ((a (make-array '(1 1))))
+ (array-in-bounds-p a 0 0))
+ ;; union types
+ (let ((s (the (simple-string 10) (eval "0123456789"))))
+ (array-in-bounds-p s 9)))
+ (must-not-optimize
+ ;; don't trust non-simple array length in safety=1
+ (let ((a (the (array * (10)) (make-array 10 :adjustable t))))
+ (eval `(adjust-array ,a 0))
+ (array-in-bounds-p a 9))
+ ;; same for a union type
+ (let ((s (the (string 10) (make-array 10
+ :element-type 'character
+ :adjustable t))))
+ (eval `(adjust-array ,s 0))
+ (array-in-bounds-p s 9))
+ ;; single unknown dimension
+ (let ((a (make-array (random 20))))
+ (array-in-bounds-p a 10))
+ ;; multiple unknown dimensions
+ (let ((a (make-array (list (random 20) (random 5)))))
+ (array-in-bounds-p a 5 2))
+ ;; some other known dimensions
+ (let ((a (make-array (list 1 (random 5)))))
+ (array-in-bounds-p a 0 2))
+ ;; subscript might be negative
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (- (random 3) 2)))
+ ;; subscript might be too large
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (random 6)))
+ ;; unknown upper bound
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (get-universal-time)))
+ ;; unknown lower bound
+ (let ((a (make-array 5)))
+ (array-in-bounds-p a (- (get-universal-time))))
+ ;; in theory we should be able to optimize
+ ;; the following but the current implementation
+ ;; doesn't cut it because the array type's
+ ;; dimensions get reported as (* *).
+ (let ((a (make-array (list (random 20) 1))))
+ (array-in-bounds-p a 5 2))))))
+
;;; optimizing (EXPT -1 INTEGER)
(test-util:with-test (:name (expt minus-one integer))
(dolist (x '(-1 -1.0 -1.0d0))
(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))
+ (disassembly (with-output-to-string (s)
+ (disassemble fun :stream s))))
+ ;; Let's make sure there is no division at runtime: for x86 and
+ ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
+ ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
+ ;; it works.
+ #+(or x86 x86-64)
+ (when check-insts
+ (assert (not (search "DIV" disassembly))))
+ ;; No generic arithmetic!
+ (assert (not (search "GENERIC" disassembly)))
+ (assert (eql res (funcall fun arg))))))
+ (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
+ (dolist (type '(single-float double-float))
+ (let* ((cf (coerce c type))
+ (arg (- (random (* 2 cf)) cf))
+ (r1 (eval `(/ ,arg ,cf)))
+ (r2 (eval `(/ ,arg ,(- cf)))))
+ (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1)
+ (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2)
+ ;; rational args should get optimized as well
+ (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1)
+ (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2))))
+ ;; Also check that inexact reciprocals (1) are not used by default (2) are
+ ;; used with FLOAT-ACCURACY=0.
+ (dolist (type '(single-float double-float))
+ (let ((trey (coerce 3 type))
+ (one (coerce 1 type)))
+ (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one
+ :check-insts nil)
+ (test `(lambda (x)
+ (declare (,type x)
+ (optimize (sb-c::float-accuracy 0)))
+ (/ x 3))
+ trey (eval `(* ,trey (/ ,trey))))))))
+
+(with-test (:name :float-multiplication-by-one)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Multiplication at runtime should be eliminated only with
+ ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
+ #+(or x86 x86-64)
+ (assert (and (search "MUL" disassembly1)
+ (not (search "MUL" disassembly2))))
+ ;; Not generic arithmetic, please!
+ (assert (and (not (search "GENERIC" disassembly1))
+ (not (search "GENERIC" disassembly2))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (dolist (type '(single-float double-float))
+ (let* ((one (coerce 1 type))
+ (arg (random (* 2 one)))
+ (-r (- arg)))
+ (test `(lambda (x) (declare (,type x)) (* x 1)) arg)
+ (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r)
+ (test `(lambda (x) (declare (,type x)) (* x ,one)) arg)
+ (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r)))))
+
+(with-test (:name :float-addition-of-zero)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Let's make sure there is no addition at runtime: for x86 and
+ ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
+ ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
+ ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
+ ;; addition in to catch SNaNs.
+ #+x86
+ (assert (and (search "FADD" disassembly1)
+ (not (search "FADD" disassembly2))))
+ #+x86-64
+ (let ((inst (if (typep result 'double-float)
+ "ADDSD" "ADDSS")))
+ (assert (and (search inst disassembly1)
+ (not (search inst disassembly2)))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45)
+ (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21)
+ (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0)
+ (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0)
+ (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0)
+ (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0)))
+
+(with-test (:name :float-substraction-of-zero)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Let's make sure there is no substraction at runtime: for x86
+ ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
+ ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
+ ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
+ ;; substraction in in to catch SNaNs.
+ #+x86
+ (assert (and (search "FSUB" disassembly1)
+ (not (search "FSUB" disassembly2))))
+ #+x86-64
+ (let ((inst (if (typep result 'double-float)
+ "SUBSD" "SUBSS")))
+ (assert (and (search inst disassembly1)
+ (not (search inst disassembly2)))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45)
+ (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21)
+ (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0)
+ (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0)
+ (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0)
+ (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0)))
+
+(with-test (:name :float-multiplication-by-two)
+ (flet ((test (lambda-form arg &optional (result arg))
+ (let* ((fun1 (compile nil lambda-form))
+ (fun2 (funcall (compile nil `(lambda ()
+ (declare (optimize (sb-c::float-accuracy 0)))
+ ,lambda-form))))
+ (disassembly1 (with-output-to-string (s)
+ (disassemble fun1 :stream s)))
+ (disassembly2 (with-output-to-string (s)
+ (disassemble fun2 :stream s))))
+ ;; Let's make sure there is no multiplication at runtime: for x86
+ ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
+ ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
+ ;; but it works.
+ #+(or x86 x86-64)
+ (assert (and (not (search "MUL" disassembly1))
+ (not (search "MUL" disassembly2))))
+ (assert (eql result (funcall fun1 arg)))
+ (assert (eql result (funcall fun2 arg))))))
+ (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9)
+ (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42)
+ (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0)
+ (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0)
+ (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0)
+ (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0)))
+
+(with-test (:name :bug-392203)
+ ;; Used to hit an AVER in COMVERT-MV-CALL.
+ (assert (zerop
+ (funcall
+ (compile nil
+ `(lambda ()
+ (flet ((k (&rest x) (declare (ignore x)) 0))
+ (multiple-value-call #'k #'k))))))))
+
+(with-test (:name :allocate-closures-failing-aver)
+ (let ((f (compile nil `(lambda ()
+ (labels ((k (&optional x) #'k)))))))
+ (assert (null (funcall f)))))
+
+(with-test (:name :flush-vector-creation)
+ (let ((f (compile nil `(lambda ()
+ (dotimes (i 1024)
+ (vector i i i))
+ t))))
+ (ctu:assert-no-consing (funcall f))))
+
+(with-test (:name :array-type-predicates)
+ (dolist (et sb-kernel::*specialized-array-element-types*)
+ (when et
+ (let* ((v (make-array 3 :element-type et))
+ (fun (compile nil `(lambda ()
+ (list
+ (if (typep ,v '(simple-array ,et (*)))
+ :good
+ :bad)
+ (if (typep (elt ,v 0) '(simple-array ,et (*)))
+ :bad
+ :good))))))
+ (assert (equal '(:good :good) (funcall fun)))))))
+
+(with-test (:name :truncate-float)
+ (let ((s (compile nil `(lambda (x)
+ (declare (single-float x))
+ (truncate x))))
+ (d (compile nil `(lambda (x)
+ (declare (double-float x))
+ (truncate x))))
+ (s-inlined (compile nil '(lambda (x)
+ (declare (type (single-float 0.0s0 1.0s0) x))
+ (truncate x))))
+ (d-inlined (compile nil '(lambda (x)
+ (declare (type (double-float 0.0d0 1.0d0) x))
+ (truncate x)))))
+ ;; Check that there is no generic arithmetic
+ (assert (not (search "GENERIC"
+ (with-output-to-string (out)
+ (disassemble s :stream out)))))
+ (assert (not (search "GENERIC"
+ (with-output-to-string (out)
+ (disassemble d :stream out)))))
+ ;; Check that we actually inlined the call when we were supposed to.
+ (assert (not (search "UNARY-TRUNCATE"
+ (with-output-to-string (out)
+ (disassemble s-inlined :stream out)))))
+ (assert (not (search "UNARY-TRUNCATE"
+ (with-output-to-string (out)
+ (disassemble d-inlined :stream out)))))))
+
+(with-test (:name :make-array-unnamed-dimension-leaf)
+ (let ((fun (compile nil `(lambda (stuff)
+ (make-array (map 'list 'length stuff))))))
+ (assert (equalp #2A((0 0 0) (0 0 0))
+ (funcall fun '((1 2) (1 2 3)))))))
+
+(with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
+ (dolist (name '(float-sign float-radix float-digits float-precision decode-float
+ integer-decode-float))
+ (let ((fun (compile nil `(lambda (x)
+ (declare (optimize safety))
+ (,name x)
+ nil))))
+ (flet ((test (arg)
+ (unless (eq :error
+ (handler-case
+ (funcall fun arg)
+ (error () :error)))
+ (error "(~S ~S) did not error"
+ name arg))))
+ ;; No error
+ (funcall fun 1.0)
+ ;; Error
+ (test 'not-a-float)
+ (when (member name '(decode-float integer-decode-float))
+ (test sb-ext:single-float-positive-infinity))))))
+
+(with-test (:name :sap-ref-16)
+ (let* ((fun (compile nil `(lambda (x y)
+ (declare (type sb-sys:system-area-pointer x)
+ (type (integer 0 100) y))
+ (sb-sys:sap-ref-16 x (+ 4 y)))))
+ (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+ '(simple-array (unsigned-byte 8) (*))))
+ (sap (sb-sys:vector-sap vector))
+ (ret (funcall fun sap 0)))
+ ;; test for either endianness
+ (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
+
+(with-test (:name :coerce-type-warning)
+ (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
+ (signed-byte 8) (signed-byte 16) (signed-byte 32)))
+ (multiple-value-bind (fun warningsp failurep)
+ (compile nil `(lambda (x)
+ (declare (type simple-vector x))
+ (coerce x '(vector ,type))))
+ (assert (null warningsp))
+ (assert (null failurep))
+ (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
+
+(with-test (:name :truncate-double-float)
+ (let ((fun (compile nil `(lambda (x)
+ (multiple-value-bind (q r)
+ (truncate (coerce x 'double-float))
+ (declare (type unsigned-byte q)
+ (type double-float r))
+ (list q r))))))
+ (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
+
+(with-test (:name :set-slot-value-no-warning)
+ (let ((notes 0))
+ (handler-bind ((warning #'error)
+ (sb-ext:compiler-note (lambda (c)
+ (declare (ignore c))
+ (incf notes))))
+ (compile nil `(lambda (x y)
+ (declare (optimize speed safety))
+ (setf (slot-value x 'bar) y))))
+ (assert (= 1 notes))))
+
+(with-test (:name :concatenate-string-opt)
+ (flet ((test (type grep)
+ (let* ((fun (compile nil `(lambda (a b c d e)
+ (concatenate ',type a b c d e))))
+ (args '("foo" #(#\.) "bar" (#\-) "quux"))
+ (res (apply fun args)))
+ (assert (search grep (with-output-to-string (out)
+ (disassemble fun :stream out))))
+ (assert (equal (apply #'concatenate type args)
+ res))
+ (assert (typep res type)))))
+ (test 'string "%CONCATENATE-TO-STRING")
+ (test 'simple-string "%CONCATENATE-TO-STRING")
+ (test 'base-string "%CONCATENATE-TO-BASE-STRING")
+ (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
+
+(with-test (:name :satisfies-no-local-fun)
+ (let ((fun (compile nil `(lambda (arg)
+ (labels ((local-not-global-bug (x)
+ t)
+ (bar (x)
+ (typep x '(satisfies local-not-global-bug))))
+ (bar arg))))))
+ (assert (eq 'local-not-global-bug
+ (handler-case
+ (funcall fun 42)
+ (undefined-function (c)
+ (cell-error-name c)))))))
+
+;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
+;;; argument that is a complex structure (needing make-load-form
+;;; processing) failed an AVER. The first attempt at a fix caused
+;;; doing the same in-core to break.
+(with-test (:name :bug-310132)
+ (compile nil '(lambda (&optional (foo #p"foo/bar")))))
+
+(with-test (:name :bug-309129)
+ (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
+ (warningp nil)
+ (fun (handler-bind ((warning (lambda (c)
+ (setf warningp t) (muffle-warning c))))
+ (compile nil src))))
+ (assert warningp)
+ (handler-case (funcall fun #(1))
+ (type-error (c)
+ ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
+ ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
+ (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
+ (:no-error (&rest values)
+ (declare (ignore values))
+ (error "no error")))))
+
+(with-test (:name :unary-round-type-derivation)
+ (let* ((src '(lambda (zone)
+ (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+ (declare (ignore h))
+ (round (* 60.0 m)))))
+ (fun (compile nil src)))
+ (assert (= (funcall fun 0.5) 30))))
+
+(with-test (:name :bug-525949)
+ (let* ((src '(lambda ()
+ (labels ((always-one () 1)
+ (f (z)
+ (let ((n (funcall z)))
+ (declare (fixnum n))
+ (the double-float (expt n 1.0d0)))))
+ (f #'always-one))))
+ (warningp nil)
+ (fun (handler-bind ((warning (lambda (c)
+ (setf warningp t) (muffle-warning c))))
+ (compile nil src))))
+ (assert (not warningp))
+ (assert (= 1.0d0 (funcall fun)))))
+
+(with-test (:name :%array-data-vector-type-derivation)
+ (let* ((f (compile nil
+ `(lambda (ary)
+ (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+ (setf (aref ary 0 0) 0))))
+ (text (with-output-to-string (s)
+ (disassemble f :stream s))))
+ (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
+
+(with-test (:name :array-storage-vector-type-derivation)
+ (let ((f (compile nil
+ `(lambda (ary)
+ (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
+ (ctu:compiler-derived-type (array-storage-vector ary))))))
+ (assert (equal '(simple-array (unsigned-byte 32) (9))
+ (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
+
+(with-test (:name :bug-523612)
+ (let ((fun
+ (compile nil
+ `(lambda (&key toff)
+ (make-array 3 :element-type 'double-float
+ :initial-contents
+ (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
+ (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
+ (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
+
+(with-test (:name :bug-309788)
+ (let ((fun
+ (compile nil
+ `(lambda (x)
+ (declare (optimize speed))
+ (let ((env nil))
+ (typep x 'fixnum env))))))
+ (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :bug-309124)
+ (let ((fun
+ (compile nil
+ `(lambda (x)
+ (declare (integer x))
+ (declare (optimize speed))
+ (cond ((typep x 'fixnum)
+ "hala")
+ ((typep x 'fixnum)
+ "buba")
+ ((typep x 'bignum)
+ "hip")
+ (t
+ "zuz"))))))
+ (assert (equal (list "hala" "hip")
+ (sort (ctu:find-code-constants fun :type 'string)
+ #'string<)))))
+
+(with-test (:name :bug-316078)
+ (let ((fun
+ (compile nil
+ `(lambda (x)
+ (declare (type (and simple-bit-vector (satisfies bar)) x)
+ (optimize speed))
+ (elt x 5)))))
+ (assert (not (ctu:find-named-callees fun)))
+ (assert (= 1 (funcall fun #*000001)))
+ (assert (= 0 (funcall fun #*000010)))))
+
+(with-test (:name :mult-by-one-in-float-acc-zero)
+ (assert (eql 1.0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x 1.0)))
+ 1)))
+ (assert (eql -1.0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x -1.0)))
+ 1)))
+ (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x 1.0d0)))
+ 1)))
+ (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
+ (declare (optimize (sb-c::float-accuracy 0)))
+ (* x -1.0d0)))
+ 1))))
+
+(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)
+ (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.
+ (assert (> (* (+ 2 max-small) 2) max-big)))))
+
+(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 (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))))))