From d80b9b477774b0e783f943cd86334ca64b9a477b Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 29 Mar 2013 10:37:37 +0100 Subject: [PATCH] re PR libfortran/56737 (Wrong I/O result with format cache for Hollerith strings) 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 directy without copying. 2013-03-29 Tobias Burnus PR fortran/56737 * testsuite/gfortran.dg/fmt_cache_3.f90: New. (Plus: Move fortran/ChangeLog item to libgfortran/ChangeLog) From-SVN: r197229 --- gcc/fortran/ChangeLog | 7 -- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/fmt_cache_3.f90 | 80 +++++++++++++++++++++++ libgfortran/ChangeLog | 15 +++++ libgfortran/io/format.c | 12 +++- 5 files changed, 110 insertions(+), 9 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/fmt_cache_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8aa1c4b8a7e..f1f176573c4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,10 +1,3 @@ -2013-03-29 Tobias Burnus - - PR fortran/56735 - * io/list_read.c (nml_query): Only abort when - an error occured. - (namelist_read): Add goto instead of falling through. - 2013-03-28 Thomas Koenig PR fortran/45159 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 622e0ca2f7f..d35c02daca9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2013-03-29 Tobias Burnus + + PR fortran/56737 + * testsuite/gfortran.dg/fmt_cache_3.f90: New. + 2013-03-29 Tobias Burnus PR fortran/56735 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 00000000000..ec8e1b389f9 --- /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 61c9fd10c63..a959728bd81 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,18 @@ +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 directy without + copying. + +2013-03-29 Tobias Burnus + + PR fortran/56735 + * io/list_read.c (nml_query): Only abort when + an error occured. + (namelist_read): Add goto instead of falling through. + 2013-03-25 Tilo Schwarz PR libfortran/52512 diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index c64596baf52..db95e490153 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -148,8 +148,7 @@ save_parsed_format (st_parameter_dt *dtp) u->format_hash_table[hash].hashed_fmt = NULL; free (u->format_hash_table[hash].key); - u->format_hash_table[hash].key = xmalloc (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; @@ -1223,6 +1222,13 @@ parse_format (st_parameter_dt *dtp) /* Not found so proceed as follows. */ + if (format_cache_ok) + { + char *fmt_string = xmalloc (dtp->format_len); + memcpy (fmt_string, dtp->format, dtp->format_len); + dtp->format = fmt_string; + } + dtp->u.p.fmt = fmt = xmalloc (sizeof (format_data)); fmt->format_string = dtp->format; fmt->format_string_len = dtp->format_len; @@ -1257,6 +1263,8 @@ parse_format (st_parameter_dt *dtp) 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; }