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: 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> ( len c-type -- array )
  26
  27 M: word <c-array>
  28     c-array-constructor execute( len -- array ) ; inline
  29
  30 M: pointer <c-array>
  31     drop void* <c-array> ;
  32
  33 GENERIC: (c-array) ( len c-type -- array )
  34
  35 M: word (c-array)
  36     c-(array)-constructor execute( len -- array ) ; inline
  37
  38 M: pointer (c-array)
  39     drop void* (c-array) ;
  40
  41 GENERIC: <c-direct-array> ( alien len c-type -- array )
  42
  43 M: word <c-direct-array>
  44     c-direct-array-constructor execute( alien len -- array ) ; inline
  45
  46 M: pointer <c-direct-array>
  47     drop void* <c-direct-array> ;
  48
  49 : malloc-array ( n type -- array )
  50     [ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
  51
  52 : malloc-byte-array ( byte-array -- alien )
  53     binary-object [ nip malloc dup ] 2keep memcpy ;
  54
  55 : memory>byte-array ( alien len -- byte-array )
  56     [ nip (byte-array) dup ] 2keep memcpy ;
  57
  58 : malloc-string ( string encoding -- alien )
  59     string>alien malloc-byte-array ;
  60
  61 M: memory-stream stream-read
  62     [
  63         [ index>> ] [ alien>> ] bi <displaced-alien>
  64         swap memory>byte-array
  65     ] [ [ + ] change-index drop ] 2bi ;
  66
  67 M: value-type c-type-rep drop int-rep ;
  68
  69 M: value-type c-type-getter
  70     drop [ swap <displaced-alien> ] ;
  71
  72 M: value-type c-type-copier
  73     heap-size '[ _ memory>byte-array ] ;
  74
  75 M: value-type c-type-setter
  76     [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
  77
  78 M: array c-type-boxer-quot
  79     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
  80
  81 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
  82
  83 ERROR: local-allocation-error ;
  84
  85 <PRIVATE
  86
  87 : (local-allot) ( size align -- alien ) local-allocation-error ;
  88
  89 : (cleanup-allot) ( -- )
  90     ! Inhibit TCO in order for the last word in the quotation
  91     ! to still be abl to access scope-allocated data.
  92     ;
  93
  94 MACRO: (simple-local-allot) ( c-type -- quot )
  95     [ depends-on-c-type ]
  96     [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
  97
  98 : [hairy-local-allot] ( c-type initial -- quot )
  99     over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
 100
 101 : hairy-local-allot? ( obj -- ? )
 102     {
 103         [ array? ]
 104         [ length 3 = ]
 105         [ second initial: eq? ]
 106     } 1&& ;
 107
 108 MACRO: (hairy-local-allot) ( obj -- quot )
 109     dup hairy-local-allot?
 110     [ first3 nip [hairy-local-allot] ]
 111     [ '[ _ (simple-local-allot) ] ]
 112     if ;
 113
 114 MACRO: (local-allots) ( c-types -- quot )
 115     [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
 116
 117 MACRO: box-values ( c-types -- quot )
 118     [ c-type-boxer-quot ] map '[ _ spread ] ;
 119
 120 MACRO: out-parameters ( c-types -- quot )
 121     [ dup hairy-local-allot? [ first ] when ] map
 122     [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
 123     '[ _ nkeep _ spread ] ;
 124
 125 PRIVATE>
 126
 127 : with-scoped-allocation ( c-types quot -- )
 128     [ [ (local-allots) ] [ box-values ] bi ] dip call
 129     (cleanup-allot) ; inline
 130
 131 : with-out-parameters ( c-types quot -- values... )
 132     [ drop (local-allots) ] [ swap out-parameters ] 2bi
 133     (cleanup-allot) ; inline
 134
 135 GENERIC: binary-zero? ( value -- ? )
 136
 137 M: object binary-zero? drop f ; inline
 138 M: f binary-zero? drop t ; inline
 139 M: integer binary-zero? zero? ; inline
 140 M: math:float binary-zero? double>bits zero? ; inline
 141 M: complex binary-zero? >rect [ binary-zero? ] both? ; inline