basis/half-floats/half-floats.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors alien.accessors alien.c-types alien.data
   3 alien.syntax kernel math math.order ;
   4 FROM: math => float ;
   5 IN: half-floats
   6
   7 : half>bits ( float -- bits )
   8     float>bits
   9     [ -31 shift 15 shift ] [
  10         HEX: 7fffffff bitand
  11         dup zero? [
  12             dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
  13                 -13 shift
  14                 112 10 shift -
  15                 0 HEX: 7c00 clamp
  16             ] if
  17         ] unless
  18     ] bi bitor ;
  19
  20 : bits>half ( bits -- float )
  21     [ -15 shift 31 shift ] [
  22         HEX: 7fff bitand
  23         dup zero? [
  24             dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
  25                 13 shift
  26                 112 23 shift +
  27             ] if
  28         ] unless
  29     ] bi bitor bits>float ;
  30
  31 SYMBOL: half
  32
  33 <<
  34
  35 <c-type>
  36     float >>class
  37     float >>boxed-class
  38     [ alien-unsigned-2 bits>half ] >>getter
  39     [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
  40     2 >>size
  41     2 >>align
  42     2 >>align-first
  43     [ >float ] >>unboxer-quot
  44 \ half define-primitive-type
  45
  46 >>