Re: Fw: Re: [Patch, fortran] PR37336 (Finalization) - [F03] Finish derived-type finalization

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 3662 bytes --]

Hi All,

Please find attached a patch for trans-array.cc that does what Harald
suggests; ie. finalization of array and structure constructors only occurs
with -std=f2003/8. Two versions of finalize_38.f90 are attached. One which
tests -std=gnu/f20018 and the other -std=f2008.

Frankly, I think that this is better. Finalization of these expressions
must be handled with a lot of care and was deleted by f2018 for good
reasons. Above all else, the results do not represent defined entities and
so it does not really make sense to finalize them. My vote is to go with
this version of the patch.

I am struggling a bit with a nit in finalize_45. One of the other
processors appears to nullify the pointer component of the result
of construct_t during finalization of the result. I can see the sense in
this but do not find any requirement to do so in the standard.

Given the scale of the overall patch, I am beginning to have a lot of
sympathy with Thomas's suggestion that the finalization calls should be
moved to the front end! I will take a quick look to see how easy this would
be to implement.

Regards

Paul


On Fri, 6 Jan 2023 at 08:34, Harald Anlauf via Fortran <fortran@gcc.gnu.org>
wrote:

> Hi Jerry,
>
> > Gesendet: Freitag, 06. Januar 2023 um 04:08 Uhr
> > Von: "Jerry D" <jvdelisle2@gmail.com>
> > An: "Harald Anlauf" <anlauf@gmx.de>, "fortran" <fortran@gcc.gnu.org>
> > Betreff: Re: Fw: Re: [Patch, fortran] PR37336 (Finalization) - [F03]
> Finish derived-type finalization
> >
> > On 1/5/23 1:14 PM, Harald Anlauf via Fortran wrote:
> > > Resending as plain text, as the original version did not appear on the
> fortran list...
> > >
> > >
> > > Gesendet: Donnerstag, 05. Januar 2023 um 22:10 Uhr
> > > Von: "Harald Anlauf" <anlauf@gmx.de>
> > > An: "Paul Richard Thomas" <paul.richard.thomas@gmail.com>
> > > Cc: "fortran@gcc.gnu.org" <fortran@gcc.gnu.org>, "Alessandro
> Fanfarillo" <alessandro.fanfarillo@gmail.com>, "Andrew Benson" <
> abenson@carnegiescience.edu>, "Thomas Koenig" <tkoenig@gcc.gnu.org>,
> "Damian Rouson" <damian@archaeologic.codes>
> > > Betreff: Re: [Patch, fortran] PR37336 (Finalization) - [F03] Finish
> derived-type finalization
> > >
> > > Dear Paul, all,
> > >
> > > I had a first look at the patch and the testcases, and I really look
> forward to getting this into gfortran.
> > >
> > > A few questions surfaced when playing with it, which is why am asking
> for others to comment.
> > >
> > > Testcase finalize_38.f90 exhibits a (potential) discrepancy to my
> expections when playing with options -std=f2018 and -std=gnu (the default).
> > >
> > > What is the expected behavior of -std=gnu?  My expectation is that
> -std=gnu always corresponds to the latest implemented standard (currently
> F2018), except for possibly allowing for GNU-extensions.  This might imply
> that corrigenda to a standard or a newer version may lead (over time) to an
> adjustment of the behavior.  Any opinions on it?  Do we need to always test
> (in the testsuite) for compliance with older standards?
> > >
> >
> > My understanding is that -std=gnu tends to be the least restrictive and
> > will allow finalize_38.f90 to compile possibly with warnings. The
> > warnings are to allow the user to know thay are out of current
> > compliance, but we should not fail on code that was previously compliant
> > and less we specify -std=f2018 which is more restrictive.
>
> So if e.g. finalize_38.f90 compiles without warnings with -std=f2018,
> it should also compile without warnings with -std=gnu, right?
>
> Harald
>
>
> > Jerry
> >
> >
>


-- 
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein

