extra/half-floats/half-floats.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors alien.c-types alien.syntax kernel math math.order
   3 specialized-arrays.functor ;
   4 IN: half-floats
   5
   6 : half>bits ( float -- bits )
   7     float>bits
   8     [ -31 shift 15 shift ] [
   9         HEX: 7fffffff bitand
  10         dup zero? [
  11             dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
  12                 -13 shift
  13                 112 10 shift -
  14                 0 HEX: 7c00 clamp
  15             ] if
  16         ] unless
  17     ] bi bitor ;
  18
  19 : bits>half ( bits -- float )
  20     [ -15 shift 31 shift ] [
  21         HEX: 7fff bitand
  22         dup zero? [
  23             dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
  24                 13 shift
  25                 112 23 shift +
  26             ] if
  27         ] unless
  28     ] bi bitor bits>float ;
  29
  30 C-STRUCT: half { "ushort" "(bits)" } ;
  31
  32 <<
  33
  34 "half" c-type
  35     [ half>bits <ushort> ] >>unboxer-quot
  36     [ *ushort bits>half ] >>boxer-quot
  37     drop
  38
  39 "half" define-array
  40
  41 >>