From 94015cb63196464f4993d195ba4da68c46f331ac Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Mon, 26 Nov 2018 03:05:22 +0000
Subject: [PATCH] Define flo:classify and flo:subnormal?.

---
 src/runtime/primitive-arithmetic.scm | 11 +++++++++++
 src/runtime/runtime.pkg              |  2 ++
 tests/runtime/test-arith.scm         | 23 +++++++++++++++++------
 3 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index af3b0f834..6d27646f0 100644
--- 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)))
 
 ;;;; Exact integers
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5476dd94b..bf4146471 100644
--- 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 0bce9039e..8c7fbbb75 100644
--- 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
-- 
2.25.1