[-- Attachment #2: finalize_38.f90 --]
[-- Type: text/x-fortran, Size: 6653 bytes --]

! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
! With -std=gnu, no finalization of array or structure constructors should occur.
! See finalize_38a.f90 for the result with f2008.
! Tests fix for PR64290 as well.
!
module testmode
  implicit none

  type :: simple
    integer :: ind
  contains
    final :: destructor1, destructor2
  end type simple

  type, extends(simple) :: complicated
    real :: rind
  contains
    final :: destructor3, destructor4
  end type complicated

  integer :: check_scalar
  integer :: check_array(4)
  real :: check_real
  real :: check_rarray(4)
  integer :: final_count = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    check_scalar = self%ind
    check_array = 0
    final_count = final_count + 1
  end subroutine destructor1

  subroutine destructor2(self)
    type(simple), intent(inout) :: self(:)
    check_scalar = 0
    check_array(1:size(self, 1)) = self%ind
    final_count = final_count + 1
  end subroutine destructor2

  subroutine destructor3(self)
    type(complicated), intent(inout) :: self
    check_real = self%rind
    check_array = 0.0
    final_count = final_count + 1
  end subroutine destructor3

  subroutine destructor4(self)
    type(complicated), intent(inout) :: self(:)
    check_real = 0.0
    check_rarray(1:size(self, 1)) = self%rind
    final_count = final_count + 1
  end subroutine destructor4

  function constructor1(ind) result(res)
    class(simple), allocatable :: res
    integer, intent(in) :: ind
    allocate (res, source = simple (ind))
  end function constructor1

  function constructor2(ind, rind) result(res)
    class(simple), allocatable :: res(:)
    integer, intent(in) :: ind(:)
    real, intent(in), optional :: rind(:)
    type(complicated), allocatable :: src(:)
    integer :: sz
    integer :: i
    if (present (rind)) then
      sz = min (size (ind, 1), size (rind, 1))
      src  = [(complicated (ind(i), rind(i)), i = 1, sz)]
      allocate (res, source = src)
    else
      sz = size (ind, 1)
      allocate (res, source = [(simple (ind(i)), i = 1, sz)])
    end if
  end function constructor2

  subroutine test (cnt, scalar, array, off, rind, rarray)
    integer :: cnt
    integer :: scalar
    integer :: array(:)
    integer :: off
    real, optional :: rind
    real, optional :: rarray(:)
    if (final_count .ne. cnt) then
        stop 1 + off
    endif
    if (check_scalar .ne. scalar) then
        stop 2 + off
    endif
    if (any (check_array(1:size (array, 1)) .ne. array)) then
        stop 3 + off
    endif
    if (present (rind)) then
        stop 4 + off
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) then
        stop 5 + off
      endif
    end if
    final_count = 0
  end subroutine test
end module testmode

program test_final
  use testmode
  implicit none

  type(simple), allocatable :: MyType, MyType2
  type(simple), allocatable :: MyTypeArray(:)
  type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
  class(simple), allocatable :: MyClass
  class(simple), allocatable :: MyClassArray(:)

! ************************
! Derived type assignments
! ************************

! The original PR - no finalization of 'var' before (re)allocation
! because it is deallocated on scope entry (para 1 of F2018 7.5.6.3.)
  MyType = ThyType
  call test(0, 0, [0,0], 0)

  if (.not. allocated(MyType)) allocate(MyType)
  allocate(MyType2)
  MyType%ind = 1
  MyType2%ind = 2

! This should result in a final call with self = simple(1) (para 1 of F2018 7.5.6.3.).
  MyType = MyType2
  call test(1, 1, [0,0], 10)

  allocate(MyTypeArray(2))
  MyTypeArray%ind = [42, 43]
! This should result no calls.
  call test(0, 1, [0,0], 20)

! This should result in a final call 'var' = initialization = simple(22).
  ThyType2 = simple(99)
  call test(1, 22, [0,0], 30)

! This should result in a final call for 'var' with self = simple(21).
  ThyType = ThyType2
  call test(1, 21, [0,0], 40)

! This should result in two final calls; the last is for Mytype2 = simple(2).
  deallocate (MyType, MyType2)
  call test(2, 2, [0,0], 50)

! This should result in one final call; MyTypeArray = [simple(42),simple(43)].
  deallocate (MyTypeArray)
  call test(1, 0, [42,43], 60)

! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
! NAGFOR doesn't finalize the function result.
  allocate (MyType, source = simple (11))
  MyType = constructor1 (99)
  call test(2, 99, [0,0], 70)
  deallocate (MyType)
! *****************
! Class assignments
! *****************

  final_count = 0

