Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 193137)
+++ gcc/fortran/module.c	(working copy)
@@ -2597,7 +2597,7 @@ mio_component (gfc_component *c, int vtype)
     c->attr.class_ok = 1;
   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 
 
-  if (!vtype)
+  if (!vtype || strcmp (c->name, "_final") == 0)
     mio_expr (&c->initializer);
 
   if (c->attr.proc_pointer)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 193137)
+++ gcc/fortran/resolve.c	(working copy)
@@ -428,7 +428,11 @@ resolve_formal_arglist (gfc_symbol *proc)
 	      if (!gfc_pure(sym))
 		proc->attr.implicit_pure = 0;
 	    }
-	  else if (!sym->attr.pointer)
+	  else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
+		   || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+		       && CLASS_DATA (sym)->attr.class_pointer))
+	    proc->attr.implicit_pure = 0;
+	  else
 	    {
 	      if (proc->attr.function && sym->attr.intent != INTENT_IN
 		  && !sym->value)
@@ -11278,10 +11282,6 @@ error:
 		 " defined at %L, suggest also scalar one",
 		 derived->name, &derived->declared_at);
 
-  /* TODO:  Remove this error when finalization is finished.  */
-  gfc_error ("Finalization at %L is not yet implemented",
-	     &derived->declared_at);
-
   gfc_find_derived_vtab (derived);
   return result;
 }
@@ -12355,6 +12355,10 @@ resolve_fl_derived0 (gfc_symbol *sym)
   /* Add derived type to the derived type list.  */
   add_dt_to_dt_list (sym);
 
+  /* Check if the type is finalizable. This is done in order to ensure that the
+     finalization wrapper is generated early enough.  */
+  gfc_is_finalizable (sym, NULL);
+
   return SUCCESS;
 }
 
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 193137)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -7273,7 +7273,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
 
       /* Deallocate "to".  */
       tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
-					       to_expr2, to_expr->ts);
+					       to_expr, to_expr->ts);
       gfc_add_expr_to_block (&block, tmp);
 
       /* Assign (_data) pointers.  */
@@ -7307,9 +7307,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
 	    }
 	  else
 	    {
-	      gfc_symbol *vtab;
-	      vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
-	      gcc_assert (vtab);
+	      gfc_symbol *vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
 	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
 	    }
 
@@ -7338,9 +7336,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
 	}
       else
 	{
-	  gfc_symbol *vtab;
-	  vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
-	  gcc_assert (vtab);
+	  gfc_symbol *vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
 	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
 	}
 
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 193137)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -95,6 +95,7 @@ conv_scalar_to_descriptor (gfc_se *se, tree scalar
 #define VTABLE_EXTENDS_FIELD 2
 #define VTABLE_DEF_INIT_FIELD 3
 #define VTABLE_COPY_FIELD 4
+#define VTABLE_FINAL_FIELD 5
 
 
 tree
@@ -180,6 +181,13 @@ gfc_vtable_copy_get (tree decl)
 }
 
 
+tree
+gfc_vtable_final_get (tree decl)
+{
+  return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
+}
+
+
 #undef CLASS_DATA_FIELD
 #undef CLASS_VPTR_FIELD
 #undef VTABLE_HASH_FIELD
@@ -187,6 +195,7 @@ gfc_vtable_copy_get (tree decl)
 #undef VTABLE_EXTENDS_FIELD
 #undef VTABLE_DEF_INIT_FIELD
 #undef VTABLE_COPY_FIELD
+#undef VTABLE_FINAL_FIELD
 
 
 /* Obtain the vptr of the last class reference in an expression.  */
