1: #!/usr/bin/perl -w
    2: # Copyright (C) 1999, 2006 Free Software Foundation, Inc.
    3: # This file is part of the GNU C Library.
    4: # Contributed by Andreas Jaeger <aj@suse.de>, 1999.
    5: 
    6: # The GNU C Library is free software; you can redistribute it and/or
    7: # modify it under the terms of the GNU Lesser General Public
    8: # License as published by the Free Software Foundation; either
    9: # version 2.1 of the License, or (at your option) any later version.
   10: 
   11: # The GNU C Library is distributed in the hope that it will be useful,
   12: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   13: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   14: # Lesser General Public License for more details.
   15: 
   16: # You should have received a copy of the GNU Lesser General Public
   17: # License along with the GNU C Library; if not, write to the Free
   18: # Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
   19: # 02111-1307 USA.
   20: 
   21: # This file needs to be tidied up
   22: # Note that functions and tests share the same namespace.
   23: 
   24: # Information about tests are stored in: %results
   25: # $results{$test}{"kind"} is either "fct" or "test" and flags whether this
   26: # is a maximal error of a function or a single test.
   27: # $results{$test}{"type"} is the result type, e.g. normal or complex.
   28: # $results{$test}{"has_ulps"} is set if deltas exist.
   29: # $results{$test}{"has_fails"} is set if exptected failures exist.
   30: # In the following description $type and $float are:
   31: # - $type is either "normal", "real" (for the real part of a complex number)
   32: #   or "imag" (for the imaginary part # of a complex number).
   33: # - $float is either of float, ifloat, double, idouble, ldouble, ildouble;
   34: #   It represents the underlying floating point type (float, double or long
   35: #   double) and if inline functions (the leading i stands for inline)
   36: #   are used.
   37: # $results{$test}{$type}{"fail"}{$float} is defined and has a 1 if
   38: # the test is expected to fail
   39: # $results{$test}{$type}{"ulp"}{$float} is defined and has a delta as value
   40: 
   41: 
   42: use Getopt::Std;
   43: 
   44: use strict;
   45: 
   46: use vars qw ($input $output);
   47: use vars qw (%results);
   48: use vars qw (@tests @functions);
   49: use vars qw ($count);
   50: use vars qw (%beautify @all_floats);
   51: use vars qw ($output_dir $ulps_file);
   52: 
   53: # all_floats is sorted and contains all recognised float types
   54: @all_floats = ('double', 'float', 'idouble',
   55:                'ifloat', 'ildouble', 'ldouble');
   56: 
   57: %beautify =
   58:   ( "minus_zero" => "-0",
   59:     "plus_zero" => "+0",
   60:     "minus_infty" => "-inf",
   61:     "plus_infty" => "inf",
   62:     "nan_value" => "NaN",
   63:     "M_El" => "e",
   64:     "M_E2l" => "e^2",
   65:     "M_E3l" => "e^3",
   66:     "M_LOG10El", "log10(e)",
   67:     "M_PIl" => "pi",
   68:     "M_PI_34l" => "3/4 pi",
   69:     "M_PI_2l" => "pi/2",
   70:     "M_PI_4l" => "pi/4",
   71:     "M_PI_6l" => "pi/6",
   72:     "M_PI_34_LOG10El" => "3/4 pi*log10(e)",
   73:     "M_PI_LOG10El" => "pi*log10(e)",
   74:     "M_PI2_LOG10El" => "pi/2*log10(e)",
   75:     "M_PI4_LOG10El" => "pi/4*log10(e)",
   76:     "M_LOG_SQRT_PIl" => "log(sqrt(pi))",
   77:     "M_LOG_2_SQRT_PIl" => "log(2*sqrt(pi))",
   78:     "M_2_SQRT_PIl" => "2 sqrt (pi)",
   79:     "M_SQRT_PIl" => "sqrt (pi)",
   80:     "INVALID_EXCEPTION" => "invalid exception",
   81:     "DIVIDE_BY_ZERO_EXCEPTION" => "division by zero exception",
   82:     "INVALID_EXCEPTION_OK" => "invalid exception allowed",
   83:     "DIVIDE_BY_ZERO_EXCEPTION_OK" => "division by zero exception allowed",
   84:     "EXCEPTIONS_OK" => "exceptions allowed",
   85:     "IGNORE_ZERO_INF_SIGN" => "sign of zero/inf not specified",
   86: "INVALID_EXCEPTION|IGNORE_ZERO_INF_SIGN" => "invalid exception and sign of zero/inf not specified"
   87:   );
   88: 
   89: 
   90: # get Options
   91: # Options:
   92: # u: ulps-file
   93: # h: help
   94: # o: output-directory
   95: # n: generate new ulps file
   96: use vars qw($opt_u $opt_h $opt_o $opt_n);
   97: getopts('u:o:nh');
   98: 
   99: $ulps_file = 'libm-test-ulps';
  100: $output_dir = '';
  101: 
  102: if ($opt_h) {
  103:   print "Usage: gen-libm-test.pl [OPTIONS]\n";
  104:   print " -h         print this help, then exit\n";
  105:   print " -o DIR     directory where generated files will be placed\n";
  106:   print " -n         only generate sorted file NewUlps from libm-test-ulps\n";
  107:   print " -u FILE    input file with ulps\n";
  108:   exit 0;
  109: }
  110: 
  111: $ulps_file = $opt_u if ($opt_u);
  112: $output_dir = $opt_o if ($opt_o);
  113: 
  114: $input = "libm-test.inc";
  115: $output = "${output_dir}libm-test.c";
  116: 
  117: $count = 0;
  118: 
  119: &parse_ulps ($ulps_file);
  120: &generate_testfile ($input, $output) unless ($opt_n);
  121: &output_ulps ("${output_dir}libm-test-ulps.h", $ulps_file) unless ($opt_n);
  122: &print_ulps_file ("${output_dir}NewUlps") if ($opt_n);
  123: 
  124: # Return a nicer representation
  125: sub beautify {
  126:   my ($arg) = @_;
  127:   my ($tmp);
  128: 
  129:   if (exists $beautify{$arg}) {
  130:     return $beautify{$arg};
  131:   }
  132:   if ($arg =~ /^-/) {
  133:     $tmp = $arg;
  134:     $tmp =~ s/^-//;
  135:     if (exists $beautify{$tmp}) {
  136:       return '-' . $beautify{$tmp};
  137:     }
  138:   }
  139:   if ($arg =~ /[0-9]L$/) {
  140:     $arg =~ s/L$//;
  141:   }
  142:   return $arg;
  143: }
  144: 
  145: # Return a nicer representation of a complex number
  146: sub build_complex_beautify {
  147:   my ($r, $i) = @_;
  148:   my ($str1, $str2);
  149: 
  150:   $str1 = &beautify ($r);
  151:   $str2 = &beautify ($i);
  152:   if ($str2 =~ /^-/) {
  153:     $str2 =~ s/^-//;
  154:     $str1 .= ' - ' . $str2;
  155:   } else {
  156:     $str1 .= ' + ' . $str2;
  157:   }
  158:   $str1 .= ' i';
  159:   return $str1;
  160: }
  161: 
  162: # Return name of a variable
  163: sub get_variable {
  164:   my ($number) = @_;
  165: 
  166:   return "x" if ($number == 1);
  167:   return "y" if ($number == 2);
  168:   return "z" if ($number == 3);
  169:   # return x1,x2,...
  170:   $number =-3;
  171:   return "x$number";
  172: }
  173: 
  174: # Add a new test to internal data structures and fill in the
  175: # ulps, failures and exception information for the C line.
  176: sub new_test {
  177:   my ($test, $exception) = @_;
  178:   my $rest;
  179: 
  180:   # Add ulp, xfail
  181:   if (exists $results{$test}{'has_ulps'}) {
  182:     $rest = ", DELTA$count";
  183:   } else {
  184:     $rest = ', 0';
  185:   }
  186:   if (exists $results{$test}{'has_fails'}) {
  187:     $rest .= ", FAIL$count";
  188:   } else {
  189:     $rest .= ', 0';
  190:   }
  191:   if (defined $exception) {
  192:     $rest .= ", $exception";
  193:   } else {
  194:     $rest .= ', 0';
  195:   }
  196:   $rest .= ");\n";
  197:   # We must increment here to keep @tests and count in sync
  198:   push @tests, $test;
  199:   ++$count;
  200:   return $rest;
  201: }
  202: 
  203: # Treat some functions especially.
  204: # Currently only sincos needs extra treatment.
  205: sub special_functions {
  206:   my ($file, $args) = @_;
  207:   my (@args, $str, $test, $cline);
  208: 
  209:   @args = split /,\s*/, $args;
  210: 
  211:   unless ($args[0] =~ /sincos/) {
  212:     die ("Don't know how to handle $args[0] extra.");
  213:   }
  214:   print $file "  FUNC (sincos) ($args[1], &sin_res, &cos_res);\n";
  215: 
  216:   $str = 'sincos (' . &beautify ($args[1]) . ', &sin_res, &cos_res)';
  217:   # handle sin
  218:   $test = $str . ' puts ' . &beautify ($args[2]) . ' in sin_res';
  219:   if ($#args == 4) {
  220:     $test .= " plus " . &beautify ($args[4]);
  221:   }
  222: 
  223:   $cline = "  check_float (\"$test\", sin_res, $args[2]";
  224:   $cline .= &new_test ($test, $args[4]);
  225:   print $file $cline;
  226: 
  227:   # handle cos
  228:   $test = $str . ' puts ' . &beautify ($args[3]) . ' in cos_res';
  229:   $cline = "  check_float (\"$test\", cos_res, $args[3]";
  230:   # only tests once for exception
  231:   $cline .= &new_test ($test, undef);
  232:   print $file $cline;
  233: }
  234: 
  235: # Parse the arguments to TEST_x_y
  236: sub parse_args {
  237:   my ($file, $descr, $fct, $args) = @_;
  238:   my (@args, $str, $descr_args, $descr_res, @descr);
  239:   my ($current_arg, $cline, $i);
  240:   my ($pre, $post, @special);
  241:   my ($extra_var, $call, $c_call);
  242: 
  243:   if ($descr eq 'extra') {
  244:     &special_functions ($file, $args);
  245:     return;
  246:   }
  247:   ($descr_args, $descr_res) = split /_/,$descr, 2;
  248: 
  249:   @args = split /,\s*/, $args;
  250: 
  251:   $call = "$fct (";
  252: 
  253:   # Generate first the string that's shown to the user
  254:   $current_arg = 1;
  255:   $extra_var = 0;
  256:   @descr = split //,$descr_args;
  257:   for ($i = 0; $i <= $#descr; $i++) {
  258:     if ($i >= 1) {
  259:       $call .= ', ';
  260:     }
  261:     # FLOAT, int, long int, long long int
  262:     if ($descr[$i] =~ /f|i|l|L/) {
  263:       $call .= &beautify ($args[$current_arg]);
  264:       ++$current_arg;
  265:       next;
  266:     }
  267:     # &FLOAT, &int - argument is added here
  268:     if ($descr[$i] =~ /F|I/) {
  269:       ++$extra_var;
  270:       $call .= '&' . &get_variable ($extra_var);
  271:       next;
  272:     }
  273:     # complex
  274:     if ($descr[$i] eq 'c') {
  275:       $call .= &build_complex_beautify ($args[$current_arg], $args[$current_arg+1]);
  276:       $current_arg += 2;
  277:       next;
  278:     }
  279: 
  280:     die ("$descr[$i] is unknown");
  281:   }
  282:   $call .= ')';
  283:   $str = "$call == ";
  284: 
  285:   # Result
  286:   @descr = split //,$descr_res;
  287:   foreach (@descr) {
  288:     if ($_ =~ /f|i|l|L/) {
  289:       $str .= &beautify ($args[$current_arg]);
  290:       ++$current_arg;
  291:     } elsif ($_ eq 'c') {
  292:       $str .= &build_complex_beautify ($args[$current_arg], $args[$current_arg+1]);
  293:       $current_arg += 2;
  294:     } elsif ($_ eq 'b') {
  295:       # boolean
  296:       $str .= ($args[$current_arg] == 0) ? "false" : "true";
  297:       ++$current_arg;
  298:     } elsif ($_ eq '1') {
  299:       ++$current_arg;
  300:     } else {
  301:       die ("$_ is unknown");
  302:     }
  303:   }
  304:   # consistency check
  305:   if ($current_arg == $#args) {
  306:     die ("wrong number of arguments")
  307:       unless ($args[$current_arg] =~ /EXCEPTION|IGNORE_ZERO_INF_SIGN/);
  308:   } elsif ($current_arg < $#args) {
  309:     die ("wrong number of arguments");
  310:   } elsif ($current_arg > ($#args+1)) {
  311:     die ("wrong number of arguments");
  312:   }
  313: 
  314: 
  315:   # check for exceptions
  316:   if ($current_arg <= $#args) {
  317:     $str .= " plus " . &beautify ($args[$current_arg]);
  318:   }
  319: 
  320:   # Put the C program line together
  321:   # Reset some variables to start again
  322:   $current_arg = 1;
  323:   $extra_var = 0;
  324:   if (substr($descr_res,0,1) eq 'f') {
  325:     $cline = 'check_float'
  326:   } elsif (substr($descr_res,0,1) eq 'b') {
  327:     $cline = 'check_bool';
  328:   } elsif (substr($descr_res,0,1) eq 'c') {
  329:     $cline = 'check_complex';
  330:   } elsif (substr($descr_res,0,1) eq 'i') {
  331:     $cline = 'check_int';
  332:   } elsif (substr($descr_res,0,1) eq 'l') {
  333:     $cline = 'check_long';
  334:   } elsif (substr($descr_res,0,1) eq 'L') {
  335:     $cline = 'check_longlong';
  336:   }
  337:   # Special handling for some macros:
  338:   $cline .= " (\"$str\", ";
  339:   if ($args[0] =~ /fpclassify|isnormal|isfinite|signbit/) {
  340:     $c_call = "$args[0] (";
  341:   } else {
  342:     $c_call = " FUNC($args[0]) (";
  343:   }
  344:   @descr = split //,$descr_args;
  345:   for ($i=0; $i <= $#descr; $i++) {
  346:     if ($i >= 1) {
  347:       $c_call .= ', ';
  348:     }
  349:     # FLOAT, int, long int, long long int
  350:     if ($descr[$i] =~ /f|i|l|L/) {
  351:       $c_call .= $args[$current_arg];
  352:       $current_arg++;
  353:       next;
  354:     }
  355:     # &FLOAT, &int
  356:     if ($descr[$i] =~ /F|I/) {
  357:       ++$extra_var;
  358:       $c_call .= '&' . &get_variable ($extra_var);
  359:       next;
  360:     }
  361:     # complex
  362:     if ($descr[$i] eq 'c') {
  363:       $c_call .= "BUILD_COMPLEX ($args[$current_arg], $args[$current_arg+1])";
  364:       $current_arg += 2;
  365:       next;
  366:     }
  367:   }
  368:   $c_call .= ')';
  369:   $cline .= "$c_call, ";
  370: 
  371:   @descr = split //,$descr_res;
  372:   foreach (@descr) {
  373:     if ($_ =~ /b|f|i|l|L/ ) {
  374:       $cline .= $args[$current_arg];
  375:       $current_arg++;
  376:     } elsif ($_ eq 'c') {
  377:       $cline .= "BUILD_COMPLEX ($args[$current_arg], $args[$current_arg+1])";
  378:       $current_arg += 2;
  379:     } elsif ($_ eq '1') {
  380:       push @special, $args[$current_arg];
  381:       ++$current_arg;
  382:     }
  383:   }
  384:   # Add ulp, xfail
  385:   $cline .= &new_test ($str, ($current_arg <= $#args) ? $args[$current_arg] : undef);
  386: 
  387:   # special treatment for some functions
  388:   if ($args[0] eq 'frexp') {
  389:     if (defined $special[0] && $special[0] ne "IGNORE") {
  390:       my ($str) = "$call sets x to $special[0]";
  391:       $post = "  check_int (\"$str\", x, $special[0]";
  392:       $post .= &new_test ($str, undef);
  393:     }
  394:   } elsif ($args[0] eq 'gamma' || $args[0] eq 'lgamma') {
  395:     $pre = "  signgam = 0;\n";
  396:     if (defined $special[0] && $special[0] ne "IGNORE") {
  397:       my ($str) = "$call sets signgam to $special[0]";
  398:       $post = "  check_int (\"$str\", signgam, $special[0]";
  399:       $post .= &new_test ($str, undef);
  400:     }
  401:   } elsif ($args[0] eq 'modf') {
  402:     if (defined $special[0] && $special[0] ne "IGNORE") {
  403:       my ($str) = "$call sets x to $special[0]";
  404:       $post = "  check_float (\"$str\", x, $special[0]";
  405:       $post .= &new_test ($str, undef);
  406:     }
  407:   } elsif ($args[0] eq 'remquo') {
  408:     if (defined $special[0] && $special[0] ne "IGNORE") {
  409:       my ($str) = "$call sets x to $special[0]";
  410:       $post = "  check_int (\"$str\", x, $special[0]";
  411:       $post .= &new_test ($str, undef);
  412:     }
  413:   }
  414: 
  415:   print $file $pre if (defined $pre);
  416: 
  417:   print $file "  $cline";
  418: 
  419:   print $file $post if (defined $post);
  420: }
  421: 
  422: # Generate libm-test.c
  423: sub generate_testfile {
  424:   my ($input, $output) = @_;
  425:   my ($lasttext);
  426:   my (@args, $i, $str, $thisfct);
  427: 
  428:   open INPUT, $input or die ("Can't open $input: $!");
  429:   open OUTPUT, ">$output" or die ("Can't open $output: $!");
  430: 
  431:   # Replace the special macros
  432:   while (<INPUT>) {
  433: 
  434:     # TEST_...
  435:     if (/^\s*TEST_/) {
  436:       my ($descr, $args);
  437:       chop;
  438:       ($descr, $args) = ($_ =~ /TEST_(\w+)\s*\((.*)\)/);
  439:       &parse_args (\*OUTPUT, $descr, $thisfct, $args);
  440:       next;
  441:     }
  442:     # START (function)
  443:     if (/START/) {
  444:       ($thisfct) = ($_ =~ /START\s*\((.*)\)/);
  445:       print OUTPUT "  init_max_error ();\n";
  446:       next;
  447:     }
  448:     # END (function)
  449:     if (/END/) {
  450:       my ($fct, $line, $type);
  451:       if (/complex/) {
  452:         s/,\s*complex\s*//;
  453:         $type = 'complex';
  454:       } else {
  455:         $type = 'normal';
  456:       }
  457:       ($fct) = ($_ =~ /END\s*\((.*)\)/);
  458:       if ($type eq 'complex') {
  459:         $line = "  print_complex_max_error (\"$fct\", ";
  460:       } else {
  461:         $line = "  print_max_error (\"$fct\", ";
  462:       }
  463:       if (exists $results{$fct}{'has_ulps'}) {
  464:         $line .= "DELTA$fct";
  465:       } else {
  466:         $line .= '0';
  467:       }
  468:       if (exists $results{$fct}{'has_fails'}) {
  469:         $line .= ", FAIL$fct";
  470:       } else {
  471:         $line .= ', 0';
  472:       }
  473:       $line .= ");\n";
  474:       print OUTPUT $line;
  475:       push @functions, $fct;
  476:       next;
  477:     }
  478:     print OUTPUT;
  479:   }
  480:   close INPUT;
  481:   close OUTPUT;
  482: }
  483: 
  484: 
  485: 
  486: # Parse ulps file
  487: sub parse_ulps {
  488:   my ($file) = @_;
  489:   my ($test, $type, $float, $eps, $kind);
  490: 
  491:   # $type has the following values:
  492:   # "normal": No complex variable
  493:   # "real": Real part of complex result
  494:   # "imag": Imaginary part of complex result
  495:   open ULP, $file  or die ("Can't open $file: $!");
  496:   while (<ULP>) {
  497:     chop;
  498:     # ignore comments and empty lines
  499:     next if /^#/;
  500:     next if /^\s*$/;
  501:     if (/^Test/) {
  502:       if (/Real part of:/) {
  503:         s/Real part of: //;
  504:         $type = 'real';
  505:       } elsif (/Imaginary part of:/) {
  506:         s/Imaginary part of: //;
  507:         $type = 'imag';
  508:       } else {
  509:         $type = 'normal';
  510:       }
  511:       s/^.+\"(.*)\".*$/$1/;
  512:       $test = $_;
  513:       $kind = 'test';
  514:       next;
  515:     }
  516:     if (/^Function: /) {
  517:       if (/Real part of/) {
  518:         s/Real part of //;
  519:         $type = 'real';
  520:       } elsif (/Imaginary part of/) {
  521:         s/Imaginary part of //;
  522:         $type = 'imag';
  523:       } else {
  524:         $type = 'normal';
  525:       }
  526:       ($test) = ($_ =~ /^Function:\s*\"([a-zA-Z0-9_]+)\"/);
  527:       $kind = 'fct';
  528:       next;
  529:     }
  530:     if (/^i?(float|double|ldouble):/) {
  531:       ($float, $eps) = split /\s*:\s*/,$_,2;
  532: 
  533:       if ($eps eq 'fail') {
  534:         $results{$test}{$type}{'fail'}{$float} = 1;
  535:         $results{$test}{'has_fails'} = 1;
  536:       } elsif ($eps eq "0") {
  537:         # ignore
  538:         next;
  539:       } else {
  540:         $results{$test}{$type}{'ulp'}{$float} = $eps;
  541:         $results{$test}{'has_ulps'} = 1;
  542:       }
  543:       if ($type =~ /^real|imag$/) {
  544:         $results{$test}{'type'} = 'complex';
  545:       } elsif ($type eq 'normal') {
  546:         $results{$test}{'type'} = 'normal';
  547:       }
  548:       $results{$test}{'kind'} = $kind;
  549:       next;
  550:     }
  551:     print "Skipping unknown entry: `$_'\n";
  552:   }
  553:   close ULP;
  554: }
  555: 
  556: 
  557: # Clean up a floating point number
  558: sub clean_up_number {
  559:   my ($number) = @_;
  560: 
  561:   # Remove trailing zeros after the decimal point
  562:   if ($number =~ /\./) {
  563:     $number =~ s/0+$//;
  564:     $number =~ s/\.$//;
  565:   }
  566:   return $number;
  567: }
  568: 
  569: # Output a file which can be read in as ulps file.
  570: sub print_ulps_file {
  571:   my ($file) = @_;
  572:   my ($test, $type, $float, $eps, $fct, $last_fct);
  573: 
  574:   $last_fct = '';
  575:   open NEWULP, ">$file" or die ("Can't open $file: $!");
  576:   print NEWULP "# Begin of automatic generation\n";
  577:   # first the function calls
  578:   foreach $test (sort keys %results) {
  579:     next if ($results{$test}{'kind'} ne 'test');
  580:     foreach $type ('real', 'imag', 'normal') {
  581:       if (exists $results{$test}{$type}) {
  582:         if (defined $results{$test}) {
  583:           ($fct) = ($test =~ /^(\w+)\s/);
  584:           if ($fct ne $last_fct) {
  585:             $last_fct = $fct;
  586:             print NEWULP "\n# $fct\n";
  587:           }
  588:         }
  589:         if ($type eq 'normal') {
  590:           print NEWULP "Test \"$test\":\n";
  591:         } elsif ($type eq 'real') {
  592:           print NEWULP "Test \"Real part of: $test\":\n";
  593:         } elsif ($type eq 'imag') {
  594:           print NEWULP "Test \"Imaginary part of: $test\":\n";
  595:         }
  596:         foreach $float (@all_floats) {
  597:           if (exists $results{$test}{$type}{'ulp'}{$float}) {
  598:             print NEWULP "$float: ",
  599:             &clean_up_number ($results{$test}{$type}{'ulp'}{$float}),
  600:             "\n";
  601:           }
  602:           if (exists $results{$test}{$type}{'fail'}{$float}) {
  603:             print NEWULP "$float: fail\n";
  604:           }
  605:         }
  606:       }
  607:     }
  608:   }
  609:   print NEWULP "\n# Maximal error of functions:\n";
  610: 
  611:   foreach $fct (sort keys %results) {
  612:     next if ($results{$fct}{'kind'} ne 'fct');
  613:     foreach $type ('real', 'imag', 'normal') {
  614:       if (exists $results{$fct}{$type}) {
  615:         if ($type eq 'normal') {
  616:           print NEWULP "Function: \"$fct\":\n";
  617:         } elsif ($type eq 'real') {
  618:           print NEWULP "Function: Real part of \"$fct\":\n";
  619:         } elsif ($type eq 'imag') {
  620:           print NEWULP "Function: Imaginary part of \"$fct\":\n";
  621:         }
  622:         foreach $float (@all_floats) {
  623:           if (exists $results{$fct}{$type}{'ulp'}{$float}) {
  624:             print NEWULP "$float: ",
  625:             &clean_up_number ($results{$fct}{$type}{'ulp'}{$float}),
  626:             "\n";
  627:           }
  628:           if (exists $results{$fct}{$type}{'fail'}{$float}) {
  629:             print NEWULP "$float: fail\n";
  630:           }
  631:         }
  632:         print NEWULP "\n";
  633:       }
  634:     }
  635:   }
  636:   print NEWULP "# end of automatic generation\n";
  637:   close NEWULP;
  638: }
  639: 
  640: sub get_ulps {
  641:   my ($test, $type, $float) = @_;
  642: 
  643:   if ($type eq 'complex') {
  644:     my ($res);
  645:     # Return 0 instead of BUILD_COMPLEX (0,0)
  646:     if (!exists $results{$test}{'real'}{'ulp'}{$float} &&
  647:         !exists $results{$test}{'imag'}{'ulp'}{$float}) {
  648:       return "0";
  649:     }
  650:     $res = 'BUILD_COMPLEX (';
  651:     $res .= (exists $results{$test}{'real'}{'ulp'}{$float}
  652:              ? $results{$test}{'real'}{'ulp'}{$float} : "0");
  653:     $res .= ', ';
  654:     $res .= (exists $results{$test}{'imag'}{'ulp'}{$float}
  655:              ? $results{$test}{'imag'}{'ulp'}{$float} : "0");
  656:     $res .= ')';
  657:     return $res;
  658:   }
  659:   return (exists $results{$test}{'normal'}{'ulp'}{$float}
  660:           ? $results{$test}{'normal'}{'ulp'}{$float} : "0");
  661: }
  662: 
  663: sub get_failure {
  664:   my ($test, $type, $float) = @_;
  665:   if ($type eq 'complex') {
  666:     # return x,y
  667:     my ($res);
  668:     # Return 0 instead of BUILD_COMPLEX_INT (0,0)
  669:     if (!exists $results{$test}{'real'}{'ulp'}{$float} &&
  670:         !exists $results{$test}{'imag'}{'ulp'}{$float}) {
  671:       return "0";
  672:     }
  673:     $res = 'BUILD_COMPLEX_INT (';
  674:     $res .= (exists $results{$test}{'real'}{'fail'}{$float}
  675:              ? $results{$test}{'real'}{'fail'}{$float} : "0");
  676:     $res .= ', ';
  677:     $res .= (exists $results{$test}{'imag'}{'fail'}{$float}
  678:              ? $results{$test}{'imag'}{'fail'}{$float} : "0");
  679:     $res .= ')';
  680:     return $res;
  681:   }
  682:   return (exists $results{$test}{'normal'}{'fail'}{$float}
  683:           ? $results{$test}{'normal'}{'fail'}{$float} : "0");
  684: 
  685: }
  686: 
  687: # Output the defines for a single test
  688: sub output_test {
  689:   my ($file, $test, $name) = @_;
  690:   my ($ldouble, $double, $float, $ildouble, $idouble, $ifloat);
  691:   my ($type);
  692: 
  693:   # Do we have ulps/failures?
  694:   if (!exists $results{$test}{'type'}) {
  695:     return;
  696:   }
  697:   $type = $results{$test}{'type'};
  698:   if (exists $results{$test}{'has_ulps'}) {
  699:     # XXX use all_floats (change order!)
  700:     $ldouble = &get_ulps ($test, $type, "ldouble");
  701:     $double = &get_ulps ($test, $type, "double");
  702:     $float = &get_ulps ($test, $type, "float");
  703:     $ildouble = &get_ulps ($test, $type, "ildouble");
  704:     $idouble = &get_ulps ($test, $type, "idouble");
  705:     $ifloat = &get_ulps ($test, $type, "ifloat");
  706:     print $file "#define DELTA$name CHOOSE($ldouble, $double, $float, $ildouble, $idouble, $ifloat)\t/* $test  */\n";
  707:   }
  708: 
  709:   if (exists $results{$test}{'has_fails'}) {
  710:     $ldouble = &get_failure ($test, "ldouble");
  711:     $double = &get_failure ($test, "double");
  712:     $float = &get_failure ($test, "float");
  713:     $ildouble = &get_failure ($test, "ildouble");
  714:     $idouble = &get_failure ($test, "idouble");
  715:     $ifloat = &get_failure ($test, "ifloat");
  716:     print $file "#define FAIL$name CHOOSE($ldouble, $double, $float $ildouble, $idouble, $ifloat)\t/* $test  */\n";
  717:   }
  718: }
  719: 
  720: # Print include file
  721: sub output_ulps {
  722:   my ($file, $ulps_filename) = @_;
  723:   my ($i, $fct);
  724: 
  725:   open ULP, ">$file" or die ("Can't open $file: $!");
  726: 
  727:   print ULP "/* This file is automatically generated\n";
  728:   print ULP "   from $ulps_filename with gen-libm-test.pl.\n";
  729:   print ULP "   Don't change it - change instead the master files.  */\n\n";
  730: 
  731:   print ULP "\n/* Maximal error of functions.  */\n";
  732:   foreach $fct (@functions) {
  733:     output_test (\*ULP, $fct, $fct);
  734:   }
  735: 
  736:   print ULP "\n/* Error of single function calls.  */\n";
  737:   for ($i = 0; $i < $count; $i++) {
  738:     output_test (\*ULP, $tests[$i], $i);
  739:   }
  740:   close ULP;
  741: }