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

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 6517 bytes --]

This patch has been an excessively long time in coming. Please accept my
apologies for that.

All but two of the PR37336 dependencies are fixed, The two exceptions are
PRs 59694 and 65347. The former involves lack of finalization of an
unreferenced entity declared in a block, which I am sure is trivial but I
cannot see where the missing trigger is, and the latter involves
finalization of function results within an array constructor, for which I
will submit an additional patch shortly.  PR104272 also remains, in which
finalization is occurring during allocation. I fixed this in one place but
it seems to have crept out in another :-)

Beyond this patch and ones for the three lagging PRs above, a thorough tidy
up and unification of finalization is needed. However, I will concentrate
on functionality in the first instance.

I have tried to interpret F2018 7.5.6.2 and 7.5.6.3 as well as possible.
This is not always straightforward and has involved a lot of head
scratching! I have used the Intel compiler as a litmus test for the
outcomes. This was largely motivated by the observation that, in the user
survey conducted by Steve Lionel, gfortran and ifort are often used
together . Therefore, quite aside from wishing to comply with the standard
as far as possible, it is more than reasonable that the two compilers
comply. On application of this patch, only exception to this is the
treatment of finalization of arrays of extended types, where the Intel
takes "If the entity is of extended type and the parent type is
finalizable, the parent component is finalized" such that the parent
component is finalized one element at a time, whereas gfortran finalises
the parent components as an array. I strongly suspect that, from reading
7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However, this
is another issue to come back to in the future.

The work centred on three areas:
(i) Finalization on assignment:
This was required because finalization of the lhs was occurring at the
wrong time relative to evaluation of the rhs expression and was taking the
finalization of entities with finalizable components in the wrong order.
The changes in trans-array.cc (structure_alloc_comps) allow
gfc_deallocate_alloc_comp_no_caf to occur without finalization so that it
can be preceded by calls to the finalization wrapper. The other key change
in this area is the addition of trans-expr.cc
(gfc_assignment_finalizer_call), which manages the ordering of finalization
and deallocation.

(ii) Finalization of derived type function results.
Previously, finalization was not occuring at all for derived type results
but it did for class results. The former is now implemented in
trans-expr.cc (finalize_function_result), into which the treatment of class
finalization has been included. In order to handled complex expressions
correctly, an extra block has been included in gfc_se and is initialized in
gfc_init_se. This block accumulates the finalizations so that they can be
added at the right time. It is the way in which I will fix PR65347 (I have
already tested the principle).

(iii) Minor fixes
These include the changes in class.cc and the exclusion of artificial
entities from finalization.

There are some missing testcases (sorry Andrew and Sandro!), which might
not be necessary because the broken/missing features are already fixed. The
fact that the work correctly now is a strong indication that this is the
case.

Regtests OK on FC33/x86_64 - OK for mainline (and 11-branch)?

Best regards

Paul

Fortran:Implement missing finalization features [PR37336]

2022-02-02  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/103854
* class.cc (has_finalizer_component): Do not return true for
procedure pointer components.

PR fortran/96122
* class.cc (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.

PR fortran/37336
* class.cc (finalizer_insert_packed_call): Remove the redundant
argument in the call to the final subroutine.
* resolve.cc (resolve_where, gfc_resolve_where_code_in_forall,
gfc_resolve_forall_body, gfc_resolve_code): Check that the op
code is still EXEC_ASSIGN. If it is set lhs to must finalize.
* trans-array.cc (structure_alloc_comps): Add boolean argument
to suppress finalization and use it for calls from
gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to
false. Add a second, additional boolean argument to nullify
pointer components and use it in gfc_copy_alloc_comp_del_ptrs.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_copy_alloc_comp_del_ptrs): New function.
* trans-array.h : Add the new boolean argument to the prototype
of gfc_deallocate_alloc_comp_no_caf with a default of false.
Add prototype for gfc_copy_alloc_comp_del_ptrs.
* trans-expr.cc (gfc_init_se): Initialize finalblock.
(finalize_function_result): New function that finalizes
function results in the correct order.
(gfc_conv_procedure_call): Use new function for finalizable
function results. Replace in-line block for class results with
call to new function.
(gfc_trans_scalar_assign): Suppress finalization by setting new
argument in call to gfc_deallocate_alloc_comp_no_caf. Add the
finalization blocks to the main block.
(gfc_assignment_finalizer_call): New function to provide
finalization on intrinsic assignment.
(trans_class_assignment, gfc_trans_assignment_1): Call it and
add the block between the rhs evaluation and any reallocation
on assignment that there might be.
* trans-io.cc (gfc_trans_transfer): Add the final block.
* trans-stmt.cc (gfc_trans_call, gfc_trans_allocate): likewise.
* trans.cc (gfc_add_finalizer_call): Exclude artificial
entities.
* trans.h: Add finalblock to gfc_se.

gcc/testsuite/
PR fortran/64290
* gfortran.dg/finalize_38.f90 : New test.
* gfortran.dg/allocate_with_source_25.f90 : The number of final
calls goes down from 6 to 4.

PR fortran/67444
* gfortran.dg/finalize_39.f90 : New test.

PR fortran/67471
* gfortran.dg/finalize_40.f90 : New test.

PR fortran/69298
PR fortran/70863
* gfortran.dg/finalize_41.f90 : New test.

PR fortran/71798
* gfortran.dg/finalize_42.f90 : New test.

PR fortran/80524
* gfortran.dg/finalize_43.f90 : New test.

PR fortran/82996
* gfortran.dg/finalize_44.f90 : New test.

PR fortran/84472
* gfortran.dg/finalize_45.f90 : New test.

PR fortran/88735
PR fortran/93691
* gfortran.dg/finalize_46.f90 : New test.

PR fortran/91316
* gfortran.dg/finalize_47.f90 : New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 38090 bytes --]

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 731e9b0fe6a..a249eea4a30 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
    gfc_component *c;
 
   for (c = derived->components; c; c = c->next)
-    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+	&& c->attr.flavor != FL_PROCEDURE)
       {
 	if (c->ts.u.derived->f2k_derived
 	    && c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
     {
       /* Call FINAL_WRAPPER (comp);  */
       gfc_code *final_wrap;
-      gfc_symbol *vtab;
+      gfc_symbol *vtab, *byte_stride;
+      gfc_expr *scalar, *size_expr, *fini_coarray_expr;
       gfc_component *c;
 
       vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 	  break;
 
       gcc_assert (c);
+
+      /* Set scalar argument for storage_size.  */
+      gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+      byte_stride->ts = e->ts;
+      byte_stride->attr.flavor = FL_VARIABLE;
+      byte_stride->attr.value = 1;
+      byte_stride->attr.artificial = 1;
+      gfc_set_sym_referenced (byte_stride);
+      gfc_commit_symbol (byte_stride);
+      scalar = gfc_lval_expr_from_sym (byte_stride);
+
       final_wrap = gfc_get_code (EXEC_CALL);
       final_wrap->symtree = c->initializer->symtree;
       final_wrap->resolved_sym = c->initializer->symtree->n.sym;
       final_wrap->ext.actual = gfc_get_actual_arglist ();
       final_wrap->ext.actual->expr = e;
 
+      /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+      size_expr = gfc_get_expr ();
+      size_expr->where = gfc_current_locus;
+      size_expr->expr_type = EXPR_OP;
+      size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+      /* STORAGE_SIZE (array,kind=c_intptr_t).  */
+      size_expr->value.op.op1
+	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+				    "storage_size", gfc_current_locus, 2,
+				    scalar,
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL, 0));
+
+      /* NUMERIC_STORAGE_SIZE.  */
+      size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+						  gfc_character_storage_size);
+      size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+      size_expr->ts = size_expr->value.op.op1->ts;
+
+      /* Which provides the argument 'byte_stride'.....  */
+      final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->expr = size_expr;
+
+      /* ...and last of all the 'fini_coarray' argument.  */
+      fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+      final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
       if (*code)
 	{
 	  (*code)->next = final_wrap;
@@ -1430,8 +1474,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->next->resolved_sym = fini->proc_tree->n.sym;
   block->next->ext.actual = gfc_get_actual_arglist ();
   block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
-  block->next->ext.actual->next = gfc_get_actual_arglist ();
-  block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
 
   /* ELSE.  */
 
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 835a4783718..fe17df2f73d 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10512,6 +10512,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
 	      if (e && !resolve_where_shape (cnext->expr1, e))
 	       gfc_error ("WHERE assignment target at %L has "
 			  "inconsistent shape", &cnext->expr1->where);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;
 
 
@@ -10599,6 +10603,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
 	    /* WHERE assignment statement */
 	    case EXEC_ASSIGN:
 	      gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;
 
 	    /* WHERE operator assignment statement */
@@ -10645,6 +10653,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
 	case EXEC_ASSIGN:
 	case EXEC_POINTER_ASSIGN:
 	  gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+	  if (c->op == EXEC_ASSIGN)
+	    c->expr1->must_finalize = 1;
+
 	  break;
 
 	case EXEC_ASSIGN_CALL:
@@ -11324,6 +11336,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
   tmp->n.sym->attr.use_assoc = 0;
   tmp->n.sym->attr.intent = INTENT_UNKNOWN;
 
+
   if (as)
     {
       tmp->n.sym->as = gfc_copy_array_spec (as);
@@ -12069,6 +12082,9 @@ start:
 	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
 	    generate_component_assignments (&code, ns);
 
+	  if (code->op == EXEC_ASSIGN)
+	    code->expr1->must_finalize = 1;
+
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cfb6eac11c7..689628e1cb6 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);
 	}
@@ -7478,7 +7478,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)
     {
@@ -8910,7 +8910,8 @@ gfc_caf_is_dealloc_only (int caf_mode)
 
 /* Recursively traverse an object of derived type, generating code to
    deallocate, nullify or copy allocatable components.  This is the work horse
-   function for the functions named in this enum.  */
+   function for the functions named in this enum.  When del_ptrs is set with
+   COPY_ALLOC_COMP, pointers are nullified.  */
 
 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
       COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
@@ -8920,9 +8921,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;
@@ -9010,11 +9013,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);
 
@@ -9048,13 +9052,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);
     }
 
@@ -9116,7 +9122,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
 		{
@@ -9124,7 +9130,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);
 		}
 	    }
 
@@ -9240,8 +9247,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,
@@ -9269,7 +9276,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
 		{
@@ -9277,7 +9284,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);
 		}
 	    }
 
@@ -9575,7 +9583,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;
@@ -9611,14 +9620,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.  */
@@ -9660,6 +9669,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),
@@ -9706,6 +9722,17 @@ 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
@@ -9719,7 +9746,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;
@@ -10092,7 +10120,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);
 }
 
 
@@ -10105,7 +10134,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
@@ -10143,7 +10173,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;
 }
 
@@ -10153,10 +10184,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);
 }
 
 
@@ -10164,7 +10197,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);
 }
 
 
@@ -10180,6 +10214,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 deleting pointers and
+   suppressing any finalization that might occur.  This is used in the
+   finaliztion 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.  */
 
@@ -10950,7 +10998,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);
     }
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 04fee617590..2743158cb11 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -56,11 +56,14 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
 			   tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+				       bool no_finalization = false);
 tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
 
 tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
 
+tree gfc_copy_alloc_comp_del_ptrs (gfc_symbol *, tree, tree, int, int);
+
 tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
 
 tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index eb6a78c3a62..34ad867e041 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1904,6 +1904,7 @@ gfc_init_se (gfc_se * se, gfc_se * parent)
 {
   memset (se, 0, sizeof (gfc_se));
   gfc_init_block (&se->pre);
+  gfc_init_block (&se->finalblock);
   gfc_init_block (&se->post);
 
   se->parent = parent;
@@ -5975,6 +5976,117 @@ post_call:
 }
 
 
+/* Finalize a function result using the finalizer wrapper. The result is fixed
+   in order to prevent repeated calls.  */
+
+static void
+finalize_function_result (gfc_se *se, gfc_symbol *derived,
+			  symbol_attribute attr, int rank)
+{
+  tree vptr, final_fndecl, desc, tmp, size, is_final, data_ptr;
+  gfc_symbol *vtab;
+  gfc_se post_se;
+  bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
+
+  if (attr.pointer)
+    return;
+
+  if (is_class)
+    {
+      if (!VAR_P (se->expr))
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->pre);
+	  se->expr = desc;
+	}
+      desc = gfc_class_data_get (se->expr);
+      vptr = gfc_class_vptr_get (se->expr);
+    }
+  else
+    {
+      desc = gfc_evaluate_now (se->expr, &se->pre);
+      se->expr = gfc_evaluate_now (desc, &se->pre);
+      /* Need to copy allocated components and delete pointer components.  */
+      gfc_add_expr_to_block (&se->pre,
+			     gfc_copy_alloc_comp_del_ptrs (derived, desc,
+							   se->expr, rank, 0));
+      vtab = gfc_find_derived_vtab (derived);
+      if (vtab->backend_decl == NULL_TREE)
+	vptr = gfc_get_symbol_decl (vtab);
+      else
+	vptr = vtab->backend_decl;
+      vptr = gfc_build_addr_expr (NULL, vptr);
+    }
+
+  size = gfc_vptr_size_get (vptr);
+  final_fndecl = gfc_vptr_final_get (vptr);
+  is_final = fold_build2_loc (input_location, NE_EXPR,
+			      logical_type_node,
+			      final_fndecl,
+			      fold_convert (TREE_TYPE (final_fndecl),
+					    null_pointer_node));
+
+  final_fndecl = build_fold_indirect_ref_loc (input_location,
+					      final_fndecl);
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      if (is_class)
+	desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
+      else
+	{
+	  gfc_init_se (&post_se, NULL);
+	  desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
+	  gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
+	}
+    }
+
+  tmp = gfc_create_var (TREE_TYPE (desc), "res");
+  gfc_add_modify (&se->pre, tmp, desc);
+  desc = tmp;
+
+  tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+			     gfc_build_addr_expr (NULL, desc),
+			     size, boolean_false_node);
+
+  tmp = fold_build3_loc (input_location, COND_EXPR,
+			 void_type_node, is_final, tmp,
+			 build_empty_stmt (input_location));
+
+  if (is_class && se->ss && se->ss->loop)
+    {
+      data_ptr = gfc_conv_descriptor_data_get (desc);
+
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR,
+			     logical_type_node,
+			     data_ptr,
+			     fold_convert (TREE_TYPE (data_ptr),
+					   null_pointer_node));
+      tmp = fold_build3_loc (input_location, COND_EXPR,
+			     void_type_node, tmp,
+			     gfc_call_free (data_ptr),
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+    }
+  else
+    {
+      gfc_add_expr_to_block (&se->finalblock, tmp);
+      if (is_class)
+	{
+	  data_ptr = gfc_conv_descriptor_data_get (desc);
+	  tmp = fold_build2_loc (input_location, NE_EXPR,
+				 logical_type_node,
+				 data_ptr,
+				 fold_convert (TREE_TYPE (data_ptr),
+					       null_pointer_node));
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 void_type_node, tmp,
+				 gfc_call_free (data_ptr),
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+    }
+}
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -7011,6 +7123,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
+      gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
 
       /* Allocated allocatable components of derived types must be
 	 deallocated for non-variable scalars, array arguments to elemental
@@ -7675,9 +7788,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   /* Allocatable scalar function results must be freed and nullified
      after use. This necessitates the creation of a temporary to
      hold the result to prevent duplicate calls.  */
+  symbol_attribute attr =  comp ? comp->attr : sym->attr;
+  bool allocatable = attr.allocatable && !attr.dimension;
+  gfc_symbol *der = comp && comp->ts.type == BT_DERIVED ? comp->ts.u.derived
+		    : (sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL);
+  bool finalizable = der != NULL && gfc_is_finalizable (der, NULL);
+
+  if (!byref && finalizable)
+    finalize_function_result (se, der, attr, expr->rank);
+
   if (!byref && sym->ts.type != BT_CHARACTER
-      && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
-	  || (comp && comp->attr.allocatable && !comp->attr.dimension)))
+      && allocatable && !finalizable)
     {
       tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
       gfc_add_modify (&se->pre, tmp, se->expr);
@@ -7737,6 +7858,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      se->expr = info->descriptor;
 	      /* Bundle in the string length.  */
 	      se->string_length = len;
+
+	      if (finalizable)
+		finalize_function_result (se, der, attr, expr->rank);
 	    }
 	  else if (ts.type == BT_CHARACTER)
 	    {
@@ -7829,8 +7953,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
 	  && expr->must_finalize)
 	{
-	  tree final_fndecl;
-	  tree is_final;
 	  int n;
 	  if (se->ss && se->ss->loop)
 	    {
@@ -7852,66 +7974,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      /* TODO Eliminate the doubling of temporaries. This
 		 one is necessary to ensure no memory leakage.  */
 	      se->expr = gfc_evaluate_now (se->expr, &se->pre);
-	      tmp = gfc_class_data_get (se->expr);
-	      tmp = gfc_conv_scalar_to_descriptor (se, tmp,
-			CLASS_DATA (expr->value.function.esym->result)->attr);
 	    }
 
-	  if ((gfc_is_class_array_function (expr)
-	       || gfc_is_alloc_class_scalar_function (expr))
-	      && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
-	    goto no_finalization;
-
-	  final_fndecl = gfc_class_vtab_final_get (se->expr);
-	  is_final = fold_build2_loc (input_location, NE_EXPR,
-				      logical_type_node,
-				      final_fndecl,
-				      fold_convert (TREE_TYPE (final_fndecl),
-					   	    null_pointer_node));
-	  final_fndecl = build_fold_indirect_ref_loc (input_location,
-						      final_fndecl);
- 	  tmp = build_call_expr_loc (input_location,
-				     final_fndecl, 3,
-				     gfc_build_addr_expr (NULL, tmp),
-				     gfc_class_vtab_size_get (se->expr),
-				     boolean_false_node);
-	  tmp = fold_build3_loc (input_location, COND_EXPR,
-				 void_type_node, is_final, tmp,
-				 build_empty_stmt (input_location));
-
-	  if (se->ss && se->ss->loop)
-	    {
-	      gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     info->data,
-				     fold_convert (TREE_TYPE (info->data),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (info->data),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->ss->loop->post, tmp);
-	    }
-	  else
-	    {
-	      tree classdata;
-	      gfc_prepend_expr_to_block (&se->post, tmp);
-	      classdata = gfc_class_data_get (se->expr);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     classdata,
-				     fold_convert (TREE_TYPE (classdata),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (classdata),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->post, tmp);
-	    }
+	  /* Finalize the result, if necessary.  */
+	  attr = CLASS_DATA (expr->value.function.esym->result)->attr;
+	  if (!((gfc_is_class_array_function (expr)
+		 || gfc_is_alloc_class_scalar_function (expr))
+		&& attr.pointer))
+	    finalize_function_result (se, NULL, attr, expr->rank);
 	}
-
-no_finalization:
       gfc_add_block_to_block (&se->post, &post);
     }
 
@@ -10430,7 +10501,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       if (dealloc)
 	{
 	  tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
-	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+						  0, true);
 	  if (deep_copy)
 	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
 			    tmp);
@@ -10438,6 +10510,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	}
 
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
       gfc_add_block_to_block (&block, &lse->pre);
 
       gfc_add_modify (&block, lse->expr,
@@ -10469,6 +10542,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
       tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
 			     TREE_TYPE (lse->expr), rse->expr);
       gfc_add_modify (&block, lse->expr, tmp);
@@ -10478,6 +10552,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
 
       if (!trans_scalar_class_assign (&block, lse, rse))
 	{
@@ -10872,6 +10947,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 
   gfc_conv_function_expr (&se, expr2);
   gfc_add_block_to_block (&se.pre, &se.post);
+  gfc_add_block_to_block (&se.pre, &se.finalblock);
 
   if (ss)
     gfc_cleanup_loop (&loop);
@@ -11387,6 +11463,96 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
 }
 
 
+  /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+     (10.2.1.3), if the variable is not an unallocated allocatable variable,
+     it is finalized after evaluation of expr and before the definition of
+     the variable. If the variable is an allocated allocatable variable, or
+     has an allocated allocatable subobject, that would be deallocated by
+     intrinsic assignment, the finalization occurs before the deallocation */
+
+static tree
+gfc_assignment_finalizer_call (gfc_expr *expr1, bool init_flag)
+{
+  stmtblock_t final_block;
+  gfc_init_block (&final_block);
+  symbol_attribute lhs_attr;
+  tree final_expr;
+  tree ptr;
+  tree cond;
+  gfc_se se;
+  gfc_symbol *sym = expr1->symtree->n.sym;
+  gfc_ref *ref = expr1->ref;
+
+  /* We have to exclude vtable procedures (_copy and _final especially), uses
+     of gfc_trans_assignment_1 in initialization and allocation before trying
+     to build a final call.  */
+  if (!expr1->must_finalize
+      || sym->attr.artificial
+      || sym->ns->proc_name->attr.artificial
+      || init_flag)
+    return NULL_TREE;
+
+  /* F2018 7.5.6.2: Only finalizable entities are finalized.  */
+  for (; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      return NULL_TREE;
+
+  if (!(sym->ts.type == BT_CLASS
+	|| (sym->ts.type == BT_DERIVED
+	    && gfc_is_finalizable (sym->ts.u.derived, NULL)))
+      || !gfc_add_finalizer_call (&final_block, expr1))
+    return NULL_TREE;
+
+  lhs_attr = gfc_expr_attr (expr1);
+
+  /* Check allocatable/pointer is allocated/associated.  */
+  if (lhs_attr.allocatable || lhs_attr.pointer)
+    {
+      if (expr1->ts.type == BT_CLASS)
+	{
+	  ptr = gfc_get_class_from_gfc_expr (expr1);
+	  gcc_assert (ptr != NULL_TREE);
+	  ptr = gfc_class_data_get (ptr);
+	  if (lhs_attr.dimension)
+	    ptr = gfc_conv_descriptor_data_get (ptr);
+	}
+      else
+	{
+	  gfc_init_se (&se, NULL);
+	  if (expr1->rank)
+	    {
+	      gfc_conv_expr_descriptor (&se, expr1);
+	      ptr = gfc_conv_descriptor_data_get (se.expr);
+	    }
+	  else
+	    {
+	      gfc_conv_expr (&se, expr1);
+	      ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
+	    }
+	}
+
+      cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			      ptr, build_zero_cst (TREE_TYPE (ptr)));
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, gfc_finish_block (&final_block),
+			       build_empty_stmt (input_location));
+    }
+  else
+    final_expr = gfc_finish_block (&final_block);
+
+  /* Check optional present.  */
+  if (sym->attr.optional)
+    {
+      cond = gfc_conv_expr_present (sym);
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, final_expr,
+			       build_empty_stmt (input_location));
+    }
+
+  return final_expr;
+}
+
+
 static tree
 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 			gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
@@ -11394,6 +11560,16 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 {
   tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
   vec<tree, va_gc> *args = NULL;
+  tree final_expr;
+
+  final_expr = gfc_assignment_finalizer_call (lhs, false);
+  if (final_expr != NULL_TREE)
+    {
+      if (rse->loop)
+	gfc_prepend_expr_to_block (&rse->loop->pre, final_expr);
+      else
+	gfc_add_expr_to_block (block, final_expr);
+    }
 
   /* Store the old vptr so that dynamic types can be compared for
      reallocation to occur or not.  */
@@ -11419,8 +11595,12 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 	old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
 
       size = gfc_vptr_size_get (vptr);
-      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
-	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      if (TREE_CODE (lse->expr) == INDIRECT_REF)
+	tmp = TREE_OPERAND (lse->expr, 0);
+      else
+	tmp = lse->expr;
+      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+	  ? gfc_class_data_get (tmp) : tmp;
 
       /* Allocate block.  */
       gfc_init_block (&alloc);
@@ -11519,6 +11699,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
     }
 }
 
+
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
    init_flag indicates initialization expressions and dealloc that no
@@ -11542,6 +11723,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   tree tmp;
   stmtblock_t block;
   stmtblock_t body;
+  tree final_expr;
   bool l_is_temp;
   bool scalar_to_array;
   tree string_length;
@@ -11582,6 +11764,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      needed at two locations, so do it once only before the information is
      needed.  */
   lhs_attr = gfc_expr_attr (expr1);
+
   is_poly_assign = (use_vptr_copy || lhs_attr.pointer
 		    || (lhs_attr.allocatable && !lhs_attr.dimension))
 		   && (expr1->ts.type == BT_CLASS
@@ -11855,6 +12038,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  else
 	    gfc_add_expr_to_block (&loop.post, tmp2);
 	}
+
+      expr1->must_finalize = 0;
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB
 	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -11900,6 +12085,32 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	}
     }
 
+  /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+     after evaluation of the rhs and before reallocation.  */
+  final_expr = gfc_assignment_finalizer_call (expr1, init_flag);
+  if (final_expr
+      && !(expr2->expr_type == EXPR_VARIABLE
+	   && expr2->symtree->n.sym->attr.artificial))
+    {
+      if (lss == gfc_ss_terminator)
+	{
+	  if (tmp != NULL_TREE && final_expr != NULL_TREE)
+	    {
+	      gfc_add_block_to_block (&block, &rse.pre);
+	      gfc_add_expr_to_block (&block, final_expr);
+	    }
+	  else
+	    gfc_add_expr_to_block (&lse.finalblock, final_expr);
+	}
+      else
+	{
+	  gfc_add_block_to_block (&body, &rse.pre);
+	  gfc_add_expr_to_block (&loop.code[expr1->rank - 1], final_expr);
+	}
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.pre);
+
   /* If nothing else works, do it the old fashioned way!  */
   if (tmp == NULL_TREE)
     tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
@@ -11909,12 +12120,18 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 				   !(l_is_temp || init_flag) && dealloc,
 				   expr1->symtree->n.sym->attr.codimension);
 
-  /* Add the pre blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.pre);
+
+  /* Add the lse pre block to the body  */
   gfc_add_block_to_block (&body, &lse.pre);
   gfc_add_expr_to_block (&body, tmp);
   /* Add the post blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.post);
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_add_block_to_block (&rse.finalblock, &rse.post);
+      gfc_add_block_to_block (&body, &rse.finalblock);
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.post);
   gfc_add_block_to_block (&body, &lse.post);
 
   if (lss == gfc_ss_terminator)
@@ -11979,6 +12196,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       /* Wrap the whole thing up.  */
       gfc_add_block_to_block (&block, &loop.pre);
       gfc_add_block_to_block (&block, &loop.post);
+      gfc_add_block_to_block (&block, &rse.finalblock);
 
       gfc_cleanup_loop (&loop);
     }
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 732221f848b..bf4f0671585 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2664,6 +2664,7 @@ scalarize:
 
   gfc_add_block_to_block (&body, &se.pre);
   gfc_add_block_to_block (&body, &se.post);
+  gfc_add_block_to_block (&body, &se.finalblock);
 
   if (se.ss == NULL)
     tmp = gfc_finish_block (&body);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 04f8147d23b..e0f513f8941 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -443,7 +443,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       else
 	gfc_add_expr_to_block (&se.pre, se.expr);
 
-      gfc_add_block_to_block (&se.pre, &se.post);
+      gfc_add_block_to_block (&se.finalblock, &se.post);
+      gfc_add_block_to_block (&se.pre, &se.finalblock);
     }
 
   else
@@ -542,6 +543,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       gfc_trans_scalarizing_loops (&loop, &body);
       gfc_add_block_to_block (&se.pre, &loop.pre);
       gfc_add_block_to_block (&se.pre, &loop.post);
+      gfc_add_block_to_block (&se.pre, &loopse.finalblock);
       gfc_add_block_to_block (&se.pre, &se.post);
       gfc_cleanup_loop (&loop);
     }
@@ -6337,7 +6339,10 @@ gfc_trans_allocate (gfc_code * code)
 	}
       gfc_add_block_to_block (&block, &se.pre);
       if (code->expr3->must_finalize)
-	gfc_add_block_to_block (&final_block, &se.post);
+	{
+	  gfc_add_block_to_block (&final_block, &se.finalblock);
+	  gfc_add_block_to_block (&final_block, &se.post);
+	}
       else
 	gfc_add_block_to_block (&post, &se.post);
 
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 333dfa69642..fabdcde7267 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1242,6 +1242,9 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
   if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
     return false;
 
+  if (gfc_expr_attr (expr2).artificial)
+    return false;
+
   if (expr2->ts.type == BT_DERIVED)
     {
       gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 738c7487a56..72af54c4d29 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -43,6 +43,10 @@ typedef struct gfc_se
   stmtblock_t pre;
   stmtblock_t post;
 
+  /* Carries finalization code that is required to be executed execution of the
+     innermost executable construct.  */
+  stmtblock_t finalblock;
+
   /* the result of the expression */
   tree expr;
 
@@ -55,7 +59,7 @@ typedef struct gfc_se
 
   /* Whether expr is a reference to an unlimited polymorphic object.  */
   unsigned unlimited_polymorphic:1;
-  
+
   /* If set gfc_conv_variable will return an expression for the array
      descriptor. When set, want_pointer should also be set.
      If not set scalarizing variables will be substituted.  */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
index 92dc50756d4..de20a147842 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
@@ -68,4 +68,4 @@ contains
   end function func_foo_a
 
 end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }

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

! { dg-do run }
!
! Test the fix for PR71798 in which the result of 'create_mytype'
! was not being finalized after the completion of the assignment
! statement.
!
! Contributed by Jonathan Hogg  <jhogg41@gmail.com>
!
module mymod
   implicit none

   integer :: next = 0

   type :: mytype
      integer :: idx = -1
   contains
      procedure :: mytype_assign
      generic :: assignment(=) => mytype_assign
      final :: mytype_final
   end type mytype

contains
   subroutine mytype_assign(this, other)
      class(mytype), intent(inout) :: this
      class(mytype), intent(in) :: other

      this%idx = next
      next = next + 1
      if (next /= 2) stop 2
   end subroutine mytype_assign

   subroutine mytype_final(this)
      type(mytype) :: this
      next = next + 1
      if (next /= 3) stop 3
   end subroutine mytype_final

   type(mytype) function create_mytype()
      create_mytype%idx = next
      next = next + 1
      if (next /= 1) stop 1
   end function create_mytype

end module mymod

program test
   use mymod
   implicit none

   type(mytype) :: x

   x = create_mytype()

end program test

[-- Attachment #4: finalize_40.f90 --]
[-- Type: text/x-fortran, Size: 836 bytes --]

! { dg-do run }
!
! Test that PR67471 is fixed. Used not to call the finalizer.
!
! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
!
module test_final_mod
  implicit none
  type :: my_final
    integer :: n = 1
  contains
    final :: destroy_rank1_array
  end type my_final
  integer :: final_calls = 0
contains
  subroutine destroy_rank1_array(self)
    type(my_final), intent(inout) :: self(:)
    if (size(self) /= 0) then
      if (size(self) /= 2) stop 1
      if (any (self%n /= [3,4])) stop 2
    else
      stop 3
    end if
    final_calls = final_calls + 1
  end subroutine destroy_rank1_array
end module test_final_mod

program test_finalizer
  use test_final_mod
  implicit none
  type(my_final) :: b(4), c(2)

  b%n = [2, 3, 4, 5]
  c%n = [6, 7]
  b(2:3) = c
  if (final_calls /= 1) stop 4
end program test_finalizer

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

! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
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)
    type(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)  stop 1 + off
    if (check_scalar .ne. scalar) stop 2 + off
    if (any (check_array(1:size (array, 1)) .ne. array)) stop 3 + off
    if (present (rind)) then
      if (check_real .ne. rind) stop 4 + off
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) stop 5 + off
    end if
  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 - one finalization of 'var' before (re)allocation.
  MyType = ThyType
  call test(1, 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).
  MyType = MyType2
  call test(2, 1, [0,0], 10)

  allocate(MyTypeArray(2))
  MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)].
  MyTypeArray = [ThyType, ThyType2]
  call test(3, 0, [42,43], 20)

! This should result in a final call with self = initialization = simple(22).
  ThyType2 = simple(99)
  call test(4, 22, [0,0], 30)

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

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

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

! Check that rhs function expressions do not interfere with finalization.
! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
  allocate (MyType, source = simple (11))
  MyType = constructor1 (99)
  call test(10, 99, [0,0], 70)

  deallocate (MyType)
! *****************
! Class assignments
! *****************

  final_count = 0

  allocate (MyClass, source = simple (3))
! This should result in a final call with the allocated value.
  MyClass = simple (4)
  call test(1, 3, [0,0], 100)

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

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

  MyClassArray = [simple (7), simple (8)]
! The final call should return the value before the assignment.
  call test(2, 4, [0,0], 130)

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

