extra/alien/data/map/map.factor

   1 ! (c)Joe Groff bsd license
   2 USING: alien alien.c-types alien.data alien.parser arrays
   3 byte-arrays fry generalizations kernel lexer locals macros math
   4 math.ranges parser sequences sequences.private ;
   5 IN: alien.data.map
   6
   7 ERROR: bad-data-map-input-length byte-length iter-size remainder ;
   8
   9 <PRIVATE
  10
  11 : even-/i ( d d -- q )
  12     2dup [ >fixnum ] bi@ /mod
  13     [ 2nip ]
  14     [ bad-data-map-input-length ] if-zero ; inline
  15
  16 :: data-map-length ( array type count -- byte-length iter-size iter-count )
  17     array byte-length >fixnum
  18     type heap-size count *
  19     2dup even-/i ; inline
  20
  21 : <displaced-direct-array> ( byte-array displacement length type -- direct-array )
  22     [ swap <displaced-alien> ] 2dip <c-direct-array> ; inline
  23
  24 :: data-map-loop ( input loop-quot out-bytes-quot in-type in-count out-type out-count -- out-bytes )
  25     input in-type in-count data-map-length
  26         :> iter-count :> in-size :> in-byte-length
  27     input >c-ptr :> in-bytes
  28
  29     out-count out-type heap-size * :> out-size
  30     out-size iter-count * :> out-byte-length
  31     out-byte-length out-bytes-quot call :> out-bytes
  32
  33     0 in-byte-length 1 - >fixnum in-size >fixnum <range>
  34     0 out-byte-length 1 - >fixnum out-size >fixnum <range>
  35     [| in-base out-base |
  36         in-bytes in-base in-count in-type <displaced-direct-array>
  37         in-count firstn-unsafe
  38         loop-quot call
  39         out-bytes out-base out-count out-type <displaced-direct-array>
  40         out-count set-firstn-unsafe
  41     ] 2each
  42     out-bytes ; inline
  43
  44 PRIVATE>
  45
  46 MACRO: data-map ( in-type in-count out-type out-count -- )
  47     '[ [ (byte-array) ] _ _ _ _ data-map-loop ] ;
  48
  49 MACRO: data-map! ( in-type in-count out-type out-count -- )
  50     '[ swap [ [ nip >c-ptr ] curry _ _ _ _ data-map-loop drop ] keep ] ;
  51
  52 <PRIVATE
  53
  54 : c-type-parsed ( accum c-type -- accum )
  55     dup array? [ unclip swap product ] [ 1 ] if
  56     [ parsed ] bi@ ;
  57
  58 PRIVATE>
  59
  60 SYNTAX: data-map(
  61     scan-c-type c-type-parsed
  62     "--" expect scan-c-type c-type-parsed ")" expect
  63     \ data-map parsed ;
  64
  65 SYNTAX: data-map!(
  66     scan-c-type c-type-parsed
  67     "--" expect scan-c-type c-type-parsed ")" expect
  68     \ data-map! parsed ;
  69