From 809b80325ac5631b8434e25b355190aa1e01a52f Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 30 Nov 2018 18:31:20 +0000
Subject: [PATCH] New procedure (flo:logb x) gives the integer exponent of x.

---
 src/relnotes/flonum                  |  4 ++-
 src/runtime/primitive-arithmetic.scm |  5 ++++
 src/runtime/runtime.pkg              |  1 +
 tests/runtime/test-flonum.scm        | 43 ++++++++++++++++++++++++++++
 4 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/src/relnotes/flonum b/src/relnotes/flonum
index f6f1b8306..488c53e92 100644
--- a/src/relnotes/flonum
+++ b/src/relnotes/flonum
@@ -52,7 +52,9 @@ New flonum-related definitions:
 . flo:greatest-normal-exponent-base-10 - Greatest flonum input x for
   which (expt 10. x) gives a finite result.
 . (flo:ldexp x e) = x * 2^e
-. (flo:scalbn x e) = x * b^e, where b is flo:radix
+. (flo:scalbn x e) = x * b^e, where b is flo:radix and e is an integer
+. (flo:logb y) = e such that y = x * b^e for x = (flo:scalbn y (- e)),
+  and 1 <= x < b, and e is an integer
 . (flo:classify x) returns one of the symbols
   - zero
   - subnormal
diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index ed5448dfa..1de69f1c6 100644
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -413,6 +413,11 @@ USA.
 (define (flo:snan? nan)
   (and (flo:nan? nan)
        (not (flo:nan-quiet? nan))))
+
+(define (flo:logb x)
+  (if (and (flo:finite? x) (not (flo:safe-zero? x)))
+      (fix:- (cdr ((ucode-primitive flonum-normalize 1) x)) 1)
+      (begin (flo:raise-exceptions! (flo:exception:invalid-operation)) #f)))
 
 ;;;; Exact integers
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7c558c60b..e0cdfa61b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -330,6 +330,7 @@ USA.
 	  flo:lgamma
 	  flo:log
 	  flo:log1p
+	  flo:logb
 	  flo:make-nan
 	  flo:max
 	  flo:max-mag
diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 21b4fb94e..df5b7307e 100644
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -82,6 +82,17 @@ USA.
 (define assert-eqv-nan
   (simple-binary-assertion eqv-nan? #f))
 
+(define (assert-only-except/no-traps except procedure)
+  (assert-eqv
+   (flo:preserving-environment
+    (lambda ()
+      (flo:clear-exceptions! (flo:supported-exceptions))
+      (no-traps
+       (lambda ()
+         (procedure)
+         (flo:test-exceptions (flo:supported-exceptions))))))
+   except))
+
 (define (with-expected-failure xfail body)
   (if (default-object? xfail)
       (body)
@@ -1046,3 +1057,35 @@ USA.
         (assert-eqv (flo:total-mag< x y) (flo:total< (flo:abs x) (flo:abs y)))
         (assert-eqv (flo:total-order-mag x y)
                     (flo:total-order (flo:abs x) (flo:abs y))))))))
+
+(define-enumerated-test 'flo:logb/finite
+  `((1. 0)
+    (,flo:radix. 1)
+    (,(+ 1 flo:radix.) 1)
+    (,(expt flo:radix. 2) 2)
+    (,(+ 1 (expt flo:radix. 2)) 2)
+    (,flo:smallest-positive-subnormal ,flo:subnormal-exponent-min)
+    (,flo:smallest-positive-normal ,flo:normal-exponent-min)
+    (,flo:largest-positive-normal ,flo:normal-exponent-max))
+  (lambda (x l)
+    (assert-eqv (flo:logb x) l)
+    (assert->= (flo:scalbn x (- (flo:logb x))) 1)
+    (assert-< (flo:scalbn x (- (flo:logb x))) flo:radix)
+    (let ((y (flo:scalbn x (- (flo:logb x)))))
+      (assert-= (flo:scalbn y l) x))))
+
+(define-enumerated-test 'flo:logb/invalid
+  `((0.)
+    (+inf.0)
+    (,(flo:qnan))
+    (,(flo:snan)))
+  (lambda (x)
+    (assert-eqv (no-traps (lambda () (flo:logb x))) #f)
+    (assert-eqv (no-traps (lambda () (flo:logb (flo:negate x)))) #f)
+    (assert-error (lambda () (yes-traps (lambda () (flo:logb x)))))
+    (assert-error
+     (lambda () (yes-traps (lambda () (flo:logb (flo:negate x))))))
+    (assert-only-except/no-traps (flo:exception:invalid-operation)
+                                 (lambda () (flo:logb x)))
+    (assert-only-except/no-traps (flo:exception:invalid-operation)
+                                 (lambda () (flo:logb (flo:negate x))))))
-- 
2.25.1