! This should produce no final calls.
  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(5, 0, [1, 3], 150, rarray = [2.0, 4.0])

! Since 'constructor2; must finalize 'src' after the finalization of
! 'MyClassArray', the result in 'check_array' should be [10,20].
  MyClassArray = constructor2 ([10,20], [10.0,20.0])
  call test(9, 0, [10,20], 160, rarray = [10.0,20.0])

  deallocate (MyClassArray)
  call test(11, 0, [10, 20], 170, rarray = [10.0,20.0])
end program test_final

[-- Attachment #6: finalize_41.f90 --]
[-- Type: text/x-fortran, Size: 3335 bytes --]

! { dg-do run }
!
! Test that PR69298 is fixed. Used to segfault on finalization in
! subroutine 'in_type'.
!
! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
!
module stuff_mod
  implicit none
  private
  public :: stuff_type, final_calls
  type stuff_type
    private
    integer :: junk
  contains
    procedure get_junk
    procedure stuff_copy_initialiser
    generic :: assignment(=) => stuff_copy_initialiser
    final :: stuff_scalar_finaliser, &
             stuff_1d_finaliser
  end type stuff_type
  integer :: final_calls = 0
  interface stuff_type
    procedure stuff_initialiser
  end interface stuff_type
contains

  function stuff_initialiser( junk ) result(new_stuff)
    implicit none
    type(stuff_type) :: new_stuff
    integer :: junk
    new_stuff%junk = junk
  end function stuff_initialiser

  subroutine stuff_copy_initialiser( destination, source )
    implicit none
    class(stuff_type), intent(out) :: destination
    class(stuff_type), intent(in)  :: source
    destination%junk = source%junk
  end subroutine stuff_copy_initialiser

  subroutine stuff_scalar_finaliser( this )
    implicit none
    type(stuff_type), intent(inout) :: this
    final_calls = final_calls + 1
  end subroutine stuff_scalar_finaliser

  subroutine stuff_1d_finaliser( this )
    implicit none
    type(stuff_type), intent(inout) :: this(:)
    integer :: i
    final_calls = final_calls + 100
  end subroutine stuff_1d_finaliser

  function get_junk( this ) result(junk)
    implicit none
    class(stuff_type), intent(in) :: this
    integer :: junk
    junk = this%junk
  end function get_junk
end module stuff_mod

module test_mod
  use stuff_mod, only : stuff_type, final_calls
  implicit none
  private
  public :: test_type
  type test_type
    private
    type(stuff_type) :: thing
    type(stuff_type) :: things(3)
  contains
    procedure get_value
  end type test_type
  interface test_type
    procedure test_type_initialiser
  end interface test_type
contains

  function test_type_initialiser() result(new_test)
    implicit none
    type(test_type) :: new_test
    integer :: i
    new_test%thing = stuff_type( 4 )
    do i = 1, 3
      new_test%things(i) = stuff_type( i )
    end do
  end function test_type_initialiser

  function get_value( this ) result(value)
    implicit none
    class(test_type) :: this
    integer :: value
    integer :: i
    value = this%thing%get_junk()
    do i = 1, 3
      value = value + this%things(i)%get_junk()
    end do
  end function get_value
end module test_mod

program test
  use stuff_mod, only : stuff_type, final_calls
  use test_mod,  only : test_type
  implicit none
  call here()
  call in_type()
! 21 calls to scalar finalizer and 4 to the vector version
  if (final_calls .ne. 421) stop 1
contains

  subroutine here()
    implicit none
    type(stuff_type) :: thing
    type(stuff_type) :: bits(3)
    integer :: i
    integer :: tally
    thing = stuff_type(4)
    do i = 1, 3
      bits(i) = stuff_type(i)
    end do
    tally = thing%get_junk()
    do i = 1, 3
      tally = tally + bits(i)%get_junk()
    end do
    if (tally .ne. 10) stop 2
  end subroutine here

  subroutine in_type()
    implicit none
    type(test_type) :: thing
    thing = test_type()
    if (thing%get_value() .ne. 10) stop 2
  end subroutine in_type
end program test

[-- Attachment #7: finalize_39.f90 --]
[-- Type: text/x-fortran, Size: 1998 bytes --]

! { dg-do run }
!
! Test the fix for PR67444 in which the finalization of a polymorphic 'var'
! was not being finalized before assignment. (STOP 3)
!
! Contributed by Balint Aradi  <baladi@gmail.com>
!
module classes
  implicit none
  integer :: ivalue = 0
  integer :: icall = 0
  integer :: fvalue = 0

  type :: Basic
    integer :: ii = -1
  contains
    procedure :: assignBasic
    generic :: assignment(=) => assignBasic
    final :: destructBasic
  end type Basic
  interface Basic
    module procedure initBasic
  end interface Basic
contains
  function initBasic(initValue) result(this)
    integer, intent(in) :: initValue
    type(Basic) :: this
    this%ii = initValue
    icall = icall + 1
  end function initBasic
  subroutine assignBasic(this, other)
    class(Basic), intent(out) :: this
    type(Basic), intent(in) :: other
    this%ii = other%ii + 1
    icall = other%ii
  end subroutine assignBasic
  subroutine destructBasic(this)
    type(Basic), intent(inout) :: this
    fvalue = fvalue + 1
    select case (fvalue)
    case (1)
        if (this%ii /= -1) stop 1          ! First finalization before assignment to 'var'
        if (icall /= 1) stop 2             ! and before evaluation of 'expr'.
    case(2)
        if (this%ii /= ivalue) stop 3      ! Finalization of intent(out) in 'assignBasic'
        if (icall /= 42) stop 4            ! and after evaluation of 'expr'.
    case(3)
        if (this%ii /= ivalue + 1) stop 5  ! Finalization of 'expr' (function!) after assignment.
    case default
        stop 6                             ! Too many or no finalizations
    end select
  end subroutine destructBasic
end module classes

module usage
  use classes
  implicit none
contains
  subroutine useBasic()
    type(Basic) :: bas
    ivalue = 42
    bas = Basic(ivalue)
  end subroutine useBasic
end module usage

program test
  use usage
  implicit none
  call useBasic()
  if (fvalue /= 3) stop 7                  ! 3 finalizations mandated.
end program test

[-- Attachment #8: finalize_43.f90 --]
[-- Type: text/x-fortran, Size: 1117 bytes --]

! { dg-do run }
!
! Test the fix for PR80524, where gfortran on issued one final call
! For 'u' going out of scope. Two further call should be emitted; one
! for the lhs of the assignment in 's' and the other for the function
! result, which occurs after assignment.
!
! Contributed by Andrew Wood  <andrew@fluidgravity.co.uk>
!
MODULE m1
   IMPLICIT NONE
   integer :: counter = 0
   integer :: fval = 0
   TYPE t
      INTEGER :: i
      CONTAINS
         FINAL :: t_final
   END TYPE t
   CONTAINS
      SUBROUTINE t_final(this)
         TYPE(t) :: this
         counter = counter + 1
      END SUBROUTINE
      FUNCTION new_t()
         TYPE(t) :: new_t
         new_t%i = 1
         fval = new_t%i
         if (counter /= 0) stop 1   ! Finalization of 'var' after evaluation of 'expr'
      END FUNCTION new_t
      SUBROUTINE s
         TYPE(t) :: u
         u = new_t()
         if (counter /= 2) stop 2   ! Finalization of 'var' and 'expr'
      END SUBROUTINE s
END MODULE m1
PROGRAM prog
   USE m1
   IMPLICIT NONE
   CALL s
   if (counter /= 3) stop 3         ! Finalization of 'u' in 's'
END PROGRAM prog

[-- Attachment #9: finalize_46.f90 --]
[-- Type: text/x-fortran, Size: 1301 bytes --]

! { dg-do run }
!
! Test the fix for pr88735 in which non-finalizable entities were being
! finalized because they had finalizable components and 'var' in defined
! assignments was being finalized.
!
! Contributed by Martin Stein  <mscfd@gmx.net>
!
module mod
  implicit none
  type, public :: t
     integer, allocatable :: i
  contains
     procedure, public :: set
     generic, public :: assignment(=) => set
     final :: finalise
  end type t
  integer, public :: final_count = 0

contains

  subroutine set(self, x)
     class(t), intent(inout) :: self
     class(t), intent(in)  :: x
     if (allocated(x%i)) then
        self%i = x%i
        self%i = self%i + 1
     end if
end subroutine set

  subroutine finalise(self)
     type(t), intent(inout) :: self
     if (allocated(self%i)) then
        final_count = final_count + 1
        deallocate(self%i)
     end if
  end subroutine finalise

end module mod

program finalise_assign
  use mod
  implicit none
  type :: s
     type(t) :: x
  end type s
  type(s) :: a, b
  type(t) :: c
  a%x%i = 123
! Produces no final calls because 'b' is not a 'finalizable entity'.
  b = a
  if (final_count /= 0) stop 1
! Produces no final calls because this is a defined assignment.
  c = a%x
  if (final_count /= 0) stop 2
end program finalise_assign

[-- Attachment #10: finalize_44.f90 --]
[-- Type: text/x-fortran, Size: 2916 bytes --]

! { dg-do run }
!
! Test the fix for all three variants of PR82996, which used to
! segfault in the original testcase and ICE in the testcases of
! comments 1 and 2.
!
! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
!
module mod0
  integer :: final_count_foo = 0
  integer :: final_count_bar = 0
end module mod0
!
! This is the original testcase, with a final routine 'foo' but
! but not in the container type 'bar1'.
!
module mod1
  use mod0
  private foo, foo_destroy
  type foo
    integer, pointer :: f(:) => null()
  contains
    final :: foo_destroy
  end type
  type bar1
    type(foo) :: b(2)
  end type
contains
  impure elemental subroutine foo_destroy(this)
    type(foo), intent(inout) :: this
    final_count_foo = final_count_foo + 1
    if (associated(this%f)) deallocate(this%f)
  end subroutine
end module mod1
!
! Comment 1 was the same as original, except that the
! 'foo' finalizer is elemental and a 'bar' finalizer is added..
!
module mod2
  use mod0
  private foo, foo_destroy, bar_destroy
  type foo
    integer, pointer :: f(:) => null()
  contains
    final :: foo_destroy
  end type
  type bar2
    type(foo) :: b(2)
  contains
    final :: bar_destroy
  end type
contains
  impure elemental subroutine foo_destroy(this)
    type(foo), intent(inout) :: this
    final_count_foo = final_count_foo + 1
    if (associated(this%f)) deallocate(this%f)
  end subroutine
  subroutine bar_destroy(this)
    type(bar2), intent(inout) :: this
    final_count_bar = final_count_bar + 1
    call foo_destroy(this%b)
  end subroutine
end module mod2
!
! Comment 2 was the same as comment 1, except that the 'foo'
! finalizer is no longer elemental.
!
module mod3
  use mod0
  private foo, foo_destroy, bar_destroy
  type foo
    integer, pointer :: f(:) => null()
  contains
    final :: foo_destroy
  end type
  type bar3
    type(foo) :: b(2)
  contains
    final :: bar_destroy
  end type
contains
  subroutine foo_destroy(this)
    type(foo), intent(inout) :: this
    final_count_foo = final_count_foo + 1
    if (associated(this%f)) deallocate(this%f)
  end subroutine
  subroutine bar_destroy(this)
    type(bar3), intent(inout) :: this
    final_count_bar = final_count_bar + 1
    do j = 1, size(this%b)
      call foo_destroy(this%b(j))
    end do
  end subroutine
end module mod3

program main
  use mod0
  use mod1
  use mod2
  use mod3
  type(bar1) :: x
  type(bar2) :: y
  type(bar3) :: z
  call sub1(x)
  if (final_count_foo /= 2) stop 1
  if (final_count_bar /= 0) stop 2
  call sub2(y)
  if (final_count_foo /= 6) stop 3
  if (final_count_bar /= 1) stop 4
  call sub3(z)
  if (final_count_foo /= 8) stop 5
  if (final_count_bar /= 2) stop 6
contains
  subroutine sub1(x)
    type(bar1), intent(out) :: x
  end subroutine
  subroutine sub2(x)
    type(bar2), intent(out) :: x
  end subroutine
  subroutine sub3(x)
    type(bar3), intent(out) :: x
  end subroutine
end program

[-- Attachment #11: finalize_47.f90 --]
[-- Type: text/x-fortran, Size: 2918 bytes --]

! { dg-do run }
!
! Test the fix for pr91396 in which some of the expected finalizations
! did not occur; within s3 and s4 scopes.
!
! Contributed by Jose Rui Faustine de Sousa  <jrfsousa@gcc.gnu.org>
!
module final_m

  implicit none

  private

  public ::        &
    assignment(=)

  public :: &
    final_t

  integer, public :: final_count

  public ::     &
    final_init, &
    final_set,  &
    final_get,  &
    final_end

  type :: final_t
    private
    integer :: n = -1
  contains
    final :: final_end
  end type final_t

  interface assignment(=)
    module procedure final_init
  end interface assignment(=)

contains

  elemental subroutine final_init(this, n)
    type(final_t), intent(out) :: this
    integer,       intent(in)  :: n

    this%n = n
    return
  end subroutine final_init

  elemental function final_set(n) result(this)
    integer, intent(in) :: n

    type(final_t) :: this

    this%n = n
    return
  end function final_set

  elemental function final_get(this) result(n)
    type(final_t), intent(in) :: this

    integer :: n

    n = this%n
    return
  end function final_get

  subroutine final_end(this)
    type(final_t), intent(inout) :: this

    final_count = final_count + 1
    this%n = -1
    return
  end subroutine final_end

end module final_m

program final_p

  use final_m

  implicit none

  type(final_t) :: f0

!  print *, "enter main"
  call final_init(f0, 0)
!  print *, "enter final_s1"
  call final_s1()
!  print *, "exit final_s1"
!  print *, "enter final_s2"
  call final_s2()
!  print *, "exit final_s2"
!  print *, "enter final_s3"
  call final_s3()
!  print *, "exit final_s3"
!  print *, "enter final_s4"
  call final_s4()
!  print *, "exit final_s4"
!  print *, "f0: ", final_get(f0)
  ! this should be automatic...
  call final_end(f0)
  if (final_count /= 10) stop 1
  stop

contains

  subroutine final_s1()

    type(final_t) :: f

    call final_init(f, 1)
    print *, "f1: ", final_get(f)
! Two finalizations for INTENT(OUT) in final_init this scope and main program.
    if (final_count /= 2) stop 2
    return
  end subroutine final_s1

  subroutine final_s2()

    type(final_t) :: f

    f = 2
! One finalization for INTENT(OUT) in final_init, used in the defined assignment
! and one for leaving 's1' scope.
    if (final_count /= 4) stop 3
    print *, "f2: ", final_get(f)
    return
  end subroutine final_s2

  subroutine final_s3()

    type(final_t) :: f

    f = final_set(3)
    print *, "f3: ", final_get(f)
! One finalization for 'var, in the assignment, one for the result of final_set
! and one for leaving 's2' scope.
    if (final_count /= 7) stop 4
    return
  end subroutine final_s3

  subroutine final_s4()

    print *, "f4: ", final_get(final_set(4)), " ", final_count
! One finalization for the result of final_set and one for leaving 's3' scope.
    return
  end subroutine final_s4

end program final_p


[-- Attachment #12: finalize_45.f90 --]
[-- Type: text/x-fortran, Size: 2173 bytes --]

! { dg-do run }
!
! Test the fix for PR84472 in which the finalizations around the
! assignment in 'mymain' were not happening.
!
! Contributed by Vipul Parekh  <fortranfan@outlook.com>
!
module m

   use, intrinsic :: iso_fortran_env, only : output_unit

   implicit none

   private

   integer, public :: final_counts = 0
   integer, public :: assoc_counts = 0

   type :: t
      private
      character(len=:), pointer :: m_s => null()
   contains
      private
      final :: final_t
      procedure, pass(this), public :: clean => clean_t
      procedure, pass(this), public :: init => init_t
   end type

   interface t
      module procedure :: construct_t
   end interface

   public :: t

contains

   function construct_t( name ) result(new_t)

      ! argument list
      character(len=*), intent(in), optional :: name
      ! function result
      type(t) :: new_t

      if ( present(name) ) then
         call new_t%init( name )
      end if

   end function

   subroutine final_t( this )

      ! argument list
      type(t), intent(inout) :: this

      final_counts = final_counts + 1
      if ( associated(this%m_s) ) then
         assoc_counts = assoc_counts + 1
      endif
      call clean_t( this )

   end subroutine

   subroutine clean_t( this )

      ! argument list
      class(t), intent(inout) :: this

      if ( associated(this%m_s) ) then
         deallocate( this%m_s )
      end if
      this%m_s => null()

   end subroutine

   subroutine init_t( this, mname )

      ! argument list
      class(t), intent(inout)      :: this
      character(len=*), intent(in) :: mname

      call this%clean()
      allocate(character(len(mname)) :: this%m_s)
      this%m_s = mname

   end subroutine

end module
   use m, only : final_counts, assoc_counts
   call mymain
   if (final_counts /= 3) stop 1
   if (assoc_counts /= 2) stop 2

contains
   subroutine mymain

   use m, only : t

   implicit none

   character(3), allocatable, target :: myname

   type(t) :: foo

   call foo%init( mname="123" )

   myname = "foo"
   foo = t( myname )

   call foo%clean()
   if (final_counts /= 2) stop 3
   if (assoc_counts /= 2) stop 4
   end
end

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

[Harald Anlauf]

Hi Paul,

thanks for attacking this.

I haven't looked at the actual patch, only tried to check the new
testcases with other compilers.

Am 03.02.22 um 18:14 schrieb Paul Richard Thomas via Fortran:
> I have tried to interpret F2018 7.5.6.2 and 7.5.6.3 as well as possible.
> This is not always straightforward and has involved a lot of head
> scratching! I have used the Intel compiler as a litmus test for the
> outcomes. This was largely motivated by the observation that, in the user
> survey conducted by Steve Lionel, gfortran and ifort are often used
> together . Therefore, quite aside from wishing to comply with the standard
> as far as possible, it is more than reasonable that the two compilers
> comply. On application of this patch, only exception to this is the
> treatment of finalization of arrays of extended types, where the Intel
> takes "If the entity is of extended type and the parent type is
> finalizable, the parent component is finalized" such that the parent
> component is finalized one element at a time, whereas gfortran finalises
> the parent components as an array. I strongly suspect that, from reading
> 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However, this
> is another issue to come back to in the future.

Could you specify which version of Intel you tried?

Testcase finalize_38.f90 fails for me with ifort 2021.5.0 with:

131

This test also fails with crayftn 11 & 12 and nagfor 7.0,
but in a different place.

(Also finalize_45.f90 fails with that version with something that
looks like memory corruption, but that might be just a compiler bug.)

Thanks,
Harald

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

[Harald Anlauf]

Hi Paul,

thanks for attacking this.

I haven't looked at the actual patch, only tried to check the new
testcases with other compilers.

Am 03.02.22 um 18:14 schrieb Paul Richard Thomas via Fortran:
> I have tried to interpret F2018 7.5.6.2 and 7.5.6.3 as well as possible.
> This is not always straightforward and has involved a lot of head
> scratching! I have used the Intel compiler as a litmus test for the
> outcomes. This was largely motivated by the observation that, in the user
> survey conducted by Steve Lionel, gfortran and ifort are often used
> together . Therefore, quite aside from wishing to comply with the standard
> as far as possible, it is more than reasonable that the two compilers
> comply. On application of this patch, only exception to this is the
> treatment of finalization of arrays of extended types, where the Intel
> takes "If the entity is of extended type and the parent type is
> finalizable, the parent component is finalized" such that the parent
> component is finalized one element at a time, whereas gfortran finalises
> the parent components as an array. I strongly suspect that, from reading
> 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However, this
> is another issue to come back to in the future.

Could you specify which version of Intel you tried?

Testcase finalize_38.f90 fails for me with ifort 2021.5.0 with:

131

This test also fails with crayftn 11 & 12 and nagfor 7.0,
but in a different place.

(Also finalize_45.f90 fails with that version with something that
looks like memory corruption, but that might be just a compiler bug.)

Thanks,
Harald

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 1853 bytes --]

Hi Harald,

Thanks for giving the patch a whirl.


> the parent components as an array. I strongly suspect that, from reading
> > 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However,
> this
> > is another issue to come back to in the future.
>
> Could you specify which version of Intel you tried?
>

ifort (IFORT) 2021.1 Beta 20201112

>
> Testcase finalize_38.f90 fails for me with ifort 2021.5.0 with:
>
> 131
>

That's the point where the interpretation of the standard diverges. Ifort
uses the scalar finalization for the parent component, whereas gfortran
uses the rank 1. Thus the final count is different by one. I have a version
of the patch, where gfortran behaves in the same way as ifort.


> This test also fails with crayftn 11 & 12 and nagfor 7.0,
> but in a different place.
>



>
> (Also finalize_45.f90 fails with that version with something that
> looks like memory corruption, but that might be just a compiler bug.)
>

I take it 'that version' is of ifort? Mine does the same. I suspect that it
is one of the perils of using pointer components in such circumstances! You
will notice that I had to nullify pointer components when doing the copy.

>
> Thanks,
> Harald
>

Could you use the attached version of finalize_38.f90 with crayftn and NAG?
All the stop statements are replaced with prints. Ifort gives:
         131           3           2
         132           0           4
         133           5           6 |           0           0
         141           4           3
         151           7           5
         152           3           0
         153           0           0 |           1           3
         161          13           9
         162          20           0
         163           0           0 |          10          20
         171          14          11

Best regards

Paul

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

! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
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)
    type(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)  print *, 1 + off, final_count, cnt
    if (check_scalar .ne. scalar) print *, 2 + off, check_scalar, scalar
    if (any (check_array(1:size (array, 1)) .ne. array)) print *,  3 + off, &
                                       check_array(1:size (array, 1)), "|", array
    if (present (rind)) then
      if (check_real .ne. rind)  print *,  4+off, check_real, rind
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) print *,  5 + off, &
                                       check_rarray(1:size (rarray, 1)), "|", rarray
    end if
  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 - one finalization of 'var' before (re)allocation.
  MyType = ThyType
  call test(1, 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).
  MyType = MyType2
  call test(2, 1, [0,0], 10)

  allocate(MyTypeArray(2))
  MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)].
  MyTypeArray = [ThyType, ThyType2]
  call test(3, 0, [42,43], 20)

! This should result in a final call with self = initialization = simple(22).
  ThyType2 = simple(99)
  call test(4, 22, [0,0], 30)

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

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

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

! Check that rhs function expressions do not interfere with finalization.
! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
  allocate (MyType, source = simple (11))
  MyType = constructor1 (99)
  call test(10, 99, [0,0], 70)

  deallocate (MyType)
! *****************
! Class assignments
! *****************

  final_count = 0

  allocate (MyClass, source = simple (3))
! This should result in a final call with the allocated value.
  MyClass = simple (4)
  call test(1, 3, [0,0], 100)

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

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

  MyClassArray = [simple (7), simple (8)]
! The final call should return the value before the assignment.
  call test(2, 4, [0,0], 130)

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

! This should produce no final calls.
  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(5, 0, [1, 3], 150, rarray = [2.0, 4.0])

! Since 'constructor2; must finalize 'src' after the finalization of
! 'MyClassArray', the result in 'check_array' should be [10,20].
  MyClassArray = constructor2 ([10,20], [10.0,20.0])
  call test(9, 0, [10,20], 160, rarray = [10.0,20.0])

  deallocate (MyClassArray)
  call test(11, 0, [10, 20], 170, rarray = [10.0,20.0])
end program test_final

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

[Harald Anlauf]

Hi Paul,

Am 08.02.22 um 12:22 schrieb Paul Richard Thomas via Fortran:
> Hi Harald,
>
> Thanks for giving the patch a whirl.
>
>
>> the parent components as an array. I strongly suspect that, from reading
>>> 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However,
>> this
>>> is another issue to come back to in the future.
>>
>> Could you specify which version of Intel you tried?
>>
>
> ifort (IFORT) 2021.1 Beta 20201112

ok, that's good to know.

>>
>> Testcase finalize_38.f90 fails for me with ifort 2021.5.0 with:
>>
>> 131
>>
>> This test also fails with crayftn 11 & 12 and nagfor 7.0,
>> but in a different place.
>>

I have run your modified version of finalize_38.f90, and now I see
that you can get a bloody head just from scratching too much...

crayftn 12.0.2:

  1,  3,  1
  2,  21,  0
  11,  3,  2
  12,  21,  1
  21,  4,  3
  23,  21,  22 | 42,  43
  31,  6,  4
  41,  7,  5
  51,  9,  7
  61,  10,  8
  71,  13,  10
  101,  2,  1
  102,  4,  3
  111,  3,  2
  121,  4,  2
  122,  0,  4
  123,  5,  6 | 2*0
  131,  5,  2
  132,  0,  4
  133,  7,  8 | 2*0
  141,  6,  3
  151,  10,  5
  161,  16,  9
  171,  18,  11
  175,  0.,  20. | 10.,  20.

nagfor 7.0:

  1 0 1
  11 1 2
  23 21 22 | 42 43
  71 9 10
  72 11 99
  131 3 2
  132 5 4
  141 4 3
  151 6 5
  161 10 9
  171 12 11

Intel 2021.5.0:

          131           3           2
          132           0           4
          133           5           6 |           0           0
          141           4           3
          151           7           5
          152           3           0
          153           0           0 |           1           3
forrtl: severe (174): SIGSEGV, segmentation fault occurred
[...]


That got me reading 7.5.6.3, where is says in paragraph 1:

"When an intrinsic assignment statement is executed (10.2.1.3), if the
variable is not an unallocated allocatable variable, it is finalized
after evaluation of expr and before the definition of the variable.
..."

Looking at the beginning of the testcase code (abridged):

   type(simple), allocatable :: MyType, MyType2
   type(simple) :: ThyType = simple(21), ThyType2 = simple(22)

! The original PR - one finalization of 'var' before (re)allocation.
   MyType = ThyType
   call test(1, 0, [0,0], 0)


This is an intrinsic assignment.

Naively I would expect MyType to be initially unallocated.

ThyType is not allocatable and non-pointer and cannot become
undefined here and would not play any role in finalization.

I am probably too blind-sighted to see why there should be
a finalization here.  What am I missing?

> Could you use the attached version of finalize_38.f90 with crayftn and NAG?
> All the stop statements are replaced with prints. Ifort gives:
>           131           3           2
>           132           0           4
>           133           5           6 |           0           0
>           141           4           3
>           151           7           5
>           152           3           0
>           153           0           0 |           1           3
>           161          13           9
>           162          20           0
>           163           0           0 |          10          20
>           171          14          11

I think it is a good idea to have these prints in the testcase
whenever there is a departure from expectations.  So print&stop?

Furthermore, for the sake of health of people reading the testcases
later, I think it would not harm to add more explanations why we
expect a certain behavior... ;-)

> Best regards
>
> Paul

Best regards,
Harald

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

[Harald Anlauf]

Hi Paul,

Am 08.02.22 um 12:22 schrieb Paul Richard Thomas via Fortran:
> Hi Harald,
> 
> Thanks for giving the patch a whirl.
> 
> 
>> the parent components as an array. I strongly suspect that, from reading
>>> 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However,
>> this
>>> is another issue to come back to in the future.
>>
>> Could you specify which version of Intel you tried?
>>
> 
> ifort (IFORT) 2021.1 Beta 20201112

ok, that's good to know.

>>
>> Testcase finalize_38.f90 fails for me with ifort 2021.5.0 with:
>>
>> 131
>>
>> This test also fails with crayftn 11 & 12 and nagfor 7.0,
>> but in a different place.
>>

I have run your modified version of finalize_38.f90, and now I see
that you can get a bloody head just from scratching too much...

crayftn 12.0.2:

  1,  3,  1
  2,  21,  0
  11,  3,  2
  12,  21,  1
  21,  4,  3
  23,  21,  22 | 42,  43
  31,  6,  4
  41,  7,  5
  51,  9,  7
  61,  10,  8
  71,  13,  10
  101,  2,  1
  102,  4,  3
  111,  3,  2
  121,  4,  2
  122,  0,  4
  123,  5,  6 | 2*0
  131,  5,  2
  132,  0,  4
  133,  7,  8 | 2*0
  141,  6,  3
  151,  10,  5
  161,  16,  9
  171,  18,  11
  175,  0.,  20. | 10.,  20.

nagfor 7.0:

  1 0 1
  11 1 2
  23 21 22 | 42 43
  71 9 10
  72 11 99
  131 3 2
  132 5 4
  141 4 3
  151 6 5
  161 10 9
  171 12 11

Intel 2021.5.0:

          131           3           2
          132           0           4
          133           5           6 |           0           0
          141           4           3
          151           7           5
          152           3           0
          153           0           0 |           1           3
forrtl: severe (174): SIGSEGV, segmentation fault occurred
[...]


That got me reading 7.5.6.3, where is says in paragraph 1:

"When an intrinsic assignment statement is executed (10.2.1.3), if the
variable is not an unallocated allocatable variable, it is finalized
after evaluation of expr and before the definition of the variable.
..."

Looking at the beginning of the testcase code (abridged):

   type(simple), allocatable :: MyType, MyType2
   type(simple) :: ThyType = simple(21), ThyType2 = simple(22)

! The original PR - one finalization of 'var' before (re)allocation.
   MyType = ThyType
   call test(1, 0, [0,0], 0)


This is an intrinsic assignment.

Naively I would expect MyType to be initially unallocated.

ThyType is not allocatable and non-pointer and cannot become
undefined here and would not play any role in finalization.

I am probably too blind-sighted to see why there should be
a finalization here.  What am I missing?

> Could you use the attached version of finalize_38.f90 with crayftn and NAG?
> All the stop statements are replaced with prints. Ifort gives:
>           131           3           2
>           132           0           4
>           133           5           6 |           0           0
>           141           4           3
>           151           7           5
>           152           3           0
>           153           0           0 |           1           3
>           161          13           9
>           162          20           0
>           163           0           0 |          10          20
>           171          14          11

I think it is a good idea to have these prints in the testcase
whenever there is a departure from expectations.  So print&stop?

Furthermore, for the sake of health of people reading the testcases
later, I think it would not harm to add more explanations why we
expect a certain behavior... ;-)

> Best regards
> 
> Paul

Best regards,
Harald

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

[Jerry D]

Remember the days when reading very old cryptic Fortran code? Remember 
the fixed line lengths and cryptic variable names!

I fear the Standards committee has achieved history with the Standard 
itself it is so difficult to understand sometimes.

Cheers to Paul and Harald for digging on this.

Jerry

On 2/8/22 11:29 AM, Harald Anlauf via Fortran wrote:
> Hi Paul,
>
> Am 08.02.22 um 12:22 schrieb Paul Richard Thomas via Fortran:
>> Hi Harald,
>>
>> Thanks for giving the patch a whirl.
>>
>>
>>> the parent components as an array. I strongly suspect that, from 
>>> reading
>>>> 7.5.6.2 paragraphs 2 and 3 closely, that ifort has it right. However,
>>> this
>>>> is another issue to come back to in the future.
>>>
>>> Could you specify which version of Intel you tried?
>>>
>>
>> ifort (IFORT) 2021.1 Beta 20201112
>
> ok, that's good to know.
>
>>>
>>> Testcase finalize_38.f90 fails for me with ifort 2021.5.0 with:
>>>
>>> 131
>>>
>>> This test also fails with crayftn 11 & 12 and nagfor 7.0,
>>> but in a different place.
>>>
>
> I have run your modified version of finalize_38.f90, and now I see
> that you can get a bloody head just from scratching too much...
>
> crayftn 12.0.2:
>
>  1,  3,  1
>  2,  21,  0
>  11,  3,  2
>  12,  21,  1
>  21,  4,  3
>  23,  21,  22 | 42,  43
>  31,  6,  4
>  41,  7,  5
>  51,  9,  7
>  61,  10,  8
>  71,  13,  10
>  101,  2,  1
>  102,  4,  3
>  111,  3,  2
>  121,  4,  2
>  122,  0,  4
>  123,  5,  6 | 2*0
>  131,  5,  2
>  132,  0,  4
>  133,  7,  8 | 2*0
>  141,  6,  3
>  151,  10,  5
>  161,  16,  9
>  171,  18,  11
>  175,  0.,  20. | 10.,  20.
>
> nagfor 7.0:
>
>  1 0 1
>  11 1 2
>  23 21 22 | 42 43
>  71 9 10
>  72 11 99
>  131 3 2
>  132 5 4
>  141 4 3
>  151 6 5
>  161 10 9
>  171 12 11
>
> Intel 2021.5.0:
>
>          131           3           2
>          132           0           4
>          133           5           6 |           0           0
>          141           4           3
>          151           7           5
>          152           3           0
>          153           0           0 |           1           3
> forrtl: severe (174): SIGSEGV, segmentation fault occurred
> [...]
>
>
> That got me reading 7.5.6.3, where is says in paragraph 1:
>
> "When an intrinsic assignment statement is executed (10.2.1.3), if the
> variable is not an unallocated allocatable variable, it is finalized
> after evaluation of expr and before the definition of the variable.
> ..."
>
> Looking at the beginning of the testcase code (abridged):
>
>   type(simple), allocatable :: MyType, MyType2
>   type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
>
> ! The original PR - one finalization of 'var' before (re)allocation.
>   MyType = ThyType
>   call test(1, 0, [0,0], 0)
>
>
> This is an intrinsic assignment.
>
> Naively I would expect MyType to be initially unallocated.
>
> ThyType is not allocatable and non-pointer and cannot become
> undefined here and would not play any role in finalization.
>
> I am probably too blind-sighted to see why there should be
> a finalization here.  What am I missing?
>
>> Could you use the attached version of finalize_38.f90 with crayftn 
>> and NAG?
>> All the stop statements are replaced with prints. Ifort gives:
>>           131           3           2
>>           132           0           4
>>           133           5           6 |           0           0
>>           141           4           3
>>           151           7           5
>>           152           3           0
>>           153           0           0 |           1           3
>>           161          13           9
>>           162          20           0
>>           163           0           0 |          10          20
>>           171          14          11
>
> I think it is a good idea to have these prints in the testcase
> whenever there is a departure from expectations.  So print&stop?
>
> Furthermore, for the sake of health of people reading the testcases
> later, I think it would not harm to add more explanations why we
> expect a certain behavior... ;-)
>
>> Best regards
>>
>> Paul
>
> Best regards,
> Harald

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

[Paul Richard Thomas]

Hi Harald,


I have run your modified version of finalize_38.f90, and now I see
> that you can get a bloody head just from scratching too much...
>
> crayftn 12.0.2:
>
>   1,  3,  1
>
 It appears that Cray interpret a derived type constructor as being a
function call and so "6 If a specification expression in a scoping unit
references a function, the result is finalized before execution of the
executable constructs in the scoping unit."
A call to 'test' as the first statement might be useful to diagnose: call
test(2, 0, [0,0], -10)

>   2,  21,  0
>
21 is presumably the value left over from simple(21) but quite why it
should happen in this order is not apparent to me.

>   11,  3,  2
>
I am mystified as to why the finalization of 'var' is not occurring because
"1 When an intrinsic assignment statement is executed (10.2.1.3), if the
variable is not an unallocated allocatable variable, it is finalized after
evaluation of expr and before the definition of the variable." Note the
double negative! 'var' has been allocated and should return 1 to 'scalar'

>   12,  21,  1
>   21,  4,  3
>
This is a residue of earlier differences in the final count.

>   23,  21,  22 | 42,  43
>
The value is inexplicable to me.

  31,  6,  4
>   41,  7,  5
>   51,  9,  7
>   61,  10,  8
>   71,  13,  10
>   101,  2,  1
>
One again, a function 'expr' finalization has been added after intrinsic
assignment; ie. derived type constructor == function.

>   102,  4,  3
>


>   111,  3,  2
>   121,  4,  2
>   122,  0,  4
>   123,  5,  6 | 2*0
>
From the value of 'array', I would devine that the source in the allocation
is being finalized as an array, whereas I would expect each invocation of
'simple' to generate a scalar final call.

>   131,  5,  2
>   132,  0,  4
>   133,  7,  8 | 2*0
>
The final count has increased by 1, as expected.  The value of 'scalar' is
stuck at 0, so the second line is explicable. The array value is explicable
if the finalization is of 'expr' and that 'var' is not finalized or the
finalization of 'var' is occuring after assignment; ie. wrong order.
***I notice from the code that even with the patch, gfortran is finalizing
before evaluation of 'expr', which is incorrect. It should be after
evaluation of 'expr' and before the assignment.***

  141,  6,  3
>
Final count offset - OK

  151,  10,  5
>
The two extra calls come, I presume from the source in the allocation.
Since the type is extended, we see two finalizations each for the
allocation and the deallocation.

  161,  16,  9
>
 I think that the extra two finalizations come from the evaluation of 'src'
in 'constructor2'.

  171,  18,  11
>
Final count offset - OK

  175,  0.,  20. | 10.,  20.
>
The value of 'rarray' is mystifying.

Conclusions from Cray:
(i) Determine if derived type constructors should be interpreted as
function calls.
(ii) The order of finalization in class array assignment needs to be
checked and fixed if necessary.

>
> nagfor 7.0:
>
>   1 0 1
>
"1 When an intrinsic assignment statement is executed (10.2.1.3), if the
variable is not an unallocated allocatable variable, it is finalized after
evaluation of expr and before the definition of the variable."   So I think
that NAG has this wrong, either because the timing is right and an
unallocatable allocatable is being finalized or because the timing is wrong.

  11 1 2
>   23 21 22 | 42 43
>
It seems that the finalization is occurring after assignment.

  71 9 10
>   72 11 99
>
It seems that the finalization of the function 'expr' after assignment is
not happening.

  131 3 2
>   132 5 4
>
I am not sure that I know where the extra final call is nor where the
scalar value of 5 comes from.

  141 4 3
>   151 6 5
>   161 10 9
>   171 12 11
>
 The above are OK since there is an offset in the final count, starting at
131.

Conclusions from NAG:
(i) Some minor nits but pretty close to my interpretation.


Intel 2021.5.0:
>
>           131           3           2
>           132           0           4
>           133           5           6 |           0           0
>           141           4           3
>           151           7           5
>           152           3           0
>           153           0           0 |           1           3
> forrtl: severe (174): SIGSEGV, segmentation fault occurred
> [...]
>

ifort (IFORT) 2021.1 Beta 20201112 manages to carry on to the end.
         161          13           9
         162          20           0
         163           0           0 |          10          20
         171          14          11

Conclusions on ifort:
(i) The agreement between gfortran, with the patch applied, and ifort is
strongest of all the other brands;
(ii) The disagreements are all down to the treatment of the parent
component of arrays of extended types: gfortran finalizes the parent
component as an array, whereas ifort does a scalarization. I have a patch
ready to do likewise.

Overall conclusions:
(i) Sort out whether or not derived type constructors are considered to be
functions;
(ii) Come to a conclusion about scalarization of parent components of
extended type arrays;
(iii) Check and, if necessary, correct the ordering of finalization in
intrinsic assignment of class arrays.
(iv) Finalization is difficult to graft on to existing pre-F2003 compilers,
as witnessed by the range of implementations.

I would be really grateful for thoughts on (i) and (ii). My gut feeling, as
remarked in the submission, is that we should aim to be as close as
possible, if not identical to, ifort. Happily, that is already the case.

Best regards

Paul

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

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 3075 bytes --]

Hi Paul,

Am 10.02.22 um 13:25 schrieb Paul Richard Thomas via Fortran:
> Conclusions on ifort:
> (i) The agreement between gfortran, with the patch applied, and ifort is
> strongest of all the other brands;
> (ii) The disagreements are all down to the treatment of the parent
> component of arrays of extended types: gfortran finalizes the parent
> component as an array, whereas ifort does a scalarization. I have a patch
> ready to do likewise.
>
> Overall conclusions:
> (i) Sort out whether or not derived type constructors are considered to be
> functions;
> (ii) Come to a conclusion about scalarization of parent components of
> extended type arrays;
> (iii) Check and, if necessary, correct the ordering of finalization in
> intrinsic assignment of class arrays.
> (iv) Finalization is difficult to graft on to existing pre-F2003 compilers,
> as witnessed by the range of implementations.
>
> I would be really grateful for thoughts on (i) and (ii). My gut feeling, as
> remarked in the submission, is that we should aim to be as close as
> possible, if not identical to, ifort. Happily, that is already the case.

I am really sorry to be such a bother, but before we think we should
do the same as Intel, we need to understand what Intel does and whether
that is actually correct.  Or not inconsistent with the standard.
And I would really like to understand even the most simple, stupid case.

I did reduce testcase finalize_38.f90 to an almost bare minimum,
see attached, and changed the main to

   type(simple), parameter   :: ThyType   = simple(21)
   type(simple)              :: ThyType2  = simple(22)
   type(simple), allocatable :: MyType, MyType2

   print *, "At start of program: ", final_count

   MyType = ThyType
   print *, "After 1st allocation:", final_count

   MyType2 = ThyType2
   print *, "After 2nd allocation:", final_count

Note that "ThyType" is now a parameter.

I tested the above and found:

Intel:
  At start of program:            0
  After 1st allocation:           1
  After 2nd allocation:           2

NAG 7.0:
  At start of program:  0
  After 1st allocation: 0
  After 2nd allocation: 0

Crayftn 12.0.2:
  At start of program:  2
  After 1st allocation: 2
  After 2nd allocation: 2

Nvidia 22.1:
  At start of program:             0
  After 1st allocation:            0
  After 2nd allocation:            0

So my stupid questions are:

- is ThyType invoking a constructor?  It is a parameter, after all.
   Should using it in an assignment invoke a destructor?  If so why?

   And why does Intel then increment the final_count?

- is the initialization of ThyType2 invoking a constructor?
   It might, if that is the implementation in the compiler, but
   should there be a finalization?

   Then ThyType2 is used in an intrinsic assignment, basically the
   same as the other one before.  Now what is the difference?

Are all compilers correct, but I do not see it?

Someone please help!

> Best regards
>
> Paul
>

Cheers,
Harald

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

module testmode
  implicit none

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

  integer :: final_count = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    final_count = final_count + 1
  end subroutine destructor1

end module testmode

program test_final
  use testmode
  implicit none
  type(simple), parameter   :: ThyType   = simple(21)
  type(simple)              :: ThyType2  = simple(22)
  type(simple), allocatable :: MyType, MyType2

  print *, "At start of program: ", final_count

  MyType = ThyType
  print *, "After 1st allocation:", final_count

  MyType2 = ThyType2
  print *, "After 2nd allocation:", final_count

end program test_final

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

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 2985 bytes --]

Hi Paul,

Am 10.02.22 um 13:25 schrieb Paul Richard Thomas via Fortran:
> Conclusions on ifort:
> (i) The agreement between gfortran, with the patch applied, and ifort is
> strongest of all the other brands;
> (ii) The disagreements are all down to the treatment of the parent
> component of arrays of extended types: gfortran finalizes the parent
> component as an array, whereas ifort does a scalarization. I have a patch
> ready to do likewise.
> 
> Overall conclusions:
> (i) Sort out whether or not derived type constructors are considered to be
> functions;
> (ii) Come to a conclusion about scalarization of parent components of
> extended type arrays;
> (iii) Check and, if necessary, correct the ordering of finalization in
> intrinsic assignment of class arrays.
> (iv) Finalization is difficult to graft on to existing pre-F2003 compilers,
> as witnessed by the range of implementations.
> 
> I would be really grateful for thoughts on (i) and (ii). My gut feeling, as
> remarked in the submission, is that we should aim to be as close as
> possible, if not identical to, ifort. Happily, that is already the case.

I am really sorry to be such a bother, but before we think we should
do the same as Intel, we need to understand what Intel does and whether
that is actually correct.  Or not inconsistent with the standard.
And I would really like to understand even the most simple, stupid case.

I did reduce testcase finalize_38.f90 to an almost bare minimum,
see attached, and changed the main to

   type(simple), parameter   :: ThyType   = simple(21)
   type(simple)              :: ThyType2  = simple(22)
   type(simple), allocatable :: MyType, MyType2

   print *, "At start of program: ", final_count

   MyType = ThyType
   print *, "After 1st allocation:", final_count

   MyType2 = ThyType2
   print *, "After 2nd allocation:", final_count

Note that "ThyType" is now a parameter.

I tested the above and found:

Intel:
  At start of program:            0
  After 1st allocation:           1
  After 2nd allocation:           2

NAG 7.0:
  At start of program:  0
  After 1st allocation: 0
  After 2nd allocation: 0

Crayftn 12.0.2:
  At start of program:  2
  After 1st allocation: 2
  After 2nd allocation: 2

Nvidia 22.1:
  At start of program:             0
  After 1st allocation:            0
  After 2nd allocation:            0

So my stupid questions are:

- is ThyType invoking a constructor?  It is a parameter, after all.
   Should using it in an assignment invoke a destructor?  If so why?

   And why does Intel then increment the final_count?

- is the initialization of ThyType2 invoking a constructor?
   It might, if that is the implementation in the compiler, but
   should there be a finalization?

   Then ThyType2 is used in an intrinsic assignment, basically the
   same as the other one before.  Now what is the difference?

Are all compilers correct, but I do not see it?

Someone please help!

> Best regards
> 
> Paul
> 

Cheers,
Harald

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

module testmode
  implicit none

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

  integer :: final_count = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    final_count = final_count + 1
  end subroutine destructor1

end module testmode

program test_final
  use testmode
  implicit none
  type(simple), parameter   :: ThyType   = simple(21)
  type(simple)              :: ThyType2  = simple(22)
  type(simple), allocatable :: MyType, MyType2

  print *, "At start of program: ", final_count

  MyType = ThyType
  print *, "After 1st allocation:", final_count

  MyType2 = ThyType2
  print *, "After 2nd allocation:", final_count

end program test_final

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

[Jerry D]

For what it is worth.

On 2/10/22 11:49 AM, Harald Anlauf via Fortran wrote:
> Hi Paul,
>
> Am 10.02.22 um 13:25 schrieb Paul Richard Thomas via Fortran:
>> Conclusions on ifort:
>> (i) The agreement between gfortran, with the patch applied, and ifort is
>> strongest of all the other brands;
>> (ii) The disagreements are all down to the treatment of the parent
>> component of arrays of extended types: gfortran finalizes the parent
>> component as an array, whereas ifort does a scalarization. I have a 
>> patch
>> ready to do likewise.
>>
>> Overall conclusions:
>> (i) Sort out whether or not derived type constructors are considered 
>> to be
>> functions;
>> (ii) Come to a conclusion about scalarization of parent components of
>> extended type arrays;
>> (iii) Check and, if necessary, correct the ordering of finalization in
>> intrinsic assignment of class arrays.
>> (iv) Finalization is difficult to graft on to existing pre-F2003 
>> compilers,
>> as witnessed by the range of implementations.
>>
>> I would be really grateful for thoughts on (i) and (ii). My gut 
>> feeling, as
>> remarked in the submission, is that we should aim to be as close as
>> possible, if not identical to, ifort. Happily, that is already the case.
>
> I am really sorry to be such a bother, but before we think we should
> do the same as Intel, we need to understand what Intel does and whether
> that is actually correct.  Or not inconsistent with the standard.
> And I would really like to understand even the most simple, stupid case.
>
> I did reduce testcase finalize_38.f90 to an almost bare minimum,
> see attached, and changed the main to
>
>   type(simple), parameter   :: ThyType   = simple(21)
>   type(simple)              :: ThyType2  = simple(22)
>   type(simple), allocatable :: MyType, MyType2
>
>   print *, "At start of program: ", final_count
>
>   MyType = ThyType
>   print *, "After 1st allocation:", final_count
>
>   MyType2 = ThyType2
>   print *, "After 2nd allocation:", final_count
>
> Note that "ThyType" is now a parameter.
>
----- snip ----
Ignore whether Thytype is  a Parameter.  Regardless Mytype and Mytype2 
are allocated upon the assignment.  Now if these are never used 
anywhere, it seems to me the deallocation can be done by the compiler 
anywhere after the last time it is used.  So it can be either after the 
PRINT statement before the end if the program or right after the 
assignment before your PRINT statements that examine the value of 
final_count.  I think the result is arbitrary/undefined in your reduced 
test case

I do not have the Intel compiler yet, so I was going to suggest see what 
it does if your test program prints something from within MyType and 
MyType2 after all your current print statements at the end.  Try this 
variation of the main program.

program test_final
   use testmode
   implicit none
   type(simple), parameter   :: ThyType   = simple(21)
   type(simple)              :: ThyType2  = simple(22)
   type(simple), allocatable :: MyType, MyType2

   print *, "At start of program: ", final_count

   MyType = ThyType
   print *, "After 1st allocation:", final_count

   MyType2 = ThyType2
   print *, "After 2nd allocation:", final_count

   print  *, MyType%ind, MyType2%ind, final_count
   deallocate(Mytype)
   print  *, MyType%ind, MyType2%ind, final_count
   deallocate(Mytype2)
   print  *, MyType%ind, MyType2%ind, final_count

end program test_final

I get with trunk:

$ ./a.out
  At start of program:            0
  After 1st allocation:            0
  After 2nd allocation:           0
           21         22           0
            0          22           1
            0          0             2

Which makes sense to me.

Regards,

Jerry

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

[Paul Richard Thomas]

Hi Harald,

I have taken gcc-patches out of the loop for now :-)

I am really sorry to be such a bother, but before we think we should
> do the same as Intel, we need to understand what Intel does and whether
> that is actually correct.  Or not inconsistent with the standard.
> And I would really like to understand even the most simple, stupid case.
>

You are not being a bother. I am happy that you are taking an interest.

....snip....
>


> So my stupid questions are:
>
> - is ThyType invoking a constructor?  It is a parameter, after all.
>    Should using it in an assignment invoke a destructor?  If so why?
>
>    And why does Intel then increment the final_count?
>
> - is the initialization of ThyType2 invoking a constructor?
>    It might, if that is the implementation in the compiler, but
>    should there be a finalization?
>
>
7.5.6.3 When finalization occurs
1 When an intrinsic assignment statement is executed (10.2.1.3), if the
variable is not an unallocated allocatable
variable, it is finalized after evaluation of expr and before the
definition of the variable. If the variable is an
allocated allocatable variable, or has an allocated allocatable subobject,
that would be deallocated by intrinsic
assignment, the finalization occurs before the deallocation.

Your "stupid questions" are not at all stupid. The finalization of
'variable' that occurs in your testcase demonstrates that the finalization
with my patch is occurring at the wrong time. I now see that NAG is correct
on this.

Please press on with the questions!

Regards

Paul

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

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 5089 bytes --]

Hi Paul,

Am 11.02.22 um 10:08 schrieb Paul Richard Thomas via Fortran:
> Your "stupid questions" are not at all stupid. The finalization of
> 'variable' that occurs in your testcase demonstrates that the finalization
> with my patch is occurring at the wrong time. I now see that NAG is correct
> on this.
>
> Please press on with the questions!

Jerry's suggestion to add lots of prints turned out to be really
enlightening with regard to observable behavior.  I rewrote the
testcase again and placed the interesting stuff into a subroutine.
This way one can distinguish what actually happens during program
start, entering and leaving a subroutine.

I encountered the least surprises (= none) with NAG 7.0 here.
For reference this is the output:

  At start of program : 0

  Enter sub           : 0
  After 1st allocation: 0
  After 2nd allocation: 0
  Checking MyType% ind: 21
  Checking MyType2%ind: 22
  Deallocate MyType   : 0
  # Leave desctructor1: 1 21
  * MyType deallocated: 1
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           : 1
  # Leave desctructor1: 2 22

  After sub           : 2

To make it short: the destructor is called only when deallocation
occurs, either explicitly or automatically.


Intel 2021.5.0:

  At start of program :           0

  Enter sub           :           0
  # Leave desctructor1:           1           0
  After 1st allocation:           1
  # Leave desctructor1:           2           0
  After 2nd allocation:           2
  Checking MyType% ind:          21
  Checking MyType2%ind:          22
  Deallocate MyType   :           2
  # Leave desctructor1:           3          21
  * MyType deallocated:           3
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           :           3
  # Leave desctructor1:           4          21
  # Leave desctructor1:           5          22
  # Leave desctructor1:           6          22

  After sub           :           6

So after entering the subroutine, the destructor is called twice,
but for unknown reasons element ind, which I had expected to be
either default-initialized to -1, or explicitly to 21 or 22, is 0.
The places where this happens seem to be the assignments of
MyType and MyType2.

Furthermore, variable MyType is finalized on return from sub,
although it is already deallocated, and MyType2 appears to
get finalized twice automatically.

I have no idea how this can get justified...


Crayftn 12.0.2: in order to make the output easier to understand,
I chose to reset final_count twice.  This will become clear soon.

  # Leave desctructor1: 1,  20

  At start of program : 1
  +++ Resetting final_count for Cray Fortran : Version 12.0.2

  # Leave desctructor1: 1,  21
  # Leave desctructor1: 2,  22
  Enter sub           : 2
  +++ Resetting final_count for Cray Fortran : Version 12.0.2
  After 1st allocation: 0
  After 2nd allocation: 0
  Checking MyType% ind: -21
  Checking MyType2%ind: 22
  Deallocate MyType   : 0
  # Leave desctructor1: 1,  -21
  * MyType deallocated: 1
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           : 1
  # Leave desctructor1: 2,  22

  After sub           : 2

So it appears that Cray is calling the destructor for each declaration
where a constructor is involved, or the like.  Even if this is a
parameter declaration, like in the main.  Resetting the counter for
the first time.

On entering sub, I see now two finalizations before the first print.
Resetting the counter for the second time.

But then the assignments do not invoke finalization, where Intel did.
So this part appears more like NAG, but...

... something is strange here: component ind is wrong after the
first assignment.  Looks clearly like a really bad bug.

Explicit and automatic deallocation seems fine.


Nvidia 22.2:

  At start of program :            0

  Enter sub           :            0
  After 1st allocation:            0
  After 2nd allocation:            0
  Checking MyType% ind:           21
  Checking MyType2%ind:           22
  Deallocate MyType   :            0
  # Leave desctructor1:            1           21
  * MyType deallocated:            1
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           :            1
  # Leave desctructor1:            2   1590094384
  # Leave desctructor1:            3           22

  After sub           :            3

OK, that is really odd.  Although valgrind does not report
invalid accesses, there is something really fishy here.
I have not investigated further.  Nvidia is out for now.


One of the lessons learned is that it might be hard to write a
portable testcase that works for all compilers that rightfully(?)
can claim to implement finalization correctly...  And I have only
scratched the surface so far.

Paul: do you think you can enhance your much more comprehensive
testcase to ease debugging further?

Cheers,
Harald

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

module testmode
  implicit none

  type :: simple
     integer :: ind = -1
  contains
    final :: destructor1
  end type simple

  integer :: final_count = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    final_count = final_count + 1
    print *, "# Leave desctructor1:", final_count, self% ind
    self% ind = - self% ind
  end subroutine destructor1

end module testmode

program test_final
  use, intrinsic :: iso_fortran_env
  use testmode
  implicit none
  type(simple), parameter :: ThyType_param = simple(20)
  character(80) :: compiler
  compiler = compiler_version ()
  print *
  print *, "At start of program :", final_count
  call reset ()
  print *
  call sub ()
  print *
  print *, "After sub           :", final_count
contains
  subroutine sub ()
    type(simple), parameter   :: ThyType   = simple(21)
    type(simple)              :: ThyType2  = simple(22)
    type(simple), allocatable :: MyType, MyType2

    print *, "Enter sub           :", final_count
    call reset ()

    MyType = ThyType
    print *, "After 1st allocation:", final_count

    MyType2 = ThyType2
    print *, "After 2nd allocation:", final_count

    print *, "Checking MyType% ind:", MyType% ind
    print *, "Checking MyType2%ind:", MyType2% ind
    if (.not. allocated (MyType )) print *, "MyType?"
    if (.not. allocated (MyType2)) print *, "MyType2?"

    print *, "Deallocate MyType   :", final_count
    deallocate (MyType)
    print *, "* MyType deallocated:", final_count

    if (allocated (MyType2)) &
    print *, "(kept MyType2 for automatic deallocation on return from sub)"
    print *, "Leave sub           :", final_count

  end subroutine sub
  !
  subroutine reset ()
    if (final_count == 0) return
    if (compiler(1:4) == "Cray") then
       print *, "+++ Resetting final_count for ", trim (compiler)
       final_count = 0 ! reset for crayftn 12.0.2
    end if
  end subroutine reset
end program test_final

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

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 4939 bytes --]

Hi Paul,

Am 11.02.22 um 10:08 schrieb Paul Richard Thomas via Fortran:
> Your "stupid questions" are not at all stupid. The finalization of
> 'variable' that occurs in your testcase demonstrates that the finalization
> with my patch is occurring at the wrong time. I now see that NAG is correct
> on this.
> 
> Please press on with the questions!

Jerry's suggestion to add lots of prints turned out to be really
enlightening with regard to observable behavior.  I rewrote the
testcase again and placed the interesting stuff into a subroutine.
This way one can distinguish what actually happens during program
start, entering and leaving a subroutine.

I encountered the least surprises (= none) with NAG 7.0 here.
For reference this is the output:

  At start of program : 0

  Enter sub           : 0
  After 1st allocation: 0
  After 2nd allocation: 0
  Checking MyType% ind: 21
  Checking MyType2%ind: 22
  Deallocate MyType   : 0
  # Leave desctructor1: 1 21
  * MyType deallocated: 1
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           : 1
  # Leave desctructor1: 2 22

  After sub           : 2

To make it short: the destructor is called only when deallocation
occurs, either explicitly or automatically.


Intel 2021.5.0:

  At start of program :           0

  Enter sub           :           0
  # Leave desctructor1:           1           0
  After 1st allocation:           1
  # Leave desctructor1:           2           0
  After 2nd allocation:           2
  Checking MyType% ind:          21
  Checking MyType2%ind:          22
  Deallocate MyType   :           2
  # Leave desctructor1:           3          21
  * MyType deallocated:           3
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           :           3
  # Leave desctructor1:           4          21
  # Leave desctructor1:           5          22
  # Leave desctructor1:           6          22

  After sub           :           6

So after entering the subroutine, the destructor is called twice,
but for unknown reasons element ind, which I had expected to be
either default-initialized to -1, or explicitly to 21 or 22, is 0.
The places where this happens seem to be the assignments of
MyType and MyType2.

Furthermore, variable MyType is finalized on return from sub,
although it is already deallocated, and MyType2 appears to
get finalized twice automatically.

I have no idea how this can get justified...


Crayftn 12.0.2: in order to make the output easier to understand,
I chose to reset final_count twice.  This will become clear soon.

  # Leave desctructor1: 1,  20

  At start of program : 1
  +++ Resetting final_count for Cray Fortran : Version 12.0.2

  # Leave desctructor1: 1,  21
  # Leave desctructor1: 2,  22
  Enter sub           : 2
  +++ Resetting final_count for Cray Fortran : Version 12.0.2
  After 1st allocation: 0
  After 2nd allocation: 0
  Checking MyType% ind: -21
  Checking MyType2%ind: 22
  Deallocate MyType   : 0
  # Leave desctructor1: 1,  -21
  * MyType deallocated: 1
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           : 1
  # Leave desctructor1: 2,  22

  After sub           : 2

So it appears that Cray is calling the destructor for each declaration
where a constructor is involved, or the like.  Even if this is a
parameter declaration, like in the main.  Resetting the counter for
the first time.

On entering sub, I see now two finalizations before the first print.
Resetting the counter for the second time.

But then the assignments do not invoke finalization, where Intel did.
So this part appears more like NAG, but...

... something is strange here: component ind is wrong after the
first assignment.  Looks clearly like a really bad bug.

Explicit and automatic deallocation seems fine.


Nvidia 22.2:

  At start of program :            0

  Enter sub           :            0
  After 1st allocation:            0
  After 2nd allocation:            0
  Checking MyType% ind:           21
  Checking MyType2%ind:           22
  Deallocate MyType   :            0
  # Leave desctructor1:            1           21
  * MyType deallocated:            1
  (kept MyType2 for automatic deallocation on return from sub)
  Leave sub           :            1
  # Leave desctructor1:            2   1590094384
  # Leave desctructor1:            3           22

  After sub           :            3

OK, that is really odd.  Although valgrind does not report
invalid accesses, there is something really fishy here.
I have not investigated further.  Nvidia is out for now.


One of the lessons learned is that it might be hard to write a
portable testcase that works for all compilers that rightfully(?)
can claim to implement finalization correctly...  And I have only
scratched the surface so far.

Paul: do you think you can enhance your much more comprehensive
testcase to ease debugging further?

Cheers,
Harald

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

module testmode
  implicit none

  type :: simple
     integer :: ind = -1
  contains
    final :: destructor1
  end type simple

  integer :: final_count = 0

contains

  subroutine destructor1(self)
    type(simple), intent(inout) :: self
    final_count = final_count + 1
    print *, "# Leave desctructor1:", final_count, self% ind
    self% ind = - self% ind
  end subroutine destructor1

end module testmode

program test_final
  use, intrinsic :: iso_fortran_env
  use testmode
  implicit none
  type(simple), parameter :: ThyType_param = simple(20)
  character(80) :: compiler
  compiler = compiler_version ()
  print *
  print *, "At start of program :", final_count
  call reset ()
  print *
  call sub ()
  print *
  print *, "After sub           :", final_count
contains
  subroutine sub ()
    type(simple), parameter   :: ThyType   = simple(21)
    type(simple)              :: ThyType2  = simple(22)
    type(simple), allocatable :: MyType, MyType2

    print *, "Enter sub           :", final_count
    call reset ()

    MyType = ThyType
    print *, "After 1st allocation:", final_count

    MyType2 = ThyType2
    print *, "After 2nd allocation:", final_count

    print *, "Checking MyType% ind:", MyType% ind
    print *, "Checking MyType2%ind:", MyType2% ind
    if (.not. allocated (MyType )) print *, "MyType?"
    if (.not. allocated (MyType2)) print *, "MyType2?"

    print *, "Deallocate MyType   :", final_count
    deallocate (MyType)
    print *, "* MyType deallocated:", final_count

    if (allocated (MyType2)) &
    print *, "(kept MyType2 for automatic deallocation on return from sub)"
    print *, "Leave sub           :", final_count

  end subroutine sub
  !
  subroutine reset ()
    if (final_count == 0) return
    if (compiler(1:4) == "Cray") then
       print *, "+++ Resetting final_count for ", trim (compiler)
       final_count = 0 ! reset for crayftn 12.0.2
    end if
  end subroutine reset
end program test_final

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

[Paul Richard Thomas]

Hi Harald and Jerry,

I am reworking my way through, line by line wit F2018 in hand. Up to test
with offset 70, NAG looks to be right. I introduced an assignment with a
direct by ref function call, which doesn't finalise at the moment. Class
entities are yet to come. I'll report back early next week.

Thanks for all the help. I have (re)learned to read the standard very
carefully.

Best regards

Paul


On Fri, 11 Feb 2022, 21:08 Harald Anlauf, <anlauf@gmx.de> wrote:

> Hi Paul,
>
> Am 11.02.22 um 10:08 schrieb Paul Richard Thomas via Fortran:
> > Your "stupid questions" are not at all stupid. The finalization of
> > 'variable' that occurs in your testcase demonstrates that the
> finalization
> > with my patch is occurring at the wrong time. I now see that NAG is
> correct
> > on this.
> >
> > Please press on with the questions!
>
> Jerry's suggestion to add lots of prints turned out to be really
> enlightening with regard to observable behavior.  I rewrote the
> testcase again and placed the interesting stuff into a subroutine.
> This way one can distinguish what actually happens during program
> start, entering and leaving a subroutine.
>
> I encountered the least surprises (= none) with NAG 7.0 here.
> For reference this is the output:
>
>   At start of program : 0
>
>   Enter sub           : 0
>   After 1st allocation: 0
>   After 2nd allocation: 0
>   Checking MyType% ind: 21
>   Checking MyType2%ind: 22
>   Deallocate MyType   : 0
>   # Leave desctructor1: 1 21
>   * MyType deallocated: 1
>   (kept MyType2 for automatic deallocation on return from sub)
>   Leave sub           : 1
>   # Leave desctructor1: 2 22
>
>   After sub           : 2
>
> To make it short: the destructor is called only when deallocation
> occurs, either explicitly or automatically.
>
>
> Intel 2021.5.0:
>
>   At start of program :           0
>
>   Enter sub           :           0
>   # Leave desctructor1:           1           0
>   After 1st allocation:           1
>   # Leave desctructor1:           2           0
>   After 2nd allocation:           2
>   Checking MyType% ind:          21
>   Checking MyType2%ind:          22
>   Deallocate MyType   :           2
>   # Leave desctructor1:           3          21
>   * MyType deallocated:           3
>   (kept MyType2 for automatic deallocation on return from sub)
>   Leave sub           :           3
>   # Leave desctructor1:           4          21
>   # Leave desctructor1:           5          22
>   # Leave desctructor1:           6          22
>
>   After sub           :           6
>
> So after entering the subroutine, the destructor is called twice,
> but for unknown reasons element ind, which I had expected to be
> either default-initialized to -1, or explicitly to 21 or 22, is 0.
> The places where this happens seem to be the assignments of
> MyType and MyType2.
>
> Furthermore, variable MyType is finalized on return from sub,
> although it is already deallocated, and MyType2 appears to
> get finalized twice automatically.
>
> I have no idea how this can get justified...
>
>
> Crayftn 12.0.2: in order to make the output easier to understand,
> I chose to reset final_count twice.  This will become clear soon.
>
>   # Leave desctructor1: 1,  20
>
>   At start of program : 1
>   +++ Resetting final_count for Cray Fortran : Version 12.0.2
>
>   # Leave desctructor1: 1,  21
>   # Leave desctructor1: 2,  22
>   Enter sub           : 2
>   +++ Resetting final_count for Cray Fortran : Version 12.0.2
>   After 1st allocation: 0
>   After 2nd allocation: 0
>   Checking MyType% ind: -21
>   Checking MyType2%ind: 22
>   Deallocate MyType   : 0
>   # Leave desctructor1: 1,  -21
>   * MyType deallocated: 1
>   (kept MyType2 for automatic deallocation on return from sub)
>   Leave sub           : 1
>   # Leave desctructor1: 2,  22
>
>   After sub           : 2
>
> So it appears that Cray is calling the destructor for each declaration
> where a constructor is involved, or the like.  Even if this is a
> parameter declaration, like in the main.  Resetting the counter for
> the first time.
>
> On entering sub, I see now two finalizations before the first print.
> Resetting the counter for the second time.
>
> But then the assignments do not invoke finalization, where Intel did.
> So this part appears more like NAG, but...
>
> ... something is strange here: component ind is wrong after the
> first assignment.  Looks clearly like a really bad bug.
>
> Explicit and automatic deallocation seems fine.
>
>
> Nvidia 22.2:
>
>   At start of program :            0
>
>   Enter sub           :            0
>   After 1st allocation:            0
>   After 2nd allocation:            0
>   Checking MyType% ind:           21
>   Checking MyType2%ind:           22
>   Deallocate MyType   :            0
>   # Leave desctructor1:            1           21
>   * MyType deallocated:            1
>   (kept MyType2 for automatic deallocation on return from sub)
>   Leave sub           :            1
>   # Leave desctructor1:            2   1590094384
>   # Leave desctructor1:            3           22
>
>   After sub           :            3
>
> OK, that is really odd.  Although valgrind does not report
> invalid accesses, there is something really fishy here.
> I have not investigated further.  Nvidia is out for now.
>
>
> One of the lessons learned is that it might be hard to write a
> portable testcase that works for all compilers that rightfully(?)
> can claim to implement finalization correctly...  And I have only
> scratched the surface so far.
>
> Paul: do you think you can enhance your much more comprehensive
> testcase to ease debugging further?
>
> Cheers,
> Harald
>

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 6489 bytes --]

Hi Harald and Jerry,

I have gone back to the start and have gone through finalizable derived
type assignments with the F2018 in hand. I have had a dreadful time with
direct by reference function calls and still am struggling with assignment
number 6 in the attached. I would be very grateful if you would run this
testcase for the other brands.

As soon as I fix the 6th assignment, I will get on to class assignments.

Best regards

Paul


On Fri, 11 Feb 2022 at 21:59, Paul Richard Thomas <
paul.richard.thomas@gmail.com> wrote:

> Hi Harald and Jerry,
>
> I am reworking my way through, line by line wit F2018 in hand. Up to test
> with offset 70, NAG looks to be right. I introduced an assignment with a
> direct by ref function call, which doesn't finalise at the moment. Class
> entities are yet to come. I'll report back early next week.
>
> Thanks for all the help. I have (re)learned to read the standard very
> carefully.
>
> Best regards
>
> Paul
>
>
> On Fri, 11 Feb 2022, 21:08 Harald Anlauf, <anlauf@gmx.de> wrote:
>
>> Hi Paul,
>>
>> Am 11.02.22 um 10:08 schrieb Paul Richard Thomas via Fortran:
>> > Your "stupid questions" are not at all stupid. The finalization of
>> > 'variable' that occurs in your testcase demonstrates that the
>> finalization
>> > with my patch is occurring at the wrong time. I now see that NAG is
>> correct
>> > on this.
>> >
>> > Please press on with the questions!
>>
>> Jerry's suggestion to add lots of prints turned out to be really
>> enlightening with regard to observable behavior.  I rewrote the
>> testcase again and placed the interesting stuff into a subroutine.
>> This way one can distinguish what actually happens during program
>> start, entering and leaving a subroutine.
>>
>> I encountered the least surprises (= none) with NAG 7.0 here.
>> For reference this is the output:
>>
>>   At start of program : 0
>>
>>   Enter sub           : 0
>>   After 1st allocation: 0
>>   After 2nd allocation: 0
>>   Checking MyType% ind: 21
>>   Checking MyType2%ind: 22
>>   Deallocate MyType   : 0
>>   # Leave desctructor1: 1 21
>>   * MyType deallocated: 1
>>   (kept MyType2 for automatic deallocation on return from sub)
>>   Leave sub           : 1
>>   # Leave desctructor1: 2 22
>>
>>   After sub           : 2
>>
>> To make it short: the destructor is called only when deallocation
>> occurs, either explicitly or automatically.
>>
>>
>> Intel 2021.5.0:
>>
>>   At start of program :           0
>>
>>   Enter sub           :           0
>>   # Leave desctructor1:           1           0
>>   After 1st allocation:           1
>>   # Leave desctructor1:           2           0
>>   After 2nd allocation:           2
>>   Checking MyType% ind:          21
>>   Checking MyType2%ind:          22
>>   Deallocate MyType   :           2
>>   # Leave desctructor1:           3          21
>>   * MyType deallocated:           3
>>   (kept MyType2 for automatic deallocation on return from sub)
>>   Leave sub           :           3
>>   # Leave desctructor1:           4          21
>>   # Leave desctructor1:           5          22
>>   # Leave desctructor1:           6          22
>>
>>   After sub           :           6
>>
>> So after entering the subroutine, the destructor is called twice,
>> but for unknown reasons element ind, which I had expected to be
>> either default-initialized to -1, or explicitly to 21 or 22, is 0.
>> The places where this happens seem to be the assignments of
>> MyType and MyType2.
>>
>> Furthermore, variable MyType is finalized on return from sub,
>> although it is already deallocated, and MyType2 appears to
>> get finalized twice automatically.
>>
>> I have no idea how this can get justified...
>>
>>
>> Crayftn 12.0.2: in order to make the output easier to understand,
>> I chose to reset final_count twice.  This will become clear soon.
>>
>>   # Leave desctructor1: 1,  20
>>
>>   At start of program : 1
>>   +++ Resetting final_count for Cray Fortran : Version 12.0.2
>>
>>   # Leave desctructor1: 1,  21
>>   # Leave desctructor1: 2,  22
>>   Enter sub           : 2
>>   +++ Resetting final_count for Cray Fortran : Version 12.0.2
>>   After 1st allocation: 0
>>   After 2nd allocation: 0
>>   Checking MyType% ind: -21
>>   Checking MyType2%ind: 22
>>   Deallocate MyType   : 0
>>   # Leave desctructor1: 1,  -21
>>   * MyType deallocated: 1
>>   (kept MyType2 for automatic deallocation on return from sub)
>>   Leave sub           : 1
>>   # Leave desctructor1: 2,  22
>>
>>   After sub           : 2
>>
>> So it appears that Cray is calling the destructor for each declaration
>> where a constructor is involved, or the like.  Even if this is a
>> parameter declaration, like in the main.  Resetting the counter for
>> the first time.
>>
>> On entering sub, I see now two finalizations before the first print.
>> Resetting the counter for the second time.
>>
>> But then the assignments do not invoke finalization, where Intel did.
>> So this part appears more like NAG, but...
>>
>> ... something is strange here: component ind is wrong after the
>> first assignment.  Looks clearly like a really bad bug.
>>
>> Explicit and automatic deallocation seems fine.
>>
>>
>> Nvidia 22.2:
>>
>>   At start of program :            0
>>
>>   Enter sub           :            0
>>   After 1st allocation:            0
>>   After 2nd allocation:            0
>>   Checking MyType% ind:           21
>>   Checking MyType2%ind:           22
>>   Deallocate MyType   :            0
>>   # Leave desctructor1:            1           21
>>   * MyType deallocated:            1
>>   (kept MyType2 for automatic deallocation on return from sub)
>>   Leave sub           :            1
>>   # Leave desctructor1:            2   1590094384
>>   # Leave desctructor1:            3           22
>>
>>   After sub           :            3
>>
>> OK, that is really odd.  Although valgrind does not report
>> invalid accesses, there is something really fishy here.
>> I have not investigated further.  Nvidia is out for now.
>>
>>
>> One of the lessons learned is that it might be hard to write a
>> portable testcase that works for all compilers that rightfully(?)
>> can claim to implement finalization correctly...  And I have only
>> scratched the surface so far.
>>
>> Paul: do you think you can enhance your much more comprehensive
>> testcase to ease debugging further?
>>
>> Cheers,
>> Harald
>>
>

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

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

module testmode
  implicit none

  type :: simple
    integer :: ind
    character(12) :: myname
  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
    print '(3A, i4)', " finalize simple - ", trim (self%myname), "%ind = ", self%ind
  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
    print '(3A, 3i4)', " finalize simple(:) - ", trim (self(1)%myname),"%ind= ", self%ind
  end subroutine destructor2

  subroutine destructor3(self)
    type(complicated), intent(inout) :: self
    check_real = self%rind
    check_array = 0.0
    final_count = final_count + 1
    print '(3A, i4, f6.2)', " finalize complicated - ", trim (self%myname)," = ",&
                            self%ind, self%rind
  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
    if (size(self, 1) == 2) then
      print '(3A, 2i4, 2f6.2)', " finalize complicated(2) - ", trim (self(1)%myname),&
                                " = ", self%ind, self%rind
    else if (size(self, 1) == 3) then
      print '(3A, 3i4, 3f6.2)', " finalize complicated(3) - ", trim (self(1)%myname),&
                                " = ", self%ind, self%rind
    else
      print *, " finalize complicated(:) - ", trim (self(1)%myname)," = ", self%ind, self%rind
    endif
  end subroutine destructor4

  function constructor1(ind ,myname) result(res)
    type(simple), allocatable :: res
    integer, intent(in) :: ind
    character(*) :: myname
    allocate (res, source = simple (ind, myname))
  end function constructor1

  function constructor2(ind, myname, rind) result(res)
    class(simple), allocatable :: res(:)
    integer, intent(in) :: ind(:)
    real, intent(in), optional :: rind(:)
    type(complicated), allocatable :: src(:)
    character(*) :: myname
    integer :: sz
    integer :: i
    if (present (rind)) then
      sz = min (size (ind, 1), size (rind, 1))
      src  = [(complicated (ind(i), myname, rind(i)), i = 1, sz)]
      allocate (res, source = src)
    else
      sz = size (ind, 1)
      allocate (res, source = [(simple (ind(i), myname), 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)  print *, 1 + off, final_count, cnt
    if (check_scalar .ne. scalar) print *, 2 + off, check_scalar, scalar
    if (any (check_array(1:size (array, 1)) .ne. array)) print *,  3 + off, &
                                       check_array(1:size (array, 1)), "|", array
    if (present (rind)) then
      if (check_real .ne. rind)  print *,  4+off, check_real, rind
    end if
    if (present (rarray)) then
      if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) print *,  5 + off, &
                                       check_rarray(1:size (rarray, 1)), "|", rarray
    end if
  end subroutine test

end module testmode

program test_final
   use testmode
   implicit none
   type(simple), parameter   :: ThyType   = simple(21, "ThyType")
   type(simple)              :: ThyType2  = simple(22, "ThyType2")
   type(simple), allocatable :: MyType, MyType2
   type(simple), allocatable :: MyTypeArray(:)
   type(complicated), allocatable :: ThyTypeArray(:)

   print '(a,i4)', " At start of program: final_count = ", final_count

!*******************************************************************
! Patch now corrected not to finalize when 'var' is not allocated.
! Mytype not allocated and so no finalization => final_count = 0
!*******************************************************************
   print *, "*******************************************************************"
   print *, ""
   print *, "1st assignment: No finalization because MyType unallocated."
   MyType = ThyType
   print '(a,i4,a)', " After 1st assignment(var not allocated): final_count = ", final_count, "(0)"
   print *, "*******************************************************************"
   print *, ""
!*******************************************************************
! Mytype2 is allocated and so finalization should occur => final_count = 1
!*******************************************************************
   print *, "2nd assignment: MyType(=simple(1,MyType) finalized before assignment"
   final_count = 0
   allocate (Mytype2, source = simple (1, "Mytype2"))
   MyType2 = ThyType2
   print '(a,i4,a)', " After 2nd assignment(var allocated): final_count = ", final_count, "(1)"
   print *, "*******************************************************************"
   print *, ""

!*******************************************************************
! This should result in a final call with self = [simple(42),simple(43)].
! NAG outputs self = [simple(21),simple(22)] and a double increment of
! the final count, which PRT does not understand.
! In PRT's opinion => final_count = 1
!*******************************************************************
   print *, "3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment"
   print *, ""
   final_count = 0
   allocate(MyTypeArray, source = [simple (42, "MyTypeArray"), simple(43, "MyTypeArray")])
   MyTypeArray = [ThyType, ThyType2]
   print '(a,i4,a)', " After 3rd assignment(array var allocated): final_count = ", final_count, "(1)"
   print *, "*******************************************************************"
   print *, ""

!*******************************************************************
! Check that rhs function expressions finalize correctly.
! 'var' is finalized on deallocation and then again on assignment. The
! function result of 'constructor1' is finalized after the assignment.
! (Note NAG only generates two final calls and check_scalar = 11.)
! In PRT's opinion => final_count = 3
!*******************************************************************
   print *, "Deallocation generates final call with self = simple (21, ThyType)"
   print *, "4th assignment: MyTypeArray finalized before assignment"
   print *, "Mtype finalized before assignment with self = simple (11, MyType)"
   print *, "Function result finalized after assignment with self = simple (99, MyType)"
   print *, ""
   final_count = 0
   deallocate (MyType)
   allocate (MyType, source = simple (11, "MyType"))
   MyType = constructor1 (99, "MyType")
   print '(a,i4,a)', " After 4th assignment(array var allocated) :final_count = ", final_count, "(3)"
   print *, "*******************************************************************"
   print *, ""

!*******************************************************************
! Check that rhs array function expressions finalize correctly.
! 'var' is on assignment. The function result of 'constructor3' is
! finalized after the assignment. Both finalizations result in a
! finalization of the extended type and then the parent. In addition,
! the assignment in constructor3 causes a finalization of 'res'.
! Therefore => final_count = 6
! (Note ifort generates ten final calls because of the scalar final
! calls of the parent components, rather than array calls.)
!*******************************************************************
   print *, "5th assignment: MyTypeArray finalized before assignment"
   print *, "1] First finalization is of 'res' in constructor3 with:"
   print *, "Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]"
   print *, "2] ThyTypeArray is finalized before assignment and after evaluation of constructor3"
   print *, "Self = [3 times complicated (-1, ThyTypeArra1,0.0)]"
   print *, "3] Function result finalized after assignment with"
   print *, "Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]"
   print *, ""
   final_count = 0
   allocate (ThyTypeArray(3), source = complicated (-1,"ThyTypeArra1",0.0))
   ThyTypeArray = constructor3 ("ThyTypeArra2")
   print '(a,i4,a)', " After 5th assignment(array var allocated):", final_count, "(6)"
   print *, ""
   print *, "*******************************************************************"
   print *, "Deallocate ThyTypeArray."
   deallocate (ThyTypeArray)
   print *, ""
   print *, "*******************************************************************"

!*******************************************************************
! 6th Assignment has the allocatable version of the function. This should
! give the same result as the previous one.
!*******************************************************************
   print *, "6th assignment: A repeat of the previous with an allocatable function result."
   print *, "This should give the same result as the 5th assignment."
   print *, ""
   final_count = 0
   allocate (ThyTypeArray(3), source = complicated (-1,"ThyTypeArra1",0.0))
   ThyTypeArray = constructor4 ("ThyTypeArra2")
   print '(a,i4,a)', " After 6th assignment(array var allocated):", final_count, "(6)"
   print *, ""
   print *, "*******************************************************************"

!*******************************************************************
! Everybody agrees (PRT thinks) about deallocation, except where arrays
! of extended types are concerned (Intel)
!*******************************************************************
   final_count = 0
   print *, "Deallocations at end"
   print *, ""
   deallocate(Mytype)
   print *, "After 1st deallocation:", final_count
   deallocate(Mytype2)
   print *, "After 2nd deallocation:", final_count
   deallocate(MytypeArray)
   print *, "After 3rd deallocation:", final_count

contains
   function constructor3 (myname) result(res)
      type(complicated) :: res(2)
      character(12) :: myname
      print *, "constructor3: final_count = ", final_count
      res%myname = "constructor3"
      res = [complicated(1, myname, 2.0),complicated(3, myname, 4.0)]
   end function

   function constructor4 (myname) result(res)
      type(complicated), allocatable :: res(:)
      character(12) :: myname
      print *, "constructor4: final_count = ", final_count
      allocate (res(2), source = complicated (1, "constructor3", 1.0))
      res%myname = "constructor4"
      res = [complicated(1, myname, 2.0),complicated(3, myname, 4.0)]
   end function

end program test_final

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

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 752 bytes --]

Hi Paul,

Am 16.02.22 um 19:49 schrieb Paul Richard Thomas via Fortran:
> Hi Harald and Jerry,
>
> I have gone back to the start and have gone through finalizable derived
> type assignments with the F2018 in hand. I have had a dreadful time with
> direct by reference function calls and still am struggling with assignment
> number 6 in the attached. I would be very grateful if you would run this
> testcase for the other brands.

please find attached the output of crayftn-12.0.3, NAG 7.0, and
Intel 2021.5.0, always both default optimization and -g.

The junk in the output for some brands is reproducible.  :-(

> As soon as I fix the 6th assignment, I will get on to class assignments.

Good luck, then.  ;-)

Cheers,
Harald

