53 lines
1.4 KiB
Factor
53 lines
1.4 KiB
Factor
! Copyright (C) 2009 Joe Groff.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors alien.accessors alien.c-types combinators
|
|
kernel math ;
|
|
FROM: math => float ;
|
|
IN: math.floats.half
|
|
|
|
: half>bits ( float -- bits )
|
|
float>bits
|
|
[ -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 ;
|
|
|
|
SYMBOL: half
|
|
|
|
<<
|
|
|
|
<c-type>
|
|
float >>class
|
|
float >>boxed-class
|
|
[ alien-unsigned-2 bits>half ] >>getter
|
|
[ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
|
|
2 >>size
|
|
2 >>align
|
|
2 >>align-first
|
|
[ >float ] >>unboxer-quot
|
|
\ half typedef
|
|
|
|
>>
|