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

gcc/fortran/ChangeLog

 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
 	PR fortran/72709
 	* trans-array.c (gfc_conv_scalarized_array_ref): If this is a

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.  */

gcc/testsuite/ChangeLog

 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
 	PR fortran/72709
 	* gfortran.dg/deferred_character_25.f90 : New test.

gcc/testsuite/gfortran.dg/associate_40.f90

+! { 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" } }