@@ -239,7 +248,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_exp
 			   gfc_typespec class_ts, tree vptr, bool optional,
 			   bool optional_alloc_ptr)
 {
-  gfc_symbol *vtab;
   tree cond_optional = NULL_TREE;
   gfc_ss *ss;
   tree ctree;
@@ -263,8 +271,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_exp
     {
       /* In this case the vtab corresponds to the derived type and the
 	 vptr must point to it.  */
-      vtab = gfc_find_derived_vtab (e->ts.u.derived);
-      gcc_assert (vtab);
+      gfc_symbol *vtab = gfc_find_derived_vtab (e->ts.u.derived);
       tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
     }
   gfc_add_modify (&parmse->pre, ctree,
@@ -1510,7 +1517,7 @@ conv_parent_component_references (gfc_se * se, gfc
   dt = ref->u.c.sym;
   c = ref->u.c.component;
 
-  /* Return if the component is not in the parent type.  */
+  /* Return if the component is in the parent type.  */
   for (cmp = dt->components; cmp; cmp = cmp->next)
     if (strcmp (c->name, cmp->name) == 0)
       return;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 193137)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2948,6 +2948,7 @@ void gfc_add_class_array_ref (gfc_expr *);
 #define gfc_add_hash_component(e)     gfc_add_component_ref(e,"_hash")
 #define gfc_add_size_component(e)     gfc_add_component_ref(e,"_size")
 #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init")
+#define gfc_add_final_component(e)    gfc_add_component_ref(e,"_final")
 bool gfc_is_class_array_ref (gfc_expr *, bool *);
 bool gfc_is_class_scalar_expr (gfc_expr *);
 bool gfc_is_class_container_ref (gfc_expr *e);
@@ -2964,6 +2965,7 @@ gfc_typebound_proc* gfc_find_typebound_intrinsic_o
 						     gfc_intrinsic_op, bool,
 						     locus*);
 gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
+bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
 
 #define CLASS_DATA(sym) sym->ts.u.derived->components
 
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 193137)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -5098,7 +5098,6 @@ gfc_trans_allocate (gfc_code * code)
 	      if (ts->type == BT_DERIVED)
 		{
 		  vtab = gfc_find_derived_vtab (ts->u.derived);
-		  gcc_assert (vtab);
 		  gfc_init_se (&lse, NULL);
 		  lse.want_pointer = 1;
 		  gfc_conv_expr (&lse, lhs);
@@ -5188,6 +5187,7 @@ gfc_trans_allocate (gfc_code * code)
 	      gfc_add_component_ref (ppc, "_copy");
 
 	      ppc_code = gfc_get_code ();
+	      /* FIXME: Probably, the interface is not avilable, cf. _final ...*/
 	      ppc_code->resolved_sym = ppc->symtree->n.sym;
 	      /* Although '_copy' is set to be elemental in class.c, it is
 		 not staying that way.  Find out why, sometime....  */
@@ -5347,14 +5347,63 @@ gfc_trans_deallocate (gfc_code *code)
       gfc_init_se (&se, NULL);
       gfc_start_block (&se.pre);
 
+/* FIXME: HOW is var == NULL handled? And how are coarrays error stats handled? */
       se.want_pointer = 1;
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
       if (expr->rank || gfc_is_coarray (expr))
 	{
-	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+	  gfc_expr *final_expr = NULL;
+
+	  if (al->expr->ts.type == BT_CLASS)
 	    {
+	      final_expr = gfc_copy_expr (al->expr);
+	      gfc_add_vptr_component (final_expr);
+	      gfc_add_final_component (final_expr);
+	    }
+	  else if (al->expr->ts.type == BT_DERIVED)
+	    gfc_is_finalizable (al->expr->ts.u.derived, &final_expr);
+
+	  if (final_expr)
+	    {
+	      tree cond;
+
+	      tmp = gfc_conv_descriptor_data_get (se.expr);
+	      STRIP_NOPS (se.expr);
+
+	      cond = fold_build2_loc (input_location, NE_EXPR,
+				      boolean_type_node, tmp,
+				      null_pointer_node);
+
+	      if (al->expr->ts.type == BT_CLASS)
+		{
+		  tree cond2;
+		  gfc_se se2;
+
+		  gfc_init_se (&se2, NULL);
+		  se2.want_pointer = 1;
+		  gfc_conv_expr (&se2, final_expr);
+		  cond2 = fold_build2_loc (input_location, NE_EXPR,
+					   boolean_type_node, se2.expr,
+					   build_int_cst (TREE_TYPE (se2.expr),
+							  0));
+		  cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					  boolean_type_node, cond, cond2);
+		}
+
+	      tmp = gfc_build_final_call (al->expr->ts, final_expr,
+					  gfc_copy_expr (expr));
+
+	      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				     cond, tmp,
+				     build_empty_stmt (input_location));
+	      gfc_add_expr_to_block (&se.pre, tmp);
+	    }
+
+	  if (!final_expr && expr->ts.type == BT_DERIVED
+	      && expr->ts.u.derived->attr.alloc_comp)
+	    {
 	      gfc_ref *ref;
 	      gfc_ref *last = NULL;
 	      for (ref = expr->ref; ref; ref = ref->next)
@@ -5378,7 +5427,7 @@ gfc_trans_deallocate (gfc_code *code)
       else
 	{
 	  tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
-						   expr, expr->ts);
+						   al->expr, al->expr->ts);
 	  gfc_add_expr_to_block (&se.pre, tmp);
 
 	  /* Set to zero after deallocation.  */
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(revision 193137)
+++ gcc/fortran/trans.c	(working copy)
@@ -1023,6 +1023,35 @@ gfc_deallocate_with_status (tree pointer, tree sta
 }
 
 
