math.floats.half: improve the roundtrip of subnormal float16.

basis/math/floats/half/half-tests.factor

@@ -1,5 +1,6 @@
-USING: accessors alien.c-types alien.syntax math.floats.half kernel
-math tools.test specialized-arrays alien.data classes.struct ;
+USING: accessors alien.c-types alien.data classes.struct kernel
+math math.floats.half math.order sequences specialized-arrays
+tools.test ;
 SPECIALIZED-ARRAY: half
 IN: math.floats.half.tests
 
@@ -46,3 +47,12 @@ STRUCT: halves
 
 { half-array{ 1.0 2.0 3.0 1/0. -1/0. } }
 [ { 1.0 2.0 3.0 1/0. -1/0. } half >c-array ] unit-test
+
+{ 0x1.0p-24 } [ 1 bits>half ] unit-test
+
+{ t } [
+    65536 <iota>
+    [ 0x7c01 0x7dff between? ] reject
+    [ 0xfc01 0xfdff between? ] reject
+    [ dup bits>half half>bits = ] all?
+] unit-test

basis/math/floats/half/half.factor

@@ -1,31 +1,36 @@
 ! Copyright (C) 2009 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.accessors alien.c-types alien.data
-alien.syntax kernel math math.order ;
+USING: accessors alien.accessors alien.c-types combinators
+kernel math ;
 FROM: math => float ;
 IN: math.floats.half
 
 : half>bits ( float -- bits )
     float>bits
-    [ -31 shift 15 shift ] [
-        0x7fffffff bitand
-        dup zero? [
-            dup 0x7f800000 >= [ -13 shift 0x7fff bitand ] [
-                -13 shift
-                112 10 shift -
-                0 0x7c00 clamp
-            ] if
-        ] unless
-    ] bi bitor ;
+    [ -16 shift 0x8000 bitand ] keep
+    [ 0x7fffff bitand ] keep
+    -23 shift 0xff bitand 127 - {
+        { [ dup -24 < ] [ 2drop 0 ] }
+        { [ dup -14 < ] [ [ 1 + shift ] [ 24 + 2^ ] bi bitor ] }
+        { [ dup 15 <= ] [ [ -13 shift ] [ 15 + 10 shift ] bi* bitor ] }
+        { [ dup 128 < ] [ 2drop 0x7c00 ] }
+        [ drop -13 shift 0x7c00 bitor ]
+    } cond bitor ;
 
 : bits>half ( bits -- float )
     [ -15 shift 31 shift ] [
         0x7fff bitand
         dup zero? [
             dup 0x7c00 >= [ 13 shift 0x7f800000 bitor ] [
+                dup 0x0400 < [
+                    dup log2
+                    [ nip 103 + 23 shift ]
+                    [ 23 swap - shift 0x7fffff bitand ] 2bi bitor
+                ] [
                     13 shift
                     112 23 shift +
                 ] if
+            ] if
         ] unless
     ] bi bitor bits>float ;