[-- Attachment #2: out.cray --]
[-- Type: text/plain, Size: 3675 bytes --]

 finalize simple - ThyType%ind =   21
 finalize simple - ThyType2%ind =   22
 At start of program: final_count =    2
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    2(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd assignment(array var allocated): final_count =    2(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 finalize simple - MyType%ind =   99
 finalize simple - MyType%ind =   99
 After 4th assignment(array var allocated) :final_count =    4(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor3: final_count =  2
 finalize complicated(2) - constructor3 =    0  41  0.00  0.00
 finalize simple(:) - constructor3%ind=    0  41
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 5th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor4: final_count =  2
 finalize complicated - constructor3 =    1  1.00
 finalize simple - constructor3%ind =    1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 6th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

[-- Attachment #3: out.intel --]
[-- Type: application/octet-stream, Size: 3808 bytes --]

[-- Attachment #4: out.nag --]
[-- Type: text/plain, Size: 3639 bytes --]

 At start of program: final_count =    0
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    0(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 After 3rd assignment(array var allocated): final_count =    1(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 After 4th assignment(array var allocated) :final_count =    2(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 constructor3: final_count =  0
 finalize complicated(2) - constructor3 =    0   0  0.00  0.00
 finalize simple(:) - constructor3%ind=    0   0
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ª\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - ª\x7f\0\0ypeArra2%ind= ****   3
 finalize complicated(2) - ª\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - ª\x7f\0\0ypeArra2%ind= ****   3
 After 5th assignment(array var allocated):  10(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 constructor4: final_count =  0
 finalize complicated(2) - constructor4 =    1   1  1.00  1.00
 finalize simple(:) - constructor4%ind=    1   1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 After 6th assignment(array var allocated):   6(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

[-- Attachment #5: out.intel-g --]
[-- Type: application/octet-stream, Size: 3808 bytes --]

[-- Attachment #6: out.cray-g --]
[-- Type: text/plain, Size: 3675 bytes --]

 finalize simple - ThyType%ind =   21
 finalize simple - ThyType2%ind =   22
 At start of program: final_count =    2
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    2(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd assignment(array var allocated): final_count =    2(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 finalize simple - MyType%ind =   99
 finalize simple - MyType%ind =   99
 After 4th assignment(array var allocated) :final_count =    4(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor3: final_count =  2
 finalize complicated(2) - constructor3 = ********  0.00  0.00
 finalize simple(:) - constructor3%ind= ********
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 5th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor4: final_count =  2
 finalize complicated - constructor3 =    1  1.00
 finalize simple - constructor3%ind =    1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 6th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

[-- Attachment #7: out.nag-g --]
[-- Type: text/plain, Size: 3565 bytes --]

 At start of program: final_count =    0
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    0(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 After 3rd assignment(array var allocated): final_count =    1(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 After 4th assignment(array var allocated) :final_count =    2(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 constructor3: final_count =  0
 finalize complicated(2) - constructor3 =    0   0  0.00  0.00
 finalize simple(:) - constructor3%ind=    0   0
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - .\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - .\x7f\0\0ypeArra2%ind= ****   3
 finalize complicated(2) - .\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - .\x7f\0\0ypeArra2%ind= ****   3
 After 5th assignment(array var allocated):  10(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 constructor4: final_count =  0
 finalize complicated(2) - constructor4 =    1   1  1.00  1.00
 finalize simple(:) - constructor4%ind=    1   1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 After 6th assignment(array var allocated):   6(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

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

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 730 bytes --]

Hi Paul,

Am 16.02.22 um 19:49 schrieb Paul Richard Thomas via Fortran:
> Hi Harald and Jerry,
> 
> I have gone back to the start and have gone through finalizable derived
> type assignments with the F2018 in hand. I have had a dreadful time with
> direct by reference function calls and still am struggling with assignment
> number 6 in the attached. I would be very grateful if you would run this
> testcase for the other brands.

please find attached the output of crayftn-12.0.3, NAG 7.0, and
Intel 2021.5.0, always both default optimization and -g.

The junk in the output for some brands is reproducible.  :-(

> As soon as I fix the 6th assignment, I will get on to class assignments.

Good luck, then.  ;-)

Cheers,
Harald

[-- Attachment #2: out.cray --]
[-- Type: text/plain, Size: 3675 bytes --]

 finalize simple - ThyType%ind =   21
 finalize simple - ThyType2%ind =   22
 At start of program: final_count =    2
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    2(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd assignment(array var allocated): final_count =    2(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 finalize simple - MyType%ind =   99
 finalize simple - MyType%ind =   99
 After 4th assignment(array var allocated) :final_count =    4(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor3: final_count =  2
 finalize complicated(2) - constructor3 =    0  41  0.00  0.00
 finalize simple(:) - constructor3%ind=    0  41
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 5th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor4: final_count =  2
 finalize complicated - constructor3 =    1  1.00
 finalize simple - constructor3%ind =    1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 6th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

[-- Attachment #3: out.intel --]
[-- Type: application/octet-stream, Size: 3808 bytes --]

[-- Attachment #4: out.nag --]
[-- Type: text/plain, Size: 3639 bytes --]

 At start of program: final_count =    0
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    0(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 After 3rd assignment(array var allocated): final_count =    1(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 After 4th assignment(array var allocated) :final_count =    2(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 constructor3: final_count =  0
 finalize complicated(2) - constructor3 =    0   0  0.00  0.00
 finalize simple(:) - constructor3%ind=    0   0
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ª\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - ª\x7f\0\0ypeArra2%ind= ****   3
 finalize complicated(2) - ª\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - ª\x7f\0\0ypeArra2%ind= ****   3
 After 5th assignment(array var allocated):  10(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 constructor4: final_count =  0
 finalize complicated(2) - constructor4 =    1   1  1.00  1.00
 finalize simple(:) - constructor4%ind=    1   1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 After 6th assignment(array var allocated):   6(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

[-- Attachment #5: out.intel-g --]
[-- Type: application/octet-stream, Size: 3808 bytes --]

[-- Attachment #6: out.cray-g --]
[-- Type: text/plain, Size: 3675 bytes --]

 finalize simple - ThyType%ind =   21
 finalize simple - ThyType2%ind =   22
 At start of program: final_count =    2
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    2(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd assignment(array var allocated): final_count =    2(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 finalize simple - MyType%ind =   99
 finalize simple - MyType%ind =   99
 After 4th assignment(array var allocated) :final_count =    4(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor3: final_count =  2
 finalize complicated(2) - constructor3 = ********  0.00  0.00
 finalize simple(:) - constructor3%ind= ********
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 5th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 finalize complicated - ThyTypeArra1 =   -1  0.00
 finalize simple - ThyTypeArra1%ind =   -1
 constructor4: final_count =  2
 finalize complicated - constructor3 =    1  1.00
 finalize simple - constructor3%ind =    1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 After 6th assignment(array var allocated):   8(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

[-- Attachment #7: out.nag-g --]
[-- Type: text/plain, Size: 3565 bytes --]

 At start of program: final_count =    0
 *******************************************************************
 
 1st assignment: No finalization because MyType unallocated.
 After 1st assignment(var not allocated): final_count =    0(0)
 *******************************************************************
 
 2nd assignment: MyType(=simple(1,MyType) finalized before assignment
 finalize simple - Mytype2%ind =    1
 After 2nd assignment(var allocated): final_count =    1(1)
 *******************************************************************
 
 3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
 
 finalize simple(:) - MyTypeArray%ind=   42  43
 After 3rd assignment(array var allocated): final_count =    1(1)
 *******************************************************************
 
 Deallocation generates final call with self = simple (21, ThyType)
 4th assignment: MyTypeArray finalized before assignment
 Mtype finalized before assignment with self = simple (11, MyType)
 Function result finalized after assignment with self = simple (99, MyType)
 
 finalize simple - ThyType%ind =   21
 finalize simple - MyType%ind =   11
 After 4th assignment(array var allocated) :final_count =    2(3)
 *******************************************************************
 
 5th assignment: MyTypeArray finalized before assignment
 1] First finalization is of 'res' in constructor3 with:
 Self = [complicated (-1, constructor3, 0.0), complicated (-1, ThyTypeArra1, 0.0)]
 2] ThyTypeArray is finalized before assignment and after evaluation of constructor3
 Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
 3] Function result finalized after assignment with
 Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, ThyTypeArra2, 0.0)]
 
 constructor3: final_count =  0
 finalize complicated(2) - constructor3 =    0   0  0.00  0.00
 finalize simple(:) - constructor3%ind=    0   0
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(2) - .\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - .\x7f\0\0ypeArra2%ind= ****   3
 finalize complicated(2) - .\x7f\0\0ypeArra2 = ****   3  2.00  4.00
 finalize simple(:) - .\x7f\0\0ypeArra2%ind= ****   3
 After 5th assignment(array var allocated):  10(6)
 
 *******************************************************************
 Deallocate ThyTypeArray.
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 
 *******************************************************************
 6th assignment: A repeat of the previous with an allocatable function result.
 This should give the same result as the 5th assignment.
 
 constructor4: final_count =  0
 finalize complicated(2) - constructor4 =    1   1  1.00  1.00
 finalize simple(:) - constructor4%ind=    1   1
 finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
 finalize simple(:) - ThyTypeArra2%ind=    1   3
 finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
 finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
 After 6th assignment(array var allocated):   6(6)
 
 *******************************************************************
 Deallocations at end
 
 finalize simple - MyType%ind =   99
 After 1st deallocation: 1
 finalize simple - ThyType2%ind =   22
 After 2nd deallocation: 2
 finalize simple(:) - ThyType%ind=   21  22
 After 3rd deallocation: 3

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

[Thomas Koenig]

Hi Paul,

> I have gone back to the start and have gone through finalizable derived
> type assignments with the F2018 in hand. I have had a dreadful time with
> direct by reference function calls and still am struggling with assignment
> number 6 in the attached. I would be very grateful if you would run this
> testcase for the other brands.

This is the output of nagfor 7.1, no idea how correct this is.

Best regards

	Thomas

  At start of program: final_count =    0
  *******************************************************************

  1st assignment: No finalization because MyType unallocated.
  After 1st assignment(var not allocated): final_count =    0(0)
  *******************************************************************

  2nd assignment: MyType(=simple(1,MyType) finalized before assignment
  finalize simple - Mytype2%ind =    1
  After 2nd assignment(var allocated): final_count =    1(1)
  *******************************************************************

  3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment

  finalize simple(:) - MyTypeArray%ind=   42  43
  After 3rd assignment(array var allocated): final_count =    1(1)
  *******************************************************************

  Deallocation generates final call with self = simple (21, ThyType)
  4th assignment: MyTypeArray finalized before assignment
  Mtype finalized before assignment with self = simple (11, MyType)
  Function result finalized after assignment with self = simple (99, MyType)

  finalize simple - ThyType%ind =   21
  finalize simple - MyType%ind =   11
  After 4th assignment(array var allocated) :final_count =    2(3)
  *******************************************************************

  5th assignment: MyTypeArray finalized before assignment
  1] First finalization is of 'res' in constructor3 with:
  Self = [complicated (-1, constructor3, 0.0), complicated (-1, 
ThyTypeArra1, 0.0)]
  2] ThyTypeArray is finalized before assignment and after evaluation of 
constructor3
  Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
  3] Function result finalized after assignment with
  Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1, 
ThyTypeArra2, 0.0)]

  constructor3: final_count =  0
  finalize complicated(2) - constructor3 =    0   0  0.00  0.00
  finalize simple(:) - constructor3%ind=    0   0
  finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
  finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
  finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
  finalize simple(:) - ThyTypeArra2%ind=    1   3
  finalize complicated(2) - IypeArra2 = ****   3  2.00  4.00
  finalize simple(:) - IypeArra2%ind= ****   3
  finalize complicated(2) - IypeArra2 = ****   3  2.00  4.00
  finalize simple(:) - IypeArra2%ind= ****   3
  After 5th assignment(array var allocated):  10(6)

  *******************************************************************
  Deallocate ThyTypeArray.
  finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
  finalize simple(:) - ThyTypeArra2%ind=    1   3

  *******************************************************************
  6th assignment: A repeat of the previous with an allocatable function 
result.
  This should give the same result as the 5th assignment.

  constructor4: final_count =  0
  finalize complicated(2) - constructor4 =    1   1  1.00  1.00
  finalize simple(:) - constructor4%ind=    1   1
  finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
  finalize simple(:) - ThyTypeArra2%ind=    1   3
  finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
  finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
  After 6th assignment(array var allocated):   6(6)

  *******************************************************************
  Deallocations at end

  finalize simple - MyType%ind =   99
  After 1st deallocation: 1
  finalize simple - ThyType2%ind =   22
  After 2nd deallocation: 2
  finalize simple(:) - ThyType%ind=   21  22
  After 3rd deallocation: 3

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 7645 bytes --]

Hi Harald and Thomas,

Thank you for your contributions to understanding the interpretation by
different vendors of the F2018 requirements for finalization. While it does
appear to be rather chaotic, the differences are down to a small number of
"features" of each compiler.

Before describing my interpretation of the behaviour of the offerings from
other vendors, I should remark briefly about where I am with gfortran. I
now have a patch that handles derived types correctly according to F2018
7.5.6.2 and 7.5.6.3, modulo the ambiguous requirement for the handling of
parent components that I will come to when discussing ifort. I have a patch
ready to fix this, should Intel's interpretation be correct. I have not
moved on to class finalization yet because there are memory leaks connected
with finalization of function results that I have yet to pin down. Also,
finalization of function results within array and structure constructors is
yet to come. Once I have it all working, I will break up the patch into a
number of stages to make it more digestible for review. However, just in
case I fall under the proverbial bus, I have attached the patch for
reference.

Turning to the results from the other vendors:

Cray: Seemingly, the only difference in interpretation concerns the
finalization of structure constructors. 7.5.6.3 paragraphs 5 and 6 only
mention function results. Having scoured the standard for guidance, I have
only found Note 7.57: "name(...) ...snip... is interpreted as a structure
constructor only if it cannot be interpreted as a generic function
reference." From this, I take it that a structure constructor is distinct
from a function reference and, since not mentioned in 7.5.6.3, the result
should not be finalized.

nagfor 7.1: The NAG offering seems to be a bit inconsistent in the
finalization of function results. It is missing in assignment 4 and suffers
a surfeit in assignment 5. The two extras in assignment 5 seem to be
mangled. As far as I can tell, these are problems of implementation rather
than interpretation.

ifort: In all the versions tested, assignment 1 generates, contrary to the
standard, a finalization of an unallocated allocated 'var'. The other
difference from gfortran with the patch applied is in the finalization of
the parent component in the finalization of arrays of extended types. ifort
makes use of the scalar finalizer, whereas all the other compilers use the
array finalizer. In fairness to the folk at Intel, I think that there is an
ambiguity in 7.5.6.2 -

"(2) All finalizable components that appear in the type definition are
finalized in a processor-dependent order. If the entity being finalized is
an array, each finalizable component of each element of that entity is
finalized separately.
(3) If the entity is of extended type and the parent type is finalizable,
the parent component is finalized."

The separate mention of the parent component in (3) rather than in (2)
saying, "..each finalizable component, including the parent component,..."
implies that it is in some way different. I think that an interpretation
request is in order.

I will be unavailable to do any gfortran work for two weeks now but will
complete this work then.

Best regards and thanks again.

Paul


On Thu, 17 Feb 2022 at 21:23, Thomas Koenig <tkoenig@netcologne.de> wrote:

> Hi Paul,
>
> > I have gone back to the start and have gone through finalizable derived
> > type assignments with the F2018 in hand. I have had a dreadful time with
> > direct by reference function calls and still am struggling with
> assignment
> > number 6 in the attached. I would be very grateful if you would run this
> > testcase for the other brands.
>
> This is the output of nagfor 7.1, no idea how correct this is.
>
> Best regards
>
>         Thomas
>
>   At start of program: final_count =    0
>   *******************************************************************
>
>   1st assignment: No finalization because MyType unallocated.
>   After 1st assignment(var not allocated): final_count =    0(0)
>   *******************************************************************
>
>   2nd assignment: MyType(=simple(1,MyType) finalized before assignment
>   finalize simple - Mytype2%ind =    1
>   After 2nd assignment(var allocated): final_count =    1(1)
>   *******************************************************************
>
>   3rd assignment: MyTypeArray(%ind = [41 42]) finalized before assignment
>
>   finalize simple(:) - MyTypeArray%ind=   42  43
>   After 3rd assignment(array var allocated): final_count =    1(1)
>   *******************************************************************
>
>   Deallocation generates final call with self = simple (21, ThyType)
>   4th assignment: MyTypeArray finalized before assignment
>   Mtype finalized before assignment with self = simple (11, MyType)
>   Function result finalized after assignment with self = simple (99,
> MyType)
>
>   finalize simple - ThyType%ind =   21
>   finalize simple - MyType%ind =   11
>   After 4th assignment(array var allocated) :final_count =    2(3)
>   *******************************************************************
>
>   5th assignment: MyTypeArray finalized before assignment
>   1] First finalization is of 'res' in constructor3 with:
>   Self = [complicated (-1, constructor3, 0.0), complicated (-1,
> ThyTypeArra1, 0.0)]
>   2] ThyTypeArray is finalized before assignment and after evaluation of
> constructor3
>   Self = [3 times complicated (-1, ThyTypeArra1,0.0)]
>   3] Function result finalized after assignment with
>   Self = [complicated (-1, ThyTypeArra2, 0.0), complicated (-1,
> ThyTypeArra2, 0.0)]
>
>   constructor3: final_count =  0
>   finalize complicated(2) - constructor3 =    0   0  0.00  0.00
>   finalize simple(:) - constructor3%ind=    0   0
>   finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
>   finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
>   finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
>   finalize simple(:) - ThyTypeArra2%ind=    1   3
>   finalize complicated(2) - IypeArra2 = ****   3  2.00  4.00
>   finalize simple(:) - IypeArra2%ind= ****   3
>   finalize complicated(2) - IypeArra2 = ****   3  2.00  4.00
>   finalize simple(:) - IypeArra2%ind= ****   3
>   After 5th assignment(array var allocated):  10(6)
>
>   *******************************************************************
>   Deallocate ThyTypeArray.
>   finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
>   finalize simple(:) - ThyTypeArra2%ind=    1   3
>
>   *******************************************************************
>   6th assignment: A repeat of the previous with an allocatable function
> result.
>   This should give the same result as the 5th assignment.
>
>   constructor4: final_count =  0
>   finalize complicated(2) - constructor4 =    1   1  1.00  1.00
>   finalize simple(:) - constructor4%ind=    1   1
>   finalize complicated(2) - ThyTypeArra2 =    1   3  2.00  4.00
>   finalize simple(:) - ThyTypeArra2%ind=    1   3
>   finalize complicated(3) - ThyTypeArra1 =   -1  -1  -1  0.00  0.00  0.00
>   finalize simple(:) - ThyTypeArra1%ind=   -1  -1  -1
>   After 6th assignment(array var allocated):   6(6)
>
>   *******************************************************************
>   Deallocations at end
>
>   finalize simple - MyType%ind =   99
>   After 1st deallocation: 1
>   finalize simple - ThyType2%ind =   22
>   After 2nd deallocation: 2
>   finalize simple(:) - ThyType%ind=   21  22
>   After 3rd deallocation: 3
>


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

[-- Attachment #2: check180222.diff --]
[-- Type: text/x-patch, Size: 42468 bytes --]

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 731e9b0fe6a..a249eea4a30 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
    gfc_component *c;
 
   for (c = derived->components; c; c = c->next)
-    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+	&& c->attr.flavor != FL_PROCEDURE)
       {
 	if (c->ts.u.derived->f2k_derived
 	    && c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
     {
       /* Call FINAL_WRAPPER (comp);  */
       gfc_code *final_wrap;
-      gfc_symbol *vtab;
+      gfc_symbol *vtab, *byte_stride;
+      gfc_expr *scalar, *size_expr, *fini_coarray_expr;
       gfc_component *c;
 
       vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 	  break;
 
       gcc_assert (c);
+
+      /* Set scalar argument for storage_size.  */
+      gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+      byte_stride->ts = e->ts;
+      byte_stride->attr.flavor = FL_VARIABLE;
+      byte_stride->attr.value = 1;
+      byte_stride->attr.artificial = 1;
+      gfc_set_sym_referenced (byte_stride);
+      gfc_commit_symbol (byte_stride);
+      scalar = gfc_lval_expr_from_sym (byte_stride);
+
       final_wrap = gfc_get_code (EXEC_CALL);
       final_wrap->symtree = c->initializer->symtree;
       final_wrap->resolved_sym = c->initializer->symtree->n.sym;
       final_wrap->ext.actual = gfc_get_actual_arglist ();
       final_wrap->ext.actual->expr = e;
 
+      /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+      size_expr = gfc_get_expr ();
+      size_expr->where = gfc_current_locus;
+      size_expr->expr_type = EXPR_OP;
+      size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+      /* STORAGE_SIZE (array,kind=c_intptr_t).  */
+      size_expr->value.op.op1
+	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+				    "storage_size", gfc_current_locus, 2,
+				    scalar,
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL, 0));
+
+      /* NUMERIC_STORAGE_SIZE.  */
+      size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+						  gfc_character_storage_size);
+      size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+      size_expr->ts = size_expr->value.op.op1->ts;
+
+      /* Which provides the argument 'byte_stride'.....  */
+      final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->expr = size_expr;
+
+      /* ...and last of all the 'fini_coarray' argument.  */
+      fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+      final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
       if (*code)
 	{
 	  (*code)->next = final_wrap;
@@ -1430,8 +1474,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->next->resolved_sym = fini->proc_tree->n.sym;
   block->next->ext.actual = gfc_get_actual_arglist ();
   block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
-  block->next->ext.actual->next = gfc_get_actual_arglist ();
-  block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
 
   /* ELSE.  */
 
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 835a4783718..fe17df2f73d 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10512,6 +10512,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
 	      if (e && !resolve_where_shape (cnext->expr1, e))
 	       gfc_error ("WHERE assignment target at %L has "
 			  "inconsistent shape", &cnext->expr1->where);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;
 
 
@@ -10599,6 +10603,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
 	    /* WHERE assignment statement */
 	    case EXEC_ASSIGN:
 	      gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;
 
 	    /* WHERE operator assignment statement */
@@ -10645,6 +10653,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
 	case EXEC_ASSIGN:
 	case EXEC_POINTER_ASSIGN:
 	  gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+	  if (c->op == EXEC_ASSIGN)
+	    c->expr1->must_finalize = 1;
+
 	  break;
 
 	case EXEC_ASSIGN_CALL:
@@ -11324,6 +11336,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
   tmp->n.sym->attr.use_assoc = 0;
   tmp->n.sym->attr.intent = INTENT_UNKNOWN;
 
+
   if (as)
     {
       tmp->n.sym->as = gfc_copy_array_spec (as);
@@ -12069,6 +12082,9 @@ start:
 	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
 	    generate_component_assignments (&code, ns);
 
+	  if (code->op == EXEC_ASSIGN)
+	    code->expr1->must_finalize = 1;
+
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cfb6eac11c7..2ff0c3840a9 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);
 	}
@@ -3161,6 +3161,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;
 
@@ -7478,7 +7479,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)
     {
@@ -8910,7 +8911,8 @@ gfc_caf_is_dealloc_only (int caf_mode)
 
 /* Recursively traverse an object of derived type, generating code to
    deallocate, nullify or copy allocatable components.  This is the work horse
-   function for the functions named in this enum.  */
+   function for the functions named in this enum.  When del_ptrs is set with
+   COPY_ALLOC_COMP, pointers are nullified.  */
 
 enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
       COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
@@ -8920,9 +8922,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;
@@ -9010,11 +9014,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);
 
@@ -9048,13 +9053,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);
     }
 
@@ -9116,7 +9123,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
 		{
@@ -9124,7 +9131,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);
 		}
 	    }
 
@@ -9240,8 +9248,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,
@@ -9269,7 +9277,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
 		{
@@ -9277,7 +9285,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);
 		}
 	    }
 
@@ -9575,7 +9584,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;
@@ -9611,14 +9621,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.  */
@@ -9660,6 +9670,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),
@@ -9706,6 +9723,17 @@ 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
@@ -9719,7 +9747,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;
@@ -10092,7 +10121,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);
 }
 
 
@@ -10105,7 +10135,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
@@ -10143,7 +10174,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;
 }
 
@@ -10153,10 +10185,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);
 }
 
 
@@ -10164,7 +10198,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);
 }
 
 
@@ -10180,6 +10215,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 deleting pointers and
+   suppressing any finalization that might occur.  This is used in the
+   finaliztion 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.  */
 
@@ -10950,7 +10999,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);
     }
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 04fee617590..2743158cb11 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -56,11 +56,14 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
 			   tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+				       bool no_finalization = false);
 tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
 
 tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
 
+tree gfc_copy_alloc_comp_del_ptrs (gfc_symbol *, tree, tree, int, int);
+
 tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
 
 tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index eb6a78c3a62..2f02cb5ea68 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1904,6 +1904,7 @@ gfc_init_se (gfc_se * se, gfc_se * parent)
 {
   memset (se, 0, sizeof (gfc_se));
   gfc_init_block (&se->pre);
+  gfc_init_block (&se->finalblock);
   gfc_init_block (&se->post);
 
   se->parent = parent;
@@ -5975,6 +5976,129 @@ post_call:
 }
 
 
+/* Finalize a function result using the finalizer wrapper. The result is fixed
+   in order to prevent repeated calls.  */
+
+static void
+finalize_function_result (gfc_se *se, gfc_symbol *derived,
+			  symbol_attribute attr, int rank)
+{
+  tree vptr, final_fndecl, desc, tmp, size, is_final, data_ptr, cond;
+  gfc_symbol *vtab;
+  gfc_se post_se;
+  bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
+
+  if (attr.pointer)
+    return;
+
+  if (is_class)
+    {
+      if (!VAR_P (se->expr))
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->pre);
+	  se->expr = desc;
+	}
+      desc = gfc_class_data_get (se->expr);
+      vptr = gfc_class_vptr_get (se->expr);
+    }
+  else
+    {
+      /* Need to copy allocated components and delete pointer components.  */
+      if (se->direct_byref)
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->finalblock);
+	  tmp = gfc_copy_alloc_comp_del_ptrs (derived, se->expr, desc, rank, 0);
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+      else
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->pre);
+	  se->expr = gfc_evaluate_now (desc, &se->pre);
+	  tmp = gfc_copy_alloc_comp_del_ptrs (derived, se->expr, desc, rank, 0);
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+
+      vtab = gfc_find_derived_vtab (derived);
+      if (vtab->backend_decl == NULL_TREE)
+	vptr = gfc_get_symbol_decl (vtab);
+      else
+	vptr = vtab->backend_decl;
+      vptr = gfc_build_addr_expr (NULL, vptr);
+    }
+
+  size = gfc_vptr_size_get (vptr);
+  final_fndecl = gfc_vptr_final_get (vptr);
+  is_final = fold_build2_loc (input_location, NE_EXPR,
+			      logical_type_node,
+			      final_fndecl,
+			      fold_convert (TREE_TYPE (final_fndecl),
+					    null_pointer_node));
+
+  final_fndecl = build_fold_indirect_ref_loc (input_location,
+					      final_fndecl);
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      if (is_class)
+	desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
+      else
+	{
+	  gfc_init_se (&post_se, NULL);
+	  desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
+	  gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
+	}
+    }
+
+  tmp = gfc_create_var (TREE_TYPE (desc), "res");
+  if (se->direct_byref)
+    gfc_add_modify (&se->finalblock, tmp, desc);
+  else
+    gfc_add_modify (&se->pre, tmp, desc);
+  desc = tmp;
+
+  data_ptr = gfc_conv_descriptor_data_get (desc);
+  cond = fold_build2_loc (input_location, NE_EXPR,
+			  logical_type_node, data_ptr,
+			  fold_convert (TREE_TYPE (data_ptr),
+					null_pointer_node));
+  is_final = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			      logical_type_node, is_final, cond);
+  tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+			     gfc_build_addr_expr (NULL, desc),
+			     size, boolean_false_node);
+  tmp = fold_build3_loc (input_location, COND_EXPR,
+			 void_type_node, is_final, tmp,
+			 build_empty_stmt (input_location));
+
+  if (is_class && se->ss && se->ss->loop)
+    {
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+      cond = fold_build2_loc (input_location, NE_EXPR,
+			      logical_type_node,
+			      data_ptr,
+			      fold_convert (TREE_TYPE (data_ptr),
+					    null_pointer_node));
+      tmp = fold_build3_loc (input_location, COND_EXPR,
+			     void_type_node, cond,
+			     gfc_call_free (data_ptr),
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+    }
+  else
+    {
+      gfc_add_expr_to_block (&se->finalblock, tmp);
+
+      /* Let the scalarizer take care of freeing of temporary arrays.  */
+      if (attr.allocatable && !(se->loop && se->loop->temp_dim))
+	{
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 void_type_node, cond,
+				 gfc_call_free (data_ptr),
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+    }
+}
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -7011,6 +7135,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
+      gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
 
       /* Allocated allocatable components of derived types must be
 	 deallocated for non-variable scalars, array arguments to elemental
@@ -7675,9 +7800,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   /* Allocatable scalar function results must be freed and nullified
      after use. This necessitates the creation of a temporary to
      hold the result to prevent duplicate calls.  */
+  symbol_attribute attr =  comp ? comp->attr : sym->attr;
+  bool allocatable = attr.allocatable && !attr.dimension;
+  gfc_symbol *der = comp && comp->ts.type == BT_DERIVED ? comp->ts.u.derived
+		    : (sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL);
+  bool finalizable = der != NULL && gfc_is_finalizable (der, NULL);
+
+  if (!byref && finalizable)
+    finalize_function_result (se, der, attr, expr->rank);
+
   if (!byref && sym->ts.type != BT_CHARACTER
-      && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
-	  || (comp && comp->attr.allocatable && !comp->attr.dimension)))
+      && allocatable && !finalizable)
     {
       tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
       gfc_add_modify (&se->pre, tmp, se->expr);
@@ -7737,6 +7870,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      se->expr = info->descriptor;
 	      /* Bundle in the string length.  */
 	      se->string_length = len;
+
+	      if (finalizable)
+		finalize_function_result (se, der, attr, expr->rank);
 	    }
 	  else if (ts.type == BT_CHARACTER)
 	    {
@@ -7829,8 +7965,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
 	  && expr->must_finalize)
 	{
-	  tree final_fndecl;
-	  tree is_final;
 	  int n;
 	  if (se->ss && se->ss->loop)
 	    {
@@ -7852,66 +7986,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      /* TODO Eliminate the doubling of temporaries. This
 		 one is necessary to ensure no memory leakage.  */
 	      se->expr = gfc_evaluate_now (se->expr, &se->pre);
-	      tmp = gfc_class_data_get (se->expr);
-	      tmp = gfc_conv_scalar_to_descriptor (se, tmp,
-			CLASS_DATA (expr->value.function.esym->result)->attr);
 	    }
 
-	  if ((gfc_is_class_array_function (expr)
-	       || gfc_is_alloc_class_scalar_function (expr))
-	      && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
-	    goto no_finalization;
-
-	  final_fndecl = gfc_class_vtab_final_get (se->expr);
-	  is_final = fold_build2_loc (input_location, NE_EXPR,
-				      logical_type_node,
-				      final_fndecl,
-				      fold_convert (TREE_TYPE (final_fndecl),
-					   	    null_pointer_node));
-	  final_fndecl = build_fold_indirect_ref_loc (input_location,
-						      final_fndecl);
- 	  tmp = build_call_expr_loc (input_location,
-				     final_fndecl, 3,
-				     gfc_build_addr_expr (NULL, tmp),
-				     gfc_class_vtab_size_get (se->expr),
-				     boolean_false_node);
-	  tmp = fold_build3_loc (input_location, COND_EXPR,
-				 void_type_node, is_final, tmp,
-				 build_empty_stmt (input_location));
-
-	  if (se->ss && se->ss->loop)
-	    {
-	      gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     info->data,
-				     fold_convert (TREE_TYPE (info->data),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (info->data),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->ss->loop->post, tmp);
-	    }
-	  else
-	    {
-	      tree classdata;
-	      gfc_prepend_expr_to_block (&se->post, tmp);
-	      classdata = gfc_class_data_get (se->expr);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     classdata,
-				     fold_convert (TREE_TYPE (classdata),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (classdata),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->post, tmp);
-	    }
+	  /* Finalize the result, if necessary.  */
+	  attr = CLASS_DATA (expr->value.function.esym->result)->attr;
+	  if (!((gfc_is_class_array_function (expr)
+		 || gfc_is_alloc_class_scalar_function (expr))
+		&& attr.pointer))
+	    finalize_function_result (se, NULL, attr, expr->rank);
 	}
-
-no_finalization:
       gfc_add_block_to_block (&se->post, &post);
     }
 
@@ -10430,7 +10513,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       if (dealloc)
 	{
 	  tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
-	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+						  0, true);
 	  if (deep_copy)
 	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
 			    tmp);
@@ -10438,6 +10522,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	}
 
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
       gfc_add_block_to_block (&block, &lse->pre);
 
       gfc_add_modify (&block, lse->expr,
@@ -10467,8 +10552,9 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
     }
   else if (gfc_bt_struct (ts.type))
     {
-      gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
+      gfc_add_block_to_block (&block, &lse->pre);
       tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
 			     TREE_TYPE (lse->expr), rse->expr);
       gfc_add_modify (&block, lse->expr, tmp);
@@ -10478,6 +10564,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
 
       if (!trans_scalar_class_assign (&block, lse, rse))
 	{
@@ -10796,6 +10883,99 @@ fcncall_realloc_result (gfc_se *se, int rank)
 }
 
 
+  /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+     (10.2.1.3), if the variable is not an unallocated allocatable variable,
+     it is finalized after evaluation of expr and before the definition of
+     the variable. If the variable is an allocated allocatable variable, or
+     has an allocated allocatable subobject, that would be deallocated by
+     intrinsic assignment, the finalization occurs before the deallocation */
+
+static bool
+gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag)
+{
+  symbol_attribute lhs_attr;
+  tree final_expr;
+  tree ptr;
+  tree cond;
+  gfc_se se;
+  gfc_symbol *sym = expr1->symtree->n.sym;
+  gfc_ref *ref = expr1->ref;
+  stmtblock_t final_block;
+  gfc_init_block (&final_block);
+
+  /* We have to exclude vtable procedures (_copy and _final especially), uses
+     of gfc_trans_assignment_1 in initialization and allocation before trying
+     to build a final call.  */
+  if (!expr1->must_finalize
+      || sym->attr.artificial
+      || sym->ns->proc_name->attr.artificial
+      || init_flag)
+    return false;
+
+  /* F2018 7.5.6.2: Only finalizable entities are finalized.  */
+  for (; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      return false;
+
+  gfc_init_block (&final_block);
+
+  if (!(sym->ts.type == BT_CLASS
+	|| (sym->ts.type == BT_DERIVED
+	    && gfc_is_finalizable (sym->ts.u.derived, NULL)))
+      || !gfc_add_finalizer_call (&final_block, expr1))
+    return false;
+
+  lhs_attr = gfc_expr_attr (expr1);
+
+  /* Check allocatable/pointer is allocated/associated.  */
+  if (lhs_attr.allocatable || lhs_attr.pointer)
+    {
+      if (expr1->ts.type == BT_CLASS)
+	{
+	  ptr = gfc_get_class_from_gfc_expr (expr1);
+	  gcc_assert (ptr != NULL_TREE);
+	  ptr = gfc_class_data_get (ptr);
+	  if (lhs_attr.dimension)
+	    ptr = gfc_conv_descriptor_data_get (ptr);
+	}
+      else
+	{
+	  gfc_init_se (&se, NULL);
+	  if (expr1->rank)
+	    {
+	      gfc_conv_expr_descriptor (&se, expr1);
+	      ptr = gfc_conv_descriptor_data_get (se.expr);
+	    }
+	  else
+	    {
+	      gfc_conv_expr (&se, expr1);
+	      ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
+	    }
+	}
+
+      cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			      ptr, build_zero_cst (TREE_TYPE (ptr)));
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, gfc_finish_block (&final_block),
+			       build_empty_stmt (input_location));
+    }
+  else
+    final_expr = gfc_finish_block (&final_block);
+
+  /* Check optional present.  */
+  if (sym->attr.optional)
+    {
+      cond = gfc_conv_expr_present (sym);
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, final_expr,
+			       build_empty_stmt (input_location));
+    }
+
+  gfc_add_expr_to_block (&lse->finalblock, final_expr);
+
+  return true;
+}
+
 
 /* Try to translate array(:) = func (...), where func is a transformational
    array function, without using a temporary.  Returns NULL if this isn't the
@@ -10808,6 +10988,12 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_ss *ss = NULL;
   gfc_component *comp = NULL;
   gfc_loopinfo loop;
+  tree tmp;
+  tree lhs;
+  gfc_se final_se;
+  gfc_symbol *sym = expr1->symtree->n.sym;
+  bool finalizable = expr1->ts.type == BT_DERIVED
+		     && gfc_is_finalizable (expr1->ts.u.derived, NULL);
 
   if (arrayfunc_assign_needs_temporary (expr1, expr2))
     return NULL;
@@ -10826,12 +11012,44 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 
+  /* First the lhs must be finalized, if necessary. We use a copy of the symbol
+     backend decl, stash the original away for the finalization so that the
+     value used is that before the assignment. This is necessary because
+     evaluation of the rhs expression using direct by reference can change
+     the value. However, the standard mandates that the finalization must occur
+     after evaluation of the rhs.  */
+  gfc_init_se (&final_se, NULL);
+
+  if (finalizable)
+    {
+      tmp = sym->backend_decl;
+      lhs = sym->backend_decl;
+      if (TREE_CODE (tmp) == INDIRECT_REF)
+	tmp = TREE_OPERAND (tmp, 0);
+      sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
+      gfc_add_modify (&se.pre, sym->backend_decl, tmp);
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
+				     expr1->rank, 0);
+	  gfc_add_expr_to_block (&final_se.pre, tmp);
+	}
+    }
+
+  if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
+    {
+      gfc_add_block_to_block (&se.pre, &final_se.pre);
+      gfc_add_block_to_block (&se.post, &final_se.finalblock);
+    }
+
+  if (finalizable)
+    sym->backend_decl = lhs;
+
   gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
 
   if (expr1->ts.type == BT_DERIVED
 	&& expr1->ts.u.derived->attr.alloc_comp)
     {
-      tree tmp;
       tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
 					      expr1->rank);
       gfc_add_expr_to_block (&se.pre, tmp);
@@ -10841,6 +11059,17 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   se.ss = gfc_walk_expr (expr2);
   gcc_assert (se.ss != gfc_ss_terminator);
 
+  /* Since this is a direct by reference call, references to the lhs can be
+     used for finalization of the function result just as long as the blocks
+     from final_se are added at the right time.  */
+  gfc_init_se (&final_se, NULL);
+  if (finalizable && expr2->value.function.esym)
+    {
+      final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+      finalize_function_result (&final_se, expr2->ts.u.derived,
+				expr2->value.function.esym->attr, expr2->rank);
+    }
+
   /* Reallocate on assignment needs the loopinfo for extrinsic functions.
      This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
      Clearly, this cannot be done for an allocatable function result, since
@@ -10871,7 +11100,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
     }
 
   gfc_conv_function_expr (&se, expr2);
+
+  /* Fix the result.  */
   gfc_add_block_to_block (&se.pre, &se.post);
+  if (finalizable)
+    gfc_add_block_to_block (&se.pre, &final_se.pre);
+
+  /* Do the finalization, including final calls from function arguments.  */
+  if (finalizable)
+    {
+      gfc_add_block_to_block (&se.pre, &final_se.post);
+      gfc_add_block_to_block (&se.pre, &se.finalblock);
+      gfc_add_block_to_block (&se.pre, &final_se.finalblock);
+   }
 
   if (ss)
     gfc_cleanup_loop (&loop);
@@ -11394,6 +11635,17 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 {
   tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
   vec<tree, va_gc> *args = NULL;
+  bool final_expr;
+
+  final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
+  if (final_expr)
+    {
+      if (rse->loop)
+	gfc_prepend_expr_to_block (&rse->loop->pre,
+				   gfc_finish_block (&lse->finalblock));
+      else
+	gfc_add_block_to_block (block, &lse->finalblock);
+    }
 
   /* Store the old vptr so that dynamic types can be compared for
      reallocation to occur or not.  */
@@ -11419,8 +11671,12 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 	old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
 
       size = gfc_vptr_size_get (vptr);
-      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
-	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      if (TREE_CODE (lse->expr) == INDIRECT_REF)
+	tmp = TREE_OPERAND (lse->expr, 0);
+      else
+	tmp = lse->expr;
+      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+	  ? gfc_class_data_get (tmp) : tmp;
 
       /* Allocate block.  */
       gfc_init_block (&alloc);
@@ -11519,6 +11775,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
     }
 }
 
+
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
    init_flag indicates initialization expressions and dealloc that no
@@ -11542,6 +11799,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   tree tmp;
   stmtblock_t block;
   stmtblock_t body;
+  bool final_expr;
   bool l_is_temp;
   bool scalar_to_array;
   tree string_length;
@@ -11582,6 +11840,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      needed at two locations, so do it once only before the information is
      needed.  */
   lhs_attr = gfc_expr_attr (expr1);
+
   is_poly_assign = (use_vptr_copy || lhs_attr.pointer
 		    || (lhs_attr.allocatable && !lhs_attr.dimension))
 		   && (expr1->ts.type == BT_CLASS
@@ -11855,6 +12114,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  else
 	    gfc_add_expr_to_block (&loop.post, tmp2);
 	}
+
+      expr1->must_finalize = 0;
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB
 	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -11900,6 +12161,27 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	}
     }
 
+  /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+     after evaluation of the rhs and before reallocation.  */
+  final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
+  if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
+		      && expr2->symtree->n.sym->attr.artificial))
+    {
+      if (lss == gfc_ss_terminator)
+	{
+	  gfc_add_block_to_block (&block, &rse.pre);
+	  gfc_add_block_to_block (&block, &lse.finalblock);
+	}
+      else
+	{
+	  gfc_add_block_to_block (&body, &rse.pre);
+	  gfc_add_block_to_block (&loop.code[expr1->rank - 1],
+				  &lse.finalblock);
+	}
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.pre);
+
   /* If nothing else works, do it the old fashioned way!  */
   if (tmp == NULL_TREE)
     tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
@@ -11909,12 +12191,20 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 				   !(l_is_temp || init_flag) && dealloc,
 				   expr1->symtree->n.sym->attr.codimension);
 
-  /* Add the pre blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.pre);
+
+  /* Add the lse pre block to the body  */
   gfc_add_block_to_block (&body, &lse.pre);
   gfc_add_expr_to_block (&body, tmp);
+
   /* Add the post blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.post);
+  if (!l_is_temp)
+    {
+      gfc_add_block_to_block (&rse.finalblock, &rse.post);
+      gfc_add_block_to_block (&body, &rse.finalblock);
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.post);
+
   gfc_add_block_to_block (&body, &lse.post);
 
   if (lss == gfc_ss_terminator)
@@ -11938,6 +12228,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  gfc_trans_scalarized_loop_boundary (&loop, &body);
 
 	  /* We need to copy the temporary to the actual lhs.  */
+//	  gfc_add_block_to_block (&loop.post, &rse.finalblock);
 	  gfc_init_se (&lse, NULL);
 	  gfc_init_se (&rse, NULL);
 	  gfc_copy_loopinfo_to_se (&lse, &loop);
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 732221f848b..bf4f0671585 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2664,6 +2664,7 @@ scalarize:
 
   gfc_add_block_to_block (&body, &se.pre);
   gfc_add_block_to_block (&body, &se.post);
+  gfc_add_block_to_block (&body, &se.finalblock);
 
   if (se.ss == NULL)
     tmp = gfc_finish_block (&body);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 04f8147d23b..e0f513f8941 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -443,7 +443,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       else
 	gfc_add_expr_to_block (&se.pre, se.expr);
 
-      gfc_add_block_to_block (&se.pre, &se.post);
+      gfc_add_block_to_block (&se.finalblock, &se.post);
+      gfc_add_block_to_block (&se.pre, &se.finalblock);
     }
 
   else
@@ -542,6 +543,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       gfc_trans_scalarizing_loops (&loop, &body);
       gfc_add_block_to_block (&se.pre, &loop.pre);
       gfc_add_block_to_block (&se.pre, &loop.post);
+      gfc_add_block_to_block (&se.pre, &loopse.finalblock);
       gfc_add_block_to_block (&se.pre, &se.post);
       gfc_cleanup_loop (&loop);
     }
@@ -6337,7 +6339,10 @@ gfc_trans_allocate (gfc_code * code)
 	}
       gfc_add_block_to_block (&block, &se.pre);
       if (code->expr3->must_finalize)
-	gfc_add_block_to_block (&final_block, &se.post);
+	{
+	  gfc_add_block_to_block (&final_block, &se.finalblock);
+	  gfc_add_block_to_block (&final_block, &se.post);
+	}
       else
 	gfc_add_block_to_block (&post, &se.post);
 
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 333dfa69642..fabdcde7267 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1242,6 +1242,9 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
   if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
     return false;
 
+  if (gfc_expr_attr (expr2).artificial)
+    return false;
+
   if (expr2->ts.type == BT_DERIVED)
     {
       gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 738c7487a56..72af54c4d29 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -43,6 +43,10 @@ typedef struct gfc_se
   stmtblock_t pre;
   stmtblock_t post;
 
+  /* Carries finalization code that is required to be executed execution of the
+     innermost executable construct.  */
+  stmtblock_t finalblock;
+
   /* the result of the expression */
   tree expr;
 
@@ -55,7 +59,7 @@ typedef struct gfc_se
 
   /* Whether expr is a reference to an unlimited polymorphic object.  */
   unsigned unlimited_polymorphic:1;
-  
+
   /* If set gfc_conv_variable will return an expression for the array
      descriptor. When set, want_pointer should also be set.
      If not set scalarizing variables will be substituted.  */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
index 92dc50756d4..de20a147842 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
@@ -68,4 +68,4 @@ contains
   end function func_foo_a
 
 end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }

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

[Paul Richard Thomas]

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

Hi All,

Happy new year!

This thread broke off in February last year, as did my effort to resolve
all the issues. However, prodded by Damian, I picked up the mantle again
about a month ago.

Please consider this posting to be a placeholder. All the dependencies of
PR37366 appear to be fixed although some minor issues remain and some
divergences with the other brands. I will be contacting the vendors of the
other brands today or tomorrow and will try to achieve some resolution with
them. In the meantime, I will break the patch down to half a dozen more
digestible chunks and will aim to submit formally in a week or so.

