-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
#include "config.h"
#include <string.h>
#include <float.h>
+#include <stdio.h>
+#include <stdlib.h>
#include "libgfortran.h"
#include "io.h"
-#include <stdio.h>
#define star_fill(p, n) memset(p, '*', n)
}
-/* calculate sign()-- Given a flag that indicate if a value is
- * negative or not, return a sign_t that gives the sign that we need
- * to produce. */
+/* Given a flag that indicate if a value is negative or not, return a
+ sign_t that gives the sign that we need to produce. */
static sign_t
calculate_sign (int negative_flag)
}
-/* calculate_exp()-- returns the value of 10**d. */
+/* Returns the value of 10**d. */
static double
calculate_exp (int d)
}
-/* calculate_G_format()-- geneate corresponding I/O format for
- FMT_G output.
- The rules to translate FMT_G to FMT_E or FNT_F from DEC fortran
+/* Generate corresponding I/O format for FMT_G output.
+ The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
Data Magnitude Equivalent Conversion
newf->u.real.w = w;
newf->u.real.d = d;
newf->u.real.e = e;
- *num_blank = e + 2;
+ *num_blank = 0;
return newf;
}
break;
}
- /* Generate the F editing. F(w-4).(-(mid-d-1)), 4' '. */
+ /* Pad with blanks where the exponent would be. */
+ if (e < 0)
+ *num_blank = 4;
+ else
+ *num_blank = e + 2;
+
+ /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
newf->format = FMT_F;
- newf->u.real.w = f->u.real.w - 4;
+ newf->u.real.w = f->u.real.w - *num_blank;
/* Special case. */
if (m == 0.0)
else
newf->u.real.d = - (mid - d - 1);
- *num_blank = 4;
-
/* For F editing, the scale factor is ignored. */
g.scale_factor = 0;
return newf;
}
-/* output_float() -- output a real number according to its format
- which is FMT_G free */
+/* Output a real number according to its format which is FMT_G free. */
static void
output_float (fnode *f, double value, int len)
{
- int w, d, e, e_new;
- int digits;
- int nsign, nblank, nesign;
- int sca, neval, itmp;
- char *p;
- const char *q, *intstr, *base;
- double n;
+ /* This must be large enough to accurately hold any value. */
+ char buffer[32];
+ char *out;
+ char *digits;
+ int e;
+ char expchar;
format_token ft;
- char exp_char = 'E';
- int with_exp = 1;
- int scale_flag = 1 ;
- double minv = 0.0, maxv = 0.0;
- sign_t sign = SIGN_NONE, esign = SIGN_NONE;
-
- int intval = 0, intlen = 0;
- int j;
-
- /* EXP value for this number */
- neval = 0;
-
- /* Width of EXP and it's sign*/
- nesign = 0;
+ int w;
+ int d;
+ int edigits;
+ int ndigits;
+ /* Number of digits before the decimal point. */
+ int nbefore;
+ /* Number of zeros after the decimal point. */
+ int nzero;
+ /* Number of digits after the decimal point. */
+ int nafter;
+ int leadzero;
+ int nblanks;
+ int i;
+ sign_t sign;
ft = f->format;
w = f->u.real.w;
- d = f->u.real.d + 1;
-
- /* Width of the EXP */
- e = 0;
-
- sca = g.scale_factor;
- n = value;
-
- sign = calculate_sign (n < 0.0);
- if (n < 0)
- n = -n;
-
- /* Width of the sign for the whole number */
- nsign = (sign == SIGN_NONE ? 0 : 1);
-
- digits = 0;
- if (ft != FMT_F)
+ d = f->u.real.d;
+
+ /* We should always know the field width and precision. */
+ if (d < 0)
+ internal_error ("Uspecified precision");
+
+ /* Use sprintf to print the number in the format +D.DDDDe+ddd
+ For an N digit exponent, this gives us (32-6)-N digits after the
+ decimal point, plus another one before the decimal point. */
+ sign = calculate_sign (value < 0.0);
+ if (value < 0)
+ value = -value;
+
+ /* Printf always prints at least two exponent digits. */
+ if (value == 0)
+ edigits = 2;
+ else
{
- e = f->u.real.e;
+ edigits = 1 + (int) log10 (fabs(log10 (value)));
+ if (edigits < 2)
+ edigits = 2;
}
- if (ft == FMT_F || ft == FMT_E || ft == FMT_D)
+
+ if (ft == FMT_F || ft == FMT_EN
+ || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
{
- if (ft == FMT_F)
- scale_flag = 0;
- if (ft == FMT_D)
- exp_char = 'D' ;
- minv = 0.1;
- maxv = 1.0;
-
- /* Here calculate the new val of the number with consideration
- of Globle Scale value */
- while (sca > 0)
- {
- minv *= 10.0;
- maxv *= 10.0;
- n *= 10.0;
- sca -- ;
- neval --;
- }
-
- /* Now calculate the new Exp value for this number */
- sca = g.scale_factor;
- while(sca >= 1)
- {
- sca /= 10;
- digits ++ ;
- }
+ /* Always convert at full precision to avoid double rounding. */
+ ndigits = 27 - edigits;
+ }
+ else
+ {
+ /* We know the number of digits, so can let printf do the rounding
+ for us. */
+ if (ft == FMT_ES)
+ ndigits = d + 1;
+ else
+ ndigits = d;
+ if (ndigits > 27 - edigits)
+ ndigits = 27 - edigits;
}
- if (ft == FMT_EN )
- {
- minv = 1.0;
- maxv = 1000.0;
- }
- if (ft == FMT_ES)
- {
- minv = 1.0;
- maxv = 10.0;
- }
+ sprintf (buffer, "%+-#31.*e", ndigits - 1, value);
+
+ /* Check the resulting string has punctuation in the correct places. */
+ if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
+ internal_error ("printf is broken");
- /* OK, let's scale the number to appropriate range */
- while (scale_flag && n > 0.0 && n < minv)
- {
- if (n < minv)
- {
- n = n * 10.0 ;
- neval --;
- }
- }
- while (scale_flag && n > 0.0 && n > maxv)
- {
- if (n > maxv)
- {
- n = n / 10.0 ;
- neval ++;
- }
- }
+ /* Read the exponent back in. */
+ e = atoi (&buffer[ndigits + 3]) + 1;
+
+ /* Make sure zero comes out as 0.0e0. */
+ if (value == 0.0)
+ e = 0;
- /* It is time to process the EXP part of the number.
- Value of 'nesign' is 0 unless following codes is executed.
- */
- if (ft != FMT_F)
+ /* Normalize the fractional component. */
+ buffer[2] = buffer[1];
+ digits = &buffer[2];
+
+ /* Figure out where to place the decimal point. */
+ switch (ft)
{
- /* Sign of the EXP value */
- if (neval >= 0)
- esign = SIGN_PLUS;
- else
- {
- esign = SIGN_MINUS;
- neval = - neval ;
- }
-
- /* Width of the EXP*/
- e_new = 0;
- j = neval;
- while (j > 0)
- {
- j = j / 10;
- e_new ++ ;
- }
- if (e <= e_new)
- e = e_new;
+ case FMT_F:
+ nbefore = e + g.scale_factor;
+ if (nbefore < 0)
+ {
+ nzero = -nbefore;
+ if (nzero > d)
+ nzero = d;
+ nafter = d - nzero;
+ nbefore = 0;
+ }
+ else
+ {
+ nzero = 0;
+ nafter = d;
+ }
+ expchar = 0;
+ break;
- /* Got the width of EXP */
- if (e < digits)
- e = digits ;
+ case FMT_E:
+ case FMT_D:
+ i = g.scale_factor;
+ e -= i;
+ if (i < 0)
+ {
+ nbefore = 0;
+ nzero = -i;
+ nafter = d + i;
+ }
+ else if (i > 0)
+ {
+ nbefore = i;
+ nzero = 0;
+ nafter = (d - i) + 1;
+ }
+ else /* i == 0 */
+ {
+ nbefore = 0;
+ nzero = 0;
+ nafter = d;
+ }
- /* Minimum value of the width would be 2 */
- if (e < 2)
- e = 2;
+ if (ft = FMT_E)
+ expchar = 'E';
+ else
+ expchar = 'D';
+ break;
- nesign = 1 ; /* We must give a position for the 'exp_char' */
- if (e > 0)
- nesign = e + nesign + (esign != SIGN_NONE ? 1 : 0);
- }
+ case FMT_EN:
+ /* The exponent must be a multiple of three, with 1-3 digits before
+ the decimal point. */
+ e--;
+ if (e >= 0)
+ nbefore = e % 3;
+ else
+ {
+ nbefore = (-e) % 3;
+ if (nbefore != 0)
+ nbefore = 3 - nbefore;
+ }
+ e -= nbefore;
+ nbefore++;
+ nzero = 0;
+ nafter = d;
+ expchar = 'E';
+ break;
+ case FMT_ES:
+ e--;
+ nbefore = 1;
+ nzero = 0;
+ nafter = d;
+ expchar = 'E';
+ break;
- intval = n;
- intstr = itoa (intval);
- intlen = strlen (intstr);
+ default:
+ /* Should never happen. */
+ internal_error ("Unexpected format token");
+ }
- q = rtoa (n, len, d);
- digits = strlen (q);
+ /* Round the value. */
+ if (nbefore + nafter == 0)
+ ndigits = 0;
+ else if (nbefore + nafter < ndigits)
+ {
+ ndigits = nbefore + nafter;
+ i = ndigits;
+ if (digits[i] >= '5')
+ {
+ /* Propagate the carry. */
+ for (i--; i >= 0; i--)
+ {
+ if (digits[i] != '9')
+ {
+ digits[i]++;
+ break;
+ }
+ digits[i] = '0';
+ }
+
+ if (i < 0)
+ {
+ /* The carry overflowed. Fortunately we have some spare space
+ at the start of the buffer. We may discard some digits, but
+ this is ok because we already know they are zero. */
+ digits--;
+ digits[0] = '1';
+ if (ft == FMT_F)
+ {
+ if (nzero > 0)
+ {
+ nzero--;
+ nafter++;
+ }
+ else
+ nbefore++;
+ }
+ else if (ft == FMT_EN)
+ {
+ nbefore++;
+ if (nbefore == 4)
+ {
+ nbefore = 1;
+ e += 3;
+ }
+ }
+ else
+ e++;
+ }
+ }
+ }
+
+ /* Calculate the format of the exponent field. */
+ if (expchar)
+ {
+ edigits = 1;
+ for (i = abs (e); i >= 10; i /= 10)
+ edigits++;
+
+ if (f->u.real.e < 0)
+ {
+ /* Width not specified. Must be no more than 3 digits. */
+ if (e > 999 || e < -999)
+ edigits = -1;
+ else
+ {
+ edigits = 4;
+ if (e > 99 || e < -99)
+ expchar = ' ';
+ }
+ }
+ else
+ {
+ /* Exponent width specified, check it is wide enough. */
+ if (edigits > f->u.real.e)
+ edigits = -1;
+ else
+ edigits = f->u.real.e + 2;
+ }
+ }
+ else
+ edigits = 0;
- /* Select a width if none was specified. */
+ /* Pick a field size if none was specified. */
if (w <= 0)
- w = digits + nsign;
+ w = nbefore + nzero + nafter + 2;
- p = write_block (w);
- if (p == NULL)
+ /* Create the ouput buffer. */
+ out = write_block (w);
+ if (out == NULL)
return;
- base = p;
+ /* Zero values always output as positive, even if the value was negative
+ before rounding. */
+ for (i = 0; i < ndigits; i++)
+ {
+ if (digits[i] != '0')
+ break;
+ }
+ if (i == ndigits)
+ sign = calculate_sign (0);
- nblank = w - (nsign + intlen + d + nesign);
- if (nblank == -1 && ft != FMT_F)
- {
- with_exp = 0;
- nesign -= 1;
- nblank = w - (nsign + intlen + d + nesign);
- }
- /* don't let a leading '0' cause field overflow */
- if (nblank == -1 && ft == FMT_F && q[0] == '0')
- {
- q++;
- nblank = 0;
- }
+ /* Work out how much padding is needed. */
+ nblanks = w - (nbefore + nzero + nafter + edigits + 1);
+ if (sign != SIGN_NONE)
+ nblanks--;
+
+ /* Check the value fits in the specified field width. */
+ if (nblanks < 0 || edigits == -1)
+ {
+ star_fill (out, w);
+ return;
+ }
- if (nblank < 0)
+ /* See if we have space for a zero before the decimal point. */
+ if (nbefore == 0 && nblanks > 0)
{
- star_fill (p, w);
- goto done;
+ leadzero = 1;
+ nblanks--;
}
- memset (p, ' ', nblank);
- p += nblank;
+ else
+ leadzero = 0;
- switch (sign)
+ /* Padd to full field width. */
+ if (nblanks > 0)
{
- case SIGN_PLUS:
- *p++ = '+';
- break;
- case SIGN_MINUS:
- *p++ = '-';
- break;
- case SIGN_NONE:
- break;
+ memset (out, ' ', nblanks);
+ out += nblanks;
}
- memcpy (p, q, intlen + d + 1);
- p += intlen + d;
+ /* Output the initial sign (if any). */
+ if (sign == SIGN_PLUS)
+ *(out++) = '+';
+ else if (sign == SIGN_MINUS)
+ *(out++) = '-';
- if (nesign > 0)
+ /* Output an optional leading zero. */
+ if (leadzero)
+ *(out++) = '0';
+
+ /* Output the part before the decimal point, padding with zeros. */
+ if (nbefore > 0)
{
- if (with_exp)
- *p++ = exp_char;
- switch (esign)
- {
- case SIGN_PLUS:
- *p++ = '+';
- break;
- case SIGN_MINUS:
- *p++ = '-';
- break;
- case SIGN_NONE:
- break;
- }
- q = itoa (neval);
- digits = strlen (q);
+ if (nbefore > ndigits)
+ i = ndigits;
+ else
+ i = nbefore;
- for (itmp = 0; itmp < e - digits; itmp++)
- *p++ = '0';
- memcpy (p, q, digits);
- p[digits] = 0;
+ memcpy (out, digits, i);
+ while (i < nbefore)
+ out[i++] = '0';
+
+ digits += i;
+ ndigits -= i;
+ out += nbefore;
}
+ /* Output the decimal point. */
+ *(out++) = '.';
-done:
- return ;
+ /* Output leading zeros after the decimal point. */
+ if (nzero > 0)
+ {
+ for (i = 0; i < nzero; i++)
+ *(out++) = '0';
+ }
+
+ /* Output digits after the decimal point, padding with zeros. */
+ if (nafter > 0)
+ {
+ if (nafter > ndigits)
+ i = ndigits;
+ else
+ i = nafter;
+
+ memcpy (out, digits, i);
+ while (i < nafter)
+ out[i++] = '0';
+
+ digits += i;
+ ndigits -= i;
+ out += nafter;
+ }
+
+ /* Output the exponent. */
+ if (expchar)
+ {
+ if (expchar != ' ')
+ {
+ *(out++) = expchar;
+ edigits--;
+ }
+#if HAVE_SNPRINTF
+ snprintf (buffer, 32, "%+0*d", edigits, e);
+#else
+ sprintf (buffer, "%+0*d", edigits, e);
+#endif
+ memcpy (out, buffer, edigits);
+ }
}
+
void
write_l (fnode * f, char *source, int len)
{
char *p;
int64_t n;
-
+
p = write_block (f->u.w);
if (p == NULL)
return;
p[f->u.w - 1] = (n) ? 'T' : 'F';
}
-/* write_float() -- output a real number according to its format */
+/* Output a real number according to its format. */
static void
write_float (fnode *f, const char *source, int len)
n = extract_real (source, len);
if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
- {
- res = finite (n);
- if (res == 0)
- {
- nb = f->u.real.w;
- if (nb <= 4)
- nb = 4;
- p = write_block (nb);
- memset (p, ' ' , 1);
-
- res = isinf (n);
- if (res != 0)
- {
- if (res > 0)
- fin = '+';
- else
- fin = '-';
-
- memset (p + 1, fin, nb - 1);
- }
- else
- sprintf(p + 1, "NaN");
- return;
- }
- }
+ {
+ res = isfinite (n);
+ if (res == 0)
+ {
+ nb = f->u.real.w;
+ p = write_block (nb);
+ if (nb < 3)
+ {
+ memset (p, '*',nb);
+ return;
+ }
+
+ memset(p, ' ', nb);
+ res = !isnan (n);
+ if (res != 0)
+ {
+ if (signbit(n))
+ fin = '-';
+ else
+ fin = '+';
+
+ if (nb > 7)
+ memcpy(p + nb - 8, "Infinity", 8);
+ else
+ memcpy(p + nb - 3, "Inf", 3);
+ if (nb < 8 && nb > 3)
+ p[nb - 4] = fin;
+ else if (nb > 8)
+ p[nb - 9] = fin;
+ }
+ else
+ memcpy(p + nb - 3, "NaN", 3);
+ return;
+ }
+ }
if (f->format != FMT_G)
{
p = write_block (nb);
memset (p, ' ', nb);
}
- }
+ }
}
n = extract_int (source, len);
- /* Special case */
+ /* Special case: */
if (m == 0 && n == 0)
{
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
- * print something. */
+ print something. */
if (w == 0)
w = ((digits < m) ? m : digits);
if (digits < m)
nzero = m - digits;
- /* See if things will work */
+ /* See if things will work. */
nblank = w - (nzero + digits);
n = extract_int (source, len);
- /* Special case */
+ /* Special case: */
if (m == 0 && n == 0)
{
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
- * print something. */
+ print something. */
if (w == 0)
w = ((digits < m) ? m : digits) + nsign;
if (digits < m)
nzero = m - digits;
- /* See if things will work */
+ /* See if things will work. */
nblank = w - (nsign + nzero + digits);
}
-/* otoa()-- Convert unsigned octal to ascii */
+/* Convert unsigned octal to ascii. */
static char *
otoa (uint64_t n)
}
-/* btoa()-- Convert unsigned binary to ascii */
+/* Convert unsigned binary to ascii. */
static char *
btoa (uint64_t n)
void
write_d (fnode *f, const char *p, int len)
{
+
write_float (f, p, len);
}
void
write_e (fnode *f, const char *p, int len)
{
+
write_float (f, p, len);
}
void
write_f (fnode *f, const char *p, int len)
{
+
write_float (f, p, len);
}
void
write_en (fnode *f, const char *p, int len)
{
+
write_float (f, p, len);
}
void
write_es (fnode *f, const char *p, int len)
{
+
write_float (f, p, len);
}
-/* write_x()-- Take care of the X/TR descriptor */
+/* Take care of the X/TR descriptor. */
void
write_x (fnode * f)
}
-/* List-directed writing */
+/* List-directed writing. */
-/* write_char()-- Write a single character to the output. Returns
- * nonzero if something goes wrong. */
+/* Write a single character to the output. Returns nonzero if
+ something goes wrong. */
static int
write_char (char c)
}
-/* write_logical()-- Write a list-directed logical value */
+/* Write a list-directed logical value. */
static void
write_logical (const char *source, int length)
}
-/* write_integer()-- Write a list-directed integer value. */
+/* Write a list-directed integer value. */
static void
write_integer (const char *source, int length)
}
-/* write_character()-- Write a list-directed string. We have to worry
- * about delimiting the strings if the file has been opened in that
- * mode. */
+/* Write a list-directed string. We have to worry about delimiting
+ the strings if the file has been opened in that mode. */
static void
write_character (const char *source, int length)
}
-/* Output the Real number with default format.
- According to DEC fortran LRM, default format for
- REAL(4) is 1PG15.7E2, and for REAL(8) is 1PG25.15E3 */
+/* Output a real number with default format.
+ This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8). */
static void
write_real (const char *source, int length)
g.scale_factor = 1;
if (length < 8)
{
- f.u.real.w = 15;
+ f.u.real.w = 14;
f.u.real.d = 7;
f.u.real.e = 2;
}
else
{
- f.u.real.w = 24;
+ f.u.real.w = 23;
f.u.real.d = 15;
f.u.real.e = 3;
}
}
-/* write_separator()-- Write the separator between items. */
+/* Write the separator between items. */
static void
write_separator (void)
}
-/* list_formatted_write()-- Write an item with list formatting.
- * TODO: handle skipping to the next record correctly, particularly
- * with strings. */
+/* Write an item with list formatting.
+ TODO: handle skipping to the next record correctly, particularly
+ with strings. */
void
list_formatted_write (bt type, void *p, int len)
void
namelist_write (void)
{
- namelist_info * t1, *t2;
- int len,num;
- void * p;
+ namelist_info * t1, *t2;
+ int len,num;
+ void * p;
- num = 0;
- write_character("&",1);
- write_character (ioparm.namelist_name, ioparm.namelist_name_len);
- write_character("\n",1);
+ num = 0;
+ write_character("&",1);
+ write_character (ioparm.namelist_name, ioparm.namelist_name_len);
+ write_character("\n",1);
- if (ionml != NULL)
- {
- t1 = ionml;
- while (t1 != NULL)
- {
+ if (ionml != NULL)
+ {
+ t1 = ionml;
+ while (t1 != NULL)
+ {
num ++;
t2 = t1;
t1 = t1->next;
- write_character(t2->var_name, strlen(t2->var_name));
- write_character("=",1);
+ if (t2->var_name)
+ {
+ write_character(t2->var_name, strlen(t2->var_name));
+ write_character("=",1);
+ }
len = t2->len;
p = t2->mem_pos;
switch (t2->type)
write_logical (p, len);
break;
case BT_CHARACTER:
- write_character (p, len);
+ write_character (p, t2->string_length);
break;
case BT_REAL:
write_real (p, len);
default:
internal_error ("Bad type for namelist write");
}
- write_character(",",1);
- if (num > 5)
- {
- num = 0;
- write_character("\n",1);
- }
- }
- }
- write_character("/",1);
-
+ write_character(",",1);
+ if (num > 5)
+ {
+ num = 0;
+ write_character("\n",1);
+ }
+ }
+ }
+ write_character("/",1);
}
-
OSDN Git Service
