X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ffloat.pure.lisp;h=5612a73fbcbb99ab070931236babd78825e7c247;hb=d7875c296a4988e9f27e2776237884deb1984c62;hp=289360f6eb07618dc3807fd772efe2a7e4ecbce7;hpb=cb427254703b615dc5d1e46a3dd8db7a8a9e6d55;p=sbcl.git diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index 289360f..5612a73 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -93,7 +93,7 @@ (assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum)))) (with-test (:name (:scale-float-overflow :bug-372) - :fails-on :darwin) ;; bug 372 + :fails-on '(and :darwin :ppc)) ;; bug 372 (progn (assert (raises-error? (scale-float 1.0 most-positive-fixnum) floating-point-overflow)) @@ -125,7 +125,31 @@ (funcall (compile nil '(lambda () (tan (tan (round 0)))))) (with-test (:name (:addition-overflow :bug-372) - :fails-on '(or (and :ppc :openbsd) :darwin (and :x86 :netbsd))) + :fails-on '(or (and :ppc :openbsd) + (and :ppc :darwin) + (and :x86 :netbsd))) + (assert (typep (nth-value + 1 + (ignore-errors + (sb-sys:without-interrupts + (sb-int:set-floating-point-modes :current-exceptions nil + :accrued-exceptions nil) + (loop repeat 2 summing most-positive-double-float) + (sleep 2)))) + 'floating-point-overflow))) + +;; This is the same test as above. Even if the above copy passes, +;; this copy will fail if SIGFPE handling ends up clearing the FPU +;; control word, which can happen if the kernel clears the FPU control +;; (a reasonable thing for it to do) and the runtime fails to +;; compensate for this (see RESTORE_FP_CONTROL_WORD in interrupt.c). +;; Note that this only works when running float.pure.lisp alone, as +;; the preceeding "pure" test files aren't as free of side effects as +;; we might like. +(with-test (:name (:addition-overflow :bug-372 :take-2) + :fails-on '(or (and :ppc :openbsd) + (and :ppc :darwin) + (and :x86 :netbsd))) (assert (typep (nth-value 1 (ignore-errors @@ -245,32 +269,6 @@ (the (eql #c(1.0 2.0)) x)))))))) -;; The x86 port used not to reduce the arguments of transcendentals -;; correctly. On other platforms, we trust libm to DTRT. -#+x86 -(with-test (:name :range-reduction) - (flet ((almost= (x y) - (< (abs (- x y)) 1d-5))) - (macrolet ((foo (op value) - `(assert (almost= (,op (mod ,value (* 2 pi))) - (,op ,value))))) - (let ((big (* pi (expt 2d0 70))) - (mid (coerce most-positive-fixnum 'double-float)) - (odd (* pi most-positive-fixnum))) - (foo sin big) - (foo sin mid) - (foo sin odd) - (foo sin (/ odd 2d0)) - - (foo cos big) - (foo cos mid) - (foo cos odd) - (foo cos (/ odd 2d0)) - - (foo tan big) - (foo tan mid) - (foo tan odd))))) - ;; Leakage from the host could result in wrong values for truncation. (with-test (:name :truncate) (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 33)))) @@ -288,10 +286,17 @@ ;; The tests are extremely brittle and could be broken by any number of ;; back- or front-end optimisations. We should just keep the issue above ;; in mind at all times when working with SSE or similar instruction sets. -#+(or x86 x86-64) ;; No other platforms have SB-VM::TOUCH-OBJECT. +;; +;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT. (macrolet ((with-pinned-floats ((count type &rest names) &body body) "Force COUNT float values to be kept live (and hopefully in registers), fill a temporary register with noise, and execute BODY." + ;; KLUDGE: SB-VM is locked, and non-x86oids don't have + ;; SB-VM::TOUCH-OBJECT. Don't even READ this body on + ;; other platforms. + #-(or x86 x86-64) + (declare (ignore count type names body)) + #+(or x86 x86-64) (let ((dummy (loop repeat count collect (or (pop names) (gensym "TEMP"))))) @@ -313,7 +318,7 @@ (locally ,@body)) ,@(loop for var in dummy collect `(sb-vm::touch-object ,var))))))) - (with-test (:name :clear-sqrtsd) + (with-test (:name :clear-sqrtsd :skipped-on '(not (or :x86 :x86-64))) (flet ((test-sqrtsd (float) (declare (optimize speed (safety 1)) (type (double-float (0d0)) float)) @@ -323,7 +328,7 @@ (declare (notinline test-sqrtsd)) (assert (zerop (imagpart (test-sqrtsd 4d0)))))) - (with-test (:name :clear-sqrtsd-single) + (with-test (:name :clear-sqrtsd-single :skipped-on '(not (or :x86 :x86-64))) (flet ((test-sqrtsd-float (float) (declare (optimize speed (safety 1)) (type (single-float (0f0)) float)) @@ -333,7 +338,7 @@ (declare (notinline test-sqrtsd-float)) (assert (zerop (imagpart (test-sqrtsd-float 4f0)))))) - (with-test (:name :clear-cvtss2sd) + (with-test (:name :clear-cvtss2sd :skipped-on '(not (or :x86 :x86-64))) (flet ((test-cvtss2sd (float) (declare (optimize speed (safety 1)) (type single-float float)) @@ -343,7 +348,7 @@ (declare (notinline test-cvtss2sd)) (assert (zerop (imagpart (test-cvtss2sd 1f0)))))) - (with-test (:name :clear-cvtsd2ss) + (with-test (:name :clear-cvtsd2ss :skipped-on '(not (or :x86 :x86-64))) (flet ((test-cvtsd2ss (float) (declare (optimize speed (safety 1)) (type double-float float)) @@ -353,7 +358,7 @@ (declare (notinline test-cvtsd2ss)) (assert (zerop (imagpart (test-cvtsd2ss 4d0)))))) - (with-test (:name :clear-cvtsi2sd) + (with-test (:name :clear-cvtsi2sd :skipped-on '(not (or :x86 :x86-64))) (flet ((test-cvtsi2sd (int) (declare (optimize speed (safety 0)) (type (unsigned-byte 10) int)) @@ -362,7 +367,7 @@ (declare (notinline test-cvtsi2sd)) (assert (zerop (imagpart (test-cvtsi2sd 4)))))) - (with-test (:name :clear-cvtsi2ss) + (with-test (:name :clear-cvtsi2ss :skipped-on '(not (or :x86 :x86-64))) (flet ((test-cvtsi2ss (int) (declare (optimize speed (safety 0)) (type (unsigned-byte 10) int)) @@ -370,3 +375,19 @@ (+ (float int 0e0) x0)))) (declare (notinline test-cvtsi2ss)) (assert (zerop (imagpart (test-cvtsi2ss 4))))))) + +(with-test (:name :round-to-bignum) + (assert (= (round 1073741822.3d0) 1073741822)) + (assert (= (round 1073741822.5d0) 1073741822)) + (assert (= (round 1073741822.7d0) 1073741823)) + (assert (= (round 1073741823.3d0) 1073741823)) + (assert (= (round 1073741823.5d0) 1073741824)) + (assert (= (round 1073741823.7d0) 1073741824))) + +(with-test (:name :round-single-to-bignum) + (assert (= (round 1e14) 100000000376832)) + (assert (= (round 1e19) 9999999980506447872))) + +(with-test (:name :scaled-%hypot) + (assert (<= (abs (complex most-positive-double-float 1d0)) + (1+ most-positive-double-float))))