diff options
Diffstat (limited to 'gcc-4.8/libgfortran/io')
| -rw-r--r-- | gcc-4.8/libgfortran/io/io.h | 10 | ||||
| -rw-r--r-- | gcc-4.8/libgfortran/io/list_read.c | 55 | ||||
| -rw-r--r-- | gcc-4.8/libgfortran/io/read.c | 8 | ||||
| -rw-r--r-- | gcc-4.8/libgfortran/io/unit.c | 68 | ||||
| -rw-r--r-- | gcc-4.8/libgfortran/io/write_float.def | 73 |
5 files changed, 136 insertions, 78 deletions
diff --git a/gcc-4.8/libgfortran/io/io.h b/gcc-4.8/libgfortran/io/io.h index 8ea932667..10f09855f 100644 --- a/gcc-4.8/libgfortran/io/io.h +++ b/gcc-4.8/libgfortran/io/io.h @@ -424,7 +424,10 @@ typedef struct st_parameter_dt unsigned g0_no_blanks : 1; /* Used to signal use of free_format_data. */ unsigned format_not_saved : 1; - /* 14 unused bits. */ + /* A flag used to identify when a non-standard expanded namelist read + has occurred. */ + unsigned expanded_read : 1; + /* 13 unused bits. */ /* Used for ungetc() style functionality. Possible values are an unsigned char, EOF, or EOF - 1 used to mark the @@ -441,9 +444,8 @@ typedef struct st_parameter_dt char *line_buffer; struct format_data *fmt; namelist_info *ionml; - /* A flag used to identify when a non-standard expanded namelist read - has occurred. */ - int expanded_read; + /* Current position within the look-ahead line buffer. */ + int line_buffer_pos; /* Storage area for values except for strings. Must be large enough to hold a complex value (two reals) of the largest kind. */ diff --git a/gcc-4.8/libgfortran/io/list_read.c b/gcc-4.8/libgfortran/io/list_read.c index 60f4549cd..43f606085 100644 --- a/gcc-4.8/libgfortran/io/list_read.c +++ b/gcc-4.8/libgfortran/io/list_read.c @@ -118,7 +118,7 @@ free_saved (st_parameter_dt *dtp) static void free_line (st_parameter_dt *dtp) { - dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_pos = 0; dtp->u.p.line_buffer_enabled = 0; if (dtp->u.p.line_buffer == NULL) @@ -150,15 +150,15 @@ next_char (st_parameter_dt *dtp) { dtp->u.p.at_eol = 0; - c = dtp->u.p.line_buffer[dtp->u.p.item_count]; - if (c != '\0' && dtp->u.p.item_count < 64) + c = dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos]; + if (c != '\0' && dtp->u.p.line_buffer_pos < 64) { - dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0'; - dtp->u.p.item_count++; + dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos] = '\0'; + dtp->u.p.line_buffer_pos++; goto done; } - dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_pos = 0; dtp->u.p.line_buffer_enabled = 0; } @@ -640,7 +640,7 @@ l_push_char (st_parameter_dt *dtp, char c) if (dtp->u.p.line_buffer == NULL) dtp->u.p.line_buffer = xcalloc (SCRATCH_SIZE, 1); - dtp->u.p.line_buffer[dtp->u.p.item_count++] = c; + dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos++] = c; } @@ -750,7 +750,7 @@ read_logical (st_parameter_dt *dtp, int length) { dtp->u.p.nml_read_error = 1; dtp->u.p.line_buffer_enabled = 1; - dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_pos = 0; return; } @@ -758,14 +758,17 @@ read_logical (st_parameter_dt *dtp, int length) bad_logical: - free_line (dtp); - if (nml_bad_return (dtp, c)) + { + free_line (dtp); return; + } + free_saved (dtp); if (c == EOF) { + free_line (dtp); hit_eof (dtp); return; } @@ -773,6 +776,7 @@ read_logical (st_parameter_dt *dtp, int length) eat_line (dtp); snprintf (message, MSGLEN, "Bad logical value while reading item %d", dtp->u.p.item_count); + free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return; @@ -913,9 +917,9 @@ read_integer (st_parameter_dt *dtp, int length) else if (c != '\n') eat_line (dtp); - free_line (dtp); snprintf (message, MSGLEN, "Bad integer for item %d in list input", dtp->u.p.item_count); + free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return; @@ -1298,9 +1302,9 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) else if (c != '\n') eat_line (dtp); - free_line (dtp); snprintf (message, MSGLEN, "Bad floating point number for item %d", dtp->u.p.item_count); + free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; @@ -1406,9 +1410,9 @@ eol_4: else if (c != '\n') eat_line (dtp); - free_line (dtp); snprintf (message, MSGLEN, "Bad complex value in item %d of list input", dtp->u.p.item_count); + free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); } @@ -1770,7 +1774,7 @@ read_real (st_parameter_dt *dtp, void * dest, int length) { dtp->u.p.nml_read_error = 1; dtp->u.p.line_buffer_enabled = 1; - dtp->u.p.item_count = 0; + dtp->u.p.line_buffer_pos = 0; return; } @@ -1789,9 +1793,9 @@ read_real (st_parameter_dt *dtp, void * dest, int length) else if (c != '\n') eat_line (dtp); - free_line (dtp); snprintf (message, MSGLEN, "Bad real number in item %d of list input", dtp->u.p.item_count); + free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); } @@ -1806,11 +1810,10 @@ check_type (st_parameter_dt *dtp, bt type, int len) if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) { - free_line (dtp); snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d", type_name (dtp->u.p.saved_type), type_name (type), dtp->u.p.item_count); - + free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; } @@ -1820,12 +1823,12 @@ check_type (st_parameter_dt *dtp, bt type, int len) if (dtp->u.p.saved_length != len) { - free_line (dtp); snprintf (message, MSGLEN, "Read kind %d %s where kind %d is required for item %d", dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len, dtp->u.p.item_count); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); + free_line (dtp); return 1; } @@ -2031,8 +2034,6 @@ list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind, void finish_list_read (st_parameter_dt *dtp) { - int err; - free_saved (dtp); fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); @@ -2043,12 +2044,22 @@ finish_list_read (st_parameter_dt *dtp) return; } - err = eat_line (dtp); - if (err == LIBERROR_END) + if (!is_internal_unit (dtp)) + { + int c; + c = next_char (dtp); + if (c == EOF) { free_line (dtp); hit_eof (dtp); + return; + } + if (c != '\n') + eat_line (dtp); } + + free_line (dtp); + } /* NAMELIST INPUT diff --git a/gcc-4.8/libgfortran/io/read.c b/gcc-4.8/libgfortran/io/read.c index 2da1048f8..f45e1b4ed 100644 --- a/gcc-4.8/libgfortran/io/read.c +++ b/gcc-4.8/libgfortran/io/read.c @@ -655,7 +655,13 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) if (c == ' ') { - if (dtp->u.p.blank_status == BLANK_NULL) continue; + if (dtp->u.p.blank_status == BLANK_NULL) + { + /* Skip spaces. */ + for ( ; w > 0; p++, w--) + if (*p != ' ') break; + continue; + } if (dtp->u.p.blank_status == BLANK_ZERO) c = '0'; } diff --git a/gcc-4.8/libgfortran/io/unit.c b/gcc-4.8/libgfortran/io/unit.c index f8c1516e0..d1b1a712e 100644 --- a/gcc-4.8/libgfortran/io/unit.c +++ b/gcc-4.8/libgfortran/io/unit.c @@ -29,6 +29,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "unix.h" #include <stdlib.h> #include <string.h> +#include <stdbool.h> /* IO locking rules: @@ -375,6 +376,36 @@ find_or_create_unit (int n) } +/* Helper function to check rank, stride, format string, and namelist. + This is used for optimization. You can't trim out blanks or shorten + the string if trailing spaces are significant. */ +static bool +is_trim_ok (st_parameter_dt *dtp) +{ + /* Check rank and stride. */ + if (dtp->internal_unit_desc) + return false; + /* Format strings can not have 'BZ' or '/'. */ + if (dtp->common.flags & IOPARM_DT_HAS_FORMAT) + { + char *p = dtp->format; + off_t i; + if (dtp->common.flags & IOPARM_DT_HAS_BLANK) + return false; + for (i = 0; i < dtp->format_len; i++) + { + if (p[i] == '/') return false; + if (p[i] == 'b' || p[i] == 'B') + if (p[i+1] == 'z' || p[i+1] == 'Z') + return false; + } + } + if (dtp->u.p.ionml) /* A namelist. */ + return false; + return true; +} + + gfc_unit * get_internal_unit (st_parameter_dt *dtp) { @@ -402,6 +433,22 @@ get_internal_unit (st_parameter_dt *dtp) some other file I/O unit. */ iunit->unit_number = -1; + /* As an optimization, adjust the unit record length to not + include trailing blanks. This will not work under certain conditions + where trailing blanks have significance. */ + if (dtp->u.p.mode == READING && is_trim_ok (dtp)) + { + int len; + if (dtp->common.unit == 0) + len = string_len_trim (dtp->internal_unit_len, + dtp->internal_unit); + else + len = string_len_trim_char4 (dtp->internal_unit_len, + (const gfc_char4_t*) dtp->internal_unit); + dtp->internal_unit_len = len; + iunit->recl = dtp->internal_unit_len; + } + /* Set up the looping specification from the array descriptor, if any. */ if (is_array_io (dtp)) @@ -414,27 +461,6 @@ get_internal_unit (st_parameter_dt *dtp) start_record *= iunit->recl; } - else - { - /* If we are not processing an array, adjust the unit record length not - to include trailing blanks for list-formatted reads. */ - if (dtp->u.p.mode == READING && !(dtp->common.flags & IOPARM_DT_HAS_FORMAT)) - { - if (dtp->common.unit == 0) - { - dtp->internal_unit_len = - string_len_trim (dtp->internal_unit_len, dtp->internal_unit); - iunit->recl = dtp->internal_unit_len; - } - else - { - dtp->internal_unit_len = - string_len_trim_char4 (dtp->internal_unit_len, - (const gfc_char4_t*) dtp->internal_unit); - iunit->recl = dtp->internal_unit_len; - } - } - } /* Set initial values for unit parameters. */ if (dtp->common.unit) diff --git a/gcc-4.8/libgfortran/io/write_float.def b/gcc-4.8/libgfortran/io/write_float.def index 5b76fd596..acfa125cf 100644 --- a/gcc-4.8/libgfortran/io/write_float.def +++ b/gcc-4.8/libgfortran/io/write_float.def @@ -125,8 +125,6 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, int nzero; /* Number of digits after the decimal point. */ int nafter; - /* Number of zeros after the decimal point, whatever the precision. */ - int nzero_real; int leadzero; int nblanks; int ndigits, edigits; @@ -138,7 +136,6 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, p = dtp->u.p.scale_factor; rchar = '5'; - nzero_real = -1; /* We should always know the field width and precision. */ if (d < 0) @@ -191,7 +188,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, if (nafter < 0) nafter = 0; nafter = d; - nzero = nzero_real = 0; + nzero = 0; } else /* p < 0 */ { @@ -211,14 +208,13 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, nafter = d + nbefore; nbefore = 0; } - nzero_real = nzero; if (nzero > d) nzero = d; } } else { - nzero = nzero_real = 0; + nzero = 0; nafter = d; } @@ -373,7 +369,7 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, updown: rchar = '0'; - if (w > 0 && d == 0 && p == 0) + if (ft != FMT_F && w > 0 && d == 0 && p == 0) nbefore = 1; /* Scan for trailing zeros to see if we really need to round it. */ for(i = nbefore + nafter; i < ndigits; i++) @@ -386,13 +382,14 @@ output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, do_rnd: if (nbefore + nafter == 0) + /* Handle the case Fw.0 and value < 1.0 */ { ndigits = 0; - if (nzero_real == d && digits[0] >= rchar) + if (digits[0] >= rchar) { /* We rounded to zero but shouldn't have */ - nzero--; - nafter = 1; + nbefore = 1; + digits--; digits[0] = '1'; ndigits = 1; } @@ -990,13 +987,14 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \ int d = f->u.real.d;\ int w = f->u.real.w;\ fnode newf;\ - GFC_REAL_ ## x rexp_d, r = 0.5;\ + GFC_REAL_ ## x exp_d, r = 0.5, r_sc;\ int low, high, mid;\ int ubound, lbound;\ char *p, pad = ' ';\ int save_scale_factor, nb = 0;\ try result;\ int nprinted, precision;\ + volatile GFC_REAL_ ## x temp;\ \ save_scale_factor = dtp->u.p.scale_factor;\ \ @@ -1015,10 +1013,13 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \ break;\ }\ \ - rexp_d = calculate_exp_ ## x (-d);\ - if ((m > 0.0 && ((m < 0.1 - 0.1 * r * rexp_d) || (rexp_d * (m + r) >= 1.0)))\ + exp_d = calculate_exp_ ## x (d);\ + r_sc = (1 - r / exp_d);\ + temp = 0.1 * r_sc;\ + if ((m > 0.0 && ((m < temp) || (r >= (exp_d - m))))\ || ((m == 0.0) && !(compile_options.allow_std\ - & (GFC_STD_F2003 | GFC_STD_F2008))))\ + & (GFC_STD_F2003 | GFC_STD_F2008)))\ + || d == 0)\ { \ newf.format = FMT_E;\ newf.u.real.w = w;\ @@ -1038,10 +1039,9 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \ \ while (low <= high)\ { \ - volatile GFC_REAL_ ## x temp;\ mid = (low + high) / 2;\ \ - temp = (calculate_exp_ ## x (mid - 1) * (1 - r * rexp_d));\ + temp = (calculate_exp_ ## x (mid - 1) * r_sc);\ \ if (m < temp)\ { \ @@ -1121,14 +1121,36 @@ OUTPUT_FLOAT_FMT_G(16,L) /* EN format is tricky since the number of significant digits depends on the magnitude. Solve it by first printing a temporary value and figure out the number of significant digits from the printed - exponent. */ + exponent. Values y, 0.95*10.0**e <= y <10.0**e, are rounded to + 10.0**e even when the final result will not be rounded to 10.0**e. + For these values the exponent returned by atoi has to be decremented + by one. The values y in the ranges + (1000.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*(n+1)) + (100.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+2) + (10.0-0.5*10.0**(-d))*10.0**(3*n) <= y < 10.0*(3*n+1) + are correctly rounded respectively to 1.0...0*10.0*(3*(n+1)), + 100.0...0*10.0*(3*n), and 10.0...0*10.0*(3*n), where 0...0 + represents d zeroes, by the lines 279 to 297. */ #define EN_PREC(x,y)\ {\ - GFC_REAL_ ## x tmp; \ - tmp = * (GFC_REAL_ ## x *)source; \ + volatile GFC_REAL_ ## x tmp, one = 1.0;\ + tmp = * (GFC_REAL_ ## x *)source;\ if (isfinite (tmp)) \ - nprinted = DTOA(y,0,tmp); \ + {\ + nprinted = DTOA(y,0,tmp);\ + int e = atoi (&buffer[4]);\ + if (buffer[1] == '1')\ + {\ + tmp = (calculate_exp_ ## x (-e)) * tmp;\ + tmp = one - (tmp < 0 ? -tmp : tmp); \ + if (tmp > 0)\ + e = e - 1;\ + }\ + nbefore = e%3;\ + if (nbefore < 0)\ + nbefore = 3 + nbefore;\ + }\ else\ nprinted = -1;\ }\ @@ -1140,6 +1162,7 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, int nprinted; char buffer[10]; const size_t size = 10; + int nbefore; /* digits before decimal point - 1. */ switch (len) { @@ -1172,16 +1195,6 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, if (nprinted == -1) return -1; - int e = atoi (&buffer[5]); - int nbefore; /* digits before decimal point - 1. */ - if (e >= 0) - nbefore = e % 3; - else - { - nbefore = (-e) % 3; - if (nbefore != 0) - nbefore = 3 - nbefore; - } int prec = f->u.real.d + nbefore; if (dtp->u.p.current_unit->round_status != ROUND_UNSPECIFIED && dtp->u.p.current_unit->round_status != ROUND_PROCDEFINED) |