1.0.4.40: small fixes

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

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index cfc11c1..ff91c66 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -411,11 +411,12 @@
 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
 
 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
 

-(raises-error? (multiple-value-bind (a b c)
-                   (eval '(truncate 3 4))
-                 (declare (integer c))
-                 (list a b c))
-               type-error)
+(assert
+ (raises-error? (multiple-value-bind (a b c)
+                    (eval '(truncate 3 4))
+                  (declare (integer c))
+                  (list a b c))
+                type-error))

 
 (assert (equal (multiple-value-list (the (values &rest integer)
                                       (eval '(values 3))))
 
 (assert (equal (multiple-value-list (the (values &rest integer)
                                       (eval '(values 3))))

@@ -1374,8 +1375,12 @@
 (handler-case (compile nil '(lambda (x)
                              (declare (optimize (speed 3) (safety 0)))
                              (the double-float (sqrt (the double-float x)))))
 (handler-case (compile nil '(lambda (x)
                              (declare (optimize (speed 3) (safety 0)))
                              (the double-float (sqrt (the double-float x)))))

-  (sb-ext:compiler-note ()
-    (error "Compiler does not trust result type assertion.")))
+  (sb-ext:compiler-note (c)
+    ;; Ignore the note for the float -> pointer conversion of the
+    ;; return value.
+    (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
+                     "<return value>")
+      (error "Compiler does not trust result type assertion."))))

 
 (let ((f (compile nil '(lambda (x)
                         (declare (optimize speed (safety 0)))
 
 (let ((f (compile nil '(lambda (x)
                         (declare (optimize speed (safety 0)))

@@ -1900,14 +1905,15 @@
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (1+ x))))
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (1+ x))))

-  ;; forced-to-do GENERIC-+, etc
-  (assert (> count0 0))
+  ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
+  (assert (> count0 1))

   (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (check-type x fixnum)
                    (1+ x))))
   (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (check-type x fixnum)
                    (1+ x))))

-  (assert (= count1 0)))
+  ;; Only the posssible word -> bignum conversion note
+  (assert (= count1 1)))

 
 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
 
 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.

@@ -2037,6 +2043,30 @@
       (compiler-note () (throw :note nil)))
     (error "Unreachable code undetected.")))
 
       (compiler-note () (throw :note nil)))
     (error "Unreachable code undetected.")))
 

+(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x y)
+                        (when (typep y 'fixnum)
+                          (when (eql x y)
+                            (unless (typep x 'fixnum)
+                              (error "This is unreachable"))
+                            (setq y nil)))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))
+
+(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x y)
+                        (when (typep y 'fixnum)
+                          (when (eql y x)
+                            (unless (typep x 'fixnum)
+                              (error "This is unreachable"))
+                            (setq y nil)))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))
+

 ;; Reported by John Wiseman, sbcl-devel
 ;; Subject: [Sbcl-devel] float type derivation bug?
 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
 ;; Reported by John Wiseman, sbcl-devel
 ;; Subject: [Sbcl-devel] float type derivation bug?
 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700

@@ -2126,3 +2156,62 @@
                    (map-into (make-array (list (length val))
                                          :element-type '(unsigned-byte 8))
                              #'char-code val)))))
                    (map-into (make-array (list (length val))
                                          :element-type '(unsigned-byte 8))
                              #'char-code val)))))

+
+;;; overconfident primitive type computation leading to bogus type
+;;; checking.
+(let* ((form1 '(lambda (x)
+                (declare (type (and condition function) x))
+                x))
+       (fun1 (compile nil form1))
+       (form2 '(lambda (x)
+                (declare (type (and standard-object function) x))
+                x))
+       (fun2 (compile nil form2)))
+  (assert (raises-error? (funcall fun1 (make-condition 'error))))
+  (assert (raises-error? (funcall fun1 fun1)))
+  (assert (raises-error? (funcall fun2 fun2)))
+  (assert (eq (funcall fun2 #'print-object) #'print-object)))
+
+;;; LET* + VALUES declaration: while the declaration is a non-standard
+;;; and possibly a non-conforming extension, as long as we do support
+;;; it, we might as well get it right.
+;;;
+;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
+(compile nil '(lambda () (let* () (declare (values list)))))
+
+
+;;; test for some problems with too large immediates in x86-64 modular
+;;; arithmetic vops
+(compile nil '(lambda (x) (declare (fixnum x))
+               (logand most-positive-fixnum (logxor x most-positive-fixnum))))
+
+(compile nil '(lambda (x) (declare (fixnum x))
+               (logand most-positive-fixnum (+ x most-positive-fixnum))))
+
+(compile nil '(lambda (x) (declare (fixnum x))
+               (logand most-positive-fixnum (* x most-positive-fixnum))))
+
+;;; bug 256.b
+(assert (let (warned-p)
+            (handler-bind ((warning (lambda (w) (setf warned-p t))))
+              (compile nil
+                         '(lambda (x)
+                           (list (let ((y (the real x)))
+                                   (unless (floatp y) (error ""))
+                                   y)
+                                 (integer-length x)))))
+            warned-p))
+
+;; Dead / in safe code
+(with-test (:name :safe-dead-/)
+  (assert (eq :error
+              (handler-case
+                  (funcall (compile nil
+                                    '(lambda (x y)
+                                      (declare (optimize (safety 3)))
+                                      (/ x y)
+                                      (+ x y)))
+                           1
+                           0)
+                (division-by-zero ()
+                  :error)))))