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
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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)
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.
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.
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/>. */
30 { S_NONE, S_MINUS, S_PLUS }
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. */
37 calculate_sign (st_parameter_dt *dtp, int negative_flag)
44 switch (dtp->u.p.sign_status)
46 case SIGN_SP: /* Show sign. */
49 case SIGN_SS: /* Suppress sign. */
52 case SIGN_S: /* Processor defined. */
53 case SIGN_UNSPECIFIED:
54 s = options.optional_plus ? S_PLUS : S_NONE;
62 /* Output a real number according to its format which is FMT_G free. */
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)
75 /* Number of digits before the decimal point. */
77 /* Number of zeros after the decimal point. */
79 /* Number of digits after the decimal point. */
81 /* Number of zeros after the decimal point, whatever the precision. */
94 /* We should always know the field width and precision. */
96 internal_error (&dtp->common, "Unspecified precision");
98 sign = calculate_sign (dtp, sign_bit);
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"); */
106 /* Read the exponent back in. */
107 e = atoi (&buffer[ndigits + 3]) + 1;
109 /* Make sure zero comes out as 0.0e0. */
113 if (compile_options.sign_zero == 1)
114 sign = calculate_sign (dtp, sign_bit);
116 sign = calculate_sign (dtp, 0);
118 /* Handle special cases. */
122 /* For this one we choose to not output a decimal point.
124 if (w == 1 && ft == FMT_F)
126 out = write_block (dtp, w);
135 /* Normalize the fractional component. */
136 buffer[2] = buffer[1];
139 /* Figure out where to place the decimal point. */
143 nbefore = e + dtp->u.p.scale_factor;
163 i = dtp->u.p.scale_factor;
164 if (d <= 0 && i == 0)
166 generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
167 "greater than zero in format specifier 'E' or 'D'");
170 if (i <= -d || i >= d + 2)
172 generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
173 "out of range in format specifier 'E' or 'D'");
189 nafter = (d - i) + 1;
205 /* The exponent must be a multiple of three, with 1-3 digits before
206 the decimal point. */
215 nbefore = 3 - nbefore;
234 /* Should never happen. */
235 internal_error (&dtp->common, "Unexpected format token");
238 /* Round the value. */
239 if (nbefore + nafter == 0)
242 if (nzero_real == d && digits[0] >= '5')
244 /* We rounded to zero but shouldn't have */
251 else if (nbefore + nafter < ndigits)
253 ndigits = nbefore + nafter;
255 if (digits[i] >= '5')
257 /* Propagate the carry. */
258 for (i--; i >= 0; i--)
260 if (digits[i] != '9')
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. */
285 else if (ft == FMT_EN)
300 /* Calculate the format of the exponent field. */
304 for (i = abs (e); i >= 10; i /= 10)
309 /* Width not specified. Must be no more than 3 digits. */
310 if (e > 999 || e < -999)
315 if (e > 99 || e < -99)
321 /* Exponent width specified, check it is wide enough. */
322 if (edigits > f->u.real.e)
325 edigits = f->u.real.e + 2;
331 /* Zero values always output as positive, even if the value was negative
333 for (i = 0; i < ndigits; i++)
335 if (digits[i] != '0')
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);
345 sign = calculate_sign (dtp, 0);
348 /* Pick a field size if none was specified. */
350 w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
352 /* Work out how much padding is needed. */
353 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
357 if (dtp->u.p.g0_no_blanks)
363 /* Create the ouput buffer. */
364 out = write_block (dtp, w);
368 /* Check the value fits in the specified field width. */
369 if (nblanks < 0 || edigits == -1)
375 /* See if we have space for a zero before the decimal point. */
376 if (nbefore == 0 && nblanks > 0)
384 /* Pad to full field width. */
386 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
388 memset (out, ' ', nblanks);
392 /* Output the initial sign (if any). */
395 else if (sign == S_MINUS)
398 /* Output an optional leading zero. */
402 /* Output the part before the decimal point, padding with zeros. */
405 if (nbefore > ndigits)
408 memcpy (out, digits, i);
416 memcpy (out, digits, i);
424 /* Output the decimal point. */
425 *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
427 /* Output leading zeros after the decimal point. */
430 for (i = 0; i < nzero; i++)
434 /* Output digits after the decimal point, padding with zeros. */
437 if (nafter > ndigits)
442 memcpy (out, digits, i);
451 /* Output the exponent. */
460 snprintf (buffer, size, "%+0*d", edigits, e);
462 sprintf (buffer, "%+0*d", edigits, e);
464 memcpy (out, buffer, edigits);
467 if (dtp->u.p.no_leading_blank)
470 memset( out , ' ' , nblanks );
471 dtp->u.p.no_leading_blank = 0;
476 #undef MIN_FIELD_WIDTH
480 /* Write "Infinite" or "Nan" as appropriate for the given format. */
483 write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
488 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
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' */
496 p = write_block (dtp, nb);
511 /* If the sign is negative and the width is 3, there is
512 insufficient room to output '-Inf', so output asterisks */
520 /* The negative sign is mandatory */
526 /* The positive sign is optional, but we output it for
532 /* We have room, so output 'Infinity' */
533 memcpy(p + nb - 8, "Infinity", 8);
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);
540 if (nb < 9 && nb > 3)
541 p[nb - 4] = fin; /* Put the sign in front of Inf */
543 p[nb - 9] = fin; /* Put the sign in front of Infinity */
546 memcpy(p + nb - 3, "NaN", 3);
552 /* Returns the value of 10**d. */
554 #define CALCULATE_EXP(x) \
555 inline static GFC_REAL_ ## x \
556 calculate_exp_ ## x (int d)\
559 GFC_REAL_ ## x r = 1.0;\
560 for (i = 0; i< (d >= 0 ? d : -d); i++)\
562 r = (d >= 0) ? r : 1.0 / r;\
570 #ifdef HAVE_GFC_REAL_10
574 #ifdef HAVE_GFC_REAL_16
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:
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]
593 notes: for Gw.d , n' ' means 4 blanks
594 for Gw.dEe, n' ' means e+2 blanks */
596 #define OUTPUT_FLOAT_FMT_G(x) \
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) \
602 int e = f->u.real.e;\
603 int d = f->u.real.d;\
604 int w = f->u.real.w;\
606 GFC_REAL_ ## x rexp_d;\
610 int save_scale_factor, nb = 0;\
612 save_scale_factor = dtp->u.p.scale_factor;\
613 newf = (fnode *) get_mem (sizeof (fnode));\
615 rexp_d = calculate_exp_ ## x (-d);\
616 if ((m > 0.0 && m < 0.1 - 0.05 * rexp_d) || (rexp_d * (m + 0.5) >= 1.0) ||\
617 ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
619 newf->format = FMT_E;\
635 GFC_REAL_ ## x temp;\
636 mid = (low + high) / 2;\
638 temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\
643 if (ubound == lbound + 1)\
650 if (ubound == lbound + 1)\
669 newf->format = FMT_F;\
670 newf->u.real.w = f->u.real.w - nb;\
673 newf->u.real.d = d - 1;\
675 newf->u.real.d = - (mid - d - 1);\
677 dtp->u.p.scale_factor = 0;\
680 output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
682 dtp->u.p.scale_factor = save_scale_factor;\
686 if (nb > 0 && !dtp->u.p.g0_no_blanks)\
688 p = write_block (dtp, nb);\
691 memset (p, ' ', nb);\
695 OUTPUT_FLOAT_FMT_G(4)
697 OUTPUT_FLOAT_FMT_G(8)
699 #ifdef HAVE_GFC_REAL_10
700 OUTPUT_FLOAT_FMT_G(10)
703 #ifdef HAVE_GFC_REAL_16
704 OUTPUT_FLOAT_FMT_G(16)
707 #undef OUTPUT_FLOAT_FMT_G
710 /* Define a macro to build code for write_float. */
712 /* Note: Before output_float is called, sprintf is used to print to buffer the
713 number in the format +D.DDDDe+ddd. For an N digit exponent, this gives us
714 (MIN_FIELD_WIDTH-5)-N digits after the decimal point, plus another one
715 before the decimal point.
717 # The result will always contain a decimal point, even if no
720 - The converted value is to be left adjusted on the field boundary
722 + A sign (+ or -) always be placed before a number
724 MIN_FIELD_WIDTH minimum field width
726 * (ndigits-1) is used as the precision
728 e format: [-]d.ddde±dd where there is one digit before the
729 decimal-point character and the number of digits after it is
730 equal to the precision. The exponent always contains at least two
731 digits; if the value is zero, the exponent is 00. */
736 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
737 "e", ndigits - 1, tmp);
740 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
741 "Le", ndigits - 1, tmp);
746 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
747 "e", ndigits - 1, tmp);
750 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
751 "Le", ndigits - 1, tmp);
755 #define WRITE_FLOAT(x,y)\
758 tmp = * (GFC_REAL_ ## x *)source;\
759 sign_bit = signbit (tmp);\
760 if (!isfinite (tmp))\
762 write_infnan (dtp, f, isnan (tmp), sign_bit);\
765 tmp = sign_bit ? -tmp : tmp;\
766 if (f->u.real.d == 0 && f->format == FMT_F\
767 && dtp->u.p.scale_factor == 0)\
774 zero_flag = (tmp == 0.0);\
778 if (f->format != FMT_G)\
779 output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
782 output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
783 zero_flag, ndigits, edigits);\
786 /* Output a real number according to its format. */
789 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
792 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
793 # define MIN_FIELD_WIDTH 46
795 # define MIN_FIELD_WIDTH 31
797 #define STR(x) STR1(x)
800 /* This must be large enough to accurately hold any value. */
801 char buffer[MIN_FIELD_WIDTH+1];
802 int sign_bit, ndigits, edigits;
806 size = MIN_FIELD_WIDTH+1;
808 /* printf pads blanks for us on the exponent so we just need it big enough
809 to handle the largest number of exponent digits expected. */
812 if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G
813 || ((f->format == FMT_D || f->format == FMT_E)
814 && dtp->u.p.scale_factor != 0))
816 /* Always convert at full precision to avoid double rounding. */
817 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
821 /* The number of digits is known, so let printf do the rounding. */
822 if (f->format == FMT_ES)
823 ndigits = f->u.real.d + 1;
825 ndigits = f->u.real.d;
826 if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
827 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
840 #ifdef HAVE_GFC_REAL_10
845 #ifdef HAVE_GFC_REAL_16
851 internal_error (NULL, "bad real kind");