X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ffloat.impure.lisp;h=1cb8c222c12a11a8ad06497bb2dc20a16ac9af91;hb=40660c4081a57a91e3cc3648a5aad3d3a95db938;hp=04609a48cc23f429e17818fd3e902874f46fa90c;hpb=b3e3fbe7d381147fccc8a3027cb6fae923e57d13;p=sbcl.git

diff --git a/tests/float.impure.lisp b/tests/float.impure.lisp
index 04609a4..1cb8c22 100644
--- a/tests/float.impure.lisp
+++ b/tests/float.impure.lisp
@@ -119,3 +119,118 @@
 (defun new-pu-label-from-pu-labels (array)
   (setf (aref (the myarraytype array) 0)
         sb-ext:double-float-positive-infinity))
+
+;;; bug 407
+;;;
+;;; FIXME: it may be that TYPE-ERROR is wrong, and we should
+;;; instead signal an overflow or coerce into an infinity.
+(defun bug-407a ()
+  (loop for n from (expt 2 1024) upto (+ 10 (expt 2 1024))
+        do (handler-case
+               (coerce n 'single-float)
+             (simple-type-error ()
+               (return-from bug-407a :type-error)))))
+(assert (eq :type-error (bug-407a)))
+(defun bug-407b ()
+  (loop for n from (expt 2 1024) upto (+ 10 (expt 2 1024))
+        do (handler-case
+               (format t "~E~%" (coerce n 'single-float))
+             (simple-type-error ()
+               (return-from bug-407b :type-error)))))
+(assert (eq :type-error (bug-407b)))
+
+;; 1.0.29.44 introduces a ton of changes for complex floats
+;; on x86-64. Huge test of doom to help catch weird corner
+;; cases.
+;; Abuse the framework to also test some float arithmetic
+;; changes wrt constant arguments in 1.0.29.54.
+(defmacro def-compute (name real-type
+                       &optional (complex-type `(complex ,real-type)))
+  `(defun ,name (x y r)
+     (declare (type ,complex-type x y)
+              (type ,real-type r))
+     (flet ((reflections (x)
+              (values x
+                      (conjugate x)
+                      (complex (- (realpart x)) (imagpart x))
+                      (- x)))
+            (compute (x y r)
+              (declare (type ,complex-type x y)
+                       (type ,real-type r))
+              (list (1+ x) (* 2 x) (/ x 2) (= 1 x)
+                    (+ x y) (+ r x) (+ x r)
+                    (- x y) (- r x) (- x r)
+                    (* x y) (* x r) (* r x)
+                    (unless (zerop y)
+                      (/ x y))
+                    (unless (zerop r)
+                      (/ x r))
+                    (unless (zerop x)
+                      (/ r x))
+                    (conjugate x) (conjugate r)
+                    (abs r) (- r) (= 1 r)
+                    (- x) (1+ r) (* 2 r) (/ r 2)
+                    (complex r) (complex r r) (complex 0 r)
+                    (= x y) (= r x) (= y r) (= x (complex 0 r))
+                    (= r (realpart x)) (= (realpart x) r)
+                    (> r (realpart x)) (< r (realpart x))
+                    (> (realpart x) r) (< (realpart x) r)
+                    (eql x y) (eql x (complex r)) (eql y (complex r))
+                    (eql x (complex r r)) (eql y (complex 0 r))
+                    (eql r (realpart x)) (eql (realpart x) r))))
+       (declare (inline reflections))
+       (multiple-value-bind (x1 x2 x3 x4) (reflections x)
+         (multiple-value-bind (y1 y2 y3 y4) (reflections y)
+           #.(let ((form '(list)))
+               (dolist (x '(x1 x2 x3 x4) (reverse form))
+                 (dolist (y '(y1 y2 y3 y4))
+                   (push `(list ,x ,y r
+                                (append (compute ,x ,y r)
+                                        (compute ,x ,y (- r))))
+                         form)))))))))
+
+(def-compute compute-number real number)
+(def-compute compute-single single-float)
+(def-compute compute-double double-float)
+
+(labels ((equal-enough (x y)
+           (cond ((eql x y))
+                 ((or (complexp x)
+                      (complexp y))
+                  (or (eql (coerce x '(complex double-float))
+                           (coerce y '(complex double-float)))
+                      (and (equal-enough (realpart x) (realpart y))
+                           (equal-enough (imagpart x) (imagpart y)))))
+                 ((numberp x)
+                  (or (eql (coerce x 'double-float) (coerce y 'double-float))
+                      (< (abs (- x y))  1d-5))))))
+  (let* ((reals     '(0 1 2))
+         (complexes '#.(let ((reals '(0 1 2))
+                             (cpx   '()))
+                         (dolist (x reals (nreverse cpx))
+                           (dolist (y reals)
+                             (push (complex x y) cpx))))))
+    (declare (notinline every))
+    (dolist (r reals)
+      (dolist (x complexes)
+        (dolist (y complexes)
+          (let ((value  (compute-number x y r))
+                (single (compute-single (coerce x '(complex single-float))
+                                        (coerce y '(complex single-float))
+                                        (coerce r 'single-float)))
+                (double (compute-double (coerce x '(complex double-float))
+                                        (coerce y '(complex double-float))
+                                        (coerce r 'double-float))))
+            (assert (every (lambda (pos ref single double)
+                             (declare (ignorable pos))
+                             (every (lambda (ref single double)
+                                      (or (and (equal-enough ref single)
+                                               (equal-enough ref double))
+                                          (and (not (numberp single)) ;; -ve 0s
+                                               (equal-enough single double))))
+                                    (fourth ref) (fourth single) (fourth double)))
+                           '((0 0) (0 1) (0 2) (0 3)
+                             (1 0) (1 1) (1 2) (1 3)
+                             (2 0) (2 1) (2 2) (2 3)
+                             (3 0) (3 1) (3 2) (3 3))
+                           value single double))))))))