]> gitweb.factorcode.org Git - factor.git/blob - basis/alien/data/data.factor
specialized-arrays: performed some cleanup.
[factor.git] / 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 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 ;
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> ] [ 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-byte-array ( byte-array -- alien )
88     binary-object [ nip malloc dup ] 2keep memcpy ;
89
90 : memory>byte-array ( alien len -- byte-array )
91     [ nip (byte-array) dup ] 2keep memcpy ;
92
93 : malloc-string ( string encoding -- alien )
94     string>alien malloc-byte-array ;
95
96 M: memory-stream stream-read
97     [
98         [ index>> ] [ alien>> ] bi <displaced-alien>
99         swap memory>byte-array
100     ] [ [ + ] change-index drop ] 2bi ;
101
102 M: value-type c-type-rep drop int-rep ;
103
104 M: value-type c-type-getter
105     drop [ swap <displaced-alien> ] ;
106
107 M: value-type c-type-copier
108     heap-size '[ _ memory>byte-array ] ;
109
110 M: value-type c-type-setter
111     [ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
112
113 M: array c-type-boxer-quot
114     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
115
116 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
117
118 ERROR: local-allocation-error ;
119
120 <PRIVATE
121
122 : (local-allot) ( size align -- alien ) local-allocation-error ;
123
124 : (cleanup-allot) ( -- )
125     ! Inhibit TCO in order for the last word in the quotation
126     ! to still be abl to access scope-allocated data.
127     ;
128
129 MACRO: (simple-local-allot) ( c-type -- quot )
130     [ depends-on-c-type ]
131     [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
132
133 : [hairy-local-allot] ( c-type initial -- quot )
134     over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
135
136 : hairy-local-allot? ( obj -- ? )
137     {
138         [ array? ]
139         [ length 3 = ]
140         [ second initial: eq? ]
141     } 1&& ;
142
143 MACRO: (hairy-local-allot) ( obj -- quot )
144     dup hairy-local-allot?
145     [ first3 nip [hairy-local-allot] ]
146     [ '[ _ (simple-local-allot) ] ]
147     if ;
148
149 MACRO: (local-allots) ( c-types -- quot )
150     [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
151
152 MACRO: box-values ( c-types -- quot )
153     [ c-type-boxer-quot ] map '[ _ spread ] ;
154
155 MACRO: out-parameters ( c-types -- quot )
156     [ dup hairy-local-allot? [ first ] when ] map
157     [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
158     '[ _ nkeep _ spread ] ;
159
160 PRIVATE>
161
162 : with-scoped-allocation ( c-types quot -- )
163     [ [ (local-allots) ] [ box-values ] bi ] dip call
164     (cleanup-allot) ; inline
165
166 : with-out-parameters ( c-types quot -- values... )
167     [ drop (local-allots) ] [ swap out-parameters ] 2bi
168     (cleanup-allot) ; inline
169
170 GENERIC: binary-zero? ( value -- ? )
171
172 M: object binary-zero? drop f ; inline
173 M: f binary-zero? drop t ; inline
174 M: integer binary-zero? zero? ; inline
175 M: math:float binary-zero? double>bits zero? ; inline
176 M: complex binary-zero? >rect [ binary-zero? ] both? ; inline