1 ! Copyright (C) 2009 Jeremy Hughes.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.inline.types
4 alien.marshall.private alien.strings byte-arrays classes
5 combinators combinators.short-circuit destructors fry
6 io.encodings.utf8 kernel libc sequences alien.data
7 specialized-arrays strings unix.utilities vocabs.parser
8 words libc.private locals generalizations math ;
9 FROM: alien.c-types => float short ;
10 SPECIALIZED-ARRAY: bool
11 SPECIALIZED-ARRAY: char
12 SPECIALIZED-ARRAY: double
13 SPECIALIZED-ARRAY: float
14 SPECIALIZED-ARRAY: int
15 SPECIALIZED-ARRAY: long
16 SPECIALIZED-ARRAY: longlong
17 SPECIALIZED-ARRAY: short
18 SPECIALIZED-ARRAY: uchar
19 SPECIALIZED-ARRAY: uint
20 SPECIALIZED-ARRAY: ulong
21 SPECIALIZED-ARRAY: ulonglong
22 SPECIALIZED-ARRAY: ushort
23 SPECIALIZED-ARRAY: void*
26 << primitive-types [ [ void* = ] [ bool = ] bi or not ]
27 filter [ define-primitive-marshallers ] each >>
29 TUPLE: alien-wrapper { underlying alien } ;
30 TUPLE: struct-wrapper < alien-wrapper disposed ;
31 TUPLE: class-wrapper < alien-wrapper disposed ;
35 GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
37 M: alien-wrapper unmarshall-cast ;
38 M: struct-wrapper unmarshall-cast ;
40 M: struct-wrapper dispose* underlying>> free ;
42 M: class-wrapper c++-type class name>> parse-c++-type ;
44 : marshall-pointer ( obj -- alien )
46 { [ dup alien? ] [ ] }
48 { [ dup byte-array? ] [ malloc-byte-array ] }
49 { [ dup alien-wrapper? ] [ underlying>> ] }
52 : marshall-primitive ( n -- n )
53 [ bool>arg ] ptr-pass-through ;
55 ALIAS: marshall-void* marshall-pointer
57 : marshall-void** ( seq -- alien )
58 [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
60 : (marshall-char*-or-string) ( n/string -- alien )
62 [ utf8 string>alien malloc-byte-array ]
63 [ (marshall-char*) ] if ;
65 : marshall-char*-or-string ( n/string -- alien )
66 [ (marshall-char*-or-string) ] ptr-pass-through ;
68 : (marshall-char**-or-strings) ( seq -- alien )
69 [ marshall-char*-or-string ] void*-array{ } map-as
72 : marshall-char**-or-strings ( seq -- alien )
73 [ (marshall-char**-or-strings) ] ptr-pass-through ;
75 : marshall-bool ( ? -- n )
76 >boolean [ 1 ] [ 0 ] if ;
78 : (marshall-bool*) ( ?/seq -- alien )
79 [ marshall-bool <bool> malloc-byte-array ]
80 [ >bool-array malloc-underlying ]
83 : marshall-bool* ( ?/seq -- alien )
84 [ (marshall-bool*) ] ptr-pass-through ;
86 : (marshall-bool**) ( seq -- alien )
87 [ marshall-bool* ] map >void*-array malloc-underlying ;
89 : marshall-bool** ( seq -- alien )
90 [ (marshall-bool**) ] ptr-pass-through ;
92 : unmarshall-bool ( n -- ? )
95 : unmarshall-bool* ( alien -- ? )
96 *bool unmarshall-bool ;
98 : unmarshall-bool*-free ( alien -- ? )
99 [ *bool unmarshall-bool ] keep add-malloc free ;
101 : primitive-marshaller ( type -- quot/f )
104 { "boolean" [ [ marshall-bool ] ] }
105 { "char" [ [ marshall-primitive ] ] }
106 { "uchar" [ [ marshall-primitive ] ] }
107 { "short" [ [ marshall-primitive ] ] }
108 { "ushort" [ [ marshall-primitive ] ] }
109 { "int" [ [ marshall-primitive ] ] }
110 { "uint" [ [ marshall-primitive ] ] }
111 { "long" [ [ marshall-primitive ] ] }
112 { "ulong" [ [ marshall-primitive ] ] }
113 { "long" [ [ marshall-primitive ] ] }
114 { "ulong" [ [ marshall-primitive ] ] }
115 { "float" [ [ marshall-primitive ] ] }
116 { "double" [ [ marshall-primitive ] ] }
117 { "bool*" [ [ marshall-bool* ] ] }
118 { "boolean*" [ [ marshall-bool* ] ] }
119 { "char*" [ [ marshall-char*-or-string ] ] }
120 { "uchar*" [ [ marshall-uchar* ] ] }
121 { "short*" [ [ marshall-short* ] ] }
122 { "ushort*" [ [ marshall-ushort* ] ] }
123 { "int*" [ [ marshall-int* ] ] }
124 { "uint*" [ [ marshall-uint* ] ] }
125 { "long*" [ [ marshall-long* ] ] }
126 { "ulong*" [ [ marshall-ulong* ] ] }
127 { "longlong*" [ [ marshall-longlong* ] ] }
128 { "ulonglong*" [ [ marshall-ulonglong* ] ] }
129 { "float*" [ [ marshall-float* ] ] }
130 { "double*" [ [ marshall-double* ] ] }
131 { "bool&" [ [ marshall-bool* ] ] }
132 { "boolean&" [ [ marshall-bool* ] ] }
133 { "char&" [ [ marshall-char* ] ] }
134 { "uchar&" [ [ marshall-uchar* ] ] }
135 { "short&" [ [ marshall-short* ] ] }
136 { "ushort&" [ [ marshall-ushort* ] ] }
137 { "int&" [ [ marshall-int* ] ] }
138 { "uint&" [ [ marshall-uint* ] ] }
139 { "long&" [ [ marshall-long* ] ] }
140 { "ulong&" [ [ marshall-ulong* ] ] }
141 { "longlong&" [ [ marshall-longlong* ] ] }
142 { "ulonglong&" [ [ marshall-ulonglong* ] ] }
143 { "float&" [ [ marshall-float* ] ] }
144 { "double&" [ [ marshall-double* ] ] }
145 { "void*" [ [ marshall-void* ] ] }
146 { "bool**" [ [ marshall-bool** ] ] }
147 { "boolean**" [ [ marshall-bool** ] ] }
148 { "char**" [ [ marshall-char**-or-strings ] ] }
149 { "uchar**" [ [ marshall-uchar** ] ] }
150 { "short**" [ [ marshall-short** ] ] }
151 { "ushort**" [ [ marshall-ushort** ] ] }
152 { "int**" [ [ marshall-int** ] ] }
153 { "uint**" [ [ marshall-uint** ] ] }
154 { "long**" [ [ marshall-long** ] ] }
155 { "ulong**" [ [ marshall-ulong** ] ] }
156 { "longlong**" [ [ marshall-longlong** ] ] }
157 { "ulonglong**" [ [ marshall-ulonglong** ] ] }
158 { "float**" [ [ marshall-float** ] ] }
159 { "double**" [ [ marshall-double** ] ] }
160 { "void**" [ [ marshall-void** ] ] }
164 : marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
166 { [ dup byte-array? ] [ ] }
167 { [ dup alien-wrapper? ]
168 [ [ underlying>> ] [ class name>> heap-size ] bi
169 memory>byte-array ] }
173 : marshaller ( type -- quot )
174 factorize-type dup primitive-marshaller [ nip ] [
176 [ [ marshall-pointer ] ]
177 [ [ marshall-non-pointer ] ] if
181 : unmarshall-char*-to-string ( alien -- string )
184 : unmarshall-char*-to-string-free ( alien -- string )
185 [ unmarshall-char*-to-string ] keep add-malloc free ;
187 : primitive-unmarshaller ( type -- quot/f )
190 { "boolean" [ [ unmarshall-bool ] ] }
199 { "longlong" [ [ ] ] }
200 { "ulonglong" [ [ ] ] }
203 { "bool*" [ [ unmarshall-bool*-free ] ] }
204 { "boolean*" [ [ unmarshall-bool*-free ] ] }
206 { "uchar*" [ [ unmarshall-uchar*-free ] ] }
207 { "short*" [ [ unmarshall-short*-free ] ] }
208 { "ushort*" [ [ unmarshall-ushort*-free ] ] }
209 { "int*" [ [ unmarshall-int*-free ] ] }
210 { "uint*" [ [ unmarshall-uint*-free ] ] }
211 { "long*" [ [ unmarshall-long*-free ] ] }
212 { "ulong*" [ [ unmarshall-ulong*-free ] ] }
213 { "longlong*" [ [ unmarshall-long*-free ] ] }
214 { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
215 { "float*" [ [ unmarshall-float*-free ] ] }
216 { "double*" [ [ unmarshall-double*-free ] ] }
217 { "bool&" [ [ unmarshall-bool*-free ] ] }
218 { "boolean&" [ [ unmarshall-bool*-free ] ] }
220 { "uchar&" [ [ unmarshall-uchar*-free ] ] }
221 { "short&" [ [ unmarshall-short*-free ] ] }
222 { "ushort&" [ [ unmarshall-ushort*-free ] ] }
223 { "int&" [ [ unmarshall-int*-free ] ] }
224 { "uint&" [ [ unmarshall-uint*-free ] ] }
225 { "long&" [ [ unmarshall-long*-free ] ] }
226 { "ulong&" [ [ unmarshall-ulong*-free ] ] }
227 { "longlong&" [ [ unmarshall-longlong*-free ] ] }
228 { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
229 { "float&" [ [ unmarshall-float*-free ] ] }
230 { "double&" [ [ unmarshall-double*-free ] ] }
234 : struct-primitive-unmarshaller ( type -- quot/f )
236 { "bool" [ [ unmarshall-bool ] ] }
237 { "boolean" [ [ unmarshall-bool ] ] }
246 { "longlong" [ [ ] ] }
247 { "ulonglong" [ [ ] ] }
250 { "bool*" [ [ unmarshall-bool* ] ] }
251 { "boolean*" [ [ unmarshall-bool* ] ] }
253 { "uchar*" [ [ unmarshall-uchar* ] ] }
254 { "short*" [ [ unmarshall-short* ] ] }
255 { "ushort*" [ [ unmarshall-ushort* ] ] }
256 { "int*" [ [ unmarshall-int* ] ] }
257 { "uint*" [ [ unmarshall-uint* ] ] }
258 { "long*" [ [ unmarshall-long* ] ] }
259 { "ulong*" [ [ unmarshall-ulong* ] ] }
260 { "longlong*" [ [ unmarshall-long* ] ] }
261 { "ulonglong*" [ [ unmarshall-ulong* ] ] }
262 { "float*" [ [ unmarshall-float* ] ] }
263 { "double*" [ [ unmarshall-double* ] ] }
264 { "bool&" [ [ unmarshall-bool* ] ] }
265 { "boolean&" [ [ unmarshall-bool* ] ] }
266 { "char&" [ [ unmarshall-char* ] ] }
267 { "uchar&" [ [ unmarshall-uchar* ] ] }
268 { "short&" [ [ unmarshall-short* ] ] }
269 { "ushort&" [ [ unmarshall-ushort* ] ] }
270 { "int&" [ [ unmarshall-int* ] ] }
271 { "uint&" [ [ unmarshall-uint* ] ] }
272 { "long&" [ [ unmarshall-long* ] ] }
273 { "ulong&" [ [ unmarshall-ulong* ] ] }
274 { "longlong&" [ [ unmarshall-longlong* ] ] }
275 { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
276 { "float&" [ [ unmarshall-float* ] ] }
277 { "double&" [ [ unmarshall-double* ] ] }
282 : ?malloc-byte-array ( c-type -- alien )
283 dup alien? [ malloc-byte-array ] unless ;
285 :: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
286 type type-quot call current-vocab lookup [
287 dup superclasses superclass swap member?
288 [ def call ] [ drop clean call f ] if
289 ] [ clean call f ] if* ; inline
291 : struct-unmarshaller ( type -- quot/f )
293 [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
297 : class-unmarshaller ( type -- quot/f )
298 [ type-sans-pointer "#" append ] \ class-wrapper
299 [ '[ _ new swap >>underlying ] ]
303 : non-primitive-unmarshaller ( type -- quot/f )
305 { [ dup pointer? ] [ class-unmarshaller ] }
306 [ struct-unmarshaller ]
309 : unmarshaller ( type -- quot )
311 [ primitive-unmarshaller ]
312 [ non-primitive-unmarshaller ]
316 : struct-field-unmarshaller ( type -- quot )
318 [ struct-primitive-unmarshaller ]
319 [ non-primitive-unmarshaller ]
323 : out-arg-unmarshaller ( type -- quot )
324 dup pointer-to-non-const-primitive?
325 [ factorize-type primitive-unmarshaller ]
326 [ drop [ drop ] ] if ;