X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Farith.pure.lisp;h=d257edca253595c0aae4d9bfa346af9e0ccaa52c;hb=69e6aef5e6fb3bd682c7a2cbf774034d2ea58ee8;hp=05a36ea9699e8de995939330f0993779ce24e149;hpb=cf99421496d43693774e361d33c7c7496a693d6c;p=sbcl.git

diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index 05a36ea..d257edc 100644
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -339,19 +339,27 @@
            (test-op (op)
              (let ((ub `(unsigned-byte ,sb-vm:n-word-bits))
                    (sb `(signed-byte ,sb-vm:n-word-bits)))
-               (loop for (x y type) in `((2 1 fixnum)
-                                         (2 1 ,ub)
-                                         (2 1 ,sb)
-                                         (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum)
-                                         (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub)
-                                         (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb)
-                                         ,@(when (> sb-vm:n-word-bits 32)
-                                             `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum)
-                                               (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub)
-                                               (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb)
-                                               (,(ash 1 40) ,(ash 1 39) fixnum)
-                                               (,(ash 1 40) ,(ash 1 39) ,ub)
-                                               (,(ash 1 40) ,(ash 1 39) ,sb))))
+               (loop for (x y type)
+                     in `((2 1 fixnum)
+                          (2 1 ,ub)
+                          (2 1 ,sb)
+                          (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum)
+                          (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub)
+                          (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb)
+                          ,@(when (> sb-vm:n-word-bits 32)
+                              `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum)
+                                (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub)
+                                (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb)
+                                (,(ash 1 40) ,(ash 1 39) fixnum)
+                                (,(ash 1 40) ,(ash 1 39) ,ub)
+                                (,(ash 1 40) ,(ash 1 39) ,sb)))
+                          ;; fixnums that can be represented as 32-bit
+                          ;; sign-extended immediates on x86-64
+                          ,@(when (and (> sb-vm:n-word-bits 32)
+                                       (< sb-vm:n-fixnum-tag-bits 3))
+                              `((,(1+ (ash 1 (- 31 sb-vm:n-fixnum-tag-bits)))
+                                 ,(1- (ash 1 (- 32 sb-vm:n-fixnum-tag-bits)))
+                                 fixnum))))
                      do
                   (test-case op x y type)
                   (test-case op x x type)))))
@@ -363,8 +371,12 @@
 ;; GCD used to sometimes return negative values. The following did, on 32 bit
 ;; builds.
 (with-test (:name :gcd)
+  ;; from lp#413680
   (assert (plusp (gcd 20286123923750474264166990598656
-                      680564733841876926926749214863536422912))))
+                      680564733841876926926749214863536422912)))
+  ;; from lp#516750
+  (assert (plusp (gcd 2596102012663483082521318626691873
+                      2596148429267413814265248164610048))))
 
 (with-test (:name :expt-zero-zero)
   ;; Check that (expt 0.0 0.0) and (expt 0 0.0) signal error, but (expt 0.0 0)
@@ -547,3 +559,98 @@
                             (declare (type (integer -3 57216651) a))
                             (ldb (byte 9 27) a)))))
     (assert (= 0 (- (funcall one 10) (funcall two 10))))))
+
+;; The ISQRT implementation is sufficiently complicated that it should
+;; be tested.
+(with-test (:name :isqrt)
+  (labels ((test (x)
+             (let* ((r (isqrt x))
+                    (r2 (expt r 2))
+                    (s2 (expt (1+ r) 2)))
+               (unless (and (<= r2 x)
+                            (> s2 x))
+                 (error "isqrt failure for ~a" x))))
+           (tests (x)
+             (test x)
+             (let ((x2 (expt x 2)))
+               (test x2)
+               (test (1+ x2))
+               (test (1- x2)))))
+    (test most-positive-fixnum)
+    (test (1+ most-positive-fixnum))
+    (loop for i from 1 to 200
+          for pow = (expt 2 (1- i))
+          for j = (+ pow (random pow))
+          do
+          (tests i)
+          (tests j))
+    (dotimes (i 10)
+      (tests (random (expt 2 (+ 1000 (random 10000))))))))
+
+;; bug 1026634 (reported by Eric Marsden on sbcl-devel)
+(with-test (:name :recursive-cut-to-width)
+  (assert (eql (funcall
+                (compile nil
+                         `(lambda (x)
+                            (declare (optimize (space 3))
+                                     (type (integer 12417236377505266230
+                                                    12417274239874990070) x))
+                            (logand 8459622733968096971 x)))
+                12417237222845306758)
+               2612793697039849090)))
+
+;; Also reported by Eric Marsden on sbcl-devel (2013-06-06)
+(with-test (:name :more-recursive-cut-to-width)
+  (assert (eql (funcall
+                (compile nil `(lambda (a b)
+                                (declare (optimize (speed 2) (safety 0)))
+                                (logand (the (eql 16779072918521075607) a)
+                                        (the (integer 21371810342718833225 21371810343571293860) b))))
+                16779072918521075607 21371810342718833263)
+               2923729245085762055)))
+
+(with-test (:name :complicated-logand-identity)
+  (loop for k from -8 upto 8 do
+    (loop for min from -16 upto 16 do
+      (loop for max from min upto 16 do
+        (let ((f (compile nil `(lambda (x)
+                                 (declare (type (integer ,min ,max) x))
+                                 (logand x ,k)))))
+          (loop for x from min upto max do
+            (assert (eql (logand x k) (funcall f x)))))))))
+
+(with-test (:name :complicated-logior-identity)
+  (loop for k from -8 upto 8 do
+    (loop for min from -16 upto 16 do
+      (loop for max from min upto 16 do
+        (let ((f (compile nil `(lambda (x)
+                                 (declare (type (integer ,min ,max) x))
+                                 (logior x ,k)))))
+          (loop for x from min upto max do
+            (assert (eql (logior x k) (funcall f x)))))))))
+
+(with-test (:name :ldb-negative-index-no-error)
+  (assert
+   (raises-error?
+    (funcall (compile nil
+                      `(lambda (x y)
+                         (ldb (byte x y) 100)))
+             -1 -2)))
+  (assert
+   (raises-error?
+    (funcall (compile nil
+                      `(lambda (x y)
+                         (mask-field (byte x y) 100)))
+             -1 -2)))
+  (assert
+   (raises-error?
+    (funcall (compile nil
+                      `(lambda (x y)
+                         (dpb 0 (byte x y) 100)))
+             -1 -2)))
+  (assert
+   (raises-error?
+    (funcall (compile nil
+                      `(lambda (x y)
+                         (deposit-field 0 (byte x y) 100)))
+             -1 -2))))