t/pmc/bignum.t

   1 #!perl
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 t/pmc/bignum.t - Test the non-implemented BigNum PMC.
   7
   8 =head1 DESCRIPTION
   9
  10 Does nothing yet, as there is no BigNum PMC yet.
  11
  12 The idea is to run the test cases parsed out of *.decTest, available
  13 from: http://www2.hursley.ibm.com/decimal/dectest.html
  14
  15 =head1 HISTORY
  16
  17 This was started by Alex Gogh, who went to work in Antarctica, http://the.earth.li/~alex/halley/.
  18 The script was supposed to test bignum.c, which should become the basis for a
  19 BigNum PMC.
  20
  21 =head1 TODO
  22
  23 This is very broken.
  24
  25 ==head1 SEE ALSO
  26
  27 F<docs/docs/pdds/draft/pdd14_bignum.pod>,
  28 L<https://rt.perl.org/rt3/Ticket/Display.html?id=36330>
  29
  30 =cut
  31
  32 use strict;
  33 use warnings;
  34
  35 use Test::More skip_all => 'No BigNum support yet.';
  36
  37 my ( $test, $one, $two, $result, $prec, $round, $maxexp, $skip, $op, @conds, $line, $arrow );
  38
  39 my ( $testsrun, $testspass, $testsfail, $extended ) = ( 0, 0, 0, 0 );
  40 $maxexp = 999999999;
  41 while (<>) {
  42     chomp;
  43     next if /^\s*--/;
  44     s/\s*--.*$//;    # and hope it's not quoted
  45     next unless /\S/;
  46     /^precision:\s+(\d+)/ && do {
  47         $precision = $1;
  48         next;
  49     };
  50     /^rounding:\s*(\w+)/ && do {
  51         $round = $1;
  52         next;
  53     };
  54     /^extended:\s*(\d+)/ && do {
  55         $extended = $1;
  56         next;
  57     };
  58     /^version/               && next;
  59     /^maxexponent:\s*(\d+)/i && do {
  60         $expskip = 1 if ( $1 > $maxexp );
  61         if ( $1 <= $maxexp ) {
  62             $expskip = 0;
  63         }
  64         next;
  65     };
  66
  67     ( $test, $op, $one, $two, $arrow, $result, @conds ) = split( /\s+/, $_ );
  68
  69     # skip null tests
  70     if ( $one eq '#' || $two eq '#' ) {
  71         print "$test ok \# skip, null test\n";
  72         next;
  73     }
  74
  75     if ( $round !~ /^(half_up|half_even|down|floor|ceiling)$/ ) {
  76         print "$test ok \# skip, $round not available\n";
  77         next;
  78     }
  79
  80     if ( $op =~ /^(power|rescale)$/ ) {
  81         print "$test ok \# skip, $op not implemented\n";
  82         next;
  83     }
  84
  85     if ( $two eq '->' ) {    # unary op
  86         unshift( @conds, $result ) if defined $result;
  87         ( $two, $result, @conds ) = ( '0', $arrow, @conds );
  88     }
  89
  90     if ( !defined($result) ) {
  91         print "$test skip\n";
  92         next;
  93     }
  94
  95     if ($expskip) {
  96         print "$test ok \# skip\n";
  97         next;
  98     }
  99
 100     for ( $one, $two, $result ) {
 101         s/^'|'$//g;
 102     }
 103
 104     $testsrun += 2;
 105     my ($output) = run_single_test( $one $two $op $precision $round $extended );
 106     chomp($output);
 107     my @out = split( /\s+/, $output );
 108     if ( $result eq $out[0] || ( $result eq '?' ) ) {
 109         print "$test ok\n";
 110         $testspass++;
 111     }
 112     else {
 113         print "$test not ok\n";
 114         print "  $one $op $two\n    (p:$precision r:$round)\n";
 115         print " => `", join( "'`", @out ), "'\n";
 116         print " ex `$result', ", ( @conds ? join( " ", @conds ) : '-' ), "\n";
 117         $testsfail++;
 118     }
 119
 120     # check flag status
 121     my ( %conds, %outs );
 122     my $tpass = 0;
 123     if (@conds) {
 124
 125         # need to map conditions, as signals and conditions don't quite mesh
 126         my %map = (
 127             Division_impossible => 'Invalid_operation',
 128             Division_undefined  => 'Invalid_operation'
 129         );
 130         foreach (@conds) {
 131             if ( $map{$_} ) {
 132                 $_ = $map{$_};
 133             }
 134         }
 135         if ( @out > 1 ) {
 136             $conds{$_} = 1 foreach @conds;
 137             $outs{$_} = 1 foreach @out[ 1 .. ( @out - 1 ) ];
 138             $tpass = 1;
 139             foreach ( keys %conds ) {
 140                 $tpass = 0 unless $outs{$_};
 141             }
 142             foreach ( keys %outs ) {
 143                 $tpass = 0 unless $conds{$_};
 144             }
 145         }
 146     }
 147     elsif ( @out == 1 ) {
 148         $tpass = 1;
 149     }
 150
 151     if ($tpass) {
 152         print "$test ok\n";
 153         $testspass++;
 154     }
 155     else {
 156         print "$test not ok\n";
 157         print "  $one $op $two\n    (p:$precision r:$round)\n";
 158         print " => `", join( "'`", @out ), "'\n";
 159         print " ex `$result', ", ( @conds ? join( " ", @conds ) : '-' ), "\n";
 160         $testsfail++;
 161     }
 162
 163 }
 164
 165 # XXX The following used to be bignum_test.pl.
 166 # Maybe it should be factored out to Parrot::Test::BigNum.
 167
 168 # This allows a single bignum test to be run directly through the C
 169 # library.  Usage available by getting the args wrong.
 170
 171 use lib "../lib";
 172 use Inline C => Config => CCFLAGS => '-I.';
 173 use Inline C => <<'END_OF_C_SECTION';
 174 #include "bignum.c"
 175
 176 int runtest (char* lef, char *rih, int oper, int prec, int round, int extended) {
 177   BIGNUM *one, *two, *result;
 178   char *output;
 179   BN_CONTEXT context;
 180   char *traps[7] = {"Lost_digits","Division_by_zero","Inexact",
 181                     "Invalid_operation","Overflow","Rounded","Underflow"};
 182
 183   context.elimit = 999999999;
 184   context.precision = prec;
 185   context.extended = extended;
 186   context.flags = 0;
 187   context.traps = 0;
 188   switch (round) {
 189   case 1 : context.rounding = ROUND_HALF_UP;
 190     break;
 191   case 2 : context.rounding = ROUND_DOWN;
 192     break;
 193   case 3 : context.rounding = ROUND_HALF_EVEN;
 194     break;
 195   case 4 : context.rounding = ROUND_CEILING;
 196     break;
 197   case 5 : context.rounding = ROUND_FLOOR;
 198     break;
 199   default : printf("Unknown rounding %i\n", round);
 200     exit(1);
 201   }
 202
 203   one = BN_from_string(lef, &context);
 204   two = BN_from_string(rih, &context);
 205
 206   result = BN_new(1);
 207
 208   switch (oper) {
 209   case 1 : BN_add(result, one, two, &context);
 210     break;
 211   case 2 : BN_subtract(result, one, two, &context);
 212     break;
 213   case 3 : BN_plus(result, one, &context);
 214     break;
 215   case 4 : BN_minus(result, one, &context);
 216     break;
 217   case 5 : BN_compare(result, one, two, &context);
 218     break;
 219   case 6 : BN_multiply(result, one, two, &context);
 220     break;
 221   case 7 : BN_divide(result, one, two, &context);
 222     break;
 223   case 8 : BN_divide_integer(result, one, two, &context);
 224     break;
 225   case 9 : BN_remainder(result, one, two, &context);
 226     break;
 227   case 10: BN_rescale(result, one, two, &context);
 228     break;
 229   case 11: BN_power(result, one, two, &context);
 230     break;
 231
 232   default : printf("No operation of type %i\n", oper);
 233     exit(0);
 234   }
 235
 236   BN_to_scientific_string(result, &output);
 237   printf("%s", output);
 238   {
 239       int i;
 240       for (i=0; i< 7; i++)
 241           if ((1 << i) & context.flags) printf(" %s", traps[i]);
 242   }
 243   printf("\n");
 244   return 1;
 245 }
 246 END_OF_C_SECTION
 247
 248 my %ops = (
 249     add       => 1,
 250     subtract  => 2,
 251     plus      => 3,
 252     minus     => 4,
 253     compare   => 5,
 254     multiply  => 6,
 255     divide    => 7,
 256     divideint => 8,
 257     remainder => 9,
 258     rescale   => 10,
 259     power     => 11,
 260 );
 261
 262 my %round = (
 263     half_up   => 1,
 264     down      => 2,
 265     half_even => 3,
 266     ceiling   => 4,
 267     floor     => 5,
 268 );
 269
 270 sub run_single_test {
 271     unless ( @_ == 6 ) {
 272         die <<ENDOFUSAGE;
 273 bignum_test.pl -- run test through bignum.c
 274 bignum_test.pl one two operation precision rounding extended
 275 ENDOFUSAGE
 276     }
 277
 278     for ( $_[0], $_[1] ) {
 279         s/^"|"$//g;
 280         s/""/\"/g;
 281         s/^'|'$//g;
 282         s/''/\'/g;
 283     }
 284
 285     # XXX Capture STDOUT
 286     runtest( $_[0], $_[1], $ops{ $ARGV[2] }, $_[3], $round{ $_[4] }, $_[5] );
 287 }
 288
 289 # Local Variables:
 290 #   mode: cperl
 291 #   cperl-indent-level: 4
 292 #   fill-column: 100
 293 # End:
 294 # vim: expandtab shiftwidth=4: