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     [
 165         boa-tuples? off
 166         c-object-pointers? off
 167         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 168     ] with-scope
 169 ] unit-test
 170
 171 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
 172 [
 173     [
 174         c-object-pointers? on
 175         12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
 176     ] with-scope
 177 ] unit-test
 178
 179 [ "S{ struct-test-foo f 0 7654 f }" ]
 180 [
 181     [
 182         boa-tuples? on
 183         c-object-pointers? off
 184         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 185     ] with-scope
 186 ] unit-test
 187
 188 [ "S@ struct-test-foo f" ]
 189 [
 190     [
 191         c-object-pointers? off
 192         f struct-test-foo memory>struct [ pprint ] with-string-writer
 193     ] with-scope
 194 ] unit-test
 195
 196 [ "USING: alien.c-types classes.struct ;
 197 IN: classes.struct.tests
 198 STRUCT: struct-test-foo
 199     { x char initial: 0 } { y int initial: 123 } { z bool } ;
 200 " ]
 201 [ [ struct-test-foo see ] with-string-writer ] unit-test
 202
 203 [ "USING: alien.c-types classes.struct ;
 204 IN: classes.struct.tests
 205 UNION-STRUCT: struct-test-float-and-bits
 206     { f float initial: 0.0 } { bits uint initial: 0 } ;
 207 " ]
 208 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
 209
 210 [ {
 211     T{ struct-slot-spec
 212         { name "x" }
 213         { offset 0 }
 214         { initial 0 }
 215         { class fixnum }
 216         { type char }
 217     }
 218     T{ struct-slot-spec
 219         { name "y" }
 220         { offset 4 }
 221         { initial 123 }
 222         { class $[ cell 4 = integer fixnum ? ] }
 223         { type int }
 224     }
 225     T{ struct-slot-spec
 226         { name "z" }
 227         { offset 8 }
 228         { initial f }
 229         { type bool }
 230         { class object }
 231     }
 232 } ] [ struct-test-foo lookup-c-type fields>> ] unit-test
 233
 234 [ {
 235     T{ struct-slot-spec
 236         { name "f" }
 237         { offset 0 }
 238         { type c:float }
 239         { class float }
 240         { initial 0.0 }
 241     }
 242     T{ struct-slot-spec
 243         { name "bits" }
 244         { offset 0 }
 245         { type uint }
 246         { class $[ cell 4 = integer fixnum ? ] }
 247         { initial 0 }
 248     }
 249 } ] [ struct-test-float-and-bits lookup-c-type fields>> ] unit-test
 250
 251 STRUCT: struct-test-equality-1
 252     { x int } ;
 253 STRUCT: struct-test-equality-2
 254     { y int } ;
 255
 256 [ 0 ] [ struct-test-equality-1 new hashcode ] unit-test
 257
 258 [ t ] [
 259     [
 260         struct-test-equality-1 <struct> 5 >>x
 261         struct-test-equality-1 malloc-struct &free 5 >>x =
 262     ] with-destructors
 263 ] unit-test
 264
 265 [ f ] [
 266     [
 267         struct-test-equality-1 <struct> 5 >>x
 268         struct-test-equality-2 malloc-struct &free 5 >>y =
 269     ] with-destructors
 270 ] unit-test
 271
 272 [ t ] [
 273     [
 274         struct-test-equality-1 <struct> 5 >>x
 275         struct-test-equality-1 malloc-struct &free 5 >>x
 276         [ hashcode ] bi@ =
 277     ] with-destructors
 278 ] unit-test
 279
 280 STRUCT: struct-test-array-slots
 281     { x int }
 282     { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
 283     { z int } ;
 284
 285 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
 286
 287 [ t ] [
 288     struct-test-array-slots <struct>
 289     [ y>> [ 8 3 ] dip set-nth ]
 290     [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
 291 ] unit-test
 292
 293 STRUCT: struct-test-optimization
 294     { x { int 3 } } { y int } ;
 295
 296 SPECIALIZED-ARRAY: struct-test-optimization
 297
 298 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 299 [ t ] [
 300     [ 3 struct-test-optimization <c-direct-array> third y>> ]
 301     { <tuple> <tuple-boa> memory>struct y>> } inlined?
 302 ] unit-test
 303
 304 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 305
 306 [ t ] [
 307     [ struct-test-optimization memory>struct x>> second ]
 308     { memory>struct x>> int <c-direct-array> <tuple> <tuple-boa> } inlined?
 309 ] unit-test
 310
 311 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 312
 313 [ t ] [
 314     [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
 315     { x>> } inlined?
 316 ] unit-test
 317
 318 [ ] [
 319     [
 320         struct-test-optimization specialized-array-vocab forget-vocab
 321     ] with-compilation-unit
 322 ] unit-test
 323
 324 ! Test cloning structs
 325 STRUCT: clone-test-struct { x int } { y char[3] } ;
 326
 327 [ 1 char-array{ 9 1 1 } ] [
 328     clone-test-struct <struct>
 329     1 >>x char-array{ 9 1 1 } >>y
 330     clone
 331     [ x>> ] [ y>> char >c-array ] bi
 332 ] unit-test
 333
 334 [ t 1 char-array{ 9 1 1 } ] [
 335     [
 336         clone-test-struct malloc-struct &free
 337         1 >>x char-array{ 9 1 1 } >>y
 338         clone
 339         [ >c-ptr byte-array? ] [ x>> ] [ y>> char >c-array ] tri
 340     ] with-destructors
 341 ] unit-test
 342
 343 STRUCT: struct-that's-a-word { x int } ;
 344
 345 : struct-that's-a-word ( -- ) "OOPS" throw ;
 346
 347 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
 348
 349 ! Interactive parsing of struct slot definitions
 350 [
 351     "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
 352     "struct-class-test-1" parse-stream
 353 ] [ error>> error>> unexpected-eof? ] must-fail-with
 354
 355 [
 356     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
 357 ] [ error>> duplicate-slot-names? ] must-fail-with
 358
 359 [
 360     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
 361 ] [ error>> duplicate-slot-names? ] must-fail-with
 362
 363 ! S{ with non-struct type
 364 [
 365     "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
 366     eval( -- value )
 367 ] [ error>> no-method? ] must-fail-with
 368
 369 ! Subclassing a struct class should not be allowed
 370 [
 371     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
 372     eval( -- )
 373 ] [ error>> bad-superclass? ] must-fail-with
 374
 375 ! Changing a superclass into a struct should reset the subclass
 376 TUPLE: will-become-struct ;
 377
 378 TUPLE: a-subclass < will-become-struct ;
 379
 380 [ f ] [ will-become-struct struct-class? ] unit-test
 381
 382 [ will-become-struct ] [ a-subclass superclass ] unit-test
 383
 384 [ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
 385
 386 [ t ] [ will-become-struct struct-class? ] unit-test
 387
 388 [ tuple ] [ a-subclass superclass ] unit-test
 389
 390 STRUCT: bit-field-test
 391     { a uint bits: 12 }
 392     { b int bits: 2 }
 393     { c char } ;
 394
 395 [ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
 396 [ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
 397 [ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
 398 [ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
 399 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
 400 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
 401 [ 3 ] [ bit-field-test heap-size ] unit-test
 402
 403 STRUCT: referent
 404     { y int } ;
 405 STRUCT: referrer
 406     { x referent* } ;
 407
 408 [ 57 ] [
 409     [
 410         referrer <struct>
 411             referent malloc-struct &free
 412                 57 >>y
 413             >>x
 414         x>> y>>
 415     ] with-destructors
 416 ] unit-test
 417
 418 STRUCT: self-referent
 419     { x self-referent* }
 420     { y int } ;
 421
 422 [ 75 ] [
 423     [
 424         self-referent <struct>
 425             self-referent malloc-struct &free
 426                 75 >>y
 427             >>x
 428         x>> y>>
 429     ] with-destructors
 430 ] unit-test
 431
 432 C-TYPE: forward-referent
 433 STRUCT: backward-referent
 434     { x forward-referent* }
 435     { y int } ;
 436 STRUCT: forward-referent
 437     { x backward-referent* }
 438     { y int } ;
 439
 440 [ 41 ] [
 441     [
 442         forward-referent <struct>
 443             backward-referent malloc-struct &free
 444                 41 >>y
 445             >>x
 446         x>> y>>
 447     ] with-destructors
 448 ] unit-test
 449
 450 [ 14 ] [
 451     [
 452         backward-referent <struct>
 453             forward-referent malloc-struct &free
 454                 14 >>y
 455             >>x
 456         x>> y>>
 457     ] with-destructors
 458 ] unit-test
 459
 460 cpu ppc? [
 461     STRUCT: ppc-align-test-1
 462         { x longlong }
 463         { y int } ;
 464
 465     [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
 466
 467     STRUCT: ppc-align-test-2
 468         { y int }
 469         { x longlong } ;
 470
 471     [ 16 ] [ ppc-align-test-2 heap-size ] unit-test
 472     [ 8 ] [ "x" ppc-align-test-2 offset-of ] unit-test
 473 ] when
 474
 475 STRUCT: struct-test-delegate
 476     { a int } ;
 477 STRUCT: struct-test-delegator
 478     { del struct-test-delegate }
 479     { b int } ;
 480 CONSULT: struct-test-delegate struct-test-delegator del>> ;
 481
 482 [ S{ struct-test-delegator f S{ struct-test-delegate f 7 } 8 } ] [
 483     struct-test-delegator <struct>
 484         7 >>a
 485         8 >>b
 486 ] unit-test
 487
 488 SPECIALIZED-ARRAY: void*
 489
 490 STRUCT: silly-array-field-test { x int*[3] } ;
 491
 492 [ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
 493
 494 ! Packed structs
 495 PACKED-STRUCT: packed-struct-test
 496     { d c:int }
 497     { e c:short }
 498     { f c:int }
 499     { g c:char }
 500     { h c:int } ;
 501
 502 [ 15 ] [ packed-struct-test heap-size ] unit-test
 503
 504 [ 0 ] [ "d" packed-struct-test offset-of ] unit-test
 505 [ 4 ] [ "e" packed-struct-test offset-of ] unit-test
 506 [ 6 ] [ "f" packed-struct-test offset-of ] unit-test
 507 [ 10 ] [ "g" packed-struct-test offset-of ] unit-test
 508 [ 11 ] [ "h" packed-struct-test offset-of ] unit-test
 509
 510 [ POSTPONE: PACKED-STRUCT: ]
 511 [ packed-struct-test struct-definer-word ] unit-test
 512
 513 STRUCT: struct-1 { a c:int } ;
 514 PACKED-STRUCT: struct-1-packed { a c:int } ;
 515 UNION-STRUCT: struct-1-union { a c:int } ;
 516
 517 [ "USING: alien.c-types classes.struct ;
 518 IN: classes.struct.tests
 519 STRUCT: struct-1 { a int initial: 0 } ;
 520 " ]
 521 [ \ struct-1 [ see ] with-string-writer ] unit-test
 522 [ "USING: alien.c-types classes.struct ;
 523 IN: classes.struct.tests
 524 PACKED-STRUCT: struct-1-packed { a int initial: 0 } ;
 525 " ]
 526 [ \ struct-1-packed [ see ] with-string-writer ] unit-test
 527 [ "USING: alien.c-types classes.struct ;
 528 IN: classes.struct.tests
 529 STRUCT: struct-1-union { a int initial: 0 } ;
 530 " ]
 531 [ \ struct-1-union [ see ] with-string-writer ] unit-test
 532
 533 ! Bug #206
 534 STRUCT: going-to-redefine { a uint } ;
 535 [ ] [
 536     "IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- )
 537 ] unit-test
 538 [ f ] [ \ going-to-redefine \ clone ?lookup-method ] unit-test
 539 [ f ] [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test
 540
 541 ! Test reset-class on structs, which should forget all the accessors, clone, and struct-slot-values
 542 STRUCT: some-accessors { aaa uint } { bbb int } ;
 543 [ ] [ [ \ some-accessors reset-class ] with-compilation-unit ] unit-test
 544 [ f ] [ \ some-accessors \ a>> ?lookup-method ] unit-test
 545 [ f ] [ \ some-accessors \ a<< ?lookup-method ] unit-test
 546 [ f ] [ \ some-accessors \ b>> ?lookup-method ] unit-test
 547 [ f ] [ \ some-accessors \ b<< ?lookup-method ] unit-test
 548 [ f ] [ \ some-accessors \ clone ?lookup-method ] unit-test
 549 [ f ] [ \ some-accessors \ struct-slot-values ?lookup-method ] unit-test
 550
 551 << \ some-accessors forget >>