Of the remaining issues:
Function results of finalizable type with zero components confound the
gimplifier: see PR65347 comment 3.
finalize_38.f90 loses 38 bytes in 4 blocks and has a load of invalid writes.
finalize_49.f90 has a number of invalid writes.

Please give the patch a whirl and any feedback that you might have would be
very welcome.

Cheers

Paul

Fortran:Implement missing finalization features [PR37336]

2022-02-02  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/103854
* class.cc (has_finalizer_component): Do not return true for
procedure pointer components.

PR fortran/96122
* class.cc (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.

PR fortran/37336
* class.cc (finalizer_insert_packed_call): Remove the redundant
argument in the call to the final subroutine.
(generate_finalization_wrapper): Add support for assumed rank
finalizers.
(gfc_may_be_finalized): New helper function.
* dump_parse_tree.cc (show_expr): Mark expressions with
must_finalize set.
* gfortran.h : Add prototype for gfc_may_be_finalized.
* resolve.cc (resolve_where, gfc_resolve_where_code_in_forall,
gfc_resolve_forall_body, gfc_resolve_code): Check that the op
code is still EXEC_ASSIGN. If it is set lhs to must finalize.
(generate_component_assignments): Set must_finalize if needed.
(gfc_resolve_finalizers): Error if assumed rank finalizer is
not the only one. Warning on lack of scalar finalizer modified
to account for assumed rank finalizers.
(resolve_symbol): Set referenced an unreferenced symbol that
will be finalized.
* trans-array.cc (gfc_trans_array_constructor_value): Add code
to finalize the constructor result. Warn that this feature was
removed in F2018 and that it is suppressed by -std=2018.
(trans_array_constructor): Add finalblock, pass to previous
and apply to loop->post if filled.
(gfc_add_loop_ss_code): Add se finalblock to outer loop post.
(gfc_trans_array_cobounds, gfc_trans_array_bounds): Add any
generated finalization code to the main block.
(structure_alloc_comps): Add boolean argument to suppress
finalization and use it for calls from
gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to
false. Add a second, additional boolean argument to nullify
pointer components and use it in gfc_copy_alloc_comp_del_ptrs.
(gfc_copy_alloc_comp_del_ptrs): New wrapper for
structure_alloc_comps.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_trans_deferred_array): Use gfc_may_be_finalized.
* trans-array.h : Add the new boolean argument to the prototype
of gfc_deallocate_alloc_comp_no_caf with a default of false.
Add prototype for gfc_copy_alloc_comp_del_ptrs.
* trans-decl.cc (gfc_get_symbol_decl): Make sure that temporary
variables from resolve.cc are not finalized by detection of a
leading '_' in the symbol name.
(init_intent_out_dt): Tidy up the code.
* trans-expr.cc (gfc_init_se): Initialize finalblock.
(finalize_function_result): New function that finalizes
function results in the correct order.
(gfc_conv_procedure_call): Use new function for finalizable
function results. Replace in-line block for class results with
call to new function.
(gfc_conv_expr): Finalize structure constructors for F2003 and
F2008. Warn that this feature was deleted in F2018 and, unlike
array constructors, is not default. Add array constructor
finalblock to the post block.
(gfc_trans_scalar_assign): Suppress finalization by setting new
argument in call to gfc_deallocate_alloc_comp_no_caf. Add the
finalization blocks to the main block.
(gfc_assignment_finalizer_call): New function to provide
finalization on intrinsic assignment.
(gfc_trans_arrayfunc_assign): Use the previous and ensure that
finalization occurs after the evaluation of the rhs but must
use the initial value for the lhs.
(trans_class_assignment, gfc_trans_assignment_1): Call it and
add the block between the rhs evaluation and any reallocation
on assignment that there might be.
* trans-io.cc (gfc_trans_transfer): Add the final block.
* trans-stmt.cc (gfc_trans_call, gfc_trans_allocate): likewise.
* trans.h: Add finalblock to gfc_se. Add the prototype for
gfc_finalize_function_result.

gcc/testsuite/
PR fortran/64290
* gfortran.dg/finalize_38.f90 : New test.
* gfortran.dg/allocate_with_source_25.f90 : The number of final
calls goes down from 6 to 4.
* gfortran.dg/unlimited_polymorphic_8.f90 : Tree dump reveals
foo.1.x rather than foo.0.x

PR fortran/67444
* gfortran.dg/finalize_39.f90 : New test.

PR fortran/67471
* gfortran.dg/finalize_40.f90 : New test.

PR fortran/69298
PR fortran/70863
* gfortran.dg/finalize_41.f90 : New test.

PR fortran/71798
* gfortran.dg/finalize_42.f90 : New test.

PR fortran/80524
* gfortran.dg/finalize_43.f90 : New test.

PR fortran/82996
* gfortran.dg/finalize_44.f90 : New test.

PR fortran/84472
* gfortran.dg/finalize_45.f90 : New test.

PR fortran/88735
PR fortran/93691
* gfortran.dg/finalize_46.f90 : New test.

PR fortran/91316
* gfortran.dg/finalize_47.f90 : New test.

PR fortran/106576
* gfortran.dg/finalize_48.f90 : New test.

PR fortran/91316
* gfortran.dg/finalize_47.f90 : New test.

[-- Attachment #2: submit020123.diff --]
[-- Type: text/x-patch, Size: 66762 bytes --]

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 731e9b0fe6a..baa5207d61b 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
    gfc_component *c;

   for (c = derived->components; c; c = c->next)
-    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+	&& c->attr.flavor != FL_PROCEDURE)
       {
 	if (c->ts.u.derived->f2k_derived
 	    && c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
     {
       /* Call FINAL_WRAPPER (comp);  */
       gfc_code *final_wrap;
-      gfc_symbol *vtab;
+      gfc_symbol *vtab, *byte_stride;
+      gfc_expr *scalar, *size_expr, *fini_coarray_expr;
       gfc_component *c;

       vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 	  break;

       gcc_assert (c);
+
+      /* Set scalar argument for storage_size.  */
+      gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+      byte_stride->ts = e->ts;
+      byte_stride->attr.flavor = FL_VARIABLE;
+      byte_stride->attr.value = 1;
+      byte_stride->attr.artificial = 1;
+      gfc_set_sym_referenced (byte_stride);
+      gfc_commit_symbol (byte_stride);
+      scalar = gfc_lval_expr_from_sym (byte_stride);
+
       final_wrap = gfc_get_code (EXEC_CALL);
       final_wrap->symtree = c->initializer->symtree;
       final_wrap->resolved_sym = c->initializer->symtree->n.sym;
       final_wrap->ext.actual = gfc_get_actual_arglist ();
       final_wrap->ext.actual->expr = e;

+      /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+      size_expr = gfc_get_expr ();
+      size_expr->where = gfc_current_locus;
+      size_expr->expr_type = EXPR_OP;
+      size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+      /* STORAGE_SIZE (array,kind=c_intptr_t).  */
+      size_expr->value.op.op1
+	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+				    "storage_size", gfc_current_locus, 2,
+				    scalar,
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL, 0));
+
+      /* NUMERIC_STORAGE_SIZE.  */
+      size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+						  gfc_character_storage_size);
+      size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+      size_expr->ts = size_expr->value.op.op1->ts;
+
+      /* Which provides the argument 'byte_stride'.....  */
+      final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->expr = size_expr;
+
+      /* ...and last of all the 'fini_coarray' argument.  */
+      fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+      final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
       if (*code)
 	{
 	  (*code)->next = final_wrap;
@@ -1430,8 +1474,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->next->resolved_sym = fini->proc_tree->n.sym;
   block->next->ext.actual = gfc_get_actual_arglist ();
   block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
-  block->next->ext.actual->next = gfc_get_actual_arglist ();
-  block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);

   /* ELSE.  */

@@ -2047,13 +2089,32 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       gfc_set_sym_referenced (ptr);
       gfc_commit_symbol (ptr);

+      fini = derived->f2k_derived->finalizers;
+
+      /* Assumed rank finalizers can be called directly. The call takes care
+	 of setting up the descriptor.  resolve_finalizers has already checked
+	 that this is the only finalizer for this kind/type (F2018: C790).  */
+      if (fini->proc_tree && fini->proc_tree->n.sym->formal->sym->as
+	  && fini->proc_tree->n.sym->formal->sym->as->type == AS_ASSUMED_RANK)
+	{
+	  last_code->next = gfc_get_code (EXEC_CALL);
+	  last_code->next->symtree = fini->proc_tree;
+	  last_code->next->resolved_sym = fini->proc_tree->n.sym;
+	  last_code->next->ext.actual = gfc_get_actual_arglist ();
+	  last_code->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+
+	  last_code = last_code->next;
+	  goto finish_assumed_rank;
+	}
+
       /* SELECT CASE (RANK (array)).  */
       last_code->next = gfc_get_code (EXEC_SELECT);
       last_code = last_code->next;
       last_code->expr1 = gfc_copy_expr (rank);
       block = NULL;

-      for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
+
+      for (; fini; fini = fini->next)
 	{
 	  gcc_assert (fini->proc_tree);   /* Should have been set in gfc_resolve_finalizers.  */
 	  if (fini->proc_tree->n.sym->attr.elemental)
@@ -2152,6 +2213,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	}
     }

+finish_assumed_rank:
+
   /* Finalize and deallocate allocatable components. The same manual
      scalarization is used as above.  */

@@ -2682,6 +2745,14 @@ yes:
 }


+bool
+gfc_may_be_finalized (gfc_typespec ts)
+{
+  return (ts.type == BT_CLASS || (ts.type == BT_DERIVED
+	  && ts.u.derived && gfc_is_finalizable (ts.u.derived, NULL)));
+}
+
+
 /* Find (or generate) the symbol for an intrinsic type's vtab.  This is
    needed to support unlimited polymorphism.  */

diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 5ae72dc1cac..629dd4eab93 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -628,7 +628,10 @@ show_expr (gfc_expr *p)
     case EXPR_VARIABLE:
       if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
 	fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
-      fprintf (dumpfile, "%s", p->symtree->n.sym->name);
+      if (p->must_finalize)
+	fprintf (dumpfile, "%s(must_finalize)", p->symtree->n.sym->name);
+      else
+	fprintf (dumpfile, "%s", p->symtree->n.sym->name);
       show_ref (p->ref);
       break;

@@ -3909,7 +3912,7 @@ write_proc (gfc_symbol *sym, bool bind_c)
       if (sym->formal)
 	fputs (", ", dumpfile);
     }
-
+
   for (f = sym->formal; f; f = f->next)
     {
       gfc_symbol *s;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 219ef8c7612..8e2b5e355f5 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3928,6 +3928,7 @@ gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, bool*,
 						     locus*);
 gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
 bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
+bool gfc_may_be_finalized (gfc_typespec);

 #define CLASS_DATA(sym) sym->ts.u.derived->components
 #define UNLIMITED_POLY(sym) \
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 0f5f1d277e4..0c0c329e04d 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10547,6 +10547,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
 	      if (e && !resolve_where_shape (cnext->expr1, e))
 	       gfc_error ("WHERE assignment target at %L has "
 			  "inconsistent shape", &cnext->expr1->where);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;


@@ -10634,6 +10638,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
 	    /* WHERE assignment statement */
 	    case EXEC_ASSIGN:
 	      gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;

 	    /* WHERE operator assignment statement */
@@ -10680,6 +10688,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
 	case EXEC_ASSIGN:
 	case EXEC_POINTER_ASSIGN:
 	  gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+	  if (c->op == EXEC_ASSIGN)
+	    c->expr1->must_finalize = 1;
+
 	  break;

 	case EXEC_ASSIGN_CALL:
@@ -11360,6 +11372,7 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
   tmp->n.sym->attr.use_assoc = 0;
   tmp->n.sym->attr.intent = INTENT_UNKNOWN;

+
   if (as)
     {
       tmp->n.sym->as = gfc_copy_array_spec (as);
@@ -11500,8 +11513,9 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 {
   gfc_component *comp1, *comp2;
   gfc_code *this_code = NULL, *head = NULL, *tail = NULL;
-  gfc_expr *t1;
+  gfc_expr *t1 = NULL;
   int error_count, depth;
+  bool finalizable_lhs = gfc_may_be_finalized ((*code)->expr1->ts);

   gfc_get_errors (NULL, &error_count);

@@ -11546,6 +11560,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
      to the final result already does this.  */
   if ((*code)->expr1->symtree->n.sym->name[2] != '@')
     {
+      if (finalizable_lhs)
+	(*code)->expr1->must_finalize = 1;
       this_code = build_assignment (EXEC_ASSIGN,
 				    (*code)->expr1, (*code)->expr2,
 				    NULL, NULL, (*code)->loc);
@@ -11555,10 +11571,10 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
   comp1 = (*code)->expr1->ts.u.derived->components;
   comp2 = (*code)->expr2->ts.u.derived->components;

-  t1 = NULL;
   for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
     {
       bool inout = false;
+      bool finalizable_out = false;

       /* The intrinsic assignment does the right thing for pointers
 	 of all kinds and allocatable components.  */
@@ -11602,8 +11618,12 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 	     a temporary must be generated and used instead.  */
 	  rsym = this_code->resolved_sym;
 	  dummy_args = gfc_sym_get_dummy_args (rsym);
-	  if (dummy_args
-	      && dummy_args->sym->attr.intent == INTENT_INOUT)
+	  finalizable_out = gfc_may_be_finalized (comp1->ts)
+			    && dummy_args
+			    && dummy_args->sym->attr.intent == INTENT_OUT;
+	  inout = dummy_args
+		  && dummy_args->sym->attr.intent == INTENT_INOUT;
+	  if (inout || finalizable_out)
 	    {
 	      gfc_code *temp_code;
 	      inout = true;
@@ -11675,19 +11695,25 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
 	{
 	  /* Don't add intrinsic assignments since they are already
 	     effected by the intrinsic assignment of the structure.  */
-	  gfc_free_statements (this_code);
-	  this_code = NULL;
-	  continue;
+	  if (gfc_may_be_finalized (this_code->expr1->ts))
+	    this_code->expr1->must_finalize = 1;
+	  else
+	    {
+	      gfc_free_statements (this_code);
+	      this_code = NULL;
+	      continue;
+	    }
 	}

       add_code_to_chain (&this_code, &head, &tail);

-      if (t1 && inout)
+      if (t1 && (inout || finalizable_out))
 	{
 	  /* Transfer the value to the final result.  */
 	  this_code = build_assignment (EXEC_ASSIGN,
 					(*code)->expr1, t1,
 					comp1, comp2, (*code)->loc);
+	  this_code->expr1->must_finalize = finalizable_out ? 0 : 1;
 	  add_code_to_chain (&this_code, &head, &tail);
 	}
     }
@@ -12146,7 +12172,12 @@ start:
 	      && code->expr1->ts.u.derived
 	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
 	    generate_component_assignments (&code, ns);
-
+	  else if (code->op == EXEC_ASSIGN)
+	    {
+	      code->expr1->must_finalize = 1;
+	      if (code->expr2->expr_type == EXPR_ARRAY)
+		code->expr2->must_finalize = 1;
+	    }
 	  break;

 	case EXEC_LABEL_ASSIGN:
@@ -13723,6 +13754,15 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
 	}
       arg = dummy_args->sym;

+      if (arg->as && arg->as->type == AS_ASSUMED_RANK
+	  && ((list != derived->f2k_derived->finalizers) || list->next))
+	{
+	  gfc_error ("FINAL procedure at %L with assumed rank argument must "
+		     "be the only finalizer with the same kind/type "
+		     "(F2018: C790)", &list->where);
+	  goto error;
+	}
+
       /* This argument must be of our type.  */
       if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
 	{
@@ -13823,7 +13863,8 @@ error:
   if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar)
     gfc_warning (OPT_Wsurprising,
 		 "Only array FINAL procedures declared for derived type %qs"
-		 " defined at %L, suggest also scalar one",
+		 " defined at %L, suggest also scalar one unless an assumed"
+		 " rank finalizer has been declared",
 		 derived->name, &derived->declared_at);

   vtab = gfc_find_derived_vtab (derived);
@@ -16326,6 +16367,15 @@ resolve_symbol (gfc_symbol *sym)

   if (sym->param_list)
     resolve_pdt (sym);
+
+  if (!sym->attr.referenced
+      && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
+    {
+      gfc_expr *final_expr = gfc_lval_expr_from_sym (sym);
+      if (gfc_is_finalizable (final_expr->ts.u.derived, NULL))
+	gfc_set_sym_referenced (sym);
+      gfc_free_expr (final_expr);
+    }
 }


diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b7d4c41b5fe..a221ed89837 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,37 @@ 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).
+     Unlike structure finalizers, array constructor finalization continues to
+     be permitted by other processors. It therefore has been retained for
+     -std=gnu.
+
+     Transmit finalization of this constructor through 'finalblock'. */
+  if ((!gfc_notification_std (GFC_STD_GNU)
+	&& !gfc_notification_std (GFC_STD_F2018)) && 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 array constructor at %C has been finalized. This"
+		      " feature was removed by f08/0011. Use -std=f2018 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 +2774,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 +2934,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 +2974,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 +3211,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 +6508,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 +6555,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 +6584,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 +6606,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;
     }
@@ -7532,7 +7587,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)
     {
@@ -8974,9 +9029,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;
@@ -9064,11 +9121,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);

@@ -9102,13 +9160,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);
     }

@@ -9170,7 +9230,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
 		{
@@ -9178,7 +9238,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);
 		}
 	    }

@@ -9294,8 +9355,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,
@@ -9323,7 +9384,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
 		{
@@ -9331,7 +9392,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);
 		}
 	    }

@@ -9629,7 +9691,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;
@@ -9665,14 +9728,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.  */
@@ -9714,6 +9777,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),
@@ -9760,6 +9830,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
@@ -9773,7 +9853,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;
@@ -10146,7 +10227,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);
 }


@@ -10159,7 +10241,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
@@ -10197,7 +10280,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;
 }

@@ -10207,10 +10291,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);
 }


@@ -10218,7 +10304,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);
 }


@@ -10234,6 +10321,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.  */

@@ -10973,7 +11074,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);
     }

@@ -11146,8 +11247,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
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index cd2b3d9f2f0..c71fa3f523c 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -56,11 +56,14 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
 			   tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+				       bool no_finalization = false);
 tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);

 tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);

+tree gfc_copy_alloc_comp_del_ptrs (gfc_symbol *, tree, tree, int, int);
+
 tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);

 tree gfc_allocate_pdt_comp (gfc_symbol *, tree, int, gfc_actual_arglist *);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 217de6b8da0..2aecada9efe 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1855,7 +1855,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	  && (sym->ts.u.derived->attr.alloc_comp
 	      || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
 		  && !sym->ns->proc_name->attr.is_main_program
-		  && gfc_is_finalizable (sym->ts.u.derived, NULL))))
+		  && (gfc_is_finalizable (sym->ts.u.derived, NULL)
+		      && sym->name[0] != '_'))))
       /* This applies a derived type default initializer.  */
       || (sym->ts.type == BT_DERIVED
 	  && sym->attr.save == SAVE_NONE
@@ -4329,6 +4330,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
   gfc_formal_arglist *f;
   tree tmp;
   tree present;
+  gfc_symbol *s;
+  bool dealloc_with_value = false;

   gfc_init_block (&init);
   for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
@@ -4336,42 +4339,50 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	&& !f->sym->attr.pointer
 	&& f->sym->ts.type == BT_DERIVED)
       {
+	s = f->sym;
 	tmp = NULL_TREE;

 	/* Note: Allocatables are excluded as they are already handled
 	   by the caller.  */
-	if (!f->sym->attr.allocatable
-	    && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
+	if (!s->attr.allocatable
+	    && gfc_is_finalizable (s->ts.u.derived, NULL))
 	  {
 	    stmtblock_t block;
 	    gfc_expr *e;

 	    gfc_init_block (&block);
-	    f->sym->attr.referenced = 1;
-	    e = gfc_lval_expr_from_sym (f->sym);
+	    s->attr.referenced = 1;
+	    e = gfc_lval_expr_from_sym (s);
 	    gfc_add_finalizer_call (&block, e);
 	    gfc_free_expr (e);
 	    tmp = gfc_finish_block (&block);
 	  }

-	if (tmp == NULL_TREE && !f->sym->attr.allocatable
-	    && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
-	  tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
-					   f->sym->backend_decl,
-					   f->sym->as ? f->sym->as->rank : 0);
+	if (tmp == NULL_TREE && !s->attr.allocatable
+	    && s->ts.u.derived->attr.alloc_comp)
+	  {
+	    tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
+					     s->backend_decl,
+					     s->as ? s->as->rank : 0);
+	    dealloc_with_value = s->value;
+	  }

-	if (tmp != NULL_TREE && (f->sym->attr.optional
-				 || f->sym->ns->proc_name->attr.entry_master))
+	if (tmp != NULL_TREE && (s->attr.optional
+				 || s->ns->proc_name->attr.entry_master))
 	  {
-	    present = gfc_conv_expr_present (f->sym);
+	    present = gfc_conv_expr_present (s);
 	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
 			      present, tmp, build_empty_stmt (input_location));
 	  }

-	if (tmp != NULL_TREE)
+	if (tmp != NULL_TREE && !dealloc_with_value)
 	  gfc_add_expr_to_block (&init, tmp);
-	else if (f->sym->value && !f->sym->attr.allocatable)
-	  gfc_init_default_dt (f->sym, &init, true);
+	else if (s->value && !s->attr.allocatable)
+	  {
+	    gfc_add_expr_to_block (&init, tmp);
+	    gfc_init_default_dt (s, &init, false);
+	    dealloc_with_value = false;
+	  }
       }
     else if (f->sym && f->sym->attr.intent == INTENT_OUT
 	     && f->sym->ts.type == BT_CLASS
@@ -4381,16 +4392,18 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	stmtblock_t block;
 	gfc_expr *e;

+	s = f->sym;
+
 	gfc_init_block (&block);
-	f->sym->attr.referenced = 1;
-	e = gfc_lval_expr_from_sym (f->sym);
+	s->attr.referenced = 1;
+	e = gfc_lval_expr_from_sym (s);
 	gfc_add_finalizer_call (&block, e);
 	gfc_free_expr (e);
 	tmp = gfc_finish_block (&block);

-	if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
+	if (s->attr.optional || s->ns->proc_name->attr.entry_master)
 	  {
-	    present = gfc_conv_expr_present (f->sym);
+	    present = gfc_conv_expr_present (s);
 	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
 			      present, tmp,
 			      build_empty_stmt (input_location));
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index b95c5cf2f96..f05e257bf76 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1910,6 +1910,7 @@ gfc_init_se (gfc_se * se, gfc_se * parent)
 {
   memset (se, 0, sizeof (gfc_se));
   gfc_init_block (&se->pre);
+  gfc_init_block (&se->finalblock);
   gfc_init_block (&se->post);

   se->parent = parent;
@@ -5987,6 +5988,136 @@ post_call:
 }


+/* Finalize a function result or array constructors using the finalizer wrapper.
+   The result is fixed in order to prevent repeated calls.  */
+
+void
+gfc_finalize_function_result (gfc_se *se, gfc_symbol *derived,
+			      symbol_attribute attr, int rank)
+{
+  tree vptr, final_fndecl, desc, tmp, size, is_final, data_ptr, cond;
+  gfc_symbol *vtab;
+  gfc_se post_se;
+  bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
+
+  if (attr.pointer)
+    return;
+
+  if (derived && (derived->attr.is_c_interop
+		  || derived->attr.is_iso_c
+		  || derived->attr.is_bind_c))
+    return;
+
+  if (is_class)
+    {
+      if (!VAR_P (se->expr))
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->pre);
+	  se->expr = desc;
+	}
+      desc = gfc_class_data_get (se->expr);
+      vptr = gfc_class_vptr_get (se->expr);
+    }
+  else if (derived && gfc_is_finalizable (derived, NULL))
+    {
+      /* Need to copy allocated components and delete pointer components.  */
+      if (se->direct_byref)
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->finalblock);
+	  tmp = gfc_copy_alloc_comp_del_ptrs (derived, se->expr, desc, rank, 0);
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+      else
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->pre);
+	  se->expr = gfc_evaluate_now (desc, &se->pre);
+	  tmp = gfc_copy_alloc_comp_del_ptrs (derived, se->expr, desc, rank, 0);
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+
+      vtab = gfc_find_derived_vtab (derived);
+      if (vtab->backend_decl == NULL_TREE)
+	vptr = gfc_get_symbol_decl (vtab);
+      else
+	vptr = vtab->backend_decl;
+      vptr = gfc_build_addr_expr (NULL, vptr);
+    }
+  else
+    return;
+
+  size = gfc_vptr_size_get (vptr);
+  final_fndecl = gfc_vptr_final_get (vptr);
+  is_final = fold_build2_loc (input_location, NE_EXPR,
+			      logical_type_node,
+			      final_fndecl,
+			      fold_convert (TREE_TYPE (final_fndecl),
+					    null_pointer_node));
+
+  final_fndecl = build_fold_indirect_ref_loc (input_location,
+					      final_fndecl);
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      if (is_class)
+	desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
+      else
+	{
+	  gfc_init_se (&post_se, NULL);
+	  desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
+	  gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
+	}
+    }
+
+  tmp = gfc_create_var (TREE_TYPE (desc), "res");
+  if (se->direct_byref)
+    gfc_add_modify (&se->finalblock, tmp, desc);
+  else
+    gfc_add_modify (&se->pre, tmp, desc);
+  desc = tmp;
+
+  data_ptr = gfc_conv_descriptor_data_get (desc);
+  cond = fold_build2_loc (input_location, NE_EXPR,
+			  logical_type_node, data_ptr,
+			  fold_convert (TREE_TYPE (data_ptr),
+					null_pointer_node));
+  is_final = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+			      logical_type_node, is_final, cond);
+  tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+			     gfc_build_addr_expr (NULL, desc),
+			     size, boolean_false_node);
+  tmp = fold_build3_loc (input_location, COND_EXPR,
+			 void_type_node, is_final, tmp,
+			 build_empty_stmt (input_location));
+
+  if (is_class && se->ss && se->ss->loop)
+    {
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+      cond = fold_build2_loc (input_location, NE_EXPR,
+			      logical_type_node,
+			      data_ptr,
+			      fold_convert (TREE_TYPE (data_ptr),
+					    null_pointer_node));
+      tmp = fold_build3_loc (input_location, COND_EXPR,
+			     void_type_node, cond,
+			     gfc_call_free (data_ptr),
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+    }
+  else
+    {
+      gfc_add_expr_to_block (&se->finalblock, tmp);
+
+      /* Let the scalarizer take care of freeing of temporary arrays.  */
+      if (attr.allocatable && !(se->loop && se->loop->temp_dim))
+	{
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 void_type_node, cond,
+				 gfc_call_free (data_ptr),
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+    }
+}
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -7067,6 +7198,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,

       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
+      gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);

       /* Allocated allocatable components of derived types must be
 	 deallocated for non-variable scalars, array arguments to elemental
@@ -7731,9 +7863,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   /* Allocatable scalar function results must be freed and nullified
      after use. This necessitates the creation of a temporary to
      hold the result to prevent duplicate calls.  */
+  symbol_attribute attr =  comp ? comp->attr : sym->attr;
+  bool allocatable = attr.allocatable && !attr.dimension;
+  gfc_symbol *der = comp && comp->ts.type == BT_DERIVED ? comp->ts.u.derived
+		    : (sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL);
+  bool finalizable = der != NULL && gfc_is_finalizable (der, NULL);
+
+  if (!byref && finalizable)
+    gfc_finalize_function_result (se, der, attr, expr->rank);
+
   if (!byref && sym->ts.type != BT_CHARACTER
-      && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
-	  || (comp && comp->attr.allocatable && !comp->attr.dimension)))
+      && allocatable && !finalizable)
     {
       tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
       gfc_add_modify (&se->pre, tmp, se->expr);
@@ -7793,6 +7933,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      se->expr = info->descriptor;
 	      /* Bundle in the string length.  */
 	      se->string_length = len;
+
+	      if (finalizable)
+		gfc_finalize_function_result (se, der, attr, expr->rank);
 	    }
 	  else if (ts.type == BT_CHARACTER)
 	    {
@@ -7885,8 +8028,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
 	  && expr->must_finalize)
 	{
-	  tree final_fndecl;
-	  tree is_final;
 	  int n;
 	  if (se->ss && se->ss->loop)
 	    {
@@ -7908,66 +8049,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      /* TODO Eliminate the doubling of temporaries. This
 		 one is necessary to ensure no memory leakage.  */
 	      se->expr = gfc_evaluate_now (se->expr, &se->pre);
-	      tmp = gfc_class_data_get (se->expr);
-	      tmp = gfc_conv_scalar_to_descriptor (se, tmp,
-			CLASS_DATA (expr->value.function.esym->result)->attr);
 	    }

-	  if ((gfc_is_class_array_function (expr)
-	       || gfc_is_alloc_class_scalar_function (expr))
-	      && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
-	    goto no_finalization;
-
-	  final_fndecl = gfc_class_vtab_final_get (se->expr);
-	  is_final = fold_build2_loc (input_location, NE_EXPR,
-				      logical_type_node,
-				      final_fndecl,
-				      fold_convert (TREE_TYPE (final_fndecl),
-					   	    null_pointer_node));
-	  final_fndecl = build_fold_indirect_ref_loc (input_location,
-						      final_fndecl);
- 	  tmp = build_call_expr_loc (input_location,
-				     final_fndecl, 3,
-				     gfc_build_addr_expr (NULL, tmp),
-				     gfc_class_vtab_size_get (se->expr),
-				     boolean_false_node);
-	  tmp = fold_build3_loc (input_location, COND_EXPR,
-				 void_type_node, is_final, tmp,
-				 build_empty_stmt (input_location));
-
-	  if (se->ss && se->ss->loop)
-	    {
-	      gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     info->data,
-				     fold_convert (TREE_TYPE (info->data),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (info->data),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->ss->loop->post, tmp);
-	    }
-	  else
-	    {
-	      tree classdata;
-	      gfc_prepend_expr_to_block (&se->post, tmp);
-	      classdata = gfc_class_data_get (se->expr);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     classdata,
-				     fold_convert (TREE_TYPE (classdata),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (classdata),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->post, tmp);
-	    }
+	  /* Finalize the result, if necessary.  */
+	  attr = CLASS_DATA (expr->value.function.esym->result)->attr;
+	  if (!((gfc_is_class_array_function (expr)
+		 || gfc_is_alloc_class_scalar_function (expr))
+		&& attr.pointer))
+	    gfc_finalize_function_result (se, NULL, attr, expr->rank);
 	}
-
-no_finalization:
       gfc_add_block_to_block (&se->post, &post);
     }

@@ -9479,10 +9569,29 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)

     case EXPR_STRUCTURE:
       gfc_conv_structure (se, expr, 0);
+      /* F2008 4.5.6.3 para 5: If an executable construct references a
+	 structure constructor or array constructor, the entity created by
+	 the constructor isfinalized 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).  */
+      if (!gfc_notification_std (GFC_STD_F2018_DEL) && expr->must_finalize
+	  && gfc_may_be_finalized (expr->ts))
+	{
+	  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.");
+	  symbol_attribute attr;
+	  attr.allocatable = attr.pointer = 0;
+	  gfc_finalize_function_result (se, expr->ts.u.derived, attr, 0);
+	  gfc_add_block_to_block (&se->post, &se->finalblock);
+	}
       break;

     case EXPR_ARRAY:
       gfc_conv_array_constructor_expr (se, expr);
+      gfc_add_block_to_block (&se->post, &se->finalblock);
       break;

     default:
@@ -10483,7 +10592,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       if (dealloc)
 	{
 	  tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
-	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+						  0, true);
 	  if (deep_copy)
 	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
 			    tmp);
@@ -10491,6 +10601,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 	}

       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
       gfc_add_block_to_block (&block, &lse->pre);

       gfc_add_modify (&block, lse->expr,
@@ -10520,8 +10631,9 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
     }
   else if (gfc_bt_struct (ts.type))
     {
-      gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);
+      gfc_add_block_to_block (&block, &lse->pre);
       tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
 			     TREE_TYPE (lse->expr), rse->expr);
       gfc_add_modify (&block, lse->expr, tmp);
@@ -10531,6 +10643,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->finalblock);

       if (!trans_scalar_class_assign (&block, lse, rse))
 	{
@@ -10849,6 +10962,118 @@ fcncall_realloc_result (gfc_se *se, int rank)
 }