! This should result in a final call for MyClass, which is simple(3).
  allocate (MyClass, source = simple (3))
  MyClass = simple (4)
  call test(1, 3, [0,0], 100)

! This should result in a final call with the assigned value of simple(4).
  deallocate (MyClass)
  call test(1, 4, [0,0], 110)


  allocate (MyClassArray, source = [simple (5), simple (6)])
! Make sure that there is no final call since MyClassArray is not allocated.
  call test(0, 4, [0,0], 120)

  MyClassArray = [simple (7), simple (8)]
! The only final call should finalize 'var'.
! NAGFOR does something strange here: makes a scalar final call with value
! simple(5).
  call test(1, 0, [5,6], 130)

! This should result in a final call with the assigned value.
  deallocate (MyClassArray)
  call test(1, 0, [7,8], 140)

! This should produce no final calls since MyClassArray was deallocated.
  allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])

! This should produce calls to destructor4 then destructor2.
  deallocate (MyClassArray)

! F2018 7.5.6.3: "If the entity is of extended type and the parent type is
! finalizable, the parent component is finalized.
  call test(2, 0, [1, 3], 150, rarray = [2.0, 4.0])

! This produces 2 final calls in turn for 'src' as it goes out of scope, for
! MyClassArray before it is assigned to and the result of 'constructor2' after
! the assignment, for which the result should be should be [10,20] & [10.0,20.0].
  MyClassArray = constructor2 ([10,20], [10.0,20.0])
  call test(4, 0, [10,20], 160, rarray = [10.0,20.0])

! This produces two final calls with the contents of 'MyClassArray. and its
! parent component.
  deallocate (MyClassArray)
  call test(2, 0, [10, 20], 170, rarray = [10.0,20.0])

! Clean up for valgrind testing
  if (allocated (MyType)) deallocate (MyType)
  if (allocated (MyType2)) deallocate (MyType2)
  if (allocated (MyTypeArray)) deallocate (MyTypeArray)
  if (allocated (MyClass)) deallocate (MyClass)
end program test_final

[-- Attachment #3: finalize_38a.f90 --]
[-- Type: text/x-fortran, Size: 7806 bytes --]

! { dg-do run }
! { dg-options "-std=f2008" }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
! With -std=f2008, structure and array constructors are finalized.
! See finalize_38.f90 for the result with -std=gnu.
! Tests fix for PR64290 as well.
!
module testmode
  implicit none

  type :: simple
    integer :: ind
  contains
    final :: destructor1, destructor2
  end type simple

  type, extends(simple) :: complicated
    real :: rind
  contains
    final :: destructor3, destructor4
  end type complicated

  integer :: check_scalar
  integer :: check_array(4)
  real :: check_real
  real :: check_rarray(4)
  integer :: final_count = 0
  integer :: fails = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    check_scalar = self%ind
    check_array = 0
    final_count = final_count + 1
  end subroutine destructor1

  subroutine destructor2(self)
    type(simple), intent(inout) :: self(:)
    check_scalar = 0
    check_array(1:size(self, 1)) = self%ind
    final_count = final_count + 1
  end subroutine destructor2

  subroutine destructor3(self)
    type(complicated), intent(inout) :: self
    check_real = self%rind
    check_array = 0.0
    final_count = final_count + 1
  end subroutine destructor3

  subroutine destructor4(self)
    type(complicated), intent(inout) :: self(:)
    check_real = 0.0
    check_rarray(1:size(self, 1)) = self%rind
    final_count = final_count + 1
  end subroutine destructor4

  function constructor1(ind) result(res)
    class(simple), allocatable :: res
    integer, intent(in) :: ind
    allocate (res, source = simple (ind))
  end function constructor1

  function constructor2(ind, rind) result(res)
    class(simple), allocatable :: res(:)
    integer, intent(in) :: ind(:)
    real, intent(in), optional :: rind(:)
    type(complicated), allocatable :: src(:)
    integer :: sz
    integer :: i
    if (present (rind)) then
      sz = min (size (ind, 1), size (rind, 1))
      src  = [(complicated (ind(i), rind(i)), i = 1, sz)]  ! { dg-warning "has been finalized" }
      allocate (res, source = src)
    else
      sz = size (ind, 1)
      allocate (res, source = [(simple (ind(i)), i = 1, sz)])
    end if
  end function constructor2

  subroutine test (cnt, scalar, array, off, rind, rarray)
    integer :: cnt
    integer :: scalar
    integer :: array(:)
    integer :: off
    real, optional :: rind
    real, optional :: rarray(:)
    if (final_count .ne. cnt) then
        print *, 1 + off, final_count, '(', cnt, ')'
        fails = fails + 1
    endif
    if (check_scalar .ne. scalar) then
        print *, 2 + off, check_scalar, '(', scalar, ')'
        fails = fails + 1
    endif
    if (any (check_array(1:size (array, 1)) .ne. array)) then
        print *, 3 + off, check_array(1:size (array, 1)) , '(', array, ')'
        fails = fails + 1
    endif
    if (present (rind)) then
      if (check_real .ne. rind) then
        print *, 4 + off, check_real,'(', rind, ')'
        fails = fails + 1
      endif
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) then
        print *, 5 + off, check_rarray(1:size (rarray, 1)), '(', rarray, ')'
        fails = fails + 1
      endif
    end if
    final_count = 0
  end subroutine test