+/* Build a call to a FINAL procedure.  */
+
+tree
+gfc_build_final_call (gfc_typespec ts, gfc_expr *final_expr, gfc_expr *arg)
+{
+  gfc_code *code;
+  tree tmp;
+
+  gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
+  gcc_assert (arg);
+
+  code = gfc_get_code ();
+  if (ts.type == BT_DERIVED)
+    code->resolved_sym = final_expr->symtree->n.sym;
+  else
+    code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface;
+  code->ext.actual = gfc_get_actual_arglist ();
+  code->ext.actual->expr = arg;
+  code->ext.actual->next = gfc_get_actual_arglist ();
+  code->ext.actual->next->expr = gfc_get_logical_expr (4, NULL, false);
+  code->expr1 = gfc_copy_expr (final_expr);
+  code->op = EXEC_CALL;
+
+  tmp = gfc_trans_call (code, true, NULL, NULL, false);
+  gfc_free_statements (code);
+  return tmp;
+}
+
+
 /* Generate code for deallocation of allocatable scalars (variables or
    components). Before the object itself is freed, any allocatable
    subcomponents are being deallocated.  */
@@ -1077,21 +1106,49 @@ gfc_deallocate_scalar_with_status (tree pointer, t
   gfc_start_block (&non_null);
   
   /* Free allocatable components.  */
-  if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+{
+  gfc_expr *final_expr = NULL;
+
+/* FIXME:  !expr && ts.type == BT_CLASS shouldn't happen.
+   Cf. trans-array.c's structure_alloc_comps for a case where it does occur.  */
+  if (expr && ts.type == BT_CLASS)
     {
-      tmp = build_fold_indirect_ref_loc (input_location, pointer);
-      tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+      final_expr = gfc_copy_expr (expr);
+      gfc_add_vptr_component (final_expr);
+      gfc_add_final_component (final_expr);
+    }
+  else if (expr && ts.type == BT_DERIVED)
+    gfc_is_finalizable (ts.u.derived, &final_expr);
+
+  if (final_expr)
+    {
+      tmp = gfc_build_final_call (ts, final_expr, gfc_copy_expr (expr));
+
+      if (ts.type == BT_CLASS)
+	{
+	  tree cond;
+	  gfc_se se;
+
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, final_expr);
+	  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				  se.expr,
+				  build_int_cst (TREE_TYPE (se.expr), 0));
+
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 cond, tmp, build_empty_stmt (input_location));
+	}
       gfc_add_expr_to_block (&non_null, tmp);
     }
-  else if (ts.type == BT_CLASS
-	   && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
+
+  if (!final_expr && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
     {
       tmp = build_fold_indirect_ref_loc (input_location, pointer);
-      tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
-				       tmp, 0);
+      tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
       gfc_add_expr_to_block (&non_null, tmp);
     }
-  
+}  
   tmp = build_call_expr_loc (input_location,
 			     builtin_decl_explicit (BUILT_IN_FREE), 1,
 			     fold_convert (pvoid_type_node, pointer));
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 193137)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -2654,7 +2654,7 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
     {
       gfc_symbol *result = sym->result ? sym->result : sym;
 
-      if (result->attr.pointer || sym->attr.proc_pointer)
+      if (result->attr.pointer || result->attr.proc_pointer)
 	spec[spec_len++] = '.';
       else
 	spec[spec_len++] = 'w';
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 193137)
+++ gcc/fortran/trans.h	(working copy)
@@ -348,9 +348,11 @@ tree gfc_vtable_size_get (tree);
 tree gfc_vtable_extends_get (tree);
 tree gfc_vtable_def_init_get (tree);
 tree gfc_vtable_copy_get (tree);
