fix bogus test in arith.pure.lisp

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

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index d8fcd3d..9c52b0f 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1212,6 +1212,29 @@
                       (assert (every #'~= (apply #'concatenate 'list nodes) '(2 3 6 9)))))))
     (sb-ext:timeout ()
       (error "Hang in ORDER-UVL-SETS?"))))
+
+(declaim (inline inlined-function-in-source-path))
+(defun inlined-function-in-source-path (x)
+  (+ x x))
+
+(with-test (:name :inlined-function-in-source-path)
+  (let ((output
+         (with-output-to-string (*error-output*)
+           (compile nil `(lambda (x)
+                           (declare (optimize speed))
+                           (funcall #'inlined-function-in-source-path x))))))
+    ;; We want the name
+    (assert (search "INLINED-FUNCTION-IN-SOURCE-PATH" output))
+    ;; ...not the leaf.
+    (assert (not (search "DEFINED-FUN" output)))))
+
+(defmacro bug-795705 ()
+  t)
+
+(with-test (:name :bug-795705)
+  (assert (macro-function 'bug-795705))
+  (fmakunbound 'bug-795705)
+  (assert (not (macro-function 'bug-795705))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -1693,6 +1716,7 @@
                            (list &whole x)))
               (program-error ()
                 :ok))))
+#+sb-eval
 (assert (eq :ok
             (handler-case
                 (let ((*evaluator-mode* :interpret))
@@ -1711,7 +1735,7 @@
                  (defmacro macro-no-env ()
                    :foo))))
 
-(dolist (*evaluator-mode* '(:interpret :compile))
+(dolist (*evaluator-mode* '(#+sb-eval :interpret :compile))
   (disassemble (eval '(defun disassemble-source-form-bug (x y z)
                        (declare (optimize debug))
                        (list x y z)))))
@@ -2003,27 +2027,113 @@
                (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))))))
+
+(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)))))
 
 ;;; success