end module testmode

program test_final
  use testmode
  implicit none

  type(simple), allocatable :: MyType, MyType2
  type(simple), allocatable :: MyTypeArray(:)
  type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
  class(simple), allocatable :: MyClass
  class(simple), allocatable :: MyClassArray(:)

! ************************
! Derived type assignments
! ************************

! The original PR - no finalization of 'var' before (re)allocation
! because it is deallocated on scope entry (para 1 of F2018 7.5.6.3.)
  MyType = ThyType
  call test(0, 0, [0,0], 0)

  if (.not. allocated(MyType)) allocate(MyType)
  allocate(MyType2)
  MyType%ind = 1
  MyType2%ind = 2

! This should result in a final call with self = simple(1) (para 1 of F2018 7.5.6.3.).
  MyType = MyType2
  call test(1, 1, [0,0], 10)

  allocate(MyTypeArray(2))
  MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)],
! followed by the finalization of the array constructor = self = [simple(21),simple(22)].
  MyTypeArray = [ThyType, ThyType2] ! { dg-warning "has been finalized" }
  call test(2, 0, [21,22], 20)

! This should result in a final call 'var' = initialization = simple(22),
! followed by one with for the structure constructor.
! NAGFOR does not finalize the constructor.
  ThyType2 = simple(99) ! { dg-warning "has been finalized" }
  call test(2, 99, [0,0], 30)

! This should result in a final call for 'var' with self = simple(21).
  ThyType = ThyType2
  call test(1, 21, [0,0], 40)

! This should result in two final calls; the last is for Mytype2 = simple(2).
  deallocate (MyType, MyType2)
  call test(2, 2, [0,0], 50)

! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
  deallocate (MyTypeArray)
  call test(1, 0, [21,22], 60)

! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
! NAGFOR doesn't finalize the function result.
  allocate (MyType, source = simple (11))
  MyType = constructor1 (99)
  call test(2, 99, [0,0], 70)
  deallocate (MyType)
! *****************
! Class assignments
! *****************

  final_count = 0

! This should result in a final call for MyClass, which is simple(3) and then
! the structure constructor with value simple(4)).
! NAGFOR does not finalize the constructor.
  allocate (MyClass, source = simple (3))
  MyClass = simple (4) ! { dg-warning "has been finalized" }
  call test(2, 4, [0,0], 100)

! This should result in a final call with the assigned value of simple(4).
  deallocate (MyClass)
  call test(1, 4, [0,0], 110)


  allocate (MyClassArray, source = [simple (5), simple (6)])
! Make sure that there is no final call since MyClassArray is not allocated.
  call test(0, 4, [0,0], 120)

  MyClassArray = [simple (7), simple (8)] ! { dg-warning "has been finalized" }
! The first final call should finalize MyClassArray and the second should return
! the value of the array constructor.
! NAGFOR makes a single scalar final call with value simple(5) and does not
! finalize the array constructor.
  call test(2, 0, [7,8], 130)

! This should result in a final call with the assigned value.
  deallocate (MyClassArray)
  call test(1, 0, [7,8], 140)

! This should produce no final calls since MyClassArray was deallocated.
  allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])

! This should produce calls to destructor4 then destructor2.
  deallocate (MyClassArray)

