basis/classes/struct/struct-tests.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.libraries
   3 alien.structs.fields alien.syntax ascii byte-arrays classes.struct
   4 combinators destructors io.encodings.utf8 io.pathnames io.streams.string
   5 kernel libc literals math multiline namespaces prettyprint
   6 prettyprint.config see sequences specialized-arrays.ushort
   7 system tools.test compiler.tree.debugger struct-arrays
   8 classes.tuple.private specialized-arrays.direct.int
   9 compiler.units specialized-arrays.char ;
  10 IN: classes.struct.tests
  11
  12 <<
  13 : libfactor-ffi-tests-path ( -- string )
  14     "resource:" (normalize-path)
  15     {
  16         { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
  17         { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
  18         { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
  19     } cond append-path ;
  20
  21 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
  22
  23 "f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
  24 >>
  25
  26 SYMBOL: struct-test-empty
  27
  28 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
  29 [ struct-must-have-slots? ] must-fail-with
  30
  31 STRUCT: struct-test-foo
  32     { x char }
  33     { y int initial: 123 }
  34     { z bool } ;
  35
  36 STRUCT: struct-test-bar
  37     { w ushort initial: HEX: ffff }
  38     { foo struct-test-foo } ;
  39
  40 [ 12 ] [ struct-test-foo heap-size ] unit-test
  41 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
  42 [ 16 ] [ struct-test-bar heap-size ] unit-test
  43 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
  44 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
  45
  46 [ 1 2 3 t ] [
  47     1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
  48     {
  49         [ w>> ]
  50         [ foo>> x>> ]
  51         [ foo>> y>> ]
  52         [ foo>> z>> ]
  53     } cleave
  54 ] unit-test
  55
  56 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
  57 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
  58
  59 UNION-STRUCT: struct-test-float-and-bits
  60     { f float }
  61     { bits uint } ;
  62
  63 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
  64 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
  65
  66 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
  67
  68 STRUCT: struct-test-string-ptr
  69     { x char* } ;
  70
  71 [ "hello world" ] [
  72     [
  73         struct-test-string-ptr <struct>
  74         "hello world" utf8 malloc-string &free >>x
  75         x>>
  76     ] with-destructors
  77 ] unit-test
  78
  79 [ "S{ struct-test-foo { y 7654 } }" ]
  80 [
  81     [
  82         boa-tuples? off
  83         c-object-pointers? off
  84         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
  85     ] with-scope
  86 ] unit-test
  87
  88 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
  89 [
  90     [
  91         c-object-pointers? on
  92         12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
  93     ] with-scope
  94 ] unit-test
  95
  96 [ "S{ struct-test-foo f 0 7654 f }" ]
  97 [
  98     [
  99         boa-tuples? on
 100         c-object-pointers? off
 101         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 102     ] with-scope
 103 ] unit-test
 104
 105 [ "S@ struct-test-foo f" ]
 106 [
 107     [
 108         c-object-pointers? off
 109         f struct-test-foo memory>struct [ pprint ] with-string-writer
 110     ] with-scope
 111 ] unit-test
 112
 113 [ <" USING: classes.struct ;
 114 IN: classes.struct.tests
 115 STRUCT: struct-test-foo
 116     { x char initial: 0 } { y int initial: 123 } { z bool } ;
 117 "> ]
 118 [ [ struct-test-foo see ] with-string-writer ] unit-test
 119
 120 [ <" USING: classes.struct ;
 121 IN: classes.struct.tests
 122 UNION-STRUCT: struct-test-float-and-bits
 123     { f float initial: 0.0 } { bits uint initial: 0 } ;
 124 "> ]
 125 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
 126
 127 [ {
 128     T{ field-spec
 129         { name "x" }
 130         { offset 0 }
 131         { type "char" }
 132         { reader x>> }
 133         { writer (>>x) }
 134     }
 135     T{ field-spec
 136         { name "y" }
 137         { offset 4 }
 138         { type "int" }
 139         { reader y>> }
 140         { writer (>>y) }
 141     }
 142     T{ field-spec
 143         { name "z" }
 144         { offset 8 }
 145         { type "bool" }
 146         { reader z>> }
 147         { writer (>>z) }
 148     }
 149 } ] [ "struct-test-foo" c-type fields>> ] unit-test
 150
 151 [ {
 152     T{ field-spec
 153         { name "f" }
 154         { offset 0 }
 155         { type "float" }
 156         { reader f>> }
 157         { writer (>>f) }
 158     }
 159     T{ field-spec
 160         { name "bits" }
 161         { offset 0 }
 162         { type "uint" }
 163         { reader bits>> }
 164         { writer (>>bits) }
 165     }
 166 } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
 167
 168 STRUCT: struct-test-equality-1
 169     { x int } ;
 170 STRUCT: struct-test-equality-2
 171     { y int } ;
 172
 173 [ t ] [
 174     [
 175         struct-test-equality-1 <struct> 5 >>x
 176         struct-test-equality-1 malloc-struct &free 5 >>x =
 177     ] with-destructors
 178 ] unit-test
 179
 180 [ f ] [
 181     [
 182         struct-test-equality-1 <struct> 5 >>x
 183         struct-test-equality-2 malloc-struct &free 5 >>y =
 184     ] with-destructors
 185 ] unit-test
 186
 187 [ t ] [
 188     [
 189         struct-test-equality-1 <struct> 5 >>x
 190         struct-test-equality-1 malloc-struct &free 5 >>x
 191         [ hashcode ] bi@ =
 192     ] with-destructors
 193 ] unit-test
 194
 195 STRUCT: struct-test-ffi-foo
 196     { x int }
 197     { y int } ;
 198
 199 LIBRARY: f-cdecl
 200 FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
 201
 202 [ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
 203
 204 STRUCT: struct-test-array-slots
 205     { x int }
 206     { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
 207     { z int } ;
 208
 209 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
 210
 211 [ t ] [
 212     struct-test-array-slots <struct>
 213     [ y>> [ 8 3 ] dip set-nth ]
 214     [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
 215 ] unit-test
 216
 217 STRUCT: struct-test-optimization
 218     { x { "int" 3 } } { y int } ;
 219
 220 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 221 [ t ] [
 222     [ 3 struct-test-optimization <direct-struct-array> third y>> ]
 223     { <tuple> <tuple-boa> memory>struct y>> } inlined?
 224 ] unit-test
 225
 226 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 227
 228 [ t ] [
 229     [ struct-test-optimization memory>struct x>> second ]
 230     { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
 231 ] unit-test
 232
 233 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 234
 235 ! Test cloning structs
 236 STRUCT: clone-test-struct { x int } { y char[3] } ;
 237
 238 [ 1 char-array{ 9 1 1 } ] [
 239     clone-test-struct <struct>
 240     1 >>x char-array{ 9 1 1 } >>y
 241     clone
 242     [ x>> ] [ y>> >char-array ] bi
 243 ] unit-test
 244
 245 [ t 1 char-array{ 9 1 1 } ] [
 246     [
 247         clone-test-struct malloc-struct &free
 248         1 >>x char-array{ 9 1 1 } >>y
 249         clone
 250         [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
 251     ] with-destructors
 252 ] unit-test
 253
 254 STRUCT: struct-that's-a-word { x int } ;
 255
 256 : struct-that's-a-word ( -- ) "OOPS" throw ;
 257
 258 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test