1 ! (c)Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.data ascii
3 assocs byte-arrays classes.struct classes.tuple.private
4 combinators compiler.tree.debugger compiler.units destructors
5 io.encodings.utf8 io.pathnames io.streams.string kernel libc
6 literals math mirrors multiline namespaces prettyprint
7 prettyprint.config see sequences specialized-arrays system
8 tools.test parser lexer eval layouts ;
10 QUALIFIED-WITH: alien.c-types c
11 SPECIALIZED-ARRAY: char
12 SPECIALIZED-ARRAY: int
13 SPECIALIZED-ARRAY: ushort
14 IN: classes.struct.tests
16 SYMBOL: struct-test-empty
18 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
19 [ struct-must-have-slots? ] must-fail-with
21 STRUCT: struct-test-foo
23 { y int initial: 123 }
26 STRUCT: struct-test-bar
27 { w ushort initial: HEX: ffff }
28 { foo struct-test-foo } ;
30 [ 12 ] [ struct-test-foo heap-size ] unit-test
31 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
32 [ 16 ] [ struct-test-bar heap-size ] unit-test
33 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
34 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
37 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
46 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
47 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
50 { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
52 { { "y" int } HEX: 7F00007F }
55 B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
59 [ { { "underlying" f } } ] [
60 f struct-test-foo memory>struct
64 [ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
65 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test
66 [ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test
67 [ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test
68 [ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
69 [ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
70 [ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
72 [ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
73 S{ struct-test-foo { x 1 } { y 2 } { z f } }
74 [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
77 [ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
78 S{ struct-test-foo { x 1 } { y 2 } { z f } }
79 [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
82 [ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
83 S{ struct-test-foo { x 1 } { y 2 } { z f } }
84 [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
87 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
88 S{ struct-test-foo { x 1 } { y 2 } { z f } }
89 [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
92 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
93 S{ struct-test-foo { x 1 } { y 2 } { z f } }
94 [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
97 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
98 S{ struct-test-foo { x 1 } { y 2 } { z f } }
99 [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
102 [ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
103 S{ struct-test-foo { x 1 } { y 2 } { z f } }
104 [ make-mirror { "y" "int" } swap delete-at ] keep
107 [ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
108 S{ struct-test-foo { x 1 } { y 2 } { z f } }
109 [ make-mirror { "x" "char" } swap delete-at ] keep
112 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
113 S{ struct-test-foo { x 1 } { y 2 } { z f } }
114 [ make-mirror { "nonexist" "char" } swap delete-at ] keep
117 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
118 S{ struct-test-foo { x 1 } { y 2 } { z f } }
119 [ make-mirror "underlying" swap delete-at ] keep
122 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
123 S{ struct-test-foo { x 1 } { y 2 } { z f } }
124 [ make-mirror "nonsense" swap delete-at ] keep
127 [ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
128 S{ struct-test-foo { x 1 } { y 2 } { z t } }
129 [ make-mirror clear-assoc ] keep
132 UNION-STRUCT: struct-test-float-and-bits
136 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
137 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
139 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
141 STRUCT: struct-test-string-ptr
146 struct-test-string-ptr <struct>
147 "hello world" utf8 malloc-string &free >>x
152 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
156 c-object-pointers? off
157 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
161 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
164 c-object-pointers? on
165 12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
169 [ "S{ struct-test-foo f 0 7654 f }" ]
173 c-object-pointers? off
174 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
178 [ "S@ struct-test-foo f" ]
181 c-object-pointers? off
182 f struct-test-foo memory>struct [ pprint ] with-string-writer
186 [ <" USING: alien.c-types classes.struct ;
187 IN: classes.struct.tests
188 STRUCT: struct-test-foo
189 { x char initial: 0 } { y int initial: 123 } { z bool } ;
191 [ [ struct-test-foo see ] with-string-writer ] unit-test
193 [ <" USING: alien.c-types classes.struct ;
194 IN: classes.struct.tests
195 UNION-STRUCT: struct-test-float-and-bits
196 { f float initial: 0.0 } { bits uint initial: 0 } ;
198 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
222 } ] [ "struct-test-foo" c-type fields>> ] unit-test
239 } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
241 STRUCT: struct-test-equality-1
243 STRUCT: struct-test-equality-2
248 struct-test-equality-1 <struct> 5 >>x
249 struct-test-equality-1 malloc-struct &free 5 >>x =
255 struct-test-equality-1 <struct> 5 >>x
256 struct-test-equality-2 malloc-struct &free 5 >>y =
262 struct-test-equality-1 <struct> 5 >>x
263 struct-test-equality-1 malloc-struct &free 5 >>x
268 STRUCT: struct-test-array-slots
270 { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
273 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
276 struct-test-array-slots <struct>
277 [ y>> [ 8 3 ] dip set-nth ]
278 [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
281 STRUCT: struct-test-optimization
282 { x { int 3 } } { y int } ;
284 SPECIALIZED-ARRAY: struct-test-optimization
286 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
288 [ 3 <direct-struct-test-optimization-array> third y>> ]
289 { <tuple> <tuple-boa> memory>struct y>> } inlined?
292 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
295 [ struct-test-optimization memory>struct x>> second ]
296 { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
299 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
302 [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
306 ! Test cloning structs
307 STRUCT: clone-test-struct { x int } { y char[3] } ;
309 [ 1 char-array{ 9 1 1 } ] [
310 clone-test-struct <struct>
311 1 >>x char-array{ 9 1 1 } >>y
313 [ x>> ] [ y>> >char-array ] bi
316 [ t 1 char-array{ 9 1 1 } ] [
318 clone-test-struct malloc-struct &free
319 1 >>x char-array{ 9 1 1 } >>y
321 [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
325 STRUCT: struct-that's-a-word { x int } ;
327 : struct-that's-a-word ( -- ) "OOPS" throw ;
329 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
331 ! Interactive parsing of struct slot definitions
333 "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
334 "struct-class-test-1" parse-stream
335 ] [ error>> error>> unexpected-eof? ] must-fail-with
337 ! S{ with non-struct type
339 "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
343 ! Subclassing a struct class should not be allowed
345 "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
349 ! Remove c-type when struct class is forgotten
351 "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
354 [ f ] [ "a-struct" c-types get key? ] unit-test