| #!/usr/bin/perl -w |
| # Copyright (C) 1999-2018 Free Software Foundation, Inc. |
| # This file is part of the GNU C Library. |
| # Contributed by Andreas Jaeger <aj@suse.de>, 1999. |
| |
| # The GNU C Library is free software; you can redistribute it and/or |
| # modify it under the terms of the GNU Lesser General Public |
| # License as published by the Free Software Foundation; either |
| # version 2.1 of the License, or (at your option) any later version. |
| |
| # The GNU C Library is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| # Lesser General Public License for more details. |
| |
| # You should have received a copy of the GNU Lesser General Public |
| # License along with the GNU C Library; if not, see |
| # <http://www.gnu.org/licenses/>. |
| |
| # This file needs to be tidied up |
| # Note that functions and tests share the same namespace. |
| |
| # Information about tests are stored in: %results |
| # $results{$test}{"type"} is the result type, e.g. normal or complex. |
| # $results{$test}{"has_ulps"} is set if deltas exist. |
| # In the following description $type and $float are: |
| # - $type is either "normal", "real" (for the real part of a complex number) |
| # or "imag" (for the imaginary part # of a complex number). |
| # - $float is either of float, ifloat, double, idouble, ldouble, ildouble; |
| # It represents the underlying floating point type (float, double or long |
| # double) and if inline functions (the leading i stands for inline) |
| # are used. |
| # $results{$test}{$type}{"ulp"}{$float} is defined and has a delta as value |
| |
| |
| use Getopt::Std; |
| |
| use strict; |
| |
| use vars qw ($input $output $auto_input); |
| use vars qw (%results); |
| use vars qw (%beautify @all_floats %all_floats_pfx); |
| use vars qw ($ulps_file); |
| use vars qw (%auto_tests); |
| |
| # all_floats is sorted and contains all recognised float types |
| @all_floats = ('double', 'float', 'float128', 'idouble', |
| 'ifloat', 'ifloat128', 'ildouble', 'ldouble'); |
| |
| # all_floats_pfx maps C types to their C like prefix for macros. |
| %all_floats_pfx = |
| ( "double" => "DBL", |
| "ldouble" => "LDBL", |
| "float" => "FLT", |
| "float128" => "FLT128", |
| ); |
| |
| %beautify = |
| ( "minus_zero" => "-0", |
| "plus_zero" => "+0", |
| "-0x0p+0f" => "-0", |
| "-0x0p+0" => "-0", |
| "-0x0p+0L" => "-0", |
| "0x0p+0f" => "+0", |
| "0x0p+0" => "+0", |
| "0x0p+0L" => "+0", |
| "minus_infty" => "-inf", |
| "plus_infty" => "inf", |
| "qnan_value" => "qNaN", |
| "snan_value" => "sNaN", |
| "snan_value_ld" => "sNaN", |
| ); |
| |
| |
| # get Options |
| # Options: |
| # a: auto-libm-test-out input file |
| # c: .inc input file |
| # u: ulps-file |
| # n: new ulps file |
| # C: libm-test.c output file |
| # H: libm-test-ulps.h output file |
| # h: help |
| use vars qw($opt_a $opt_c $opt_u $opt_n $opt_C $opt_H $opt_h); |
| getopts('a:c:u:n:C:H:h'); |
| |
| $ulps_file = 'libm-test-ulps'; |
| |
| if ($opt_h) { |
| print "Usage: gen-libm-test.pl [OPTIONS]\n"; |
| print " -h print this help, then exit\n"; |
| print " -a FILE input file with automatically generated tests\n"; |
| print " -c FILE input file .inc file with tests\n"; |
| print " -u FILE input file with ulps\n"; |
| print " -n FILE generate sorted file FILE from libm-test-ulps\n"; |
| print " -C FILE generate output C file FILE from libm-test.inc\n"; |
| print " -H FILE generate output ulps header FILE from libm-test-ulps\n"; |
| exit 0; |
| } |
| |
| $ulps_file = $opt_u if ($opt_u); |
| |
| $input = $opt_c if ($opt_c); |
| $auto_input = $opt_a if ($opt_a); |
| $output = $opt_C if ($opt_C); |
| |
| &parse_ulps ($ulps_file) if ($opt_H || $opt_n); |
| &parse_auto_input ($auto_input) if ($opt_C); |
| &generate_testfile ($input, $output) if ($opt_C); |
| &output_ulps ($opt_H, $ulps_file) if ($opt_H); |
| &print_ulps_file ($opt_n) if ($opt_n); |
| |
| # Return a nicer representation |
| sub beautify { |
| my ($arg) = @_; |
| my ($tmp); |
| |
| if (exists $beautify{$arg}) { |
| return $beautify{$arg}; |
| } |
| if ($arg =~ /^-/) { |
| $tmp = $arg; |
| $tmp =~ s/^-//; |
| if (exists $beautify{$tmp}) { |
| return '-' . $beautify{$tmp}; |
| } |
| } |
| if ($arg =~ /^-?0x[0-9a-f.]*p[-+][0-9]+f$/) { |
| $arg =~ s/f$//; |
| } |
| if ($arg =~ /[0-9]L$/) { |
| $arg =~ s/L$//; |
| } |
| return $arg; |
| } |
| |
| # Return a nicer representation of a complex number |
| sub build_complex_beautify { |
| my ($r, $i) = @_; |
| my ($str1, $str2); |
| |
| $str1 = &beautify ($r); |
| $str2 = &beautify ($i); |
| if ($str2 =~ /^-/) { |
| $str2 =~ s/^-//; |
| $str1 .= ' - ' . $str2; |
| } else { |
| $str1 .= ' + ' . $str2; |
| } |
| $str1 .= ' i'; |
| return $str1; |
| } |
| |
| # Return the text to put in an initializer for a test's exception |
| # information. |
| sub show_exceptions { |
| my ($ignore_result, $non_finite, $test_snan, $exception) = @_; |
| $ignore_result = ($ignore_result ? "IGNORE_RESULT|" : ""); |
| $non_finite = ($non_finite ? "NON_FINITE|" : ""); |
| $test_snan = ($test_snan ? "TEST_SNAN|" : ""); |
| if (defined $exception) { |
| return ", ${ignore_result}${non_finite}${test_snan}$exception"; |
| } else { |
| return ", ${ignore_result}${non_finite}${test_snan}0"; |
| } |
| } |
| |
| # Apply the LIT(x) macro to a literal floating point constant |
| # and strip any existing suffix. |
| sub _apply_lit { |
| my ($lit) = @_; |
| my $exp_re = "([+-])?[[:digit:]]+"; |
| # Don't wrap something that does not look like a: |
| # * Hexadecimal FP value |
| # * Decimal FP value without a decimal point |
| # * Decimal value with a fraction |
| return $lit if $lit !~ /([+-])?0x[[:xdigit:]\.]+[pP]$exp_re/ |
| and $lit !~ /[[:digit:]]+[eE]$exp_re/ |
| and $lit !~ /[[:digit:]]*\.[[:digit:]]*([eE]$exp_re)?/; |
| |
| # Strip any existing literal suffix. |
| $lit =~ s/[lLfF]$//; |
| |
| return "LIT (${lit})"; |
| } |
| |
| # Apply LIT macro to individual tokens within an expression. |
| # |
| # This function assumes the C expression follows GNU coding |
| # standards. Specifically, a space separates each lexical |
| # token. Otherwise, this post-processing may apply LIT |
| # incorrectly, or around an entire expression. |
| sub apply_lit { |
| my ($lit) = @_; |
| my @toks = split (/ /, $lit); |
| foreach (@toks) { |
| $_ = _apply_lit ($_); |
| } |
| return join (' ', @toks); |
| } |
| |
| # Parse the arguments to TEST_x_y |
| sub parse_args { |
| my ($file, $descr, $args) = @_; |
| my (@args, $descr_args, $descr_res, @descr); |
| my ($current_arg, $cline, $cline_res, $i); |
| my (@special); |
| my ($call_args); |
| my ($ignore_result_any, $ignore_result_all); |
| my ($num_res, @args_res, @start_rm, $rm); |
| my (@plus_oflow, @minus_oflow, @plus_uflow, @minus_uflow); |
| my (@errno_plus_oflow, @errno_minus_oflow); |
| my (@errno_plus_uflow, @errno_minus_uflow); |
| my (@xfail_rounding_ibm128_libgcc); |
| my ($non_finite, $test_snan); |
| |
| ($descr_args, $descr_res) = split /_/,$descr, 2; |
| |
| @args = split /,\s*/, $args; |
| |
| $call_args = ""; |
| |
| # Generate first the string that's shown to the user |
| $current_arg = 1; |
| @descr = split //,$descr_args; |
| for ($i = 0; $i <= $#descr; $i++) { |
| my $comma = ""; |
| if ($current_arg > 1) { |
| $comma = ', '; |
| } |
| # FLOAT, long double, int, unsigned int, long int, long long int |
| if ($descr[$i] =~ /f|j|i|u|l|L/) { |
| $call_args .= $comma . &beautify ($args[$current_arg]); |
| ++$current_arg; |
| next; |
| } |
| # Argument passed via pointer. |
| if ($descr[$i] =~ /p/) { |
| next; |
| } |
| # &FLOAT, &int - simplify call by not showing argument. |
| if ($descr[$i] =~ /F|I/) { |
| next; |
| } |
| # complex |
| if ($descr[$i] eq 'c') { |
| $call_args .= $comma . &build_complex_beautify ($args[$current_arg], $args[$current_arg+1]); |
| $current_arg += 2; |
| next; |
| } |
| |
| die ("$descr[$i] is unknown"); |
| } |
| |
| # Result |
| @args_res = @args[$current_arg .. $#args]; |
| $num_res = 0; |
| @descr = split //,$descr_res; |
| foreach (@descr) { |
| if ($_ =~ /f|i|l|L|M|U/) { |
| ++$num_res; |
| } elsif ($_ eq 'c') { |
| $num_res += 2; |
| } elsif ($_ eq 'b') { |
| # boolean |
| ++$num_res; |
| } elsif ($_ eq '1') { |
| ++$num_res; |
| } else { |
| die ("$_ is unknown"); |
| } |
| } |
| # consistency check |
| if ($#args_res == $num_res - 1) { |
| # One set of results for all rounding modes, no flags. |
| @start_rm = ( 0, 0, 0, 0 ); |
| } elsif ($#args_res == $num_res) { |
| # One set of results for all rounding modes, with flags. |
| die ("wrong number of arguments") |
| unless ($args_res[$#args_res] =~ /EXCEPTION|ERRNO|IGNORE_ZERO_INF_SIGN|TEST_NAN_SIGN|NO_TEST_INLINE|XFAIL/); |
| @start_rm = ( 0, 0, 0, 0 ); |
| } elsif ($#args_res == 4 * $num_res + 3) { |
| # One set of results per rounding mode, with flags. |
| @start_rm = ( 0, $num_res + 1, 2 * $num_res + 2, 3 * $num_res + 3 ); |
| } else { |
| die ("wrong number of arguments"); |
| } |
| |
| # Put the C program line together |
| # Reset some variables to start again |
| $current_arg = 1; |
| $call_args =~ s/\"/\\\"/g; |
| $cline = "{ \"$call_args\""; |
| @descr = split //,$descr_args; |
| for ($i=0; $i <= $#descr; $i++) { |
| # FLOAT, int, long int, long long int |
| if ($descr[$i] =~ /f|j|i|u|l|L/) { |
| if ($descr[$i] eq "f") { |
| $cline .= ", " . &apply_lit ($args[$current_arg]); |
| } else { |
| $cline .= ", $args[$current_arg]"; |
| } |
| $current_arg++; |
| next; |
| } |
| # &FLOAT, &int, argument passed via pointer |
| if ($descr[$i] =~ /F|I|p/) { |
| next; |
| } |
| # complex |
| if ($descr[$i] eq 'c') { |
| $cline .= ", " . &apply_lit ($args[$current_arg]); |
| $cline .= ", " . &apply_lit ($args[$current_arg+1]); |
| $current_arg += 2; |
| next; |
| } |
| } |
| |
| @descr = split //,$descr_res; |
| @plus_oflow = qw(max_value plus_infty max_value plus_infty); |
| @minus_oflow = qw(minus_infty minus_infty -max_value -max_value); |
| @plus_uflow = qw(plus_zero plus_zero plus_zero min_subnorm_value); |
| @minus_uflow = qw(-min_subnorm_value minus_zero minus_zero minus_zero); |
| @errno_plus_oflow = qw(0 ERRNO_ERANGE 0 ERRNO_ERANGE); |
| @errno_minus_oflow = qw(ERRNO_ERANGE ERRNO_ERANGE 0 0); |
| @errno_plus_uflow = qw(ERRNO_ERANGE ERRNO_ERANGE ERRNO_ERANGE 0); |
| @errno_minus_uflow = qw(0 ERRNO_ERANGE ERRNO_ERANGE ERRNO_ERANGE); |
| @xfail_rounding_ibm128_libgcc = qw(XFAIL_IBM128_LIBGCC 0 |
| XFAIL_IBM128_LIBGCC XFAIL_IBM128_LIBGCC); |
| for ($rm = 0; $rm <= 3; $rm++) { |
| $current_arg = $start_rm[$rm]; |
| $ignore_result_any = 0; |
| $ignore_result_all = 1; |
| $cline_res = ""; |
| @special = (); |
| foreach (@descr) { |
| if ($_ =~ /b|f|j|i|l|L|M|U/ ) { |
| my ($result) = $args_res[$current_arg]; |
| if ($result eq "IGNORE") { |
| $ignore_result_any = 1; |
| $result = "0"; |
| } else { |
| $ignore_result_all = 0; |
| } |
| if ($_ eq "f") { |
| $result = apply_lit ($result); |
| } |
| $cline_res .= ", $result"; |
| $current_arg++; |
| } elsif ($_ eq 'c') { |
| my ($result1) = $args_res[$current_arg]; |
| if ($result1 eq "IGNORE") { |
| $ignore_result_any = 1; |
| $result1 = "0"; |
| } else { |
| $ignore_result_all = 0; |
| } |
| my ($result2) = $args_res[$current_arg + 1]; |
| if ($result2 eq "IGNORE") { |
| $ignore_result_any = 1; |
| $result2 = "0"; |
| } else { |
| $ignore_result_all = 0; |
| } |
| $result1 = apply_lit ($result1); |
| $result2 = apply_lit ($result2); |
| $cline_res .= ", $result1, $result2"; |
| $current_arg += 2; |
| } elsif ($_ eq '1') { |
| push @special, $args_res[$current_arg]; |
| ++$current_arg; |
| } |
| } |
| if ($ignore_result_any && !$ignore_result_all) { |
| die ("some but not all function results ignored\n"); |
| } |
| # Determine whether any arguments or results, for any rounding |
| # mode, are non-finite. |
| $non_finite = ($args =~ /qnan_value|snan_value|plus_infty|minus_infty/); |
| $test_snan = ($args =~ /snan_value/); |
| # Add exceptions. |
| $cline_res .= show_exceptions ($ignore_result_any, |
| $non_finite, |
| $test_snan, |
| ($current_arg <= $#args_res) |
| ? $args_res[$current_arg] |
| : undef); |
| |
| # special treatment for some functions |
| $i = 0; |
| foreach (@special) { |
| ++$i; |
| my ($extra_expected) = $_; |
| my ($run_extra) = ($extra_expected ne "IGNORE" ? 1 : 0); |
| if (!$run_extra) { |
| $extra_expected = "0"; |
| } else { |
| $extra_expected = apply_lit ($extra_expected); |
| } |
| $cline_res .= ", $run_extra, $extra_expected"; |
| } |
| $cline_res =~ s/^, //; |
| $cline_res =~ s/plus_oflow/$plus_oflow[$rm]/g; |
| $cline_res =~ s/minus_oflow/$minus_oflow[$rm]/g; |
| $cline_res =~ s/plus_uflow/$plus_uflow[$rm]/g; |
| $cline_res =~ s/minus_uflow/$minus_uflow[$rm]/g; |
| $cline_res =~ s/ERRNO_PLUS_OFLOW/$errno_plus_oflow[$rm]/g; |
| $cline_res =~ s/ERRNO_MINUS_OFLOW/$errno_minus_oflow[$rm]/g; |
| $cline_res =~ s/ERRNO_PLUS_UFLOW/$errno_plus_uflow[$rm]/g; |
| $cline_res =~ s/ERRNO_MINUS_UFLOW/$errno_minus_uflow[$rm]/g; |
| $cline_res =~ s/XFAIL_ROUNDING_IBM128_LIBGCC/$xfail_rounding_ibm128_libgcc[$rm]/g; |
| $cline .= ", { $cline_res }"; |
| } |
| print $file " $cline },\n"; |
| } |
| |
| # Convert a condition from auto-libm-test-out to C form. |
| sub convert_condition { |
| my ($cond) = @_; |
| my (@conds, $ret); |
| @conds = split /:/, $cond; |
| foreach (@conds) { |
| s/-/_/g; |
| s/^/TEST_COND_/; |
| } |
| $ret = join " && ", @conds; |
| return "($ret)"; |
| } |
| |
| # Return text to OR a value into an accumulated flags string. |
| sub or_value { |
| my ($cond) = @_; |
| if ($cond eq "0") { |
| return ""; |
| } else { |
| return " | $cond"; |
| } |
| } |
| |
| # Return a conditional expression between two values. |
| sub cond_value { |
| my ($cond, $if, $else) = @_; |
| if ($cond eq "1") { |
| return $if; |
| } elsif ($cond eq "0") { |
| return $else; |
| } else { |
| return "($cond ? $if : $else)"; |
| } |
| } |
| |
| # Return text to OR a conditional expression between two values into |
| # an accumulated flags string. |
| sub or_cond_value { |
| my ($cond, $if, $else) = @_; |
| return or_value (cond_value ($cond, $if, $else)); |
| } |
| |
| # Generate libm-test.c |
| sub generate_testfile { |
| my ($input, $output) = @_; |
| |
| open INPUT, $input or die ("Can't open $input: $!"); |
| open OUTPUT, ">$output" or die ("Can't open $output: $!"); |
| |
| # Replace the special macros |
| while (<INPUT>) { |
| # AUTO_TESTS (function), |
| if (/^\s*AUTO_TESTS_/) { |
| my ($descr, $func, @modes, $auto_test, $num_auto_tests); |
| my (@rm_tests, $rm, $i); |
| @modes = qw(downward tonearest towardzero upward); |
| ($descr, $func) = ($_ =~ /AUTO_TESTS_(\w+)\s*\((\w+)\)/); |
| for ($rm = 0; $rm <= 3; $rm++) { |
| $rm_tests[$rm] = [sort keys %{$auto_tests{$func}{$modes[$rm]}}]; |
| } |
| $num_auto_tests = scalar @{$rm_tests[0]}; |
| for ($rm = 1; $rm <= 3; $rm++) { |
| if ($num_auto_tests != scalar @{$rm_tests[$rm]}) { |
| die ("inconsistent numbers of tests for $func\n"); |
| } |
| for ($i = 0; $i < $num_auto_tests; $i++) { |
| if ($rm_tests[0][$i] ne $rm_tests[$rm][$i]) { |
| die ("inconsistent list of tests of $func\n"); |
| } |
| } |
| } |
| if ($num_auto_tests == 0) { |
| die ("no automatic tests for $func\n"); |
| } |
| foreach $auto_test (@{$rm_tests[0]}) { |
| my ($format, $inputs, $format_conv, $args_str); |
| ($format, $inputs) = split / /, $auto_test, 2; |
| $inputs =~ s/ /, /g; |
| $format_conv = convert_condition ($format); |
| print OUTPUT "#if $format_conv\n"; |
| $args_str = "$func, $inputs"; |
| for ($rm = 0; $rm <= 3; $rm++) { |
| my ($auto_test_out, $outputs, $flags); |
| my ($flags_conv, @flags, %flag_cond); |
| $auto_test_out = $auto_tests{$func}{$modes[$rm]}{$auto_test}; |
| ($outputs, $flags) = split / : */, $auto_test_out; |
| $outputs =~ s/ /, /g; |
| @flags = split / /, $flags; |
| foreach (@flags) { |
| if (/^([^:]*):(.*)$/) { |
| my ($flag, $cond); |
| $flag = $1; |
| $cond = convert_condition ($2); |
| if (defined ($flag_cond{$flag})) { |
| if ($flag_cond{$flag} ne "1") { |
| $flag_cond{$flag} .= " || $cond"; |
| } |
| } else { |
| $flag_cond{$flag} = $cond; |
| } |
| } else { |
| $flag_cond{$_} = "1"; |
| } |
| } |
| $flags_conv = ""; |
| if (defined ($flag_cond{"ignore-zero-inf-sign"})) { |
| $flags_conv .= or_cond_value ($flag_cond{"ignore-zero-inf-sign"}, |
| "IGNORE_ZERO_INF_SIGN", "0"); |
| } |
| if (defined ($flag_cond{"no-test-inline"})) { |
| $flags_conv .= or_cond_value ($flag_cond{"no-test-inline"}, |
| "NO_TEST_INLINE", "0"); |
| } |
| if (defined ($flag_cond{"xfail"})) { |
| $flags_conv .= or_cond_value ($flag_cond{"xfail"}, |
| "XFAIL_TEST", "0"); |
| } |
| my (@exc_list) = qw(divbyzero inexact invalid overflow underflow); |
| my ($exc); |
| foreach $exc (@exc_list) { |
| my ($exc_expected, $exc_ok, $no_exc, $exc_cond, $exc_ok_cond); |
| $exc_expected = "\U$exc\E_EXCEPTION"; |
| $exc_ok = "\U$exc\E_EXCEPTION_OK"; |
| $no_exc = "0"; |
| if ($exc eq "inexact") { |
| $exc_ok = "0"; |
| $no_exc = "NO_INEXACT_EXCEPTION"; |
| } |
| if (defined ($flag_cond{$exc})) { |
| $exc_cond = $flag_cond{$exc}; |
| } else { |
| $exc_cond = "0"; |
| } |
| if (defined ($flag_cond{"$exc-ok"})) { |
| $exc_ok_cond = $flag_cond{"$exc-ok"}; |
| } else { |
| $exc_ok_cond = "0"; |
| } |
| $flags_conv .= or_cond_value ($exc_cond, |
| cond_value ($exc_ok_cond, |
| $exc_ok, $exc_expected), |
| cond_value ($exc_ok_cond, |
| $exc_ok, $no_exc)); |
| } |
| my ($errno_expected, $errno_unknown_cond); |
| if (defined ($flag_cond{"errno-edom"})) { |
| if ($flag_cond{"errno-edom"} ne "1") { |
| die ("unexpected condition for errno-edom"); |
| } |
| if (defined ($flag_cond{"errno-erange"})) { |
| die ("multiple errno values expected"); |
| } |
| $errno_expected = "ERRNO_EDOM"; |
| } elsif (defined ($flag_cond{"errno-erange"})) { |
| if ($flag_cond{"errno-erange"} ne "1") { |
| die ("unexpected condition for errno-erange"); |
| } |
| $errno_expected = "ERRNO_ERANGE"; |
| } else { |
| $errno_expected = "ERRNO_UNCHANGED"; |
| } |
| if (defined ($flag_cond{"errno-edom-ok"})) { |
| if (defined ($flag_cond{"errno-erange-ok"}) |
| && ($flag_cond{"errno-erange-ok"} |
| ne $flag_cond{"errno-edom-ok"})) { |
| $errno_unknown_cond = "($flag_cond{\"errno-edom-ok\"} || $flag_cond{\"errno-erange-ok\"})"; |
| } else { |
| $errno_unknown_cond = $flag_cond{"errno-edom-ok"}; |
| } |
| } elsif (defined ($flag_cond{"errno-erange-ok"})) { |
| $errno_unknown_cond = $flag_cond{"errno-erange-ok"}; |
| } else { |
| $errno_unknown_cond = "0"; |
| } |
| $flags_conv .= or_cond_value ($errno_unknown_cond, |
| "0", $errno_expected); |
| if ($flags_conv eq "") { |
| $flags_conv = ", NO_EXCEPTION"; |
| } else { |
| $flags_conv =~ s/^ \|/,/; |
| } |
| $args_str .= ", $outputs$flags_conv"; |
| } |
| &parse_args (\*OUTPUT, $descr, $args_str); |
| print OUTPUT "#endif\n"; |
| } |
| next; |
| } |
| |
| # TEST_... |
| if (/^\s*TEST_/) { |
| my ($descr, $args); |
| chop; |
| ($descr, $args) = ($_ =~ /TEST_(\w+)\s*\((.*)\)/); |
| &parse_args (\*OUTPUT, $descr, $args); |
| next; |
| } |
| print OUTPUT; |
| } |
| close INPUT; |
| close OUTPUT; |
| } |
| |
| |
| |
| # Parse ulps file |
| sub parse_ulps { |
| my ($file) = @_; |
| my ($test, $type, $float, $eps, $float_regex); |
| |
| # Build a basic regex to match type entries in the |
| # generated ULPS file. |
| foreach my $ftype (@all_floats) { |
| $float_regex .= "|" . $ftype; |
| } |
| $float_regex = "^" . substr ($float_regex, 1) . ":"; |
| |
| # $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 (/^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_]+)\"/); |
| next; |
| } |
| if (/$float_regex/) { |
| ($float, $eps) = split /\s*:\s*/,$_,2; |
| |
| if ($eps eq "0") { |
| # ignore |
| next; |
| } else { |
| if (!defined ($results{$test}{$type}{'ulp'}{$float}) |
| || $results{$test}{$type}{'ulp'}{$float} < $eps) { |
| $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'; |
| } |
| next; |
| } |
| print "Skipping unknown entry: `$_'\n"; |
| } |
| close ULP; |
| } |
| |
| |
| # Clean up a floating point number |
| sub clean_up_number { |
| my ($number) = @_; |
| |
| # Remove trailing zeros after the decimal point |
| if ($number =~ /\./) { |
| $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"; |
| print NEWULP "\n# Maximal error of functions:\n"; |
| |
| foreach $fct (sort keys %results) { |
| 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"; |
| } |
| } |
| print NEWULP "\n"; |
| } |
| } |
| } |
| print NEWULP "# end of automatic generation\n"; |
| close NEWULP; |
| } |
| |
| sub get_ulps { |
| my ($test, $type, $float) = @_; |
| |
| return (exists $results{$test}{$type}{'ulp'}{$float} |
| ? $results{$test}{$type}{'ulp'}{$float} : "0"); |
| } |
| |
| # Return the ulps value for a single test. |
| sub get_all_ulps_for_test { |
| my ($test, $type) = @_; |
| my ($ldouble, $double, $float, $ildouble, $idouble, $ifloat); |
| my ($ulps_str); |
| |
| if (exists $results{$test}{'has_ulps'}) { |
| foreach $float (@all_floats) { |
| $ulps_str .= &get_ulps ($test, $type, $float) . ", "; |
| } |
| return "{" . substr ($ulps_str, 0, -2) . "}"; |
| } else { |
| die "get_all_ulps_for_test called for \"$test\" with no ulps\n"; |
| } |
| } |
| |
| # Print include file |
| sub output_ulps { |
| my ($file, $ulps_filename) = @_; |
| my ($i, $fct, $type, $ulp, $ulp_real, $ulp_imag); |
| my (%func_ulps, %func_real_ulps, %func_imag_ulps); |
| |
| 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 "struct ulp_data\n"; |
| print ULP "{\n"; |
| print ULP " const char *name;\n"; |
| print ULP " FLOAT max_ulp[" . @all_floats . "];\n"; |
| print ULP "};\n\n"; |
| |
| for ($i = 0; $i <= $#all_floats; $i++) { |
| $type = $all_floats[$i]; |
| print ULP "#define ULP_"; |
| if ($type =~ /^i/) { |
| print ULP "I_"; |
| $type = substr $type, 1; |
| } |
| print ULP "$all_floats_pfx{$type} $i\n"; |
| } |
| |
| foreach $fct (keys %results) { |
| $type = $results{$fct}{'type'}; |
| if ($type eq 'normal') { |
| $ulp = get_all_ulps_for_test ($fct, 'normal'); |
| } elsif ($type eq 'complex') { |
| $ulp_real = get_all_ulps_for_test ($fct, 'real'); |
| $ulp_imag = get_all_ulps_for_test ($fct, 'imag'); |
| } else { |
| die "unknown results ($fct) type $type\n"; |
| } |
| if ($type eq 'normal') { |
| $func_ulps{$fct} = $ulp; |
| } else { |
| $func_real_ulps{$fct} = $ulp_real; |
| $func_imag_ulps{$fct} = $ulp_imag; |
| } |
| } |
| print ULP "\n/* Maximal error of functions. */\n"; |
| print ULP "static const struct ulp_data func_ulps[] =\n {\n"; |
| foreach $fct (sort keys %func_ulps) { |
| print ULP " { \"$fct\", $func_ulps{$fct} },\n"; |
| } |
| print ULP " };\n"; |
| print ULP "static const struct ulp_data func_real_ulps[] =\n {\n"; |
| foreach $fct (sort keys %func_real_ulps) { |
| print ULP " { \"$fct\", $func_real_ulps{$fct} },\n"; |
| } |
| print ULP " };\n"; |
| print ULP "static const struct ulp_data func_imag_ulps[] =\n {\n"; |
| foreach $fct (sort keys %func_imag_ulps) { |
| print ULP " { \"$fct\", $func_imag_ulps{$fct} },\n"; |
| } |
| print ULP " };\n"; |
| close ULP; |
| } |
| |
| # Parse auto-libm-test-out. |
| sub parse_auto_input { |
| my ($file) = @_; |
| open AUTO, $file or die ("Can't open $file: $!"); |
| while (<AUTO>) { |
| chop; |
| next if !/^= /; |
| s/^= //; |
| if (/^(\S+) (\S+) ([^:]*) : (.*)$/) { |
| $auto_tests{$1}{$2}{$3} = $4; |
| } else { |
| die ("bad automatic test line: $_\n"); |
| } |
| } |
| close AUTO; |
| } |