summaryrefslogtreecommitdiff
path: root/libgfortran/io
diff options
context:
space:
mode:
Diffstat (limited to 'libgfortran/io')
-rw-r--r--libgfortran/io/format.c40
-rw-r--r--libgfortran/io/io.h3
-rw-r--r--libgfortran/io/transfer.c80
-rw-r--r--libgfortran/io/unit.c4
-rw-r--r--libgfortran/io/write_float.def83
5 files changed, 195 insertions, 15 deletions
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index e888a2eba3f..4ab70e8c3ad 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -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:
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 9ca6d387480..51143f548aa 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -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;
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 4525bb49c88..06a1d2eb984 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -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 :
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index d8d0c29a8f5..5dc3538f264 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -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;
diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
index 9804d7b9ab1..e6880027a86 100644
--- a/libgfortran/io/write_float.def
+++ b/libgfortran/io/write_float.def
@@ -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)
{
View Lorry Controller Status