From: Tobias Burnus Date: Thu, 4 Apr 2013 09:31:53 +0000 (+0200) Subject: backport: re PR libfortran/56737 (Wrong I/O result with format cache for Hollerith... X-Git-Tag: releases/gcc-4.6.4~59 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=9a6bf0318d22386762659c9adbd0dffe27587439;p=thirdparty%2Fgcc.git backport: re PR libfortran/56737 (Wrong I/O result with format cache for Hollerith strings) libgfortran/ 2013-04-04 Tobias Burnus Backport from mainline: 2013-03-29 Tobias Burnus PR fortran/56737 * io/format.c (parse_format): With caching, copy dtp->format string. (save_parsed_format): Use dtp->format directly without copying. 2012-03-29 Tobias Burnus PR fortran/56737 * io/format.c (parse_format_list): Also cache FMT_STRING. (parse_format): Update call. gcc/testsuite/ 2013-04-04 Tobias Burnus Backport from mainline: 2013-03-29 Tobias Burnus PR fortran/56737 * testsuite/gfortran.dg/fmt_cache_3.f90: New. From-SVN: r197474 --- diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2dcfa1ef07d7..cd660f6e3fa0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2013-04-04 Tobias Burnus + + Backport from mainline: + 2013-03-29 Tobias Burnus + + PR fortran/56737 + * testsuite/gfortran.dg/fmt_cache_3.f90: New. + 2013-04-04 Tobias Burnus Backport from mainline: diff --git a/gcc/testsuite/gfortran.dg/fmt_cache_3.f90 b/gcc/testsuite/gfortran.dg/fmt_cache_3.f90 new file mode 100644 index 000000000000..ec8e1b389f9f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fmt_cache_3.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! PR fortran/56737 +! +! Contributed by Jonathan Hogg +! +module hsl_mc73_single + implicit none + integer, parameter, private :: wp = kind(0.0) +contains + subroutine mc73_fiedler(n,lirn,irn,ip,list) + integer, intent (in) :: n + integer, intent (in) :: lirn + integer, intent (in) :: irn(*) + integer, intent (in) :: ip(*) + integer, intent (out) :: list(*) + + integer :: icntl(10) + + call fiedler_graph(icntl) + end subroutine mc73_fiedler + + subroutine mc73_order + integer :: icntl(10) + + call fiedler_graph(icntl) + end subroutine mc73_order + + subroutine fiedler_graph(icntl) + integer, intent (in) :: icntl(10) + + real (kind = wp) :: tol + real (kind = wp) :: tol1 + real (kind = wp) :: rtol + + call multilevel_eig(tol,tol1,rtol,icntl) + end subroutine fiedler_graph + + subroutine multilevel_eig(tol,tol1,rtol,icntl) + real (kind = wp), intent (in) :: tol,tol1,rtol + integer, intent(in) :: icntl(10) + + call level_print(6,'end of level ',1) + end subroutine multilevel_eig + + subroutine level_print(mp,title1,level) + character (len = *), intent(in) :: title1 + integer, intent(in) :: mp,level + character(len=80) fmt + integer :: char_len1,char_len2 + + char_len1=len_trim(title1) + + write (fmt,"('(',i4,'(1H ),6h===== ,a',i4,',i4,6h =====)')") & + level*3, char_len1 +! print *, "fmt = ", fmt +! print *, "title1= ", title1 +! print *, "level = ", level + write (66,fmt) title1,level + end subroutine level_print +end module hsl_mc73_single + +program test + use hsl_mc73_single + implicit none + character(len=200) :: str(2) + integer, parameter :: wp = kind(0.0) + + integer :: n, lirn + integer :: irn(1), ip(1), list(1) + + str = "" + open (66, status='scratch') + call mc73_order + call mc73_fiedler(n,lirn,irn,ip,list) + rewind (66) + read (66, '(a)') str + close (66) + if (any (str /= " ===== end of level 1 =====")) call abort() +end program test diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 573093811dfa..933cb9ce5dc5 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,20 @@ +2013-04-04 Tobias Burnus + + Backport from mainline: + 2013-03-29 Tobias Burnus + + PR fortran/56737 + * io/format.c (parse_format): With caching, copy + dtp->format string. + (save_parsed_format): Use dtp->format directly without + copying. + + 2012-03-29 Tobias Burnus + + PR fortran/56737 + * io/format.c (parse_format_list): Also cache FMT_STRING. + (parse_format): Update call. + 2013-04-04 Tobias Burnus Backport from mainline: diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index d540fc47e321..17b58126bc49 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -151,8 +151,7 @@ save_parsed_format (st_parameter_dt *dtp) if (u->format_hash_table[hash].key != NULL) free (u->format_hash_table[hash].key); - u->format_hash_table[hash].key = get_mem (dtp->format_len); - memcpy (u->format_hash_table[hash].key, dtp->format, dtp->format_len); + u->format_hash_table[hash].key = dtp->format; u->format_hash_table[hash].key_len = dtp->format_len; u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt; @@ -590,16 +589,15 @@ format_lex (format_data *fmt) * parenthesis node which contains the rest of the list. */ static fnode * -parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd) +parse_format_list (st_parameter_dt *dtp, bool *seen_dd) { fnode *head, *tail; format_token t, u, t2; int repeat; format_data *fmt = dtp->u.p.fmt; - bool saveit, seen_data_desc = false; + bool seen_data_desc = false; head = tail = NULL; - saveit = *save_ok; /* Get the next format item */ format_item: @@ -616,7 +614,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd) } get_fnode (fmt, &head, &tail, FMT_LPAREN); tail->repeat = -2; /* Signifies unlimited format. */ - tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc); + tail->u.child = parse_format_list (dtp, &seen_data_desc); if (fmt->error != NULL) goto finished; if (!seen_data_desc) @@ -635,7 +633,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd) case FMT_LPAREN: get_fnode (fmt, &head, &tail, FMT_LPAREN); tail->repeat = repeat; - tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc); + tail->u.child = parse_format_list (dtp, &seen_data_desc); *seen_dd = seen_data_desc; if (fmt->error != NULL) goto finished; @@ -663,7 +661,7 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd) case FMT_LPAREN: get_fnode (fmt, &head, &tail, FMT_LPAREN); tail->repeat = 1; - tail->u.child = parse_format_list (dtp, &saveit, &seen_data_desc); + tail->u.child = parse_format_list (dtp, &seen_data_desc); *seen_dd = seen_data_desc; if (fmt->error != NULL) goto finished; @@ -727,8 +725,6 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd) goto between_desc; case FMT_STRING: - /* TODO: Find out why it is necessary to turn off format caching. */ - saveit = false; get_fnode (fmt, &head, &tail, FMT_STRING); tail->u.string.p = fmt->string; tail->u.string.length = fmt->value; @@ -1108,8 +1104,6 @@ parse_format_list (st_parameter_dt *dtp, bool *save_ok, bool *seen_dd) finished: - *save_ok = saveit; - return head; } @@ -1225,6 +1219,13 @@ parse_format (st_parameter_dt *dtp) /* Not found so proceed as follows. */ + if (format_cache_ok) + { + char *fmt_string = get_mem (dtp->format_len); + memcpy (fmt_string, dtp->format, dtp->format_len); + dtp->format = fmt_string; + } + dtp->u.p.fmt = fmt = get_mem (sizeof (format_data)); fmt->format_string = dtp->format; fmt->format_string_len = dtp->format_len; @@ -1251,14 +1252,15 @@ parse_format (st_parameter_dt *dtp) fmt->avail++; if (format_lex (fmt) == FMT_LPAREN) - fmt->array.array[0].u.child = parse_format_list (dtp, &format_cache_ok, - &seen_data_desc); + fmt->array.array[0].u.child = parse_format_list (dtp, &seen_data_desc); else fmt->error = "Missing initial left parenthesis in format"; if (fmt->error) { format_error (dtp, NULL, fmt->error); + if (format_cache_ok) + free (dtp->format); free_format_hash_table (dtp->u.p.current_unit); return; }