basis/compiler/tests/intrinsics.factor

   1 USING: accessors arrays compiler.units kernel kernel.private math
   2 math.constants math.private sequences strings tools.test words
   3 continuations sequences.private hashtables.private byte-arrays
   4 strings.private system random layouts vectors
   5 sbufs strings.private slots.private alien math.order
   6 alien.accessors alien.c-types alien.syntax alien.strings
   7 namespaces libc sequences.private io.encodings.ascii ;
   8 IN: compiler.tests
   9
  10 ! Make sure that intrinsic ops compile to correct code.
  11 [ ] [ 1 [ drop ] compile-call ] unit-test
  12 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
  13 [ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test
  14 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
  15 [ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test
  16 [ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test
  17 [ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test
  18 [ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test
  19 [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
  20 [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
  21 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
  22 [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
  23 [ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
  24 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
  25 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
  26 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
  27
  28 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
  29 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
  30 [ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
  31 [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
  32 [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
  33 [ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
  34 [ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
  35 [ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
  36
  37 ! Write barrier hits on the wrong value were causing segfaults
  38 [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
  39
  40 ! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
  41 ! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
  42 ! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
  43 !
  44 ! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
  45 ! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
  46 ! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
  47
  48 [ ] [ [ 0 getenv ] compile-call drop ] unit-test
  49 [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
  50
  51 [ ] [ 1 [ drop ] compile-call ] unit-test
  52 [ ] [ [ 1 drop ] compile-call ] unit-test
  53 [ ] [ [ 1 2 2drop ] compile-call ] unit-test
  54 [ ] [ 1 [ 2 2drop ] compile-call ] unit-test
  55 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
  56 [ 2 1 ] [ [ 1 2 swap ] compile-call ] unit-test
  57 [ 2 1 ] [ 1 [ 2 swap ] compile-call ] unit-test
  58 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
  59 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
  60 [ 1 1 ] [ [ 1 dup ] compile-call ] unit-test
  61 [ 1 2 1 ] [ [ 1 2 over ] compile-call ] unit-test
  62 [ 1 2 1 ] [ 1 [ 2 over ] compile-call ] unit-test
  63 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
  64 [ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-call ] unit-test
  65 [ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-call ] unit-test
  66 [ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-call ] unit-test
  67 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
  68 [ 1 1 2 ] [ [ 1 2 dupd ] compile-call ] unit-test
  69 [ 1 1 2 ] [ 1 [ 2 dupd ] compile-call ] unit-test
  70 [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
  71 [ 2 ] [ [ 1 2 nip ] compile-call ] unit-test
  72 [ 2 ] [ 1 [ 2 nip ] compile-call ] unit-test
  73 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
  74
  75 [ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-call ] unit-test
  76
  77 [ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
  78 [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
  79 [ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
  80
  81 [ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
  82 [ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
  83 [ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
  84
  85 [ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
  86 [ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
  87 [ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
  88
  89 [ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  90 [ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  91 [ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  92 [ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  93 [ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  94
  95 [ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  96 [ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  97 [ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
  98
  99 [ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 100 [ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 101 [ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 102 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 103 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 104 [ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 105
 106 [ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 107 [ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 108 [ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 109
 110 [ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 111 [ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 112 [ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 113 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 114 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 115 [ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 116
 117 [ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 118 [ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 119 [ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 120
 121 [ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 122 [ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 123 [ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 124 [ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 125 [ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 126
 127 [ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 128 [ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 129 [ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 130
 131 [ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
 132 [ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
 133 [ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
 134 [ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
 135 [ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
 136 [ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
 137
 138 [ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] unit-test
 139 [ -1 ] [ [ 0 fixnum-bitnot ] compile-call ] unit-test
 140
 141 [ 3 ] [ 13 10 [ fixnum-mod ] compile-call ] unit-test
 142 [ 3 ] [ 13 [ 10 fixnum-mod ] compile-call ] unit-test
 143 [ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test
 144 [ -3 ] [ -13 10 [ fixnum-mod ] compile-call ] unit-test
 145 [ -3 ] [ -13 [ 10 fixnum-mod ] compile-call ] unit-test
 146 [ -3 ] [ [ -13 10 fixnum-mod ] compile-call ] unit-test
 147
 148 [ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test
 149 [ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test
 150 [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
 151 [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
 152
 153 [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
 154 [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
 155 [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
 156
 157 [ 4 ] [ 1 3 [ fixnum+fast ] compile-call ] unit-test
 158 [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
 159 [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
 160
 161 [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
 162
 163 [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
 164 [ 6 ] [ 2 [ 3 fixnum*fast ] compile-call ] unit-test
 165 [ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test
 166 [ -6 ] [ 2 -3 [ fixnum*fast ] compile-call ] unit-test
 167 [ -6 ] [ 2 [ -3 fixnum*fast ] compile-call ] unit-test
 168 [ -6 ] [ [ 2 -3 fixnum*fast ] compile-call ] unit-test
 169
 170 [ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test
 171 [ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test
 172 [ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test
 173 [ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test
 174 [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
 175 [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
 176
 177 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 178 [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 179 [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
 180 [ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
 181
 182 [ 8 ] [ 1 3 [ fixnum-shift ] compile-call ] unit-test
 183 [ 8 ] [ 1 [ 3 fixnum-shift ] compile-call ] unit-test
 184 [ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test
 185 [ -8 ] [ -1 3 [ fixnum-shift ] compile-call ] unit-test
 186 [ -8 ] [ -1 [ 3 fixnum-shift ] compile-call ] unit-test
 187 [ -8 ] [ [ -1 3 fixnum-shift ] compile-call ] unit-test
 188
 189 [ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] unit-test
 190 [ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] unit-test
 191
 192 [ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
 193 [ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
 194 [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
 195 [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
 196
 197 [ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
 198 [ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
 199
 200 [ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
 201 [ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
 202
 203 [ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
 204 [ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
 205 [ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 206 [ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
 207 [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
 208 [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 209
 210 [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
 211 [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
 212 [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
 213 [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
 214
 215 [ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 216
 217 [ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 218
 219 [ t ] [ f [ f eq? ] compile-call ] unit-test
 220
 221 ! regression
 222 [ 3 ] [
 223     100001 f <array> 3 100000 pick set-nth
 224     [ 100000 swap array-nth ] compile-call
 225 ] unit-test
 226
 227 ! 64-bit overflow
 228 cell 8 = [
 229     [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
 230     [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
 231
 232     [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
 233     [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
 234     [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 235     [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 236     [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 237
 238     [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test
 239     [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test
 240     [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
 241     [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test
 242     [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
 243     [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
 244
 245     [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 246
 247     [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 248
 249     [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
 250 ] when
 251
 252 ! Some randomized tests
 253 : compiled-fixnum* fixnum* ;
 254
 255 : test-fixnum* ( -- )
 256     32 random-bits >fixnum 32 random-bits >fixnum
 257     2dup
 258     [ fixnum* ] 2keep compiled-fixnum* =
 259     [ 2drop ] [ "Oops" throw ] if ;
 260
 261 [ ] [ 10000 [ test-fixnum* ] times ] unit-test
 262
 263 : compiled-fixnum>bignum fixnum>bignum ;
 264
 265 : test-fixnum>bignum ( -- )
 266     32 random-bits >fixnum
 267     dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
 268     [ drop ] [ "Oops" throw ] if ;
 269
 270 [ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
 271
 272 : compiled-bignum>fixnum bignum>fixnum ;
 273
 274 : test-bignum>fixnum ( -- )
 275     5 random [ drop 32 random-bits ] map product >bignum
 276     dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
 277     [ drop ] [ "Oops" throw ] if ;
 278
 279 [ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
 280
 281 ! Test overflow check removal
 282 [ t ] [
 283     most-positive-fixnum 100 - >fixnum
 284     200
 285     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 286     [ fixnum+ >fixnum ] compile-call
 287     =
 288 ] unit-test
 289
 290 [ t ] [
 291     most-negative-fixnum 100 + >fixnum
 292     -200
 293     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 294     [ fixnum+ >fixnum ] compile-call
 295     =
 296 ] unit-test
 297
 298 [ t ] [
 299     most-negative-fixnum 100 + >fixnum
 300     200
 301     [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 302     [ fixnum- >fixnum ] compile-call
 303     =
 304 ] unit-test
 305
 306 ! Test inline allocators
 307 [ { 1 1 1 } ] [
 308     [ 3 1 <array> ] compile-call
 309 ] unit-test
 310
 311 [ B{ 0 0 0 } ] [
 312     [ 3 <byte-array> ] compile-call
 313 ] unit-test
 314
 315 [ 500 ] [
 316     [ 500 <byte-array> length ] compile-call
 317 ] unit-test
 318
 319 [ 1 2 ] [
 320     1 2 [ <complex> ] compile-call
 321     dup real-part swap imaginary-part
 322 ] unit-test
 323
 324 [ 1 2 ] [
 325     1 2 [ <ratio> ] compile-call dup numerator swap denominator
 326 ] unit-test
 327
 328 [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
 329
 330 [ B{ 0 0 0 0 0 } ] [
 331     [ 5 <byte-array> ] compile-call
 332 ] unit-test
 333
 334 [ V{ 1 2 } ] [
 335     { 1 2 3 } 2 [ vector boa ] compile-call
 336 ] unit-test
 337
 338 [ SBUF" hello" ] [
 339     "hello world" 5 [ sbuf boa ] compile-call
 340 ] unit-test
 341
 342 [ [ 3 + ] ] [
 343     3 [ + ] [ curry ] compile-call
 344 ] unit-test
 345
 346 ! Alien intrinsics
 347 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-call ] unit-test
 348 [ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-call ] unit-test
 349 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 350 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 351
 352 [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
 353 [ t ] [ "b" get >boolean ] unit-test
 354
 355 "b" get [
 356     [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
 357     [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
 358     [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 359     [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 360
 361     [ ] [ "b" get free ] unit-test
 362 ] when
 363
 364 [ ] [ "hello world" ascii malloc-string "s" set ] unit-test
 365
 366 "s" get [
 367     [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
 368     [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
 369
 370     [ ] [ "s" get free ] unit-test
 371 ] when
 372
 373 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
 374 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
 375 [ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-call *void* ] unit-test
 376
 377 [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 378 [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
 379
 380 : xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
 381
 382 [ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
 383 [ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
 384
 385 [ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
 386 [ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
 387
 388 [ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
 389 [ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
 390
 391 [ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
 392 [ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
 393
 394 [ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
 395 [ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
 396
 397 [ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
 398 [ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
 399
 400 [ t ] [ pi pi <double> *double = ] unit-test
 401
 402 [ t ] [ pi <double> [ { byte-array } declare *double ] compile-call pi = ] unit-test
 403
 404 ! Silly
 405 [ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
 406 [ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
 407
 408 [ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
 409
 410 [ 4 ] [
 411     2 B{ 1 2 3 4 5 6 } <displaced-alien> [
 412         { alien } declare 1 alien-unsigned-1
 413     ] compile-call
 414 ] unit-test
 415
 416 [
 417     B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
 418 ] must-fail
 419
 420 [
 421     B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
 422 ] must-fail
 423
 424 [
 425     4 5
 426 ] [
 427     3 [
 428         [
 429             { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
 430         ] keep 2 fixnum+fast
 431     ] compile-call
 432 ] unit-test
 433
 434 [ 1 ] [
 435     8 -3 [ fixnum-shift-fast ] compile-call
 436 ] unit-test
 437
 438 [ 2 ] [
 439     16 -3 [ fixnum-shift-fast ] compile-call
 440 ] unit-test
 441
 442 [ 2 ] [
 443     16 [ -3 fixnum-shift-fast ] compile-call
 444 ] unit-test
 445
 446 [ 8 ] [
 447     1 3 [ fixnum-shift-fast ] compile-call
 448 ] unit-test
 449
 450 [ 8 ] [
 451     1 [ 3 fixnum-shift-fast ] compile-call
 452 ] unit-test
 453
 454 TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
 455
 456 [ B{ 0 1 } ] [
 457     B{ 0 0 } 1 alien-accessor-regression boa
 458     dup [
 459         { alien-accessor-regression } declare
 460         [ i>> ] [ b>> ] bi over set-alien-unsigned-1
 461     ] compile-call
 462     b>>
 463 ] unit-test