+  /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+     (10.2.1.3), if the variable is not an unallocated allocatable variable,
+     it is finalized after evaluation of expr and before the definition of
+     the variable. If the variable is an allocated allocatable variable, or
+     has an allocated allocatable subobject, that would be deallocated by
+     intrinsic assignment, the finalization occurs before the deallocation */
+
+static bool
+gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag)
+{
+  symbol_attribute lhs_attr;
+  tree final_expr;
+  tree ptr;
+  tree cond;
+  gfc_se se;
+  gfc_symbol *sym = expr1->symtree->n.sym;
+  gfc_ref *ref = expr1->ref;
+  stmtblock_t final_block;
+  gfc_init_block (&final_block);
+  gfc_expr *finalize_expr;
+  bool class_array_ref;
+
+  /* We have to exclude vtable procedures (_copy and _final especially), uses
+     of gfc_trans_assignment_1 in initialization and allocation before trying
+     to build a final call.  */
+  if (!expr1->must_finalize
+      || sym->attr.artificial
+      || sym->ns->proc_name->attr.artificial
+      || init_flag)
+    return false;
+
+  class_array_ref = ref && ref->type == REF_COMPONENT
+		    && !strcmp (ref->u.c.component->name, "_data")
+		    && ref->next && ref->next->type == REF_ARRAY
+		    && !ref->next->next;
+
+  if (class_array_ref)
+    {
+      finalize_expr = gfc_lval_expr_from_sym (sym);
+      finalize_expr->must_finalize = 1;
+      ref = NULL;
+    }
+  else
+    finalize_expr = gfc_copy_expr (expr1);
+
+  /* F2018 7.5.6.2: Only finalizable entities are finalized.  */
+  if (!(expr1->ts.type == BT_DERIVED
+	&& gfc_is_finalizable (expr1->ts.u.derived, NULL))
+      && expr1->ts.type != BT_CLASS)
+      return false;
+
+  if (!gfc_may_be_finalized (sym->ts))
+    return false;
+
+  gfc_init_block (&final_block);
+  bool finalizable = gfc_add_finalizer_call (&final_block, finalize_expr);
+  gfc_free_expr (finalize_expr);
+
+  if (!finalizable)
+    return false;
+
+  lhs_attr = gfc_expr_attr (expr1);
+
+  /* Check allocatable/pointer is allocated/associated.  */
+  if (lhs_attr.allocatable || lhs_attr.pointer)
+    {
+      if (expr1->ts.type == BT_CLASS)
+	{
+	  ptr = gfc_get_class_from_gfc_expr (expr1);
+	  gcc_assert (ptr != NULL_TREE);
+	  ptr = gfc_class_data_get (ptr);
+	  if (lhs_attr.dimension)
+	    ptr = gfc_conv_descriptor_data_get (ptr);
+	}
+      else
+	{
+	  gfc_init_se (&se, NULL);
+	  if (expr1->rank)
+	    {
+	      gfc_conv_expr_descriptor (&se, expr1);
+	      ptr = gfc_conv_descriptor_data_get (se.expr);
+	    }
+	  else
+	    {
+	      gfc_conv_expr (&se, expr1);
+	      ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
+	    }
+	}
+
+      cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			      ptr, build_zero_cst (TREE_TYPE (ptr)));
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, gfc_finish_block (&final_block),
+			       build_empty_stmt (input_location));
+    }
+  else
+    final_expr = gfc_finish_block (&final_block);
+
+  /* Check optional present.  */
+  if (sym->attr.optional)
+    {
+      cond = gfc_conv_expr_present (sym);
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, final_expr,
+			       build_empty_stmt (input_location));
+    }
+
+  gfc_add_expr_to_block (&lse->finalblock, final_expr);
+
+  return true;
+}
+

 /* Try to translate array(:) = func (...), where func is a transformational
    array function, without using a temporary.  Returns NULL if this isn't the
@@ -10861,6 +11086,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_ss *ss = NULL;
   gfc_component *comp = NULL;
   gfc_loopinfo loop;
+  tree tmp;
+  tree lhs;
+  gfc_se final_se;
+  gfc_symbol *sym = expr1->symtree->n.sym;
+  bool finalizable =  gfc_may_be_finalized (expr1->ts);

   if (arrayfunc_assign_needs_temporary (expr1, expr2))
     return NULL;
@@ -10879,12 +11109,44 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_start_block (&se.pre);
   se.want_pointer = 1;

+  /* First the lhs must be finalized, if necessary. We use a copy of the symbol
+     backend decl, stash the original away for the finalization so that the
+     value used is that before the assignment. This is necessary because
+     evaluation of the rhs expression using direct by reference can change
+     the value. However, the standard mandates that the finalization must occur
+     after evaluation of the rhs.  */
+  gfc_init_se (&final_se, NULL);
+
+  if (finalizable)
+    {
+      tmp = sym->backend_decl;
+      lhs = sym->backend_decl;
+      if (TREE_CODE (tmp) == INDIRECT_REF)
+	tmp = TREE_OPERAND (tmp, 0);
+      sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
+      gfc_add_modify (&se.pre, sym->backend_decl, tmp);
+      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
+				     expr1->rank, 0);
+	  gfc_add_expr_to_block (&final_se.pre, tmp);
+	}
+    }
+
+  if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
+    {
+      gfc_add_block_to_block (&se.pre, &final_se.pre);
+      gfc_add_block_to_block (&se.post, &final_se.finalblock);
+    }
+
+  if (finalizable)
+    sym->backend_decl = lhs;
+
   gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);

   if (expr1->ts.type == BT_DERIVED
 	&& expr1->ts.u.derived->attr.alloc_comp)
     {
-      tree tmp;
       tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
 					      expr1->rank);
       gfc_add_expr_to_block (&se.pre, tmp);
@@ -10894,6 +11156,18 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   se.ss = gfc_walk_expr (expr2);
   gcc_assert (se.ss != gfc_ss_terminator);

+  /* Since this is a direct by reference call, references to the lhs can be
+     used for finalization of the function result just as long as the blocks
+     from final_se are added at the right time.  */
+  gfc_init_se (&final_se, NULL);
+  if (finalizable && expr2->value.function.esym)
+    {
+      final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
+      gfc_finalize_function_result (&final_se, expr2->ts.u.derived,
+				    expr2->value.function.esym->attr,
+				    expr2->rank);
+    }
+
   /* Reallocate on assignment needs the loopinfo for extrinsic functions.
      This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
      Clearly, this cannot be done for an allocatable function result, since
@@ -10924,7 +11198,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
     }

   gfc_conv_function_expr (&se, expr2);
+
+  /* Fix the result.  */
   gfc_add_block_to_block (&se.pre, &se.post);
+  if (finalizable)
+    gfc_add_block_to_block (&se.pre, &final_se.pre);
+
+  /* Do the finalization, including final calls from function arguments.  */
+  if (finalizable)
+    {
+      gfc_add_block_to_block (&se.pre, &final_se.post);
+      gfc_add_block_to_block (&se.pre, &se.finalblock);
+      gfc_add_block_to_block (&se.pre, &final_se.finalblock);
+   }

   if (ss)
     gfc_cleanup_loop (&loop);
@@ -11447,6 +11733,17 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 {
   tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
   vec<tree, va_gc> *args = NULL;
+  bool final_expr;
+
+  final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
+  if (final_expr)
+    {
+      if (rse->loop)
+	gfc_prepend_expr_to_block (&rse->loop->pre,
+				   gfc_finish_block (&lse->finalblock));
+      else
+	gfc_add_block_to_block (block, &lse->finalblock);
+    }

   /* Store the old vptr so that dynamic types can be compared for
      reallocation to occur or not.  */
@@ -11472,8 +11769,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 	old_vptr = build_int_cst (TREE_TYPE (vptr), 0);

       size = gfc_vptr_size_get (vptr);
-      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
-	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      tmp = lse->expr;
+      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+	  ? gfc_class_data_get (tmp) : tmp;

       if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
 	class_han = gfc_build_addr_expr (NULL_TREE, class_han);
@@ -11575,6 +11873,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
     }
 }

+
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
    init_flag indicates initialization expressions and dealloc that no
@@ -11598,6 +11897,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   tree tmp;
   stmtblock_t block;
   stmtblock_t body;
+  bool final_expr;
   bool l_is_temp;
   bool scalar_to_array;
   tree string_length;
@@ -11634,10 +11934,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  || gfc_is_alloc_class_scalar_function (expr2)))
     expr2->must_finalize = 1;

+  if (expr2->ts.type == BT_DERIVED && expr2->expr_type == EXPR_STRUCTURE)
+    expr2->must_finalize = 1;
+
   /* Checking whether a class assignment is desired is quite complicated and
      needed at two locations, so do it once only before the information is
      needed.  */
   lhs_attr = gfc_expr_attr (expr1);
+
   is_poly_assign = (use_vptr_copy || lhs_attr.pointer
 		    || (lhs_attr.allocatable && !lhs_attr.dimension))
 		   && (expr1->ts.type == BT_CLASS
@@ -11911,6 +12215,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  else
 	    gfc_add_expr_to_block (&loop.post, tmp2);
 	}
+
+      expr1->must_finalize = 0;
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB
 	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -11956,6 +12262,27 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	}
     }

+  /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+     after evaluation of the rhs and before reallocation.  */
+  final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
+  if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
+		      && expr2->symtree->n.sym->attr.artificial))
+    {
+      if (lss == gfc_ss_terminator)
+	{
+	  gfc_add_block_to_block (&block, &rse.pre);
+	  gfc_add_block_to_block (&block, &lse.finalblock);
+	}
+      else
+	{
+	  gfc_add_block_to_block (&body, &rse.pre);
+	  gfc_add_block_to_block (&loop.code[expr1->rank - 1],
+				  &lse.finalblock);
+	}
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.pre);
+
   /* If nothing else works, do it the old fashioned way!  */
   if (tmp == NULL_TREE)
     tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
@@ -11965,12 +12292,20 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 				   !(l_is_temp || init_flag) && dealloc,
 				   expr1->symtree->n.sym->attr.codimension);

-  /* Add the pre blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.pre);
+
+  /* Add the lse pre block to the body  */
   gfc_add_block_to_block (&body, &lse.pre);
   gfc_add_expr_to_block (&body, tmp);
+
   /* Add the post blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.post);
+  if (!l_is_temp)
+    {
+      gfc_add_block_to_block (&rse.finalblock, &rse.post);
+      gfc_add_block_to_block (&body, &rse.finalblock);
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.post);
+
   gfc_add_block_to_block (&body, &lse.post);

   if (lss == gfc_ss_terminator)
@@ -11994,6 +12329,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  gfc_trans_scalarized_loop_boundary (&loop, &body);

 	  /* We need to copy the temporary to the actual lhs.  */
+//	  gfc_add_block_to_block (&loop.post, &rse.finalblock);
 	  gfc_init_se (&lse, NULL);
 	  gfc_init_se (&rse, NULL);
 	  gfc_copy_loopinfo_to_se (&lse, &loop);
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 9f86815388c..5edf1fe1b51 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2690,6 +2690,7 @@ scalarize:

   gfc_add_block_to_block (&body, &se.pre);
   gfc_add_block_to_block (&body, &se.post);
+  gfc_add_block_to_block (&body, &se.finalblock);

   if (se.ss == NULL)
     tmp = gfc_finish_block (&body);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index b288f1f9050..51261690744 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -444,7 +444,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       else
 	gfc_add_expr_to_block (&se.pre, se.expr);

-      gfc_add_block_to_block (&se.pre, &se.post);
+      gfc_add_block_to_block (&se.finalblock, &se.post);
+      gfc_add_block_to_block (&se.pre, &se.finalblock);
     }

   else
@@ -543,6 +544,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       gfc_trans_scalarizing_loops (&loop, &body);
       gfc_add_block_to_block (&se.pre, &loop.pre);
       gfc_add_block_to_block (&se.pre, &loop.post);
+      gfc_add_block_to_block (&se.pre, &loopse.finalblock);
       gfc_add_block_to_block (&se.pre, &se.post);
       gfc_cleanup_loop (&loop);
     }
@@ -6347,7 +6349,10 @@ gfc_trans_allocate (gfc_code * code)
 	}
       gfc_add_block_to_block (&block, &se.pre);
       if (code->expr3->must_finalize)
-	gfc_add_block_to_block (&final_block, &se.post);
+	{
+	  gfc_add_block_to_block (&final_block, &se.finalblock);
+	  gfc_add_block_to_block (&final_block, &se.post);
+	}
       else
 	gfc_add_block_to_block (&post, &se.post);

@@ -7007,8 +7012,13 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_expr *init_expr = gfc_expr_to_initialize (expr);
 	  gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
 	  flag_realloc_lhs = 0;
+
+	  /* Set the symbol to be artificial so that the result is not finalized.  */
+	  init_expr->symtree->n.sym->attr.artificial = 1;
 	  tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
 				      false);
+	  init_expr->symtree->n.sym->attr.artificial = 0;
+
 	  flag_realloc_lhs = realloc_lhs;
 	  /* Free the expression allocated for init_expr.  */
 	  gfc_free_expr (init_expr);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index bc9035c1717..b404da49878 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -43,6 +43,10 @@ typedef struct gfc_se
   stmtblock_t pre;
   stmtblock_t post;

+  /* Carries finalization code that is required to be executed execution of the
+     innermost executable construct.  */
+  stmtblock_t finalblock;
+
   /* the result of the expression */
   tree expr;

@@ -55,7 +59,7 @@ typedef struct gfc_se

   /* Whether expr is a reference to an unlimited polymorphic object.  */
   unsigned unlimited_polymorphic:1;
-
+
   /* If set gfc_conv_variable will return an expression for the array
      descriptor. When set, want_pointer should also be set.
      If not set scalarizing variables will be substituted.  */
@@ -551,6 +555,9 @@ void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool,
 				gfc_symbol *sym = NULL,
 				bool check_contiguous = false);

+void gfc_finalize_function_result (gfc_se *, gfc_symbol *,
+				  symbol_attribute, int);
+
 void gfc_conv_is_contiguous_expr (gfc_se *, gfc_expr *);

 /* Generate code for a scalar assignment.  */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
index 92dc50756d4..de20a147842 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
@@ -68,4 +68,4 @@ contains
   end function func_foo_a

 end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90
index 46b9a9f6518..7b27ddb2e3b 100644
--- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90
@@ -15,5 +15,5 @@ contains
   end
 end

-! { dg-final { scan-tree-dump-times "foo.0.x._data = 0B;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "foo.0.x._vptr = .* &__vtab__STAR;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo.1.x._data = 0B;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo.1.x._vptr = .* &__vtab__STAR;" 1 "original" } }

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

! { dg-do run }
!
! Test the fix for PR67444 in which the finalization of a polymorphic 'var'
! was not being finalized before assignment. (STOP 3)
!
! Contributed by Balint Aradi  <baladi@gmail.com>
!
module classes
  implicit none
  integer :: ivalue = 0
  integer :: icall = 0
  integer :: fvalue = 0

  type :: Basic
    integer :: ii = -1
  contains
    procedure :: assignBasic
    generic :: assignment(=) => assignBasic
    final :: destructBasic
  end type Basic
  interface Basic
    module procedure initBasic
  end interface Basic
contains
  function initBasic(initValue) result(this)
    integer, intent(in) :: initValue
    type(Basic) :: this
    this%ii = initValue
    icall = icall + 1
  end function initBasic
  subroutine assignBasic(this, other)
    class(Basic), intent(out) :: this
    type(Basic), intent(in) :: other
    this%ii = other%ii + 1
    icall = other%ii
  end subroutine assignBasic
  subroutine destructBasic(this)
    type(Basic), intent(inout) :: this
    fvalue = fvalue + 1
    select case (fvalue)
    case (1)
        if (this%ii /= -1) stop 1          ! First finalization before assignment to 'var'
        if (icall /= 1) stop 2             ! and before evaluation of 'expr'.
    case(2)
        if (this%ii /= ivalue) stop 3      ! Finalization of intent(out) in 'assignBasic'
        if (icall /= 42) stop 4            ! and after evaluation of 'expr'.
    case(3)
        if (this%ii /= ivalue + 1) stop 5  ! Finalization of 'expr' (function!) after assignment.
    case default
        stop 6                             ! Too many or no finalizations
    end select
  end subroutine destructBasic
end module classes

module usage
  use classes
  implicit none
contains
  subroutine useBasic()
    type(Basic) :: bas
    ivalue = 42
    bas = Basic(ivalue)
  end subroutine useBasic
end module usage

program test
  use usage
  implicit none
  call useBasic()
  if (fvalue /= 3) stop 7                  ! 3 finalizations mandated.
end program test

[-- Attachment #4: finalize_42.f90 --]
[-- Type: text/x-fortran, Size: 1242 bytes --]

! { dg-do run }
!
! Test the fix for PR71798 in which the result of 'create_mytype'
! was not being finalized after the completion of the assignment
! statement.
!
! Contributed by Jonathan Hogg  <jhogg41@gmail.com>
!
module mymod
   implicit none

   integer :: next = 0

   type :: mytype
      integer :: idx = -1
   contains
      procedure :: mytype_assign
      generic :: assignment(=) => mytype_assign
      final :: mytype_final
   end type mytype

contains
   subroutine mytype_assign(this, other)
      class(mytype), intent(inout) :: this
      class(mytype), intent(in) :: other

      this%idx = next
      next = next + 1
   end subroutine mytype_assign

   subroutine mytype_final(this)
      type(mytype) :: this
      next = next + 1
      if (this%idx /= 0) stop 1 ! finalize 'create_mtype' result
   end subroutine mytype_final

   type(mytype) function create_mytype()
      create_mytype%idx = next
      next = next + 1
   end function create_mytype

end module mymod

program test
   use mymod
   implicit none

   type(mytype) :: x

   x = create_mytype()
   if (x%idx /= 1) stop 2       ! Defined assignment failed
   if (next /= 3) stop 3        ! Used to give 2 because finalization did not occur
end program test

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

! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
! 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)]  ! { 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
        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 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 self = initialization = simple(22).
! (with -std=f2003/8: followed by one with for the structure constructor)
  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(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
! with -std=f2003/8, the structure constructor with value simle(4)).
  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)] ! { dg-warning "has been finalized" }
! The first final call should finalize MyClassArray and the second should return
! the value of the array constructor.
! NAGFOR does something strange here: makes a scalar final call with value
! simple(5).
  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)
end program test_final

