backport: re PR libfortran/56737 (Wrong I/O result with format cache for Hollerith strings)
2013-04-03 Tobias Burnus <burnus@net-b.de>
Backport from mainline:
2013-03-29 Tobias Burnus <burnus@net-b.de>
PR fortran/56737
* io/format.c (parse_format): With caching, copy
dtp->format string.
(save_parsed_format): Use dtp->format directly without
copying.
2013-04-03 Tobias Burnus <burnus@net-b.de>
Backport from mainline:
2013-03-29 Tobias Burnus <burnus@net-b.de>
PR fortran/56737
* testsuite/gfortran.dg/fmt_cache_3.f90: New.
From-SVN: r197412
This commit is contained in:
Tobias Burnus
Tobias Burnus
parent
1661e2108b
commit
76b3663751
|
|
@ -1,3 +1,11 @@
|
|||
2013-04-03 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
Backport from mainline:
|
||||
2013-03-29 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/56737
|
||||
* testsuite/gfortran.dg/fmt_cache_3.f90: New.
|
||||
|
||||
2013-04-03 Richard Biener <rguenther@suse.de>
|
||||
|
||||
PR tree-optimization/56501
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,3 +1,20 @@
|
|||
2013-04-03 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
Backport from mainline:
|
||||
2013-03-29 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
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 <burnus@net-b.de>
|
||||
|
||||
PR fortran/56737
|
||||
* io/format.c (parse_format_list): Also cache FMT_STRING.
|
||||
(parse_format): Update call.
|
||||
|
||||
2013-04-03 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
Backport from mainline:
|
||||
|
|
|
|||
|
|
@ -150,8 +150,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 = 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;
|
||||
|
|
@ -589,16 +588,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:
|
||||
|
|
@ -615,7 +613,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)
|
||||
|
|
@ -634,7 +632,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;
|
||||
|
|
@ -662,7 +660,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;
|
||||
|
|
@ -726,8 +724,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;
|
||||
|
|
@ -1107,8 +1103,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;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue