basis/alien/data/data.factor

   1 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.strings arrays
   3 byte-arrays cpu.architecture fry io io.encodings.binary
   4 io.files io.streams.memory kernel libc math sequences words
   5 byte-vectors ;
   6 IN: alien.data
   7
   8 GENERIC: require-c-array ( c-type -- )
   9
  10 M: array require-c-array first require-c-array ;
  11
  12 GENERIC: c-array-constructor ( c-type -- word ) foldable
  13
  14 GENERIC: c-(array)-constructor ( c-type -- word ) foldable
  15
  16 GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
  17
  18 GENERIC: <c-array> ( len c-type -- array )
  19
  20 M: word <c-array>
  21     c-array-constructor execute( len -- array ) ; inline
  22
  23 GENERIC: (c-array) ( len c-type -- array )
  24
  25 M: word (c-array)
  26     c-(array)-constructor execute( len -- array ) ; inline
  27
  28 GENERIC: <c-direct-array> ( alien len c-type -- array )
  29
  30 M: word <c-direct-array>
  31     c-direct-array-constructor execute( alien len -- array ) ; inline
  32
  33 : malloc-array ( n type -- array )
  34     [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
  35
  36 : (malloc-array) ( n type -- alien )
  37     [ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
  38
  39 : <c-object> ( type -- array )
  40     heap-size <byte-array> ; inline
  41
  42 : (c-object) ( type -- array )
  43     heap-size (byte-array) ; inline
  44
  45 : malloc-object ( type -- alien )
  46     1 swap heap-size calloc ; inline
  47
  48 : (malloc-object) ( type -- alien )
  49     heap-size malloc ; inline
  50
  51 : malloc-byte-array ( byte-array -- alien )
  52     binary-object [ nip malloc dup ] 2keep memcpy ;
  53
  54 : memory>byte-array ( alien len -- byte-array )
  55     [ nip (byte-array) dup ] 2keep memcpy ;
  56
  57 : malloc-string ( string encoding -- alien )
  58     string>alien malloc-byte-array ;
  59
  60 M: memory-stream stream-read
  61     [
  62         [ index>> ] [ alien>> ] bi <displaced-alien>
  63         swap memory>byte-array
  64     ] [ [ + ] change-index drop ] 2bi ;
  65
  66 M: byte-vector stream-write
  67     [ dup byte-length tail-slice ]
  68     [ [ [ byte-length ] bi@ + ] keep lengthen ]
  69     [ drop byte-length ]
  70     2tri
  71     [ >c-ptr swap >c-ptr ] dip memcpy ;
  72
  73 M: value-type c-type-rep drop int-rep ;
  74
  75 M: value-type c-type-getter
  76     drop [ swap <displaced-alien> ] ;
  77
  78 M: value-type c-type-setter ( type -- quot )
  79     [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
  80     '[ @ swap @ _ memcpy ] ;