1 ! (c)Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.data alien.syntax
3 ascii assocs byte-arrays classes.struct
4 classes.struct.prettyprint classes.struct.prettyprint.private
5 classes.tuple.parser classes.tuple.private classes.tuple
6 combinators compiler.tree.debugger compiler.units delegate
7 destructors io.encodings.utf8 io.pathnames io.streams.string
8 kernel libc literals math mirrors namespaces prettyprint
9 prettyprint.config see sequences specialized-arrays system
10 tools.test parser lexer eval layouts generic.single classes
11 vocabs generic classes.private definitions ;
13 FROM: specialized-arrays.private => specialized-array-vocab ;
14 QUALIFIED-WITH: alien.c-types c
15 SPECIALIZED-ARRAY: char
16 SPECIALIZED-ARRAY: int
17 SPECIALIZED-ARRAY: ushort
18 IN: classes.struct.tests
20 SYMBOL: struct-test-empty
22 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
23 [ struct-must-have-slots? ] must-fail-with
25 STRUCT: struct-test-foo
27 { y int initial: 123 }
30 STRUCT: struct-test-bar
31 { w ushort initial: 0xffff }
32 { foo struct-test-foo } ;
34 [ 12 ] [ struct-test-foo heap-size ] unit-test
35 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
36 [ 16 ] [ struct-test-bar heap-size ] unit-test
37 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
38 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
41 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
50 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
51 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
54 { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
56 { { "y" int } 0x7F00007F }
59 B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
63 [ { { "underlying" f } } ] [
64 f struct-test-foo memory>struct
68 [ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } ?of ] unit-test
69 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } ?of ] unit-test
70 [ t t ] [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } ?of ] unit-test
71 [ f t ] [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } ?of ] unit-test
72 [ { "nonexist" "bool" } f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } ?of ] unit-test
73 [ "nonexist" f ] [ S{ struct-test-foo } make-mirror "nonexist" ?of ] unit-test
74 [ f t ] [ f struct-test-foo memory>struct make-mirror "underlying" ?of ] unit-test
76 [ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
77 S{ struct-test-foo { x 1 } { y 2 } { z f } }
78 [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
81 [ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
82 S{ struct-test-foo { x 1 } { y 2 } { z f } }
83 [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
86 [ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
87 S{ struct-test-foo { x 1 } { y 2 } { z f } }
88 [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
91 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
92 S{ struct-test-foo { x 1 } { y 2 } { z f } }
93 [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
96 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
97 S{ struct-test-foo { x 1 } { y 2 } { z f } }
98 [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
101 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
102 S{ struct-test-foo { x 1 } { y 2 } { z f } }
103 [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
106 [ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
107 S{ struct-test-foo { x 1 } { y 2 } { z f } }
108 [ make-mirror { "y" "int" } swap delete-at ] keep
111 [ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
112 S{ struct-test-foo { x 1 } { y 2 } { z f } }
113 [ make-mirror { "x" "char" } swap delete-at ] keep
116 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
117 S{ struct-test-foo { x 1 } { y 2 } { z f } }
118 [ make-mirror { "nonexist" "char" } swap delete-at ] keep
121 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
122 S{ struct-test-foo { x 1 } { y 2 } { z f } }
123 [ make-mirror "underlying" swap delete-at ] keep
126 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
127 S{ struct-test-foo { x 1 } { y 2 } { z f } }
128 [ make-mirror "nonsense" swap delete-at ] keep
131 [ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
132 S{ struct-test-foo { x 1 } { y 2 } { z t } }
133 [ make-mirror clear-assoc ] keep
136 [ POSTPONE: STRUCT: ]
137 [ struct-test-foo struct-definer-word ] unit-test
139 UNION-STRUCT: struct-test-float-and-bits
143 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
144 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
146 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
148 [ POSTPONE: UNION-STRUCT: ]
149 [ struct-test-float-and-bits struct-definer-word ] unit-test
151 STRUCT: struct-test-string-ptr
156 struct-test-string-ptr <struct>
157 "hello world" utf8 malloc-string &free >>x
162 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
164 H{ { boa-tuples? f } { c-object-pointers? f } } [
165 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
169 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
171 H{ { c-object-pointers? t } } [
172 12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
176 [ "S{ struct-test-foo f 0 7654 f }" ]
178 H{ { boa-tuples? t } { c-object-pointers? f } } [
179 struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
183 [ "S@ struct-test-foo f" ]
185 H{ { c-object-pointers? f } } [
186 f struct-test-foo memory>struct [ pprint ] with-string-writer
190 [ "USING: alien.c-types classes.struct ;
191 IN: classes.struct.tests
192 STRUCT: struct-test-foo
193 { x char initial: 0 } { y int initial: 123 } { z bool } ;
195 [ [ struct-test-foo see ] with-string-writer ] unit-test
197 [ "USING: alien.c-types classes.struct ;
198 IN: classes.struct.tests
199 UNION-STRUCT: struct-test-float-and-bits
200 { f float initial: 0.0 } { bits uint initial: 0 } ;
202 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
216 { class $[ cell 4 = integer fixnum ? ] }
226 } ] [ struct-test-foo lookup-c-type fields>> ] unit-test
240 { class $[ cell 4 = integer fixnum ? ] }
243 } ] [ struct-test-float-and-bits lookup-c-type fields>> ] unit-test
245 STRUCT: struct-test-equality-1
247 STRUCT: struct-test-equality-2
250 [ 0 ] [ struct-test-equality-1 new hashcode ] unit-test
254 struct-test-equality-1 <struct> 5 >>x
255 struct-test-equality-1 malloc-struct &free 5 >>x =
261 struct-test-equality-1 <struct> 5 >>x
262 struct-test-equality-2 malloc-struct &free 5 >>y =
268 struct-test-equality-1 <struct> 5 >>x
269 struct-test-equality-1 malloc-struct &free 5 >>x
274 STRUCT: struct-test-array-slots
276 { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
279 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
282 struct-test-array-slots <struct>
283 [ y>> [ 8 3 ] dip set-nth ]
284 [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
287 STRUCT: struct-test-optimization
288 { x { int 3 } } { y int } ;
290 SPECIALIZED-ARRAY: struct-test-optimization
292 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
294 [ 3 struct-test-optimization <c-direct-array> third y>> ]
295 { <tuple> <tuple-boa> memory>struct y>> } inlined?
298 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
301 [ struct-test-optimization memory>struct x>> second ]
302 { memory>struct x>> int <c-direct-array> <tuple> <tuple-boa> } inlined?
305 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
308 [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
314 struct-test-optimization specialized-array-vocab forget-vocab
315 ] with-compilation-unit
318 ! Test cloning structs
319 STRUCT: clone-test-struct { x int } { y char[3] } ;
321 [ 1 char-array{ 9 1 1 } ] [
322 clone-test-struct <struct>
323 1 >>x char-array{ 9 1 1 } >>y
325 [ x>> ] [ y>> char >c-array ] bi
328 [ t 1 char-array{ 9 1 1 } ] [
330 clone-test-struct malloc-struct &free
331 1 >>x char-array{ 9 1 1 } >>y
333 [ >c-ptr byte-array? ] [ x>> ] [ y>> char >c-array ] tri
337 STRUCT: struct-that's-a-word { x int } ;
339 : struct-that's-a-word ( -- ) "OOPS" throw ;
341 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
343 ! Interactive parsing of struct slot definitions
345 "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
346 "struct-class-test-1" parse-stream
347 ] [ error>> error>> unexpected-eof? ] must-fail-with
350 "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
351 ] [ error>> duplicate-slot-names? ] must-fail-with
354 "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
355 ] [ error>> duplicate-slot-names? ] must-fail-with
357 ! S{ with non-struct type
359 "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
361 ] [ error>> no-method? ] must-fail-with
363 ! Subclassing a struct class should not be allowed
365 "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
367 ] [ error>> bad-superclass? ] must-fail-with
369 ! Changing a superclass into a struct should reset the subclass
370 TUPLE: will-become-struct ;
372 TUPLE: a-subclass < will-become-struct ;
374 [ f ] [ will-become-struct struct-class? ] unit-test
376 [ will-become-struct ] [ a-subclass superclass ] unit-test
378 [ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
380 [ t ] [ will-become-struct struct-class? ] unit-test
382 [ tuple ] [ a-subclass superclass ] unit-test
384 STRUCT: bit-field-test
389 [ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
390 [ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
391 [ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
392 [ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
393 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
394 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
395 [ 3 ] [ bit-field-test heap-size ] unit-test
405 referent malloc-struct &free
412 STRUCT: self-referent
418 self-referent <struct>
419 self-referent malloc-struct &free
426 C-TYPE: forward-referent
427 STRUCT: backward-referent
428 { x forward-referent* }
430 STRUCT: forward-referent
431 { x backward-referent* }
436 forward-referent <struct>
437 backward-referent malloc-struct &free
446 backward-referent <struct>
447 forward-referent malloc-struct &free
455 STRUCT: ppc-align-test-1
459 [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
461 STRUCT: ppc-align-test-2
465 [ 16 ] [ ppc-align-test-2 heap-size ] unit-test
466 [ 8 ] [ "x" ppc-align-test-2 offset-of ] unit-test
469 STRUCT: struct-test-delegate
471 STRUCT: struct-test-delegator
472 { del struct-test-delegate }
474 CONSULT: struct-test-delegate struct-test-delegator del>> ;
476 [ S{ struct-test-delegator f S{ struct-test-delegate f 7 } 8 } ] [
477 struct-test-delegator <struct>
482 SPECIALIZED-ARRAY: void*
484 STRUCT: silly-array-field-test { x int*[3] } ;
486 [ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
489 PACKED-STRUCT: packed-struct-test
496 [ 15 ] [ packed-struct-test heap-size ] unit-test
498 [ 0 ] [ "d" packed-struct-test offset-of ] unit-test
499 [ 4 ] [ "e" packed-struct-test offset-of ] unit-test
500 [ 6 ] [ "f" packed-struct-test offset-of ] unit-test
501 [ 10 ] [ "g" packed-struct-test offset-of ] unit-test
502 [ 11 ] [ "h" packed-struct-test offset-of ] unit-test
504 [ POSTPONE: PACKED-STRUCT: ]
505 [ packed-struct-test struct-definer-word ] unit-test
507 STRUCT: struct-1 { a c:int } ;
508 PACKED-STRUCT: struct-1-packed { a c:int } ;
509 UNION-STRUCT: struct-1-union { a c:int } ;
511 [ "USING: alien.c-types classes.struct ;
512 IN: classes.struct.tests
513 STRUCT: struct-1 { a int initial: 0 } ;
515 [ \ struct-1 [ see ] with-string-writer ] unit-test
516 [ "USING: alien.c-types classes.struct ;
517 IN: classes.struct.tests
518 PACKED-STRUCT: struct-1-packed { a int initial: 0 } ;
520 [ \ struct-1-packed [ see ] with-string-writer ] unit-test
521 [ "USING: alien.c-types classes.struct ;
522 IN: classes.struct.tests
523 STRUCT: struct-1-union { a int initial: 0 } ;
525 [ \ struct-1-union [ see ] with-string-writer ] unit-test
528 STRUCT: going-to-redefine { a uint } ;
530 "IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- )
532 [ f ] [ \ going-to-redefine \ clone ?lookup-method ] unit-test
533 [ f ] [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test
535 ! Test reset-class on structs, which should forget all the accessors, clone, and struct-slot-values
536 STRUCT: some-accessors { aaa uint } { bbb int } ;
537 [ ] [ [ \ some-accessors reset-class ] with-compilation-unit ] unit-test
538 [ f ] [ \ some-accessors \ a>> ?lookup-method ] unit-test
539 [ f ] [ \ some-accessors \ a<< ?lookup-method ] unit-test
540 [ f ] [ \ some-accessors \ b>> ?lookup-method ] unit-test
541 [ f ] [ \ some-accessors \ b<< ?lookup-method ] unit-test
542 [ f ] [ \ some-accessors \ clone ?lookup-method ] unit-test
543 [ f ] [ \ some-accessors \ struct-slot-values ?lookup-method ] unit-test
545 << \ some-accessors forget >>