+tree gfc_vtable_final_get (tree);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree);
+tree gfc_build_final_call (gfc_typespec, gfc_expr *, gfc_expr *);
 void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
 				bool);
 void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 193137)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -1406,7 +1406,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	  && !sym->attr.data
 	  && !sym->attr.allocatable
 	  && (sym->value && !sym->ns->proc_name->attr.is_main_program)
-	  && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
+	  && !(sym->attr.use_assoc && !intrinsic_array_parameter))
+      /* Finalization.  */
+      || (sym->ts.type == BT_DERIVED && gfc_is_finalizable (sym->ts.u.derived, NULL)
+	  && !sym->attr.pointer && !sym->attr.allocatable && !sym->attr.dummy
+	  && !sym->attr.result && sym->attr.save == SAVE_NONE))
     gfc_defer_symbol_init (sym);
 
   gfc_finish_var_decl (decl, sym);
@@ -3432,8 +3436,30 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wra
 	&& !f->sym->attr.pointer
 	&& f->sym->ts.type == BT_DERIVED)
       {
-	if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+	gfc_expr *final_expr;
+
+	if (gfc_is_finalizable (f->sym->ts.u.derived, &final_expr))
 	  {
+	    f->sym->attr.referenced = 1;
+	    tmp = gfc_build_final_call (f->sym->ts, final_expr,
+					gfc_lval_expr_from_sym (f->sym));
+
+	    if (f->sym->attr.optional
+		|| f->sym->ns->proc_name->attr.entry_master)
+	      {
+		present = gfc_conv_expr_present (f->sym);
+		tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+				  present, tmp,
+				  build_empty_stmt (input_location));
+	      }
+
+	    gfc_add_expr_to_block (&init, tmp);
+
+	    if (f->sym->value)
+	      gfc_init_default_dt (f->sym, &init, false);
+	  }
+	else if (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);
@@ -3454,25 +3480,52 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wra
       }
     else if (f->sym && f->sym->attr.intent == INTENT_OUT
 	     && f->sym->ts.type == BT_CLASS
-	     && !CLASS_DATA (f->sym)->attr.class_pointer
-	     && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
+	     && !CLASS_DATA (f->sym)->attr.class_pointer)
       {
-	tmp = gfc_class_data_get (f->sym->backend_decl);
-	if (CLASS_DATA (f->sym)->as == NULL)
-	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
-	tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
-					 tmp,
-					 CLASS_DATA (f->sym)->as ?
-					 CLASS_DATA (f->sym)->as->rank : 0);
+	gfc_expr *final_expr;
+	gfc_symbol *vtab;
+	gfc_component *final;
 
-	if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
-	  {
-	    present = gfc_conv_expr_present (f->sym);
+	/* Make sure the vtab is available.  */
+	vtab = gfc_find_derived_vtab (f->sym->ts.u.derived);
+
+	final_expr = gfc_lval_expr_from_sym (f->sym);
+	gfc_add_vptr_component (final_expr);
+	gfc_add_final_component (final_expr);
+
+	f->sym->attr.referenced = 1;
+	tmp = gfc_build_final_call (f->sym->ts, final_expr,
+				    gfc_lval_expr_from_sym (f->sym));
+
+	/* We don't need add a run-time check when we know that a
+	   finalization wrapper exists.  */
+	final = vtab->ts.u.derived->components->next->next->next->next->next;
+	gcc_assert (strcmp (final->name, "_final") == 0);
+
+	if (!final->initializer || final->initializer->expr_type == EXPR_NULL)
+	  { 
+	    tree cond;
+/* FIXME: For OPTIONAL, the condition is completely missing, see: PR fortran/54618  */
+/*	    cond = gfc_class_data_get (f->sym->backend_decl);
+	    if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cond)))
+	      cond = gfc_conv_descriptor_data_get (cond);
+	    else if (!POINTER_TYPE_P (TREE_TYPE (cond)))
+	      cond = gfc_build_addr_expr (NULL_TREE, cond); */
+	    cond = gfc_vtable_final_get (f->sym->backend_decl);
+	    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				cond, build_int_cst (TREE_TYPE (cond), 0));
+
+	    if (f->sym->attr.optional
+		|| f->sym->ns->proc_name->attr.entry_master)
+	      {
+		present = gfc_conv_expr_present (f->sym);
+		cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+					boolean_type_node, present, cond);
+	      }
+
 	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
