+(declaim (ftype (function () (integer 42 42)) bug-655581))
+(defun bug-655581 ()
+ 42)
+(declaim (notinline bug-655581))
+(test-util:with-test (:name :bug-655581)
+ (multiple-value-bind (type derived)
+ (funcall (compile nil `(lambda ()
+ (ctu:compiler-derived-type (bug-655581)))))
+ (assert derived)
+ (assert (equal '(integer 42 42) type))))
+
+(test-util:with-test (:name :clear-derived-types-on-set-fdefn)
+ (let ((*evaluator-mode* :compile)
+ (*derive-function-types* t))
+ (eval `(progn
+ (defun clear-derived-types-on-set-fdefn-1 ()
+ "foo")
+ (setf (symbol-function 'clear-derived-types-on-set-fdefn-1)
+ (constantly "foobar"))
+ (defun clear-derived-types-on-set-fdefn-2 ()
+ (length (clear-derived-types-on-set-fdefn-1)))))
+ (assert (= 6 (clear-derived-types-on-set-fdefn-2)))))
+
+(test-util:with-test (:name (:bug-655126 :derive-function-types t))
+ (let ((*evaluator-mode* :compile)
+ (*derive-function-types* t))
+ (eval `(defun bug-655126 (x) x))
+ ;; Full warnings are ok due to *derive-function-types* = T.
+ (assert (eq :full-warning
+ (handler-case
+ (eval `(defun bug-655126-2 ()
+ (bug-655126)))
+ ((and warning (not style-warning)) ()
+ :full-warning))))
+ (assert (eq 'bug-655126
+ (handler-case
+ (eval `(defun bug-655126 (x y)
+ (cons x y)))
+ ((and warning (not sb-kernel:redefinition-warning)) ()
+ :oops))))
+ (assert (eq :full-warning
+ (handler-case
+ (eval `(defun bug-655126 (x)
+ (bug-655126 x y)))
+ ((and warning
+ (not style-warning)
+ (not sb-kernel:redefinition-warning)) ()
+ :full-warning))))))
+
+(test-util:with-test (:name (:bug-655126 :derive-function-types nil))
+ (let ((*evaluator-mode* :compile))
+ (eval `(defun bug-655126/b (x) x))
+ ;; Just style-warning here.
+ (assert (eq :style-warning
+ (handler-case
+ (eval `(defun bug-655126-2/b ()
+ (bug-655126/b)))
+ (style-warning ()
+ :style-warning))))
+ (assert (eq 'bug-655126/b
+ (handler-case
+ (eval `(defun bug-655126/b (x y)
+ (cons x y)))
+ ((and warning (not sb-kernel:redefinition-warning)) ()
+ :oops))))
+ ;; Bogus self-call is always worth a full one.
+ (assert (eq :full-warning
+ (handler-case
+ (eval `(defun bug-655126/b (x)
+ (bug-655126/b x y)))
+ ((and warning
+ (not style-warning)
+ (not sb-kernel:redefinition-warning)) ()
+ :full-warning))))))
+
+(test-util:with-test (:name :bug-657499)
+ ;; Don't trust derived types within the compilation unit.
+ (ctu:file-compile
+ `((declaim (optimize safety))
+ (defun bug-657499-foo ()
+ (cons t t))
+ (defun bug-657499-bar ()
+ (let ((cons (bug-657499-foo)))
+ (setf (car cons) 3)
+ cons)))
+ :load t)
+ (locally (declare (optimize safety))
+ (setf (symbol-function 'bug-657499-foo) (constantly "foobar"))
+ (assert (eq :type-error
+ (handler-case
+ (funcall 'bug-657499-bar)
+ (type-error (e)
+ (assert (eq 'cons (type-error-expected-type e)))
+ (assert (equal "foobar" (type-error-datum e)))
+ :type-error))))))
+
+(declaim (unsigned-byte *symbol-value-test-var*))
+(defvar *symbol-value-test-var*)
+
+(declaim (unsigned-byte **global-symbol-value-test-var**))
+(defglobal **global-symbol-value-test-var** 0)
+
+(test-util:with-test (:name :symbol-value-type-derivation)
+ (let ((fun (compile
+ nil
+ `(lambda ()
+ *symbol-value-test-var*))))
+ (assert (equal '(function () (values unsigned-byte &optional))
+ (%simple-fun-type fun))))
+ (let ((fun (compile
+ nil
+ `(lambda ()
+ **global-symbol-value-test-var**))))
+ (assert (equal '(function () (values unsigned-byte &optional))
+ (%simple-fun-type fun))))
+ (let ((fun (compile
+ nil
+ `(lambda (*symbol-value-test-var*)
+ (declare (fixnum *symbol-value-test-var*))
+ (symbol-value '*symbol-value-test-var*))))
+ (ufix (type-specifier (specifier-type `(and unsigned-byte fixnum)))))
+ (assert (equal `(function (,ufix) (values ,ufix &optional))
+ (%simple-fun-type fun))))
+ (let ((fun (compile
+ nil
+ `(lambda ()
+ (declare (fixnum **global-symbol-value-test-var**))
+ (symbol-global-value '**global-symbol-value-test-var**))))
+ (ufix (type-specifier (specifier-type `(and unsigned-byte fixnum)))))
+ (assert (equal `(function () (values ,ufix &optional))
+ (%simple-fun-type fun)))))
+
+(test-util:with-test (:name :mv-bind-to-let-type-propagation)
+ (let ((f (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (integer 20 50) x))
+ (< (truncate x 10) 1))))
+ (g (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (integer 20 50) x))
+ (< (nth-value 1 (truncate x 10)) 10))))
+ (h (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (integer 20 50) x))
+ (multiple-value-bind (q r)
+ (truncate x 10)
+ (declare (ignore r))
+ (< q 1)))))
+ (type0 '(function ((integer 20 50)) (values null &optional)))
+ (type1 '(function ((integer 20 50)) (values (member t) &optional))))
+ (assert (equal type0 (sb-kernel:%simple-fun-type f)))
+ (assert (equal type1 (sb-kernel:%simple-fun-type g)))
+ (assert (equal type0 (sb-kernel:%simple-fun-type h)))))
+