! F2018 7.5.6.3: "If the entity is of extended type and the parent type is
! finalizable, the parent component is finalized.
  call test(2, 0, [1, 3], 150, rarray = [2.0, 4.0])

! This produces 2 final calls in turn for 'src' as it goes out of scope, for
! MyClassArray before it is assigned to and the result of 'constructor2' after
! the assignment, for which the result should be should be [10,20] & [10.0,20.0].
  MyClassArray = constructor2 ([10,20], [10.0,20.0])
  call test(6, 0, [10,20], 160, rarray = [10.0,20.0])

! This produces two final calls with the contents of 'MyClassArray. and its
! parent component.
  deallocate (MyClassArray)
  call test(2, 0, [10, 20], 170, rarray = [10.0,20.0])

! Clean up for valgrind testing
  if (allocated (MyType)) deallocate (MyType)
  if (allocated (MyType2)) deallocate (MyType2)
  if (allocated (MyTypeArray)) deallocate (MyTypeArray)
  if (allocated (MyClass)) deallocate (MyClass)

! Error messages printed out by 'test'.
  if (fails .ne. 0) stop
end program test_final

[-- Attachment #4: trans-array.diff --]
[-- Type: text/x-patch, Size: 19914 bytes --]

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 44177aa0813..0b312f807df 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -994,9 +994,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
       if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
 	{
 	  gcc_assert (expr->ts.type == BT_CHARACTER);
-	  
+
 	  tmp = gfc_get_character_len_in_bytes (tmp);
-	  
+
 	  if (tmp == NULL_TREE || integer_zerop (tmp))
 	    {
 	      tree bs;
@@ -1007,7 +1007,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
 	      tmp = fold_build2_loc (input_location, MULT_EXPR,
 				     gfc_array_index_type, tmp, bs);
 	    }
-	  
+
 	  tmp = (tmp && !integer_zerop (tmp))
 	    ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
 	}
@@ -2026,10 +2026,11 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
    for the dynamic parts must be allocated using realloc.  */
 
 static void
-gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
-				   tree desc, gfc_constructor_base base,
-				   tree * poffset, tree * offsetvar,
-				   bool dynamic)
+gfc_trans_array_constructor_value (stmtblock_t * pblock,
+				   stmtblock_t * finalblock,
+				   tree type, tree desc,
+				   gfc_constructor_base base, tree * poffset,
+				   tree * offsetvar, bool dynamic)
 {
   tree tmp;
   tree start = NULL_TREE;
@@ -2039,6 +2040,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
   gfc_se se;
   mpz_t size;
   gfc_constructor *c;
+  gfc_typespec ts;
+  int ctr = 0;
 
   tree shadow_loopvar = NULL_TREE;
   gfc_saved_var saved_loopvar;
@@ -2046,6 +2049,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
   mpz_init (size);
   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
     {
+      ctr++;
       /* If this is an iterator or an array, the offset must be a variable.  */
       if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
 	gfc_put_offset_into_var (pblock, poffset, offsetvar);
@@ -2091,8 +2095,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
       if (c->expr->expr_type == EXPR_ARRAY)
 	{
 	  /* Array constructors can be nested.  */
-	  gfc_trans_array_constructor_value (&body, type, desc,
-					     c->expr->value.constructor,
+	  gfc_trans_array_constructor_value (&body, finalblock, type,
+					     desc, c->expr->value.constructor,
 					     poffset, offsetvar, dynamic);
 	}
       else if (c->expr->rank > 0)
@@ -2200,6 +2204,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
               gfc_add_modify (&body, *offsetvar, *poffset);
               *poffset = *offsetvar;
             }
+	  ts = c->expr->ts;
 	}
 
       /* The frontend should already have done any expansions
@@ -2292,6 +2297,34 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
 	  gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
 	}
     }
+
+  /* F2008 4.5.6.3 para 5: If an executable construct references a structure
+     constructor or array constructor, the entity created by the constructor is
+     finalized after execution of the innermost executable construct containing
+     the reference. This, in fact, was later deleted by the Combined Techical
+     Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
+
+     Transmit finalization of this constructor through 'finalblock'. */
+  if (!gfc_notification_std (GFC_STD_F2018_DEL) && finalblock != NULL
+      && gfc_may_be_finalized (ts)
+      && ctr > 0 && desc != NULL_TREE
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      symbol_attribute attr;
+      gfc_se fse;
+      gfc_warning (0, "The structure constructor at %C has been"
+			 " finalized. This feature was removed by f08/0011."
+			 " Use -std=f2018 or -std=gnu to eliminate the"
+			 " finalization.");
+      attr.pointer = attr.allocatable = 0;
+      gfc_init_se (&fse, NULL);
+      fse.expr = desc;
+      gfc_finalize_function_result (&fse, ts.u.derived, attr, 1);
+      gfc_add_block_to_block (finalblock, &fse.pre);
+      gfc_add_block_to_block (finalblock, &fse.finalblock);
+      gfc_add_block_to_block (finalblock, &fse.post);
+    }
+
   mpz_clear (size);
 }
 
