basis/classes/struct/struct-tests.factor

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