basis/classes/struct/struct-tests.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data ascii
   3 assocs byte-arrays classes.struct classes.tuple.private classes.tuple
   4 combinators compiler.tree.debugger compiler.units destructors
   5 io.encodings.utf8 io.pathnames io.streams.string kernel libc
   6 literals math mirrors namespaces prettyprint
   7 prettyprint.config see sequences specialized-arrays system
   8 tools.test parser lexer eval layouts generic.single classes ;
   9 FROM: math => float ;
  10 QUALIFIED-WITH: alien.c-types c
  11 SPECIALIZED-ARRAY: char
  12 SPECIALIZED-ARRAY: int
  13 SPECIALIZED-ARRAY: ushort
  14 IN: classes.struct.tests
  15
  16 SYMBOL: struct-test-empty
  17
  18 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
  19 [ struct-must-have-slots? ] must-fail-with
  20
  21 STRUCT: struct-test-foo
  22     { x char }
  23     { y int initial: 123 }
  24     { z bool } ;
  25
  26 STRUCT: struct-test-bar
  27     { w ushort initial: HEX: ffff }
  28     { foo struct-test-foo } ;
  29
  30 [ 12 ] [ struct-test-foo heap-size ] unit-test
  31 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
  32 [ 16 ] [ struct-test-bar heap-size ] unit-test
  33 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
  34 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
  35
  36 [ 1 2 3 t ] [
  37     1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
  38     {
  39         [ w>> ]
  40         [ foo>> x>> ]
  41         [ foo>> y>> ]
  42         [ foo>> z>> ]
  43     } cleave
  44 ] unit-test
  45
  46 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
  47 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
  48
  49 [ {
  50     { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
  51     { { "x" char } 98            }
  52     { { "y" int  } HEX: 7F00007F }
  53     { { "z" bool } f             }
  54 } ] [
  55     B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
  56     make-mirror >alist
  57 ] unit-test
  58
  59 [ { { "underlying" f } } ] [
  60     f struct-test-foo memory>struct
  61     make-mirror >alist
  62 ] unit-test
  63
  64 [ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
  65 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int"  } swap at* ] unit-test
  66 [ t  t ] [ S{ struct-test-foo { z t  } } make-mirror { "z" "bool" } swap at* ] unit-test
  67 [ f  t ] [ S{ struct-test-foo { z f  } } make-mirror { "z" "bool" } swap at* ] unit-test
  68 [ f  f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
  69 [ f  f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
  70 [ f  t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
  71
  72 [ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
  73     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  74     [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
  75 ] unit-test
  76
  77 [ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
  78     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  79     [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
  80 ] unit-test
  81
  82 [ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
  83     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  84     [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
  85 ] unit-test
  86
  87 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
  88     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  89     [ make-mirror [ "nonsense" "underlying" ] dip set-at ] keep
  90 ] unit-test
  91
  92 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
  93     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  94     [ make-mirror [ "nonsense" "nonexist" ] 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" { "nonexist" "int" } ] dip set-at ] keep
 100 ] unit-test
 101
 102 [ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
 103     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 104     [ make-mirror { "y" "int" } swap delete-at ] keep
 105 ] unit-test
 106
 107 [ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
 108     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 109     [ make-mirror { "x" "char" } swap delete-at ] keep
 110 ] unit-test
 111
 112 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
 113     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 114     [ make-mirror { "nonexist" "char" } swap delete-at ] keep
 115 ] unit-test
 116
 117 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
 118     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 119     [ make-mirror "underlying" 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 "nonsense" swap delete-at ] keep
 125 ] unit-test
 126
 127 [ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
 128     S{ struct-test-foo { x 1 } { y 2 } { z t } }
 129     [ make-mirror clear-assoc ] keep
 130 ] unit-test
 131
 132 UNION-STRUCT: struct-test-float-and-bits
 133     { f c:float }
 134     { bits uint } ;
 135
 136 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
 137 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 138
 139 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 140
 141 STRUCT: struct-test-string-ptr
 142     { x char* } ;
 143
 144 [ "hello world" ] [
 145     [
 146         struct-test-string-ptr <struct>
 147         "hello world" utf8 malloc-string &free >>x
 148         x>>
 149     ] with-destructors
 150 ] unit-test
 151
 152 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
 153 [
 154     [
 155         boa-tuples? off
 156         c-object-pointers? off
 157         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 158     ] with-scope
 159 ] unit-test
 160
 161 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
 162 [
 163     [
 164         c-object-pointers? on
 165         12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
 166     ] with-scope
 167 ] unit-test
 168
 169 [ "S{ struct-test-foo f 0 7654 f }" ]
 170 [
 171     [
 172         boa-tuples? on
 173         c-object-pointers? off
 174         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 175     ] with-scope
 176 ] unit-test
 177
 178 [ "S@ struct-test-foo f" ]
 179 [
 180     [
 181         c-object-pointers? off
 182         f struct-test-foo memory>struct [ pprint ] with-string-writer
 183     ] with-scope
 184 ] unit-test
 185
 186 [ "USING: alien.c-types classes.struct ;
 187 IN: classes.struct.tests
 188 STRUCT: struct-test-foo
 189     { x char initial: 0 } { y int initial: 123 } { z bool } ;
 190 " ]
 191 [ [ struct-test-foo see ] with-string-writer ] unit-test
 192
 193 [ "USING: alien.c-types classes.struct ;
 194 IN: classes.struct.tests
 195 UNION-STRUCT: struct-test-float-and-bits
 196     { f float initial: 0.0 } { bits uint initial: 0 } ;
 197 " ]
 198 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
 199
 200 [ {
 201     T{ struct-slot-spec
 202         { name "x" }
 203         { offset 0 }
 204         { initial 0 }
 205         { class fixnum }
 206         { type char }
 207     }
 208     T{ struct-slot-spec
 209         { name "y" }
 210         { offset 4 }
 211         { initial 123 }
 212         { class integer }
 213         { type int }
 214     }
 215     T{ struct-slot-spec
 216         { name "z" }
 217         { offset 8 }
 218         { initial f }
 219         { type bool }
 220         { class object }
 221     }
 222 } ] [ struct-test-foo c-type fields>> ] unit-test
 223
 224 [ {
 225     T{ struct-slot-spec
 226         { name "f" }
 227         { offset 0 }
 228         { type c:float }
 229         { class float }
 230         { initial 0.0 }
 231     }
 232     T{ struct-slot-spec
 233         { name "bits" }
 234         { offset 0 }
 235         { type uint }
 236         { class integer }
 237         { initial 0 }
 238     }
 239 } ] [ struct-test-float-and-bits c-type fields>> ] unit-test
 240
 241 STRUCT: struct-test-equality-1
 242     { x int } ;
 243 STRUCT: struct-test-equality-2
 244     { y int } ;
 245
 246 [ t ] [
 247     [
 248         struct-test-equality-1 <struct> 5 >>x
 249         struct-test-equality-1 malloc-struct &free 5 >>x =
 250     ] with-destructors
 251 ] unit-test
 252
 253 [ f ] [
 254     [
 255         struct-test-equality-1 <struct> 5 >>x
 256         struct-test-equality-2 malloc-struct &free 5 >>y =
 257     ] with-destructors
 258 ] unit-test
 259
 260 [ t ] [
 261     [
 262         struct-test-equality-1 <struct> 5 >>x
 263         struct-test-equality-1 malloc-struct &free 5 >>x
 264         [ hashcode ] bi@ =
 265     ] with-destructors
 266 ] unit-test
 267
 268 STRUCT: struct-test-array-slots
 269     { x int }
 270     { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
 271     { z int } ;
 272
 273 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
 274
 275 [ t ] [
 276     struct-test-array-slots <struct>
 277     [ y>> [ 8 3 ] dip set-nth ]
 278     [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
 279 ] unit-test
 280
 281 STRUCT: struct-test-optimization
 282     { x { int 3 } } { y int } ;
 283
 284 SPECIALIZED-ARRAY: struct-test-optimization
 285
 286 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 287 [ t ] [
 288     [ 3 <direct-struct-test-optimization-array> third y>> ]
 289     { <tuple> <tuple-boa> memory>struct y>> } inlined?
 290 ] unit-test
 291
 292 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 293
 294 [ t ] [
 295     [ struct-test-optimization memory>struct x>> second ]
 296     { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
 297 ] unit-test
 298
 299 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 300
 301 [ t ] [
 302     [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
 303     { x>> } inlined?
 304 ] unit-test
 305
 306 ! Test cloning structs
 307 STRUCT: clone-test-struct { x int } { y char[3] } ;
 308
 309 [ 1 char-array{ 9 1 1 } ] [
 310     clone-test-struct <struct>
 311     1 >>x char-array{ 9 1 1 } >>y
 312     clone
 313     [ x>> ] [ y>> >char-array ] bi
 314 ] unit-test
 315
 316 [ t 1 char-array{ 9 1 1 } ] [
 317     [
 318         clone-test-struct malloc-struct &free
 319         1 >>x char-array{ 9 1 1 } >>y
 320         clone
 321         [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
 322     ] with-destructors
 323 ] unit-test
 324
 325 STRUCT: struct-that's-a-word { x int } ;
 326
 327 : struct-that's-a-word ( -- ) "OOPS" throw ;
 328
 329 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
 330
 331 ! Interactive parsing of struct slot definitions
 332 [
 333     "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
 334     "struct-class-test-1" parse-stream
 335 ] [ error>> error>> unexpected-eof? ] must-fail-with
 336
 337 ! S{ with non-struct type
 338 [
 339     "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
 340     eval( -- value )
 341 ] [ error>> no-method? ] must-fail-with
 342
 343 ! Subclassing a struct class should not be allowed
 344 [
 345     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
 346     eval( -- )
 347 ] [ error>> bad-superclass? ] must-fail-with
 348
 349 ! Changing a superclass into a struct should reset the subclass
 350 TUPLE: will-become-struct ;
 351
 352 TUPLE: a-subclass < will-become-struct ;
 353
 354 [ f ] [ will-become-struct struct-class? ] unit-test
 355
 356 [ will-become-struct ] [ a-subclass superclass ] unit-test
 357
 358 [ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
 359
 360 [ t ] [ will-become-struct struct-class? ] unit-test
 361
 362 [ tuple ] [ a-subclass superclass ] unit-test
 363
 364 STRUCT: bit-field-test
 365     { a uint bits: 12 }
 366     { b int bits: 2 }
 367     { c char } ;
 368
 369 [ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
 370 [ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
 371 [ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
 372 [ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
 373 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
 374 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
 375 [ 3 ] [ bit-field-test heap-size ] unit-test
 376
 377 cpu ppc? [
 378     STRUCT: ppc-align-test-1
 379         { x longlong }
 380         { y int } ;
 381
 382     [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
 383
 384     STRUCT: ppc-align-test-2
 385         { y int }
 386         { x longlong } ;
 387
 388     [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
 389     [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
 390 ] when