-/* Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
Contributed by Andy Vaught
Write float code factoring to this file by Jerry DeLisle
F2003 I/O support contributed by Jerry DeLisle
-This file is part of the GNU Fortran 95 runtime library (libgfortran).
+This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
/* Output a real number according to its format which is FMT_G free. */
-static void
+static try
output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
int sign_bit, bool zero_flag, int ndigits, int edigits)
{
if (zero_flag)
{
e = 0;
- if (compile_options.sign_zero == 1)
- sign = calculate_sign (dtp, sign_bit);
- else
+ if (compile_options.sign_zero != 1)
sign = calculate_sign (dtp, 0);
/* Handle special cases. */
if (w == 0)
- w = d + 2;
-
- /* For this one we choose to not output a decimal point.
- F95 10.5.1.2.1 */
- if (w == 1 && ft == FMT_F)
- {
- out = write_block (dtp, w);
- if (out == NULL)
- return;
- *out = '0';
- return;
- }
-
+ w = d + (sign != S_NONE ? 2 : 1) + (d == 0 ? 1 : 0);
}
/* Normalize the fractional component. */
{
generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
"greater than zero in format specifier 'E' or 'D'");
- return;
+ return FAILURE;
}
if (i <= -d || i >= d + 2)
{
generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
"out of range in format specifier 'E' or 'D'");
- return;
+ return FAILURE;
}
if (!zero_flag)
/* Pick a field size if none was specified. */
if (w <= 0)
- w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
+ {
+ w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
+ w = w == 1 ? 2 : w;
+ }
/* Work out how much padding is needed. */
nblanks = w - (nbefore + nzero + nafter + edigits + 1);
/* Create the ouput buffer. */
out = write_block (dtp, w);
if (out == NULL)
- return;
+ return FAILURE;
/* Check the value fits in the specified field width. */
- if (nblanks < 0 || edigits == -1)
+ if (nblanks < 0 || edigits == -1 || w == 1 || (w == 2 && sign != S_NONE))
{
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *out4 = (gfc_char4_t *) out;
+ memset4 (out4, '*', w);
+ return FAILURE;
+ }
star_fill (out, w);
- return;
+ return FAILURE;
}
/* See if we have space for a zero before the decimal point. */
else
leadzero = 0;
+ /* For internal character(kind=4) units, we duplicate the code used for
+ regular output slightly modified. This needs to be maintained
+ consistent with the regular code that follows this block. */
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *out4 = (gfc_char4_t *) out;
+ /* Pad to full field width. */
+
+ if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
+ {
+ memset4 (out4, ' ', nblanks);
+ out4 += nblanks;
+ }
+
+ /* Output the initial sign (if any). */
+ if (sign == S_PLUS)
+ *(out4++) = '+';
+ else if (sign == S_MINUS)
+ *(out4++) = '-';
+
+ /* Output an optional leading zero. */
+ if (leadzero)
+ *(out4++) = '0';
+
+ /* Output the part before the decimal point, padding with zeros. */
+ if (nbefore > 0)
+ {
+ if (nbefore > ndigits)
+ {
+ i = ndigits;
+ memcpy4 (out4, digits, i);
+ ndigits = 0;
+ while (i < nbefore)
+ out4[i++] = '0';
+ }
+ else
+ {
+ i = nbefore;
+ memcpy4 (out4, digits, i);
+ ndigits -= i;
+ }
+
+ digits += i;
+ out4 += nbefore;
+ }
+
+ /* Output the decimal point. */
+ *(out4++) = dtp->u.p.current_unit->decimal_status
+ == DECIMAL_POINT ? '.' : ',';
+
+ /* Output leading zeros after the decimal point. */
+ if (nzero > 0)
+ {
+ for (i = 0; i < nzero; i++)
+ *(out4++) = '0';
+ }
+
+ /* Output digits after the decimal point, padding with zeros. */
+ if (nafter > 0)
+ {
+ if (nafter > ndigits)
+ i = ndigits;
+ else
+ i = nafter;
+
+ memcpy4 (out4, digits, i);
+ while (i < nafter)
+ out4[i++] = '0';
+
+ digits += i;
+ ndigits -= i;
+ out4 += nafter;
+ }
+
+ /* Output the exponent. */
+ if (expchar)
+ {
+ if (expchar != ' ')
+ {
+ *(out4++) = expchar;
+ edigits--;
+ }
+#if HAVE_SNPRINTF
+ snprintf (buffer, size, "%+0*d", edigits, e);
+#else
+ sprintf (buffer, "%+0*d", edigits, e);
+#endif
+ memcpy4 (out4, buffer, edigits);
+ }
+
+ if (dtp->u.p.no_leading_blank)
+ {
+ out4 += edigits;
+ memset4 (out4, ' ' , nblanks);
+ dtp->u.p.no_leading_blank = 0;
+ }
+ return SUCCESS;
+ } /* End of character(kind=4) internal unit code. */
+
/* Pad to full field width. */
if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
#undef STR
#undef STR1
#undef MIN_FIELD_WIDTH
+ return SUCCESS;
}
{
char * p, fin;
int nb = 0;
+ sign_t sign;
+ int mark;
if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
{
- nb = f->u.real.w;
-
- /* If the field width is zero, the processor must select a width
- not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
-
- if (nb == 0) nb = 4;
- p = write_block (dtp, nb);
- if (p == NULL)
- return;
- if (nb < 3)
+ sign = calculate_sign (dtp, sign_bit);
+ mark = (sign == S_PLUS || sign == S_MINUS) ? 8 : 7;
+
+ nb = f->u.real.w;
+
+ /* If the field width is zero, the processor must select a width
+ not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
+
+ if (nb == 0)
+ {
+ if (isnan_flag)
+ nb = 3;
+ else
+ nb = (sign == S_PLUS || sign == S_MINUS) ? 4 : 3;
+ }
+ p = write_block (dtp, nb);
+ if (p == NULL)
+ return;
+ if (nb < 3)
+ {
+ if (unlikely (is_char4_unit (dtp)))
{
- memset (p, '*',nb);
- return;
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, '*', nb);
}
+ else
+ memset (p, '*', nb);
+ return;
+ }
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', nb);
+ }
+ else
+ memset(p, ' ', nb);
- memset(p, ' ', nb);
- if (!isnan_flag)
+ if (!isnan_flag)
+ {
+ if (sign_bit)
{
- if (sign_bit)
- {
-
- /* If the sign is negative and the width is 3, there is
- insufficient room to output '-Inf', so output asterisks */
-
- if (nb == 3)
- {
- memset (p, '*',nb);
- return;
- }
-
- /* The negative sign is mandatory */
-
- fin = '-';
- }
- else
-
- /* The positive sign is optional, but we output it for
- consistency */
- fin = '+';
-
- if (nb > 8)
-
- /* We have room, so output 'Infinity' */
- memcpy(p + nb - 8, "Infinity", 8);
+ /* If the sign is negative and the width is 3, there is
+ insufficient room to output '-Inf', so output asterisks */
+ if (nb == 3)
+ {
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, '*', nb);
+ }
+ else
+ memset (p, '*', nb);
+ return;
+ }
+ /* The negative sign is mandatory */
+ fin = '-';
+ }
+ else
+ /* The positive sign is optional, but we output it for
+ consistency */
+ fin = '+';
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+
+ if (nb > mark)
+ /* We have room, so output 'Infinity' */
+ memcpy4 (p4 + nb - 8, "Infinity", 8);
else
-
- /* For the case of width equals 8, there is not enough room
- for the sign and 'Infinity' so we go with 'Inf' */
- memcpy(p + nb - 3, "Inf", 3);
+ /* For the case of width equals mark, there is not enough room
+ for the sign and 'Infinity' so we go with 'Inf' */
+ memcpy4 (p4 + nb - 3, "Inf", 3);
+
+ if (sign == S_PLUS || sign == S_MINUS)
+ {
+ if (nb < 9 && nb > 3)
+ /* Put the sign in front of Inf */
+ p4[nb - 4] = (gfc_char4_t) fin;
+ else if (nb > 8)
+ /* Put the sign in front of Infinity */
+ p4[nb - 9] = (gfc_char4_t) fin;
+ }
+ return;
+ }
+
+ if (nb > mark)
+ /* We have room, so output 'Infinity' */
+ memcpy(p + nb - 8, "Infinity", 8);
+ else
+ /* For the case of width equals 8, there is not enough room
+ for the sign and 'Infinity' so we go with 'Inf' */
+ memcpy(p + nb - 3, "Inf", 3);
+ if (sign == S_PLUS || sign == S_MINUS)
+ {
if (nb < 9 && nb > 3)
p[nb - 4] = fin; /* Put the sign in front of Inf */
else if (nb > 8)
p[nb - 9] = fin; /* Put the sign in front of Infinity */
}
+ }
+ else
+ {
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memcpy4 (p4 + nb - 3, "NaN", 3);
+ }
else
memcpy(p + nb - 3, "NaN", 3);
- return;
}
+ return;
}
+}
/* Returns the value of 10**d. */
GFC_REAL_ ## x rexp_d;\
int low, high, mid;\
int ubound, lbound;\
- char *p;\
+ char *p, pad = ' ';\
int save_scale_factor, nb = 0;\
+ try result;\
\
save_scale_factor = dtp->u.p.scale_factor;\
newf = (fnode *) get_mem (sizeof (fnode));\
}\
}\
\
+ if (e > 4)\
+ e = 4;\
if (e < 0)\
nb = 4;\
else\
nb = e + 2;\
\
+ nb = nb >= w ? 0 : nb;\
newf->format = FMT_F;\
newf->u.real.w = f->u.real.w - nb;\
\
dtp->u.p.scale_factor = 0;\
\
finish:\
- output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
- edigits);\
+ result = output_float (dtp, newf, buffer, size, sign_bit, zero_flag, \
+ ndigits, edigits);\
dtp->u.p.scale_factor = save_scale_factor;\
\
- free_mem(newf);\
+ free (newf);\
\
if (nb > 0 && !dtp->u.p.g0_no_blanks)\
- { \
+ {\
p = write_block (dtp, nb);\
if (p == NULL)\
return;\
- memset (p, ' ', nb);\
+ if (result == FAILURE)\
+ pad = '*';\
+ if (unlikely (is_char4_unit (dtp)))\
+ {\
+ gfc_char4_t *p4 = (gfc_char4_t *) p;\
+ memset4 (p4, pad, nb);\
+ }\
+ else\
+ memset (p, pad, nb);\
}\
}\
#endif
+#if defined(GFC_REAL_16_IS_FLOAT128)
+#define DTOAQ \
+__qmath_(quadmath_snprintf) (buffer, sizeof buffer, \
+ "%+-#" STR(MIN_FIELD_WIDTH) ".*" \
+ "Qe", ndigits - 1, tmp);
+#endif
+
#define WRITE_FLOAT(x,y)\
{\
GFC_REAL_ ## x tmp;\
write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
-#if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
+#if defined(HAVE_GFC_REAL_16) || __LDBL_DIG__ > 18
# define MIN_FIELD_WIDTH 46
#else
# define MIN_FIELD_WIDTH 31
#endif
#ifdef HAVE_GFC_REAL_16
case 16:
+# ifdef GFC_REAL_16_IS_FLOAT128
+ WRITE_FLOAT(16,Q)
+# else
WRITE_FLOAT(16,L)
+# endif
break;
#endif
default:
OSDN Git Service
