Ticket #1114: perl_to_pir.patch
| File perl_to_pir.patch, 33.4 KB (added by mgrimes, 12 years ago) |
|---|
-
t/op/arithmetics_pmc.t
1 #! perl1 #! parrot 2 2 # Copyright (C) 2001-2009, Parrot Foundation. 3 3 # $Id$ 4 4 5 use strict;6 use warnings;7 use lib qw( . lib ../lib ../../lib );8 9 use Test::More;10 use Parrot::Test;11 12 # test for GMP13 use Parrot::Config;14 15 5 =head1 NAME 16 6 17 7 t/op/arithmetics_pmc.t - Arithmetic Ops involving PMCs … … 26 16 27 17 =cut 28 18 29 # We don't check BigInt and BigNum ops 30 if ( $PConfig{gmp} ) { 31 plan tests => 68; 32 } 33 else { 34 plan tests => 34; 35 } 19 .sub main :main 20 .include 'test_more.pir' 21 .include "iglobals.pasm" 36 22 23 plan(68) 37 24 38 # Map vtable method to op 39 my %methods = qw{ 40 add add 41 subtract sub 42 multiply mul 43 divide div 25 # Don't check BigInt or BigNum without gmp 26 .local pmc interp # a handle to our interpreter object. 27 interp = getinterp 28 .local pmc config 29 config = interp[.IGLOBALS_CONFIG_HASH] 30 .local int gmp 31 gmp = config['gmp'] 44 32 45 floor_divide fdiv 46 modulus mod 47 pow pow 33 run_tests_for('Integer') 34 run_tests_for('Float') 48 35 49 bitwise_or bor50 bitwise_and band51 bitwise_xor bxor36 if gmp goto do_big_ones 37 skip( 34, "will not test BigInt or BigNum without gmp" ) 38 goto end 52 39 53 bitwise_shr shr54 bitwise_shl shl55 bitwise_lsr lsr40 do_big_ones: 41 run_tests_for('BigInt') 42 run_tests_for('BigNum') 56 43 57 concatenate concat 44 end: 45 .end 58 46 59 logical_or or 60 logical_and and 61 logical_xor xor 62 }; 47 .sub run_tests_for 48 .param pmc type 49 test_add(type) 50 test_divide(type) 51 test_multiply(type) 52 test_floor_divide(type) 53 test_logical_and(type) 54 test_concatenate(type) 55 test_logical_xor(type) 56 test_logical_or(type) 57 test_bitwise_shr(type) 58 test_bitwise_or(type) 59 test_bitwise_shl(type) 60 test_bitwise_xor(type) 61 test_modulus(type) 62 test_pow(type) 63 test_subtract(type) 64 test_bitwise_lsr(type) 65 test_bitwise_and(type) 66 .end 63 67 64 # XXX Put BigInt and BigNum here 65 my @pmcs = qw{ 66 Integer Float 67 }; 68 .sub test_add 69 .param pmc type 68 70 69 if ($PConfig{gmp}) { 70 push @pmcs, qw{ BigInt BigNum}; 71 } 71 $P0 = new type 72 $P0 = 40 73 $P1 = new type 74 $P1 = 2 75 $P2 = new type 76 $P2 = 115200 72 77 73 foreach my $pmc (@pmcs) { 74 while(my($vtable, $op) = each(%methods)) { 78 $P99 = $P2 75 79 76 # We should generate more tests for all possible combinations 77 pir_output_is( <<"CODE", <<OUTPUT, "Original dest is untouched in $pmc.$vtable " ); 78 .sub 'test' :main 79 \$P0 = new '$pmc' 80 \$P0 = 40 81 \$P1 = new '$pmc' 82 \$P1 = 2 83 \$P2 = new '$pmc' 84 \$P2 = 115200 80 $S0 = "original dest is untouched in add for " 81 $S1 = type 82 concat $S0, $S1 85 83 86 \$P99 = \$P287 84 # ignore exceptions 88 85 push_eh done 89 $op \$P2, \$P0, \$P186 add $P2, $P0, $P1 90 87 91 \$I0 = cmp \$P99, 115200 92 unless \$I0 goto done 93 print " not " 88 $I0 = cmp $P99, 115200 89 90 is( $I0, 0, $S0 ) 91 goto end 92 94 93 done: 95 say "ok" 94 ok(1, 'ignoring exceptions') 95 end: 96 96 .end 97 CODE98 ok99 OUTPUT100 97 101 } 102 } 98 .sub test_divide 99 .param pmc type 103 100 101 $P0 = new type 102 $P0 = 40 103 $P1 = new type 104 $P1 = 2 105 $P2 = new type 106 $P2 = 115200 107 108 $P99 = $P2 109 110 $S0 = "original dest is untouched in divide for " 111 $S1 = type 112 concat $S0, $S1 113 114 # ignore exceptions 115 push_eh done 116 div $P2, $P0, $P1 117 118 $I0 = cmp $P99, 115200 119 120 is( $I0, 0, $S0 ) 121 goto end 122 123 done: 124 ok(1, 'ignoring exceptions') 125 end: 126 .end 127 128 .sub test_multiply 129 .param pmc type 130 131 $P0 = new type 132 $P0 = 40 133 $P1 = new type 134 $P1 = 2 135 $P2 = new type 136 $P2 = 115200 137 138 $P99 = $P2 139 140 $S0 = "original dest is untouched in multiply for " 141 $S1 = type 142 concat $S0, $S1 143 144 # ignore exceptions 145 push_eh done 146 mul $P2, $P0, $P1 147 148 $I0 = cmp $P99, 115200 149 150 is( $I0, 0, $S0 ) 151 goto end 152 153 done: 154 ok(1, 'ignoring exceptions') 155 end: 156 .end 157 158 .sub test_floor_divide 159 .param pmc type 160 161 $P0 = new type 162 $P0 = 40 163 $P1 = new type 164 $P1 = 2 165 $P2 = new type 166 $P2 = 115200 167 168 $P99 = $P2 169 170 $S0 = "original dest is untouched in floor_divide for " 171 $S1 = type 172 concat $S0, $S1 173 174 # ignore exceptions 175 push_eh done 176 fdiv $P2, $P0, $P1 177 178 $I0 = cmp $P99, 115200 179 180 is( $I0, 0, $S0 ) 181 goto end 182 183 done: 184 ok(1, 'ignoring exceptions') 185 end: 186 .end 187 188 .sub test_logical_and 189 .param pmc type 190 191 $P0 = new type 192 $P0 = 40 193 $P1 = new type 194 $P1 = 2 195 $P2 = new type 196 $P2 = 115200 197 198 $P99 = $P2 199 200 $S0 = "original dest is untouched in logical_and for " 201 $S1 = type 202 concat $S0, $S1 203 204 # ignore exceptions 205 push_eh done 206 and $P2, $P0, $P1 207 208 $I0 = cmp $P99, 115200 209 210 is( $I0, 0, $S0 ) 211 goto end 212 213 done: 214 ok(1, 'ignoring exceptions') 215 end: 216 .end 217 218 .sub test_concatenate 219 .param pmc type 220 221 $P0 = new type 222 $P0 = 40 223 $P1 = new type 224 $P1 = 2 225 $P2 = new type 226 $P2 = 115200 227 228 $P99 = $P2 229 230 $S0 = "original dest is untouched in concatenate for " 231 $S1 = type 232 concat $S0, $S1 233 234 # ignore exceptions 235 push_eh done 236 concat $P2, $P0, $P1 237 238 $I0 = cmp $P99, 115200 239 240 is( $I0, 0, $S0 ) 241 goto end 242 243 done: 244 ok(1, 'ignoring exceptions') 245 end: 246 .end 247 248 .sub test_logical_xor 249 .param pmc type 250 251 $P0 = new type 252 $P0 = 40 253 $P1 = new type 254 $P1 = 2 255 $P2 = new type 256 $P2 = 115200 257 258 $P99 = $P2 259 260 $S0 = "original dest is untouched in logical_xor for " 261 $S1 = type 262 concat $S0, $S1 263 264 # ignore exceptions 265 push_eh done 266 xor $P2, $P0, $P1 267 268 $I0 = cmp $P99, 115200 269 270 is( $I0, 0, $S0 ) 271 goto end 272 273 done: 274 ok(1, 'ignoring exceptions') 275 end: 276 .end 277 278 .sub test_logical_or 279 .param pmc type 280 281 $P0 = new type 282 $P0 = 40 283 $P1 = new type 284 $P1 = 2 285 $P2 = new type 286 $P2 = 115200 287 288 $P99 = $P2 289 290 $S0 = "original dest is untouched in logical_or for " 291 $S1 = type 292 concat $S0, $S1 293 294 # ignore exceptions 295 push_eh done 296 or $P2, $P0, $P1 297 298 $I0 = cmp $P99, 115200 299 300 is( $I0, 0, $S0 ) 301 goto end 302 303 done: 304 ok(1, 'ignoring exceptions') 305 end: 306 .end 307 308 .sub test_bitwise_shr 309 .param pmc type 310 311 $P0 = new type 312 $P0 = 40 313 $P1 = new type 314 $P1 = 2 315 $P2 = new type 316 $P2 = 115200 317 318 $P99 = $P2 319 320 $S0 = "original dest is untouched in bitwise_shr for " 321 $S1 = type 322 concat $S0, $S1 323 324 # ignore exceptions 325 push_eh done 326 shr $P2, $P0, $P1 327 328 $I0 = cmp $P99, 115200 329 330 is( $I0, 0, $S0 ) 331 goto end 332 333 done: 334 ok(1, 'ignoring exceptions') 335 end: 336 .end 337 338 .sub test_bitwise_or 339 .param pmc type 340 341 $P0 = new type 342 $P0 = 40 343 $P1 = new type 344 $P1 = 2 345 $P2 = new type 346 $P2 = 115200 347 348 $P99 = $P2 349 350 $S0 = "original dest is untouched in bitwise_or for " 351 $S1 = type 352 concat $S0, $S1 353 354 # ignore exceptions 355 push_eh done 356 bor $P2, $P0, $P1 357 358 $I0 = cmp $P99, 115200 359 360 is( $I0, 0, $S0 ) 361 goto end 362 363 done: 364 ok(1, 'ignoring exceptions') 365 end: 366 .end 367 368 .sub test_bitwise_shl 369 .param pmc type 370 371 $P0 = new type 372 $P0 = 40 373 $P1 = new type 374 $P1 = 2 375 $P2 = new type 376 $P2 = 115200 377 378 $P99 = $P2 379 380 $S0 = "original dest is untouched in bitwise_shl for " 381 $S1 = type 382 concat $S0, $S1 383 384 # ignore exceptions 385 push_eh done 386 shl $P2, $P0, $P1 387 388 $I0 = cmp $P99, 115200 389 390 is( $I0, 0, $S0 ) 391 goto end 392 393 done: 394 ok(1, 'ignoring exceptions') 395 end: 396 .end 397 398 .sub test_bitwise_xor 399 .param pmc type 400 401 $P0 = new type 402 $P0 = 40 403 $P1 = new type 404 $P1 = 2 405 $P2 = new type 406 $P2 = 115200 407 408 $P99 = $P2 409 410 $S0 = "original dest is untouched in bitwise_xor for " 411 $S1 = type 412 concat $S0, $S1 413 414 # ignore exceptions 415 push_eh done 416 bxor $P2, $P0, $P1 417 418 $I0 = cmp $P99, 115200 419 420 is( $I0, 0, $S0 ) 421 goto end 422 423 done: 424 ok(1, 'ignoring exceptions') 425 end: 426 .end 427 428 .sub test_modulus 429 .param pmc type 430 431 $P0 = new type 432 $P0 = 40 433 $P1 = new type 434 $P1 = 2 435 $P2 = new type 436 $P2 = 115200 437 438 $P99 = $P2 439 440 $S0 = "original dest is untouched in modulus for " 441 $S1 = type 442 concat $S0, $S1 443 444 # ignore exceptions 445 push_eh done 446 mod $P2, $P0, $P1 447 448 $I0 = cmp $P99, 115200 449 450 is( $I0, 0, $S0 ) 451 goto end 452 453 done: 454 ok(1, 'ignoring exceptions') 455 end: 456 .end 457 458 .sub test_pow 459 .param pmc type 460 461 $P0 = new type 462 $P0 = 40 463 $P1 = new type 464 $P1 = 2 465 $P2 = new type 466 $P2 = 115200 467 468 $P99 = $P2 469 470 $S0 = "original dest is untouched in pow for " 471 $S1 = type 472 concat $S0, $S1 473 474 # ignore exceptions 475 push_eh done 476 pow $P2, $P0, $P1 477 478 $I0 = cmp $P99, 115200 479 480 is( $I0, 0, $S0 ) 481 goto end 482 483 done: 484 ok(1, 'ignoring exceptions') 485 end: 486 .end 487 488 .sub test_subtract 489 .param pmc type 490 491 $P0 = new type 492 $P0 = 40 493 $P1 = new type 494 $P1 = 2 495 $P2 = new type 496 $P2 = 115200 497 498 $P99 = $P2 499 500 $S0 = "original dest is untouched in subtract for " 501 $S1 = type 502 concat $S0, $S1 503 504 # ignore exceptions 505 push_eh done 506 sub $P2, $P0, $P1 507 508 $I0 = cmp $P99, 115200 509 510 is( $I0, 0, $S0 ) 511 goto end 512 513 done: 514 ok(1, 'ignoring exceptions') 515 end: 516 .end 517 518 .sub test_bitwise_lsr 519 .param pmc type 520 521 $P0 = new type 522 $P0 = 40 523 $P1 = new type 524 $P1 = 2 525 $P2 = new type 526 $P2 = 115200 527 528 $P99 = $P2 529 530 $S0 = "original dest is untouched in bitwise_lsr for " 531 $S1 = type 532 concat $S0, $S1 533 534 # ignore exceptions 535 push_eh done 536 lsr $P2, $P0, $P1 537 538 $I0 = cmp $P99, 115200 539 540 is( $I0, 0, $S0 ) 541 goto end 542 543 done: 544 ok(1, 'ignoring exceptions') 545 end: 546 .end 547 548 .sub test_bitwise_and 549 .param pmc type 550 551 $P0 = new type 552 $P0 = 40 553 $P1 = new type 554 $P1 = 2 555 $P2 = new type 556 $P2 = 115200 557 558 $P99 = $P2 559 560 $S0 = "original dest is untouched in bitwise_and for " 561 $S1 = type 562 concat $S0, $S1 563 564 # ignore exceptions 565 push_eh done 566 band $P2, $P0, $P1 567 568 $I0 = cmp $P99, 115200 569 570 is( $I0, 0, $S0 ) 571 goto end 572 573 done: 574 ok(1, 'ignoring exceptions') 575 end: 576 .end 577 578 ## Perl code used to generate above tests: 579 # #!/usr/bin/env perl 580 # 581 # # We should generate more tests for all possible combinations 582 # # Map vtable method to op 583 # my %methods = qw{ 584 # add add 585 # subtract sub 586 # multiply mul 587 # divide div 588 # 589 # floor_divide fdiv 590 # modulus mod 591 # pow pow 592 # 593 # bitwise_or bor 594 # bitwise_and band 595 # bitwise_xor bxor 596 # 597 # bitwise_shr shr 598 # bitwise_shl shl 599 # bitwise_lsr lsr 600 # 601 # concatenate concat 602 # 603 # logical_or or 604 # logical_and and 605 # logical_xor xor 606 # }; 607 # 608 # # foreach my $pmc (@pmcs) { 609 # while(my($vtable, $op) = each(%methods)) { 610 # 611 # print <<"END"; 612 # .sub test_$vtable 613 # .param pmc type 614 # 615 # \$P0 = new type 616 # \$P0 = 40 617 # \$P1 = new type 618 # \$P1 = 2 619 # \$P2 = new type 620 # \$P2 = 115200 621 # 622 # \$P99 = \$P2 623 # 624 # \$S0 = "original dest is untouched in $vtable for " 625 # \$S1 = type 626 # concat \$S0, \$S1 627 # 628 # # ignore exceptions 629 # push_eh done 630 # $op \$P2, \$P0, \$P1 631 # 632 # \$I0 = cmp \$P99, 115200 633 # 634 # is( \$I0, 0, \$S0 ) 635 # goto end 636 # 637 # done: 638 # ok(1, 'ignoring exceptions') 639 # end: 640 # .end 641 # 642 # END 643 # 644 # } 645 104 646 # Local Variables: 105 # mode: cperl647 # mode: pir 106 648 # cperl-indent-level: 4 107 649 # fill-column: 100 108 650 # End: 109 # vim: expandtab shiftwidth=4 :651 # vim: expandtab shiftwidth=4 ft=pir : -
t/op/64bit.t
1 #! perl2 # Copyright (C) 2001-200 5, Parrot Foundation.1 #! parrot 2 # Copyright (C) 2001-2009, Parrot Foundation. 3 3 # $Id$ 4 4 5 use strict;6 use warnings;7 use lib qw( . lib ../lib ../../lib );8 use Test::More;9 use Parrot::Test;10 use Parrot::Config;11 12 5 =head1 NAME 13 6 14 7 t/op/64bit.t - Testing integer ops on 64-bit platforms … … 24 17 25 18 =cut 26 19 27 ## remember to change the number of tests :-) 28 if ( $PConfig{intvalsize} == 8 ) { 29 plan tests => 1; 30 } 31 else { 32 plan skip_all => "64bit INTVAL platforms only"; 33 } 20 .sub main :main 21 .include "iglobals.pasm" 22 .include 'test_more.pir' 34 23 35 pasm_output_is( <<'CODE', <<'OUTPUT', "bitops64" ); 24 # Check to see if this is 64 bit 25 .local pmc interp # a handle to our interpreter object. 26 interp = getinterp 27 .local pmc config 28 config = interp[.IGLOBALS_CONFIG_HASH] 29 .local int intvalsize 30 intvalsize = config['intvalsize'] 31 32 plan(5) 33 34 if intvalsize == 8 goto is_64_bit 35 skip(5, "this is not a 64 bit platform") 36 goto end 37 38 is_64_bit: 39 bitops64() 40 41 end: 42 .end 43 44 45 .sub bitops64 36 46 # check bitops for 8-byte ints 37 set I0, 0xffffffffffffffff38 print I0 # -139 print "\n"40 set I1, 0x00000000ffffffff41 print I1 # 429496729542 print "\n"43 set I0, I144 shl I0, I0, 3245 print I0 # -429496729646 print "\n"47 band I2, I0, I148 print I2 # 049 print "\n"50 bor I2, I0, I151 print I2 # -152 print "\n"53 end54 47 55 CODE 56 -1 57 4294967295 58 -4294967296 59 0 60 -1 61 OUTPUT 48 set $I0, 0xffffffffffffffff 49 is( $I0, -1 ) 50 51 set $I1, 0x00000000ffffffff 52 is( $I1, 4294967295 ) 53 54 set $I0, $I1 55 shl $I0, $I0, 32 56 is( $I0, -4294967296 ) 57 58 band $I2, $I0, $I1 59 is( $I2, 0 ) 62 60 61 bor $I2, $I0, $I1 62 is( $I2, -1 ) 63 .end 64 63 65 # Local Variables: 64 # mode: cperl66 # mode: pir 65 67 # cperl-indent-level: 4 66 68 # fill-column: 100 67 69 # End: 68 # vim: expandtab shiftwidth=4 :70 # vim: expandtab shiftwidth=4 ft=pir: -
t/op/arithmetics.t
1 #! perl2 # Copyright (C) 2001-200 9, Parrot Foundation.1 #! parrot 2 # Copyright (C) 2001-2008, Parrot Foundation. 3 3 # $Id$ 4 4 5 use strict;6 use warnings;7 use lib qw( . lib ../lib ../../lib );8 9 use Test::More;10 use Parrot::Test tests => 21;11 12 # test for GMP13 use Parrot::Config;14 15 5 =head1 NAME 16 6 17 7 t/op/arithmetics.t - Arithmetic Ops … … 27 17 28 18 =cut 29 19 20 .sub main :main 21 .include 'test_more.pir' 22 23 plan(125) 24 25 take_the_negative_of_a_native_integer() 26 take_the_absolute_of_a_native_integer() 27 add_native_integer_to_native_integer() 28 subtract_native_integer_from_native_integer() 29 multiply_native_integer_with_native_integer() 30 divide_native_integer_by_native_integer() 31 negate_minus_zero_point_zero() 32 negate_a_native_number() 33 take_the_absolute_of_a_native_number() 34 ceil_of_a_native_number() 35 floor_of_a_native_number() 36 add_native_integer_to_native_number() 37 subtract_native_integer_from_native_number() 38 multiply_native_number_with_native_integer() 39 divide_native_number_by_native_integer() 40 add_native_number_to_native_number() 41 subtract_native_number_from_native_number() 42 multiply_native_number_with_native_number() 43 divide_native_number_by_native_number() 44 lcm_test() 45 integer_overflow_with_pow() 46 # END_OF_TESTS 47 48 .end 49 30 50 # 31 51 # Operations on a single INTVAL 32 52 # 33 pasm_output_is( <<'CODE', <<OUTPUT, "take the negative of a native integer" ); 34 set I0, 0 35 neg I0 36 say I0 37 set I0, 1234567890 38 neg I0 39 say I0 40 set I0, -1234567890 41 neg I0 42 say I0 43 set I0, 0 44 set I1, 0 45 neg I1, I0 46 say I1 47 set I0, 1234567890 48 neg I1, I0 49 say I1 50 set I0, -1234567890 51 neg I1, I0 52 say I1 53 end 54 CODE 55 0 56 -1234567890 57 1234567890 58 0 59 -1234567890 60 1234567890 61 OUTPUT 53 .sub take_the_negative_of_a_native_integer 54 set $I0, 0 55 neg $I0 56 is( $I0, "0", '' ) 62 57 63 pasm_output_is( <<'CODE', <<OUTPUT, "take the absolute of a native integer" ); 64 set I0, 0 65 abs I0 66 say I0 67 set I0, 1234567890 68 abs I0 69 say I0 70 set I0, -1234567890 71 abs I0 72 say I0 73 set I0, 0 74 set I1, 0 75 abs I1, I0 76 say I1 77 set I0, 1234567890 78 abs I1, I0 79 say I1 80 set I0, -1234567890 81 abs I1, I0 82 say I1 83 end 84 CODE 85 0 86 1234567890 87 1234567890 88 0 89 1234567890 90 1234567890 91 OUTPUT 58 set $I0, 1234567890 59 neg $I0 60 is( $I0, "-1234567890", '' ) 61 62 set $I0, -1234567890 63 neg $I0 64 is( $I0, "1234567890", '' ) 65 66 set $I0, 0 67 set $I1, 0 68 neg $I1, $I0 69 is( $I1, "0", '' ) 70 71 set $I0, 1234567890 72 neg $I1, $I0 73 is( $I1, "-1234567890", '' ) 74 75 set $I0, -1234567890 76 neg $I1, $I0 77 is( $I1, "1234567890", '' ) 78 .end 92 79 80 .sub take_the_absolute_of_a_native_integer 81 set $I0, 0 82 abs $I0 83 is( $I0, "0", '' ) 84 85 set $I0, 1234567890 86 abs $I0 87 is( $I0, "1234567890", '' ) 88 89 set $I0, -1234567890 90 abs $I0 91 is( $I0, "1234567890", '' ) 92 93 set $I0, 0 94 set $I1, 0 95 abs $I1, $I0 96 is( $I1, "0", '' ) 97 98 set $I0, 1234567890 99 abs $I1, $I0 100 is( $I1, "1234567890", '' ) 101 102 set $I0, -1234567890 103 abs $I1, $I0 104 is( $I1, "1234567890", '' ) 105 .end 106 93 107 # 94 108 # first arg is INTVAL, second arg is INTVAL 95 109 # 96 pasm_output_is( <<'CODE', <<OUTPUT, "add native integer to native integer" ); 97 set I0, 4000 98 set I1, -123 99 add I2, I0, I1 100 say I2 101 add I0, I0, I1 102 say I0 103 end 104 CODE 105 3877 106 3877 107 OUTPUT 110 .sub add_native_integer_to_native_integer 111 set $I0, 4000 112 set $I1, -123 113 add $I2, $I0, $I1 114 is( $I2, "3877", '' ) 108 115 109 pasm_output_is( <<'CODE', <<OUTPUT, "subtract native integer from native integer" ); 110 set I0, 4000 111 set I1, -123 112 sub I2, I0, I1 113 say I2 114 sub I0, I0, I1 115 say I0 116 end 117 CODE 118 4123 119 4123 120 OUTPUT 116 add $I0, $I0, $I1 117 is( $I0, "3877", '' ) 118 .end 119 120 .sub subtract_native_integer_from_native_integer 121 set $I0, 4000 122 set $I1, -123 123 sub $I2, $I0, $I1 124 is( $I2, "4123", '' ) 121 125 122 pasm_output_is( <<'CODE', <<OUTPUT, "multiply native integer with native integer" ); 123 set I0, 4000 124 set I1, -123 125 mul I2, I0, I1 126 say I2 127 mul I0, I0, I1 128 say I0 129 end 130 CODE 131 -492000 132 -492000 133 OUTPUT 126 sub $I0, $I0, $I1 127 is( $I0, "4123", '' ) 128 .end 129 130 .sub multiply_native_integer_with_native_integer 131 set $I0, 4000 132 set $I1, -123 133 mul $I2, $I0, $I1 134 is( $I2, "-492000", '' ) 134 135 135 pasm_output_is( <<'CODE', <<OUTPUT, "divide native integer by native integer" ); 136 set I0, 4000 137 set I1, -123 138 div I2, I0, I1 139 say I2 140 div I0, I0, I1 141 say I0 142 end 143 CODE 144 -32 145 -32 146 OUTPUT 136 mul $I0, $I0, $I1 137 is( $I0, "-492000", '' ) 138 .end 139 140 .sub divide_native_integer_by_native_integer 141 set $I0, 4000 142 set $I1, -123 143 div $I2, $I0, $I1 144 is( $I2, "-32", '' ) 147 145 146 div $I0, $I0, $I1 147 is( $I0, "-32", '' ) 148 .end 149 148 150 # 149 151 # print -0.0 as -0 150 152 # 153 .sub negate_minus_zero_point_zero 154 set $N0, 0 155 neg $N0 156 $S0 = $N0 157 is( $S0, "-0", '1' ) 151 158 152 pasm_output_is( <<'CODE', <<OUTPUT, 'negate -0.0' ); 153 set N0, 0 154 neg N0 155 say N0 156 set N0, -0.0 157 neg N0 158 say N0 159 set N0, -0.0 160 neg N1, N0 161 say N1 162 set N0, 0 163 set N1, 1 164 neg N1, N0 165 say N1 166 end 167 CODE 168 -0 169 0 170 0 171 -0 172 OUTPUT 159 set $N0, -0.0 160 neg $N0 161 $S0 = $N0 162 is( $S0, "0", '2' ) 173 163 164 set $N0, -0.0 165 neg $N1, $N0 166 $S0 = $N1 167 is( $S0, "0", '3' ) 174 168 175 169 set $N0, 0 170 set $N1, 1 171 neg $N1, $N0 172 $S0 = $N1 173 is( $S0, "-0", '4' ) 174 .end 175 176 176 # 177 177 # Operations on a single NUMVAL 178 178 # 179 .sub negate_a_native_number 180 set $N0, 123.4567890 181 neg $N0 182 is( $N0, "-123.456789", '' ) 179 183 180 pasm_output_is( <<'CODE', <<OUTPUT, 'negate a native number' ); 181 set N0, 123.4567890 182 neg N0 183 say N0 184 set N0, -123.4567890 185 neg N0 186 say N0 187 set N0, 123.4567890 188 neg N1, N0 189 say N1 190 set N0, -123.4567890 191 neg N1, N0 192 say N1 193 end 194 CODE 195 -123.456789 196 123.456789 197 -123.456789 198 123.456789 199 OUTPUT 184 set $N0, -123.4567890 185 neg $N0 186 is( $N0, "123.456789", '' ) 200 187 201 pasm_output_is( <<'CODE', <<OUTPUT, "take the absolute of a native number" ); 202 set N0, 0 203 abs N0 204 say N0 205 set N0, -0.0 206 abs N0 207 say N0 208 set N0, 123.45678901 209 abs N0 210 say N0 211 set N0, -123.45678901 212 abs N0 213 say N0 214 set N0, 0 215 set N1, 1 216 abs N1, N0 217 say N1 218 set N0, 0.0 219 set N1, 1 220 abs N1, N0 221 say N1 222 set N0, 123.45678901 223 set N1, 1 224 abs N1, N0 225 say N1 226 set N0, -123.45678901 227 set N1, 1 228 abs N1, N0 229 say N1 230 end 231 CODE 232 0 233 0 234 123.45678901 235 123.45678901 236 0 237 0 238 123.45678901 239 123.45678901 240 OUTPUT 188 set $N0, 123.4567890 189 neg $N1, $N0 190 is( $N1, "-123.456789", '' ) 241 191 242 pasm_output_is( <<'CODE', <<OUTPUT, "ceil of a native number" ); 243 set N0, 0 244 ceil N0 245 say N0 246 set N0, 123.45678901 247 ceil N0 248 say N0 249 set N0, -123.45678901 250 ceil N0 251 say N0 252 set N0, 0 253 set N1, 1 254 ceil N1, N0 255 say N1 256 set N0, 0.0 257 set N1, 1 258 ceil N1, N0 259 say N1 260 set N0, 123.45678901 261 set N1, 1 262 ceil N1, N0 263 say N1 264 set N0, -123.45678901 265 set N1, 1 266 ceil N1, N0 267 say N1 268 set N0, 0 269 set I1, 1 270 ceil I1, N0 271 say I1 272 set N0, 0.0 273 set I1, 1 274 ceil I1, N0 275 say I1 276 set N0, 123.45678901 277 set I1, 1 278 ceil I1, N0 279 say I1 280 set N0, -123.45678901 281 set I1, 1 282 ceil I1, N0 283 say I1 284 end 285 CODE 286 0 287 124 288 -123 289 0 290 0 291 124 292 -123 293 0 294 0 295 124 296 -123 297 OUTPUT 192 set $N0, -123.4567890 193 neg $N1, $N0 194 is( $N1, "123.456789", '' ) 195 .end 196 197 .sub take_the_absolute_of_a_native_number 198 set $N0, 0 199 abs $N0 200 is( $N0, "0", '' ) 298 201 299 pasm_output_is( <<'CODE', <<OUTPUT, "floor of a native number" ); 300 set N0, 0 301 floor N0 302 say N0 303 set N0, 123.45678901 304 floor N0 305 say N0 306 set N0, -123.45678901 307 floor N0 308 say N0 309 set N0, 0 310 set N1, 1 311 floor N1, N0 312 say N1 313 set N0, 0.0 314 set N1, 1 315 floor N1, N0 316 say N1 317 set N0, 123.45678901 318 set N1, 1 319 floor N1, N0 320 say N1 321 set N0, -123.45678901 322 set N1, 1 323 floor N1, N0 324 say N1 325 set N0, 0 326 set I1, 1 327 floor I1, N0 328 say I1 329 set N0, 0.0 330 set I1, 1 331 floor I1, N0 332 say I1 333 set N0, 123.45678901 334 set I1, 1 335 floor I1, N0 336 say I1 337 set N0, -123.45678901 338 set I1, 1 339 floor I1, N0 340 say I1 341 end 342 CODE 343 0 344 123 345 -124 346 0 347 0 348 123 349 -124 350 0 351 0 352 123 353 -124 354 OUTPUT 202 set $N0, -0.0 203 abs $N0 204 is( $N0, "0", '' ) 355 205 206 set $N0, 123.45678901 207 abs $N0 208 is( $N0, "123.45678901", '' ) 209 210 set $N0, -123.45678901 211 abs $N0 212 is( $N0, "123.45678901", '' ) 213 214 set $N0, 0 215 set $N1, 1 216 abs $N1, $N0 217 is( $N1, "0", '' ) 218 219 set $N0, 0.0 220 set $N1, 1 221 abs $N1, $N0 222 is( $N1, "0", '' ) 223 224 set $N0, 123.45678901 225 set $N1, 1 226 abs $N1, $N0 227 is( $N1, "123.45678901", '' ) 228 229 set $N0, -123.45678901 230 set $N1, 1 231 abs $N1, $N0 232 is( $N1, "123.45678901", '' ) 233 .end 234 235 .sub ceil_of_a_native_number 236 set $N0, 0 237 ceil $N0 238 is( $N0, "0", '' ) 239 240 set $N0, 123.45678901 241 ceil $N0 242 is( $N0, "124", '' ) 243 244 set $N0, -123.45678901 245 ceil $N0 246 is( $N0, "-123", '' ) 247 248 set $N0, 0 249 set $N1, 1 250 ceil $N1, $N0 251 is( $N1, "0", '' ) 252 253 set $N0, 0.0 254 set $N1, 1 255 ceil $N1, $N0 256 is( $N1, "0", '' ) 257 258 set $N0, 123.45678901 259 set $N1, 1 260 ceil $N1, $N0 261 is( $N1, "124", '' ) 262 263 set $N0, -123.45678901 264 set $N1, 1 265 ceil $N1, $N0 266 is( $N1, "-123", '' ) 267 268 set $N0, 0 269 set $I1, 1 270 ceil $I1, $N0 271 is( $I1, "0", '' ) 272 273 set $N0, 0.0 274 set $I1, 1 275 ceil $I1, $N0 276 is( $I1, "0", '' ) 277 278 set $N0, 123.45678901 279 set $I1, 1 280 ceil $I1, $N0 281 is( $I1, "124", '' ) 282 283 set $N0, -123.45678901 284 set $I1, 1 285 ceil $I1, $N0 286 is( $I1, "-123", '' ) 287 .end 288 289 .sub floor_of_a_native_number 290 set $N0, 0 291 floor $N0 292 is( $N0, "0", '' ) 293 294 set $N0, 123.45678901 295 floor $N0 296 is( $N0, "123", '' ) 297 298 set $N0, -123.45678901 299 floor $N0 300 is( $N0, "-124", '' ) 301 302 set $N0, 0 303 set $N1, 1 304 floor $N1, $N0 305 is( $N1, "0", '' ) 306 307 set $N0, 0.0 308 set $N1, 1 309 floor $N1, $N0 310 is( $N1, "0", '' ) 311 312 set $N0, 123.45678901 313 set $N1, 1 314 floor $N1, $N0 315 is( $N1, "123", '' ) 316 317 set $N0, -123.45678901 318 set $N1, 1 319 floor $N1, $N0 320 is( $N1, "-124", '' ) 321 322 set $N0, 0 323 set $I1, 1 324 floor $I1, $N0 325 is( $I1, "0", '' ) 326 327 set $N0, 0.0 328 set $I1, 1 329 floor $I1, $N0 330 is( $I1, "0", '' ) 331 332 set $N0, 123.45678901 333 set $I1, 1 334 floor $I1, $N0 335 is( $I1, "123", '' ) 336 337 set $N0, -123.45678901 338 set $I1, 1 339 floor $I1, $N0 340 is( $I1, "-124", '' ) 341 342 .end 343 356 344 # 357 345 # FLOATVAL and INTVAL tests 358 346 # 359 pasm_output_is( <<'CODE', <<OUTPUT, "add native integer to native number" ); 360 set I0, 4000 361 set N0, -123.123 362 add N1, N0, I0 363 say N1 364 add N0, N0, I0 365 say N0 366 add N0, I0 367 say N0 368 end 369 CODE 370 3876.877 371 3876.877 372 7876.877 373 OUTPUT 347 .sub add_native_integer_to_native_number 348 set $I0, 4000 349 set $N0, -123.123 350 add $N1, $N0, $I0 351 is( $N1, "3876.877", '' ) 374 352 375 pasm_output_is( <<'CODE', <<OUTPUT, "subtract native integer from native number" ); 376 set I0, 4000 377 set N0, -123.123 378 sub N1, N0, I0 379 say N1 380 sub N0, N0, I0 381 say N0 382 sub N0, I0 383 say N0 384 end 385 CODE 386 -4123.123 387 -4123.123 388 -8123.123 389 OUTPUT 353 add $N0, $N0, $I0 354 is( $N0, "3876.877", '' ) 390 355 391 pasm_output_is( <<'CODE', <<OUTPUT, "multiply native number with native integer" ); 392 set I0, 4000 393 set N0, -123.123 394 mul N1, N0, I0 395 say N1 396 mul N0, N0, I0 397 say N0 398 mul N0, -2 399 say N0 400 end 401 CODE 402 -492492 403 -492492 404 984984 405 OUTPUT 356 add $N0, $I0 357 is( $N0, "7876.877", '' ) 406 358 407 pasm_output_is( <<'CODE', <<OUTPUT, "divide native number by native integer" ); 408 set I0, 4000 409 set N0, -123.123 410 div N1, N0, I0 411 say N1 412 div N0, N0, I0 413 say N0 414 div N0, 1 415 say N0 416 set N0, 100.000 417 div N0, 100 418 say N0 419 div N0, 0.01 420 say N0 421 end 422 CODE 423 -0.03078075 424 -0.03078075 425 -0.03078075 426 1 427 100 428 OUTPUT 359 .end 360 361 .sub subtract_native_integer_from_native_number 362 set $I0, 4000 363 set $N0, -123.123 364 sub $N1, $N0, $I0 365 is( $N1, "-4123.123", '' ) 429 366 367 sub $N0, $N0, $I0 368 is( $N0, "-4123.123", '' ) 369 370 sub $N0, $I0 371 is( $N0, "-8123.123", '' ) 372 373 .end 374 375 .sub multiply_native_number_with_native_integer 376 set $I0, 4000 377 set $N0, -123.123 378 mul $N1, $N0, $I0 379 is( $N1, "-492492", '' ) 380 381 mul $N0, $N0, $I0 382 is( $N0, "-492492", '' ) 383 384 mul $N0, -2 385 is( $N0, "984984", '' ) 386 .end 387 388 .sub divide_native_number_by_native_integer 389 set $I0, 4000 390 set $N0, -123.123 391 div $N1, $N0, $I0 392 is( $N1, "-0.03078075", '' ) 393 394 div $N0, $N0, $I0 395 is( $N0, "-0.03078075", '' ) 396 397 div $N0, 1 398 is( $N0, "-0.03078075", '' ) 399 400 set $N0, 100.000 401 div $N0, 100 402 is( $N0, "1", '' ) 403 404 div $N0, 0.01 405 is( $N0, "100", '' ) 406 .end 407 430 408 # 431 409 # FLOATVAL and FLOATVAL tests 432 410 # 433 pasm_output_is( <<'CODE', <<OUTPUT, "add native number to native number" ); 434 set N2, 4000.246 435 set N0, -123.123 436 add N1, N0, N2 437 say N1 438 add N0, N0, N2 439 say N0 440 end 441 CODE 442 3877.123 443 3877.123 444 OUTPUT 411 .sub add_native_number_to_native_number 412 set $N2, 4000.246 413 set $N0, -123.123 414 add $N1, $N0, $N2 415 is( $N1, "3877.123", '' ) 445 416 446 pasm_output_is( <<'CODE', <<OUTPUT, "subtract native number from native number" ); 447 set N2, 4000.246 448 set N0, -123.123 449 sub N1, N0, N2 450 say N1 451 sub N0, N0, N2 452 say N0 453 end 454 CODE 455 -4123.369 456 -4123.369 457 OUTPUT 417 add $N0, $N0, $N2 418 is( $N0, "3877.123", '' ) 419 .end 420 421 .sub subtract_native_number_from_native_number 422 set $N2, 4000.246 423 set $N0, -123.123 424 sub $N1, $N0, $N2 425 is( $N1, "-4123.369", '' ) 458 426 459 pasm_output_is( <<'CODE', <<OUTPUT, "multiply native number with native number" ); 460 set N2, 4000.246 461 set N0, -123.123 462 mul N1, N0, N2 463 say N1 464 mul N0, N0, N2 465 say N0 466 end 467 CODE 468 -492522.288258 469 -492522.288258 470 OUTPUT 427 sub $N0, $N0, $N2 428 is( $N0, "-4123.369", '' ) 471 429 472 pasm_output_is( <<'CODE', <<OUTPUT, "divide native number by native number" ); 473 set N2, 4000.246 474 set N0, -123.123 475 div N1, N0, N2 476 say N1 477 div N0, N0, N2 478 say N0 479 end 480 CODE 481 -0.0307788571002883 482 -0.0307788571002883 483 OUTPUT 430 .end 431 432 .sub multiply_native_number_with_native_number 433 set $N2, 4000.246 434 set $N0, -123.123 435 mul $N1, $N0, $N2 436 is( $N1, "-492522.288258", '' ) 484 437 485 pasm_output_is( <<'CODE', <<OUTPUT, "lcm_I_I_I" ); 486 set I0, 10 487 set I1, 10 488 lcm I2, I1, I0 489 eq I2, 10, OK1 490 print "not " 491 OK1: say "ok 1" 438 mul $N0, $N0, $N2 439 is( $N0, "-492522.288258", '' ) 492 440 493 set I1, 17 494 lcm I2, I1, I0 495 eq I2, 170, OK2 496 print I2 497 print "not " 498 OK2: print "ok 2\n" 441 .end 442 443 .sub divide_native_number_by_native_number 444 set $N2, 4000.246 445 set $N0, -123.123 446 div $N1, $N0, $N2 447 is( $N1, "-0.0307788571002883", '' ) 499 448 500 set I0, 17 501 set I1, 10 502 lcm I2, I1, I0 503 eq I2, 170, OK3 504 print "not " 505 OK3: print "ok 3\n" 449 div $N0, $N0, $N2 450 is( $N0, "-0.0307788571002883", '' ) 506 451 507 set I0, 10 508 set I1, 0 509 lcm I2, I1, I0 510 eq I2, 0, OK4 511 print "not " 512 OK4: print "ok 4\n" 452 .end 453 454 .sub lcm_test 455 set $I0, 10 456 set $I1, 10 457 lcm $I2, $I1, $I0 458 is( $I2, 10 ) 513 459 514 set I0, 0 515 set I1, 10 516 lcm I2, I1, I0 517 eq I2, 0, OK5 518 print "not " 519 OK5: print "ok 5\n" 460 set $I1, 17 461 lcm $I2, $I1, $I0 462 is( $I2, 170 ) 520 463 521 end 522 CODE 523 ok 1 524 ok 2 525 ok 3 526 ok 4 527 ok 5 528 OUTPUT 464 set $I0, 17 465 set $I1, 10 466 lcm $I2, $I1, $I0 467 is( $I2, 170 ) 529 468 530 SKIP: { 531 skip( 'No integer overflow for 32-bit INTVALs without GMP installed', 1 ) 532 if $PConfig{intvalsize} == 4 && !$PConfig{gmp}; 469 set $I0, 10 470 set $I1, 0 471 lcm $I2, $I1, $I0 472 is( $I2, 0 ) 533 473 534 pir_output_is( <<'CODE', <<OUTPUT, "integer overflow with 'pow'" ); 535 .sub main 474 set $I0, 0 475 set $I1, 10 476 lcm $I2, $I1, $I0 477 is( $I2, 0 ) 478 .end 479 480 .sub integer_overflow_with_pow 481 .include "iglobals.pasm" 482 483 # Check that we aren't 32-bit INTVALs without GMP 484 .local pmc interp # a handle to our interpreter object. 485 interp = getinterp 486 .local pmc config 487 config = interp[.IGLOBALS_CONFIG_HASH] 488 .local int intvalsize 489 intvalsize = config['intvalsize'] 490 .local int gmp 491 gmp = config['gmp'] 492 493 if intvalsize != 4 goto can_test 494 if gmp goto can_test 495 skip(40,'No integer overflow for 32-bit INTVALs without GMP installed') 496 goto end 497 498 can_test: 499 536 500 .local pmc i1, i2, r 537 501 i1 = new 'Integer' 538 502 i2 = new 'Integer' 539 503 i1 = 2 540 504 i2 = 1 541 next: 505 $I1 = 1 506 next: 542 507 null r 543 508 r = pow i1, i2 544 509 $S0 = r 545 say $S0 510 511 $I1 = $I1 * 2 512 is( $S0, $I1 ) 513 546 514 inc i2 547 515 # XXX: this must be extended to at least 64 bit range 548 516 # when sure that the result is not floating point. 549 517 # In the meantime, make sure it overflows nicely 550 518 # on 32 bit. 551 519 unless i2 > 40 goto next 520 521 end: 552 522 .end 553 CODE554 2555 4556 8557 16558 32559 64560 128561 256562 512563 1024564 2048565 4096566 8192567 16384568 32768569 65536570 131072571 262144572 524288573 1048576574 2097152575 4194304576 8388608577 16777216578 33554432579 67108864580 134217728581 268435456582 536870912583 1073741824584 2147483648585 4294967296586 8589934592587 17179869184588 34359738368589 68719476736590 137438953472591 274877906944592 549755813888593 1099511627776594 OUTPUT595 }596 523 597 598 524 # Local Variables: 599 # mode: cperl525 # mode: pir 600 526 # cperl-indent-level: 4 601 527 # fill-column: 100 602 528 # End: 603 # vim: expandtab shiftwidth=4 :529 # vim: expandtab shiftwidth=4 ft=pir :
