basis/compiler/tests/intrinsics.factor

   1 USING: accessors arrays compiler.units kernel kernel.private
   2 math math.constants math.private math.integers.private sequences
   3 strings tools.test words continuations sequences.private
   4 hashtables.private byte-arrays system random layouts vectors
   5 sbufs strings.private slots.private alien math.order
   6 alien.accessors alien.c-types alien.data alien.syntax alien.strings
   7 namespaces libc io.encodings.ascii classes compiler.test ;
   8 FROM: math => float ;
   9 FROM: alien.c-types => short ;
  10 QUALIFIED-WITH: alien.c-types c
  11 IN: compiler.tests.intrinsics
  12
  13 ! Make sure that intrinsic ops compile to correct code.
  14 [ ] [ 1 [ drop ] compile-call ] unit-test
  15 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
  16 [ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test
  17 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
  18 [ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test
  19 [ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test
  20 [ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test
  21 [ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test
  22 [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
  23 [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
  24 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
  25 [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
  26 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
  27 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
  28 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
  29
  30 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
  31 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
  32
  33 [ { f f } ] [ 2 f <array> ] unit-test
  34
  35 [ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
  36 [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
  37 [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
  38 [ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
  39 [ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
  40 [ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
  41
  42 ! Write barrier hits on the wrong value were causing segfaults
  43 [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
  44
  45 [ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
  46 [ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
  47 [ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
  48 [ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
  49 [ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
  50 [ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
  51
  52 [ 0x123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
  53 [ 0x123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
  54 [ 0x123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
  55 [ 0x123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
  56 [ 0x123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
  57 [ 0x123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
  58
  59 [ ] [ [ 0 special-object ] compile-call drop ] unit-test
  60 [ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test
  61
  62 [ ] [ 1 [ drop ] compile-call ] unit-test
  63 [ ] [ [ 1 drop ] compile-call ] unit-test
  64 [ ] [ [ 1 2 2drop ] compile-call ] unit-test
  65 [ ] [ 1 [ 2 2drop ] compile-call ] unit-test
  66 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
  67 [ 2 1 ] [ [ 1 2 swap ] compile-call ] unit-test
  68 [ 2 1 ] [ 1 [ 2 swap ] compile-call ] unit-test
  69 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
  70 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
  71 [ 1 1 ] [ [ 1 dup ] compile-call ] unit-test
  72 [ 1 2 1 ] [ [ 1 2 over ] compile-call ] unit-test
  73 [ 1 2 1 ] [ 1 [ 2 over ] compile-call ] unit-test
  74 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
  75 [ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-call ] unit-test
  76 [ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-call ] unit-test
  77 [ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-call ] unit-test
  78 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
  79 [ 1 1 2 ] [ [ 1 2 dupd ] compile-call ] unit-test
  80 [ 1 1 2 ] [ 1 [ 2 dupd ] compile-call ] unit-test
  81 [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
  82 [ 2 ] [ [ 1 2 nip ] compile-call ] unit-test
  83 [ 2 ] [ 1 [ 2 nip ] compile-call ] unit-test
  84 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
  85
  86 [ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-call ] unit-test
  87
  88 [ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
  89 [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
  90 [ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
  91 [ -16 ] [ -1 [ -16 fixnum-bitand ] compile-call ] unit-test
  92
  93 [ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
  94 [ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
  95 [ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
  96 [ -1 ] [ -1 [ -16 fixnum-bitor ] compile-call ] unit-test
  97
  98 [ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
  99 [ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
 100 [ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
 101 [ 15 ] [ -1 [ -16 fixnum-bitxor ] compile-call ] unit-test
 102
 103 [ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 104 [ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 105 [ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 106 [ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 107 [ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 108
 109 [ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 110 [ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 111 [ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 112
 113 [ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 114 [ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 115 [ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 116 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 117 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 118 [ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 119
 120 [ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 121 [ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 122 [ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 123
 124 [ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 125 [ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 126 [ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 127 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 128 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 129 [ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 130
 131 [ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 132 [ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 133 [ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 134
 135 [ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 136 [ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 137 [ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 138 [ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 139 [ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 140
 141 [ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 142 [ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 143 [ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 144
 145 [ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
 146 [ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
 147 [ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
 148 [ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
 149 [ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
 150 [ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
 151
 152 [ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] unit-test
 153 [ -1 ] [ [ 0 fixnum-bitnot ] compile-call ] unit-test
 154
 155 [ 3 ] [ 13 10 [ fixnum-mod ] compile-call ] unit-test
 156 [ 3 ] [ 13 [ 10 fixnum-mod ] compile-call ] unit-test
 157 [ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test
 158 [ -3 ] [ -13 10 [ fixnum-mod ] compile-call ] unit-test
 159 [ -3 ] [ -13 [ 10 fixnum-mod ] compile-call ] unit-test
 160 [ -3 ] [ [ -13 10 fixnum-mod ] compile-call ] unit-test
 161
 162 [ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test
 163 [ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test
 164 [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
 165 [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
 166
 167 [ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
 168 [ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
 169 [ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
 170 [ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
 171
 172 [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
 173 [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
 174 [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
 175
 176 [ 4 ] [ 1 3 [ fixnum+fast ] compile-call ] unit-test
 177 [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
 178 [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
 179
 180 [ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
 181 [ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
 182 [ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
 183
 184 [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
 185
 186 [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
 187 [ 6 ] [ 2 [ 3 fixnum*fast ] compile-call ] unit-test
 188 [ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test
 189 [ -6 ] [ 2 -3 [ fixnum*fast ] compile-call ] unit-test
 190 [ -6 ] [ 2 [ -3 fixnum*fast ] compile-call ] unit-test
 191 [ -6 ] [ [ 2 -3 fixnum*fast ] compile-call ] unit-test
 192
 193 [ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test
 194 [ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test
 195 [ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test
 196 [ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test
 197 [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
 198 [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
 199
 200 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 201 [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 202 [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
 203 [ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
 204
 205 [ 8 ] [ 1 3 [ fixnum-shift ] compile-call ] unit-test
 206 [ 8 ] [ 1 [ 3 fixnum-shift ] compile-call ] unit-test
 207 [ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test
 208 [ -8 ] [ -1 3 [ fixnum-shift ] compile-call ] unit-test
 209 [ -8 ] [ -1 [ 3 fixnum-shift ] compile-call ] unit-test
 210 [ -8 ] [ [ -1 3 fixnum-shift ] compile-call ] unit-test
 211
 212 [ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] unit-test
 213 [ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] unit-test
 214
 215 [ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
 216 [ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
 217 [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
 218 [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
 219
 220 [ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
 221 [ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
 222 [ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 223 [ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
 224 [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
 225 [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 226
 227 [ 8 ] [ 1 3 [ fixnum-shift-fast ] compile-call ] unit-test
 228 [ 8 ] [ 1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
 229 [ 8 ] [ 1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
 230 [ 8 ] [ [ 1 3 fixnum-shift-fast ] compile-call ] unit-test
 231 [ -8 ] [ -1 3 [ fixnum-shift-fast ] compile-call ] unit-test
 232 [ -8 ] [ -1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
 233 [ -8 ] [ -1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
 234 [ -8 ] [ [ -1 3 fixnum-shift-fast ] compile-call ] unit-test
 235
 236 [ 2 ] [ 8 -2 [ fixnum-shift-fast ] compile-call ] unit-test
 237 [ 2 ] [ 8 2 [ 15 bitand neg fixnum-shift-fast ] compile-call ] unit-test
 238 [ 2 ] [ 8 [ -2 fixnum-shift-fast ] compile-call ] unit-test
 239
 240 [ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
 241 [ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
 242 [ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 243 [ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
 244 [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
 245 [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 246
 247 [ 0x10000000 ] [ 0x1000000 0x10 [ fixnum* ] compile-call ] unit-test
 248 [ 0x8000000 ] [ -0x8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
 249 [ 0x8000000 ] [ -0x7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
 250
 251 [ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
 252 [ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
 253
 254 [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
 255 [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
 256 [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
 257 [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
 258
 259 [ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 260
 261 [ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 262
 263 [ t ] [ f [ f eq? ] compile-call ] unit-test
 264
 265 cell 8 = [
 266     [ 0x40400000 ] [
 267         0x4200 [ 0x7fff fixnum-bitand 13 fixnum-shift-fast 112 23 fixnum-shift-fast fixnum+fast ]
 268         compile-call
 269     ] unit-test
 270 ] when
 271
 272 ! regression
 273 [ 3 ] [
 274     100001 f <array> 3 100000 pick set-nth
 275     [ 100000 swap array-nth ] compile-call
 276 ] unit-test
 277
 278 [ 2 ] [ 2 4 [ fixnum-min ] compile-call ] unit-test
 279 [ 2 ] [ 4 2 [ fixnum-min ] compile-call ] unit-test
 280 [ 4 ] [ 2 4 [ fixnum-max ] compile-call ] unit-test
 281 [ 4 ] [ 4 2 [ fixnum-max ] compile-call ] unit-test
 282 [ -2 ] [ -2 -4 [ fixnum-max ] compile-call ] unit-test
 283 [ -2 ] [ -4 -2 [ fixnum-max ] compile-call ] unit-test
 284 [ -4 ] [ -2 -4 [ fixnum-min ] compile-call ] unit-test
 285 [ -4 ] [ -4 -2 [ fixnum-min ] compile-call ] unit-test
 286
 287 ! 64-bit overflow
 288 cell 8 = [
 289     [ t ] [ 1 fixnum-bits 2 - fixnum-shift dup [ fixnum+ ] compile-call 1 fixnum-bits 1 - fixnum-shift = ] unit-test
 290     [ t ] [ most-negative-fixnum [ -1 fixnum+ ] compile-call first-bignum 1 + neg = ] unit-test
 291
 292     [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
 293     [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
 294     [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 295     [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 296     [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 297
 298     [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test
 299     [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test
 300     [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
 301     [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test
 302     [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
 303     [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
 304
 305     [ t ] [ most-negative-fixnum -1 [ fixnum/i ] compile-call first-bignum = ] unit-test
 306
 307     [ t ] [ most-negative-fixnum -1 [ fixnum/mod ] compile-call [ first-bignum = ] [ zero? ] bi* and ] unit-test
 308
 309     [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
 310 ] when
 311
 312 ! Some randomized tests
 313 : compiled-fixnum* ( a b -- c ) fixnum* ;
 314
 315 ERROR: bug-in-fixnum* x y a b ;
 316
 317 [ ] [
 318     10000 [
 319         32 random-bits >fixnum
 320         32 random-bits >fixnum
 321         2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
 322         [ 4drop ] [ bug-in-fixnum* ] if
 323     ] times
 324 ] unit-test
 325
 326 : compiled-fixnum>bignum ( a -- b ) fixnum>bignum ;
 327
 328 [ bignum ] [ 0 compiled-fixnum>bignum class-of ] unit-test
 329
 330 [ ] [
 331     10000 [
 332         32 random-bits >fixnum
 333         dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
 334         [ drop ] [ "Oops" throw ] if
 335     ] times
 336 ] unit-test
 337
 338 : compiled-bignum>fixnum ( a -- b ) bignum>fixnum ;
 339
 340 [ ] [
 341     10000 [
 342         5 random <iota> [ drop 32 random-bits ] map product >bignum
 343         dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
 344         [ drop ] [ "Oops" throw ] if
 345     ] times
 346 ] unit-test
 347
 348 ! Test overflow check removal
 349 [ t ] [
 350     most-positive-fixnum 100 - >fixnum
 351     200
 352     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 353     [ fixnum+ >fixnum ] compile-call
 354     =
 355 ] unit-test
 356
 357 [ t ] [
 358     most-negative-fixnum 100 + >fixnum
 359     -200
 360     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 361     [ fixnum+ >fixnum ] compile-call
 362     =
 363 ] unit-test
 364
 365 [ t ] [
 366     most-negative-fixnum 100 + >fixnum
 367     200
 368     [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 369     [ fixnum- >fixnum ] compile-call
 370     =
 371 ] unit-test
 372
 373 ! Test inline allocators
 374 [ { 1 1 1 } ] [
 375     [ 3 1 <array> ] compile-call
 376 ] unit-test
 377
 378 [ B{ 0 0 0 } ] [
 379     [ 3 <byte-array> ] compile-call
 380 ] unit-test
 381
 382 [ 500 ] [
 383     [ 500 <byte-array> length ] compile-call
 384 ] unit-test
 385
 386 [ 1 2 ] [
 387     1 2 [ complex boa ] compile-call
 388     dup real-part swap imaginary-part
 389 ] unit-test
 390
 391 [ 1 2 ] [
 392     1 2 [ ratio boa ] compile-call dup numerator swap denominator
 393 ] unit-test
 394
 395 [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
 396
 397 [ B{ 0 0 0 0 0 } ] [
 398     [ 5 <byte-array> ] compile-call
 399 ] unit-test
 400
 401 [ V{ 1 2 } ] [
 402     { 1 2 3 } 2 [ vector boa ] compile-call
 403 ] unit-test
 404
 405 [ SBUF" hello" ] [
 406     "hello world" 5 [ sbuf boa ] compile-call
 407 ] unit-test
 408
 409 [ [ 3 + ] ] [
 410     3 [ + ] [ curry ] compile-call
 411 ] unit-test
 412
 413 ! Alien intrinsics
 414 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-call ] unit-test
 415 [ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-call ] unit-test
 416 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 417 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 418
 419 [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
 420 [ t ] [ "b" get >boolean ] unit-test
 421
 422 "b" get [
 423     [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
 424     [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
 425     [ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 426     [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 427
 428     [ ] [ "b" get free ] unit-test
 429 ] when
 430
 431 [ ] [ "hello world" ascii malloc-string "s" set ] unit-test
 432
 433 "s" get [
 434     [ "hello world" ] [ "s" get void* <ref> [ { byte-array } declare void* deref ] compile-call ascii alien>string ] unit-test
 435     [ "hello world" ] [ "s" get void* <ref> [ { c-ptr } declare void* deref ] compile-call ascii alien>string ] unit-test
 436
 437     [ ] [ "s" get free ] unit-test
 438 ] when
 439
 440 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare void* <ref> ] compile-call void* deref ] unit-test
 441 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare void* <ref> ] compile-call void* deref ] unit-test
 442 [ f ] [ f [ { POSTPONE: f } declare void* <ref> ] compile-call void* deref ] unit-test
 443
 444 [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 445 [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
 446
 447 [ -100 ] [ -100 char <ref> [ { byte-array } declare char deref ] compile-call ] unit-test
 448 [ 156 ] [ -100 uchar <ref> [ { byte-array } declare uchar deref ] compile-call ] unit-test
 449
 450 [ -100 ] [ -100 [ char <ref> ] [ { fixnum } declare ] prepend compile-call char deref ] unit-test
 451 [ 156 ] [ -100 [ uchar <ref> ] [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test
 452
 453 [ -1000 ] [ -1000 short <ref> [ { byte-array } declare short deref ] compile-call ] unit-test
 454 [ 64536 ] [ -1000 ushort <ref> [ { byte-array } declare ushort deref ] compile-call ] unit-test
 455
 456 [ -1000 ] [ -1000 [ short <ref> ] [ { fixnum } declare ] prepend compile-call short deref ] unit-test
 457 [ 64536 ] [ -1000 [ ushort <ref> ] [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test
 458
 459 [ -100000 ] [ -100000 int <ref> [ { byte-array } declare int deref ] compile-call ] unit-test
 460 [ 4294867296 ] [ -100000 uint <ref> [ { byte-array } declare uint deref ] compile-call ] unit-test
 461
 462 [ -100000 ] [ -100000 [ int <ref> ] [ { fixnum } declare ] prepend compile-call int deref ] unit-test
 463 [ 4294867296 ] [ -100000 [ uint <ref> ] [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
 464
 465 [ t ] [ pi pi double <ref> double deref = ] unit-test
 466
 467 [ t ] [ pi double <ref> [ { byte-array } declare double deref ] compile-call pi = ] unit-test
 468
 469 ! Silly
 470 [ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep c:float deref pi - -0.001 0.001 between? ] unit-test
 471 [ t ] [ pi c:float <ref> [ { byte-array } declare c:float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
 472
 473 [ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep double deref pi = ] unit-test
 474
 475 [ 4 ] [
 476     2 B{ 1 2 3 4 5 6 } <displaced-alien> [
 477         { alien } declare 1 alien-unsigned-1
 478     ] compile-call
 479 ] unit-test
 480
 481 [ ALIEN: 123 ] [
 482     0x123 [ <alien> ] compile-call
 483 ] unit-test
 484
 485 [ ALIEN: 123 ] [
 486     0x123 [ { fixnum } declare <alien> ] compile-call
 487 ] unit-test
 488
 489 [ ALIEN: 123 ] [
 490     [ 0x123 <alien> ] compile-call
 491 ] unit-test
 492
 493 [ f ] [
 494     0 [ <alien> ] compile-call
 495 ] unit-test
 496
 497 [ f ] [
 498     0 [ { fixnum } declare <alien> ] compile-call
 499 ] unit-test
 500
 501 [ f ] [
 502     [ 0 <alien> ] compile-call
 503 ] unit-test
 504
 505 [ ALIEN: 321 ] [
 506     0 ALIEN: 321 [ <displaced-alien> ] compile-call
 507 ] unit-test
 508
 509 [ ALIEN: 321 ] [
 510     0 ALIEN: 321 [ { fixnum c-ptr } declare <displaced-alien> ] compile-call
 511 ] unit-test
 512
 513 [ ALIEN: 321 ] [
 514     ALIEN: 321 [ 0 swap <displaced-alien> ] compile-call
 515 ] unit-test
 516
 517 [ B{ 0 1 2 3 4 } ] [
 518    2  B{ 0 1 2 3 4 } <displaced-alien>
 519     [ 1 swap <displaced-alien> ] compile-call
 520     underlying>>
 521 ] unit-test
 522
 523 [ B{ 0 1 2 3 4 } ] [
 524     2 B{ 0 1 2 3 4 } <displaced-alien>
 525     [ 1 swap { c-ptr } declare <displaced-alien> ] compile-call
 526     underlying>>
 527 ] unit-test
 528
 529 [ ALIEN: 1234 ALIEN: 2234 ] [
 530     ALIEN: 234 [
 531         { c-ptr } declare
 532         [ 0x1000 swap <displaced-alien> ]
 533         [ 0x2000 swap <displaced-alien> ] bi
 534     ] compile-call
 535 ] unit-test
 536
 537 ! These tests must fail because we're not allowed to store
 538 ! a pointer to a byte array inside of an alien object
 539 [
 540     B{ 0 0 0 0 } [ { byte-array } declare void* <ref> ] compile-call
 541 ] must-fail
 542
 543 [
 544     B{ 0 0 0 0 } [ { c-ptr } declare void* <ref> ] compile-call
 545 ] must-fail
 546
 547 [
 548     4 5
 549 ] [
 550     3 [
 551         [
 552             { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
 553         ] keep 2 fixnum+fast
 554     ] compile-call
 555 ] unit-test
 556
 557 [ 1 ] [
 558     8 -3 [ fixnum-shift-fast ] compile-call
 559 ] unit-test
 560
 561 [ 2 ] [
 562     16 -3 [ fixnum-shift-fast ] compile-call
 563 ] unit-test
 564
 565 [ 2 ] [
 566     16 [ -3 fixnum-shift-fast ] compile-call
 567 ] unit-test
 568
 569 [ 8 ] [
 570     1 3 [ fixnum-shift-fast ] compile-call
 571 ] unit-test
 572
 573 [ 8 ] [
 574     1 [ 3 fixnum-shift-fast ] compile-call
 575 ] unit-test
 576
 577 TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
 578
 579 [ B{ 0 1 } ] [
 580     B{ 0 0 } 1 alien-accessor-regression boa
 581     dup [
 582         { alien-accessor-regression } declare
 583         [ i>> ] [ b>> ] bi over set-alien-unsigned-1
 584     ] compile-call
 585     b>>
 586 ] unit-test
 587
 588 : mutable-value-bug-1 ( a b -- c )
 589     swap [
 590         { tuple } declare 1 slot
 591     ] [
 592         1 slot
 593     ] if ;
 594
 595 [ 0 ] [ f { } mutable-value-bug-1 ] unit-test
 596
 597 : mutable-value-bug-2 ( a b -- c )
 598     swap [
 599         1 slot
 600     ] [
 601         { tuple } declare 1 slot
 602     ] if ;
 603
 604 [ 0 ] [ t { } mutable-value-bug-2 ] unit-test