@@ -2738,6 +2771,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
   gfc_ss *s;
   tree neg_len;
   char *msg;
+  stmtblock_t finalblock;
 
   /* Save the old values for nested checking.  */
   old_first_len = first_len;
@@ -2897,8 +2931,12 @@ trans_array_constructor (gfc_ss * ss, locus * where)
   offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
   suppress_warning (offsetvar);
   TREE_USED (offsetvar) = 0;
-  gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
-				     &offset, &offsetvar, dynamic);
+
+  gfc_init_block (&finalblock);
+  gfc_trans_array_constructor_value (&outer_loop->pre,
+				     expr->must_finalize ? &finalblock : NULL,
+				     type, desc, c, &offset, &offsetvar,
+				     dynamic);
 
   /* If the array grows dynamically, the upper bound of the loop variable
      is determined by the array's final upper bound.  */
@@ -2933,6 +2971,15 @@ finish:
   first_len = old_first_len;
   first_len_val = old_first_len_val;
   typespec_chararray_ctor = old_typespec_chararray_ctor;
+
+  /* F2008 4.5.6.3 para 5: If an executable construct references a structure
+     constructor or array constructor, the entity created by the constructor is
+     finalized after execution of the innermost executable construct containing
+     the reference.  */
+  if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+       && finalblock.head != NULL_TREE)
+    gfc_add_block_to_block (&loop->post, &finalblock);
+
 }
 
 
@@ -3161,6 +3208,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
 	  gfc_conv_expr (&se, expr);
 	  gfc_add_block_to_block (&outer_loop->pre, &se.pre);
 	  gfc_add_block_to_block (&outer_loop->post, &se.post);
+	  gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
 	  ss_info->string_length = se.string_length;
 	  break;
 
@@ -6457,20 +6505,22 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
       /* Evaluate non-constant array bound expressions.  */
       lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
       if (as->lower[dim] && !INTEGER_CST_P (lbound))
-        {
-          gfc_init_se (&se, NULL);
-          gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
-          gfc_add_block_to_block (pblock, &se.pre);
-          gfc_add_modify (pblock, lbound, se.expr);
-        }
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  gfc_add_block_to_block (pblock, &se.finalblock);
+	  gfc_add_modify (pblock, lbound, se.expr);
+	}
       ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
       if (as->upper[dim] && !INTEGER_CST_P (ubound))
-        {
-          gfc_init_se (&se, NULL);
-          gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
-          gfc_add_block_to_block (pblock, &se.pre);
-          gfc_add_modify (pblock, ubound, se.expr);
-        }
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  gfc_add_block_to_block (pblock, &se.finalblock);
+	  gfc_add_modify (pblock, ubound, se.expr);
+	}
     }
 }
 
@@ -6502,20 +6552,22 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
       /* Evaluate non-constant array bound expressions.  */
       lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
       if (as->lower[dim] && !INTEGER_CST_P (lbound))
-        {
-          gfc_init_se (&se, NULL);
-          gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
-          gfc_add_block_to_block (pblock, &se.pre);
-          gfc_add_modify (pblock, lbound, se.expr);
-        }
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  gfc_add_block_to_block (pblock, &se.finalblock);
+	  gfc_add_modify (pblock, lbound, se.expr);
+	}
       ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
       if (as->upper[dim] && !INTEGER_CST_P (ubound))
-        {
-          gfc_init_se (&se, NULL);
-          gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
-          gfc_add_block_to_block (pblock, &se.pre);
-          gfc_add_modify (pblock, ubound, se.expr);
-        }
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	  gfc_add_block_to_block (pblock, &se.finalblock);
+	  gfc_add_modify (pblock, ubound, se.expr);
+	}
       /* The offset of this dimension.  offset = offset - lbound * stride.  */
       tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			     lbound, size);
