OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR libfortran/35862 ([F2003] Implement new rounding modes for run time) 

2009-09-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/35862
	* io.h (gfc_unit): Add round_status.
	(format_token): Add enumerators for rounding format specifiers.
	* transfer.c (round_opt): New options table.
	(formatted_transfer_scalar_read): Add set round_status for each rounding
	format token. (formatted_transfer_scalar_write): Likewise.
	* format.c (format_lex): Tokenize the rounding format specifiers.
	(parse_format_list): Parse the rounding format specifiers.
	* write_float.def (outout_float): Modify rounding code to use new
	variable rchar to set the appropriate rounding. Fix some whitespace.
	* unit.c (get_internal_unit): Initialize rounding mode for internal
	units. (init_units): Likewise.

From-SVN: r152263
This commit is contained in:
Jerry DeLisle 2009-09-29 02:47:54 +00:00
parent f2a71504e0
commit 379924dd59
6 changed files with 210 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
libgfortran/ChangeLog
View File

@ -1,3 +1,18 @@
2009-09-28 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/35862
* io.h (gfc_unit): Add round_status.
(format_token): Add enumerators for rounding format specifiers.
* transfer.c (round_opt): New options table.
(formatted_transfer_scalar_read): Add set round_status for each rounding
format token. (formatted_transfer_scalar_write): Likewise.
* format.c (format_lex): Tokenize the rounding format specifiers.
(parse_format_list): Parse the rounding format specifiers.
* write_float.def (outout_float): Modify rounding code to use new
variable rchar to set the appropriate rounding. Fix some whitespace.
* unit.c (get_internal_unit): Initialize rounding mode for internal
units. (init_units): Likewise.
2009-09-19 Iain Sandoe <iain.sandoe@sandoe-acoustics.co.uk>
* configure.ac: Check for GFORTRAN_C99_1.1 funcs in OS libm.

40
libgfortran/io/format.c
View File

@ -564,6 +564,34 @@ format_lex (format_data *fmt)
}
break;
case 'R':
switch (next_char (fmt, 0))
{
case 'C':
token = FMT_RC;
break;
case 'D':
token = FMT_RD;
break;
case 'N':
token = FMT_RN;
break;
case 'P':
token = FMT_RP;
break;
case 'U':
token = FMT_RU;
break;
case 'Z':
token = FMT_RZ;
break;
default:
unget_char (fmt);
token = FMT_UNKNOWN;
break;
}
break;
case -1:
token = FMT_END;
break;
@ -713,6 +741,18 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok)
tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
case FMT_RC:
case FMT_RD:
case FMT_RN:
case FMT_RP:
case FMT_RU:
case FMT_RZ:
notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: Round "
"descriptor not allowed");
get_fnode (fmt, &head, &tail, t);
tail->repeat = 1;
goto between_desc;
case FMT_DC:
case FMT_DP:

3
libgfortran/io/io.h
View File

@ -602,6 +602,7 @@ typedef struct gfc_unit
unit_pad pad_status;
unit_decimal decimal_status;
unit_delim delim_status;
unit_round round_status;
/* recl -- Record length of the file.
last_record -- Last record number read or written
@ -654,7 +655,7 @@ typedef enum
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
FMT_DP, FMT_STAR
FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
}
format_token;

80
libgfortran/io/transfer.c
View File

@ -101,6 +101,16 @@ static const st_option decimal_opt[] = {
{NULL, 0}
};
static const st_option round_opt[] = {
{"up", ROUND_UP},
{"down", ROUND_DOWN},
{"zero", ROUND_ZERO},
{"nearest", ROUND_NEAREST},
{"compatible", ROUND_COMPATIBLE},
{"processor_defined", ROUND_PROCDEFINED},
{NULL, 0}
};
static const st_option sign_opt[] = {
{"plus", SIGN_SP},
@ -1202,6 +1212,36 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
consume_data_flag = 0;
dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
break;
case FMT_RC:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
break;
case FMT_RD:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_DOWN;
break;
case FMT_RN:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_NEAREST;
break;
case FMT_RP:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
break;
case FMT_RU:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_UP;
break;
case FMT_RZ:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_ZERO;
break;
case FMT_P:
consume_data_flag = 0;
@ -1566,6 +1606,36 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
break;
case FMT_RC:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
break;
case FMT_RD:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_DOWN;
break;
case FMT_RN:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_NEAREST;
break;
case FMT_RP:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
break;
case FMT_RU:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_UP;
break;
case FMT_RZ:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_ZERO;
break;
case FMT_P:
consume_data_flag = 0;
dtp->u.p.scale_factor = f->u.k;
@ -2252,6 +2322,16 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
/* Check the round mode. */
dtp->u.p.current_unit->round_status
= !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
find_option (&dtp->common, dtp->round, dtp->round_len,
round_opt, "Bad ROUND parameter in data transfer "
"statement");
if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
/* Check the sign mode. */
dtp->u.p.sign_status
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :

