Commit 38217d3e by Paul Thomas

re PR fortran/67177 (MOVE_ALLOC not automatically allocating deferred character…

re PR fortran/67177 (MOVE_ALLOC not automatically allocating deferred character arrays in derived types)

2015-10-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/67177
	PR fortran/67977
	* primary.c (match_substring): Add an argument 'deferred' to
	flag that a substring reference with null start and end should
	not be optimized away for deferred length strings.
	(match_string_constant, gfc_match_rvalue): Set the argument.
	* trans-expr.c (alloc_scalar_allocatable_for_assignment): If
	there is a substring reference return.
	* trans-intrinsic.c (conv_intrinsic_move_alloc): For deferred
	characters, assign the 'from' string length to the 'to' string
	length. If the 'from' expression is deferred, set its string
	length to zero. If the 'to' expression has allocatable
	components, deallocate them.

2015-10-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/67177
	* gfortran.dg/move_alloc_15.f90: New test
	* gfortran.dg/move_alloc_16.f90: New test

	PR fortran/67977
	* gfortran.dg/deferred_character_assignment_1.f90: New test

From-SVN: r228940
parent 2fe7f26c
2015-10-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/67177
PR fortran/67977
* primary.c (match_substring): Add an argument 'deferred' to
flag that a substring reference with null start and end should
not be optimized away for deferred length strings.
(match_string_constant, gfc_match_rvalue): Set the argument.
* trans-expr.c (alloc_scalar_allocatable_for_assignment): If
there is a substring reference return.
* trans-intrinsic.c (conv_intrinsic_move_alloc): For deferred
characters, assign the 'from' string length to the 'to' string
length. If the 'from' expression is deferred, set its string
length to zero. If the 'to' expression has allocatable
components, deallocate them.
2015-10-17 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/67987
* decl.c (char_len_param_value): Unwrap unlong line. If LEN < 0,
force it to zero per the Fortran 90, 95, 2003, and 2008 Standards.
force it to zero per the Fortran 90, 95, 2003, and 2008 Standards.
* resolve.c (gfc_resolve_substring_charlen): Unwrap unlong line.
If 'start' is larger than 'end', length of substring is negative,
so explicitly set it to zero.
......
......@@ -761,7 +761,7 @@ done:
{
if (*p == '.')
continue;
if (*p != '0')
{
*p = '0';
......@@ -800,7 +800,7 @@ cleanup:
/* Match a substring reference. */
static match
match_substring (gfc_charlen *cl, int init, gfc_ref **result)
match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
{
gfc_expr *start, *end;
locus old_loc;
......@@ -852,7 +852,7 @@ match_substring (gfc_charlen *cl, int init, gfc_ref **result)
}
/* Optimize away the (:) reference. */
if (start == NULL && end == NULL)
if (start == NULL && end == NULL && !deferred)
ref = NULL;
else
{
......@@ -1150,7 +1150,7 @@ got_delim:
if (ret != -1)
gfc_internal_error ("match_string_constant(): Delimiter not found");
if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
e->expr_type = EXPR_SUBSTRING;
*result = e;
......@@ -2133,7 +2133,8 @@ check_substring:
if (primary->ts.type == BT_CHARACTER)
{
switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
bool def = primary->ts.deferred == 1;
switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
{
case MATCH_YES:
if (tail == NULL)
......@@ -3147,7 +3148,7 @@ gfc_match_rvalue (gfc_expr **result)
that we're not sure is a variable yet. */
if ((implicit_char || sym->ts.type == BT_CHARACTER)
&& match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
&& match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
{
e->expr_type = EXPR_VARIABLE;
......
......@@ -8891,6 +8891,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
tree jump_label1;
tree jump_label2;
gfc_se lse;
gfc_ref *ref;
if (!expr1 || expr1->rank)
return;
......@@ -8898,6 +8899,10 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
if (!expr2 || expr2->rank)
return;
for (ref = expr1->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING)
return;
realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
/* Since this is a scalar lhs, we can afford to do this. That is,
......
......@@ -9414,6 +9414,16 @@ conv_intrinsic_move_alloc (gfc_code *code)
}
}
if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
{
gfc_add_modify_loc (input_location, &block, to_se.string_length,
fold_convert (TREE_TYPE (to_se.string_length),
from_se.string_length));
if (from_expr->ts.deferred)
gfc_add_modify_loc (input_location, &block, from_se.string_length,
build_int_cst (TREE_TYPE (from_se.string_length), 0));
}
return gfc_finish_block (&block);
}
......@@ -9513,6 +9523,14 @@ conv_intrinsic_move_alloc (gfc_code *code)
}
else
{
if (to_expr->ts.type == BT_DERIVED
&& to_expr->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
to_se.expr, to_expr->rank);
gfc_add_expr_to_block (&block, tmp);
}
tmp = gfc_conv_descriptor_data_get (to_se.expr);
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
NULL_TREE, true, to_expr, false);
......@@ -9527,6 +9545,17 @@ conv_intrinsic_move_alloc (gfc_code *code)
gfc_add_modify_loc (input_location, &block, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
{
gfc_add_modify_loc (input_location, &block, to_se.string_length,
fold_convert (TREE_TYPE (to_se.string_length),
from_se.string_length));
if (from_expr->ts.deferred)
gfc_add_modify_loc (input_location, &block, from_se.string_length,
build_int_cst (TREE_TYPE (from_se.string_length), 0));
}
return gfc_finish_block (&block);
}
......
2015-10-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/67177
* gfortran.dg/move_alloc_15.f90: New test
* gfortran.dg/move_alloc_16.f90: New test
PR fortran/67977
* gfortran.dg/deferred_character_assignment_1.f90: New test
2015-10-17 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/67987
......
! { dg-do run }
!
! Checks the fix for PR67977 in which automatic reallocation on assignment
! was performed when the lhs had a substring reference.
!
! Contributed by Anton Shterenlikht <mexas@bristol.ac.uk>
!
character(:), allocatable :: z
integer :: length
z = "cockatoo"
length = len (z)
z(:) = ''
if (len(z) .ne. length) call abort
if (trim (z) .ne. '') call abort
z(:3) = "foo"
if (len(z) .ne. length) call abort
if (trim (z) .ne. "foo") call abort
z(4:) = "__bar"
if (len(z) .ne. length) call abort
if (trim (z) .ne. "foo__bar") call abort
deallocate (z)
end
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Fix for PR......
!
! The 'to' components of 'mytemp' would remain allocated after the call to
! MOVE_ALLOC, resulting in memory leaks.
!
! Contributed by Alberto Luaces.
!
! See https://groups.google.com/forum/#!topic/comp.lang.fortran/k3bkKUbOpFU
!
module alloctest
type myallocatable
integer, allocatable:: i(:)
end type myallocatable
contains
subroutine f(num, array)
implicit none
integer, intent(in) :: num
integer :: i
type(myallocatable):: array(:)
do i = 1, num
allocate(array(i)%i(5), source = [1,2,3,4,5])
end do
end subroutine f
end module alloctest
program name
use alloctest
implicit none
type(myallocatable), allocatable:: myarray(:), mytemp(:)
integer, parameter:: OLDSIZE = 7, NEWSIZE = 20
logical :: flag
allocate(myarray(OLDSIZE))
call f(size(myarray), myarray)
allocate(mytemp(NEWSIZE))
mytemp(1:OLDSIZE) = myarray
flag = .false.
call foo
call bar
deallocate(myarray)
if (allocated (mytemp)) deallocate (mytemp)
allocate(myarray(OLDSIZE))
call f(size(myarray), myarray)
allocate(mytemp(NEWSIZE))
mytemp(1:OLDSIZE) = myarray
! Verfify that there is no segfault if the allocatable components
! are deallocated before the call to move_alloc
flag = .true.
call foo
call bar
deallocate(myarray)
contains
subroutine foo
integer :: i
if (flag) then
do i = 1, OLDSIZE
deallocate (mytemp(i)%i)
end do
end if
call move_alloc(mytemp, myarray)
end subroutine
subroutine bar
integer :: i
do i = 1, OLDSIZE
if (.not.flag .and. allocated (myarray(i)%i)) then
if (any (myarray(i)%i .ne. [1,2,3,4,5])) call abort
else
if (.not.flag) call abort
end if
end do
end subroutine
end program name
! { dg-final { scan-tree-dump-times "__builtin_malloc" 11 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
! { dg-do run }
!
! Tests the fix for PR67177 in which MOVE_ALLOC was not assigning the string
! length for deferred length characters.
!
! Contributed by <templed@tcd.ie>
!
program str
implicit none
type string
character(:), Allocatable :: text
end type string
type strings
type(string), allocatable, dimension(:) :: strlist
end type strings
type(strings) :: teststrs
type(string) :: tmpstr
integer :: strlen = 20
allocate (teststrs%strlist(1))
allocate (character(len=strlen) :: tmpstr%text)
allocate (character(len=strlen) :: teststrs%strlist(1)%text)
! Full string reference was required because reallocation on assignment is
! functioning when it should not if the lhs is a substring - PR67977
tmpstr%text(1:3) = 'foo'
if (.not.allocated (teststrs%strlist(1)%text)) call abort
if (len (tmpstr%text) .ne. strlen) call abort
call move_alloc(tmpstr%text,teststrs%strlist(1)%text)
if (.not.allocated (teststrs%strlist(1)%text)) call abort
if (len (teststrs%strlist(1)%text) .ne. strlen) call abort
if (trim (teststrs%strlist(1)%text(1:3)) .ne. 'foo') call abort
! Clean up so that valgrind reports all allocated memory freed.
if (allocated (teststrs%strlist(1)%text)) deallocate (teststrs%strlist(1)%text)
if (allocated (teststrs%strlist)) deallocate (teststrs%strlist)
end program str
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment