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