-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
{ 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
! 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 ] [
- 13 shift
- 112 23 shift +
+ 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 ;