@@ -6529,19 +6581,19 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
 	stride = GFC_TYPE_ARRAY_SIZE (type);
 
       if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
-        {
-          /* Calculate stride = size * (ubound + 1 - lbound).  */
-          tmp = fold_build2_loc (input_location, MINUS_EXPR,
+	{
+	  /* Calculate stride = size * (ubound + 1 - lbound).  */
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
 				 gfc_array_index_type,
 				 gfc_index_one_node, lbound);
-          tmp = fold_build2_loc (input_location, PLUS_EXPR,
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
 				 gfc_array_index_type, ubound, tmp);
-          tmp = fold_build2_loc (input_location, MULT_EXPR,
+	  tmp = fold_build2_loc (input_location, MULT_EXPR,
 				 gfc_array_index_type, size, tmp);
-          if (stride)
-            gfc_add_modify (pblock, stride, tmp);
-          else
-            stride = gfc_evaluate_now (tmp, pblock);
+	  if (stride)
+	    gfc_add_modify (pblock, stride, tmp);
+	  else
+	    stride = gfc_evaluate_now (tmp, pblock);
 
 	  /* Make sure that negative size arrays are translated
 	     to being zero size.  */
@@ -6551,7 +6603,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
 				 gfc_array_index_type, tmp,
 				 stride, gfc_index_zero_node);
 	  gfc_add_modify (pblock, stride, tmp);
-        }
+	}
 
       size = stride;
     }
@@ -7531,7 +7583,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
   if (!se->direct_byref)
     se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-  
+
   /* Special case things we know we can pass easily.  */
   switch (expr->expr_type)
     {
@@ -8973,9 +9025,11 @@ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
 static gfc_actual_arglist *pdt_param_list;
 
 static tree
-structure_alloc_comps (gfc_symbol * der_type, tree decl,
-		       tree dest, int rank, int purpose, int caf_mode,
-		       gfc_co_subroutines_args *args)
+structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
+		       int rank, int purpose, int caf_mode,
+		       gfc_co_subroutines_args *args,
+		       bool no_finalization = false,
+		       bool del_ptrs = false)
 {
   gfc_component *c;
   gfc_loopinfo loop;
@@ -9063,11 +9117,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					     gfc_conv_array_data (dest));
 	  dref = gfc_build_array_ref (tmp, index, NULL);
 	  tmp = structure_alloc_comps (der_type, vref, dref, rank,
-				       COPY_ALLOC_COMP, caf_mode, args);
+				       COPY_ALLOC_COMP, caf_mode, args,
+				       no_finalization);
 	}
       else
 	tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
-				     caf_mode, args);
+				     caf_mode, args, no_finalization);
 
       gfc_add_expr_to_block (&loopbody, tmp);
 
@@ -9101,13 +9156,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
   if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
     {
       tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				   DEALLOCATE_PDT_COMP, 0, args);
+				   DEALLOCATE_PDT_COMP, 0, args,
+				   no_finalization);
       gfc_add_expr_to_block (&fnblock, tmp);
     }
   else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
     {
       tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				   NULLIFY_ALLOC_COMP, 0, args);
+				   NULLIFY_ALLOC_COMP, 0, args,
+				   no_finalization);
       gfc_add_expr_to_block (&fnblock, tmp);
     }
 
@@ -9169,7 +9226,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated
 		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
 					       comp, NULL_TREE, rank, purpose,
-					       caf_mode, args);
+					       caf_mode, args, no_finalization);
 		}
 	      else
 		{
@@ -9177,7 +9234,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							      comp, NULL_TREE,
 							      rank, purpose,
-							      caf_mode, args);
+							      caf_mode, args,
+							      no_finalization);
 		}
 	    }
 
@@ -9293,8 +9351,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		continue;
 	    }
 
-	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
-	     || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+	  if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+	     || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
 	    /* Call the finalizer, which will free the memory and nullify the
 	       pointer of an array.  */
 	    deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
@@ -9322,7 +9380,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated
 		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
 					       comp, NULL_TREE, rank, purpose,
