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 s
= options.optional_plus ? S_PLUS
: S_NONE
;
66 /* Output a real number according to its format which is FMT_G free.
*/
69 output_float (st_parameter_dt
*dtp
, const fnode
*f
, char
*buffer
, size_t size
,
70 int sign_bit
, bool zero_flag
, int ndigits
, int edigits
)
79 /* Number of digits before the decimal point.
*/
81 /* Number of zeros after the decimal point.
*/
83 /* Number of digits after the decimal point.
*/
85 /* Number of zeros after the decimal point
, whatever the precision.
*/
98 /* We should always know the field width and precision.
*/
100 internal_error (&dtp
->common
, "Unspecified precision");
102 /* Use sprintf to print the number in the format
+D.DDDDe
+ddd
103 For an N digit exponent
, this gives
us (MIN_FIELD_WIDTH
-5)-N digits
104 after the decimal point
, plus another one before the decimal point.
*/
106 sign
= calculate_sign (dtp
, sign_bit
);
108 /* # The result will always contain a decimal point
, even if no
111 * - The converted value is to be left adjusted on the field boundary
113 * + A
sign (+ or
-) always be placed before a number
115 * MIN_FIELD_WIDTH minimum field width
117 * * (ndigits
-1) is used as the precision
119 * e format
: [-]d.ddde±dd where there is one digit before the
120 * decimal
-point character and the number of digits after it is
121 * equal to the precision. The exponent always contains at least two
122 * digits
; if the value is zero
, the exponent is
00.
125 /* Check the given string has punctuation in the correct places.
*/
126 if (d
!= 0 && (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e'))
127 internal_error (&dtp
->common
, "printf is broken");
129 /* Read the exponent back in.
*/
130 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
132 /* Make sure zero comes out as
0.0e0.
*/
136 if (compile_options.sign_zero
== 1)
137 sign
= calculate_sign (dtp
, sign_bit
);
139 sign
= calculate_sign (dtp
, 0);
142 /* Normalize the fractional component.
*/
143 buffer
[2] = buffer
[1];
146 /* Figure out where to place the decimal point.
*/
150 nbefore
= e
+ dtp
->u.p.scale_factor
;
170 i
= dtp
->u.p.scale_factor
;
171 if (d
<= 0 && i
== 0)
173 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Precision not "
174 "greater than zero in format specifier 'E' or 'D'");
177 if (i
<= -d || i
>= d
+ 2)
179 generate_error (&dtp
->common
, LIBERROR_FORMAT
, "Scale factor "
180 "out of range in format specifier 'E' or 'D'");
196 nafter
= (d
- i
) + 1;
212 /* The exponent must be a multiple of three
, with
1-3 digits before
213 the decimal point.
*/
222 nbefore
= 3 - nbefore
;
241 /* Should never happen.
*/
242 internal_error (&dtp
->common
, "Unexpected format token");
245 /* Round the value.
*/
246 if (nbefore
+ nafter
== 0)
249 if (nzero_real
== d
&& digits
[0] >= '5')
251 /* We rounded to zero but shouldn
't have */
258 else if (nbefore + nafter < ndigits)
260 ndigits = nbefore + nafter;
262 if (digits[i] >= '5')
264 /* Propagate the carry. */
265 for (i--; i >= 0; i--)
267 if (digits[i] != '9')
277 /* The carry overflowed. Fortunately we have some spare space
278 at the start of the buffer. We may discard some digits, but
279 this is ok because we already know they are zero. */
292 else if (ft == FMT_EN)
307 /* Calculate the format of the exponent field. */
311 for (i = abs (e); i >= 10; i /= 10)
316 /* Width not specified. Must be no more than 3 digits. */
317 if (e > 999 || e < -999)
322 if (e > 99 || e < -99)
328 /* Exponent width specified, check it is wide enough. */
329 if (edigits > f->u.real.e)
332 edigits = f->u.real.e + 2;
338 /* Pick a field size if none was specified. */
340 w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
342 /* Create the ouput buffer. */
343 out = write_block (dtp, w);
347 /* Zero values always output as positive, even if the value was negative
349 for (i = 0; i < ndigits; i++)
351 if (digits[i] != '0')
356 /* The output is zero, so set the sign according to the sign bit unless
357 -fno-sign-zero was specified. */
358 if (compile_options.sign_zero == 1)
359 sign = calculate_sign (dtp, sign_bit);
361 sign = calculate_sign (dtp, 0);
364 /* Work out how much padding is needed. */
365 nblanks = w - (nbefore + nzero + nafter + edigits + 1);
369 /* Check the value fits in the specified field width. */
370 if (nblanks < 0 || edigits == -1)
376 /* See if we have space for a zero before the decimal point. */
377 if (nbefore == 0 && nblanks > 0)
385 /* Pad to full field width. */
387 if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
389 memset (out, ' ', nblanks);
393 /* Output the initial sign (if any). */
396 else if (sign == S_MINUS)
399 /* Output an optional leading zero. */
403 /* Output the part before the decimal point, padding with zeros. */
406 if (nbefore > ndigits)
409 memcpy (out, digits, i);
417 memcpy (out, digits, i);
424 /* Output the decimal point. */
425 *(out++) = dtp->u.p.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);
466 if (dtp->u.p.no_leading_blank)
469 memset( out , ' ' , nblanks );
470 dtp->u.p.no_leading_blank = 0;
474 #undef MIN_FIELD_WIDTH
478 /* Write "Infinite" or "Nan" as appropriate for the given format. */
481 write_infnan (st_parameter_dt *dtp, const fnode *f, int isnan_flag, int sign_bit)
486 if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
490 /* If the field width is zero, the processor must select a width
491 not zero. 4 is chosen to allow output of '-Inf
' or '+Inf
' */
494 p = write_block (dtp, nb);
509 /* If the sign is negative and the width is 3, there is
510 insufficient room to output '-Inf
', so output asterisks */
518 /* The negative sign is mandatory */
524 /* The positive sign is optional, but we output it for
530 /* We have room, so output 'Infinity
' */
531 memcpy(p + nb - 8, "Infinity", 8);
534 /* For the case of width equals 8, there is not enough room
535 for the sign and 'Infinity
' so we go with 'Inf
' */
536 memcpy(p + nb - 3, "Inf", 3);
538 if (nb < 9 && nb > 3)
539 p[nb - 4] = fin; /* Put the sign in front of Inf */
541 p[nb - 9] = fin; /* Put the sign in front of Infinity */
544 memcpy(p + nb - 3, "NaN", 3);
550 /* Returns the value of 10**d. */
552 #define CALCULATE_EXP(x) \
553 inline static GFC_REAL_ ## x \
554 calculate_exp_ ## x (int d)\
557 GFC_REAL_ ## x r = 1.0;\
558 for (i = 0; i< (d >= 0 ? d : -d); i++)\
560 r = (d >= 0) ? r : 1.0 / r;\
568 #ifdef HAVE_GFC_REAL_10
572 #ifdef HAVE_GFC_REAL_16
577 /* Generate corresponding I/O format for FMT_G and output.
578 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
579 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
581 Data Magnitude Equivalent Conversion
582 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
583 m = 0 F(w-n).(d-1), n' '
584 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
585 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
586 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
587 ................ ..........
588 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
589 m >= 10**d-0.5 Ew.d[Ee]
591 notes: for Gw.d , n' ' means 4 blanks
592 for Gw.dEe, n' ' means e+2 blanks */
594 #define OUTPUT_FLOAT_FMT_G(x) \
596 output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
597 GFC_REAL_ ## x m, char *buffer, size_t size, \
598 int sign_bit, bool zero_flag, int ndigits, int edigits) \
600 int e = f->u.real.e;\
601 int d = f->u.real.d;\
602 int w = f->u.real.w;\
604 GFC_REAL_ ## x exp_d;\
608 int save_scale_factor, nb = 0;\
610 save_scale_factor = dtp->u.p.scale_factor;\
611 newf = get_mem (sizeof (fnode));\
613 exp_d = calculate_exp_ ## x (d);\
614 if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\
615 ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
617 newf->format = FMT_E;\
633 GFC_REAL_ ## x temp;\
634 mid = (low + high) / 2;\
636 temp = 0.1 * calculate_exp_ ## x (mid) - 0.5\
637 * calculate_exp_ ## x (mid - d - 1);\
642 if (ubound == lbound + 1)\
649 if (ubound == lbound + 1)\
665 newf->format = FMT_F;\
666 newf->u.real.w = f->u.real.w - nb;\
669 newf->u.real.d = d - 1;\
671 newf->u.real.d = - (mid - d - 1);\
673 dtp->u.p.scale_factor = 0;\
676 output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
678 dtp->u.p.scale_factor = save_scale_factor;\
684 p = write_block (dtp, nb);\
687 memset (p, ' ', nb);\
691 OUTPUT_FLOAT_FMT_G(4)
693 OUTPUT_FLOAT_FMT_G(8)
695 #ifdef HAVE_GFC_REAL_10
696 OUTPUT_FLOAT_FMT_G(10)
699 #ifdef HAVE_GFC_REAL_16
700 OUTPUT_FLOAT_FMT_G(16)
703 #undef OUTPUT_FLOAT_FMT_G
705 /* Define a macro to build code for write_float. */
710 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
711 "e", ndigits - 1, tmp);
714 snprintf (buffer, size, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
715 "Le", ndigits - 1, tmp);
720 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
721 "e", ndigits - 1, tmp);
724 sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
725 "Le", ndigits - 1, tmp);
729 #define WRITE_FLOAT(x,y)\
732 tmp = * (GFC_REAL_ ## x *)source;\
733 sign_bit = signbit (tmp);\
734 if (!isfinite (tmp))\
736 write_infnan (dtp, f, isnan (tmp), sign_bit);\
739 tmp = sign_bit ? -tmp : tmp;\
740 if (f->u.real.d == 0 && f->format == FMT_F)\
747 zero_flag = (tmp == 0.0);\
751 if (f->format != FMT_G)\
752 output_float (dtp, f, buffer, size, sign_bit, zero_flag, ndigits, \
755 output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
756 zero_flag, ndigits, edigits);\
759 /* Output a real number according to its format. */
762 write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
765 #if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
766 # define MIN_FIELD_WIDTH 46
768 # define MIN_FIELD_WIDTH 31
770 #define STR(x) STR1(x)
773 /* This must be large enough to accurately hold any value. */
774 char buffer[MIN_FIELD_WIDTH+1];
775 int sign_bit, ndigits, edigits;
779 size = MIN_FIELD_WIDTH+1;
781 /* printf pads blanks for us on the exponent so we just need it big enough
782 to handle the largest number of exponent digits expected. */
785 if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G
786 || ((f->format == FMT_D || f->format == FMT_E)
787 && dtp->u.p.scale_factor != 0))
789 /* Always convert at full precision to avoid double rounding. */
790 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
794 /* The number of digits is known, so let printf do the rounding. */
795 if (f->format == FMT_ES)
796 ndigits = f->u.real.d + 1;
798 ndigits = f->u.real.d;
799 if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
800 ndigits = MIN_FIELD_WIDTH - 4 - edigits;
813 #ifdef HAVE_GFC_REAL_10
818 #ifdef HAVE_GFC_REAL_16
824 internal_error (NULL, "bad real kind");