diff options
author | Jerry DeLisle <jvdelisle@gcc.gnu.org> | 2009-09-29 02:47:54 +0000 |
---|---|---|
committer | Jerry DeLisle <jvdelisle@gcc.gnu.org> | 2009-09-29 02:47:54 +0000 |
commit | 379924dd5991228b5e65fac5815ecac0d389a786 (patch) | |
tree | b230ba0e2e2c68e0265fe9335396a5deeeb603e0 | |
parent | f2a71504e00cb7785bdc78b12da8d1608762f6cc (diff) | |
download | gcc-379924dd5991228b5e65fac5815ecac0d389a786.zip gcc-379924dd5991228b5e65fac5815ecac0d389a786.tar.gz gcc-379924dd5991228b5e65fac5815ecac0d389a786.tar.bz2 |
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
-rw-r--r-- | libgfortran/ChangeLog | 15 | ||||
-rw-r--r-- | libgfortran/io/format.c | 40 | ||||
-rw-r--r-- | libgfortran/io/io.h | 3 | ||||
-rw-r--r-- | libgfortran/io/transfer.c | 80 | ||||
-rw-r--r-- | libgfortran/io/unit.c | 4 | ||||
-rw-r--r-- | libgfortran/io/write_float.def | 83 |
6 files changed, 210 insertions, 15 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index ab6348b..2530bf7 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -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. diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index e888a2e..4ab70e8 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 9ca6d38..51143f5 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 4525bb4..06a1d2e 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 d8d0c29..5dc3538 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 9804d7b..e688002 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) { |