X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=1e747c4be7c0ca53e1547b8647e95a70520d7ba1;hb=83659744f9caa97aa83eb562d872b1c0127403c0;hp=a454e59b86e4b97dba1878f4e617a5978a41fb71;hpb=af4276830f299244920d0e131e1e5e088383b763;p=sbcl.git

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index a454e59..1e747c4 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1003,33 +1003,18 @@
     (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun)))
     (assert (= 1 (count-full-calls "QUUX-MARKER" fun)))))
 
-(defun file-compile (toplevel-forms &key load)
-  (let* ((lisp "compile-impure-tmp.lisp")
-         (fasl (compile-file-pathname lisp)))
-    (unwind-protect
-         (progn
-           (with-open-file (f lisp :direction :output)
-             (dolist (form toplevel-forms)
-               (prin1 form f)))
-           (multiple-value-bind (fasl warn fail) (compile-file lisp)
-             (when load
-               (load fasl))
-             (values warn fail)))
-      (ignore-errors (delete-file lisp))
-      (ignore-errors (delete-file fasl)))))
-
 (with-test (:name :bug-405)
   ;; These used to break with a TYPE-ERROR
   ;;     The value NIL is not of type SB-C::PHYSENV.
   ;; in MERGE-LETS.
-  (file-compile
+  (ctu:file-compile
    '((LET (outer-let-var)
        (lambda ()
          (print outer-let-var)
          (MULTIPLE-VALUE-CALL 'some-function
            (MULTIPLE-VALUE-CALL (LAMBDA (a) 'foo)
              1))))))
-  (file-compile
+  (ctu:file-compile
    '((declaim (optimize (debug 3)))
      (defstruct bug-405-foo bar)
      (let ()
@@ -2018,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