Flonum operations always return flonums.

Fixes <http://bugs.gnu.org/14871>.
Reported by Göran Weinholt <goran@weinholt.se>.

* module/rnrs/arithmetic/flonums.scm (ensure-flonum): New procedure.
  (fllog): Rewrite using case-lambda.  Handle negative zeroes.  Use
  'ensure-flonum'.
  (flatan): Rewrite using case-lambda.
  (flasin, flacos, flsqrt, flexpt): Use 'ensure-flonum'.

* test-suite/tests/r6rs-arithmetic-flonums.test
  (fllog, flasin, flacos, flsqrt, flexpt): Add tests.

module/rnrs/arithmetic/flonums.scm

@@ -61,6 +61,7 @@
 	  (only (guile) inf?)
 	  (rnrs arithmetic fixnums (6))
 	  (rnrs base (6))
+	  (rnrs control (6))
 	  (rnrs conditions (6))
 	  (rnrs exceptions (6))
 	  (rnrs lists (6))
@@ -73,6 +74,11 @@
     (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
 	(raise (make-assertion-violation))))
 
+  (define (ensure-flonum z)
+    (cond ((real? z) z)
+          ((zero? (imag-part z)) (real-part z))
+          (else +nan.0)))
+
   (define (real->flonum x) 
     (or (real? x) (raise (make-assertion-violation)))
     (exact->inexact x))
@@ -167,23 +173,30 @@
   (define (flround fl) (assert-flonum fl) (round fl))
 
   (define (flexp fl) (assert-flonum fl) (exp fl))
-  (define* (fllog fl #:optional fl2)
-    (assert-flonum fl)
-    (cond ((fl=? fl -inf.0) +nan.0)
-	  (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2))))
-	  (else (log fl))))
+  (define fllog
+    (case-lambda
+      ((fl)
+       (assert-flonum fl)
+       ;; add 0.0 to fl, to change -0.0 to 0.0,
+       ;; so that (fllog -0.0) will be -inf.0, not -inf.0+pi*i.
+       (ensure-flonum (log (+ fl 0.0))))
+      ((fl fl2)
+       (assert-flonum fl fl2)
+       (ensure-flonum (/ (log (+ fl 0.0))
+                         (log (+ fl2 0.0)))))))
 
   (define (flsin fl) (assert-flonum fl) (sin fl))
   (define (flcos fl) (assert-flonum fl) (cos fl))
   (define (fltan fl) (assert-flonum fl) (tan fl))
-  (define (flasin fl) (assert-flonum fl) (asin fl))
-  (define (flacos fl) (assert-flonum fl) (acos fl))
-  (define* (flatan fl #:optional fl2)
-    (assert-flonum fl)
-    (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl)))
+  (define (flasin fl) (assert-flonum fl) (ensure-flonum (asin fl)))
+  (define (flacos fl) (assert-flonum fl) (ensure-flonum (acos fl)))
+  (define flatan
+    (case-lambda
+      ((fl) (assert-flonum fl) (atan fl))
+      ((fl fl2) (assert-flonum fl fl2) (atan fl fl2))))
 
-  (define (flsqrt fl) (assert-flonum fl) (sqrt fl))
-  (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2))
+  (define (flsqrt fl) (assert-flonum fl) (ensure-flonum (sqrt fl)))
+  (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (ensure-flonum (expt fl1 fl2)))
 
   (define-condition-type &no-infinities
     &implementation-restriction

test-suite/tests/r6rs-arithmetic-flonums.test

@@ -256,14 +256,18 @@
 
 (with-test-prefix "fllog"
   (pass-if "unary fllog returns natural log"
-    (let ((l (fllog 2.718281828459045)))
-      (and (fl<=? 0.9 l) (fl>=? 1.1 l))))
+    (reasonably-close? (fllog 2.718281828459045) 1.0))
   
   (pass-if "infinities"
     (and (fl=? (fllog +inf.0) +inf.0)
 	 (flnan? (fllog -inf.0))))
 
-  (pass-if "zeroes" (fl=? (fllog 0.0) -inf.0))
+  (pass-if "negative argument"
+    (flnan? (fllog -1.0)))
+
+  (pass-if "zero" (fl=? (fllog 0.0) -inf.0))
+  (pass-if "negative zero" (fl=? (fllog -0.0) -inf.0))
+  (pass-if "negative zero with base" (fl=? (fllog -0.0 0.5) +inf.0))
 
   (pass-if "binary fllog returns log in specified base"
     (fl=? (fllog 8.0 2.0) 3.0)))
@@ -285,12 +289,16 @@
 (with-test-prefix "flasin" 
   (pass-if "simple"
     (and (reasonably-close? (flasin 1.0) (/ fake-pi 2))
-	 (reasonably-close? (flasin 0.5) (/ fake-pi 6)))))
+	 (reasonably-close? (flasin 0.5) (/ fake-pi 6))))
+  (pass-if "out of range"
+    (flnan? (flasin 2.0))))
 
 (with-test-prefix "flacos" 
   (pass-if "simple"
     (and (fl=? (flacos 1.0) 0.0)
-	 (reasonably-close? (flacos 0.5) (/ fake-pi 3)))))
+	 (reasonably-close? (flacos 0.5) (/ fake-pi 3))))
+  (pass-if "out of range"
+    (flnan? (flacos 2.0))))
 
 (with-test-prefix "flatan"
   (pass-if "unary flatan"
@@ -306,12 +314,15 @@
 
 (with-test-prefix "flsqrt"
   (pass-if "simple" (fl=? (flsqrt 4.0) 2.0))
-
+  (pass-if "negative" (flnan? (flsqrt -1.0)))
   (pass-if "infinity" (fl=? (flsqrt +inf.0) +inf.0))
-
   (pass-if "negative zero" (fl=? (flsqrt -0.0) -0.0)))
 
-(with-test-prefix "flexpt" (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0)))
+(with-test-prefix "flexpt"
+  (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0))
+  (pass-if "negative squared" (fl=? (flexpt -2.0 2.0) 4.0))
+  (pass-if "negative cubed" (fl=? (flexpt -2.0 3.0) -8.0))
+  (pass-if "negative to non-integer power" (flnan? (flexpt -2.0 2.5))))
 
 (with-test-prefix "fixnum->flonum"
   (pass-if "simple" (fl=? (fixnum->flonum 100) 100.0)))