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