re PR fortran/87359 (pointer being freed was not allocated)

2018-09-30  Paul Thomas  <pault@gcc.gnu.org>

	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  <pault@gcc.gnu.org>

	PR fortran/87359
	* gfortran.dg/associate_40.f90 : New test.

From-SVN: r264725

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 318567b68935c121c53d71aee8de4eb1853dd985..399d6f9cc3f7e718bb7a4be7cac10e9bd4b17bbe 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2018-09-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       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  <pault@gcc.gnu.org>
 
        PR fortran/70752

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 035257aab120ad0a44484b4655e94698d9a8fd8d..1e8f777211d38ce253c29d8c1d94ea491d76f737 100644 (file)
--- 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 e06098d0b6a634502551aa48adf294514788e367..4dc292aded6be41052c827f36fc16c6642871910 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-09-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/87359
+       * gfortran.dg/associate_40.f90 : New test.
+
 2018-09-30  Paul Thomas  <pault@gcc.gnu.org>
 
        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 (file)
index 0000000..8ca5ef5
--- /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  <juergen.reuter@desy.de>
+!
+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" } }