gen-libm-test.pl

Axis 221 camera embedded programing interface

  @descr = split //,$descr_res;
  foreach (@descr) {
    if ($_ =~ /b|f|i|l|L/ ) {
      $cline .= $args[$current_arg];
      $current_arg++;
    } elsif ($_ eq 'c') {
      $cline .= "BUILD_COMPLEX ($args[$current_arg], $args[$current_arg+1])";
      $current_arg += 2;
    } elsif ($_ eq '1') {
      push @special, $args[$current_arg];
      ++$current_arg;
    }
  }
  # Add ulp, xfail
  $cline .= &new_test ($str, ($current_arg <= $#args) ? $args[$current_arg] : undef);

  # special treatment for some functions
  if ($args[0] eq 'frexp') {
    if (defined $special[0] && $special[0] ne "IGNORE") {
      my ($str) = "$call sets x to $special[0]";
      $post = "  check_int (\"$str\", x, $special[0]";
      $post .= &new_test ($str, undef);
    }
  } elsif ($args[0] eq 'gamma' || $args[0] eq 'lgamma') {
    $pre = "  signgam = 0;\n";
    if (defined $special[0] && $special[0] ne "IGNORE") {
      my ($str) = "$call sets signgam to $special[0]";
      $post = "  check_int (\"$str\", signgam, $special[0]";
      $post .= &new_test ($str, undef);
    }
  } elsif ($args[0] eq 'modf') {
    if (defined $special[0] && $special[0] ne "IGNORE") {
      my ($str) = "$call sets x to $special[0]";
      $post = "  check_float (\"$str\", x, $special[0]";
      $post .= &new_test ($str, undef);
    }
  } elsif ($args[0] eq 'remquo') {
    if (defined $special[0] && $special[0] ne "IGNORE") {
      my ($str) = "$call sets x to $special[0]";
      $post = "  check_int (\"$str\", x, $special[0]";
      $post .= &new_test ($str, undef);
    }
  }

  print $file $pre if (defined $pre);

  print $file "  $cline";

  print $file $post if (defined $post);
}

# Generate libm-test.c
sub generate_testfile {
  my ($input, $output) = @_;
  my ($lasttext);
  my (@args, $i, $str);

  open INPUT, $input or die ("Can't open $input: $!");
  open OUTPUT, ">$output" or die ("Can't open $output: $!");

  # Replace the special macros
  while (<INPUT>) {

    # TEST_...
    if (/^\s*TEST_/) {
      my ($descr, $args);
      chop;
      ($descr, $args) = ($_ =~ /TEST_(\w+)\s*\((.*)\)/);
      &parse_args (\*OUTPUT, $descr, $args);
      next;
    }
    # START (function)
    if (/START/) {
      print OUTPUT "  init_max_error ();\n";
      next;
    }
    # END (function)
    if (/END/) {
      my ($fct, $line, $type);
      if (/complex/) {
	s/,\s*complex\s*//;
	$type = 'complex';
      } else {
	$type = 'normal';
      }
      ($fct) = ($_ =~ /END\s*\((.*)\)/);
      if ($type eq 'complex') {
	$line = "  print_complex_max_error (\"$fct\", ";
      } else {
	$line = "  print_max_error (\"$fct\", ";
      }
      if (exists $results{$fct}{'has_ulps'}) {
	$line .= "DELTA$fct";
      } else {
	$line .= '0';
      }
      if (exists $results{$fct}{'has_fails'}) {
	$line .= ", FAIL$fct";
      } else {
	$line .= ', 0';
      }
      $line .= ");\n";
      print OUTPUT $line;
      push @functions, $fct;
      next;
    }
    print OUTPUT;
  }
  close INPUT;
  close OUTPUT;
}



# Parse ulps file
sub parse_ulps {
  my ($file) = @_;
  my ($test, $type, $float, $eps, $kind);

  # $type has the following values:
  # "normal": No complex variable
  # "real": Real part of complex result
  # "imag": Imaginary part of complex result
  open ULP, $file  or die ("Can't open $file: $!");
  while (<ULP>) {
    chop;
    # ignore comments and empty lines
    next if /^#/;
    next if /^\s*$/;
    if (/^Test/) {
      if (/Real part of:/) {
	s/Real part of: //;
	$type = 'real';
      } elsif (/Imaginary part of:/) {
	s/Imaginary part of: //;
	$type = 'imag';
      } else {
	$type = 'normal';
      }
      s/^.+\"(.*)\".*$/$1/;
      $test = $_;
      $kind = 'test';
      next;
    }
    if (/^Function: /) {
      if (/Real part of/) {
	s/Real part of //;
	$type = 'real';
      } elsif (/Imaginary part of/) {
	s/Imaginary part of //;
	$type = 'imag';
      } else {
	$type = 'normal';
      }
      ($test) = ($_ =~ /^Function:\s*\"([a-zA-Z0-9_]+)\"/);
      $kind = 'fct';
      next;
    }
    if (/^i?(float|double|ldouble):/) {
      ($float, $eps) = split /\s*:\s*/,$_,2;

      if ($eps eq 'fail') {
	$results{$test}{$type}{'fail'}{$float} = 1;
	$results{$test}{'has_fails'} = 1;
      } elsif ($eps eq "0") {
	# ignore
	next;
      } else {
	$results{$test}{$type}{'ulp'}{$float} = $eps;
	$results{$test}{'has_ulps'} = 1;
      }
      if ($type =~ /^real|imag$/) {
	$results{$test}{'type'} = 'complex';
      } elsif ($type eq 'normal') {
	$results{$test}{'type'} = 'normal';
      }
      $results{$test}{'kind'} = $kind;
      next;
    }
    print "Skipping unknown entry: `$_'\n";
  }
  close ULP;
}


# Clean up a floating point number
sub clean_up_number {
  my ($number) = @_;

  # Remove trailing zeros
  $number =~ s/0+$//;
  $number =~ s/\.$//;
  return $number;
}

# Output a file which can be read in as ulps file.
sub print_ulps_file {
  my ($file) = @_;
  my ($test, $type, $float, $eps, $fct, $last_fct);

  $last_fct = '';
  open NEWULP, ">$file" or die ("Can't open $file: $!");
  print NEWULP "# Begin of automatic generation\n";
  # first the function calls
  foreach $test (sort keys %results) {
    next if ($results{$test}{'kind'} ne 'test');
    foreach $type ('real', 'imag', 'normal') {
      if (exists $results{$test}{$type}) {
	if (defined $results{$test}) {
	  ($fct) = ($test =~ /^(\w+)\s/);
	  if ($fct ne $last_fct) {
	    $last_fct = $fct;
	    print NEWULP "\n# $fct\n";
	  }
	}
	if ($type eq 'normal') {
	  print NEWULP "Test \"$test\":\n";
	} elsif ($type eq 'real') {
	  print NEWULP "Test \"Real part of: $test\":\n";
	} elsif ($type eq 'imag') {
	  print NEWULP "Test \"Imaginary part of: $test\":\n";
	}
	foreach $float (@all_floats) {
	  if (exists $results{$test}{$type}{'ulp'}{$float}) {
	    print NEWULP "$float: ",
	    &clean_up_number ($results{$test}{$type}{'ulp'}{$float}),
	    "\n";
	  }
	  if (exists $results{$test}{$type}{'fail'}{$float}) {
	    print NEWULP "$float: fail\n";
	  }
	}
      }
    }
  }
  print NEWULP "\n# Maximal error of functions:\n";

  foreach $fct (sort keys %results) {
    next if ($results{$fct}{'kind'} ne 'fct');
    foreach $type ('real', 'imag', 'normal') {
      if (exists $results{$fct}{$type}) {
	if ($type eq 'normal') {
	  print NEWULP "Function: \"$fct\":\n";
	} elsif ($type eq 'real') {
	  print NEWULP "Function: Real part of \"$fct\":\n";
	} elsif ($type eq 'imag') {
	  print NEWULP "Function: Imaginary part of \"$fct\":\n";
	}
	foreach $float (@all_floats) {
	  if (exists $results{$fct}{$type}{'ulp'}{$float}) {
	    print NEWULP "$float: ",
	    &clean_up_number ($results{$fct}{$type}{'ulp'}{$float}),
	    "\n";
	  }
	  if (exists $results{$fct}{$type}{'fail'}{$float}) {
	    print NEWULP "$float: fail\n";
	  }
	}
	print NEWULP "\n";
      }
    }
  }
  print NEWULP "# end of automatic generation\n";
  close NEWULP;
}

sub get_ulps {
  my ($test, $type, $float) = @_;

  if ($type eq 'complex') {
    my ($res);
    # Return 0 instead of BUILD_COMPLEX (0,0)
    if (!exists $results{$test}{'real'}{'ulp'}{$float} &&
	!exists $results{$test}{'imag'}{'ulp'}{$float}) {
      return "0";
    }
    $res = 'BUILD_COMPLEX (';
    $res .= (exists $results{$test}{'real'}{'ulp'}{$float}
	     ? $results{$test}{'real'}{'ulp'}{$float} : "0");
    $res .= ', ';
    $res .= (exists $results{$test}{'imag'}{'ulp'}{$float}
	     ? $results{$test}{'imag'}{'ulp'}{$float} : "0");
    $res .= ')';
    return $res;
  }
  return (exists $results{$test}{'normal'}{'ulp'}{$float}
	  ? $results{$test}{'normal'}{'ulp'}{$float} : "0");
}

sub get_failure {
  my ($test, $type, $float) = @_;
  if ($type eq 'complex') {
    # return x,y
    my ($res);
    # Return 0 instead of BUILD_COMPLEX_INT (0,0)
    if (!exists $results{$test}{'real'}{'ulp'}{$float} &&
	!exists $results{$test}{'imag'}{'ulp'}{$float}) {
      return "0";
    }
    $res = 'BUILD_COMPLEX_INT (';
    $res .= (exists $results{$test}{'real'}{'fail'}{$float}
	     ? $results{$test}{'real'}{'fail'}{$float} : "0");
    $res .= ', ';
    $res .= (exists $results{$test}{'imag'}{'fail'}{$float}
	     ? $results{$test}{'imag'}{'fail'}{$float} : "0");
    $res .= ')';
    return $res;
  }
  return (exists $results{$test}{'normal'}{'fail'}{$float}
	  ? $results{$test}{'normal'}{'fail'}{$float} : "0");

}

# Output the defines for a single test
sub output_test {
  my ($file, $test, $name) = @_;
  my ($ldouble, $double, $float, $ildouble, $idouble, $ifloat);
  my ($type);

  # Do we have ulps/failures?
  if (!exists $results{$test}{'type'}) {
    return;
  }
  $type = $results{$test}{'type'};
  if (exists $results{$test}{'has_ulps'}) {
    # XXX use all_floats (change order!)
    $ldouble = &get_ulps ($test, $type, "ldouble");
    $double = &get_ulps ($test, $type, "double");
    $float = &get_ulps ($test, $type, "float");
    $ildouble = &get_ulps ($test, $type, "ildouble");
    $idouble = &get_ulps ($test, $type, "idouble");
    $ifloat = &get_ulps ($test, $type, "ifloat");
    print $file "#define DELTA$name CHOOSE($ldouble, $double, $float, $ildouble, $idouble, $ifloat)\t/* $test  */\n";
  }

  if (exists $results{$test}{'has_fails'}) {
    $ldouble = &get_failure ($test, "ldouble");
    $double = &get_failure ($test, "double");
    $float = &get_failure ($test, "float");
    $ildouble = &get_failure ($test, "ildouble");
    $idouble = &get_failure ($test, "idouble");
    $ifloat = &get_failure ($test, "ifloat");
    print $file "#define FAIL$name CHOOSE($ldouble, $double, $float $ildouble, $idouble, $ifloat)\t/* $test  */\n";
  }
}

# Print include file
sub output_ulps {
  my ($file, $ulps_filename) = @_;
  my ($i, $fct);

  open ULP, ">$file" or die ("Can't open $file: $!");

  print ULP "/* This file is automatically generated\n";
  print ULP "   from $ulps_filename with gen-libm-test.pl.\n";
  print ULP "   Don't change it - change instead the master files.  */\n\n";

  print ULP "\n/* Maximal error of functions.  */\n";
  foreach $fct (@functions) {
    output_test (\*ULP, $fct, $fct);
  }

  print ULP "\n/* Error of single function calls.  */\n";
  for ($i = 0; $i < $count; $i++) {
    output_test (\*ULP, $tests[$i], $i);
  }
  close ULP;
}