[-- Attachment #6: finalize_41.f90 --]
[-- Type: text/x-fortran, Size: 3934 bytes --]

! { dg-do run }
!
! Test that PR69298 is fixed. Used to segfault on finalization in
! subroutine 'in_type'.
!
! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
!
module stuff_mod
  implicit none
  private
  public :: stuff_type, final_calls
  type stuff_type
    private
    integer :: junk
  contains
    procedure get_junk
    procedure stuff_copy_initialiser
    generic :: assignment(=) => stuff_copy_initialiser
    final :: stuff_scalar_finaliser, &
             stuff_1d_finaliser
  end type stuff_type
  integer :: final_calls = 0
  interface stuff_type
    procedure stuff_initialiser
  end interface stuff_type
contains

  function stuff_initialiser( junk ) result(new_stuff)
    implicit none
    type(stuff_type) :: new_stuff
    integer :: junk
    new_stuff%junk = junk
  end function stuff_initialiser

  subroutine stuff_copy_initialiser( destination, source )
    implicit none
    class(stuff_type), intent(out) :: destination
    class(stuff_type), intent(in)  :: source
    destination%junk = source%junk
  end subroutine stuff_copy_initialiser

  subroutine stuff_scalar_finaliser( this )
    implicit none
    type(stuff_type), intent(inout) :: this
    final_calls = final_calls + 1
  end subroutine stuff_scalar_finaliser

  subroutine stuff_1d_finaliser( this )
    implicit none
    type(stuff_type), intent(inout) :: this(:)
    integer :: i
    final_calls = final_calls + 100
  end subroutine stuff_1d_finaliser

  function get_junk( this ) result(junk)
    implicit none
    class(stuff_type), intent(in) :: this
    integer :: junk
    junk = this%junk
  end function get_junk
end module stuff_mod

module test_mod
  use stuff_mod, only : stuff_type, final_calls
  implicit none
  private
  public :: test_type
  type test_type
    private
    type(stuff_type) :: thing
    type(stuff_type) :: things(3)
  contains
    procedure get_value
  end type test_type
  interface test_type
    procedure test_type_initialiser
  end interface test_type
contains

  function test_type_initialiser() result(new_test)
    implicit none
    type(test_type) :: new_test
    integer :: i ! At entry: 1 array and 9 scalars
    new_test%thing = stuff_type( 4 ) ! Gives 2 scalar calls
    do i = 1, 3
      new_test%things(i) = stuff_type( i )  ! Gives 6 scalar calls
    end do
  end function test_type_initialiser

  function get_value( this ) result(value)
    implicit none
    class(test_type) :: this
    integer :: value
    integer :: i
    value = this%thing%get_junk()
    do i = 1, 3
      value = value + this%things(i)%get_junk()
    end do
  end function get_value
end module test_mod

program test
  use stuff_mod, only : stuff_type, final_calls
  use test_mod,  only : test_type
  implicit none
  call here()
! One array call and 1 scalar call after leaving scope => 1 + 9 total; NAGFOR and IFORT agree
  if (final_calls .ne. 109) stop 1
  call in_type()
! 22 calls to scalar finalizer and 5 to the vector version; NAGFOR agrees
! IFORT also produces 21 scalar calls but only 4 vector calls.
  if (final_calls .ne. 521) print *, final_calls
contains

  subroutine here()
    implicit none
    type(stuff_type) :: thing
    type(stuff_type) :: bits(3)
    integer :: i
    integer :: tally
    thing = stuff_type(4) ! Two scalar final calls; INTENT(OUT) and initialiser
    do i = 1, 3
      bits(i) = stuff_type(i) ! ditto times 3
    end do
    tally = thing%get_junk()
    do i = 1, 3
      tally = tally + bits(i)%get_junk()
    end do
    if (tally .ne. 10) stop 3 ! 8 scalar final calls by here
  end subroutine here

  subroutine in_type()
    implicit none
    type(test_type) :: thing
    thing = test_type() ! 8 scalar in test_type + 1 vector and 1 scalar to finalize function result and
                        ! 2 vectors and 2 scalars from the expansion of the defined assignment.
    if (thing%get_value() .ne. 10) print *, thing%get_value()
  end subroutine in_type
end program test

[-- Attachment #7: finalize_40.f90 --]
[-- Type: text/x-fortran, Size: 1063 bytes --]

! { dg-do run }
!
! Test that PR67471 is fixed. Used not to call the finalizer.
!
! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
!
module test_final_mod
  implicit none
  type :: my_final
    integer :: n = 1
  contains
    final :: destroy_scalar, destroy_rank1_array
  end type my_final
  integer :: final_calls = 0
contains
  subroutine destroy_rank1_array(self)
    type(my_final), intent(inout) :: self(:)
    if (size(self) /= 0) then
      if (size(self) /= 2) stop 1
      if (any (self%n /= [3,4])) stop 2
    else
      stop 3
    end if
    final_calls = final_calls + 1
  end subroutine destroy_rank1_array

! Eliminate the warning about the lack of a scalar finalizer.
  subroutine destroy_scalar(self)
    type(my_final), intent(inout) :: self
    final_calls = final_calls + self%n
  end subroutine destroy_scalar

end module test_final_mod

program test_finalizer
  use test_final_mod
  implicit none
  type(my_final) :: b(4), c(2)

  b%n = [2, 3, 4, 5]
  c%n = [6, 7]
  b(2:3) = c
  if (final_calls /= 1) stop 4
end program test_finalizer

[-- Attachment #8: finalize_43.f90 --]
[-- Type: text/x-fortran, Size: 1117 bytes --]

! { dg-do run }
!
! Test the fix for PR80524, where gfortran on issued one final call
! For 'u' going out of scope. Two further call should be emitted; one
! for the lhs of the assignment in 's' and the other for the function
! result, which occurs after assignment.
!
! Contributed by Andrew Wood  <andrew@fluidgravity.co.uk>
!
MODULE m1
   IMPLICIT NONE
   integer :: counter = 0
   integer :: fval = 0
   TYPE t
      INTEGER :: i
      CONTAINS
         FINAL :: t_final
   END TYPE t
   CONTAINS
      SUBROUTINE t_final(this)
         TYPE(t) :: this
         counter = counter + 1
      END SUBROUTINE
      FUNCTION new_t()
         TYPE(t) :: new_t
         new_t%i = 1
         fval = new_t%i
         if (counter /= 0) stop 1   ! Finalization of 'var' after evaluation of 'expr'
      END FUNCTION new_t
      SUBROUTINE s
         TYPE(t) :: u
         u = new_t()
         if (counter /= 2) stop 2   ! Finalization of 'var' and 'expr'
      END SUBROUTINE s
END MODULE m1
PROGRAM prog
   USE m1
   IMPLICIT NONE
   CALL s
   if (counter /= 3) stop 3         ! Finalization of 'u' in 's'
END PROGRAM prog

[-- Attachment #9: finalize_44.f90 --]
[-- Type: text/x-fortran, Size: 2916 bytes --]

! { dg-do run }
!
! Test the fix for all three variants of PR82996, which used to
! segfault in the original testcase and ICE in the testcases of
! comments 1 and 2.
!
! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
!
module mod0
  integer :: final_count_foo = 0
  integer :: final_count_bar = 0
end module mod0
!
! This is the original testcase, with a final routine 'foo' but
! but not in the container type 'bar1'.
!
module mod1
  use mod0
  private foo, foo_destroy
  type foo
    integer, pointer :: f(:) => null()
  contains
    final :: foo_destroy
  end type
  type bar1
    type(foo) :: b(2)
  end type
contains
  impure elemental subroutine foo_destroy(this)
    type(foo), intent(inout) :: this
    final_count_foo = final_count_foo + 1
    if (associated(this%f)) deallocate(this%f)
  end subroutine
end module mod1
!
! Comment 1 was the same as original, except that the
! 'foo' finalizer is elemental and a 'bar' finalizer is added..
!
module mod2
  use mod0
  private foo, foo_destroy, bar_destroy
  type foo
    integer, pointer :: f(:) => null()
  contains
    final :: foo_destroy
  end type
  type bar2
    type(foo) :: b(2)
  contains
    final :: bar_destroy
  end type
contains
  impure elemental subroutine foo_destroy(this)
    type(foo), intent(inout) :: this
    final_count_foo = final_count_foo + 1
    if (associated(this%f)) deallocate(this%f)
  end subroutine
  subroutine bar_destroy(this)
    type(bar2), intent(inout) :: this
    final_count_bar = final_count_bar + 1
    call foo_destroy(this%b)
  end subroutine
end module mod2
!
! Comment 2 was the same as comment 1, except that the 'foo'
! finalizer is no longer elemental.
!
module mod3
  use mod0
  private foo, foo_destroy, bar_destroy
  type foo
    integer, pointer :: f(:) => null()
  contains
    final :: foo_destroy
  end type
  type bar3
    type(foo) :: b(2)
  contains
    final :: bar_destroy
  end type
contains
  subroutine foo_destroy(this)
    type(foo), intent(inout) :: this
    final_count_foo = final_count_foo + 1
    if (associated(this%f)) deallocate(this%f)
  end subroutine
  subroutine bar_destroy(this)
    type(bar3), intent(inout) :: this
    final_count_bar = final_count_bar + 1
    do j = 1, size(this%b)
      call foo_destroy(this%b(j))
    end do
  end subroutine
end module mod3

program main
  use mod0
  use mod1
  use mod2
  use mod3
  type(bar1) :: x
  type(bar2) :: y
  type(bar3) :: z
  call sub1(x)
  if (final_count_foo /= 2) stop 1
  if (final_count_bar /= 0) stop 2
  call sub2(y)
  if (final_count_foo /= 6) stop 3
  if (final_count_bar /= 1) stop 4
  call sub3(z)
  if (final_count_foo /= 8) stop 5
  if (final_count_bar /= 2) stop 6
contains
  subroutine sub1(x)
    type(bar1), intent(out) :: x
  end subroutine
  subroutine sub2(x)
    type(bar2), intent(out) :: x
  end subroutine
  subroutine sub3(x)
    type(bar3), intent(out) :: x
  end subroutine
end program

[-- Attachment #10: finalize_46.f90 --]
[-- Type: text/x-fortran, Size: 3249 bytes --]

! { dg-do run }
!
! Test the fix for pr88735.
!
! Contributed by Martin Stein  <mscfd@gmx.net>
!
! NOTE: Is incorrectly finalizing 'var' in a defined assignment (IMHO) to comply with
! behaviour of another brand. Will consult with vendor to come to an agreement as to
! the correct interpretation.
! F2018 7.5.6.3 paragraph 1 is explicit that it is only 'var' in intrinsic assignments
! that are finalized. The only finalization that occurs in the two assignments, a=b,
! is to the INTENT(OUT) dummy in 'set'.

module mod
  implicit none
  type, public :: t
     integer, pointer :: i => NULL ()
     character :: myname = 'z'
     character :: alloc = 'n'
  contains
     procedure, public :: set
     generic, public :: assignment(=) => set
     final :: finalise
  end type t
  integer, public :: assoc_in_final = 0
  integer, public :: calls_to_final = 0
  character, public :: myname1, myname2

contains

  subroutine set(self, x)
     class(t), intent(out) :: self
     class(t), intent(in)  :: x
     if (associated(self%i)) then
        stop 1                               ! Default init for INTENT(OUT)
     endif
     if (associated(x%i)) then
        myname2 = self%myname
        self%i => x%i
        self%i = self%i + 1
     end if
end subroutine set

  subroutine finalise(self)
     type(t), intent(inout) :: self
     calls_to_final = calls_to_final + 1
     myname1 = self%myname
     if (associated(self%i)) then
        assoc_in_final = assoc_in_final + 1
        if (self%alloc .eq. 'y') deallocate (self%i)
     end if
  end subroutine finalise

end module mod

program finalise_assign
  use mod
  implicit none
  type :: s
     integer :: i = 0
     type(t) :: x
  end type s
  type(s) :: a, b
  type(t) :: c
  a%x%myname = 'a'
  b%x%myname = 'b'
  c%myname = 'c'
  allocate (a%x%i)
  a%x%i = 123
  a%x%alloc = 'y'

  b = a
  if (assoc_in_final /= 0) stop 2  ! b%x%i not associated before finalization
  if (calls_to_final /= 2) stop 3  ! Two finalization calls (Should be one?)
  if (myname1 .ne. 'b') stop 4     ! Finalization before intent out become undefined
  if (myname2 .ne. 'z') stop 5     ! Intent out now default initialized
  if (.not.associated (b%x%i, a%x%i)) stop 6

  allocate (c%i, source = 789)
  c%alloc = 'y'
  c = a%x
  if (assoc_in_final /= 1) stop 6  ! c%i is allocated prior to the assignment
  if (calls_to_final /= 3) stop 7  ! One finalization call for the assignment
  if (myname1 .ne. 'c') stop 8     ! Finalization before intent out become undefined
  if (myname2 .ne. 'z') stop 9     ! Intent out now default initialized

  b = a
  if (assoc_in_final /= 3) stop 10 ! b%i is associated by earlier assignment
  if (calls_to_final /= 5) stop 11 ! Two finalization calls for the assignment (Should be one?)
  if (myname1 .ne. 'z') stop 12    ! b%x%myname was default initialized in earlier assignment
  if (myname2 .ne. 'z') stop 13    ! Intent out now default initialized
  if (b%x%i .ne. 126) stop 14      ! Three assignments with self%x%i pointing to same target
  deallocate (a%x%i)
  if (.not.associated (b%x%i, c%i)) then
    stop 15                        ! ditto
    b%x%i =>NULL ()                ! Although not needed here, clean up
    c%i => NULL ()
  endif
end program finalise_assign

[-- Attachment #11: finalize_47.f90 --]
[-- Type: text/x-fortran, Size: 2632 bytes --]

! { dg-do run }
!
! Check that PR91316 is fixed. Note removal of recursive I/O.
!
! Contributed by Jose Rui Faustino de Sousa  <jrfsousa@gcc.gnu.org>
!
! NAGFOR complains correctly about the finalization of an INTENT(OUT) dummy
! with an impure finalization subroutine, within a pure procedure.
! It also complains about the finalization of final_set, which does not seem
! to be correct (see finalize_50.f90).
! Both procedures have been made impure so that this testcase runs with both
! compilers.
!
module final_m
  implicit none
  private
  public ::        &
    assignment(=)

  public :: &
    final_t

  public ::     &
    final_init, &
    final_set,  &
    final_get,  &
    final_end

  type :: final_t
    private
    integer :: n = -1
  contains
    final :: final_end
  end type final_t

  interface assignment(=)
    module procedure final_init
  end interface assignment(=)

  integer, public :: final_ctr = 0
  integer, public :: final_res = 0

contains

  impure elemental subroutine final_init(this, n)
    type(final_t), intent(out) :: this
    integer,       intent(in)  :: n
    this%n = n
  end subroutine final_init

  impure elemental function final_set(n) result(this)
    integer, intent(in) :: n
    type(final_t) :: this
    this%n = n
  end function final_set

  elemental function final_get(this) result(n)
    type(final_t), intent(in) :: this
    integer :: n
    n = this%n
  end function final_get

  subroutine final_end(this)
    type(final_t), intent(inout) :: this
!    print *, "DESTROY: ", this%n !< generates illegal, recursive io in 'final_s4'
    final_res = this%n
    final_ctr = final_ctr + 1
    this%n = -1
  end subroutine final_end
end module final_m

program final_p
  use final_m
  implicit none
  type(final_t) :: f0
!  call final_init(f0, 0)
  call final_s1()
  call final_s2()
  call final_s3()
  call final_s4()
  call final_end(f0)
contains
  subroutine final_s1()
    type(final_t) :: f
    call final_init(f, 1)
    print *, "f1: ", final_get(f)
    if ((final_ctr .ne. 1) .or. (final_res .ne. -1)) stop 1
  end subroutine final_s1
  subroutine final_s2()
    type(final_t) :: f
    f = 2
    print *, "f2: ", final_get(f)
    if ((final_ctr .ne. 3) .or. (final_res .ne. -1)) stop 1
  end subroutine final_s2
  subroutine final_s3()
    type(final_t) :: f
    f = final_set(3)
    print *, "f3: ", final_get(f)
    if ((final_ctr .ne. 6) .or. (final_res .ne. 3)) stop 1
  end subroutine final_s3
  subroutine final_s4()
    print *, "f4: ", final_get(final_set(4))
    if ((final_ctr .ne. 8) .or. (final_res .ne. 4)) stop 1
  end subroutine final_s4
end program final_p

[-- Attachment #12: finalize_45.f90 --]
[-- Type: text/x-fortran, Size: 2386 bytes --]

! { dg-do run }
!
! Test the fix for PR84472 in which the finalizations around the
! assignment in 'mymain' were not happening.
!
! Contributed by Vipul Parekh  <fortranfan@outlook.com>
!
module m

   use, intrinsic :: iso_fortran_env, only : output_unit

   implicit none

   private

   integer, public :: final_counts = 0
   integer, public :: assoc_counts = 0

   type :: t
      private
      character(len=:), pointer :: m_s => null()
   contains
      private
      final :: final_t
      procedure, pass(this), public :: clean => clean_t
      procedure, pass(this), public :: init => init_t
   end type

   interface t
      module procedure :: construct_t
   end interface

   public :: t

contains

   function construct_t( name ) result(new_t)

      ! argument list
      character(len=*), intent(in), optional :: name
      ! function result
      type(t) :: new_t

      if ( present(name) ) then
         call new_t%init( name )
      end if

   end function

   subroutine final_t( this )

      ! argument list
      type(t), intent(inout) :: this

      final_counts = final_counts + 1
      if ( associated(this%m_s) ) then
         assoc_counts = assoc_counts + 1
      endif
      call clean_t( this )

   end subroutine

   subroutine clean_t( this )

      ! argument list
      class(t), intent(inout) :: this

      if ( associated(this%m_s) ) then
         deallocate( this%m_s )
      end if
      this%m_s => null()

   end subroutine

   subroutine init_t( this, mname )

      ! argument list
      class(t), intent(inout)      :: this
      character(len=*), intent(in) :: mname

      call this%clean()
      allocate(character(len(mname)) :: this%m_s)
      this%m_s = mname

   end subroutine

end module
   use m, only : final_counts, assoc_counts
   call mymain
! See comment below.
   if (final_counts /= 3) stop 1
   if (assoc_counts /= 1) stop 2

contains
   subroutine mymain

   use m, only : t

   implicit none

   character(3), allocatable, target :: myname

   type(t) :: foo

   call foo%init( mname="123" )

   myname = "foo"
   foo = t( myname )

   call foo%clean()

! NAGFOR has assoc_counts =2, which is probably correct. If nullification
! of the pointer component is not done in gfortran, function finalization
! results in a double free. TODO fix this.
   if (final_counts /= 2) stop 3
   if (assoc_counts /= 1) stop 4
   end
end


[-- Attachment #13: finalize_48.f90 --]
[-- Type: text/x-fortran, Size: 1500 bytes --]

! { dg-do run }
!
! Check that pr106576 is fixed. The temporary from the function result
! was not being finalized.
!
! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
!
module y
  implicit none
  type foo
     integer :: n
   contains
     final :: cleanup
  end type foo
  interface assignment (=)
     module procedure assign
  end interface assignment (=)
  character(16) :: buffer(4)
  integer :: buffer_count = 1
contains

  subroutine assign (rop, op)
    type(foo), intent(inout) :: rop
    type(foo), intent(in) :: op
    rop%n = op%n + 1
    write (buffer(buffer_count), '(A12,I4)') "assign", rop%n
    buffer_count = buffer_count + 1
  end subroutine assign

  function to_foo(n) result(res)
    integer, intent(in) :: n
    type (foo) :: res
    res%n = n
    write (buffer(buffer_count),  '(A12,I4)') "to_foo", res%n
    buffer_count = buffer_count + 1
  end function to_foo

  subroutine cleanup (self)
    type (foo), intent(inout) :: self
    write (buffer(buffer_count),  '(A12,I4)') "cleanup", self%n
    buffer_count = buffer_count + 1
  end subroutine cleanup
end module y

program memain
  use y
  implicit none
  character(16) :: check(4) = ["      to_foo   3", &
                               "      assign   4", &
                               "     cleanup   3", &
                               "     cleanup   4"]
  call chk
  if (any (buffer .ne. check)) stop 1
contains
  subroutine chk
    type (foo) :: a
    a = to_foo(3)
  end subroutine chk
end program memain

[-- Attachment #14: finalize_50.f90 --]
[-- Type: text/x-fortran, Size: 8256 bytes --]

! { dg-do run }
!
! Test conformance with clause 7.5.6.3, paragraph 6 of F2018. Most of PR106576:
! The finalization of function results within specification expressions is tested
! in finalize_49.f90.
!
! Contributed by Damian Rouson  <damian@archaeologic.codes>
!
module test_result_m
  !! Define tests for each scenario in which the Fortran 2018
  !! standard mandates type finalization.
  implicit none

  private
  public :: test_result_t, get_test_results

  type test_result_t
    character(len=132) description
    logical outcome
  end type

  type object_t
    integer dummy
  contains
    final :: count_finalizations
  end type

  type wrapper_t
    private
    type(object_t), allocatable :: object
  end type

  integer :: finalizations = 0
  integer, parameter :: avoid_unused_variable_warning = 1

contains

  function get_test_results() result(test_results)
    type(test_result_t), allocatable :: test_results(:)

    test_results = [ &
       test_result_t("finalizes a non-allocatable object on the LHS of an intrinsic assignment", lhs_object()) &
      ,test_result_t("finalizes an allocated allocatable LHS of an intrinsic assignment", allocated_allocatable_lhs()) &
      ,test_result_t("finalizes a target when the associated pointer is deallocated", target_deallocation()) &
      ,test_result_t("finalizes an object upon explicit deallocation", finalize_on_deallocate()) &
      ,test_result_t("finalizes a non-pointer non-allocatable object at the END statement", finalize_on_end()) &
      ,test_result_t("finalizes a non-pointer non-allocatable object at the end of a block construct", block_end()) &
      ,test_result_t("finalizes a function reference on the RHS of an intrinsic assignment", rhs_function_reference()) &
      ,test_result_t("finalizes an intent(out) derived type dummy argument", intent_out()) &
      ,test_result_t("finalizes an allocatable component object", allocatable_component()) &
    ]
  end function

  function construct_object() result(object)
    !! Constructor for object_t
    type(object_t) object
    object % dummy = avoid_unused_variable_warning
  end function

  subroutine count_finalizations(self)
    !! Destructor for object_t
    type(object_t), intent(inout) :: self
    finalizations = finalizations + 1
    self % dummy = avoid_unused_variable_warning
  end subroutine

  function lhs_object() result(outcome)
    !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 1 behavior:
    !! "not an unallocated allocatable variable"
    type(object_t) lhs, rhs
    logical outcome
    integer initial_tally

    rhs%dummy = avoid_unused_variable_warning
    initial_tally = finalizations
    lhs = rhs ! finalizes lhs
    associate(finalization_tally => finalizations - initial_tally)
      outcome = finalization_tally==1
    end associate
  end function

  function allocated_allocatable_lhs() result(outcome)
    !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 1 behavior:
    !! "allocated allocatable variable"
    type(object_t), allocatable :: lhs
    type(object_t) rhs
    logical outcome
    integer initial_tally

    rhs%dummy = avoid_unused_variable_warning
    initial_tally = finalizations
    allocate(lhs)
    lhs = rhs ! finalizes lhs
    associate(finalization_tally => finalizations - initial_tally)
      outcome = finalization_tally==1
    end associate
  end function

  function target_deallocation() result(outcome)
    !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 2 behavior:
    !! "pointer is deallocated"
    type(object_t), pointer :: object_ptr => null()
    logical outcome
    integer initial_tally

    allocate(object_ptr, source=object_t(dummy=0))
    initial_tally = finalizations
    deallocate(object_ptr) ! finalizes object
    associate(finalization_tally => finalizations - initial_tally)
      outcome = finalization_tally==1
    end associate
  end function

  function allocatable_component() result(outcome)
    !! Test conformance with Fortran 2018 clause 7.5.6.3, para. 2 ("allocatable entity is deallocated")
    !! + 9.7.3.2, para. 6 ("INTENT(OUT) allocatable dummy argument is deallocated")
    type(wrapper_t), allocatable :: wrapper
    logical outcome
    integer initial_tally

    initial_tally = finalizations

    allocate(wrapper)
    allocate(wrapper%object)
    call finalize_intent_out_component(wrapper)
    associate(finalization_tally => finalizations - initial_tally)
      outcome = finalization_tally==1
    end associate

  contains

    subroutine finalize_intent_out_component(output)
      type(wrapper_t), intent(out) :: output ! finalizes object component
      allocate(output%object)
      output%object%dummy = avoid_unused_variable_warning
    end subroutine

  end function

  function finalize_on_deallocate() result(outcome)
    !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 2:
    !! "allocatable entity is deallocated"
    type(object_t), allocatable :: object
    logical outcome
    integer initial_tally

    initial_tally = finalizations
    allocate(object)
    object%dummy = 1
    deallocate(object)          ! finalizes object
    associate(final_tally => finalizations - initial_tally)
      outcome = final_tally==1
    end associate
  end function

  function finalize_on_end() result(outcome)
    !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 3:
    !! "before return or END statement"
    logical outcome
    integer initial_tally

    initial_tally = finalizations
    call finalize_on_end_subroutine() ! Finalizes local_obj
    associate(final_tally => finalizations - initial_tally)
      outcome = final_tally==1
    end associate

  contains

    subroutine finalize_on_end_subroutine()
      type(object_t) local_obj
      local_obj % dummy = avoid_unused_variable_warning
    end subroutine

  end function

  function block_end() result(outcome)
    !! Test conformance with Fortran 2018 clause  7.5.6.3, paragraph 4:
    !! "termination of the BLOCK construct"
    logical outcome
    integer initial_tally

    initial_tally = finalizations
    block
      type(object_t) object
      object % dummy = avoid_unused_variable_warning
    end block ! Finalizes object
    associate(finalization_tally => finalizations - initial_tally)
      outcome = finalization_tally==1
    end associate
  end function

  function rhs_function_reference() result(outcome)
    !! Test conformance with Fortran 2018 clause 7.5.6.3, paragraph 5 behavior:
    !! "nonpointer function result"
    type(object_t), allocatable :: object
    logical outcome
    integer initial_tally

    initial_tally = finalizations
    object = construct_object() ! finalizes object_t result
    associate(finalization_tally => finalizations - initial_tally)
      outcome = finalization_tally==1
    end associate
  end function

  function intent_out() result(outcome)
    !! Test conformance with Fortran 2018 standard clause 7.5.6.3, paragraph 7:
    !! "nonpointer, nonallocatable, INTENT (OUT) dummy argument"
    logical outcome
    type(object_t) object
    integer initial_tally

    initial_tally = finalizations
    call finalize_intent_out_arg(object)
    associate(finalization_tally => finalizations - initial_tally)
      outcome = finalization_tally==1
    end associate
  contains
    subroutine finalize_intent_out_arg(output)
      type(object_t), intent(out) :: output ! finalizes output
      output%dummy = avoid_unused_variable_warning
    end subroutine
  end function

end module test_result_m

program main
  !! Test each scenario in which the Fortran 2018 standard
  !! requires type finalization.
  use test_result_m, only : test_result_t, get_test_results
  implicit none
  type(test_result_t), allocatable :: test_results(:)
  integer i

  test_results = get_test_results()

  do i=1,size(test_results)
    print *, report(test_results(i)%outcome), test_results(i)%description
  end do

  if (any(.not.test_results%outcome)) stop "Failing tests"

  if (allocated (test_results)) deallocate (test_results)

contains

  pure function report(outcome)
    logical, intent(in) :: outcome
    character(len=:), allocatable ::  report
    report = merge("Pass: ", "Fail: ", outcome)
  end function

end program

[-- Attachment #15: finalize_49.f90 --]
[-- Type: text/x-fortran, Size: 2739 bytes --]

! { dg-do run }
!
! Test conformance with clause 7.5.6.3, paragraph 6 of F2018. Part of PR106576.
!
! Contributed by Damian Rouson  <damian@archaeologic.codes>
!
module finalizable_m
  !! This module supports the main program at the bottom of this file, which
  !! tests compiler conformance with clause 7.5.6.3, paragraph 6 in the Fortran
  !! Interpretation Document (https://j3-fortran.org/doc/year/18/18-007r1.pdf):
  !! "If a specification expression in a scoping unit references
  !! a function, the result is finalized before execution of the executable
  !! constructs in the scoping unit."

! NAGFOR complains about this testcase: "Error: finalize_50.f90, line 38: Rank 0
! type FINALIZABLE_T result variable of pure function CONSTRUCT will invoke an
! impure final subroutine."

! The standard doesn't specify whether the finalization is considered to be within
! the function or not. However, given the previous paragraph, "If an executable
! construct references a nonpointer function, the result is finalized after
! execution of the innermost executable construct containing the reference.", the
! pureness of the function whose result is being finalized doesn't matter. Instead,
! it should be the pureness of the containing scope.

  implicit none

  private
  public :: finalizable_t, component

  type finalizable_t
    private
    integer, allocatable :: component_
  contains
    final :: finalize
  end Type

  interface finalizable_t
    module procedure construct
  end interface

  integer, public :: final_ctr = 0

contains

  pure function construct(component) result(finalizable)
    integer, intent(in) :: component
    type(finalizable_t) finalizable
    allocate(finalizable%component_, source = component)
  end function

  pure function component(self) result(self_component)
    type(finalizable_t), intent(in) :: self
    integer self_component
    if (.not. allocated(self%component_)) error stop "component: unallocated component"
    self_component = self%component_
  end function

  subroutine finalize(self)
    type(finalizable_t), intent(inout) :: self
    if (allocated(self%component_)) deallocate(self%component_)
    final_ctr = final_ctr + 1
  end subroutine

end module

program specification_expression_finalization
  use finalizable_m, only : finalizable_t, component, final_ctr
  implicit none

  call finalize_specification_expression_result
  if (final_ctr .ne. 1) stop 1

contains

  subroutine finalize_specification_expression_result
    real tmp(component(finalizable_t(component=1))) !! Finalizes the finalizable_t function result
    real eliminate_unused_variable_warning
    tmp = eliminate_unused_variable_warning
    if (final_ctr .ne. 1) stop 2
  end subroutine

end program

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

[Harald Anlauf]

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?
 
If there is a change in the behavior between versions of the standard: should the compiler give a warning, when, and if so, is there a preferred flag that should control that warning (-pedantic or rather -Wsurprising or whatever)?
 

Thanks,
Harald
 

Gesendet: Montag, 02. Januar 2023 um 14:15 Uhr
Von: "Paul Richard Thomas" <paul.richard.thomas@gmail.com>
An: "fortran@gcc.gnu.org" <fortran@gcc.gnu.org>
Cc: "Harald Anlauf" <anlauf@gmx.de>, "Alessandro Fanfarillo" <alessandro.fanfarillo@gmail.com>, "Andrew Benson" <abenson@carnegiescience.edu>, "Thomas Koenig" <tkoenig@gcc.gnu.org>, "Damian Rouson" <damian@archaeologic.codes>
Betreff: [Patch, fortran] PR37336 (Finalization) - [F03] Finish derived-type finalization

Hi All,
 
Happy new year!
 
This thread broke off in February last year, as did my effort to resolve all the issues. However, prodded by Damian, I picked up the mantle again about a month ago.
 
Please consider this posting to be a placeholder. All the dependencies of PR37366 appear to be fixed although some minor issues remain and some divergences with the other brands. I will be contacting the vendors of the other brands today or tomorrow and will try to achieve some resolution with them. In the meantime, I will break the patch down to half a dozen more digestible chunks and will aim to submit formally in a week or so.
 
Of the remaining issues:
Function results of finalizable type with zero components confound the gimplifier: see PR65347 comment 3.
finalize_38.f90 loses 38 bytes in 4 blocks and has a load of invalid writes.
finalize_49.f90 has a number of invalid writes.
 
Please give the patch a whirl and any feedback that you might have would be very welcome.
 
Cheers
 
Paul
 
Fortran:Implement missing finalization features [PR37336]

2022-02-02  Paul Thomas  <pault@gcc.gnu.org[mailto:pault@gcc.gnu.org]>

gcc/fortran
PR fortran/103854
* class.cc (has_finalizer_component): Do not return true for
procedure pointer components.

PR fortran/96122
* class.cc (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.

PR fortran/37336
* class.cc (finalizer_insert_packed_call): Remove the redundant
argument in the call to the final subroutine.
(generate_finalization_wrapper): Add support for assumed rank
finalizers.
(gfc_may_be_finalized): New helper function.
* dump_parse_tree.cc (show_expr): Mark expressions with
must_finalize set.
* gfortran.h : Add prototype for gfc_may_be_finalized.
* resolve.cc (resolve_where, gfc_resolve_where_code_in_forall,
gfc_resolve_forall_body, gfc_resolve_code): Check that the op
code is still EXEC_ASSIGN. If it is set lhs to must finalize.
(generate_component_assignments): Set must_finalize if needed.
(gfc_resolve_finalizers): Error if assumed rank finalizer is
not the only one. Warning on lack of scalar finalizer modified
to account for assumed rank finalizers.
(resolve_symbol): Set referenced an unreferenced symbol that
will be finalized.
* trans-array.cc (gfc_trans_array_constructor_value): Add code
to finalize the constructor result. Warn that this feature was
removed in F2018 and that it is suppressed by -std=2018.
(trans_array_constructor): Add finalblock, pass to previous
and apply to loop->post if filled.
(gfc_add_loop_ss_code): Add se finalblock to outer loop post.
(gfc_trans_array_cobounds, gfc_trans_array_bounds): Add any
generated finalization code to the main block.
(structure_alloc_comps): Add boolean argument to suppress
finalization and use it for calls from
gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to
false. Add a second, additional boolean argument to nullify
pointer components and use it in gfc_copy_alloc_comp_del_ptrs.
(gfc_copy_alloc_comp_del_ptrs): New wrapper for
structure_alloc_comps.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_trans_deferred_array): Use gfc_may_be_finalized.
* trans-array.h : Add the new boolean argument to the prototype
of gfc_deallocate_alloc_comp_no_caf with a default of false.
Add prototype for gfc_copy_alloc_comp_del_ptrs.
* trans-decl.cc (gfc_get_symbol_decl): Make sure that temporary
variables from resolve.cc are not finalized by detection of a
leading '_' in the symbol name.
(init_intent_out_dt): Tidy up the code.
* trans-expr.cc (gfc_init_se): Initialize finalblock.
(finalize_function_result): New function that finalizes
function results in the correct order.
(gfc_conv_procedure_call): Use new function for finalizable
function results. Replace in-line block for class results with
call to new function.
(gfc_conv_expr): Finalize structure constructors for F2003 and
F2008. Warn that this feature was deleted in F2018 and, unlike
array constructors, is not default. Add array constructor
finalblock to the post block.
(gfc_trans_scalar_assign): Suppress finalization by setting new
argument in call to gfc_deallocate_alloc_comp_no_caf. Add the
finalization blocks to the main block.
(gfc_assignment_finalizer_call): New function to provide
finalization on intrinsic assignment.
(gfc_trans_arrayfunc_assign): Use the previous and ensure that
finalization occurs after the evaluation of the rhs but must
use the initial value for the lhs.
(trans_class_assignment, gfc_trans_assignment_1): Call it and
add the block between the rhs evaluation and any reallocation
on assignment that there might be.
* trans-io.cc (gfc_trans_transfer): Add the final block.
* trans-stmt.cc (gfc_trans_call, gfc_trans_allocate): likewise.
* trans.h: Add finalblock to gfc_se. Add the prototype for
gfc_finalize_function_result.

gcc/testsuite/
PR fortran/64290
* gfortran.dg/finalize_38.f90 : New test.
* gfortran.dg/allocate_with_source_25.f90 : The number of final
calls goes down from 6 to 4.
* gfortran.dg/unlimited_polymorphic_8.f90 : Tree dump reveals
foo.1.x rather than foo.0.x

PR fortran/67444
* gfortran.dg/finalize_39.f90 : New test.

PR fortran/67471
* gfortran.dg/finalize_40.f90 : New test.

PR fortran/69298
PR fortran/70863
* gfortran.dg/finalize_41.f90 : New test.

PR fortran/71798
* gfortran.dg/finalize_42.f90 : New test.

PR fortran/80524
* gfortran.dg/finalize_43.f90 : New test.

PR fortran/82996
* gfortran.dg/finalize_44.f90 : New test.

PR fortran/84472
* gfortran.dg/finalize_45.f90 : New test.

PR fortran/88735
PR fortran/93691
* gfortran.dg/finalize_46.f90 : New test.

PR fortran/91316
* gfortran.dg/finalize_47.f90 : New test.

PR fortran/106576
* gfortran.dg/finalize_48.f90 : New test.

PR fortran/91316
* gfortran.dg/finalize_47.f90 : New test.
 
 
 
 

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

[Jerry D]

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.

Jerry

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

[Harald Anlauf]

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
> 
>

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

[Paul Richard Thomas]

[-- 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

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

[Thomas Koenig]

Hi Paul,

first, thanks for taking on this rather monumental task!

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

There is one drawback if you do this in the front end:  There are a few
places where it is not possible to add code without running into ICEs
later, like WHERE/ELSEWHERE, which is why fronend_passes.cc keeps track
of these things.

Best regards

	Thomas

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 825 bytes --]

Hi Thomas,

What causes the ICES?

Cheers

Paul


On Sat, 7 Jan 2023 at 15:28, Thomas Koenig <tkoenig@netcologne.de> wrote:

> Hi Paul,
>
> first, thanks for taking on this rather monumental task!
>
> > 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.
>
> There is one drawback if you do this in the front end:  There are a few
> places where it is not possible to add code without running into ICEs
> later, like WHERE/ELSEWHERE, which is why fronend_passes.cc keeps track
> of these things.
>
> Best regards
>
>         Thomas
>


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

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

[Thomas Koenig]

Hi Paul,

> What causes the ICES?

There were a few PRs along this line.  Usually, it is the
front-end pass inserting code which is illegal Fortran, and
the later stages then asserting that it doesn't happen.

Here are a few examples:

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=50690 (function
elimination in OMP Workshare)

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=50564 (forall)

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=69154 (matmul
in where)

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=69742 (in
associate).

If you want to do the finalization of function results via
a front end pass, creating a variable and then assigning it
from within these constructs can cause these kinds of problems.

Best regards

	Thomas

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

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 1630 bytes --]

Hi Thomas,

I was thinking of a function in resolve.cc, similar
to generate_component_assignments that would generate the final call and,
where necessary, generate a temporary and place rhs finalization after the
assignment. Since this would only involve ordinary assignment and
subroutine calls, I think that it is compatible both with forall and where
constructs.

I guess that I should check whether or not generate_component_assignments
should not be placed within frontend_passes.cc. This part of resolve.cc
precedes your efforts, I believe.

Generating the final calls in the frontend would eliminate a substantial
amount of rather opaque code.

Best regards

Paul


On Sun, 8 Jan 2023 at 12:03, Thomas Koenig <tkoenig@netcologne.de> wrote:

> Hi Paul,
>
> > What causes the ICES?
>
> There were a few PRs along this line.  Usually, it is the
> front-end pass inserting code which is illegal Fortran, and
> the later stages then asserting that it doesn't happen.
>
> Here are a few examples:
>
> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=50690 (function
> elimination in OMP Workshare)
>
> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=50564 (forall)
>
> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=69154 (matmul
> in where)
>
> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=69742 (in
> associate).
>
> If you want to do the finalization of function results via
> a front end pass, creating a variable and then assigning it
> from within these constructs can cause these kinds of problems.
>
> Best regards
>
>         Thomas
>


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

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

[Harald Anlauf]

Hi Paul, all,
 
this is certainly better, and I am close to saying "go ahead", and
"let's fix any fallout later".

I am still confused about the handling of F2008 backward compatibility,
even more so after looking at the mentioned interp F08/0011.

When referring to the published standard, this document really has a lot
of "this does not seem to make sense." or "This makes even less sense..."
It appears to be really tough on the F2008 text.

At the risk of sounding stupid, but what line of interpretation do
we normally follow?  The published standard as-is, or rather take
into account the interpretation, even if it says that the published
document does not make sense?

If I understood you correctly, you are trying to implement a
backward compatibility, and the warning you emit refers to the
pre-interp version.  I haven't looked at the latest standard,
but I guess you spent a lot of time on it: is there a difference
between the interp version and the F2018 version?  If not, wouldn't
your/our life be easier if we focus on no-nonsense interpretations?
Or is there a convincing reason to support the pre-interp variant?

(From a practical point of view, a "F2018+ only" compliant
finalization would be more than most competitors offer... :)

Thanks,
Harald


Gesendet: Samstag, 07. Januar 2023 um 11:57 Uhr
Von: "Paul Richard Thomas" <paul.richard.thomas@gmail.com>
An: "Harald Anlauf" <anlauf@gmx.de>
Cc: "Jerry D" <jvdelisle2@gmail.com>, "fortran" <fortran@gcc.gnu.org>
Betreff: Re: Fw: Re: [Patch, fortran] PR37336 (Finalization) - [F03] Finish derived-type finalization

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[mailto:fortran@gcc.gnu.org]> wrote:Hi Jerry,

> Gesendet: Freitag, 06. Januar 2023 um 04:08 Uhr
> Von: "Jerry D" <jvdelisle2@gmail.com[mailto:jvdelisle2@gmail.com]>
> An: "Harald Anlauf" <anlauf@gmx.de[mailto:anlauf@gmx.de]>, "fortran" <fortran@gcc.gnu.org[mailto: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[mailto:anlauf@gmx.de]>
> > An: "Paul Richard Thomas" <paul.richard.thomas@gmail.com[mailto:paul.richard.thomas@gmail.com]>
> > Cc: "fortran@gcc.gnu.org[mailto:fortran@gcc.gnu.org]" <fortran@gcc.gnu.org[mailto:fortran@gcc.gnu.org]>, "Alessandro Fanfarillo" <alessandro.fanfarillo@gmail.com[mailto:alessandro.fanfarillo@gmail.com]>, "Andrew Benson" <abenson@carnegiescience.edu[mailto:abenson@carnegiescience.edu]>, "Thomas Koenig" <tkoenig@gcc.gnu.org[mailto: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

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

[Harald Anlauf]

Dear all,

Jerry pointed out to me off-list that I might have left others
with confusion.  Here's a simple example of what I had in my
mind when I wrote the previous mail, and sorry for the TOFU:

module m
  implicit none
  type :: simple
    integer :: ind
  contains
    final :: destructor1
  end type simple
contains
  subroutine destructor1(self)
    type(simple), intent(inout) :: self
  end subroutine destructor1
end

program p
  use m
  type(simple)              :: ThyType = simple(21)
  type(simple), allocatable :: MyTypeArray(:)
  MyTypeArray = [ThyType]
end


With the latest patch version I have from Paul:

-std=f2018 : silent
-std=gnu   : silent (good so far)

-std=f2008 :

foo.f90:18:25:

   18 |   MyTypeArray = [ThyType]
      |                         1
Warning: The structure constructor at (1) has been finalized. This feature was removed by f08/0011. Use -std=f2018 or -std=gnu to eliminate the finalization.

So the question is do we follow the original f2008 text or f08/0011?
(For reference, see https://j3-fortran.org/doc/year/10/10-202r1.txt
which says:

```
Which is the correct approach?

ANSWER:
Approach 4.  Constructors don't do anything that needs finalization.
```

I was trying to argue that the best user experience would be obtained
by just doing what the interp says, and voting to draw the line between
pre-f08/0011 and f08/0011 / f2018+.

I am open to what should be done for -std=f2003 or -std=legacy, but
then I do not really care, as finalization is not exactly legacy stuff.

Thanks,
Harald


> Gesendet: Montag, 09. Januar 2023 um 21:42 Uhr
> Von: "Harald Anlauf" <anlauf@gmx.de>
> An: "Paul Richard Thomas" <paul.richard.thomas@gmail.com>
> Cc: "Jerry D" <jvdelisle2@gmail.com>, "fortran" <fortran@gcc.gnu.org>
> Betreff: Aw: Re: Fw: Re: [Patch, fortran] PR37336 (Finalization) - [F03] Finish derived-type finalization
>
> Hi Paul, all,
>  
> this is certainly better, and I am close to saying "go ahead", and
> "let's fix any fallout later".
> 
> I am still confused about the handling of F2008 backward compatibility,
> even more so after looking at the mentioned interp F08/0011.
> 
> When referring to the published standard, this document really has a lot
> of "this does not seem to make sense." or "This makes even less sense..."
> It appears to be really tough on the F2008 text.
> 
> At the risk of sounding stupid, but what line of interpretation do
> we normally follow?  The published standard as-is, or rather take
> into account the interpretation, even if it says that the published
> document does not make sense?
> 
> If I understood you correctly, you are trying to implement a
> backward compatibility, and the warning you emit refers to the
> pre-interp version.  I haven't looked at the latest standard,
> but I guess you spent a lot of time on it: is there a difference
> between the interp version and the F2018 version?  If not, wouldn't
> your/our life be easier if we focus on no-nonsense interpretations?
> Or is there a convincing reason to support the pre-interp variant?
> 
> (From a practical point of view, a "F2018+ only" compliant
> finalization would be more than most competitors offer... :)
> 
> Thanks,
> Harald
> 
> 
> Gesendet: Samstag, 07. Januar 2023 um 11:57 Uhr
> Von: "Paul Richard Thomas" <paul.richard.thomas@gmail.com>
> An: "Harald Anlauf" <anlauf@gmx.de>
> Cc: "Jerry D" <jvdelisle2@gmail.com>, "fortran" <fortran@gcc.gnu.org>
> Betreff: Re: Fw: Re: [Patch, fortran] PR37336 (Finalization) - [F03] Finish derived-type finalization
> 
> 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[mailto:fortran@gcc.gnu.org]> wrote:Hi Jerry,
> 
> > Gesendet: Freitag, 06. Januar 2023 um 04:08 Uhr
> > Von: "Jerry D" <jvdelisle2@gmail.com[mailto:jvdelisle2@gmail.com]>
> > An: "Harald Anlauf" <anlauf@gmx.de[mailto:anlauf@gmx.de]>, "fortran" <fortran@gcc.gnu.org[mailto: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[mailto:anlauf@gmx.de]>
> > > An: "Paul Richard Thomas" <paul.richard.thomas@gmail.com[mailto:paul.richard.thomas@gmail.com]>
> > > Cc: "fortran@gcc.gnu.org[mailto:fortran@gcc.gnu.org]" <fortran@gcc.gnu.org[mailto:fortran@gcc.gnu.org]>, "Alessandro Fanfarillo" <alessandro.fanfarillo@gmail.com[mailto:alessandro.fanfarillo@gmail.com]>, "Andrew Benson" <abenson@carnegiescience.edu[mailto:abenson@carnegiescience.edu]>, "Thomas Koenig" <tkoenig@gcc.gnu.org[mailto: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