-			      present, tmp,
-			      build_empty_stmt (input_location));
+			      cond, tmp, build_empty_stmt (input_location));
 	  }
-
 	gfc_add_expr_to_block (&init, tmp);
       }
 
@@ -3482,12 +3535,13 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wra
 
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
-    Allocation and initialization of array variables.
-    Allocation of character string variables.
-    Initialization and possibly repacking of dummy arrays.
-    Initialization of ASSIGN statement auxiliary variable.
-    Initialization of ASSOCIATE names.
-    Automatic deallocation.  */
+   * Allocation and initialization of array variables.
+   * Allocation of character string variables.
+   * Initialization and possibly repacking of dummy arrays.
+   * Initialization of ASSIGN statement auxiliary variable.
+   * Initialization of ASSOCIATE names.
+   * Automatic deallocation.
+   * Finalization. */
 
 void
 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
@@ -3501,6 +3555,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf
   gfc_expr *e;
   gfc_se se;
   stmtblock_t init;
+  gfc_expr *final_expr;
 
   /* Deal with implicit return variables.  Explicit return variables will
      already have been added.  */
@@ -3782,9 +3837,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf
 						      NULL_TREE, true, NULL,
 						      true);
 		  else
-		    tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
-							     true, NULL,
-							     sym->ts);
+		    tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE,
+						   true,
+						   gfc_lval_expr_from_sym (sym),
+						   sym->ts);
 		}
 	      if (sym->ts.type == BT_CLASS)
 		{
@@ -3857,16 +3913,24 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gf
 	  gfc_trans_assign_aux_var (sym, block);
 	  gfc_restore_backend_locus (&loc);
 	}
-      else if (sym->ts.type == BT_DERIVED
-		 && sym->value
-		 && !sym->attr.data
-		 && sym->attr.save == SAVE_NONE)
+      else if (sym->ts.type == BT_DERIVED && sym->value && !sym->attr.data
+	       && sym->attr.save == SAVE_NONE)
 	{
 	  gfc_start_block (&tmpblock);
 	  gfc_init_default_dt (sym, &tmpblock, false);
-	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
-				NULL_TREE);
+	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
 	}
+      else if (sym->ts.type == BT_DERIVED
+	       && gfc_is_finalizable (sym->ts.u.derived, &final_expr)
+	       && !sym->attr.pointer && !sym->attr.allocatable
+	       && !sym->attr.dummy && !sym->attr.result
+	       && sym->attr.save == SAVE_NONE)
+	{
+	  /* Call FINAL procedure.  */
+	  tmp = gfc_build_final_call (sym->ts, final_expr,
+				      gfc_lval_expr_from_sym (sym));
+	  gfc_add_init_cleanup (block, NULL_TREE, tmp);
+	}
       else
 	gcc_unreachable ();
     }
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 193137)
+++ gcc/fortran/parse.c	(working copy)
@@ -1998,8 +1998,7 @@ parse_derived_contains (void)
 
 	case ST_FINAL:
 	  if (gfc_notify_std (GFC_STD_F2003,
-			      "FINAL procedure declaration"
-			      " at %C") == FAILURE)
+			      "FINAL procedure declaration at %C") == FAILURE)
 	    goto error;
 
 	  accept_statement (ST_FINAL);
@@ -2009,7 +2008,7 @@ parse_derived_contains (void)
 	case ST_END_TYPE:
 	  to_finish = true;
 
-	  if (!seen_comps
+	  if (!seen_comps && (gfc_option.allow_std & GFC_STD_F2003) != 0
 	      && (gfc_notify_std (GFC_STD_F2008, "Derived type "
 				  "definition at %C with empty CONTAINS "
 				  "section") == FAILURE))
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 193137)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -7588,7 +7588,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree
 					CLASS_DATA (c)->attr.codimension);
 	      else
 		{
-		  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+		  tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
 							   CLASS_DATA (c)->ts);
 		  gfc_add_expr_to_block (&tmpblock, tmp);
 		  called_dealloc_with_status = true;
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c	(revision 193137)
+++ gcc/fortran/class.c	(working copy)
@@ -839,7 +839,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *de
       gfc_component *c;
 
       for (c = comp->ts.u.derived->components; c; c = c->next)
