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 assocs byte-arrays
   4 classes.struct classes.tuple.private combinators
   5 compiler.tree.debugger compiler.units destructors
   6 io.encodings.utf8 io.pathnames io.streams.string kernel libc
   7 literals math mirrors multiline namespaces prettyprint
   8 prettyprint.config see sequences specialized-arrays.char
   9 specialized-arrays.int specialized-arrays.ushort
  10 struct-arrays system tools.test ;
  11 IN: classes.struct.tests
  12
  13 <<
  14 : libfactor-ffi-tests-path ( -- string )
  15     "resource:" (normalize-path)
  16     {
  17         { [ os winnt? ]  [ "libfactor-ffi-test.dll" ] }
  18         { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
  19         { [ os unix?  ]  [ "libfactor-ffi-test.so" ] }
  20     } cond append-path ;
  21
  22 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
  23
  24 "f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
  25 >>
  26
  27 SYMBOL: struct-test-empty
  28
  29 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
  30 [ struct-must-have-slots? ] must-fail-with
  31
  32 STRUCT: struct-test-foo
  33     { x char }
  34     { y int initial: 123 }
  35     { z bool } ;
  36
  37 STRUCT: struct-test-bar
  38     { w ushort initial: HEX: ffff }
  39     { foo struct-test-foo } ;
  40
  41 [ 12 ] [ struct-test-foo heap-size ] unit-test
  42 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
  43 [ 16 ] [ struct-test-bar heap-size ] unit-test
  44 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
  45 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
  46
  47 [ 1 2 3 t ] [
  48     1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
  49     {
  50         [ w>> ]
  51         [ foo>> x>> ]
  52         [ foo>> y>> ]
  53         [ foo>> z>> ]
  54     } cleave
  55 ] unit-test
  56
  57 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
  58 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
  59
  60 [ {
  61     { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
  62     { { "x" "char" } 98            }
  63     { { "y" "int"  } HEX: 7F00007F }
  64     { { "z" "bool" } f             }
  65 } ] [
  66     B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
  67     make-mirror >alist
  68 ] unit-test
  69
  70 [ { { "underlying" f } } ] [
  71     f struct-test-foo memory>struct
  72     make-mirror >alist
  73 ] unit-test
  74
  75 [ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
  76 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int"  } swap at* ] unit-test
  77 [ t  t ] [ S{ struct-test-foo { z t  } } make-mirror { "z" "bool" } swap at* ] unit-test
  78 [ f  t ] [ S{ struct-test-foo { z f  } } make-mirror { "z" "bool" } swap at* ] unit-test
  79 [ f  f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
  80 [ f  f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
  81 [ f  t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
  82
  83 [ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
  84     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  85     [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
  86 ] unit-test
  87
  88 [ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
  89     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  90     [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
  91 ] unit-test
  92
  93 [ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
  94     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  95     [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
  96 ] unit-test
  97
  98 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
  99     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 100     [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
 101 ] unit-test
 102
 103 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
 104     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 105     [ make-mirror [ "nonsense" "nonexist" ] dip set-at ] keep
 106 ] unit-test
 107
 108 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
 109     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 110     [ make-mirror [ "nonsense" { "nonexist" "int" } ] dip set-at ] keep
 111 ] unit-test
 112
 113 [ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
 114     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 115     [ make-mirror { "y" "int" } swap delete-at ] keep
 116 ] unit-test
 117
 118 [ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
 119     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 120     [ make-mirror { "x" "char" } swap delete-at ] keep
 121 ] unit-test
 122
 123 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
 124     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 125     [ make-mirror { "nonexist" "char" } swap delete-at ] keep
 126 ] unit-test
 127
 128 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
 129     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 130     [ make-mirror "underlying" swap delete-at ] keep
 131 ] unit-test
 132
 133 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
 134     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 135     [ make-mirror "nonsense" swap delete-at ] keep
 136 ] unit-test
 137
 138 [ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
 139     S{ struct-test-foo { x 1 } { y 2 } { z t } }
 140     [ make-mirror clear-assoc ] keep
 141 ] unit-test
 142
 143 UNION-STRUCT: struct-test-float-and-bits
 144     { f float }
 145     { bits uint } ;
 146
 147 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
 148 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 149
 150 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 151
 152 STRUCT: struct-test-string-ptr
 153     { x char* } ;
 154
 155 [ "hello world" ] [
 156     [
 157         struct-test-string-ptr <struct>
 158         "hello world" utf8 malloc-string &free >>x
 159         x>>
 160     ] with-destructors
 161 ] unit-test
 162
 163 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
 164 [
 165     [
 166         boa-tuples? off
 167         c-object-pointers? off
 168         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 169     ] with-scope
 170 ] unit-test
 171
 172 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
 173 [
 174     [
 175         c-object-pointers? on
 176         12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
 177     ] with-scope
 178 ] unit-test
 179
 180 [ "S{ struct-test-foo f 0 7654 f }" ]
 181 [
 182     [
 183         boa-tuples? on
 184         c-object-pointers? off
 185         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 186     ] with-scope
 187 ] unit-test
 188
 189 [ "S@ struct-test-foo f" ]
 190 [
 191     [
 192         c-object-pointers? off
 193         f struct-test-foo memory>struct [ pprint ] with-string-writer
 194     ] with-scope
 195 ] unit-test
 196
 197 [ <" USING: classes.struct ;
 198 IN: classes.struct.tests
 199 STRUCT: struct-test-foo
 200     { x char initial: 0 } { y int initial: 123 } { z bool } ;
 201 "> ]
 202 [ [ struct-test-foo see ] with-string-writer ] unit-test
 203
 204 [ <" USING: classes.struct ;
 205 IN: classes.struct.tests
 206 UNION-STRUCT: struct-test-float-and-bits
 207     { f float initial: 0.0 } { bits uint initial: 0 } ;
 208 "> ]
 209 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
 210
 211 [ {
 212     T{ field-spec
 213         { name "x" }
 214         { offset 0 }
 215         { type "char" }
 216         { reader x>> }
 217         { writer (>>x) }
 218     }
 219     T{ field-spec
 220         { name "y" }
 221         { offset 4 }
 222         { type "int" }
 223         { reader y>> }
 224         { writer (>>y) }
 225     }
 226     T{ field-spec
 227         { name "z" }
 228         { offset 8 }
 229         { type "bool" }
 230         { reader z>> }
 231         { writer (>>z) }
 232     }
 233 } ] [ "struct-test-foo" c-type fields>> ] unit-test
 234
 235 [ {
 236     T{ field-spec
 237         { name "f" }
 238         { offset 0 }
 239         { type "float" }
 240         { reader f>> }
 241         { writer (>>f) }
 242     }
 243     T{ field-spec
 244         { name "bits" }
 245         { offset 0 }
 246         { type "uint" }
 247         { reader bits>> }
 248         { writer (>>bits) }
 249     }
 250 } ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
 251
 252 STRUCT: struct-test-equality-1
 253     { x int } ;
 254 STRUCT: struct-test-equality-2
 255     { y int } ;
 256
 257 [ t ] [
 258     [
 259         struct-test-equality-1 <struct> 5 >>x
 260         struct-test-equality-1 malloc-struct &free 5 >>x =
 261     ] with-destructors
 262 ] unit-test
 263
 264 [ f ] [
 265     [
 266         struct-test-equality-1 <struct> 5 >>x
 267         struct-test-equality-2 malloc-struct &free 5 >>y =
 268     ] with-destructors
 269 ] unit-test
 270
 271 [ t ] [
 272     [
 273         struct-test-equality-1 <struct> 5 >>x
 274         struct-test-equality-1 malloc-struct &free 5 >>x
 275         [ hashcode ] bi@ =
 276     ] with-destructors
 277 ] unit-test
 278
 279 STRUCT: struct-test-ffi-foo
 280     { x int }
 281     { y int } ;
 282
 283 LIBRARY: f-cdecl
 284 FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
 285
 286 [ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
 287
 288 STRUCT: struct-test-array-slots
 289     { x int }
 290     { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
 291     { z int } ;
 292
 293 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
 294
 295 [ t ] [
 296     struct-test-array-slots <struct>
 297     [ y>> [ 8 3 ] dip set-nth ]
 298     [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
 299 ] unit-test
 300
 301 STRUCT: struct-test-optimization
 302     { x { "int" 3 } } { y int } ;
 303
 304 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 305 [ t ] [
 306     [ 3 struct-test-optimization <direct-struct-array> third y>> ]
 307     { <tuple> <tuple-boa> memory>struct y>> } inlined?
 308 ] unit-test
 309
 310 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 311
 312 [ t ] [
 313     [ struct-test-optimization memory>struct x>> second ]
 314     { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
 315 ] unit-test
 316
 317 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 318
 319 [ t ] [
 320     [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
 321     { x>> } inlined?
 322 ] unit-test
 323
 324 ! Test cloning structs
 325 STRUCT: clone-test-struct { x int } { y char[3] } ;
 326
 327 [ 1 char-array{ 9 1 1 } ] [
 328     clone-test-struct <struct>
 329     1 >>x char-array{ 9 1 1 } >>y
 330     clone
 331     [ x>> ] [ y>> >char-array ] bi
 332 ] unit-test
 333
 334 [ t 1 char-array{ 9 1 1 } ] [
 335     [
 336         clone-test-struct malloc-struct &free
 337         1 >>x char-array{ 9 1 1 } >>y
 338         clone
 339         [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
 340     ] with-destructors
 341 ] unit-test
 342
 343 STRUCT: struct-that's-a-word { x int } ;
 344
 345 : struct-that's-a-word ( -- ) "OOPS" throw ;
 346
 347 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
 348