basis/alien/data/data.factor

   1 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.arrays alien.strings
   3 arrays byte-arrays cpu.architecture fry io io.encodings.binary
   4 io.files io.streams.memory kernel libc math math.functions
   5 sequences words macros combinators generalizations
   6 stack-checker.dependencies combinators.short-circuit ;
   7 QUALIFIED: math
   8 IN: alien.data
   9
  10 : <ref> ( value c-type -- c-ptr )
  11     [ heap-size <byte-array> ] keep
  12     '[ 0 _ set-alien-value ] keep ; inline
  13
  14 : deref ( c-ptr c-type -- value )
  15     [ 0 ] dip alien-value ; inline
  16
  17 : little-endian? ( -- ? ) 1 int <ref> char deref 1 = ; foldable
  18
  19 GENERIC: require-c-array ( c-type -- )
  20
  21 M: array require-c-array first require-c-array ;
  22
  23 GENERIC: c-array-constructor ( c-type -- word ) foldable
  24
  25 GENERIC: c-(array)-constructor ( c-type -- word ) foldable
  26
  27 GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
  28
  29 GENERIC: <c-array> ( len c-type -- array )
  30
  31 M: word <c-array>
  32     c-array-constructor execute( len -- array ) ; inline
  33
  34 M: pointer <c-array>
  35     drop void* <c-array> ;
  36
  37 GENERIC: (c-array) ( len c-type -- array )
  38
  39 M: word (c-array)
  40     c-(array)-constructor execute( len -- array ) ; inline
  41
  42 M: pointer (c-array)
  43     drop void* (c-array) ;
  44
  45 GENERIC: <c-direct-array> ( alien len c-type -- array )
  46
  47 M: word <c-direct-array>
  48     c-direct-array-constructor execute( alien len -- array ) ; inline
  49
  50 M: pointer <c-direct-array>
  51     drop void* <c-direct-array> ;
  52
  53 : malloc-array ( n type -- array )
  54     [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
  55
  56 : malloc-byte-array ( byte-array -- alien )
  57     binary-object [ nip malloc dup ] 2keep memcpy ;
  58
  59 : memory>byte-array ( alien len -- byte-array )
  60     [ nip (byte-array) dup ] 2keep memcpy ;
  61
  62 : malloc-string ( string encoding -- alien )
  63     string>alien malloc-byte-array ;
  64
  65 M: memory-stream stream-read
  66     [
  67         [ index>> ] [ alien>> ] bi <displaced-alien>
  68         swap memory>byte-array
  69     ] [ [ + ] change-index drop ] 2bi ;
  70
  71 M: value-type c-type-rep drop int-rep ;
  72
  73 M: value-type c-type-getter
  74     drop [ swap <displaced-alien> ] ;
  75
  76 M: value-type c-type-copier
  77     heap-size '[ _ memory>byte-array ] ;
  78
  79 M: value-type c-type-setter
  80     [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
  81
  82 M: array c-type-boxer-quot
  83     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
  84
  85 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
  86
  87 ERROR: local-allocation-error ;
  88
  89 <PRIVATE
  90
  91 : (local-allot) ( size align -- alien ) local-allocation-error ;
  92
  93 : (cleanup-allot) ( -- )
  94     ! Inhibit TCO in order for the last word in the quotation
  95     ! to still be abl to access scope-allocated data.
  96     ;
  97
  98 MACRO: (simple-local-allot) ( c-type -- quot )
  99     [ depends-on-c-type ]
 100     [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
 101
 102 : [hairy-local-allot] ( c-type initial -- quot )
 103     over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
 104
 105 : hairy-local-allot? ( obj -- ? )
 106     {
 107         [ array? ]
 108         [ length 3 = ]
 109         [ second initial: eq? ]
 110     } 1&& ;
 111
 112 MACRO: (hairy-local-allot) ( obj -- quot )
 113     dup hairy-local-allot?
 114     [ first3 nip [hairy-local-allot] ]
 115     [ '[ _ (simple-local-allot) ] ]
 116     if ;
 117
 118 MACRO: (local-allots) ( c-types -- quot )
 119     [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
 120
 121 MACRO: box-values ( c-types -- quot )
 122     [ c-type-boxer-quot ] map '[ _ spread ] ;
 123
 124 MACRO: out-parameters ( c-types -- quot )
 125     [ dup hairy-local-allot? [ first ] when ] map
 126     [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
 127     '[ _ nkeep _ spread ] ;
 128
 129 PRIVATE>
 130
 131 : with-scoped-allocation ( c-types quot -- )
 132     [ [ (local-allots) ] [ box-values ] bi ] dip call
 133     (cleanup-allot) ; inline
 134
 135 : with-out-parameters ( c-types quot -- values... )
 136     [ drop (local-allots) ] [ swap out-parameters ] 2bi
 137     (cleanup-allot) ; inline
 138
 139 GENERIC: binary-zero? ( value -- ? )
 140
 141 M: object binary-zero? drop f ; inline
 142 M: f binary-zero? drop t ; inline
 143 M: integer binary-zero? zero? ; inline
 144 M: math:float binary-zero? double>bits zero? ; inline
 145 M: complex binary-zero? >rect [ binary-zero? ] both? ; inline