! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data ascii
-assocs byte-arrays classes.struct classes.tuple.private
-combinators compiler.tree.debugger compiler.units destructors
-io.encodings.utf8 io.pathnames io.streams.string kernel libc
-literals math mirrors namespaces prettyprint
+USING: accessors alien alien.c-types alien.data alien.syntax
+ascii assocs byte-arrays classes.struct
+classes.struct.prettyprint classes.struct.prettyprint.private
+classes.tuple.parser classes.tuple.private classes.tuple
+combinators compiler.tree.debugger compiler.units delegate
+destructors io.encodings.utf8 io.pathnames io.streams.string
+kernel libc literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
-tools.test parser lexer eval layouts ;
+tools.test parser lexer eval layouts generic.single classes
+vocabs generic classes.private definitions ;
FROM: math => float ;
+FROM: specialized-arrays.private => specialized-array-vocab ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int
{ z bool } ;
STRUCT: struct-test-bar
- { w ushort initial: HEX: ffff }
+ { w ushort initial: 0xffff }
{ foo struct-test-foo } ;
[ 12 ] [ struct-test-foo heap-size ] unit-test
[ {
{ "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
{ { "x" char } 98 }
- { { "y" int } HEX: 7F00007F }
+ { { "y" int } 0x7F00007F }
{ { "z" bool } f }
} ] [
B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
[ make-mirror clear-assoc ] keep
] unit-test
+[ POSTPONE: STRUCT: ]
+[ struct-test-foo struct-definer-word ] unit-test
+
UNION-STRUCT: struct-test-float-and-bits
{ f c:float }
{ bits uint } ;
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
+[ POSTPONE: UNION-STRUCT: ]
+[ struct-test-float-and-bits struct-definer-word ] unit-test
+
STRUCT: struct-test-string-ptr
- { x char* } ;
+ { x c-string } ;
[ "hello world" ] [
[
{ name "y" }
{ offset 4 }
{ initial 123 }
- { class integer }
+ { class $[ cell 4 = integer fixnum ? ] }
{ type int }
}
T{ struct-slot-spec
{ type bool }
{ class object }
}
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
+} ] [ struct-test-foo lookup-c-type fields>> ] unit-test
[ {
T{ struct-slot-spec
{ name "bits" }
{ offset 0 }
{ type uint }
- { class integer }
+ { class $[ cell 4 = integer fixnum ? ] }
{ initial 0 }
}
-} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+} ] [ struct-test-float-and-bits lookup-c-type fields>> ] unit-test
STRUCT: struct-test-equality-1
{ x int } ;
STRUCT: struct-test-equality-2
{ y int } ;
+[ 0 ] [ struct-test-equality-1 new hashcode ] unit-test
+
[ t ] [
[
struct-test-equality-1 <struct> 5 >>x
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
- [ 3 <direct-struct-test-optimization-array> third y>> ]
+ [ 3 struct-test-optimization <c-direct-array> third y>> ]
{ <tuple> <tuple-boa> memory>struct y>> } inlined?
] unit-test
[ t ] [
[ struct-test-optimization memory>struct x>> second ]
- { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
+ { memory>struct x>> int <c-direct-array> <tuple> <tuple-boa> } inlined?
] unit-test
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
{ x>> } inlined?
] unit-test
+[ ] [
+ [
+ struct-test-optimization specialized-array-vocab forget-vocab
+ ] with-compilation-unit
+] unit-test
+
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
clone-test-struct <struct>
1 >>x char-array{ 9 1 1 } >>y
clone
- [ x>> ] [ y>> >char-array ] bi
+ [ x>> ] [ y>> char >c-array ] bi
] unit-test
[ t 1 char-array{ 9 1 1 } ] [
clone-test-struct malloc-struct &free
1 >>x char-array{ 9 1 1 } >>y
clone
- [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
+ [ >c-ptr byte-array? ] [ x>> ] [ y>> char >c-array ] tri
] with-destructors
] unit-test
"struct-class-test-1" parse-stream
] [ error>> error>> unexpected-eof? ] must-fail-with
+[
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
+] [ error>> duplicate-slot-names? ] must-fail-with
+
+[
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
+] [ error>> duplicate-slot-names? ] must-fail-with
+
! S{ with non-struct type
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value )
-] must-fail
+] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed
[
- "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- )
-] must-fail
+] [ error>> bad-superclass? ] must-fail-with
-! Remove c-type when struct class is forgotten
-[ ] [
- "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
-] unit-test
+! Changing a superclass into a struct should reset the subclass
+TUPLE: will-become-struct ;
+
+TUPLE: a-subclass < will-become-struct ;
+
+[ f ] [ will-become-struct struct-class? ] unit-test
+
+[ will-become-struct ] [ a-subclass superclass ] unit-test
-[ f ] [ "a-struct" c-types get key? ] unit-test
+[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
+
+[ t ] [ will-become-struct struct-class? ] unit-test
+
+[ tuple ] [ a-subclass superclass ] unit-test
STRUCT: bit-field-test
{ a uint bits: 12 }
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test
+STRUCT: referent
+ { y int } ;
+STRUCT: referrer
+ { x referent* } ;
+
+[ 57 ] [
+ [
+ referrer <struct>
+ referent malloc-struct &free
+ 57 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
+STRUCT: self-referent
+ { x self-referent* }
+ { y int } ;
+
+[ 75 ] [
+ [
+ self-referent <struct>
+ self-referent malloc-struct &free
+ 75 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
+C-TYPE: forward-referent
+STRUCT: backward-referent
+ { x forward-referent* }
+ { y int } ;
+STRUCT: forward-referent
+ { x backward-referent* }
+ { y int } ;
+
+[ 41 ] [
+ [
+ forward-referent <struct>
+ backward-referent malloc-struct &free
+ 41 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
+[ 14 ] [
+ [
+ backward-referent <struct>
+ forward-referent malloc-struct &free
+ 14 >>y
+ >>x
+ x>> y>>
+ ] with-destructors
+] unit-test
+
cpu ppc? [
STRUCT: ppc-align-test-1
{ x longlong }
{ y int }
{ x longlong } ;
- [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
- [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+ [ 16 ] [ ppc-align-test-2 heap-size ] unit-test
+ [ 8 ] [ "x" ppc-align-test-2 offset-of ] unit-test
] when
+
+STRUCT: struct-test-delegate
+ { a int } ;
+STRUCT: struct-test-delegator
+ { del struct-test-delegate }
+ { b int } ;
+CONSULT: struct-test-delegate struct-test-delegator del>> ;
+
+[ S{ struct-test-delegator f S{ struct-test-delegate f 7 } 8 } ] [
+ struct-test-delegator <struct>
+ 7 >>a
+ 8 >>b
+] unit-test
+
+SPECIALIZED-ARRAY: void*
+
+STRUCT: silly-array-field-test { x int*[3] } ;
+
+[ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
+
+! Packed structs
+PACKED-STRUCT: packed-struct-test
+ { d c:int }
+ { e c:short }
+ { f c:int }
+ { g c:char }
+ { h c:int } ;
+
+[ 15 ] [ packed-struct-test heap-size ] unit-test
+
+[ 0 ] [ "d" packed-struct-test offset-of ] unit-test
+[ 4 ] [ "e" packed-struct-test offset-of ] unit-test
+[ 6 ] [ "f" packed-struct-test offset-of ] unit-test
+[ 10 ] [ "g" packed-struct-test offset-of ] unit-test
+[ 11 ] [ "h" packed-struct-test offset-of ] unit-test
+
+[ POSTPONE: PACKED-STRUCT: ]
+[ packed-struct-test struct-definer-word ] unit-test
+
+STRUCT: struct-1 { a c:int } ;
+PACKED-STRUCT: struct-1-packed { a c:int } ;
+UNION-STRUCT: struct-1-union { a c:int } ;
+
+[ "USING: alien.c-types classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-1 { a int initial: 0 } ;
+" ]
+[ \ struct-1 [ see ] with-string-writer ] unit-test
+[ "USING: alien.c-types classes.struct ;
+IN: classes.struct.tests
+PACKED-STRUCT: struct-1-packed { a int initial: 0 } ;
+" ]
+[ \ struct-1-packed [ see ] with-string-writer ] unit-test
+[ "USING: alien.c-types classes.struct ;
+IN: classes.struct.tests
+STRUCT: struct-1-union { a int initial: 0 } ;
+" ]
+[ \ struct-1-union [ see ] with-string-writer ] unit-test
+
+! Bug #206
+STRUCT: going-to-redefine { a uint } ;
+[ ] [
+ "IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- )
+] unit-test
+[ f ] [ \ going-to-redefine \ clone ?lookup-method ] unit-test
+[ f ] [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test
+
+! Test reset-class on structs, which should forget all the accessors, clone, and struct-slot-values
+STRUCT: some-accessors { aaa uint } { bbb int } ;
+[ ] [ [ \ some-accessors reset-class ] with-compilation-unit ] unit-test
+[ f ] [ \ some-accessors \ a>> ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ a<< ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ b>> ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ b<< ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ clone ?lookup-method ] unit-test
+[ f ] [ \ some-accessors \ struct-slot-values ?lookup-method ] unit-test
+
+<< \ some-accessors forget >>
projects / factor.git / blobdiff