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