1.0.43.57: better handling of derived function types

[sbcl.git] / tests / compiler.impure.lisp

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index d8fcd3d..1e747c4 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -2003,27 +2003,77 @@
                (length (clear-derived-types-on-set-fdefn-1)))))
     (assert (= 6 (clear-derived-types-on-set-fdefn-2)))))
 
-(test-util:with-test (:name :bug-655126)
+(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))
-    (assert (eq :style-warning
+    ;; Full warnings are ok due to *derive-function-types* = T.
+    (assert (eq :full-warning
                 (handler-case
                     (eval `(defun bug-655126-2 ()
                              (bug-655126)))
-                  (style-warning ()
-                    :style-warning))))
+                  ((and warning (not style-warning)) ()
+                    :full-warning))))
     (assert (eq 'bug-655126
                 (handler-case
                     (eval `(defun bug-655126 (x y)
                              (cons x y)))
-                  ((and style-warning (not sb-kernel:redefinition-warning)) ()
+                  ((and warning (not sb-kernel:redefinition-warning)) ()
                     :oops))))
-    (assert (eq :style-warning
+    (assert (eq :full-warning
                 (handler-case
                     (eval `(defun bug-655126 (x)
                              (bug-655126 x y)))
-                  ((and style-warning (not sb-kernel:redefinition-warning)) ()
-                    :style-warning))))))
+                  ((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))))))
 
 ;;; success