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

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