4
libgfortran/io/unit.c
View File

@ -441,6 +441,7 @@ get_internal_unit (st_parameter_dt *dtp)
iunit->flags.decimal = DECIMAL_POINT;
iunit->flags.encoding = ENCODING_DEFAULT;
iunit->flags.async = ASYNC_NO;
iunit->flags.round = ROUND_COMPATIBLE;
/* Initialize the data transfer parameters. */
@ -531,6 +532,7 @@ init_units (void)
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
u->flags.async = ASYNC_NO;
u->flags.round = ROUND_COMPATIBLE;
u->recl = options.default_recl;
u->endfile = NO_ENDFILE;
@ -560,6 +562,7 @@ init_units (void)
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
u->flags.async = ASYNC_NO;
u->flags.round = ROUND_COMPATIBLE;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
@ -589,6 +592,7 @@ init_units (void)
u->flags.decimal = DECIMAL_POINT;
u->flags.encoding = ENCODING_DEFAULT;
u->flags.async = ASYNC_NO;
u->flags.round = ROUND_COMPATIBLE;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;

83
libgfortran/io/write_float.def
View File

@ -68,7 +68,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
char *out;
char *digits;
int e;
char expchar;
char expchar, rchar;
format_token ft;
int w;
int d;
@ -89,6 +89,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
w = f->u.real.w;
d = f->u.real.d;
rchar = '5';
nzero_real = -1;
/* We should always know the field width and precision. */
@ -235,24 +236,75 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
internal_error (&dtp->common, "Unexpected format token");
}
/* Round the value. */
/* Round the value. The value being rounded is an unsigned magnitude.
The ROUND_COMPATIBLE is rounding away from zero when there is a tie. */
switch (dtp->u.p.current_unit->round_status)
{
case ROUND_ZERO: /* Do nothing and truncation occurs. */
goto skip;
case ROUND_UP:
if (sign_bit)
goto skip;
rchar = '0';
break;
case ROUND_DOWN:
if (!sign_bit)
goto skip;
rchar = '0';
break;
case ROUND_NEAREST:
/* Round compatible unless there is a tie. A tie is a 5 with
all trailing zero's. */
i = nafter + 1;
if (digits[i] == '5')
{
for(i++ ; i < ndigits; i++)
{
if (digits[i] != '0')
goto do_rnd;
}
/* It is a tie so round to even. */
switch (digits[nafter])
{
case '1':
case '3':
case '5':
case '7':
case '9':
/* If odd, round away from zero to even. */
break;
default:
/* If even, skip rounding, truncate to even. */
goto skip;
}
}
/* Fall through. */
case ROUND_PROCDEFINED:
case ROUND_UNSPECIFIED:
case ROUND_COMPATIBLE:
rchar = '5';
/* Just fall through and do the actual rounding. */
}
do_rnd:
if (nbefore + nafter == 0)
{
ndigits = 0;
if (nzero_real == d && digits[0] >= '5')
{
/* We rounded to zero but shouldn't have */
nzero--;
nafter = 1;
digits[0] = '1';
ndigits = 1;
}
if (nzero_real == d && digits[0] >= rchar)
{
/* We rounded to zero but shouldn't have */
nzero--;
nafter = 1;
digits[0] = '1';
ndigits = 1;
}
}
else if (nbefore + nafter < ndigits)
{
ndigits = nbefore + nafter;
i = ndigits;
if (digits[i] >= '5')
if (digits[i] >= rchar)
{
/* Propagate the carry. */
for (i--; i >= 0; i--)
@ -267,9 +319,10 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
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. */
/* 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)
@ -297,6 +350,8 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size,
}
}
skip:
/* Calculate the format of the exponent field. */
if (expchar)
{