basis/classes/struct/struct-tests.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien alien.c-types ascii
   3 assocs byte-arrays classes.struct classes.tuple.private
   4 combinators compiler.tree.debugger compiler.units destructors
   5 io.encodings.utf8 io.pathnames io.streams.string kernel libc
   6 literals math mirrors multiline namespaces prettyprint
   7 prettyprint.config see sequences specialized-arrays system
   8 tools.test parser lexer eval ;
   9 SPECIALIZED-ARRAY: char
  10 SPECIALIZED-ARRAY: int
  11 SPECIALIZED-ARRAY: ushort
  12 IN: classes.struct.tests
  13
  14 SYMBOL: struct-test-empty
  15
  16 [ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
  17 [ struct-must-have-slots? ] must-fail-with
  18
  19 STRUCT: struct-test-foo
  20     { x char }
  21     { y int initial: 123 }
  22     { z bool } ;
  23
  24 STRUCT: struct-test-bar
  25     { w ushort initial: HEX: ffff }
  26     { foo struct-test-foo } ;
  27
  28 [ 12 ] [ struct-test-foo heap-size ] unit-test
  29 [ 12 ] [ struct-test-foo <struct> byte-length ] unit-test
  30 [ 16 ] [ struct-test-bar heap-size ] unit-test
  31 [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
  32 [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
  33
  34 [ 1 2 3 t ] [
  35     1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
  36     {
  37         [ w>> ]
  38         [ foo>> x>> ]
  39         [ foo>> y>> ]
  40         [ foo>> z>> ]
  41     } cleave
  42 ] unit-test
  43
  44 [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
  45 [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
  46
  47 [ {
  48     { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } }
  49     { { "x" "char" } 98            }
  50     { { "y" "int"  } HEX: 7F00007F }
  51     { { "z" "bool" } f             }
  52 } ] [
  53     B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct
  54     make-mirror >alist
  55 ] unit-test
  56
  57 [ { { "underlying" f } } ] [
  58     f struct-test-foo memory>struct
  59     make-mirror >alist
  60 ] unit-test
  61
  62 [ 55 t ] [ S{ struct-test-foo { x 55 } } make-mirror { "x" "char" } swap at* ] unit-test
  63 [ 55 t ] [ S{ struct-test-foo { y 55 } } make-mirror { "y" "int"  } swap at* ] unit-test
  64 [ t  t ] [ S{ struct-test-foo { z t  } } make-mirror { "z" "bool" } swap at* ] unit-test
  65 [ f  t ] [ S{ struct-test-foo { z f  } } make-mirror { "z" "bool" } swap at* ] unit-test
  66 [ f  f ] [ S{ struct-test-foo } make-mirror { "nonexist" "bool" } swap at* ] unit-test
  67 [ f  f ] [ S{ struct-test-foo } make-mirror "nonexist" swap at* ] unit-test
  68 [ f  t ] [ f struct-test-foo memory>struct make-mirror "underlying" swap at* ] unit-test
  69
  70 [ S{ struct-test-foo { x 3 } { y 2 } { z f } } ] [
  71     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  72     [ make-mirror [ 3 { "x" "char" } ] dip set-at ] keep
  73 ] unit-test
  74
  75 [ S{ struct-test-foo { x 1 } { y 5 } { z f } } ] [
  76     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  77     [ make-mirror [ 5 { "y" "int" } ] dip set-at ] keep
  78 ] unit-test
  79
  80 [ S{ struct-test-foo { x 1 } { y 2 } { z t } } ] [
  81     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  82     [ make-mirror [ t { "z" "bool" } ] dip set-at ] keep
  83 ] unit-test
  84
  85 [ S{ struct-test-foo { x 1 } { y 2 } { z f } } ] [
  86     S{ struct-test-foo { x 1 } { y 2 } { z f } }
  87     [ make-mirror [ "nonsense" "underlying" ] 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" "nonexist" ] 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" "int" } ] dip set-at ] keep
  98 ] unit-test
  99
 100 [ S{ struct-test-foo { x 1 } { y 123 } { z f } } ] [
 101     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 102     [ make-mirror { "y" "int" } swap delete-at ] keep
 103 ] unit-test
 104
 105 [ S{ struct-test-foo { x 0 } { y 2 } { z f } } ] [
 106     S{ struct-test-foo { x 1 } { y 2 } { z f } }
 107     [ make-mirror { "x" "char" } swap delete-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 { "nonexist" "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 "underlying" 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 "nonsense" swap delete-at ] keep
 123 ] unit-test
 124
 125 [ S{ struct-test-foo { x 0 } { y 123 } { z f } } ] [
 126     S{ struct-test-foo { x 1 } { y 2 } { z t } }
 127     [ make-mirror clear-assoc ] keep
 128 ] unit-test
 129
 130 UNION-STRUCT: struct-test-float-and-bits
 131     { f float }
 132     { bits uint } ;
 133
 134 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
 135 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 136
 137 [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 138
 139 STRUCT: struct-test-string-ptr
 140     { x char* } ;
 141
 142 [ "hello world" ] [
 143     [
 144         struct-test-string-ptr <struct>
 145         "hello world" utf8 malloc-string &free >>x
 146         x>>
 147     ] with-destructors
 148 ] unit-test
 149
 150 [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
 151 [
 152     [
 153         boa-tuples? off
 154         c-object-pointers? off
 155         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 156     ] with-scope
 157 ] unit-test
 158
 159 [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
 160 [
 161     [
 162         c-object-pointers? on
 163         12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
 164     ] with-scope
 165 ] unit-test
 166
 167 [ "S{ struct-test-foo f 0 7654 f }" ]
 168 [
 169     [
 170         boa-tuples? on
 171         c-object-pointers? off
 172         struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
 173     ] with-scope
 174 ] unit-test
 175
 176 [ "S@ struct-test-foo f" ]
 177 [
 178     [
 179         c-object-pointers? off
 180         f struct-test-foo memory>struct [ pprint ] with-string-writer
 181     ] with-scope
 182 ] unit-test
 183
 184 [ <" USING: classes.struct ;
 185 IN: classes.struct.tests
 186 STRUCT: struct-test-foo
 187     { x char initial: 0 } { y int initial: 123 } { z bool } ;
 188 "> ]
 189 [ [ struct-test-foo see ] with-string-writer ] unit-test
 190
 191 [ <" USING: classes.struct ;
 192 IN: classes.struct.tests
 193 UNION-STRUCT: struct-test-float-and-bits
 194     { f float initial: 0.0 } { bits uint initial: 0 } ;
 195 "> ]
 196 [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
 197
 198 [ {
 199     T{ struct-slot-spec
 200         { name "x" }
 201         { offset 0 }
 202         { class fixnum }
 203         { type "char" }
 204         { reader x>> }
 205         { writer (>>x) }
 206     }
 207     T{ struct-slot-spec
 208         { name "y" }
 209         { offset 4 }
 210         { class $[ cell 8 = fixnum integer ? ] }
 211         { type "int" }
 212         { reader y>> }
 213         { writer (>>y) }
 214     }
 215     T{ struct-slot-spec
 216         { name "z" }
 217         { offset 8 }
 218         { type "bool" }
 219         { class boolean }
 220         { reader z>> }
 221         { writer (>>z) }
 222     }
 223 } ] [ "struct-test-foo" c-type fields>> ] unit-test
 224
 225 [ {
 226     T{ struct-slot-spec
 227         { name "f" }
 228         { offset 0 }
 229         { type "float" }
 230         { class float }
 231         { reader f>> }
 232         { writer (>>f) }
 233     }
 234     T{ struct-slot-spec
 235         { name "bits" }
 236         { offset 0 }
 237         { type "uint" }
 238         { class $[ cell 8 = fixnum integer ? ] }
 239         { reader bits>> }
 240         { writer (>>bits) }
 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 ! Test cloning structs
 310 STRUCT: clone-test-struct { x int } { y char[3] } ;
 311
 312 [ 1 char-array{ 9 1 1 } ] [
 313     clone-test-struct <struct>
 314     1 >>x char-array{ 9 1 1 } >>y
 315     clone
 316     [ x>> ] [ y>> >char-array ] bi
 317 ] unit-test
 318
 319 [ t 1 char-array{ 9 1 1 } ] [
 320     [
 321         clone-test-struct malloc-struct &free
 322         1 >>x char-array{ 9 1 1 } >>y
 323         clone
 324         [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
 325     ] with-destructors
 326 ] unit-test
 327
 328 STRUCT: struct-that's-a-word { x int } ;
 329
 330 : struct-that's-a-word ( -- ) "OOPS" throw ;
 331
 332 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
 333
 334 ! Interactive parsing of struct slot definitions
 335 [
 336     "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
 337     "struct-class-test-1" parse-stream
 338 ] [ error>> error>> unexpected-eof? ] must-fail-with
 339
 340 ! S{ with non-struct type
 341 [
 342     "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
 343     eval( -- value )
 344 ] must-fail
 345
 346 ! Subclassing a struct class should not be allowed
 347 [
 348     "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
 349     eval( -- )
 350 ] must-fail
 351
 352 ! Remove c-type when struct class is forgotten
 353 [ ] [
 354     "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
 355 ] unit-test
 356
 357 [ f ] [ "a-struct" c-types get key? ] unit-test