aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog18
-rw-r--r--gcc/fortran/primary.c13
-rw-r--r--gcc/fortran/trans-expr.c5
-rw-r--r--gcc/fortran/trans-intrinsic.c29
-rw-r--r--gcc/testsuite/ChangeLog9
-rw-r--r--gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f9022
-rw-r--r--gcc/testsuite/gfortran.dg/move_alloc_15.f9088
-rw-r--r--gcc/testsuite/gfortran.dg/move_alloc_16.f9044
8 files changed, 221 insertions, 7 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9c5bb76..51b07de 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,8 +1,24 @@
+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.
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 9f75666..e39c890 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -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;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e086fe3..2f42c04 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 15ef560..d72ea98 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -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);
}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b12db82..b477f0d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+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
diff --git a/gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90 b/gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90
new file mode 100644
index 0000000..f3a739f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90
@@ -0,0 +1,22 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_15.f90 b/gcc/testsuite/gfortran.dg/move_alloc_15.f90
new file mode 100644
index 0000000..1c96ccb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_15.f90
@@ -0,0 +1,88 @@
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_16.f90 b/gcc/testsuite/gfortran.dg/move_alloc_16.f90
new file mode 100644
index 0000000..fc09f77
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_16.f90
@@ -0,0 +1,44 @@
+! { 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
generated by cgit v1.1 at 2025-04-11 10:31:26 +0000