basis/alien/data/data.factor

   1 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
   2 USING: accessors alien alien.arrays alien.c-types alien.strings
   3 arrays byte-arrays combinators combinators.short-circuit
   4 cpu.architecture fry generalizations io io.streams.memory kernel
   5 libc locals macros math math.functions parser sequences
   6 stack-checker.dependencies summary words ;
   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: c-array-constructor ( c-type -- word ) foldable
  20
  21 GENERIC: c-(array)-constructor ( c-type -- word ) foldable
  22
  23 GENERIC: c-direct-array-constructor ( c-type -- word ) foldable
  24
  25 GENERIC: c-array-type ( c-type -- word ) foldable
  26
  27 GENERIC: c-array-type? ( c-type -- word ) foldable
  28
  29 GENERIC: c-array? ( obj c-type -- ? ) foldable
  30
  31 M: word c-array?
  32     c-array-type? execute( seq -- array ) ; inline
  33
  34 M: pointer c-array?
  35     drop void* c-array? ;
  36
  37 GENERIC: >c-array ( seq c-type -- array )
  38
  39 M: word >c-array
  40     c-array-type new clone-like ; inline
  41
  42 M: pointer >c-array
  43     drop void* >c-array ;
  44
  45 GENERIC: <c-array> ( len c-type -- array )
  46
  47 M: word <c-array>
  48     c-array-constructor execute( len -- array ) ; inline
  49
  50 M: pointer <c-array>
  51     drop void* <c-array> ;
  52
  53 GENERIC: (c-array) ( len c-type -- array )
  54
  55 M: word (c-array)
  56     c-(array)-constructor execute( len -- array ) ; inline
  57
  58 M: pointer (c-array)
  59     drop void* (c-array) ;
  60
  61 GENERIC: <c-direct-array> ( alien len c-type -- array )
  62
  63 M: word <c-direct-array>
  64     c-direct-array-constructor execute( alien len -- array ) ; inline
  65
  66 M: pointer <c-direct-array>
  67     drop void* <c-direct-array> ;
  68
  69 SYNTAX: c-array{ \ } [ unclip >c-array ] parse-literal ;
  70
  71 SYNTAX: c-array@
  72     scan-object [ scan-object scan-object ] dip
  73     <c-direct-array> suffix! ;
  74
  75 ERROR: bad-byte-array-length byte-array type ;
  76
  77 M: bad-byte-array-length summary
  78     drop "Byte array length doesn't divide type width" ;
  79
  80 : cast-array ( byte-array c-type -- array )
  81     [ binary-object ] dip [ heap-size /mod 0 = ] keep swap
  82     [ <c-direct-array> ] [ throw-bad-byte-array-length ] if ; inline
  83
  84 : malloc-array ( n c-type -- array )
  85     [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
  86
  87 : malloc-like ( seq c-type -- malloc )
  88     [ dup length ] dip malloc-array [ 0 swap copy ] keep ;
  89
  90 : malloc-byte-array ( byte-array -- alien )
  91     binary-object [ nip malloc dup ] 2keep memcpy ;
  92
  93 : memory>byte-array ( alien len -- byte-array )
  94     [ nip (byte-array) dup ] 2keep memcpy ;
  95
  96 : malloc-string ( string encoding -- alien )
  97     string>alien malloc-byte-array ;
  98
  99 M:: memory-stream stream-read-unsafe ( n buf stream -- count )
 100     stream alien>> :> src
 101     buf src n memcpy
 102     n src <displaced-alien> stream alien<<
 103     n ; inline
 104
 105 M: value-type c-type-rep drop int-rep ;
 106
 107 M: value-type c-type-getter
 108     drop [ swap <displaced-alien> ] ;
 109
 110 M: value-type c-type-copier
 111     heap-size '[ _ memory>byte-array ] ;
 112
 113 M: value-type c-type-setter
 114     [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
 115
 116 M: array c-type-boxer-quot
 117     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
 118
 119 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
 120
 121 ERROR: local-allocation-error ;
 122
 123 <PRIVATE
 124
 125 : (local-allot) ( size align -- alien ) local-allocation-error ;
 126
 127 : (cleanup-allot) ( -- )
 128     ! Inhibit TCO in order for the last word in the quotation
 129     ! to still be abl to access scope-allocated data.
 130     ;
 131
 132 MACRO: (simple-local-allot) ( c-type -- quot )
 133     [ add-depends-on-c-type ]
 134     [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
 135
 136 : [hairy-local-allot] ( c-type initial -- quot )
 137     over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
 138
 139 : hairy-local-allot? ( obj -- ? )
 140     {
 141         [ array? ]
 142         [ length 3 = ]
 143         [ second initial: eq? ]
 144     } 1&& ;
 145
 146 MACRO: (hairy-local-allot) ( obj -- quot )
 147     dup hairy-local-allot?
 148     [ first3 nip [hairy-local-allot] ]
 149     [ '[ _ (simple-local-allot) ] ]
 150     if ;
 151
 152 MACRO: (local-allots) ( c-types -- quot )
 153     [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
 154
 155 MACRO: box-values ( c-types -- quot )
 156     [ c-type-boxer-quot ] map '[ _ spread ] ;
 157
 158 MACRO: out-parameters ( c-types -- quot )
 159     [ dup hairy-local-allot? [ first ] when ] map
 160     [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
 161     '[ _ nkeep _ spread ] ;
 162
 163 PRIVATE>
 164
 165 : with-scoped-allocation ( c-types quot -- )
 166     [ [ (local-allots) ] [ box-values ] bi ] dip call
 167     (cleanup-allot) ; inline
 168
 169 : with-out-parameters ( c-types quot -- values... )
 170     [ drop (local-allots) ] [ swap out-parameters ] 2bi
 171     (cleanup-allot) ; inline
 172
 173 GENERIC: binary-zero? ( value -- ? )
 174
 175 M: object binary-zero? drop f ; inline
 176 M: f binary-zero? drop t ; inline
 177 M: integer binary-zero? zero? ; inline
 178 M: math:float binary-zero? double>bits zero? ; inline
 179 M: complex binary-zero? >rect [ binary-zero? ] both? ; inline