libgfortran/io/write_float.def

   1 /* Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    Write float code factoring to this file by Jerry DeLisle
   4    F2003 I/O support contributed by Jerry DeLisle
   5
   6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 Libgfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "config.h"
  28
  29 typedef enum
  30 { S_NONE, S_MINUS, S_PLUS }
  31 sign_t;
  32
  33 /* Given a flag that indicates if a value is negative or not, return a
  34    sign_t that gives the sign that we need to produce.  */
  35
  36 static sign_t
  37 calculate_sign (st_parameter_dt *dtp, int negative_flag)
  38 {
  39   sign_t s = S_NONE;
  40
  41   if (negative_flag)
  42     s = S_MINUS;
  43   else
  44     switch (dtp->u.p.sign_status)
  45       {
  46       case SIGN_SP:     /* Show sign. */
  47         s = S_PLUS;
  48         break;
  49       case SIGN_SS:     /* Suppress sign. */
  50         s = S_NONE;
  51         break;
  52       case SIGN_S:      /* Processor defined. */
  53       case SIGN_UNSPECIFIED:
  54         s = options.optional_plus ? S_PLUS : S_NONE;
  55         break;
  56       }
  57
  58   return s;
  59 }
  60
  61
  62 /* Output a real number according to its format which is FMT_G free.  */
  63
  64 static void
  65 output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
  66               int sign_bit, bool zero_flag, int ndigits, int edigits)
  67 {
  68   char *out;
  69   char *digits;
  70   int e;
  71   char expchar;
  72   format_token ft;
  73   int w;
  74   int d;
  75   /* Number of digits before the decimal point.  */
  76   int nbefore;
  77   /* Number of zeros after the decimal point.  */
  78   int nzero;
  79   /* Number of digits after the decimal point.  */
  80   int nafter;
  81   /* Number of zeros after the decimal point, whatever the precision.  */
  82   int nzero_real;
  83   int leadzero;
  84   int nblanks;
  85   int i;
  86   sign_t sign;
  87
  88   ft = f->format;
  89   w = f->u.real.w;
  90   d = f->u.real.d;
  91
  92   nzero_real = -1;
  93
  94   /* We should always know the field width and precision.  */
  95   if (d < 0)
  96     internal_error (&dtp->common, "Unspecified precision");
  97
  98   sign = calculate_sign (dtp, sign_bit);
  99
 100   /* The following code checks the given string has punctuation in the correct
 101      places.  Uncomment if needed for debugging.
 102      if (d != 0 && ((buffer[2] != '.' && buffer[2] != ',')
 103                     || buffer[ndigits + 2] != 'e'))
 104        internal_error (&dtp->common, "printf is broken");  */
 105
 106   /* Read the exponent back in.  */
 107   e = atoi (&buffer[ndigits + 3]) + 1;
 108
 109   /* Make sure zero comes out as 0.0e0.   */
 110   if (zero_flag)
 111     {
 112       e = 0;
 113       if (compile_options.sign_zero == 1)
 114         sign = calculate_sign (dtp, sign_bit);
 115       else
 116         sign = calculate_sign (dtp, 0);
 117
 118       /* Handle special cases.  */
 119       if (w == 0)
 120         w = d + 2;
 121
 122       /* For this one we choose to not output a decimal point.
 123          F95 10.5.1.2.1  */
 124       if (w == 1 && ft == FMT_F)
 125         {
 126           out = write_block (dtp, w);
 127           if (out == NULL)
 128             return;
 129           *out = '0';
 130           return;
 131         }
 132
 133     }
 134
 135   /* Normalize the fractional component.  */
 136   buffer[2] = buffer[1];
 137   digits = &buffer[2];
 138
 139   /* Figure out where to place the decimal point.  */
 140   switch (ft)
 141     {
 142     case FMT_F:
 143       nbefore = e + dtp->u.p.scale_factor;
 144       if (nbefore < 0)
 145         {
 146           nzero = -nbefore;
 147           nzero_real = nzero;
 148           if (nzero > d)
 149             nzero = d;
 150           nafter = d - nzero;
 151           nbefore = 0;
 152         }
 153       else
 154         {
 155           nzero = 0;
 156           nafter = d;
 157         }
 158       expchar = 0;
 159       break;
 160
 161     case FMT_E:
 162     case FMT_D:
 163       i = dtp->u.p.scale_factor;
 164       if (d <= 0 && i == 0)
 165         {
 166           generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
 167                           "greater than zero in format specifier 'E' or 'D'");
 168           return;
 169         }
 170       if (i <= -d || i >= d + 2)
 171         {
 172           generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
 173                           "out of range in format specifier 'E' or 'D'");
 174           return;
 175         }
 176
 177       if (!zero_flag)
 178         e -= i;
 179       if (i < 0)
 180         {
 181           nbefore = 0;
 182           nzero = -i;
 183           nafter = d + i;
 184         }
 185       else if (i > 0)
 186         {
 187           nbefore = i;
 188           nzero = 0;
 189           nafter = (d - i) + 1;
 190         }
 191       else /* i == 0 */
 192         {
 193           nbefore = 0;
 194           nzero = 0;
 195           nafter = d;
 196         }
 197
 198       if (ft == FMT_E)
 199         expchar = 'E';
 200       else
 201         expchar = 'D';
 202       break;
 203
 204     case FMT_EN:
 205       /* The exponent must be a multiple of three, with 1-3 digits before
 206          the decimal point.  */
 207       if (!zero_flag)
 208         e--;
 209       if (e >= 0)
 210         nbefore = e % 3;
 211       else
 212         {
 213           nbefore = (-e) % 3;
 214           if (nbefore != 0)
 215             nbefore = 3 - nbefore;
 216         }
 217       e -= nbefore;
 218       nbefore++;
 219       nzero = 0;
 220       nafter = d;
 221       expchar = 'E';
 222       break;
 223
 224     case FMT_ES:
 225       if (!zero_flag)
 226         e--;
 227       nbefore = 1;
 228       nzero = 0;
 229       nafter = d;
 230       expchar = 'E';
 231       break;
 232
 233     default:
 234       /* Should never happen.  */
 235       internal_error (&dtp->common, "Unexpected format token");
 236     }
 237
 238   /* Round the value.  */
 239   if (nbefore + nafter == 0)
 240     {
 241       ndigits = 0;
 242       if (nzero_real == d && digits[0] >= '5')
 243         {
 244           /* We rounded to zero but shouldn't have */
 245           nzero--;
 246           nafter = 1;
 247           digits[0] = '1';
 248           ndigits = 1;
 249         }
 250     }
 251   else if (nbefore + nafter < ndigits)
 252     {
 253       ndigits = nbefore + nafter;
 254       i = ndigits;
 255       if (digits[i] >= '5')
 256         {
 257           /* Propagate the carry.  */
 258           for (i--; i >= 0; i--)
 259             {
 260               if (digits[i] != '9')
 261                 {
 262                   digits[i]++;
 263                   break;
 264                 }
 265               digits[i] = '0';
 266             }
 267
 268           if (i < 0)
 269             {
 270               /* The carry overflowed.  Fortunately we have some spare space
 271                  at the start of the buffer.  We may discard some digits, but
 272                  this is ok because we already know they are zero.  */
 273               digits--;
 274               digits[0] = '1';
 275               if (ft == FMT_F)
 276                 {
 277                   if (nzero > 0)
 278                     {
 279                       nzero--;
 280                       nafter++;
 281                     }
 282                   else
 283                     nbefore++;
 284                 }
 285               else if (ft == FMT_EN)
 286                 {
 287                   nbefore++;
 288                   if (nbefore == 4)
 289                     {
 290                       nbefore = 1;
 291                       e += 3;
 292                     }
 293                 }
 294               else
 295                 e++;
 296             }
 297         }
 298     }
 299
 300   /* Calculate the format of the exponent field.  */
 301   if (expchar)
 302     {
 303       edigits = 1;
 304       for (i = abs (e); i >= 10; i /= 10)
 305         edigits++;
 306
 307       if (f->u.real.e < 0)
 308         {
 309           /* Width not specified.  Must be no more than 3 digits.  */
 310           if (e > 999 || e < -999)
 311             edigits = -1;
 312           else
 313             {
 314               edigits = 4;
 315               if (e > 99 || e < -99)
 316                 expchar = ' ';
 317             }
 318         }
 319       else
 320         {
 321           /* Exponent width specified, check it is wide enough.  */
 322           if (edigits > f->u.real.e)
 323             edigits = -1;
 324           else
 325             edigits = f->u.real.e + 2;
 326         }
 327     }
 328   else
 329     edigits = 0;
 330
 331   /* Zero values always output as positive, even if the value was negative
 332      before rounding.  */
 333   for (i = 0; i < ndigits; i++)
 334     {
 335       if (digits[i] != '0')
 336         break;
 337     }
 338   if (i == ndigits)
 339     {
 340       /* The output is zero, so set the sign according to the sign bit unless
 341          -fno-sign-zero was specified.  */
 342       if (compile_options.sign_zero == 1)
 343         sign = calculate_sign (dtp, sign_bit);
 344       else
 345         sign = calculate_sign (dtp, 0);
 346     }
 347
 348   /* Pick a field size if none was specified.  */
 349   if (w <= 0)
 350     w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
 351
 352   /* Work out how much padding is needed.  */
 353   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
 354   if (sign != S_NONE)
 355     nblanks--;
 356
 357   if (dtp->u.p.g0_no_blanks)
 358     {
 359       w -= nblanks;
 360       nblanks = 0;
 361     }
 362
 363   /* Create the ouput buffer.  */
 364   out = write_block (dtp, w);
 365   if (out == NULL)
 366     return;
 367
 368   /* Check the value fits in the specified field width.  */
 369   if (nblanks < 0 || edigits == -1)
 370     {
 371       star_fill (out, w);
 372       return;
 373     }
 374
 375   /* See if we have space for a zero before the decimal point.  */
 376   if (nbefore == 0 && nblanks > 0)
 377     {
 378       leadzero = 1;
 379       nblanks--;
 380     }
 381   else
 382     leadzero = 0;
 383
 384   /* Pad to full field width.  */
 385
 386   if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
 387     {
 388       memset (out, ' ', nblanks);
 389       out += nblanks;
 390     }
 391
 392   /* Output the initial sign (if any).  */
 393   if (sign == S_PLUS)
 394     *(out++) = '+';
 395   else if (sign == S_MINUS)
 396     *(out++) = '-';
 397
 398   /* Output an optional leading zero.  */
 399   if (leadzero)
 400     *(out++) = '0';
 401
 402   /* Output the part before the decimal point, padding with zeros.  */
 403   if (nbefore > 0)
 404     {
 405       if (nbefore > ndigits)
 406         {
 407           i = ndigits;
 408           memcpy (out, digits, i);
 409           ndigits = 0;
 410           while (i < nbefore)
 411             out[i++] = '0';
 412         }
 413       else
 414         {
 415           i = nbefore;
 416           memcpy (out, digits, i);
 417           ndigits -= i;
 418         }
 419
 420       digits += i;
 421       out += nbefore;
 422     }
 423
 424   /* Output the decimal point.  */
 425   *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
 426
 427   /* Output leading zeros after the decimal point.  */
 428   if (nzero > 0)
 429     {
 430       for (i = 0; i < nzero; i++)
 431         *(out++) = '0';
 432     }
 433
 434   /* Output digits after the decimal point, padding with zeros.  */
 435   if (nafter > 0)
 436     {
 437       if (nafter > ndigits)
 438         i = ndigits;
 439       else
 440         i = nafter;
 441
 442       memcpy (out, digits, i);
 443       while (i < nafter)
 444         out[i++] = '0';
 445
 446       digits += i;
 447       ndigits -= i;
 448       out += nafter;
 449     }
 450
 451   /* Output the exponent.  */
 452   if (expchar)
 453     {
 454       if (expchar != ' ')
 455         {
 456           *(out++) = expchar;
 457           edigits--;
 458         }
 459 #if HAVE_SNPRINTF
 460       snprintf (buffer, size, "%+0*d", edigits, e);
 461 #else
 462       sprintf (buffer, "%+0*d", edigits, e);
 463 #endif
 464       memcpy (out, buffer, edigits);
 465     }
 466
 467   if (dtp->u.p.no_leading_blank)
 468     {
 469       out += edigits;
 470       memset( out , ' ' , nblanks );
 471       dtp->u.p.no_leading_blank = 0;
 472     }
 473
 474 #undef STR
 475 #undef STR1
 476 #undef MIN_FIELD_WIDTH
 477 }
 478
 479
 480 /* Write "Infinite" or "Nan" as appropriate for the given format.  */
 481
 482 static void
 483 write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
 484 {
 485   char * p, fin;
 486   int nb = 0;
 487
 488   if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
 489     {
 490           nb =  f->u.real.w;
 491
 492           /* If the field width is zero, the processor must select a width
 493              not zero.  4 is chosen to allow output of '-Inf' or '+Inf' */
 494
 495           if (nb == 0) nb = 4;
 496           p = write_block (dtp, nb);
 497           if (p == NULL)
 498             return;
 499           if (nb < 3)
 500             {
 501               memset (p, '*',nb);
 502               return;
 503             }
 504
 505           memset(p, ' ', nb);
 506           if (!isnan_flag)
 507             {
 508               if (sign_bit)
 509                 {
 510
 511                   /* If the sign is negative and the width is 3, there is
 512                      insufficient room to output '-Inf', so output asterisks */
 513
 514                   if (nb == 3)
 515                     {
 516                       memset (p, '*',nb);
 517                       return;
 518                     }
 519
 520                   /* The negative sign is mandatory */
 521
 522                   fin = '-';
 523                 }
 524               else
 525
 526                   /* The positive sign is optional, but we output it for
 527                      consistency */
 528                   fin = '+';
 529
 530               if (nb > 8)
 531
 532                 /* We have room, so output 'Infinity' */
 533                 memcpy(p + nb - 8, "Infinity", 8);
 534               else
 535
 536                 /* For the case of width equals 8, there is not enough room
 537                    for the sign and 'Infinity' so we go with 'Inf' */
 538                 memcpy(p + nb - 3, "Inf", 3);
 539
 540               if (nb < 9 && nb > 3)
 541                 p[nb - 4] = fin;  /* Put the sign in front of Inf */
 542               else if (nb > 8)
 543                 p[nb - 9] = fin;  /* Put the sign in front of Infinity */
 544             }
 545           else
 546             memcpy(p + nb - 3, "NaN", 3);
 547           return;
 548         }
 549     }
 550
 551
 552 /* Returns the value of 10**d.  */
 553
 554 #define CALCULATE_EXP(x) \
 555 inline static GFC_REAL_ ## x \
 556 calculate_exp_ ## x  (int d)\
 557 {\
 558   int i;\
 559   GFC_REAL_ ## x r = 1.0;\
 560   for (i = 0; i< (d >= 0 ? d : -d); i++)\
 561     r *= 10;\
 562   r = (d >= 0) ? r : 1.0 / r;\
 563   return r;\
 564 }
 565
 566 CALCULATE_EXP(4)
 567
 568 CALCULATE_EXP(8)
 569
 570 #ifdef HAVE_GFC_REAL_10
 571 CALCULATE_EXP(10)
 572 #endif
 573
 574 #ifdef HAVE_GFC_REAL_16
 575 CALCULATE_EXP(16)
 576 #endif
 577 #undef CALCULATE_EXP
 578
 579 /* Generate corresponding I/O format for FMT_G and output.
 580    The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
 581    LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
 582
 583    Data Magnitude                              Equivalent Conversion
 584    0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
 585    m = 0                                       F(w-n).(d-1), n' '
 586    0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
 587    1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
 588    10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
 589    ................                           ..........
 590    10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
 591    m >= 10**d-0.5                              Ew.d[Ee]
 592
 593    notes: for Gw.d ,  n' ' means 4 blanks
 594           for Gw.dEe, n' ' means e+2 blanks  */
 595
 596 #define OUTPUT_FLOAT_FMT_G(x) \
 597 static void \
 598 output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
 599                       GFC_REAL_ ## x m, char *buffer, size_t size, \
 600                       int sign_bit, bool zero_flag, int ndigits, int edigits) \
 601 { \
 602   int e = f->u.real.e;\
 603   int d = f->u.real.d;\
 604   int w = f->u.real.w;\
 605   fnode *newf;\
 606   GFC_REAL_ ## x exp_d;\
 607   int low, high, mid;\
 608   int ubound, lbound;\
 609   char *p;\
 610   int save_scale_factor, nb = 0;\
 611 \
 612   save_scale_factor = dtp->u.p.scale_factor;\
 613   newf = (fnode *) get_mem (sizeof (fnode));\
 614 \
 615   exp_d = calculate_exp_ ## x (d);\
 616   if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\
 617       ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
 618     { \
 619       newf->format = FMT_E;\
 620       newf->u.real.w = w;\
 621       newf->u.real.d = d;\
 622       newf->u.real.e = e;\
 623       nb = 0;\
 624       goto finish;\
 625     }\
 626 \
 627   mid = 0;\
 628   low = 0;\
 629   high = d + 1;\
 630   lbound = 0;\
 631   ubound = d + 1;\
 632 \
 633   while (low <= high)\
 634     { \
 635       GFC_REAL_ ## x temp;\
 636       mid = (low + high) / 2;\
 637 \
 638       temp = (calculate_exp_ ## x (mid) - \
 639               5 * calculate_exp_ ## x (mid - d - 1)) / 10;\
 640 \
 641       if (m < temp)\
 642         { \
 643           ubound = mid;\
 644           if (ubound == lbound + 1)\
 645             break;\
 646           high = mid - 1;\
 647         }\
 648       else if (m > temp)\
 649         { \
 650           lbound = mid;\
 651           if (ubound == lbound + 1)\
 652             { \
 653               mid ++;\
 654               break;\
 655             }\
 656           low = mid + 1;\
 657         }\
 658       else\
 659         {\
 660           mid++;\
 661           break;\
 662         }\
 663     }\
 664 \
 665   if (e < 0)\
 666     nb = 4;\
 667   else\
 668     nb = e + 2;\
 669 \
 670   newf->format = FMT_F;\
 671   newf->u.real.w = f->u.real.w - nb;\
 672 \
 673   if (m == 0.0)\
 674     newf->u.real.d = d - 1;\
 675   else\
 676     newf->u.real.d = - (mid - d - 1);\
 677 \
 678   dtp->u.p.scale_factor = 0;\
 679 \
 680  finish:\
 681   output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
 682                 edigits);\
 683   dtp->u.p.scale_factor = save_scale_factor;\
 684 \
 685   free_mem(newf);\
 686 \
 687   if (nb > 0 && !dtp->u.p.g0_no_blanks)\
 688     { \
 689       p = write_block (dtp, nb);\
 690       if (p == NULL)\
 691         return;\
 692       memset (p, ' ', nb);\
 693     }\
 694 }\
 695
 696 OUTPUT_FLOAT_FMT_G(4)
 697
 698 OUTPUT_FLOAT_FMT_G(8)
 699
 700 #ifdef HAVE_GFC_REAL_10
 701 OUTPUT_FLOAT_FMT_G(10)
 702 #endif
 703
 704 #ifdef HAVE_GFC_REAL_16
 705 OUTPUT_FLOAT_FMT_G(16)
 706 #endif
 707
 708 #undef OUTPUT_FLOAT_FMT_G
 709
 710
 711 /* Define a macro to build code for write_float.  */
 712
 713   /* Note: Before output_float is called, sprintf is used to print to buffer the
 714      number in the format +D.DDDDe+ddd. For an N digit exponent, this gives us
 715      (MIN_FIELD_WIDTH-5)-N digits after the decimal point, plus another one
 716      before the decimal point.
 717
 718      #   The result will always contain a decimal point, even if no
 719          digits follow it
 720
 721      -   The converted value is to be left adjusted on the field boundary
 722
 723      +   A sign (+ or -) always be placed before a number
 724
 725      MIN_FIELD_WIDTH  minimum field width
 726
 727      *   (ndigits-1) is used as the precision
 728
 729      e format: [-]d.dddeÂ±dd where there is one digit before the
 730        decimal-point character and the number of digits after it is
 731        equal to the precision. The exponent always contains at least two
 732        digits; if the value is zero, the exponent is 00.  */
 733
 734 #ifdef HAVE_SNPRINTF
 735
 736 #define DTOA \
 737 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
 738           "e", ndigits - 1, tmp);
 739
 740 #define DTOAL \
 741 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
 742           "Le", ndigits - 1, tmp);
 743
 744 #else
 745
 746 #define DTOA \
 747 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
 748          "e", ndigits - 1, tmp);
 749
 750 #define DTOAL \
 751 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
 752          "Le", ndigits - 1, tmp);
 753
 754 #endif
 755
 756 #define WRITE_FLOAT(x,y)\
 757 {\
 758         GFC_REAL_ ## x tmp;\
 759         tmp = * (GFC_REAL_ ## x *)source;\
 760         sign_bit = signbit (tmp);\
 761         if (!isfinite (tmp))\
 762           { \
 763             write_infnan (dtp, f, isnan (tmp), sign_bit);\
 764             return;\
 765           }\
 766         tmp = sign_bit ? -tmp : tmp;\
 767         if (f->u.real.d == 0 && f->format == FMT_F\
 768             && dtp->u.p.scale_factor == 0)\
 769           {\
 770             if (tmp < 0.5)\
 771               tmp = 0.0;\
 772             else if (tmp < 1.0)\
 773               tmp = 1.0;\
 774           }\
 775         zero_flag = (tmp == 0.0);\
 776 \
 777         DTOA ## y\
 778 \
 779         if (f->format != FMT_G)\
 780           output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
 781                         edigits);\
 782         else \
 783           output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
 784                                     zero_flag, ndigits, edigits);\
 785 }\
 786
 787 /* Output a real number according to its format.  */
 788
 789 static void
 790 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 791 {
 792
 793 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
 794 # define MIN_FIELD_WIDTH 46
 795 #else
 796 # define MIN_FIELD_WIDTH 31
 797 #endif
 798 #define STR(x) STR1(x)
 799 #define STR1(x) #x
 800
 801   /* This must be large enough to accurately hold any value.  */
 802   char buffer[MIN_FIELD_WIDTH+1];
 803   int sign_bit, ndigits, edigits;
 804   bool zero_flag;
 805   size_t size;
 806
 807   size = MIN_FIELD_WIDTH+1;
 808
 809   /* printf pads blanks for us on the exponent so we just need it big enough
 810      to handle the largest number of exponent digits expected.  */
 811   edigits=4;
 812
 813   if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G
 814       || ((f->format == FMT_D || f->format == FMT_E)
 815       && dtp->u.p.scale_factor != 0))
 816     {
 817       /* Always convert at full precision to avoid double rounding.  */
 818       ndigits = MIN_FIELD_WIDTH - 4 - edigits;
 819     }
 820   else
 821     {
 822       /* The number of digits is known, so let printf do the rounding.  */
 823       if (f->format == FMT_ES)
 824         ndigits = f->u.real.d + 1;
 825       else
 826         ndigits = f->u.real.d;
 827       if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
 828         ndigits = MIN_FIELD_WIDTH - 4 - edigits;
 829     }
 830
 831   switch (len)
 832     {
 833     case 4:
 834       WRITE_FLOAT(4,)
 835       break;
 836
 837     case 8:
 838       WRITE_FLOAT(8,)
 839       break;
 840
 841 #ifdef HAVE_GFC_REAL_10
 842     case 10:
 843       WRITE_FLOAT(10,L)
 844       break;
 845 #endif
 846 #ifdef HAVE_GFC_REAL_16
 847     case 16:
 848       WRITE_FLOAT(16,L)
 849       break;
 850 #endif
 851     default:
 852       internal_error (NULL, "bad real kind");
 853     }
 854 }