1 ! (c)Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.data alien.syntax ascii
3 assocs byte-arrays classes.struct classes.tuple.parser
4 classes.tuple.private classes.tuple combinators compiler.tree.debugger
5 compiler.units delegate destructors io.encodings.utf8 io.pathnames
6 io.streams.string kernel libc literals math mirrors namespaces
7 prettyprint prettyprint.config see sequences specialized-arrays
8 system tools.test parser lexer eval layouts generic.single classes
11 FROM: specialized-arrays.private => specialized-array-vocab ;
12 QUALIFIED-WITH: alien.c-types c
13 SPECIALIZED-ARRAY: char
14 SPECIALIZED-ARRAY: int
15 SPECIALIZED-ARRAY: ushort
16 IN: classes.struct.tests
18 SYMBOL: struct-test-empty
20 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
21 [ struct-must-have-slots? ] must-fail-with
23 STRUCT: struct-test-foo
25 { y int initial: 123 }
28 STRUCT: struct-test-bar
29 { w ushort initial: HEX: ffff }
30 { foo struct-test-foo } ;
32 [ 12 ] [ struct-test-foo heap-size ] unit-test
33 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
34 [ 16 ] [ struct-test-bar heap-size ] unit-test
35 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
36 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
39 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
48 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
49 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
52 { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
54 { { "y" int } HEX: 7F00007F }
57 B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
61 [ { { "underlying" f } } ] [
62 f struct-test-foo memory>struct
66 [ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
67 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } swap at* ] unit-test
68 [ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } swap at* ] unit-test
69 [ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } swap at* ] unit-test
70 [ f f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
71 [ f f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
72 [ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
74 [ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
75 S{ struct-test-foo { x 1 } { y 2 } { z f } }
76 [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
79 [ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
80 S{ struct-test-foo { x 1 } { y 2 } { z f } }
81 [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
84 [ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
85 S{ struct-test-foo { x 1 } { y 2 } { z f } }
86 [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
89 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
90 S{ struct-test-foo { x 1 } { y 2 } { z f } }
91 [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
94 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
95 S{ struct-test-foo { x 1 } { y 2 } { z f } }
96 [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
99 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
100 S{ struct-test-foo { x 1 } { y 2 } { z f } }
101 [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
104 [ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
105 S{ struct-test-foo { x 1 } { y 2 } { z f } }
106 [ make-mirror { "y" "int" } swap delete-at ] keep
109 [ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
110 S{ struct-test-foo { x 1 } { y 2 } { z f } }
111 [ make-mirror { "x" "char" } swap delete-at ] keep
114 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
115 S{ struct-test-foo { x 1 } { y 2 } { z f } }
116 [ make-mirror { "nonexist" "char" } swap delete-at ] keep
119 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
120 S{ struct-test-foo { x 1 } { y 2 } { z f } }
121 [ make-mirror "underlying" swap delete-at ] keep
124 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
125 S{ struct-test-foo { x 1 } { y 2 } { z f } }
126 [ make-mirror "nonsense" swap delete-at ] keep
129 [ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
130 S{ struct-test-foo { x 1 } { y 2 } { z t } }
131 [ make-mirror clear-assoc ] keep
134 UNION-STRUCT: struct-test-float-and-bits
138 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
139 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
141 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
143 STRUCT: struct-test-string-ptr
148 struct-test-string-ptr <struct>
149 "hello world" utf8 malloc-string &free >>x
154 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
158 c-object-pointers? off
159 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
163 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
166 c-object-pointers? on
167 12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
171 [ "S{ struct-test-foo f 0 7654 f }" ]
175 c-object-pointers? off
176 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
180 [ "S@ struct-test-foo f" ]
183 c-object-pointers? off
184 f struct-test-foo memory>struct [ pprint ] with-string-writer
188 [ "USING: alien.c-types classes.struct ;
189 IN: classes.struct.tests
190 STRUCT: struct-test-foo
191 { x char initial: 0 } { y int initial: 123 } { z bool } ;
193 [ [ struct-test-foo see ] with-string-writer ] unit-test
195 [ "USING: alien.c-types classes.struct ;
196 IN: classes.struct.tests
197 UNION-STRUCT: struct-test-float-and-bits
198 { f float initial: 0.0 } { bits uint initial: 0 } ;
200 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
214 { class $[ cell 4 = integer fixnum ? ] }
224 } ] [ struct-test-foo c-type fields>> ] unit-test
238 { class $[ cell 4 = integer fixnum ? ] }
241 } ] [ struct-test-float-and-bits c-type fields>> ] unit-test
243 STRUCT: struct-test-equality-1
245 STRUCT: struct-test-equality-2
250 struct-test-equality-1 <struct> 5 >>x
251 struct-test-equality-1 malloc-struct &free 5 >>x =
257 struct-test-equality-1 <struct> 5 >>x
258 struct-test-equality-2 malloc-struct &free 5 >>y =
264 struct-test-equality-1 <struct> 5 >>x
265 struct-test-equality-1 malloc-struct &free 5 >>x
270 STRUCT: struct-test-array-slots
272 { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
275 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
278 struct-test-array-slots <struct>
279 [ y>> [ 8 3 ] dip set-nth ]
280 [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
283 STRUCT: struct-test-optimization
284 { x { int 3 } } { y int } ;
286 SPECIALIZED-ARRAY: struct-test-optimization
288 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
290 [ 3 <direct-struct-test-optimization-array> third y>> ]
291 { <tuple> <tuple-boa> memory>struct y>> } inlined?
294 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
297 [ struct-test-optimization memory>struct x>> second ]
298 { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
301 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
304 [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
310 struct-test-optimization specialized-array-vocab forget-vocab
311 ] with-compilation-unit
314 ! Test cloning structs
315 STRUCT: clone-test-struct { x int } { y char[3] } ;
317 [ 1 char-array{ 9 1 1 } ] [
318 clone-test-struct <struct>
319 1 >>x char-array{ 9 1 1 } >>y
321 [ x>> ] [ y>> >char-array ] bi
324 [ t 1 char-array{ 9 1 1 } ] [
326 clone-test-struct malloc-struct &free
327 1 >>x char-array{ 9 1 1 } >>y
329 [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
333 STRUCT: struct-that's-a-word { x int } ;
335 : struct-that's-a-word ( -- ) "OOPS" throw ;
337 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
339 ! Interactive parsing of struct slot definitions
341 "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
342 "struct-class-test-1" parse-stream
343 ] [ error>> error>> unexpected-eof? ] must-fail-with
346 "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
347 ] [ error>> duplicate-slot-names? ] must-fail-with
350 "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
351 ] [ error>> duplicate-slot-names? ] must-fail-with
353 ! S{ with non-struct type
355 "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
357 ] [ error>> no-method? ] must-fail-with
359 ! Subclassing a struct class should not be allowed
361 "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
363 ] [ error>> bad-superclass? ] must-fail-with
365 ! Changing a superclass into a struct should reset the subclass
366 TUPLE: will-become-struct ;
368 TUPLE: a-subclass < will-become-struct ;
370 [ f ] [ will-become-struct struct-class? ] unit-test
372 [ will-become-struct ] [ a-subclass superclass ] unit-test
374 [ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
376 [ t ] [ will-become-struct struct-class? ] unit-test
378 [ tuple ] [ a-subclass superclass ] unit-test
380 STRUCT: bit-field-test
385 [ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
386 [ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
387 [ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
388 [ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
389 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
390 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
391 [ 3 ] [ bit-field-test heap-size ] unit-test
401 referent malloc-struct &free
408 STRUCT: self-referent
414 self-referent <struct>
415 self-referent malloc-struct &free
422 C-TYPE: forward-referent
423 STRUCT: backward-referent
424 { x forward-referent* }
426 STRUCT: forward-referent
427 { x backward-referent* }
432 forward-referent <struct>
433 backward-referent malloc-struct &free
442 backward-referent <struct>
443 forward-referent malloc-struct &free
451 STRUCT: ppc-align-test-1
455 [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
457 STRUCT: ppc-align-test-2
461 [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
462 [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
465 STRUCT: struct-test-delegate
467 STRUCT: struct-test-delegator
468 { del struct-test-delegate }
470 CONSULT: struct-test-delegate struct-test-delegator del>> ;
472 [ S{ struct-test-delegator f S{ struct-test-delegate f 7 } 8 } ] [
473 struct-test-delegator <struct>
480 >>>>>>> alien.data: make binary-zero? public and move it from classes.struct.private