basis/math/vectors/conversion/conversion.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien.c-types arrays assocs classes combinators
   3 combinators.short-circuit cords fry kernel locals math
   4 math.vectors math.vectors.conversion.backend sequences ;
   5 FROM: alien.c-types => char uchar short ushort int uint longlong ulonglong float double ;
   6 IN: math.vectors.conversion
   7
   8 ERROR: bad-vconvert from-type to-type ;
   9 ERROR: bad-vconvert-input value expected-type ;
  10
  11 <PRIVATE
  12
  13 : float-type? ( c-type -- ? )
  14     { float double } member-eq? ;
  15 : unsigned-type? ( c-type -- ? )
  16     { uchar ushort uint ulonglong } member-eq? ;
  17
  18 : check-vconvert-type ( value expected-type -- value )
  19     2dup instance? [ drop ] [ bad-vconvert-input ] if ; inline
  20
  21 :: [vconvert] ( from-element to-element from-size to-size from-type to-type -- quot )
  22     {
  23         {
  24             [ from-element to-element eq? ]
  25             [ [ ] ]
  26         }
  27         {
  28             [ from-element to-element [ float-type? not ] both? ]
  29             [ [ underlying>> to-type boa ] ]
  30         }
  31         {
  32             [ from-element float-type? ]
  33             [ [ to-type (v>integer) ] ]
  34         }
  35         {
  36             [ to-element   float-type? ]
  37             [ [ to-type (v>float)   ] ]
  38         }
  39     } cond
  40     [ from-type check-vconvert-type ] prepose ;
  41
  42 :: check-vpack ( from-element to-element from-type to-type steps -- )
  43     {
  44         [ steps 1 = not ]
  45         [ from-element to-element [ float-type? ] bi@ xor ]
  46         [ from-element unsigned-type? to-element unsigned-type? not and ]
  47     } 0|| [ from-type to-type bad-vconvert ] when ;
  48
  49 :: [[vpack-unsigned]] ( from-type to-type -- quot )
  50     [ [ from-type check-vconvert-type ] bi@ to-type (vpack-unsigned) ] ;
  51
  52 :: [[vpack-signed]] ( from-type to-type -- quot )
  53     [ [ from-type check-vconvert-type ] bi@ to-type (vpack-signed) ] ;
  54
  55 :: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot )
  56     from-size to-size /i log2 :> steps
  57
  58     from-element to-element from-type to-type steps check-vpack
  59
  60     from-type to-type to-element unsigned-type?
  61     [ [[vpack-unsigned]] ] [ [[vpack-signed]] ] if ;
  62
  63 :: check-vunpack ( from-element to-element from-type to-type steps -- )
  64     {
  65         [ steps 1 = not ]
  66         [ from-element to-element [ float-type? ] bi@ xor ]
  67         [ from-element unsigned-type? not to-element unsigned-type? and ]
  68     } 0|| [ from-type to-type bad-vconvert ] when ;
  69
  70 :: [[vunpack]] ( from-type to-type -- quot )
  71     [
  72         from-type check-vconvert-type
  73         [ to-type (vunpack-head) ] [ to-type (vunpack-tail) ] bi
  74     ] ;
  75
  76 :: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
  77     to-size from-size /i log2 :> steps
  78     from-element to-element from-type to-type steps check-vunpack
  79     from-type to-type [[vunpack]] ;
  80
  81 PRIVATE>
  82
  83 MACRO:: vconvert ( from-type to-type -- )
  84     from-type new [ element-type ] [ byte-length ] bi :> ( from-element from-length )
  85     to-type   new [ element-type ] [ byte-length ] bi :> ( to-element   to-length   )
  86     from-element heap-size :> from-size
  87     to-element   heap-size :> to-size
  88
  89     from-length to-length = [ from-type to-type bad-vconvert ] unless
  90
  91     from-element to-element from-size to-size from-type to-type {
  92         { [ from-size to-size < ] [ [vunpack] ] }
  93         { [ from-size to-size = ] [ [vconvert] ] }
  94         { [ from-size to-size > ] [ [vpack] ] }
  95     } cond ;
  96