New procedure (flo:logb x) gives the integer exponent of x.

diff --git a/src/relnotes/flonum b/src/relnotes/flonum
index f6f1b830676110dd881dc9cf9f27ede1da2aa116..488c53e925d771cacdba9fe1cdc6d0fccff937af 100644 (file)
--- 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 ed5448dfa14022569c66dae10f17a618fc723599..1de69f1c6ceeb9d800ba17c3d037c9d941e3476b 100644 (file)
--- 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)))
 \f
 ;;;; Exact integers
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7c558c60b47e3658381f1a29d943e0c6efed1310..e0cdfa61bb270010b00580b0db9893af7a2f1909 100644 (file)
--- 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 21b4fb94e7d31bc83c1d546ae311ba2bbe9fcad0..df5b7307e380748e2e3880ff4e5b6753424631ae 100644 (file)
--- 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))))))