basis/classes/struct/struct-tests.factor

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