1 /* Copyright (C) 2007, 2008, 2009, 2010, 2011 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 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. */
95 /* We should always know the field width and precision. */
97 internal_error (&dtp->common, "Unspecified precision");
99 sign = calculate_sign (dtp, sign_bit);
101 /* The following code checks the given string has punctuation in the correct
102 places. Uncomment if needed for debugging.
103 if (d != 0 && ((buffer[2] != '.' && buffer[2] != ',')
104 || buffer[ndigits + 2] != 'e'))
105 internal_error (&dtp->common, "printf is broken"); */
107 /* Read the exponent back in. */
108 e = atoi (&buffer[ndigits + 3]) + 1;
110 /* Make sure zero comes out as 0.0e0. */
114 /* Normalize the fractional component. */
115 buffer[2] = buffer[1];
118 /* Figure out where to place the decimal point. */
122 if (d == 0 && e <= 0 && dtp->u.p.scale_factor == 0)
124 memmove (digits + 1, digits, ndigits - 1);
129 nbefore = e + dtp->u.p.scale_factor;
149 i = dtp->u.p.scale_factor;
150 if (d <= 0 && i == 0)
152 generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
153 "greater than zero in format specifier 'E' or 'D'");
156 if (i <= -d || i >= d + 2)
158 generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
159 "out of range in format specifier 'E' or 'D'");
175 nafter = (d - i) + 1;
191 /* The exponent must be a multiple of three, with 1-3 digits before
192 the decimal point. */
201 nbefore = 3 - nbefore;
220 /* Should never happen. */
221 internal_error (&dtp->common, "Unexpected format token");
226 /* Round the value. The value being rounded is an unsigned magnitude.
227 The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
228 switch (dtp->u.p.current_unit->round_status)
230 case ROUND_ZERO: /* Do nothing and truncation occurs. */
243 /* Round compatible unless there is a tie. A tie is a 5 with
244 all trailing zero's. */
245 i = nafter + nbefore;
246 if (digits[i] == '5')
248 for(i++ ; i < ndigits; i++)
250 if (digits[i] != '0')
253 /* It is a tie so round to even. */
254 switch (digits[nafter + nbefore - 1])
261 /* If odd, round away from zero to even. */
264 /* If even, skip rounding, truncate to even. */
269 case ROUND_PROCDEFINED:
270 case ROUND_UNSPECIFIED:
271 case ROUND_COMPATIBLE:
273 /* Just fall through and do the actual rounding. */
278 if (nbefore + nafter == 0)
281 if (nzero_real == d && digits[0] >= rchar)
283 /* We rounded to zero but shouldn't have */
290 else if (nbefore + nafter < ndigits)
292 i = ndigits = nbefore + nafter;
293 if (d == 0 && digits[1] == '0')
295 if (digits[i] >= rchar)
297 /* Propagate the carry. */
298 for (i--; i >= 0; i--)
300 if (digits[i] != '9')
310 /* The carry overflowed. Fortunately we have some spare
311 space at the start of the buffer. We may discard some
312 digits, but this is ok because we already know they are
326 else if (ft == FMT_EN)
343 /* Calculate the format of the exponent field. */
347 for (i = abs (e); i >= 10; i /= 10)
352 /* Width not specified. Must be no more than 3 digits. */
353 if (e > 999 || e < -999)
358 if (e > 99 || e < -99)
364 /* Exponent width specified, check it is wide enough. */
365 if (edigits > f->u.real.e)
368 edigits = f->u.real.e + 2;
374 /* Scan the digits string and count the number of zeros. If we make it
375 all the way through the loop, we know the value is zero after the
376 rounding completed above. */
377 for (i = 0; i < ndigits; i++)
379 if (digits[i] != '0')
383 /* To format properly, we need to know if the rounded result is zero and if
384 so, we set the zero_flag which may have been already set for
389 /* The output is zero, so set the sign according to the sign bit unless
390 -fno-sign-zero was specified. */
391 if (compile_options.sign_zero == 1)
392 sign = calculate_sign (dtp, sign_bit);
394 sign = calculate_sign (dtp, 0);
397 /* Pick a field size if none was specified, taking into account small
398 values that may have been rounded to zero. */
402 w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0);
405 w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
410 /* Work out how much padding is needed. */
411 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
415 if (dtp->u.p.g0_no_blanks)
421 /* Create the ouput buffer. */
422 out = write_block (dtp, w);
426 /* Check the value fits in the specified field width. */
427 if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE))
429 if (unlikely (is_char4_unit (dtp)))
431 gfc_char4_t *out4 = (gfc_char4_t *) out;
432 memset4 (out4, '*', w);
439 /* See if we have space for a zero before the decimal point. */
440 if (nbefore == 0 && nblanks > 0)
448 /* For internal character(kind=4) units, we duplicate the code used for
449 regular output slightly modified. This needs to be maintained
450 consistent with the regular code that follows this block. */
451 if (unlikely (is_char4_unit (dtp)))
453 gfc_char4_t *out4 = (gfc_char4_t *) out;
454 /* Pad to full field width. */
456 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
458 memset4 (out4, ' ', nblanks);
462 /* Output the initial sign (if any). */
465 else if (sign == S_MINUS)
468 /* Output an optional leading zero. */
472 /* Output the part before the decimal point, padding with zeros. */
475 if (nbefore > ndigits)
478 memcpy4 (out4, digits, i);
486 memcpy4 (out4, digits, i);
494 /* Output the decimal point. */
495 *(out4++) = dtp->u.p.current_unit->decimal_status
496 == DECIMAL_POINT ? '.' : ',';
498 /* Output leading zeros after the decimal point. */
501 for (i = 0; i < nzero; i++)
505 /* Output digits after the decimal point, padding with zeros. */
508 if (nafter > ndigits)
513 memcpy4 (out4, digits, i);
522 /* Output the exponent. */
530 snprintf (buffer, size, "%+0*d", edigits, e);
531 memcpy4 (out4, buffer, edigits);
534 if (dtp->u.p.no_leading_blank)
537 memset4 (out4, ' ' , nblanks);
538 dtp->u.p.no_leading_blank = 0;
541 } /* End of character(kind=4) internal unit code. */
543 /* Pad to full field width. */
545 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
547 memset (out, ' ', nblanks);
551 /* Output the initial sign (if any). */
554 else if (sign == S_MINUS)
557 /* Output an optional leading zero. */
561 /* Output the part before the decimal point, padding with zeros. */
564 if (nbefore > ndigits)
567 memcpy (out, digits, i);
575 memcpy (out, digits, i);
583 /* Output the decimal point. */
584 *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
586 /* Output leading zeros after the decimal point. */
589 for (i = 0; i < nzero; i++)
593 /* Output digits after the decimal point, padding with zeros. */
596 if (nafter > ndigits)
601 memcpy (out, digits, i);
610 /* Output the exponent. */
618 snprintf (buffer, size, "%+0*d", edigits, e);
619 memcpy (out, buffer, edigits);
622 if (dtp->u.p.no_leading_blank)
625 memset( out , ' ' , nblanks );
626 dtp->u.p.no_leading_blank = 0;
631 #undef MIN_FIELD_WIDTH
636 /* Write "Infinite" or "Nan" as appropriate for the given format. */
639 write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
646 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
648 sign = calculate_sign (dtp, sign_bit);
649 mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7;
653 /* If the field width is zero, the processor must select a width
654 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
656 if ((nb == 0) || dtp->u.p.g0_no_blanks)
661 nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3;
663 p = write_block (dtp, nb);
668 if (unlikely (is_char4_unit (dtp)))
670 gfc_char4_t *p4 = (gfc_char4_t *) p;
671 memset4 (p4, '*', nb);
678 if (unlikely (is_char4_unit (dtp)))
680 gfc_char4_t *p4 = (gfc_char4_t *) p;
681 memset4 (p4, ' ', nb);
690 /* If the sign is negative and the width is 3, there is
691 insufficient room to output '-Inf', so output asterisks */
694 if (unlikely (is_char4_unit (dtp)))
696 gfc_char4_t *p4 = (gfc_char4_t *) p;
697 memset4 (p4, '*', nb);
703 /* The negative sign is mandatory */
707 /* The positive sign is optional, but we output it for
711 if (unlikely (is_char4_unit (dtp)))
713 gfc_char4_t *p4 = (gfc_char4_t *) p;
716 /* We have room, so output 'Infinity' */
717 memcpy4 (p4 + nb - 8, "Infinity", 8);
719 /* For the case of width equals mark, there is not enough room
720 for the sign and 'Infinity' so we go with 'Inf' */
721 memcpy4 (p4 + nb - 3, "Inf", 3);
723 if (sign == S_PLUS || sign == S_MINUS)
725 if (nb < 9 && nb > 3)
726 /* Put the sign in front of Inf */
727 p4[nb - 4] = (gfc_char4_t) fin;
729 /* Put the sign in front of Infinity */
730 p4[nb - 9] = (gfc_char4_t) fin;
736 /* We have room, so output 'Infinity' */
737 memcpy(p + nb - 8, "Infinity", 8);
739 /* For the case of width equals 8, there is not enough room
740 for the sign and 'Infinity' so we go with 'Inf' */
741 memcpy(p + nb - 3, "Inf", 3);
743 if (sign == S_PLUS || sign == S_MINUS)
745 if (nb < 9 && nb > 3)
746 p[nb - 4] = fin; /* Put the sign in front of Inf */
748 p[nb - 9] = fin; /* Put the sign in front of Infinity */
753 if (unlikely (is_char4_unit (dtp)))
755 gfc_char4_t *p4 = (gfc_char4_t *) p;
756 memcpy4 (p4 + nb - 3, "NaN", 3);
759 memcpy(p + nb - 3, "NaN", 3);
766 /* Returns the value of 10**d. */
768 #define CALCULATE_EXP(x) \
769 inline static GFC_REAL_ ## x \
770 calculate_exp_ ## x (int d)\
773 GFC_REAL_ ## x r = 1.0;\
774 for (i = 0; i< (d >= 0 ? d : -d); i++)\
776 r = (d >= 0) ? r : 1.0 / r;\
784 #ifdef HAVE_GFC_REAL_10
788 #ifdef HAVE_GFC_REAL_16
793 /* Generate corresponding I/O format for FMT_G and output.
794 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
795 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
797 Data Magnitude Equivalent Conversion
798 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
799 m = 0 F(w-n).(d-1), n' '
800 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
801 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
802 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
803 ................ ..........
804 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
805 m >= 10**d-0.5 Ew.d[Ee]
807 notes: for Gw.d , n' ' means 4 blanks
808 for Gw.dEe, n' ' means e+2 blanks
809 for rounding modes adjustment, r, See Fortran F2008 10.7.5.2.2
810 the asm volatile is required for 32-bit x86 platforms. */
812 #define OUTPUT_FLOAT_FMT_G(x) \
814 output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
815 GFC_REAL_ ## x m, char *buffer, size_t size, \
816 int sign_bit, bool zero_flag, int ndigits, \
817 int edigits, int comp_d) \
819 int e = f->u.real.e;\
820 int d = f->u.real.d;\
821 int w = f->u.real.w;\
823 GFC_REAL_ ## x rexp_d, r = 0.5;\
827 int save_scale_factor, nb = 0;\
830 save_scale_factor = dtp->u.p.scale_factor;\
831 newf = (fnode *) get_mem (sizeof (fnode));\
833 switch (dtp->u.p.current_unit->round_status)\
836 r = sign_bit ? 1.0 : 0.0;\
848 rexp_d = calculate_exp_ ## x (-d);\
849 if ((m > 0.0 && ((m < 0.1 - 0.1 * r * rexp_d) || (rexp_d * (m + r) >= 1.0)))\
850 || ((m == 0.0) && !(compile_options.allow_std\
851 & (GFC_STD_F2003 | GFC_STD_F2008))))\
853 newf->format = FMT_E;\
855 newf->u.real.d = d - comp_d;\
869 volatile GFC_REAL_ ## x temp;\
870 mid = (low + high) / 2;\
872 temp = (calculate_exp_ ## x (mid - 1) * (1 - r * rexp_d));\
877 if (ubound == lbound + 1)\
884 if (ubound == lbound + 1)\
898 nb = e <= 0 ? 4 : e + 2;\
899 nb = nb >= w ? w - 1 : nb;\
900 newf->format = FMT_F;\
901 newf->u.real.w = w - nb;\
902 newf->u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
903 dtp->u.p.scale_factor = 0;\
906 result = output_float (dtp, newf, buffer, size, sign_bit, zero_flag, \
908 dtp->u.p.scale_factor = save_scale_factor;\
912 if (nb > 0 && !dtp->u.p.g0_no_blanks)\
914 p = write_block (dtp, nb);\
917 if (result == FAILURE)\
919 if (unlikely (is_char4_unit (dtp)))\
921 gfc_char4_t *p4 = (gfc_char4_t *) p;\
922 memset4 (p4, pad, nb);\
925 memset (p, pad, nb);\
929 OUTPUT_FLOAT_FMT_G(4)
931 OUTPUT_FLOAT_FMT_G(8)
933 #ifdef HAVE_GFC_REAL_10
934 OUTPUT_FLOAT_FMT_G(10)
937 #ifdef HAVE_GFC_REAL_16
938 OUTPUT_FLOAT_FMT_G(16)
941 #undef OUTPUT_FLOAT_FMT_G
944 /* Define a macro to build code for write_float. */
946 /* Note: Before output_float is called, snprintf is used to print to buffer the
947 number in the format +D.DDDDe+ddd. For an N digit exponent, this gives us
948 (MIN_FIELD_WIDTH-5)-N digits after the decimal point, plus another one
949 before the decimal point.
951 # The result will always contain a decimal point, even if no
954 - The converted value is to be left adjusted on the field boundary
956 + A sign (+ or -) always be placed before a number
958 MIN_FIELD_WIDTH minimum field width
960 * (ndigits-1) is used as the precision
962 e format: [-]d.ddde±dd where there is one digit before the
963 decimal-point character and the number of digits after it is
964 equal to the precision. The exponent always contains at least two
965 digits; if the value is zero, the exponent is 00. */
968 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
969 "e", ndigits - 1, tmp);
972 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
973 "Le", ndigits - 1, tmp);
976 #if defined(GFC_REAL_16_IS_FLOAT128)
978 __qmath_(quadmath_snprintf) (buffer, sizeof buffer, \
979 "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
980 "Qe", ndigits - 1, tmp);
983 #define WRITE_FLOAT(x,y)\
986 tmp = * (GFC_REAL_ ## x *)source;\
987 sign_bit = signbit (tmp);\
988 if (!isfinite (tmp))\
990 write_infnan (dtp, f, isnan (tmp), sign_bit);\
993 tmp = sign_bit ? -tmp : tmp;\
994 zero_flag = (tmp == 0.0);\
998 if (f->format != FMT_G)\
999 output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
1002 output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
1003 zero_flag, ndigits, edigits, comp_d);\
1006 /* Output a real number according to its format. */
1009 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, \
1010 int len, int comp_d)
1013 #if defined(HAVE_GFC_REAL_16) || __LDBL_DIG__ > 18
1014 # define MIN_FIELD_WIDTH 49
1016 # define MIN_FIELD_WIDTH 32
1018 #define STR(x) STR1(x)
1021 /* This must be large enough to accurately hold any value. */
1022 char buffer[MIN_FIELD_WIDTH+1];
1023 int sign_bit, ndigits, edigits;
1027 size = MIN_FIELD_WIDTH+1;
1029 /* printf pads blanks for us on the exponent so we just need it big enough
1030 to handle the largest number of exponent digits expected. */
1033 /* Always convert at full precision to avoid double rounding. */
1034 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
1046 #ifdef HAVE_GFC_REAL_10
1051 #ifdef HAVE_GFC_REAL_16
1053 # ifdef GFC_REAL_16_IS_FLOAT128
1061 internal_error (NULL, "bad real kind");