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