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