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