-	finalize_component (e, c->ts.u.derived, c, stat, code);
+	finalize_component (e, comp->ts.u.derived, c, stat, code);
       gfc_free_expr (e);
     }
 }
@@ -985,13 +985,14 @@ static void
 generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 			       const char *tname, gfc_component *vtab_final)
 {
-  gfc_symbol *final, *array, *nelem;
+  gfc_symbol *final, *array, *nelem, *skip_coarray;
   gfc_symbol *ptr = NULL, *idx = NULL;
   gfc_component *comp;
   gfc_namespace *sub_ns;
   gfc_code *last_code;
   char name[GFC_MAX_SYMBOL_LEN+1];
   bool finalizable_comp = false;
+  bool expr_null_wrapper = false;
   gfc_expr *ancestor_wrapper = NULL;
 
   /* Search for the ancestor's finalizers. */
@@ -1011,43 +1012,35 @@ generate_finalization_wrapper (gfc_symbol *derived
 	  }
     }
 
-  /* No wrapper of the ancestor and no own FINAL subroutines and
-     allocatable components: Return a NULL() expression.  */
+  /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
+     components: Return a NULL() expression; we defer this a bit to have have
+     an interface declaration.  */
   if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
       && !derived->attr.alloc_comp
       && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
       && !has_finalizer_component (derived))
-    {
-      vtab_final->initializer = gfc_get_null_expr (NULL);
-      return;
-    }
-
-  /* Check whether there are new allocatable components.  */
-  for (comp = derived->components; comp; comp = comp->next)
-    {
-      if (comp == derived->components && derived->attr.extension
-	  && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+    expr_null_wrapper = true;
+  else
+    /* Check whether there are new allocatable components.  */
+    for (comp = derived->components; comp; comp = comp->next)
+      {
+	if (comp == derived->components && derived->attr.extension
+	    && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
 	continue;
 
-      if (comp->ts.type != BT_CLASS && !comp->attr.pointer
-	  && (comp->attr.alloc_comp || comp->attr.allocatable
-	      || (comp->ts.type == BT_DERIVED
-		  && has_finalizer_component (comp->ts.u.derived))))
-	finalizable_comp = true;
-      else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
-	       && CLASS_DATA (comp)->attr.allocatable)
-	finalizable_comp = true;
-    }
+	if (comp->ts.type != BT_CLASS && !comp->attr.pointer
+	    && (comp->attr.allocatable
+		|| (comp->ts.type == BT_DERIVED
+		    && (comp->ts.u.derived->attr.alloc_comp
+			|| has_finalizer_component (comp->ts.u.derived)
+			|| (comp->ts.u.derived->f2k_derived
+			    && comp->ts.u.derived->f2k_derived->finalizers)))))
+	  finalizable_comp = true;
+	else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+		 && CLASS_DATA (comp)->attr.allocatable)
+	  finalizable_comp = true;
+      }
 
-  /* If there is no new finalizer and no new allocatable, return with
-     an expr to the ancestor's one.  */
-  if ((!derived->f2k_derived || !derived->f2k_derived->finalizers)
-      && !finalizable_comp)
-    {
-      vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
-      return;
-    }
-
   /* We now create a wrapper, which does the following:
      1. Call the suitable finalization subroutine for this type
      2. Loop over all noninherited allocatable components and noninherited
@@ -1057,12 +1050,13 @@ generate_finalization_wrapper (gfc_symbol *derived
      3. Call the ancestor's finalizer.  */
 
   /* Declare the wrapper function; it takes an assumed-rank array
-     as argument. */
+     and a VALUE logical as arguments. */
 
   /* Set up the namespace.  */
   sub_ns = gfc_get_namespace (ns, 0);
   sub_ns->sibling = ns->contained;
-  ns->contained = sub_ns;
+  if (!expr_null_wrapper)
+    ns->contained = sub_ns;
   sub_ns->resolved = 1;
 
   /* Set up the procedure symbol.  */
