basis/specialized-arrays/specialized-arrays-tests.factor

   1 USING: tools.test alien.syntax specialized-arrays sequences
   2 alien accessors kernel arrays combinators compiler
   3 compiler.units classes.struct combinators.smart
   4 compiler.tree.debugger math libc destructors sequences.private
   5 multiline eval words vocabs namespaces assocs prettyprint
   6 alien.data math.vectors definitions compiler.test ;
   7 FROM: specialized-arrays.private => specialized-array-vocab ;
   8 FROM: alien.c-types => int float bool uchar char float ulonglong ushort uint
   9 heap-size ;
  10 FROM: alien.data => little-endian? ;
  11 IN: specialized-arrays.tests
  12
  13 SPECIALIZED-ARRAY: int
  14 SPECIALIZED-ARRAYS: bool uchar ushort char uint float ulonglong ;
  15
  16 [ t ] [ { 1 2 3 } int >c-array int-array? ] unit-test
  17
  18 [ t ] [ int-array{ 1 2 3 } int-array? ] unit-test
  19
  20 [ 2 ] [ int-array{ 1 2 3 } second ] unit-test
  21
  22 [ t ] [
  23     { t f t } bool >c-array underlying>>
  24     { 1 0 1 } bool heap-size {
  25         { 1 [ char >c-array ] }
  26         { 4 [ uint >c-array ] }
  27     } case underlying>> =
  28 ] unit-test
  29
  30 [ ushort-array{ 1234 } ] [
  31     little-endian? B{ 210 4 } B{ 4 210 } ? ushort cast-array
  32 ] unit-test
  33
  34 [ B{ 210 4 1 } ushort cast-array ] must-fail
  35
  36 [ { 3 1 3 3 7 } ] [
  37     int-array{ 3 1 3 3 7 } malloc-byte-array 5 int <c-direct-array> >array
  38 ] unit-test
  39
  40 [ float-array{ 0x1.222,222   0x1.111,112   } ]
  41 [ float-array{ 0x1.222,222,2 0x1.111,111,1 } ] unit-test
  42
  43 [ f ] [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] unit-test
  44
  45 [ f ] [ [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] compile-call ] unit-test
  46
  47 [ ushort-array{ 0 0 0 } ] [
  48     3 ALIEN: 123 100 <direct-ushort-array> new-sequence
  49     [ drop 0 ] map!
  50 ] unit-test
  51
  52 STRUCT: test-struct
  53     { x int }
  54     { y int } ;
  55
  56 SPECIALIZED-ARRAY: test-struct
  57
  58 [ 1 ] [
  59     1 test-struct-array{ } new-sequence length
  60 ] unit-test
  61
  62 [ V{ test-struct } ] [
  63     [ [ test-struct-array <struct> ] test-struct-array{ } output>sequence first ] final-classes
  64 ] unit-test
  65
  66 : make-point ( x y -- struct )
  67     test-struct <struct-boa> ;
  68
  69 [ 5/4 ] [
  70     2 <test-struct-array>
  71     1 2 make-point over set-first
  72     3 4 make-point over set-second
  73     0 [ [ x>> ] [ y>> ] bi / + ] reduce
  74 ] unit-test
  75
  76 [ 5/4 ] [
  77     [
  78         2 \ test-struct malloc-array
  79         dup &free drop
  80         1 2 make-point over set-first
  81         3 4 make-point over set-second
  82         0 [ [ x>> ] [ y>> ] bi / + ] reduce
  83     ] with-destructors
  84 ] unit-test
  85
  86 [ ] [ ALIEN: 123 10 <direct-test-struct-array> drop ] unit-test
  87
  88 [ ] [
  89     [
  90         10 \ test-struct malloc-array
  91         &free drop
  92     ] with-destructors
  93 ] unit-test
  94
  95 [ 15 ] [ 15 10 <test-struct-array> resize length ] unit-test
  96
  97 [ S{ test-struct f 12 20 } ] [
  98     test-struct-array{
  99         S{ test-struct f  4 20 }
 100         S{ test-struct f 12 20 }
 101         S{ test-struct f 20 20 }
 102     } second
 103 ] unit-test
 104
 105 [ ] [
 106     [
 107         test-struct specialized-array-vocab forget-vocab
 108     ] with-compilation-unit
 109 ] unit-test
 110
 111 ! Regression
 112 STRUCT: fixed-string { text char[64] } ;
 113
 114 SPECIALIZED-ARRAY: fixed-string
 115
 116 [ { ALIEN: 100 ALIEN: 140 ALIEN: 180 ALIEN: 1c0 } ] [
 117     ALIEN: 100 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
 118 ] unit-test
 119
 120 ! Ensure that byte-length works with direct arrays
 121 [ 400 ] [
 122     ALIEN: 123 100 <direct-int-array> byte-length
 123 ] unit-test
 124
 125 [ ] [
 126     [
 127         fixed-string specialized-array-vocab forget-vocab
 128     ] with-compilation-unit
 129 ] unit-test
 130
 131 ! Test prettyprinting
 132 [ "int-array{ 1 2 3 }" ] [ int-array{ 1 2 3 } unparse ] unit-test
 133 [ "c-array@ int f 100" ] [ f 100 <direct-int-array> unparse ] unit-test
 134
 135 ! If the C type doesn't exist, don't generate a vocab
 136 SYMBOL: __does_not_exist__
 137
 138 [
 139     """
 140 IN: specialized-arrays.tests
 141 USING: specialized-arrays ;
 142
 143 SPECIALIZED-ARRAY: __does_not_exist__ """ eval( -- )
 144 ] must-fail
 145
 146 [ ] [
 147     """
 148 IN: specialized-arrays.tests
 149 USING: alien.c-types classes.struct specialized-arrays ;
 150
 151 STRUCT: __does_not_exist__ { x int } ;
 152
 153 SPECIALIZED-ARRAY: __does_not_exist__
 154 """ eval( -- )
 155 ] unit-test
 156
 157 [ f ] [
 158     "__does_not_exist__-array{"
 159     __does_not_exist__ specialized-array-vocab lookup-word
 160     deferred?
 161 ] unit-test
 162
 163 [ ] [
 164     [
 165         \ __does_not_exist__ forget
 166         __does_not_exist__ specialized-array-vocab forget-vocab
 167     ] with-compilation-unit
 168 ] unit-test
 169
 170 STRUCT: struct-resize-test { x int } ;
 171
 172 SPECIALIZED-ARRAY: struct-resize-test
 173
 174 [ 40 ] [ 10 <struct-resize-test-array> byte-length ] unit-test
 175
 176 : struct-resize-test-usage ( seq -- seq )
 177     [ struct-resize-test <struct> swap >>x ] map
 178     \ struct-resize-test >c-array
 179     [ x>> ] { } map-as ;
 180
 181 [ { 10 20 30 } ] [ { 10 20 30 } struct-resize-test-usage ] unit-test
 182
 183 [ ] [ "IN: specialized-arrays.tests USE: classes.struct USE: alien.c-types STRUCT: struct-resize-test { x int } { y int } ;" eval( -- ) ] unit-test
 184
 185 [ 80 ] [ 10 <struct-resize-test-array> byte-length ] unit-test
 186
 187 [ { 10 20 30 } ] [ { 10 20 30 } struct-resize-test-usage ] unit-test
 188
 189 [ ] [
 190     [
 191         struct-resize-test specialized-array-vocab forget-vocab
 192         \ struct-resize-test-usage forget
 193     ] with-compilation-unit
 194 ] unit-test
 195
 196 [ int-array{ 4 5 6 } ] [ 3 6 int-array{ 1 2 3 4 5 6 7 8 } direct-slice ] unit-test
 197 [ int-array{ 1 2 3 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-head ] unit-test
 198 [ int-array{ 1 2 3 4 5 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-head* ] unit-test
 199 [ int-array{ 4 5 6 7 8 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-tail ] unit-test
 200 [ int-array{ 6 7 8 } ] [ int-array{ 1 2 3 4 5 6 7 8 } 3 direct-tail* ] unit-test
 201
 202 [ uchar-array{ 0 1 255 } ] [ 3 6 B{ 1 1 1 0 1 255 2 2 2 } direct-slice ] unit-test
 203
 204 [ int-array{ 1 2 3 4 55555 6 7 8 } ] [
 205     int-array{ 1 2 3 4 5 6 7 8 }
 206     3 6 pick direct-slice [ 55555 1 ] dip set-nth
 207 ] unit-test
 208