OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
690c364e3e
gcc/libgfortran/io/write.c
Paul Brook 6d3e9d8454 * io/format.c (write_real): Don't include padding in format. 
From-SVN: r81922
2004-05-16 20:17:04 +00:00

1151 lines
20 KiB
C
Raw Blame History

/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 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
the Free Software Foundation; either version 2, or (at your option)
any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
#include "config.h"
#include <string.h>
#include <float.h>
#include "libgfortran.h"
#include "io.h"
#include <stdio.h>
#define star_fill(p, n) memset(p, '*', n)
typedef enum
{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
sign_t;
void
write_a (fnode * f, const char *source, int len)
{
int wlen;
char *p;
wlen = f->u.string.length < 0 ? len : f->u.string.length;
p = write_block (wlen);
if (p == NULL)
return;
if (wlen < len)
memcpy (p, source, wlen);
else
{
memset (p, ' ', wlen - len);
memcpy (p + wlen - len, source, len);
}
}
static int64_t
extract_int (const void *p, int len)
{
int64_t i = 0;
if (p == NULL)
return i;
switch (len)
{
case 1:
i = *((const int8_t *) p);
break;
case 2:
i = *((const int16_t *) p);
break;
case 4:
i = *((const int32_t *) p);
break;
case 8:
i = *((const int64_t *) p);
break;
default:
internal_error ("bad integer kind");
}
return i;
}
static double
extract_real (const void *p, int len)
{
double i = 0.0;
switch (len)
{
case 4:
i = *((const float *) p);
break;
case 8:
i = *((const double *) p);
break;
default:
internal_error ("bad real kind");
}
return i;
}
/* 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. */
static sign_t
calculate_sign (int negative_flag)
{
sign_t s = SIGN_NONE;
if (negative_flag)
s = SIGN_MINUS;
else
switch (g.sign_status)
{
case SIGN_SP:
s = SIGN_PLUS;
break;
case SIGN_SS:
s = SIGN_NONE;
break;
case SIGN_S:
s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
break;
}
return s;
}
/* calculate_exp()-- returns the value of 10**d. */
static double
calculate_exp (int d)
{
int i;
double r = 1.0;
for (i = 0; i< (d >= 0 ? d : -d); i++)
r *= 10;
r = (d >= 0) ? r : 1.0 / r;
return r;
}
/* 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
LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
Data Magnitude Equivalent Conversion
0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
m = 0 F(w-n).(d-1), n' '
0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
................ ..........
10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
m >= 10**d-0.5 Ew.d[Ee]
notes: for Gw.d , n' ' means 4 blanks
for Gw.dEe, n' ' means e+2 blanks */
static fnode *
calculate_G_format (fnode *f, double value, int len, int *num_blank)
{
int e = f->u.real.e;
int d = f->u.real.d;
int w = f->u.real.w;
fnode *newf;
double m, exp_d;
int low, high, mid;
int ubound, lbound;
newf = get_mem (sizeof (fnode));
/* Absolute value. */
m = (value > 0.0) ? value : -value;
/* In case of the two data magnitude ranges,
generate E editing, Ew.d[Ee]. */
exp_d = calculate_exp (d);
if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
|| (m >= (double) exp_d - 0.5 ))
{
newf->format = FMT_E;
newf->u.real.w = w;
newf->u.real.d = d;
newf->u.real.e = e;
*num_blank = e + 2;
return newf;
}
/* Use binary search to find the data magnitude range. */
mid = 0;
low = 0;
high = d + 1;
lbound = 0;
ubound = d + 1;
while (low <= high)
{
double temp;
mid = (low + high) / 2;
/* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
if (m < temp)
{
ubound = mid;
if (ubound == lbound + 1)
break;
high = mid - 1;
}
else if (m > temp)
{
lbound = mid;
if (ubound == lbound + 1)
{
mid ++;
break;
}
low = mid + 1;
}
else
break;
}
/* Generate the F editing. F(w-4).(-(mid-d-1)), 4' '. */
newf->format = FMT_F;
newf->u.real.w = f->u.real.w - 4;
/* Special case. */
if (m == 0.0)
newf->u.real.d = d - 1;
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 */
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;
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;
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)
{
e = f->u.real.e;
}
if (ft == FMT_F || ft == FMT_E || ft == FMT_D)
{
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 ++ ;
}
}
if (ft == FMT_EN )
{
minv = 1.0;
maxv = 1000.0;
}
if (ft == FMT_ES)
{
minv = 1.0;
maxv = 10.0;
}
/* 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 ++;
}
}
/* 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)
{
/* 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;
/* Got the width of EXP */
if (e < digits)
e = digits ;
/* Minimum value of the width would be 2 */
if (e < 2)
e = 2;
nesign = 1 ; /* We must give a position for the 'exp_char' */
if (e > 0)
nesign = e + nesign + (esign != SIGN_NONE ? 1 : 0);
}
intval = n;
intstr = itoa (intval);
intlen = strlen (intstr);
q = rtoa (n, len, d);
digits = strlen (q);
/* Select a width if none was specified. */
if (w <= 0)
w = digits + nsign;
p = write_block (w);
if (p == NULL)
return;
base = p;
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;
}
if (nblank < 0)
{
star_fill (p, w);
goto done;
}
memset (p, ' ', nblank);
p += nblank;
switch (sign)
{
case SIGN_PLUS:
*p++ = '+';
break;
case SIGN_MINUS:
*p++ = '-';
break;
case SIGN_NONE:
break;
}
memcpy (p, q, intlen + d + 1);
p += intlen + d;
if (nesign > 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);
for (itmp = 0; itmp < e - digits; itmp++)
*p++ = '0';
memcpy (p, q, digits);
p[digits] = 0;
}
done:
return ;
}
void
write_l (fnode * f, char *source, int len)
{
char *p;
int64_t n;
p = write_block (f->u.w);
if (p == NULL)
return;
memset (p, ' ', f->u.w - 1);
n = extract_int (source, len);
p[f->u.w - 1] = (n) ? 'T' : 'F';
}
/* write_float() -- output a real number according to its format */
static void
write_float (fnode *f, const char *source, int len)
{
double n;
int nb =0, res;
char * p, fin;
fnode *f2 = NULL;
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;
}
}
if (f->format != FMT_G)
{
output_float (f, n, len);
}
else
{
f2 = calculate_G_format(f, n, len, &nb);
output_float (f2, n, len);
if (f2 != NULL)
free_mem(f2);
if (nb > 0)
{
p = write_block (nb);
memset (p, ' ', nb);
}
}
}
static void
write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
{
uint32_t ns =0;
uint64_t n = 0;
int w, m, digits, nzero, nblank;
char *p, *q;
w = f->u.integer.w;
m = f->u.integer.m;
n = extract_int (source, len);
/* Special case */
if (m == 0 && n == 0)
{
if (w == 0)
w = 1;
p = write_block (w);
if (p == NULL)
return;
memset (p, ' ', w);
goto done;
}
if (len < 8)
{
ns = n;
q = conv (ns);
}
else
q = conv (n);
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
* print something. */
if (w == 0)
w = ((digits < m) ? m : digits);
p = write_block (w);
if (p == NULL)
return;
nzero = 0;
if (digits < m)
nzero = m - digits;
/* See if things will work */
nblank = w - (nzero + digits);
if (nblank < 0)
{
star_fill (p, w);
goto done;
}
memset (p, ' ', nblank);
p += nblank;
memset (p, '0', nzero);
p += nzero;
memcpy (p, q, digits);
done:
return;
}
static void
write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
{
int64_t n = 0;
int w, m, digits, nsign, nzero, nblank;
char *p, *q;
sign_t sign;
w = f->u.integer.w;
m = f->u.integer.m;
n = extract_int (source, len);
/* Special case */
if (m == 0 && n == 0)
{
if (w == 0)
w = 1;
p = write_block (w);
if (p == NULL)
return;
memset (p, ' ', w);
goto done;
}
sign = calculate_sign (n < 0);
if (n < 0)
n = -n;
nsign = sign == SIGN_NONE ? 0 : 1;
q = conv (n);
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
* print something. */
if (w == 0)
w = ((digits < m) ? m : digits) + nsign;
p = write_block (w);
if (p == NULL)
return;
nzero = 0;
if (digits < m)
nzero = m - digits;
/* See if things will work */
nblank = w - (nsign + nzero + digits);
if (nblank < 0)
{
star_fill (p, w);
goto done;
}
memset (p, ' ', nblank);
p += nblank;
switch (sign)
{
case SIGN_PLUS:
*p++ = '+';
break;
case SIGN_MINUS:
*p++ = '-';
break;
case SIGN_NONE:
break;
}
memset (p, '0', nzero);
p += nzero;
memcpy (p, q, digits);
done:
return;
}
/* otoa()-- Convert unsigned octal to ascii */
static char *
otoa (uint64_t n)
{
char *p;
if (n == 0)
{
scratch[0] = '0';
scratch[1] = '\0';
return scratch;
}
p = scratch + sizeof (SCRATCH_SIZE) - 1;
*p-- = '\0';
while (n != 0)
{
*p = '0' + (n & 7);
p -- ;
n >>= 3;
}
return ++p;
}
/* btoa()-- Convert unsigned binary to ascii */
static char *
btoa (uint64_t n)
{
char *p;
if (n == 0)
{
scratch[0] = '0';
scratch[1] = '\0';
return scratch;
}
p = scratch + sizeof (SCRATCH_SIZE) - 1;
*p-- = '\0';
while (n != 0)
{
*p-- = '0' + (n & 1);
n >>= 1;
}
return ++p;
}
void
write_i (fnode * f, const char *p, int len)
{
write_decimal (f, p, len, (void *) itoa);
}
void
write_b (fnode * f, const char *p, int len)
{
write_int (f, p, len, btoa);
}
void
write_o (fnode * f, const char *p, int len)
{
write_int (f, p, len, otoa);
}
void
write_z (fnode * f, const char *p, int len)
{
write_int (f, p, len, xtoa);
}
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 */
void
write_x (fnode * f)
{
char *p;
p = write_block (f->u.n);
if (p == NULL)
return;
memset (p, ' ', f->u.n);
}
/* List-directed writing */
/* write_char()-- Write a single character to the output. Returns
* nonzero if something goes wrong. */
static int
write_char (char c)
{
char *p;
p = write_block (1);
if (p == NULL)
return 1;
*p = c;
return 0;
}
/* write_logical()-- Write a list-directed logical value */
static void
write_logical (const char *source, int length)
{
write_char (extract_int (source, length) ? 'T' : 'F');
}
/* write_integer()-- Write a list-directed integer value. */
static void
write_integer (const char *source, int length)
{
char *p;
const char *q;
int digits;
int width;
q = itoa (extract_int (source, length));
switch (length)
{
case 1:
width = 4;
break;
case 2:
width = 6;
break;
case 4:
width = 11;
break;
case 8:
width = 20;
break;
default:
width = 0;
break;
}
digits = strlen (q);
if(width < digits )
width = digits ;
p = write_block (width) ;
memset(p ,' ', width - digits) ;
memcpy (p + width - digits, q, digits);
}
/* write_character()-- 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)
{
int i, extra;
char *p, d;
switch (current_unit->flags.delim)
{
case DELIM_APOSTROPHE:
d = '\'';
break;
case DELIM_QUOTE:
d = '"';
break;
default:
d = ' ';
break;
}
if (d == ' ')
extra = 0;
else
{
extra = 2;
for (i = 0; i < length; i++)
if (source[i] == d)
extra++;
}
p = write_block (length + extra);
if (p == NULL)
return;
if (d == ' ')
memcpy (p, source, length);
else
{
*p++ = d;
for (i = 0; i < length; i++)
{
*p++ = source[i];
if (source[i] == d)
*p++ = d;
}
*p = d;
}
}
/* Output the Real number with default format.
REAL(4) is 1PG14.7E2, and REAL(8) is 1PG23.15E3 */
static void
write_real (const char *source, int length)
{
fnode f ;
int org_scale = g.scale_factor;
f.format = FMT_G;
g.scale_factor = 1;
if (length < 8)
{
f.u.real.w = 14;
f.u.real.d = 7;
f.u.real.e = 2;
}
else
{
f.u.real.w = 23;
f.u.real.d = 15;
f.u.real.e = 3;
}
write_float (&f, source , length);
g.scale_factor = org_scale;
}
static void
write_complex (const char *source, int len)
{
if (write_char ('('))
return;
write_real (source, len);
if (write_char (','))
return;
write_real (source + len, len);
write_char (')');
}
/* write_separator()-- Write the separator between items. */
static void
write_separator (void)
{
char *p;
p = write_block (options.separator_len);
if (p == NULL)
return;
memcpy (p, options.separator, options.separator_len);
}
/* list_formatted_write()-- 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)
{
static int char_flag;
if (current_unit == NULL)
return;
if (g.first_item)
{
g.first_item = 0;
char_flag = 0;
write_char (' ');
}
else
{
if (type != BT_CHARACTER || !char_flag ||
current_unit->flags.delim != DELIM_NONE)
write_separator ();
}
switch (type)
{
case BT_INTEGER:
write_integer (p, len);
break;
case BT_LOGICAL:
write_logical (p, len);
break;
case BT_CHARACTER:
write_character (p, len);
break;
case BT_REAL:
write_real (p, len);
break;
case BT_COMPLEX:
write_complex (p, len);
break;
default:
internal_error ("list_formatted_write(): Bad type");
}
char_flag = (type == BT_CHARACTER);
}
void
namelist_write (void)
{
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);
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);
len = t2->len;
p = t2->mem_pos;
switch (t2->type)
{
case BT_INTEGER:
write_integer (p, len);
break;
case BT_LOGICAL:
write_logical (p, len);
break;
case BT_CHARACTER:
write_character (p, len);
break;
case BT_REAL:
write_real (p, len);
break;
case BT_COMPLEX:
write_complex (p, len);
break;
default:
internal_error ("Bad type for namelist write");
}
write_character(",",1);
if (num > 5)
{
num = 0;
write_character("\n",1);
}
}
}
write_character("/",1);
}
Reference in New Issue View Git Blame Copy Permalink