basis/classes/struct/struct-tests.factor

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