! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types ascii
-assocs byte-arrays classes.struct classes.tuple.private
+USING: accessors alien alien.c-types alien.data ascii
+assocs byte-arrays classes.struct classes.tuple.private classes.tuple
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
-literals math mirrors multiline namespaces prettyprint
+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 ;
+FROM: math => float ;
+QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: ushort
[ {
{ "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
- { { "x" "char" } 98 }
- { { "y" "int" } HEX: 7F00007F }
- { { "z" "bool" } f }
+ { { "x" char } 98 }
+ { { "y" int } HEX: 7F00007F }
+ { { "z" bool } f }
} ] [
B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
make-mirror >alist
] unit-test
UNION-STRUCT: struct-test-float-and-bits
- { f float }
+ { f c:float }
{ bits uint } ;
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
] with-scope
] unit-test
-[ <" USING: classes.struct ;
+[ "USING: alien.c-types classes.struct ;
IN: classes.struct.tests
STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { z bool } ;
-"> ]
+" ]
[ [ struct-test-foo see ] with-string-writer ] unit-test
-[ <" USING: classes.struct ;
+[ "USING: alien.c-types classes.struct ;
IN: classes.struct.tests
UNION-STRUCT: struct-test-float-and-bits
{ f float initial: 0.0 } { bits uint initial: 0 } ;
-"> ]
+" ]
[ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
[ {
{ offset 0 }
{ initial 0 }
{ class fixnum }
- { type "char" }
+ { type char }
}
T{ struct-slot-spec
{ name "y" }
{ offset 4 }
{ initial 123 }
{ class integer }
- { type "int" }
+ { type int }
}
T{ struct-slot-spec
{ name "z" }
{ offset 8 }
{ initial f }
- { type "bool" }
+ { type bool }
{ class object }
}
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
+} ] [ struct-test-foo c-type fields>> ] unit-test
[ {
T{ struct-slot-spec
{ name "f" }
{ offset 0 }
- { type "float" }
+ { type c:float }
{ class float }
{ initial 0.0 }
}
T{ struct-slot-spec
{ name "bits" }
{ offset 0 }
- { type "uint" }
+ { type uint }
{ class integer }
{ initial 0 }
}
-} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+} ] [ struct-test-float-and-bits c-type fields>> ] unit-test
STRUCT: struct-test-equality-1
{ x int } ;
] unit-test
STRUCT: struct-test-optimization
- { x { "int" 3 } } { y int } ;
+ { x { int 3 } } { y int } ;
SPECIALIZED-ARRAY: struct-test-optimization
[
"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( -- )
+! 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
+
+[ ] [ "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 }
+ { b int bits: 2 }
+ { c char } ;
+
+[ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
+[ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
+[ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
+[ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
+[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
+[ 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
-[ f ] [ "a-struct" c-types get key? ] 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 } ;
+
+ [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
+
+ STRUCT: ppc-align-test-2
+ { y int }
+ { x longlong } ;
+
+ [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
+ [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+] when
projects / factor.git / blobdiff