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

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

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