From 6f29994cb8c6a797f241adac76663143309c03dd Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 18 Oct 2015 09:31:21 +0000 Subject: [PATCH] 2015-10-18 Paul Thomas 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 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 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@228940 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 18 +++- gcc/fortran/primary.c | 13 +-- gcc/fortran/trans-expr.c | 5 ++ gcc/fortran/trans-intrinsic.c | 29 ++++++ gcc/testsuite/ChangeLog | 9 ++ .../deferred_character_assignment_1.f90 | 22 +++++ gcc/testsuite/gfortran.dg/move_alloc_15.f90 | 88 +++++++++++++++++++ gcc/testsuite/gfortran.dg/move_alloc_16.f90 | 44 ++++++++++ 8 files changed, 221 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_15.f90 create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_16.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9c5bb766c9b8..51b07de4f026 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,8 +1,24 @@ +2015-10-18 Paul Thomas + + 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 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 9f75666becfe..e39c89054d6a 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 e086fe3a1034..2f42c04436ad 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 15ef5608e956..d72ea98abf32 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 b12db829324a..b477f0d27f9f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2015-10-18 Paul Thomas + + 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 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 000000000000..f3a739f503dd --- /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 +! + 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 000000000000..1c96ccba1cf4 --- /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 000000000000..fc09f7778c38 --- /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 +! +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 -- 2.39.2