basis/classes/struct/struct-tests.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data alien.syntax ascii
   3 assocs byte-arrays classes.struct classes.tuple.parser
   4 classes.tuple.private classes.tuple combinators compiler.tree.debugger
   5 compiler.units delegate destructors io.encodings.utf8 io.pathnames
   6 io.streams.string kernel libc literals math mirrors namespaces
   7 prettyprint prettyprint.config see sequences specialized-arrays
   8 system tools.test parser lexer eval layouts generic.single classes
   9 vocabs ;
  10 FROM: math => float ;
  11 FROM: specialized-arrays.private => specialized-array-vocab ;
  12 FROM: classes.struct.private => binary-zero? ;
  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: HEX: ffff }
  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  } HEX: 7F00007F }
  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" } swap at* ] unit-test
  68 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int"  } swap at* ] unit-test
  69 [ t  t ] [ S{ struct-test-foo { z t  } } make-mirror { "z" "bool" } swap at* ] unit-test
  70 [ f  t ] [ S{ struct-test-foo { z f  } } make-mirror { "z" "bool" } swap at* ] unit-test
  71 [ f  f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
  72 [ f  f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
  73 [ f  t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] 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 UNION-STRUCT: struct-test-float-and-bits
 136     { f c:float }
 137     { bits uint } ;
 138
 139 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
 140 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 141
 142 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 143
 144 STRUCT: struct-test-string-ptr
 145     { x c-string } ;
 146
 147 [ "hello world" ] [
 148     [
 149         struct-test-string-ptr <struct>
 150         "hello world" utf8 malloc-string &free >>x
 151         x>>
 152     ] with-destructors
 153 ] unit-test
 154
 155 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
 156 [
 157     [
 158         boa-tuples? off
 159         c-object-pointers? off
 160         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 161     ] with-scope
 162 ] unit-test
 163
 164 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
 165 [
 166     [
 167         c-object-pointers? on
 168         12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
 169     ] with-scope
 170 ] unit-test
 171
 172 [ "S{ struct-test-foo f 0 7654 f }" ]
 173 [
 174     [
 175         boa-tuples? on
 176         c-object-pointers? off
 177         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 178     ] with-scope
 179 ] unit-test
 180
 181 [ "S@ struct-test-foo f" ]
 182 [
 183     [
 184         c-object-pointers? off
 185         f struct-test-foo memory>struct [ pprint ] with-string-writer
 186     ] with-scope
 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 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 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 [ t ] [
 250     [
 251         struct-test-equality-1 <struct> 5 >>x
 252         struct-test-equality-1 malloc-struct &free 5 >>x =
 253     ] with-destructors
 254 ] unit-test
 255
 256 [ f ] [
 257     [
 258         struct-test-equality-1 <struct> 5 >>x
 259         struct-test-equality-2 malloc-struct &free 5 >>y =
 260     ] with-destructors
 261 ] unit-test
 262
 263 [ t ] [
 264     [
 265         struct-test-equality-1 <struct> 5 >>x
 266         struct-test-equality-1 malloc-struct &free 5 >>x
 267         [ hashcode ] bi@ =
 268     ] with-destructors
 269 ] unit-test
 270
 271 STRUCT: struct-test-array-slots
 272     { x int }
 273     { y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
 274     { z int } ;
 275
 276 [ 11 ] [ struct-test-array-slots <struct> y>> 4 swap nth ] unit-test
 277
 278 [ t ] [
 279     struct-test-array-slots <struct>
 280     [ y>> [ 8 3 ] dip set-nth ]
 281     [ y>> ushort-array{ 2 3 5 8 11 13 } sequence= ] bi
 282 ] unit-test
 283
 284 STRUCT: struct-test-optimization
 285     { x { int 3 } } { y int } ;
 286
 287 SPECIALIZED-ARRAY: struct-test-optimization
 288
 289 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 290 [ t ] [
 291     [ 3 <direct-struct-test-optimization-array> third y>> ]
 292     { <tuple> <tuple-boa> memory>struct y>> } inlined?
 293 ] unit-test
 294
 295 [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 296
 297 [ t ] [
 298     [ struct-test-optimization memory>struct x>> second ]
 299     { memory>struct x>> <direct-int-array> <tuple> <tuple-boa> } inlined?
 300 ] unit-test
 301
 302 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 303
 304 [ t ] [
 305     [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
 306     { x>> } inlined?
 307 ] unit-test
 308
 309 [ ] [
 310     [
 311         struct-test-optimization specialized-array-vocab forget-vocab
 312     ] with-compilation-unit
 313 ] unit-test
 314
 315 ! Test cloning structs
 316 STRUCT: clone-test-struct { x int } { y char[3] } ;
 317
 318 [ 1 char-array{ 9 1 1 } ] [
 319     clone-test-struct <struct>
 320     1 >>x char-array{ 9 1 1 } >>y
 321     clone
 322     [ x>> ] [ y>> >char-array ] bi
 323 ] unit-test
 324
 325 [ t 1 char-array{ 9 1 1 } ] [
 326     [
 327         clone-test-struct malloc-struct &free
 328         1 >>x char-array{ 9 1 1 } >>y
 329         clone
 330         [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
 331     ] with-destructors
 332 ] unit-test
 333
 334 STRUCT: struct-that's-a-word { x int } ;
 335
 336 : struct-that's-a-word ( -- ) "OOPS" throw ;
 337
 338 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
 339
 340 ! Interactive parsing of struct slot definitions
 341 [
 342     "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
 343     "struct-class-test-1" parse-stream
 344 ] [ error>> error>> unexpected-eof? ] must-fail-with
 345
 346 [
 347     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
 348 ] [ error>> duplicate-slot-names? ] must-fail-with
 349
 350 [
 351     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
 352 ] [ error>> duplicate-slot-names? ] must-fail-with
 353
 354 ! S{ with non-struct type
 355 [
 356     "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
 357     eval( -- value )
 358 ] [ error>> no-method? ] must-fail-with
 359
 360 ! Subclassing a struct class should not be allowed
 361 [
 362     "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
 363     eval( -- )
 364 ] [ error>> bad-superclass? ] must-fail-with
 365
 366 ! Changing a superclass into a struct should reset the subclass
 367 TUPLE: will-become-struct ;
 368
 369 TUPLE: a-subclass < will-become-struct ;
 370
 371 [ f ] [ will-become-struct struct-class? ] unit-test
 372
 373 [ will-become-struct ] [ a-subclass superclass ] unit-test
 374
 375 [ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
 376
 377 [ t ] [ will-become-struct struct-class? ] unit-test
 378
 379 [ tuple ] [ a-subclass superclass ] unit-test
 380
 381 STRUCT: bit-field-test
 382     { a uint bits: 12 }
 383     { b int bits: 2 }
 384     { c char } ;
 385
 386 [ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
 387 [ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
 388 [ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
 389 [ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
 390 [ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
 391 [ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
 392 [ 3 ] [ bit-field-test heap-size ] unit-test
 393
 394 STRUCT: referent
 395     { y int } ;
 396 STRUCT: referrer
 397     { x referent* } ;
 398
 399 [ 57 ] [
 400     [
 401         referrer <struct>
 402             referent malloc-struct &free
 403                 57 >>y
 404             >>x
 405         x>> y>>
 406     ] with-destructors
 407 ] unit-test
 408
 409 STRUCT: self-referent
 410     { x self-referent* }
 411     { y int } ;
 412
 413 [ 75 ] [
 414     [
 415         self-referent <struct>
 416             self-referent malloc-struct &free
 417                 75 >>y
 418             >>x
 419         x>> y>>
 420     ] with-destructors
 421 ] unit-test
 422
 423 C-TYPE: forward-referent
 424 STRUCT: backward-referent
 425     { x forward-referent* }
 426     { y int } ;
 427 STRUCT: forward-referent
 428     { x backward-referent* }
 429     { y int } ;
 430
 431 [ 41 ] [
 432     [
 433         forward-referent <struct>
 434             backward-referent malloc-struct &free
 435                 41 >>y
 436             >>x
 437         x>> y>>
 438     ] with-destructors
 439 ] unit-test
 440
 441 [ 14 ] [
 442     [
 443         backward-referent <struct>
 444             forward-referent malloc-struct &free
 445                 14 >>y
 446             >>x
 447         x>> y>>
 448     ] with-destructors
 449 ] unit-test
 450
 451 cpu ppc? [
 452     STRUCT: ppc-align-test-1
 453         { x longlong }
 454         { y int } ;
 455
 456     [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
 457
 458     STRUCT: ppc-align-test-2
 459         { y int }
 460         { x longlong } ;
 461
 462     [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
 463     [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
 464 ] when
 465
 466 STRUCT: struct-test-delegate
 467     { a int } ;
 468 STRUCT: struct-test-delegator
 469     { del struct-test-delegate }
 470     { b int } ;
 471 CONSULT: struct-test-delegate struct-test-delegator del>> ;
 472
 473 [ S{ struct-test-delegator f S{ struct-test-delegate f 7 } 8 } ] [
 474     struct-test-delegator <struct>
 475         7 >>a
 476         8 >>b
 477 ] unit-test
 478
 479 SPECIALIZED-ARRAY: struct-test-foo
 480
 481 [ t ] [ 0 binary-zero? ] unit-test
 482 [ f ] [ 1 binary-zero? ] unit-test
 483 [ f ] [ -1 binary-zero? ] unit-test
 484 [ t ] [ 0.0 binary-zero? ] unit-test
 485 [ f ] [ 1.0 binary-zero? ] unit-test
 486 [ f ] [ -0.0 binary-zero? ] unit-test
 487 [ t ] [ C{ 0.0 0.0 } binary-zero? ] unit-test
 488 [ f ] [ C{ 1.0 0.0 } binary-zero? ] unit-test
 489 [ f ] [ C{ -0.0 0.0 } binary-zero? ] unit-test
 490 [ f ] [ C{ 0.0 1.0 } binary-zero? ] unit-test
 491 [ f ] [ C{ 0.0 -0.0 } binary-zero? ] unit-test
 492 [ t ] [ f binary-zero? ] unit-test
 493 [ t ] [ 0 <alien> binary-zero? ] unit-test
 494 [ f ] [ 1 <alien> binary-zero? ] unit-test
 495 [ f ] [ B{ } binary-zero? ] unit-test
 496 [ t ] [ S{ struct-test-foo f 0 0 f } binary-zero? ] unit-test
 497 [ f ] [ S{ struct-test-foo f 1 0 f } binary-zero? ] unit-test
 498 [ f ] [ S{ struct-test-foo f 0 1 f } binary-zero? ] unit-test
 499 [ f ] [ S{ struct-test-foo f 0 0 t } binary-zero? ] unit-test
 500 [ t t f ] [
 501     struct-test-foo-array{
 502         S{ struct-test-foo f 0 0 f }
 503         S{ struct-test-foo f 0 0 f }
 504         S{ struct-test-foo f 1 0 f }
 505     } [ first binary-zero? ] [ second binary-zero? ] [ third binary-zero? ] tri
 506 ] unit-test