Define flo:classify and flo:subnormal?.

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index af3b0f8341f6a8dcfdc11e07eb6d063921978359..6d27646f0e80f8768226a1e8b76b24bdcbdf2e9a 100644 (file)
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -267,6 +267,17 @@ USA.
 (define (->flonum x)
   (guarantee real? x '->flonum)
   (exact->inexact (real-part x)))
+
+(define (flo:subnormal? x)
+  (and (flo:finite? x)
+       (not (or (flo:zero? x)
+               (flo:normal? x)))))
+
+(define (flo:classify x)
+  (cond ((not (flo:finite? x)) (if (flo:infinite? x) 'infinite 'nan))
+       ((flo:zero? x) 'zero)
+       ((flo:normal? x) 'normal)
+       (else 'subnormal)))
 \f
 ;;;; Exact integers
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5476dd94b5568995b4a183ae19c4ec0212afc25c..bf4146471f5cded480b0bb08407317b857b9acc0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -306,6 +306,7 @@ USA.
          flo:cbrt
          flo:ceiling
          flo:ceiling->exact
+         flo:classify
          flo:copysign
          flo:cos
          flo:cosh
@@ -348,6 +349,7 @@ USA.
          flo:sin
          flo:sinh
          flo:sqrt
+         flo:subnormal?
          flo:tan
          flo:tanh
          flo:truncate

diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index 0bce9039e6b48b3e6bf5e960e54232414cdb3f3c..8c7fbbb75ffb9ee32b68780a2b98ee80b2ee15eb 100644 (file)
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -71,11 +71,6 @@ USA.
 (define assert-normal
   (predicate-assertion flo:normal? "normal floating-point number"))
 
-(define (flo:subnormal? x)
-  (and (flo:finite? x)
-       (not (flo:zero? x))
-       (not (flo:normal? x))))
-
 (define assert-subnormal
   (predicate-assertion flo:subnormal? "subnormal floating-point number"))
 
@@ -785,4 +780,20 @@ USA.
   (lambda (v)
     (let ((z (vector-ref v 0))
           (t (vector-ref v 1)))
-      (assert-<= (relerr t (angle z)) 1e-15))))
\ No newline at end of file
+      (assert-<= (relerr t (angle z)) 1e-15))))
+
+(define-enumerated-test 'flo:classify
+  `#((0. zero)
+     (-0. zero)
+     (,(flo:nextafter 0. 1.) subnormal)
+     (,flo:smallest-positive-subnormal subnormal)
+     (,flo:smallest-positive-normal normal)
+     (1. normal)
+     (+inf.0 infinite)
+     (-inf.0 infinite)
+     (+nan.0 nan)
+     (-nan.0 nan))
+  (lambda (l)
+    (let ((x (car l))
+          (c (cadr l)))
+      (assert-eq (flo:classify x) c))))
\ No newline at end of file