1 /* Copyright (C) 2007, 2008 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 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
35 { S_NONE, S_MINUS, S_PLUS }
38 /* Given a flag that indicates if a value is negative or not, return a
39 sign_t that gives the sign that we need to produce. */
42 calculate_sign (st_parameter_dt *dtp, int negative_flag)
49 switch (dtp->u.p.sign_status)
51 case SIGN_SP: /* Show sign. */
54 case SIGN_SS: /* Suppress sign. */
57 case SIGN_S: /* Processor defined. */
58 case SIGN_UNSPECIFIED:
59 s = options.optional_plus ? S_PLUS : S_NONE;
67 /* Output a real number according to its format which is FMT_G free. */
70 output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
71 int sign_bit, bool zero_flag, int ndigits, int edigits)
80 /* Number of digits before the decimal point. */
82 /* Number of zeros after the decimal point. */
84 /* Number of digits after the decimal point. */
86 /* Number of zeros after the decimal point, whatever the precision. */
99 /* We should always know the field width and precision. */
101 internal_error (&dtp->common, "Unspecified precision");
103 sign = calculate_sign (dtp, sign_bit);
105 /* The following code checks the given string has punctuation in the correct
106 places. Uncomment if needed for debugging.
107 if (d != 0 && ((buffer[2] != '.' && buffer[2] != ',')
108 || buffer[ndigits + 2] != 'e'))
109 internal_error (&dtp->common, "printf is broken"); */
111 /* Read the exponent back in. */
112 e = atoi (&buffer[ndigits + 3]) + 1;
114 /* Make sure zero comes out as 0.0e0. */
118 if (compile_options.sign_zero == 1)
119 sign = calculate_sign (dtp, sign_bit);
121 sign = calculate_sign (dtp, 0);
123 /* Handle special cases. */
127 /* For this one we choose to not output a decimal point.
129 if (w == 1 && ft == FMT_F)
131 out = write_block (dtp, w);
140 /* Normalize the fractional component. */
141 buffer[2] = buffer[1];
144 /* Figure out where to place the decimal point. */
148 nbefore = e + dtp->u.p.scale_factor;
168 i = dtp->u.p.scale_factor;
169 if (d <= 0 && i == 0)
171 generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
172 "greater than zero in format specifier 'E' or 'D'");
175 if (i <= -d || i >= d + 2)
177 generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
178 "out of range in format specifier 'E' or 'D'");
194 nafter = (d - i) + 1;
210 /* The exponent must be a multiple of three, with 1-3 digits before
211 the decimal point. */
220 nbefore = 3 - nbefore;
239 /* Should never happen. */
240 internal_error (&dtp->common, "Unexpected format token");
243 /* Round the value. */
244 if (nbefore + nafter == 0)
247 if (nzero_real == d && digits[0] >= '5')
249 /* We rounded to zero but shouldn't have */
256 else if (nbefore + nafter < ndigits)
258 ndigits = nbefore + nafter;
260 if (digits[i] >= '5')
262 /* Propagate the carry. */
263 for (i--; i >= 0; i--)
265 if (digits[i] != '9')
275 /* The carry overflowed. Fortunately we have some spare space
276 at the start of the buffer. We may discard some digits, but
277 this is ok because we already know they are zero. */
290 else if (ft == FMT_EN)
305 /* Calculate the format of the exponent field. */
309 for (i = abs (e); i >= 10; i /= 10)
314 /* Width not specified. Must be no more than 3 digits. */
315 if (e > 999 || e < -999)
320 if (e > 99 || e < -99)
326 /* Exponent width specified, check it is wide enough. */
327 if (edigits > f->u.real.e)
330 edigits = f->u.real.e + 2;
336 /* Zero values always output as positive, even if the value was negative
338 for (i = 0; i < ndigits; i++)
340 if (digits[i] != '0')
345 /* The output is zero, so set the sign according to the sign bit unless
346 -fno-sign-zero was specified. */
347 if (compile_options.sign_zero == 1)
348 sign = calculate_sign (dtp, sign_bit);
350 sign = calculate_sign (dtp, 0);
353 /* Pick a field size if none was specified. */
355 w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
357 /* Work out how much padding is needed. */
358 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
362 if (dtp->u.p.g0_no_blanks)
368 /* Create the ouput buffer. */
369 out = write_block (dtp, w);
373 /* Check the value fits in the specified field width. */
374 if (nblanks < 0 || edigits == -1)
380 /* See if we have space for a zero before the decimal point. */
381 if (nbefore == 0 && nblanks > 0)
389 /* Pad to full field width. */
391 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
393 memset (out, ' ', nblanks);
397 /* Output the initial sign (if any). */
400 else if (sign == S_MINUS)
403 /* Output an optional leading zero. */
407 /* Output the part before the decimal point, padding with zeros. */
410 if (nbefore > ndigits)
413 memcpy (out, digits, i);
421 memcpy (out, digits, i);
429 /* Output the decimal point. */
430 *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
432 /* Output leading zeros after the decimal point. */
435 for (i = 0; i < nzero; i++)
439 /* Output digits after the decimal point, padding with zeros. */
442 if (nafter > ndigits)
447 memcpy (out, digits, i);
456 /* Output the exponent. */
465 snprintf (buffer, size, "%+0*d", edigits, e);
467 sprintf (buffer, "%+0*d", edigits, e);
469 memcpy (out, buffer, edigits);
472 if (dtp->u.p.no_leading_blank)
475 memset( out , ' ' , nblanks );
476 dtp->u.p.no_leading_blank = 0;
481 #undef MIN_FIELD_WIDTH
485 /* Write "Infinite" or "Nan" as appropriate for the given format. */
488 write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
493 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
497 /* If the field width is zero, the processor must select a width
498 not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
501 p = write_block (dtp, nb);
516 /* If the sign is negative and the width is 3, there is
517 insufficient room to output '-Inf', so output asterisks */
525 /* The negative sign is mandatory */
531 /* The positive sign is optional, but we output it for
537 /* We have room, so output 'Infinity' */
538 memcpy(p + nb - 8, "Infinity", 8);
541 /* For the case of width equals 8, there is not enough room
542 for the sign and 'Infinity' so we go with 'Inf' */
543 memcpy(p + nb - 3, "Inf", 3);
545 if (nb < 9 && nb > 3)
546 p[nb - 4] = fin; /* Put the sign in front of Inf */
548 p[nb - 9] = fin; /* Put the sign in front of Infinity */
551 memcpy(p + nb - 3, "NaN", 3);
557 /* Returns the value of 10**d. */
559 #define CALCULATE_EXP(x) \
560 inline static GFC_REAL_ ## x \
561 calculate_exp_ ## x (int d)\
564 GFC_REAL_ ## x r = 1.0;\
565 for (i = 0; i< (d >= 0 ? d : -d); i++)\
567 r = (d >= 0) ? r : 1.0 / r;\
575 #ifdef HAVE_GFC_REAL_10
579 #ifdef HAVE_GFC_REAL_16
584 /* Generate corresponding I/O format for FMT_G and output.
585 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
586 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
588 Data Magnitude Equivalent Conversion
589 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
590 m = 0 F(w-n).(d-1), n' '
591 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
592 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
593 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
594 ................ ..........
595 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
596 m >= 10**d-0.5 Ew.d[Ee]
598 notes: for Gw.d , n' ' means 4 blanks
599 for Gw.dEe, n' ' means e+2 blanks */
601 #define OUTPUT_FLOAT_FMT_G(x) \
603 output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
604 GFC_REAL_ ## x m, char *buffer, size_t size, \
605 int sign_bit, bool zero_flag, int ndigits, int edigits) \
607 int e = f->u.real.e;\
608 int d = f->u.real.d;\
609 int w = f->u.real.w;\
611 GFC_REAL_ ## x exp_d;\
615 int save_scale_factor, nb = 0;\
617 save_scale_factor = dtp->u.p.scale_factor;\
618 newf = (fnode *) get_mem (sizeof (fnode));\
620 exp_d = calculate_exp_ ## x (d);\
621 if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\
622 ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
624 newf->format = FMT_E;\
640 GFC_REAL_ ## x temp;\
641 mid = (low + high) / 2;\
643 temp = (calculate_exp_ ## x (mid) - \
644 5 * calculate_exp_ ## x (mid - d - 1)) / 10;\
649 if (ubound == lbound + 1)\
656 if (ubound == lbound + 1)\
675 newf->format = FMT_F;\
676 newf->u.real.w = f->u.real.w - nb;\
679 newf->u.real.d = d - 1;\
681 newf->u.real.d = - (mid - d - 1);\
683 dtp->u.p.scale_factor = 0;\
686 output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
688 dtp->u.p.scale_factor = save_scale_factor;\
692 if (nb > 0 && !dtp->u.p.g0_no_blanks)\
694 p = write_block (dtp, nb);\
697 memset (p, ' ', nb);\
701 OUTPUT_FLOAT_FMT_G(4)
703 OUTPUT_FLOAT_FMT_G(8)
705 #ifdef HAVE_GFC_REAL_10
706 OUTPUT_FLOAT_FMT_G(10)
709 #ifdef HAVE_GFC_REAL_16
710 OUTPUT_FLOAT_FMT_G(16)
713 #undef OUTPUT_FLOAT_FMT_G
716 /* Define a macro to build code for write_float. */
718 /* Note: Before output_float is called, sprintf is used to print to buffer the
719 number in the format +D.DDDDe+ddd. For an N digit exponent, this gives us
720 (MIN_FIELD_WIDTH-5)-N digits after the decimal point, plus another one
721 before the decimal point.
723 # The result will always contain a decimal point, even if no
726 - The converted value is to be left adjusted on the field boundary
728 + A sign (+ or -) always be placed before a number
730 MIN_FIELD_WIDTH minimum field width
732 * (ndigits-1) is used as the precision
734 e format: [-]d.ddde±dd where there is one digit before the
735 decimal-point character and the number of digits after it is
736 equal to the precision. The exponent always contains at least two
737 digits; if the value is zero, the exponent is 00. */
742 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
743 "e", ndigits - 1, tmp);
746 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
747 "Le", ndigits - 1, tmp);
752 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
753 "e", ndigits - 1, tmp);
756 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
757 "Le", ndigits - 1, tmp);
761 #define WRITE_FLOAT(x,y)\
764 tmp = * (GFC_REAL_ ## x *)source;\
765 sign_bit = signbit (tmp);\
766 if (!isfinite (tmp))\
768 write_infnan (dtp, f, isnan (tmp), sign_bit);\
771 tmp = sign_bit ? -tmp : tmp;\
772 if (f->u.real.d == 0 && f->format == FMT_F\
773 && dtp->u.p.scale_factor == 0)\
780 zero_flag = (tmp == 0.0);\
784 if (f->format != FMT_G)\
785 output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
788 output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
789 zero_flag, ndigits, edigits);\
792 /* Output a real number according to its format. */
795 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
798 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
799 # define MIN_FIELD_WIDTH 46
801 # define MIN_FIELD_WIDTH 31
803 #define STR(x) STR1(x)
806 /* This must be large enough to accurately hold any value. */
807 char buffer[MIN_FIELD_WIDTH+1];
808 int sign_bit, ndigits, edigits;
812 size = MIN_FIELD_WIDTH+1;
814 /* printf pads blanks for us on the exponent so we just need it big enough
815 to handle the largest number of exponent digits expected. */
818 if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G
819 || ((f->format == FMT_D || f->format == FMT_E)
820 && dtp->u.p.scale_factor != 0))
822 /* Always convert at full precision to avoid double rounding. */
823 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
827 /* The number of digits is known, so let printf do the rounding. */
828 if (f->format == FMT_ES)
829 ndigits = f->u.real.d + 1;
831 ndigits = f->u.real.d;
832 if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
833 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
846 #ifdef HAVE_GFC_REAL_10
851 #ifdef HAVE_GFC_REAL_16
857 internal_error (NULL, "bad real kind");