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 QUALIFIED-WITH: alien.c-types c
  10 IN: compiler.tests.intrinsics
  11
  12 ! Make sure that intrinsic ops compile to correct code.
  13 { } [ 1 [ drop ] compile-call ] unit-test
  14 { } [ 1 2 [ 2drop ] compile-call ] unit-test
  15 { } [ 1 2 3 [ 3drop ] compile-call ] unit-test
  16 { 1 1 } [ 1 [ dup ] compile-call ] unit-test
  17 { 1 2 1 2 } [ 1 2 [ 2dup ] compile-call ] unit-test
  18 { 1 2 3 1 2 3 } [ 1 2 3 [ 3dup ] compile-call ] unit-test
  19 { 2 3 1 } [ 1 2 3 [ rot ] compile-call ] unit-test
  20 { 3 1 2 } [ 1 2 3 [ -rot ] compile-call ] unit-test
  21 { 1 1 2 } [ 1 2 [ dupd ] compile-call ] unit-test
  22 { 2 1 3 } [ 1 2 3 [ swapd ] compile-call ] unit-test
  23 { 2 } [ 1 2 [ nip ] compile-call ] unit-test
  24 { 3 } [ 1 2 3 [ 2nip ] 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 { 0x123456 } [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
  52 { 0x123456 } [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
  53 { 0x123456 } [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
  54 { 0x123456 } [ 1 "a\u123456c" [ 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
  58 [ [ 0 special-object ] compile-call ] must-not-fail
  59 { } [ 1 special-object [ 1 set-special-object ] 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 { -16 } [ -1 [ -16 fixnum-bitand ] compile-call ] unit-test
  91
  92 { 15 } [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
  93 { 15 } [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
  94 { 15 } [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
  95 { -1 } [ -1 [ -16 fixnum-bitor ] compile-call ] unit-test
  96
  97 { 11 } [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
  98 { 11 } [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
  99 { 11 } [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
 100 { 15 } [ -1 [ -16 fixnum-bitxor ] compile-call ] unit-test
 101
 102 { f } [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 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 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 106 { f } [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 107
 108 { t } [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
 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
 112 { f } [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 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 { t } [ [ 12 12 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
 119 { t } [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
 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
 123 { t } [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 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 { f } [ [ 12 12 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
 130 { f } [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
 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
 134 { t } [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 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 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 138 { t } [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 139
 140 { f } [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
 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
 144 { f } [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
 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 { t } [ 3 3 [ 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
 151 { -1 } [ 0 [ fixnum-bitnot ] compile-call ] unit-test
 152 { -1 } [ [ 0 fixnum-bitnot ] compile-call ] unit-test
 153
 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 { -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
 161 { 2 } [ 4 2 [ fixnum/i ] compile-call ] unit-test
 162 { 2 } [ 4 [ 2 fixnum/i ] compile-call ] unit-test
 163 { -2 } [ 4 [ -2 fixnum/i ] compile-call ] unit-test
 164 { 3 1 } [ 10 3 [ fixnum/mod ] compile-call ] unit-test
 165
 166 { 2 } [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
 167 { 2 } [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
 168 { -2 } [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
 169 { 3 1 } [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
 170
 171 { 4 } [ 1 3 [ fixnum+ ] compile-call ] unit-test
 172 { 4 } [ 1 [ 3 fixnum+ ] compile-call ] unit-test
 173 { 4 } [ [ 1 3 fixnum+ ] compile-call ] unit-test
 174
 175 { 4 } [ 1 3 [ fixnum+fast ] compile-call ] unit-test
 176 { 4 } [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
 177 { 4 } [ [ 1 3 fixnum+fast ] compile-call ] unit-test
 178
 179 { -2 } [ 1 3 [ fixnum-fast ] compile-call ] unit-test
 180 { -2 } [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
 181 { -2 } [ [ 1 3 fixnum-fast ] compile-call ] unit-test
 182
 183 { 30001 } [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
 184
 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 { -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
 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 { -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
 199 { 5 } [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 200 { 3 } [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 201 { 3 } [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
 202 { 5 } [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
 203
 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 { -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
 211 { 2 } [ 8 -2 [ fixnum-shift ] compile-call ] unit-test
 212 { 2 } [ 8 [ -2 fixnum-shift ] compile-call ] unit-test
 213
 214 { 0 } [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
 215 { 0 } [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
 216 { -1 } [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
 217 { -1 } [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
 218
 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 { -4294967296 } [ -1 32 [ fixnum-shift ] compile-call ] unit-test
 223 { -4294967296 } [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
 224 { -4294967296 } [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 225
 226 { 8 } [ 1 3 [ fixnum-shift-fast ] compile-call ] unit-test
 227 { 8 } [ 1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
 228 { 8 } [ 1 [ 3 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 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
 232 { -8 } [ -1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
 233 { -8 } [ [ -1 3 fixnum-shift-fast ] compile-call ] unit-test
 234
 235 { 2 } [ 8 -2 [ fixnum-shift-fast ] compile-call ] unit-test
 236 { 2 } [ 8 2 [ 15 bitand neg fixnum-shift-fast ] compile-call ] unit-test
 237 { 2 } [ 8 [ -2 fixnum-shift-fast ] compile-call ] unit-test
 238
 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 { -4294967296 } [ -1 32 [ fixnum-shift ] compile-call ] unit-test
 243 { -4294967296 } [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
 244 { -4294967296 } [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
 245
 246 { 0x10000000 } [ 0x1000000 0x10 [ fixnum* ] compile-call ] unit-test
 247 { 0x8000000 } [ -0x8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
 248 { 0x8000000 } [ -0x7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
 249
 250 { t } [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
 251 { -134217729 } [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
 252
 253 { t } [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
 254 { t } [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
 255 { t } [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
 256 { -351382792 } [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
 257
 258 { 134217728 } [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
 259
 260 { 134217728 0 } [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
 261
 262 { t } [ f [ f eq? ] compile-call ] unit-test
 263
 264 cell 8 = [
 265     { 0x40400000 } [
 266         0x4200 [ 0x7fff fixnum-bitand 13 fixnum-shift-fast 112 23 fixnum-shift-fast fixnum+fast ]
 267         compile-call
 268     ] unit-test
 269 ] when
 270
 271 ! regression
 272 { 3 } [
 273     100001 f <array> 3 100000 pick set-nth
 274     [ 100000 swap array-nth ] compile-call
 275 ] unit-test
 276
 277 { 2 } [ 2 4 [ fixnum-min ] compile-call ] unit-test
 278 { 2 } [ 4 2 [ fixnum-min ] compile-call ] unit-test
 279 { 4 } [ 2 4 [ fixnum-max ] compile-call ] unit-test
 280 { 4 } [ 4 2 [ fixnum-max ] compile-call ] unit-test
 281 { -2 } [ -2 -4 [ fixnum-max ] compile-call ] unit-test
 282 { -2 } [ -4 -2 [ fixnum-max ] compile-call ] unit-test
 283 { -4 } [ -2 -4 [ fixnum-min ] compile-call ] unit-test
 284 { -4 } [ -4 -2 [ fixnum-min ] compile-call ] unit-test
 285
 286 ! 64-bit overflow
 287 cell 8 = [
 288     { t } [ 1 fixnum-bits 2 - fixnum-shift dup [ fixnum+ ] compile-call 1 fixnum-bits 1 - fixnum-shift = ] unit-test
 289     { t } [ most-negative-fixnum [ -1 fixnum+ ] compile-call first-bignum 1 + neg = ] unit-test
 290
 291     { t } [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
 292     { t } [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
 293     { t } [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 294     { t } [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 295     { t } [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
 296
 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     { -18446744073709551616 } [ -1 64 [ fixnum-shift ] compile-call ] unit-test
 301     { -18446744073709551616 } [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
 302     { -18446744073709551616 } [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
 303
 304     { t } [ most-negative-fixnum -1 [ fixnum/i ] compile-call first-bignum = ] unit-test
 305
 306     { t } [ most-negative-fixnum -1 [ fixnum/mod ] compile-call [ first-bignum = ] [ zero? ] bi* and ] unit-test
 307
 308     { -268435457 } [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
 309 ] when
 310
 311 ! Some randomized tests
 312 : compiled-fixnum* ( a b -- c ) fixnum* ;
 313
 314 ERROR: bug-in-fixnum* x y a b ;
 315
 316 { } [
 317     10000 [
 318         32 random-bits >fixnum
 319         32 random-bits >fixnum
 320         2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
 321         [ 4drop ] [ bug-in-fixnum* ] if
 322     ] times
 323 ] unit-test
 324
 325 : compiled-fixnum>bignum ( a -- b ) fixnum>bignum ;
 326
 327 { bignum } [ 0 compiled-fixnum>bignum class-of ] unit-test
 328
 329 { } [
 330     10000 [
 331         32 random-bits >fixnum
 332         dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
 333         [ drop ] [ "Oops" throw ] if
 334     ] times
 335 ] unit-test
 336
 337 : compiled-bignum>fixnum ( a -- b ) bignum>fixnum ;
 338
 339 { } [
 340     10000 [
 341         5 random <iota> [ drop 32 random-bits ] map product >bignum
 342         dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
 343         [ drop ] [ "Oops" throw ] if
 344     ] times
 345 ] unit-test
 346
 347 ! Test overflow check removal
 348 { t } [
 349     most-positive-fixnum 100 - >fixnum
 350     200
 351     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 352     [ fixnum+ >fixnum ] compile-call
 353     =
 354 ] unit-test
 355
 356 { t } [
 357     most-negative-fixnum 100 + >fixnum
 358     -200
 359     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 360     [ fixnum+ >fixnum ] compile-call
 361     =
 362 ] unit-test
 363
 364 { t } [
 365     most-negative-fixnum 100 + >fixnum
 366     200
 367     [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
 368     [ fixnum- >fixnum ] compile-call
 369     =
 370 ] unit-test
 371
 372 ! Test inline allocators
 373 { { 1 1 1 } } [
 374     [ 3 1 <array> ] compile-call
 375 ] unit-test
 376
 377 { B{ 0 0 0 } } [
 378     [ 3 <byte-array> ] compile-call
 379 ] unit-test
 380
 381 { 500 } [
 382     [ 500 <byte-array> length ] compile-call
 383 ] unit-test
 384
 385 { 1 2 } [
 386     1 2 [ complex boa ] compile-call
 387     dup real-part swap imaginary-part
 388 ] unit-test
 389
 390 { 1 2 } [
 391     1 2 [ ratio boa ] compile-call dup numerator swap denominator
 392 ] unit-test
 393
 394 { \ + } [ \ + [ <wrapper> ] compile-call ] unit-test
 395
 396 { B{ 0 0 0 0 0 } } [
 397     [ 5 <byte-array> ] compile-call
 398 ] unit-test
 399
 400 { V{ 1 2 } } [
 401     { 1 2 3 } 2 [ vector boa ] compile-call
 402 ] unit-test
 403
 404 { SBUF" hello" } [
 405     "hello world" 5 [ sbuf boa ] compile-call
 406 ] unit-test
 407
 408 { [ 3 + ] } [
 409     3 [ + ] [ curry ] compile-call
 410 ] unit-test
 411
 412 ! Alien intrinsics
 413 { 3 } [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-call ] unit-test
 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 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 416 { 3 } [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 417
 418 { } [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
 419 { t } [ "b" get >boolean ] unit-test
 420
 421 "b" get [
 422     { 3 } [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
 423     { 3 } [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
 424     { 3 } [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 425     { 3 } [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 426
 427     { } [ "b" get free ] unit-test
 428 ] when
 429
 430 { } [ "hello world" ascii malloc-string "s" set ] unit-test
 431
 432 "s" get [
 433     { "hello world" } [ "s" get void* <ref> [ { byte-array } declare void* deref ] compile-call ascii alien>string ] unit-test
 434     { "hello world" } [ "s" get void* <ref> [ { c-ptr } declare void* deref ] compile-call ascii alien>string ] unit-test
 435
 436     { } [ "s" get free ] unit-test
 437 ] when
 438
 439 { ALIEN: 1234 } [ ALIEN: 1234 [ { alien } declare void* <ref> ] compile-call void* deref ] unit-test
 440 { ALIEN: 1234 } [ ALIEN: 1234 [ { c-ptr } declare void* <ref> ] compile-call void* deref ] unit-test
 441 { f } [ f [ { POSTPONE: f } declare void* <ref> ] compile-call void* deref ] unit-test
 442
 443 { 252 } [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 444 { -4 } [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
 445
 446 { -100 } [ -100 char <ref> [ { byte-array } declare char deref ] compile-call ] unit-test
 447 { 156 } [ -100 uchar <ref> [ { byte-array } declare uchar deref ] compile-call ] unit-test
 448
 449 { -100 } [ -100 [ char <ref> ] [ { fixnum } declare ] prepend compile-call char deref ] unit-test
 450 { 156 } [ -100 [ uchar <ref> ] [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test
 451
 452 { -1000 } [ -1000 short <ref> [ { byte-array } declare short deref ] compile-call ] unit-test
 453 { 64536 } [ -1000 ushort <ref> [ { byte-array } declare ushort deref ] compile-call ] unit-test
 454
 455 { -1000 } [ -1000 [ short <ref> ] [ { fixnum } declare ] prepend compile-call short deref ] unit-test
 456 { 64536 } [ -1000 [ ushort <ref> ] [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test
 457
 458 { -100000 } [ -100000 int <ref> [ { byte-array } declare int deref ] compile-call ] unit-test
 459 { 4294867296 } [ -100000 uint <ref> [ { byte-array } declare uint deref ] compile-call ] unit-test
 460
 461 { -100000 } [ -100000 [ int <ref> ] [ { fixnum } declare ] prepend compile-call int deref ] unit-test
 462 { 4294867296 } [ -100000 [ uint <ref> ] [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
 463
 464 { t } [ pi pi double <ref> double deref = ] unit-test
 465
 466 { t } [ pi double <ref> [ { byte-array } declare double deref ] compile-call pi = ] unit-test
 467
 468 ! Silly
 469 { 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
 470 { t } [ pi c:float <ref> [ { byte-array } declare c:float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
 471
 472 { t } [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep double deref pi = ] unit-test
 473
 474 { 4 } [
 475     2 B{ 1 2 3 4 5 6 } <displaced-alien> [
 476         { alien } declare 1 alien-unsigned-1
 477     ] compile-call
 478 ] unit-test
 479
 480 { ALIEN: 123 } [
 481     0x123 [ <alien> ] compile-call
 482 ] unit-test
 483
 484 { ALIEN: 123 } [
 485     0x123 [ { fixnum } declare <alien> ] compile-call
 486 ] unit-test
 487
 488 { ALIEN: 123 } [
 489     [ 0x123 <alien> ] compile-call
 490 ] unit-test
 491
 492 { f } [
 493     0 [ <alien> ] compile-call
 494 ] unit-test
 495
 496 { f } [
 497     0 [ { fixnum } declare <alien> ] compile-call
 498 ] unit-test
 499
 500 { f } [
 501     [ 0 <alien> ] compile-call
 502 ] unit-test
 503
 504 { ALIEN: 321 } [
 505     0 ALIEN: 321 [ <displaced-alien> ] compile-call
 506 ] unit-test
 507
 508 { ALIEN: 321 } [
 509     0 ALIEN: 321 [ { fixnum c-ptr } declare <displaced-alien> ] compile-call
 510 ] unit-test
 511
 512 { ALIEN: 321 } [
 513     ALIEN: 321 [ 0 swap <displaced-alien> ] compile-call
 514 ] unit-test
 515
 516 { B{ 0 1 2 3 4 } } [
 517     2 B{ 0 1 2 3 4 } <displaced-alien>
 518     [ 1 swap <displaced-alien> ] compile-call
 519     underlying>>
 520 ] unit-test
 521
 522 { B{ 0 1 2 3 4 } } [
 523     2 B{ 0 1 2 3 4 } <displaced-alien>
 524     [ 1 swap { c-ptr } declare <displaced-alien> ] compile-call
 525     underlying>>
 526 ] unit-test
 527
 528 { ALIEN: 1234 ALIEN: 2234 } [
 529     ALIEN: 234 [
 530         { c-ptr } declare
 531         [ 0x1000 swap <displaced-alien> ]
 532         [ 0x2000 swap <displaced-alien> ] bi
 533     ] compile-call
 534 ] unit-test
 535
 536 ! These tests must fail because we're not allowed to store
 537 ! a pointer to a byte array inside of an alien object
 538 [
 539     B{ 0 0 0 0 } [ { byte-array } declare void* <ref> ] compile-call
 540 ] must-fail
 541
 542 [
 543     B{ 0 0 0 0 } [ { c-ptr } declare void* <ref> ] compile-call
 544 ] must-fail
 545
 546 { 4 5 } [
 547     3 [
 548         [
 549             { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
 550         ] keep 2 fixnum+fast
 551     ] compile-call
 552 ] unit-test
 553
 554 { 1 } [
 555     8 -3 [ fixnum-shift-fast ] compile-call
 556 ] unit-test
 557
 558 { 2 } [
 559     16 -3 [ fixnum-shift-fast ] compile-call
 560 ] unit-test
 561
 562 { 2 } [
 563     16 [ -3 fixnum-shift-fast ] compile-call
 564 ] unit-test
 565
 566 { 8 } [
 567     1 3 [ fixnum-shift-fast ] compile-call
 568 ] unit-test
 569
 570 { 8 } [
 571     1 [ 3 fixnum-shift-fast ] compile-call
 572 ] unit-test
 573
 574 TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
 575
 576 { B{ 0 1 } } [
 577     B{ 0 0 } 1 alien-accessor-regression boa
 578     dup [
 579         { alien-accessor-regression } declare
 580         [ i>> ] [ b>> ] bi over set-alien-unsigned-1
 581     ] compile-call
 582     b>>
 583 ] unit-test
 584
 585 : mutable-value-bug-1 ( a b -- c )
 586     swap [
 587         { tuple } declare 1 slot
 588     ] [
 589         1 slot
 590     ] if ;
 591
 592 { 0 } [ f { } mutable-value-bug-1 ] unit-test
 593
 594 : mutable-value-bug-2 ( a b -- c )
 595     swap [
 596         1 slot
 597     ] [
 598         { tuple } declare 1 slot
 599     ] if ;
 600
 601 { 0 } [ t { } mutable-value-bug-2 ] unit-test