From: Paul Thomas Date: Sun, 30 Sep 2018 13:52:55 +0000 (+0000) Subject: re PR fortran/87359 (pointer being freed was not allocated) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a086078b8f7ee2580e55afc03026acf63bfb9605;p=gcc.git re PR fortran/87359 (pointer being freed was not allocated) 2018-09-30 Paul Thomas PR fortran/87359 * trans-array.c (gfc_is_reallocatable_lhs): Correct the problem introduced by r264358, which prevented components of associate names from being reallocated on assignment. 2018-09-30 Paul Thomas PR fortran/87359 * gfortran.dg/associate_40.f90 : New test. From-SVN: r264725 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 318567b6893..399d6f9cc3f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2018-09-30 Paul Thomas + + PR fortran/87359 + * trans-array.c (gfc_is_reallocatable_lhs): Correct the problem + introduced by r264358, which prevented components of associate + names from being reallocated on assignment. + 2018-09-30 Paul Thomas PR fortran/70752 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 035257aab12..1e8f777211d 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -9574,11 +9574,12 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) sym = expr->symtree->n.sym; - if (sym->attr.associate_var) + if (sym->attr.associate_var && !expr->ref) return false; /* An allocatable class variable with no reference. */ if (sym->ts.type == BT_CLASS + && !sym->attr.associate_var && CLASS_DATA (sym)->attr.allocatable && expr->ref && expr->ref->type == REF_COMPONENT && strcmp (expr->ref->u.c.component->name, "_data") == 0 @@ -9587,9 +9588,10 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) /* An allocatable variable. */ if (sym->attr.allocatable - && expr->ref - && expr->ref->type == REF_ARRAY - && expr->ref->u.ar.type == AR_FULL) + && !sym->attr.associate_var + && expr->ref + && expr->ref->type == REF_ARRAY + && expr->ref->u.ar.type == AR_FULL) return true; /* All that can be left are allocatable components. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e06098d0b6a..4dc292aded6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-09-30 Paul Thomas + + PR fortran/87359 + * gfortran.dg/associate_40.f90 : New test. + 2018-09-30 Paul Thomas PR fortran/70752 diff --git a/gcc/testsuite/gfortran.dg/associate_40.f90 b/gcc/testsuite/gfortran.dg/associate_40.f90 new file mode 100644 index 00000000000..8ca5ef5422e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_40.f90 @@ -0,0 +1,96 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for the second part of PR87359 in which the reallocation on +! assignment for components of associate names was disallowed by r264358. +! -fcheck-all exposed the mismatch in array shapes. The deallocations at +! the end of the main program are there to make sure that valgrind does +! not report an memory leaks. +! +! Contributed by Juergen Reuter +! +module phs_fks + implicit none + private + public :: phs_identifier_t + public :: phs_fks_t + type :: phs_identifier_t + integer, dimension(:), allocatable :: contributors + contains + procedure :: init => phs_identifier_init + end type phs_identifier_t + + type :: phs_fks_t + type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers + end type phs_fks_t +contains + + subroutine phs_identifier_init & + (phs_id, contributors) + class(phs_identifier_t), intent(out) :: phs_id + integer, intent(in), dimension(:) :: contributors + allocate (phs_id%contributors (size (contributors))) + phs_id%contributors = contributors + end subroutine phs_identifier_init + +end module phs_fks + +!!!!! + +module instances + use phs_fks + implicit none + private + public :: process_instance_t + + type :: nlo_event_deps_t + type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers + end type nlo_event_deps_t + + type :: process_instance_t + type(phs_fks_t), pointer :: phs => null () + type(nlo_event_deps_t) :: event_deps + contains + procedure :: init => process_instance_init + procedure :: setup_real_event_kinematics => pi_setup_real_event_kinematics + end type process_instance_t + +contains + + subroutine process_instance_init (instance) + class(process_instance_t), intent(out), target :: instance + integer :: i + integer :: i_born, i_real + allocate (instance%phs) + end subroutine process_instance_init + + subroutine pi_setup_real_event_kinematics (process_instance) + class(process_instance_t), intent(inout) :: process_instance + integer :: i_real, i + associate (event_deps => process_instance%event_deps) + i_real = 2 + associate (phs => process_instance%phs) + allocate (phs%phs_identifiers (3)) + call phs%phs_identifiers(1)%init ([1]) + call phs%phs_identifiers(2)%init ([1,2]) + call phs%phs_identifiers(3)%init ([1,2,3]) + process_instance%event_deps%phs_identifiers = phs%phs_identifiers ! Error: mismatch in array shapes. + end associate + end associate + end subroutine pi_setup_real_event_kinematics + +end module instances + +!!!!! + +program main + use instances, only: process_instance_t + implicit none + type(process_instance_t), allocatable, target :: process_instance + allocate (process_instance) + call process_instance%init () + call process_instance%setup_real_event_kinematics () + if (associated (process_instance%phs)) deallocate (process_instance%phs) + if (allocated (process_instance)) deallocate (process_instance) +end program main +! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } }