basis/classes/struct/struct-tests.factor

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