basis/classes/struct/struct-tests.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data alien.syntax
   3 ascii assocs byte-arrays classes.struct
   4 classes.struct.prettyprint classes.struct.prettyprint.private
   5 classes.tuple.parser classes.tuple.private classes.tuple
   6 combinators compiler.tree.debugger compiler.units delegate
   7 destructors io.encodings.utf8 io.pathnames io.streams.string
   8 kernel libc literals math mirrors namespaces prettyprint
   9 prettyprint.config see sequences specialized-arrays system
  10 tools.test parser lexer eval layouts generic.single classes
  11 vocabs generic classes.private definitions ;
  12 FROM: math => float ;
  13 FROM: specialized-arrays.private => specialized-array-vocab ;
  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" } swap at* ] unit-test
  69 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int"  } swap at* ] unit-test
  70 [ t  t ] [ S{ struct-test-foo { z t  } } make-mirror { "z" "bool" } swap at* ] unit-test
  71 [ f  t ] [ S{ struct-test-foo { z f  } } make-mirror { "z" "bool" } swap at* ] unit-test
  72 [ f  f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
  73 [ f  f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
  74 [ f  t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] 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 [ pprint ] with-string-writer
 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 [ pprint ] with-string-writer
 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 [ pprint ] with-string-writer
 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 [ pprint ] with-string-writer
 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 [ 0 ] [ struct-test-equality-1 new hashcode ] unit-test
 251
 252 [ t ] [
 253     [
 254         struct-test-equality-1 <struct> 5 >>x
 255         struct-test-equality-1 malloc-struct &free 5 >>x =
 256     ] with-destructors
 257 ] unit-test
 258
 259 [ f ] [
 260     [
 261         struct-test-equality-1 <struct> 5 >>x
 262         struct-test-equality-2 malloc-struct &free 5 >>y =
 263     ] with-destructors
 264 ] unit-test
 265
 266 [ t ] [
 267     [
 268         struct-test-equality-1 <struct> 5 >>x
 269         struct-test-equality-1 malloc-struct &free 5 >>x
 270         [ hashcode ] bi@ =
 271     ] with-destructors
 272 ] unit-test
 273
 274 STRUCT: struct-test-array-slots
 275     { x int }
 276     { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
 277     { z int } ;
 278
 279 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
 280
 281 [ t ] [
 282     struct-test-array-slots <struct>
 283     [ y>> [ 8 3 ] dip set-nth ]
 284     [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
 285 ] unit-test
 286
 287 STRUCT: struct-test-optimization
 288     { x { int 3 } } { y int } ;
 289
 290 SPECIALIZED-ARRAY: struct-test-optimization
 291
 292 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 293 [ t ] [
 294     [ 3 struct-test-optimization <c-direct-array> third y>> ]
 295     { <tuple> <tuple-boa> memory>struct y>> } inlined?
 296 ] unit-test
 297
 298 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 299
 300 [ t ] [
 301     [ struct-test-optimization memory>struct x>> second ]
 302     { memory>struct x>> int <c-direct-array> <tuple> <tuple-boa> } inlined?
 303 ] unit-test
 304
 305 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 306
 307 [ t ] [
 308     [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
 309     { x>> } inlined?
 310 ] unit-test
 311
 312 [ ] [
 313     [
 314         struct-test-optimization specialized-array-vocab forget-vocab
 315     ] with-compilation-unit
 316 ] unit-test
 317
 318 ! Test cloning structs
 319 STRUCT: clone-test-struct { x int } { y char[3] } ;
 320
 321 [ 1 char-array{ 9 1 1 } ] [
 322     clone-test-struct <struct>
 323     1 >>x char-array{ 9 1 1 } >>y
 324     clone
 325     [ x>> ] [ y>> char >c-array ] bi
 326 ] unit-test
 327
 328 [ t 1 char-array{ 9 1 1 } ] [
 329     [
 330         clone-test-struct malloc-struct &free
 331         1 >>x char-array{ 9 1 1 } >>y
 332         clone
 333         [ >c-ptr byte-array? ] [ x>> ] [ y>> char >c-array ] tri
 334     ] with-destructors
 335 ] unit-test
 336
 337 STRUCT: struct-that's-a-word { x int } ;
 338
 339 : struct-that's-a-word ( -- ) "OOPS" throw ;
 340
 341 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
 342
 343 ! Interactive parsing of struct slot definitions
 344 [
 345     "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
 346     "struct-class-test-1" parse-stream
 347 ] [ error>> error>> unexpected-eof? ] must-fail-with
 348
 349 [
 350     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
 351 ] [ error>> duplicate-slot-names? ] must-fail-with
 352
 353 [
 354     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
 355 ] [ error>> duplicate-slot-names? ] must-fail-with
 356
 357 ! S{ with non-struct type
 358 [
 359     "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
 360     eval( -- value )
 361 ] [ error>> no-method? ] must-fail-with
 362
 363 ! Subclassing a struct class should not be allowed
 364 [
 365     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
 366     eval( -- )
 367 ] [ error>> bad-superclass? ] must-fail-with
 368
 369 ! Changing a superclass into a struct should reset the subclass
 370 TUPLE: will-become-struct ;
 371
 372 TUPLE: a-subclass < will-become-struct ;
 373
 374 [ f ] [ will-become-struct struct-class? ] unit-test
 375
 376 [ will-become-struct ] [ a-subclass superclass ] unit-test
 377
 378 [ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
 379
 380 [ t ] [ will-become-struct struct-class? ] unit-test
 381
 382 [ tuple ] [ a-subclass superclass ] unit-test
 383
 384 STRUCT: bit-field-test
 385     { a uint bits: 12 }
 386     { b int bits: 2 }
 387     { c char } ;
 388
 389 [ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
 390 [ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
 391 [ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
 392 [ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
 393 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
 394 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
 395 [ 3 ] [ bit-field-test heap-size ] unit-test
 396
 397 STRUCT: referent
 398     { y int } ;
 399 STRUCT: referrer
 400     { x referent* } ;
 401
 402 [ 57 ] [
 403     [
 404         referrer <struct>
 405             referent malloc-struct &free
 406                 57 >>y
 407             >>x
 408         x>> y>>
 409     ] with-destructors
 410 ] unit-test
 411
 412 STRUCT: self-referent
 413     { x self-referent* }
 414     { y int } ;
 415
 416 [ 75 ] [
 417     [
 418         self-referent <struct>
 419             self-referent malloc-struct &free
 420                 75 >>y
 421             >>x
 422         x>> y>>
 423     ] with-destructors
 424 ] unit-test
 425
 426 C-TYPE: forward-referent
 427 STRUCT: backward-referent
 428     { x forward-referent* }
 429     { y int } ;
 430 STRUCT: forward-referent
 431     { x backward-referent* }
 432     { y int } ;
 433
 434 [ 41 ] [
 435     [
 436         forward-referent <struct>
 437             backward-referent malloc-struct &free
 438                 41 >>y
 439             >>x
 440         x>> y>>
 441     ] with-destructors
 442 ] unit-test
 443
 444 [ 14 ] [
 445     [
 446         backward-referent <struct>
 447             forward-referent malloc-struct &free
 448                 14 >>y
 449             >>x
 450         x>> y>>
 451     ] with-destructors
 452 ] unit-test
 453
 454 cpu ppc? [
 455     STRUCT: ppc-align-test-1
 456         { x longlong }
 457         { y int } ;
 458
 459     [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
 460
 461     STRUCT: ppc-align-test-2
 462         { y int }
 463         { x longlong } ;
 464
 465     [ 16 ] [ ppc-align-test-2 heap-size ] unit-test
 466     [ 8 ] [ "x" ppc-align-test-2 offset-of ] unit-test
 467 ] when
 468
 469 STRUCT: struct-test-delegate
 470     { a int } ;
 471 STRUCT: struct-test-delegator
 472     { del struct-test-delegate }
 473     { b int } ;
 474 CONSULT: struct-test-delegate struct-test-delegator del>> ;
 475
 476 [ S{ struct-test-delegator f S{ struct-test-delegate f 7 } 8 } ] [
 477     struct-test-delegator <struct>
 478         7 >>a
 479         8 >>b
 480 ] unit-test
 481
 482 SPECIALIZED-ARRAY: void*
 483
 484 STRUCT: silly-array-field-test { x int*[3] } ;
 485
 486 [ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
 487
 488 ! Packed structs
 489 PACKED-STRUCT: packed-struct-test
 490     { d c:int }
 491     { e c:short }
 492     { f c:int }
 493     { g c:char }
 494     { h c:int } ;
 495
 496 [ 15 ] [ packed-struct-test heap-size ] unit-test
 497
 498 [ 0 ] [ "d" packed-struct-test offset-of ] unit-test
 499 [ 4 ] [ "e" packed-struct-test offset-of ] unit-test
 500 [ 6 ] [ "f" packed-struct-test offset-of ] unit-test
 501 [ 10 ] [ "g" packed-struct-test offset-of ] unit-test
 502 [ 11 ] [ "h" packed-struct-test offset-of ] unit-test
 503
 504 [ POSTPONE: PACKED-STRUCT: ]
 505 [ packed-struct-test struct-definer-word ] unit-test
 506
 507 STRUCT: struct-1 { a c:int } ;
 508 PACKED-STRUCT: struct-1-packed { a c:int } ;
 509 UNION-STRUCT: struct-1-union { a c:int } ;
 510
 511 [ "USING: alien.c-types classes.struct ;
 512 IN: classes.struct.tests
 513 STRUCT: struct-1 { a int initial: 0 } ;
 514 " ]
 515 [ \ struct-1 [ see ] with-string-writer ] unit-test
 516 [ "USING: alien.c-types classes.struct ;
 517 IN: classes.struct.tests
 518 PACKED-STRUCT: struct-1-packed { a int initial: 0 } ;
 519 " ]
 520 [ \ struct-1-packed [ see ] with-string-writer ] unit-test
 521 [ "USING: alien.c-types classes.struct ;
 522 IN: classes.struct.tests
 523 STRUCT: struct-1-union { a int initial: 0 } ;
 524 " ]
 525 [ \ struct-1-union [ see ] with-string-writer ] unit-test
 526
 527 ! Bug #206
 528 STRUCT: going-to-redefine { a uint } ;
 529 [ ] [
 530     "IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- )
 531 ] unit-test
 532 [ f ] [ \ going-to-redefine \ clone ?lookup-method ] unit-test
 533 [ f ] [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test
 534
 535 ! Test reset-class on structs, which should forget all the accessors, clone, and struct-slot-values
 536 STRUCT: some-accessors { aaa uint } { bbb int } ;
 537 [ ] [ [ \ some-accessors reset-class ] with-compilation-unit ] unit-test
 538 [ f ] [ \ some-accessors \ a>> ?lookup-method ] unit-test
 539 [ f ] [ \ some-accessors \ a<< ?lookup-method ] unit-test
 540 [ f ] [ \ some-accessors \ b>> ?lookup-method ] unit-test
 541 [ f ] [ \ some-accessors \ b<< ?lookup-method ] unit-test
 542 [ f ] [ \ some-accessors \ clone ?lookup-method ] unit-test
 543 [ f ] [ \ some-accessors \ struct-slot-values ?lookup-method ] unit-test
 544
 545 << \ some-accessors forget >>