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

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

	PR fortran/87359
	* trans-stmt.c (gfc_trans_allocate): Don't deallocate alloc
	components if must_finalize is set for expr3.

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

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

From-SVN: r264485

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1f622495d09a666b75d1abbcc39575b45798529d..0d8797eaab0fe62bd229ff0e2dfa1603e0559d00 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2018-09-21  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/87359
+       * trans-stmt.c (gfc_trans_allocate): Don't deallocate alloc
+       components if must_finalize is set for expr3.
+
 2018-09-21  Andrew Stubbs  <ams@codesourcery.com>
             Kwok Cheung Yeung  <kcy@codesourcery.com>
 

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 92d9c3767c0aed1e2c2b706b27e1f958c08973a6..833c6c5f0a7c66e77d7052a7b6a5303d67aba840 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5998,7 +5998,8 @@ gfc_trans_allocate (gfc_code * code)
       if ((code->expr3->ts.type == BT_DERIVED
           || code->expr3->ts.type == BT_CLASS)
          && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
-         && code->expr3->ts.u.derived->attr.alloc_comp)
+         && code->expr3->ts.u.derived->attr.alloc_comp
+         && !code->expr3->must_finalize)
        {
          tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
                                           expr3, code->expr3->rank);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b861eabc0e812e8ef1bfcb16dab25ecd076511d8..97b60da78ec915679b7934c04ac1286c8598caa6 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-09-21  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/87359
+       * gfortran.dg/finalize_33.f90 : New test.
+
 2018-09-21  David Malcolm  <dmalcolm@redhat.com>
 
        PR tree-optimization/87309

diff --git a/gcc/testsuite/gfortran.dg/finalize_33.f90 b/gcc/testsuite/gfortran.dg/finalize_33.f90
new file mode 100644 (file)
index 0000000..3857e44
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_33.f90
@@ -0,0 +1,119 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Tests the fix for PR87359 in which the finalization of
+! 'source=process%component%extract_mci_template()' in the allocation
+! of 'process%mci' caused invalid reads and freeing of already freed
+! memory. This test is a greatly reduced version of the original code.
+!
+! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
+!
+module mci_base
+  implicit none
+  private
+  public :: mci_t
+  public :: mci_midpoint_t
+  public :: cnt
+  integer :: cnt = 0
+  type, abstract :: mci_t
+     integer, dimension(:), allocatable :: chain
+  end type mci_t
+  type, extends (mci_t) :: mci_midpoint_t
+  contains
+    final :: mci_midpoint_final
+  end type mci_midpoint_t
+contains
+  IMPURE ELEMENTAL SUBROUTINE mci_midpoint_final(arg)
+    TYPE(mci_midpoint_t), INTENT(INOUT) :: arg
+    cnt = cnt + 1
+  END SUBROUTINE mci_midpoint_final
+end module mci_base
+
+!!!!!
+
+module process_config
+  use mci_base
+  implicit none
+  private
+  public :: process_component_t
+  type :: process_component_t
+     class(mci_t), allocatable :: mci_template
+   contains
+     procedure :: init => process_component_init
+     procedure :: extract_mci_template => process_component_extract_mci_template
+  end type process_component_t
+
+contains
+
+  subroutine process_component_init (component, mci_template)
+    class(process_component_t), intent(out) :: component
+    class(mci_t), intent(in), allocatable :: mci_template
+    if (allocated (mci_template)) &
+         allocate (component%mci_template, source = mci_template)
+  end subroutine process_component_init
+
+  function process_component_extract_mci_template (component) &
+         result (mci_template)
+    class(mci_t), allocatable :: mci_template
+    class(process_component_t), intent(in) :: component
+    if (allocated (component%mci_template)) &
+       allocate (mci_template, source = component%mci_template)
+  end function process_component_extract_mci_template
+end module process_config
+
+!!!!!
+
+module process
+  use mci_base
+  use process_config
+  implicit none
+  private
+  public :: process_t
+  type :: process_t
+     private
+     type(process_component_t) :: component
+     class(mci_t), allocatable :: mci
+   contains
+     procedure :: init_component => process_init_component
+     procedure :: setup_mci => process_setup_mci
+  end type process_t
+contains
+  subroutine process_init_component &
+       (process, mci_template)
+    class(process_t), intent(inout), target :: process
+    class(mci_t), intent(in), allocatable :: mci_template
+    call process%component%init (mci_template)
+  end subroutine process_init_component
+
+  subroutine process_setup_mci (process)
+    class(process_t), intent(inout) :: process
+    allocate (process%mci, source=process%component%extract_mci_template ())
+  end subroutine process_setup_mci
+
+end module process
+
+!!!!!
+
+program main_ut
+  use mci_base
+  use process, only: process_t
+  implicit none
+  call event_transforms_1 ()
+  if (cnt .ne. 4) stop 2
+contains
+
+  subroutine event_transforms_1 ()
+    class(mci_t), allocatable :: mci_template
+    type(process_t), allocatable, target :: process
+    allocate (process)
+    allocate (mci_midpoint_t :: mci_template)
+    call process%init_component (mci_template)
+    call process%setup_mci ()                  ! generates 1 final call from call to extract_mci_template
+    if (cnt .ne. 1) stop 1
+  end subroutine event_transforms_1            ! generates 3 final calls to mci_midpoint_final:
+                                               ! (i) process%component%mci_template
+                                               ! (ii) process%mci
+                                               ! (iii) mci_template
+end program main_ut
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 17 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 20 "original" } }