factor/basis/classes/struct/struct-tests.factor

562 lines
16 KiB
Factor

! Copyright (C) 2009, 2010, 2011 Joe Groff, Slava Pestov, John Benediktsson.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.syntax
assocs byte-arrays classes classes.private classes.struct
classes.struct.prettyprint.private classes.tuple
classes.tuple.parser classes.tuple.private combinators
compiler.tree.debugger compiler.units definitions delegate
destructors eval generic generic.single io.encodings.utf8
io.streams.string kernel layouts lexer libc literals math
mirrors namespaces parser prettyprint prettyprint.config see
sequences specialized-arrays specialized-arrays.private
system tools.test vocabs ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
SPECIALIZED-ARRAY: int
SPECIALIZED-ARRAY: ushort
IN: classes.struct.tests
SYMBOL: struct-test-empty
[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
[ struct-must-have-slots? ] must-fail-with
STRUCT: struct-test-foo
{ x char }
{ y int initial: 123 }
{ z bool } ;
STRUCT: struct-test-bar
{ w ushort initial: 0xffff }
{ foo struct-test-foo } ;
{ 12 } [ struct-test-foo heap-size ] unit-test
{ 12 } [ struct-test-foo <struct> byte-length ] unit-test
{ 16 } [ struct-test-bar heap-size ] unit-test
{ 123 } [ struct-test-foo <struct> y>> ] unit-test
{ 123 } [ struct-test-bar <struct> foo>> y>> ] unit-test
{ 1 2 3 t } [
1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
{
[ w>> ]
[ foo>> x>> ]
[ foo>> y>> ]
[ foo>> z>> ]
} cleave
] unit-test
{ 7654 } [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
{ 7654 } [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
{ {
{ "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
{ { "x" char } 98 }
{ { "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 >alist
] unit-test
{ { { "underlying" f } } } [
f struct-test-foo memory>struct
make-mirror >alist
] unit-test
{ 55 t } [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } ?of ] unit-test
{ 55 t } [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int" } ?of ] unit-test
{ t t } [ S{ struct-test-foo { z t } } make-mirror { "z" "bool" } ?of ] unit-test
{ f t } [ S{ struct-test-foo { z f } } make-mirror { "z" "bool" } ?of ] unit-test
{ { "nonexist" "bool" } f } [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } ?of ] unit-test
{ "nonexist" f } [ S{ struct-test-foo } make-mirror "nonexist" ?of ] unit-test
{ f t } [ f struct-test-foo memory>struct make-mirror "underlying" ?of ] unit-test
{ S{ struct-test-foo { x 3 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 5 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 2 } { z t } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 123 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror { "y" "int" } swap delete-at ] keep
] unit-test
{ S{ struct-test-foo { x 0 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror { "x" "char" } swap delete-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror { "nonexist" "char" } swap delete-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror "underlying" swap delete-at ] keep
] unit-test
{ S{ struct-test-foo { x 1 } { y 2 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z f } }
[ make-mirror "nonsense" swap delete-at ] keep
] unit-test
{ S{ struct-test-foo { x 0 } { y 123 } { z f } } } [
S{ struct-test-foo { x 1 } { y 2 } { z t } }
[ 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 } ;
{ 1.0 } [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
{ 4 } [ struct-test-float-and-bits heap-size ] unit-test
{ 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 c-string } ;
{ "hello world" } [
[
struct-test-string-ptr <struct>
"hello world" utf8 malloc-string &free >>x
x>>
] with-destructors
] unit-test
{ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" }
[
H{ { boa-tuples? f } { c-object-pointers? f } } [
struct-test-foo <struct> 7654 >>y unparse
] with-variables
] unit-test
{ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" }
[
H{ { c-object-pointers? t } } [
12 <byte-array> struct-test-foo memory>struct unparse
] with-variables
] unit-test
{ "S{ struct-test-foo f 0 7654 f }" }
[
H{ { boa-tuples? t } { c-object-pointers? f } } [
struct-test-foo <struct> 7654 >>y unparse
] with-variables
] unit-test
{ "S@ struct-test-foo f" }
[
H{ { c-object-pointers? f } } [
f struct-test-foo memory>struct unparse
] with-variables
] unit-test
{ "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: 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
{ {
T{ struct-slot-spec
{ name "x" }
{ offset 0 }
{ initial 0 }
{ class fixnum }
{ type char }
}
T{ struct-slot-spec
{ name "y" }
{ offset 4 }
{ initial 123 }
{ class $[ cell 4 = integer fixnum ? ] }
{ type int }
}
T{ struct-slot-spec
{ name "z" }
{ offset 8 }
{ initial f }
{ type bool }
{ class object }
}
} } [ struct-test-foo lookup-c-type fields>> ] unit-test
{ {
T{ struct-slot-spec
{ name "f" }
{ offset 0 }
{ type c:float }
{ class float }
{ initial 0.0 }
}
T{ struct-slot-spec
{ name "bits" }
{ offset 0 }
{ type uint }
{ class $[ cell 4 = integer fixnum ? ] }
{ initial 0 }
}
} } [ 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 } ;
{ t } [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-1 malloc-struct &free 5 >>x =
] with-destructors
] unit-test
{ f } [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-2 malloc-struct &free 5 >>y =
] with-destructors
] unit-test
STRUCT: struct-test-array-slots
{ x int }
{ y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
{ z int } ;
{ 11 } [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
{ t } [
struct-test-array-slots <struct>
[ y>> [ 8 3 ] dip set-nth ]
[ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
] unit-test
STRUCT: struct-test-optimization
{ x { int 3 } } { y int } ;
SPECIALIZED-ARRAY: struct-test-optimization
{ t } [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
{ t } [
[ 3 struct-test-optimization <c-direct-array> third y>> ]
{ <tuple> <tuple-boa> memory>struct y>> } inlined?
] unit-test
{ t } [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
{ t } [
[ struct-test-optimization memory>struct x>> second ]
{ memory>struct x>> int <c-direct-array> <tuple> <tuple-boa> } inlined?
] unit-test
{ f } [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
{ t } [
[ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
{ 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] } ;
{ 1 char-array{ 9 1 1 } } [
clone-test-struct <struct>
1 >>x char-array{ 9 1 1 } >>y
clone
[ 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 >c-array ] tri
] with-destructors
] unit-test
STRUCT: struct-that's-a-word { x int } ;
: struct-that's-a-word ( -- ) "OOPS" throw ;
{ -77 } [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
! Interactive parsing of struct slot definitions
[
"USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
"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 )
] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed
[
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- )
] [ error>> bad-superclass? ] must-fail-with
! 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-of ] 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-of ] 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
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 } ;
[ 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 >>
! hashcode tests
{ 0 } [ struct-test-equality-1 new hashcode ] unit-test
{ t } [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-1 malloc-struct &free 5 >>x
[ hashcode ] same?
] with-destructors
] unit-test
! Same slots, so the hashcode should be the same.
{ t } [
B{ 98 0 33 0 1 1 1 1 1 1 1 1 } struct-test-foo memory>struct
B{ 98 0 22 0 1 1 1 1 1 1 1 1 } struct-test-foo memory>struct
[ hashcode ] same?
] unit-test
! Equality tests
{ t } [
B{ 98 0 33 0 1 1 1 1 1 1 1 1 } struct-test-foo memory>struct
B{ 98 0 22 0 1 1 1 1 1 1 1 1 } struct-test-foo memory>struct
=
] unit-test