@@ -1070,13 +1064,17 @@ generate_finalization_wrapper (gfc_symbol *derived
   gfc_get_symbol (name, sub_ns, &final);
   sub_ns->proc_name = final;
   final->attr.flavor = FL_PROCEDURE;
-  final->attr.subroutine = 1;
-  final->attr.pure = 1;
+  final->attr.function = 1;
+  final->attr.pure = 0;
+  final->result = final;
+  final->ts.type = BT_INTEGER;
+  final->ts.kind = 4;
   final->attr.artificial = 1;
-  final->attr.if_source = IFSRC_DECL;
+  final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
   if (ns->proc_name->attr.flavor == FL_MODULE)
     final->module = ns->proc_name->name;
   gfc_set_sym_referenced (final);
+  gfc_commit_symbol (final);
 
   /* Set up formal argument.  */
   gfc_get_symbol ("array", sub_ns, &array);
@@ -1096,6 +1094,37 @@ generate_finalization_wrapper (gfc_symbol *derived
   final->formal->sym = array;
   gfc_commit_symbol (array);
 
+  /* Set up formal argument.  */
+  gfc_get_symbol ("skip_coarray", sub_ns, &skip_coarray);
+  skip_coarray->ts.type = BT_LOGICAL;
+  skip_coarray->ts.kind = 4;
+  skip_coarray->attr.flavor = FL_VARIABLE;
+  skip_coarray->attr.dummy = 1;
+  skip_coarray->attr.value = 1;
+  skip_coarray->attr.artificial = 1;
+  gfc_set_sym_referenced (skip_coarray);
+  final->formal->next = gfc_get_formal_arglist ();
+  final->formal->next->sym = skip_coarray;
+  gfc_commit_symbol (skip_coarray);
+
+  /* Return with a NULL() expression but with an interface which has
+     the formal arguments.  */
+  if (expr_null_wrapper)
+    {
+      vtab_final->initializer = gfc_get_null_expr (NULL);
+      vtab_final->ts.interface = final;
+      return;
+    }
+
+
+  /* Set return value to 0.  */
+  last_code = XCNEW (gfc_code);
+  last_code->op = EXEC_ASSIGN;
+  last_code->loc = gfc_current_locus;
+  last_code->expr1 = gfc_lval_expr_from_sym (final);
+  last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
+  sub_ns->code = last_code;
+
   /* Obtain the size (number of elements) of "array" MINUS ONE,
      which is used in the scalarization.  */
   gfc_get_symbol ("nelem", sub_ns, &nelem);
@@ -1107,7 +1136,8 @@ generate_finalization_wrapper (gfc_symbol *derived
   gfc_commit_symbol (nelem);
 
   /* Generate: nelem = SIZE (array) - 1.  */
-  last_code = XCNEW (gfc_code);
+  last_code->next = XCNEW (gfc_code);
+  last_code = last_code->next;
   last_code->op = EXEC_ASSIGN;
   last_code->loc = gfc_current_locus;
 
@@ -1386,9 +1416,10 @@ generate_finalization_wrapper (gfc_symbol *derived
 
       last_code->ext.actual = gfc_get_actual_arglist ();
       last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
+      last_code->ext.actual->next = gfc_get_actual_arglist ();
+      last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (skip_coarray);
     }
 
-  gfc_commit_symbol (final);
   vtab_final->initializer = gfc_lval_expr_from_sym (final);
   vtab_final->ts.interface = final;
 }
@@ -1440,7 +1471,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (ns)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
-      
+
       get_unique_hashed_string (tname, derived);
       sprintf (name, "__vtab_%s", tname);
 
@@ -1464,7 +1495,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	  vtab->attr.access = ACCESS_PUBLIC;
 	  gfc_set_sym_referenced (vtab);
 	  sprintf (name, "__vtype_%s", tname);
-	  
+
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
 	    {
@@ -1608,7 +1639,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  dst->attr.flavor = FL_VARIABLE;
 		  dst->attr.dummy = 1;
 		  dst->attr.artificial = 1;
-		  dst->attr.intent = INTENT_OUT;
+		  dst->attr.intent = INTENT_INOUT;
 		  gfc_set_sym_referenced (dst);
 		  copy->formal->next = gfc_get_formal_arglist ();
 		  copy->formal->next->sym = dst;
@@ -1627,9 +1658,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		 components and the calls to finalization subroutines.
 		 Note: The actual wrapper function can only be generated
 		 at resolution time.  */
-	    /* FIXME: Enable ABI-breaking "_final" generation.  */
-	    if (0) 
-	    {
 	      if (gfc_add_component (vtype, "_final", &c) == FAILURE)
 		goto cleanup;
 	      c->attr.proc_pointer = 1;
@@ -1637,7 +1665,6 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
 	      generate_finalization_wrapper (derived, ns, tname, c);
-	    }
 
 	      /* Add procedure pointers for type-bound procedures.  */
 	      add_procs_to_declared_vtab (derived, vtype);
@@ -1675,6 +1702,48 @@ cleanup:
 }
 
 
+/* Check if a derived type is finalizable. That is the case if it
+   (1) has a FINAL subroutine or
+   (2) has a nonpointer nonallocatable component of finalizable type.
+   If it is finalizable, return an expression containing the
+   finalization wrapper.  */
+
+bool
+gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
+{
+  gfc_symbol *vtab;
+  gfc_component *c;
+
+  /* (1) Check for FINAL subroutines.  */
+  if (derived->f2k_derived && derived->f2k_derived->finalizers)
+    goto yes;
+
+  /* (2) Check for components of finalizable type.  */
+  for (c = derived->components; c; c = c->next)
+    if (c->ts.type == BT_DERIVED
+	&& !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
+	&& gfc_is_finalizable (c->ts.u.derived, NULL))
+      goto yes;
+
+  return false;
+  
+yes:
+  /* Make sure vtab is generated.  */
+  vtab = gfc_find_derived_vtab (derived);
+  if (final_expr)
+    {
+      /* Return finalizer expression.  */
+      gfc_component *final;
+      final = vtab->ts.u.derived->components->next->next->next->next->next;
+      gcc_assert (strcmp (final->name, "_final") == 0);
+      gcc_assert (final->initializer
+		  && final->initializer->expr_type != EXPR_NULL);
+      *final_expr = final->initializer;
+    }
+  return true;
+}
+
+
 /* General worker function to find either a type-bound procedure or a
    type-bound user operator.  */
 
Index: gcc/testsuite/gfortran.dg/class_19.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_19.f03	(revision 193137)
+++ gcc/testsuite/gfortran.dg/class_19.f03	(working copy)
@@ -39,5 +39,5 @@ program main
 
 end program main
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/finalize_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_7.f03	(revision 193137)
+++ gcc/testsuite/gfortran.dg/finalize_7.f03	(working copy)
@@ -52,6 +52,3 @@ PROGRAM finalizer
   IMPLICIT NONE
   ! Nothing here
 END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
Index: gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/auto_dealloc_2.f90	(revision 193137)
+++ gcc/testsuite/gfortran.dg/auto_dealloc_2.f90	(working copy)
@@ -25,5 +25,5 @@ contains
 
 end program 
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/finalize_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_6.f90	(revision 193137)
+++ gcc/testsuite/gfortran.dg/finalize_6.f90	(working copy)
@@ -11,7 +11,7 @@ MODULE final_type
     INTEGER :: fooarr(42)
     REAL :: foobar
   CONTAINS ! { dg-error "Fortran 2003" }
-    FINAL :: finalize_single ! { dg-error "Fortran 2003" }
+    FINAL :: finalize_single ! { dg-error "Fortran 2003|is not a SUBROUTINE" }
   END TYPE mytype
 
 CONTAINS
@@ -28,6 +28,3 @@ PROGRAM finalizer
   IMPLICIT NONE
   ! Do nothing
 END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
Index: gcc/testsuite/gfortran.dg/finalize_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_5.f03	(revision 193137)
+++ gcc/testsuite/gfortran.dg/finalize_5.f03	(working copy)
@@ -107,6 +107,3 @@ PROGRAM finalizer
   IMPLICIT NONE
   ! Nothing here, errors above
 END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
Index: gcc/testsuite/gfortran.dg/typebound_call_21.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_21.f03	(revision 193137)
+++ gcc/testsuite/gfortran.dg/typebound_call_21.f03	(working copy)
@@ -27,7 +27,7 @@ end module m
 
 
   use m
-  class(t), allocatable :: x
+  class(t), pointer :: x
   allocate(x)
   call x%testsub()
   print *,x%testfun()
Index: gcc/testsuite/gfortran.dg/finalize_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_4.f03	(revision 193137)
+++ gcc/testsuite/gfortran.dg/finalize_4.f03	(working copy)
@@ -1,4 +1,4 @@
-! { dg-do compile }
+! { dg-do run }
 
 ! Parsing of finalizer procedure definitions.
 ! Check parsing of valid finalizer definitions.
@@ -48,6 +48,3 @@ PROGRAM finalizer
   DEALLOCATE(mat)
 
 END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