-					       caf_mode, args);
+					       caf_mode, args, no_finalization);
 		}
 	      else
 		{
@@ -9330,7 +9388,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							      comp, NULL_TREE,
 							      rank, purpose,
-							      caf_mode, args);
+							      caf_mode, args,
+							      no_finalization);
 		}
 	    }
 
@@ -9628,7 +9687,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				      decl, cdecl, NULL_TREE);
 	      rank = c->as ? c->as->rank : 0;
 	      tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
-					   rank, purpose, caf_mode, args);
+					   rank, purpose, caf_mode, args,
+					   no_finalization);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 	  break;
@@ -9664,14 +9724,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
 					       rank, purpose, caf_mode
 					       | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
-					       args);
+					       args, no_finalization);
 		  gfc_add_expr_to_block (&fnblock, tmp);
 		}
 	    }
 	  break;
 
 	case COPY_ALLOC_COMP:
-	  if (c->attr.pointer || c->attr.proc_pointer)
+	  if ((c->attr.pointer && !del_ptrs) || c->attr.proc_pointer)
 	    continue;
 
 	  /* We need source and destination components.  */
@@ -9713,6 +9773,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  dst_data = gfc_conv_descriptor_data_get (dst_data);
 		}
 
+	      if (CLASS_DATA (c)->attr.pointer)
+		{
+		  gfc_add_modify (&fnblock, dst_data,
+				  build_int_cst (TREE_TYPE (dst_data), 0));
+		  continue;
+		}
+
 	      gfc_init_block (&tmpblock);
 
 	      gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
@@ -9759,6 +9826,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 							 tmp, null_data));
 	      continue;
 	    }
+	  else if (c->attr.pointer)
+	    {
+	      if (c->attr.dimension)
+		tmp = gfc_conv_descriptor_data_get (dcmp);
+	      else
+		tmp = dcmp;
+	      gfc_add_modify (&fnblock, tmp,
+			      build_int_cst (TREE_TYPE (tmp), 0));
+	      continue;
+	    }
 
 	  /* To implement guarded deep copy, i.e., deep copy only allocatable
 	     components that are really allocated, the deep copy code has to
@@ -9772,7 +9849,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							  comp, dcmp,
 							  rank, purpose,
-							  caf_mode, args);
+							  caf_mode, args,
+							  no_finalization);
 	    }
 	  else
 	    add_when_allocated = NULL_TREE;
@@ -10145,7 +10223,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				NULLIFY_ALLOC_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+				NULL);
 }
 
 
@@ -10158,7 +10237,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				DEALLOCATE_ALLOC_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+				NULL);
 }
 
 tree
@@ -10196,7 +10276,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
 
   tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
 			       BCAST_ALLOC_COMP,
-  			       GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
+			       GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+			       &args);
   return tmp;
 }
 
@@ -10206,10 +10287,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
    status of coarrays.  */
 
 tree
-gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
+				  bool no_finalization)
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				DEALLOCATE_ALLOC_COMP, 0, NULL);
+				DEALLOCATE_ALLOC_COMP, 0, NULL,
+				no_finalization);
 }
 
 
@@ -10217,7 +10300,8 @@ tree
 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
 {
   return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+				NULL);
 }
 
 
@@ -10233,6 +10317,20 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
 }
 
 
+/* Recursively traverse an object of derived type, generating code to
+   copy it and its allocatable components, while suppressing any
+   finalization that might occur.  This is used in the finalization of
+   function results.  */
+
+tree
+gfc_copy_alloc_comp_del_ptrs (gfc_symbol * der_type, tree decl, tree dest,
+			      int rank, int caf_mode)
+{
+  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
+				caf_mode, NULL, true, true);
+}
+
+
 /* Recursively traverse an object of derived type, generating code to
    copy only its allocatable components.  */
 
@@ -10972,7 +11070,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 	&& expr1->ts.u.derived->attr.alloc_comp)
     {
       tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
-					      expr1->rank);
+					      expr1->rank, true);
       gfc_add_expr_to_block (&realloc_block, tmp);
     }
 
@@ -11145,8 +11243,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
   sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
 			|| sym->ts.type == BT_CLASS)
 			  && sym->ts.u.derived->attr.alloc_comp;
-  has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
-		   ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+  has_finalizer = gfc_may_be_finalized (sym->ts);
 
   /* Make sure the frontend gets these right.  */
   gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp