This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
PR fortran/35862 * io.c (format_token): Add enumerators for rounding format specifiers. (format_lex): Tokenize the rounding format specifiers. (gfc_match_open): Enable rounding modes in OPEN statement.
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.
Index: gcc/testsuite/gfortran.dg/f2003_io_3.f03 =================================================================== --- gcc/testsuite/gfortran.dg/f2003_io_3.f03 (revision 152187) +++ gcc/testsuite/gfortran.dg/f2003_io_3.f03 (working copy) @@ -11,7 +11,7 @@ a = 43.21 WRITE(99,'(10f8.3)',decimal="comma") a rewind(99) read(99,'(dc,10f8.3)',blank=msg) b -write(99,'(dp,10f8.3)',round="up") ! { dg-error "not implemented" } +write(99,'(dp,10f8.3)',round="up") rewind(99) read(99,'(10f8.3)',pad="yes") msg="suppress" Index: gcc/fortran/io.c =================================================================== --- gcc/fortran/io.c (revision 152187) +++ gcc/fortran/io.c (working copy) @@ -111,7 +111,8 @@ typedef enum FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, - FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR + FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC, + FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ } format_token; @@ -467,6 +468,35 @@ format_lex (void) } break; + case 'R': + c = next_char_not_space (&error); + switch (c) + { + 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: + token = FMT_UNKNOWN; + unget_char (); + break; + } + break; + case '\0': token = FMT_END; break; @@ -623,6 +653,12 @@ format_item_1: case FMT_BLANK: case FMT_DP: case FMT_DC: + case FMT_RC: + case FMT_RD: + case FMT_RN: + case FMT_RP: + case FMT_RU: + case FMT_RZ: goto between_desc; case FMT_CHAR: @@ -1924,8 +1960,8 @@ gfc_match_open (void) /* Checks on the ROUND specifier. */ if (open->round) { - /* When implemented, change the following to use gfc_notify_std F2003. */ - gfc_error ("Fortran F2003: ROUND= specifier at %C not implemented"); + if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C " + "not allowed in Fortran 95") == FAILURE) goto cleanup; if (open->round->expr_type == EXPR_CONSTANT) @@ -3275,12 +3311,9 @@ if (condition) \ if (dt->round) { - /* When implemented, change the following to use gfc_notify_std F2003. if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C " "not allowed in Fortran 95") == FAILURE) - return MATCH_ERROR; */ - gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented"); - return MATCH_ERROR; + return MATCH_ERROR; if (dt->round->expr_type == EXPR_CONSTANT) { Index: libgfortran/io/io.h =================================================================== --- libgfortran/io/io.h (revision 152187) +++ libgfortran/io/io.h (working copy) @@ -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; Index: libgfortran/io/transfer.c =================================================================== --- libgfortran/io/transfer.c (revision 152187) +++ libgfortran/io/transfer.c (working copy) @@ -101,7 +101,17 @@ 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}, {"suppress", SIGN_SS}, @@ -1202,7 +1212,37 @@ formatted_transfer_scalar_read (st_parameter_dt *d 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; dtp->u.p.scale_factor = f->u.k; @@ -1566,6 +1606,36 @@ formatted_transfer_scalar_write (st_parameter_dt * 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 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->decimal_status == DECIMAL_UNSPECIFIED) + dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal; + /* Check the sign mode. */ dtp->u.p.sign_status = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED : Index: libgfortran/io/format.c =================================================================== --- libgfortran/io/format.c (revision 152187) +++ libgfortran/io/format.c (working copy) @@ -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 *sav 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: Index: libgfortran/io/write_float.def =================================================================== --- libgfortran/io/write_float.def (revision 152187) +++ libgfortran/io/write_float.def (working copy) @@ -68,7 +68,7 @@ output_float (st_parameter_dt *dtp, const fnode *f 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 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 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 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 } } + skip: + /* Calculate the format of the exponent field. */ if (expchar) {
Attachment:
round_1.f03
Description: Text document
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |