1 ! (c)Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.libraries
3 alien.structs.fields alien.syntax ascii assocs byte-arrays
4 classes.struct classes.tuple.private combinators
5 compiler.tree.debugger compiler.units destructors
6 io.encodings.utf8 io.pathnames io.streams.string kernel libc
7 literals math mirrors multiline namespaces prettyprint
8 prettyprint.config see sequences specialized-arrays.char
9 specialized-arrays.int specialized-arrays.ushort
10 struct-arrays system tools.test ;
11 IN: classes.struct.tests
14 : libfactor-ffi-tests-path ( -- string )
15 "resource:" (normalize-path)
17 { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
18 { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
19 { [ os unix? ] [ "libfactor-ffi-test.so" ] }
22 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
24 "f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
27 SYMBOL: struct-test-empty
29 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
30 [ struct-must-have-slots? ] must-fail-with
32 STRUCT: struct-test-foo
34 { y int initial: 123 }
37 STRUCT: struct-test-bar
38 { w ushort initial: HEX: ffff }
39 { foo struct-test-foo } ;
41 [ 12 ] [ struct-test-foo heap-size ] unit-test
42 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
43 [ 16 ] [ struct-test-bar heap-size ] unit-test
44 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
45 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
48 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
57 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
58 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
61 { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
63 { { "y" "int" } HEX: 7F00007F }
66 B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
70 [ { { "underlying" f } } ] [
71 f struct-test-foo memory>struct
75 [ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
76 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test
77 [ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test
78 [ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test
79 [ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
80 [ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
81 [ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
83 [ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
84 S{ struct-test-foo { x 1 } { y 2 } { z f } }
85 [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
88 [ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
89 S{ struct-test-foo { x 1 } { y 2 } { z f } }
90 [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
93 [ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
94 S{ struct-test-foo { x 1 } { y 2 } { z f } }
95 [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
98 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
99 S{ struct-test-foo { x 1 } { y 2 } { z f } }
100 [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
103 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
104 S{ struct-test-foo { x 1 } { y 2 } { z f } }
105 [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
108 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
109 S{ struct-test-foo { x 1 } { y 2 } { z f } }
110 [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
113 [ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
114 S{ struct-test-foo { x 1 } { y 2 } { z f } }
115 [ make-mirror { "y" "int" } swap delete-at ] keep
118 [ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
119 S{ struct-test-foo { x 1 } { y 2 } { z f } }
120 [ make-mirror { "x" "char" } swap delete-at ] keep
123 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
124 S{ struct-test-foo { x 1 } { y 2 } { z f } }
125 [ make-mirror { "nonexist" "char" } swap delete-at ] keep
128 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
129 S{ struct-test-foo { x 1 } { y 2 } { z f } }
130 [ make-mirror "underlying" swap delete-at ] keep
133 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
134 S{ struct-test-foo { x 1 } { y 2 } { z f } }
135 [ make-mirror "nonsense" swap delete-at ] keep
138 [ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
139 S{ struct-test-foo { x 1 } { y 2 } { z t } }
140 [ make-mirror clear-assoc ] keep
143 UNION-STRUCT: struct-test-float-and-bits
147 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
148 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
150 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
152 STRUCT: struct-test-string-ptr
157 struct-test-string-ptr <struct>
158 "hello world" utf8 malloc-string &free >>x
163 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
167 c-object-pointers? off
168 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
172 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
175 c-object-pointers? on
176 12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
180 [ "S{ struct-test-foo f 0 7654 f }" ]
184 c-object-pointers? off
185 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
189 [ "S@ struct-test-foo f" ]
192 c-object-pointers? off
193 f struct-test-foo memory>struct [ pprint ] with-string-writer
197 [ <" USING: classes.struct ;
198 IN: classes.struct.tests
199 STRUCT: struct-test-foo
200 { x char initial: 0 } { y int initial: 123 } { z bool } ;
202 [ [ struct-test-foo see ] with-string-writer ] unit-test
204 [ <" USING: classes.struct ;
205 IN: classes.struct.tests
206 UNION-STRUCT: struct-test-float-and-bits
207 { f float initial: 0.0 } { bits uint initial: 0 } ;
209 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
233 } ] [ "struct-test-foo" c-type fields>> ] unit-test
250 } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
252 STRUCT: struct-test-equality-1
254 STRUCT: struct-test-equality-2
259 struct-test-equality-1 <struct> 5 >>x
260 struct-test-equality-1 malloc-struct &free 5 >>x =
266 struct-test-equality-1 <struct> 5 >>x
267 struct-test-equality-2 malloc-struct &free 5 >>y =
273 struct-test-equality-1 <struct> 5 >>x
274 struct-test-equality-1 malloc-struct &free 5 >>x
279 STRUCT: struct-test-ffi-foo
284 FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
286 [ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
288 STRUCT: struct-test-array-slots
290 { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
293 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
296 struct-test-array-slots <struct>
297 [ y>> [ 8 3 ] dip set-nth ]
298 [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
301 STRUCT: struct-test-optimization
302 { x { "int" 3 } } { y int } ;
304 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
306 [ 3 struct-test-optimization <direct-struct-array> third y>> ]
307 { <tuple> <tuple-boa> memory>struct y>> } inlined?
310 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
313 [ struct-test-optimization memory>struct x>> second ]
314 { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
317 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
319 ! Test cloning structs
320 STRUCT: clone-test-struct { x int } { y char[3] } ;
322 [ 1 char-array{ 9 1 1 } ] [
323 clone-test-struct <struct>
324 1 >>x char-array{ 9 1 1 } >>y
326 [ x>> ] [ y>> >char-array ] bi
329 [ t 1 char-array{ 9 1 1 } ] [
331 clone-test-struct malloc-struct &free
332 1 >>x char-array{ 9 1 1 } >>y
334 [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
338 STRUCT: struct-that's-a-word { x int } ;
340 : struct-that's-a-word ( -- ) "OOPS" throw ;
342 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test