basis/math/floats/half/half.factor

   1 ! Copyright (C) 2009 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.accessors alien.c-types combinators
   4 kernel math ;
   5 FROM: math => float ;
   6 IN: math.floats.half
   7
   8 : half>bits ( float -- bits )
   9     float>bits
  10     [ -16 shift 0x8000 bitand ] keep
  11     [ 0x7fffff bitand ] keep
  12     -23 shift 0xff bitand 127 - {
  13         { [ dup -24 < ] [ 2drop 0 ] }
  14         { [ dup -14 < ] [ [ 1 + shift ] [ 24 + 2^ ] bi bitor ] }
  15         { [ dup 15 <= ] [ [ -13 shift ] [ 15 + 10 shift ] bi* bitor ] }
  16         { [ dup 128 < ] [ 2drop 0x7c00 ] }
  17         [ drop -13 shift 0x7c00 bitor ]
  18     } cond bitor ;
  19
  20 : bits>half ( bits -- float )
  21     [ -15 shift 31 shift ] [
  22         0x7fff bitand
  23         dup zero? [
  24             dup 0x7c00 >= [ 13 shift 0x7f800000 bitor ] [
  25                 dup 0x0400 < [
  26                     dup log2
  27                     [ nip 103 + 23 shift ]
  28                     [ 23 swap - shift 0x7fffff bitand ] 2bi bitor
  29                 ] [
  30                     13 shift
  31                     112 23 shift +
  32                 ] if
  33             ] if
  34         ] unless
  35     ] bi bitor bits>float ;
  36
  37 SYMBOL: half
  38
  39 <<
  40
  41 <c-type>
  42     float >>class
  43     float >>boxed-class
  44     [ alien-unsigned-2 bits>half ] >>getter
  45     [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
  46     2 >>size
  47     2 >>align
  48     2 >>align-first
  49     [ >float ] >>unboxer-quot
  50 \ half typedef
  51
  52 >>