Patchwork [Fortran] Enable FINALization/poly dealloc for allocatables

login
register
mail settings
Submitter Tobias Burnus
Date May 30, 2013, 10:25 a.m.
Message ID <51A72907.3030107@net-b.de>
Download mbox | patch
Permalink /patch/247524/
State New
Headers show

Comments

Tobias Burnus - May 30, 2013, 10:25 a.m.
Small update of the patch. Changes:

* There was a problem finalizing  "var(:)%comp", which lead to an ICE. 
Thanks to Dominique pointed out. See "expr->rank =" code added in 
gfc_add_finalizer_call. I added the full test case from PR37336 (dg-do 
compile: finalize_14.f90) to test for this.

* I added a new test case, which ensures that the built-in scalarizer 
and packer works correctly (it did), see finalize_13.f90.

The latter test case depends on the patch posted at: 
http://gcc.gnu.org/ml/fortran/2013-05/msg00114.html
[As Domique has pointed out, I forgot to change the allocate back to "t2 
::" in that test case. I will do so before committal (and change the 
malloc check to "(40)".)]


OK for the trunk?

Tobias


Tobias Burnus wrote:
> this patch enables finalization (and polymorphic deallocation) for 
> allocatables for: end of scope, DEALLOCATE and intent(out).
>
> As a side effect, an allocatable is no longer deallocated at the end 
> of the main program. (Variables declared in the main program have 
> automatically SAVE attribute; before finalization, it made no 
> difference but with finalization it is detectable. And only finalizing 
> nonfinalizable allocatables seems to be too much effort for too little 
> gain.)
...
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias
>
> PS: Fortran requires additional cases where finalization has to 
> happen; those will be added in follow-up patches.

Patch

2013-05-30  Tobias Burnus  <burnus@net-b.de>

	PR fortran/37336
	* trans-array.c (gfc_trans_dealloc_allocated): Support finalization.
	(structure_alloc_comps): Update caller.
	(gfc_trans_deferred_array): Call finalizer.
	* trans-array.h (gfc_trans_dealloc_allocated): Update prototype.
	* trans-decl.c (gfc_trans_deferred_vars): Don't deallocate/finalize
	variables of the main program.
	* trans-expr.c (gfc_conv_procedure_call): Support finalization.
	* trans-openmp.c (gfc_omp_clause_dtor,
	gfc_trans_omp_array_reduction): Update calls.
	* trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation
	of alloc components.
	* trans.c (gfc_add_finalizer_call): New function.
	(gfc_deallocate_with_status,
	gfc_deallocate_scalar_with_status): Call it
	(gfc_build_final_call): Fix handling of scalar coarrays.

2013-05-30  Tobias Burnus  <burnus@net-b.de>

	PR fortran/37336
	* gfortran.dg/finalize_12.f90: New.
	* gfortran.dg/alloc_comp_basics_1.f90: Add BLOCK for
	end of scope finalization.
	* gfortran.dg/alloc_comp_constructor_1.f90: Ditto.
	* gfortran.dg/allocatable_scalar_9.f90: Ditto.
	* gfortran.dg/auto_dealloc_2.f90: Ditto.
	* gfortran.dg/class_19.f03: Ditto.
	* gfortran.dg/coarray_lib_alloc_1.f90: Ditto.
	* gfortran.dg/coarray_lib_alloc_2.f90: Ditto.
	* gfortran.dg/extends_14.f03: Ditto.
	* gfortran.dg/move_alloc_4.f90: Ditto.
	* gfortran.dg/typebound_proc_27.f03: Ditto.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index be3a5a0..89f26d7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4834,7 +4834,8 @@  static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
 		     stmtblock_t * descriptor_block, tree * overflow,
-		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
+		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
+		     gfc_typespec *ts)
 {
   tree type;
   tree tmp;
@@ -5012,6 +5013,9 @@  gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 	  tmp = TYPE_SIZE_UNIT (tmp);
 	}
     }
+  else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
+    /* FIXME: Properly handle characters.  See PR 57456.  */
+    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
   else
     tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
 
@@ -5081,7 +5085,7 @@  gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 		    tree errlen, tree label_finish, tree expr3_elem_size,
-		    tree *nelems, gfc_expr *expr3)
+		    tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
 {
   tree tmp;
   tree pointer;
@@ -5166,7 +5170,7 @@  gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3);
+			      expr3_elem_size, nelems, expr3, ts);
 
   if (dimension)
     {
@@ -7243,7 +7247,7 @@  gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 /* Generate code to deallocate an array, if it is allocated.  */
 
 tree
-gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
 {
   tree tmp;
   tree var;
@@ -7259,7 +7263,7 @@  gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
      are already deallocated are ignored.  */
   tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
 				    NULL_TREE, NULL_TREE, NULL_TREE, true,
-				    NULL, coarray);
+				    expr, coarray);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */
@@ -7548,7 +7552,7 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    {
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
+	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	    }
 	  else if (c->attr.allocatable)
@@ -7580,7 +7584,7 @@  structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
 	        tmp = gfc_trans_dealloc_allocated (comp,
-					CLASS_DATA (c)->attr.codimension);
+					CLASS_DATA (c)->attr.codimension, NULL);
 	      else
 		{
 		  tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
@@ -8292,7 +8296,7 @@  gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
   stmtblock_t cleanup;
   locus loc;
   int rank;
-  bool sym_has_alloc_comp;
+  bool sym_has_alloc_comp, has_finalizer;
 
   sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
 			|| sym->ts.type == BT_CLASS)
@@ -8379,8 +8383,12 @@  gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
 
   /* Allocatable arrays need to be freed when they go out of scope.
      The allocatable components of pointers must not be touched.  */
-  if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
-      && !sym->attr.pointer && !sym->attr.save)
+  has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
+		   ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+  if ((!sym->attr.allocatable || !has_finalizer)
+      && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
+      && !sym->attr.pointer && !sym->attr.save
+      && !sym->ns->proc_name->attr.is_main_program)
     {
       int rank;
       rank = sym->as ? sym->as->rank : 0;
@@ -8389,10 +8397,13 @@  gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
     }
 
   if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
-      && !sym->attr.save && !sym->attr.result)
+      && !sym->attr.save && !sym->attr.result
+      && !sym->ns->proc_name->attr.is_main_program)
     {
       tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
-					 sym->attr.codimension);
+					 sym->attr.codimension,
+					 has_finalizer
+					 ? gfc_lval_expr_from_sym (sym) : NULL);
       gfc_add_expr_to_block (&cleanup, tmp);
     }
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 6f44d79..8d9e461 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -24,7 +24,7 @@  tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
 /* Generate code to initialize and allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
 bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
-			 tree, tree *, gfc_expr *);
+			 tree, tree *, gfc_expr *, gfc_typespec *);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
@@ -42,7 +42,7 @@  void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
 /* Generate entry and exit code for g77 calling convention arrays.  */
 void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
 /* Generate code to deallocate an array, if it is allocated.  */
-tree gfc_trans_dealloc_allocated (tree, bool);
+tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
 
 tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 100ec18..b0e3ffc 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3872,7 +3872,8 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 
 	      /* Deallocate when leaving the scope. Nullifying is not
 		 needed.  */
-	      if (!sym->attr.result && !sym->attr.dummy)
+	      if (!sym->attr.result && !sym->attr.dummy
+		  && !sym->ns->proc_name->attr.is_main_program)
 		{
 		  if (sym->ts.type == BT_CLASS
 		      && CLASS_DATA (sym)->attr.codimension)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 07b0fa6..9d07345 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4274,10 +4274,8 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      if (e->ts.type == BT_CLASS)
 			ptr = gfc_class_data_get (ptr);
 
-		      tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
-							NULL_TREE, NULL_TREE,
-							NULL_TREE, true, NULL,
-							false);
+		      tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
+							       true, e, e->ts);
 		      gfc_add_expr_to_block (&block, tmp);
 		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 					     void_type_node, ptr,
@@ -4409,8 +4407,8 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  else
 		    tmp = gfc_finish_block (&block);
 
-		      gfc_add_expr_to_block (&se->pre, tmp);
-}
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
 
 	      /* The conversion does not repackage the reference to a class
 	         array - _data descriptor.  */
@@ -4511,7 +4509,7 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  tmp = build_fold_indirect_ref_loc (input_location,
 						     parmse.expr);
-		  tmp = gfc_trans_dealloc_allocated (tmp, false);
+		  tmp = gfc_trans_dealloc_allocated (tmp, false, e);
 		  if (fsym->attr.optional
 		      && e->expr_type == EXPR_VARIABLE
 		      && e->symtree->n.sym->attr.optional)
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 882927e..2765561 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -325,7 +325,7 @@  gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
 
   /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
      to be deallocated if they were allocated.  */
-  return gfc_trans_dealloc_allocated (decl, false);
+  return gfc_trans_dealloc_allocated (decl, false, NULL);
 }
 
 
@@ -707,7 +707,8 @@  gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
       gfc_start_block (&block);
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
 			     true));
-      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false));
+      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false,
+								  NULL));
       stmt = gfc_finish_block (&block);
     }
   else
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 7812934..e2d0110 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4925,7 +4925,7 @@  gfc_trans_allocate (gfc_code * code)
 
       nelems = NULL_TREE;
       if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
-			       memsz, &nelems, code->expr3))
+			       memsz, &nelems, code->expr3, &code->ext.alloc.ts))
 	{
 	  bool unlimited_char;
 
@@ -5398,7 +5398,8 @@  gfc_trans_deallocate (gfc_code *code)
 
       if (expr->rank || gfc_is_coarray (expr))
 	{
-	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
+	      && !gfc_is_finalizable (expr->ts.u.derived, NULL))
 	    {
 	      gfc_ref *ref;
 	      gfc_ref *last = NULL;
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 8211573..00deee3 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -838,6 +838,115 @@  gfc_call_free (tree var)
 }
 
 
+/* Add a call to the finalizer, using the passed *expr. Returns
+   true when a finalizer call has been inserted.  */
+
+static bool
+gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
+{
+  tree tmp;
+  gfc_ref *ref;
+  gfc_expr *expr;
+  gfc_expr *final_expr = NULL;
+  gfc_expr *elem_size = NULL;
+  bool has_finalizer = false;
+
+  if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
+    return false;
+
+  if (expr2->ts.type == BT_DERIVED)
+    {
+      gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
+      if (!final_expr)
+        return false;
+    }
+
+  /* If we have a class array, we need go back to the class
+     container. */
+  expr = gfc_copy_expr (expr2);
+
+  if (expr->ref && expr->ref->next && !expr->ref->next->next
+      && expr->ref->next->type == REF_ARRAY
+      && expr->ref->type == REF_COMPONENT
+      && strcmp (expr->ref->u.c.component->name, "_data") == 0)
+    {
+      gfc_free_ref_list (expr->ref);
+      expr->ref = NULL;
+    }
+  else
+    for (ref = expr->ref; ref; ref = ref->next)
+      if (ref->next && ref->next->next && !ref->next->next->next
+         && ref->next->next->type == REF_ARRAY
+         && ref->next->type == REF_COMPONENT
+         && strcmp (ref->next->u.c.component->name, "_data") == 0)
+       {
+         gfc_free_ref_list (ref->next);
+         ref->next = NULL;
+       }
+
+  if (expr->ts.type == BT_CLASS)
+    {
+      has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
+
+      if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
+	expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
+
+      final_expr = gfc_copy_expr (expr);
+      gfc_add_vptr_component (final_expr);
+      gfc_add_component_ref (final_expr, "_final");
+
+      elem_size = gfc_copy_expr (expr);
+      gfc_add_vptr_component (elem_size);
+      gfc_add_component_ref (elem_size, "_size");
+    }
+
+  gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
+
+  tmp = gfc_build_final_call (expr->ts, final_expr, expr,
+			      false, elem_size);
+
+  if (expr->ts.type == BT_CLASS && !has_finalizer)
+    {
+      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));
+
+      /* For CLASS(*) not only sym->_vtab->_final can be NULL
+	 but already sym->_vtab itself.  */
+      if (UNLIMITED_POLY (expr))
+	{
+	  tree cond2;
+	  gfc_expr *vptr_expr;
+
+	  vptr_expr = gfc_copy_expr (expr);
+	  gfc_add_vptr_component (vptr_expr);
+
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, vptr_expr);
+	  gfc_free_expr (vptr_expr);
+
+	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   se.expr,
+				   build_int_cst (TREE_TYPE (se.expr), 0));
+	  cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+				  boolean_type_node, cond2, cond);
+	}
+
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     cond, tmp, build_empty_stmt (input_location));
+    }
+
+  gfc_add_expr_to_block (block, tmp);
+
+  return true;
+}
+
 
 /* User-deallocate; we emit the code directly from the front-end, and the
    logic is the same as the previous library function:
@@ -930,6 +1039,7 @@  gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
+  gfc_add_finalizer_call (&non_null, expr);
   if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
     {
       tmp = build_call_expr_loc (input_location,
@@ -1055,17 +1165,11 @@  gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 
       gfc_init_se (&se, NULL);
       se.want_pointer = 1;
-      if (var->rank || attr.dimension
-	  || (attr.codimension && attr.allocatable
-	      && gfc_option.coarray == GFC_FCOARRAY_LIB))
+      if (var->rank)
 	{
-	  if (var->rank == 0)
-	    se.want_coarray = 1;
 	  se.descriptor_only = 1;
 	  gfc_conv_expr_descriptor (&se, var);
 	  array = se.expr;
-	  if (!POINTER_TYPE_P (TREE_TYPE (array)))
-	    array = gfc_build_addr_expr (NULL, array);
 	}
       else
 	{
@@ -1077,9 +1181,11 @@  gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 	      && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
 	    tmp = TREE_OPERAND (array, 0);
 
-	  gfc_init_se (&se, NULL);
-	  array = gfc_conv_scalar_to_descriptor (&se, array, attr);
-	  array = gfc_build_addr_expr (NULL, array);
+	  if (!attr.allocatable || !gfc_is_coarray (var))
+	    {
+	      gfc_init_se (&se, NULL);
+	      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+	    }
 	  gcc_assert (se.post.head == NULL_TREE);
 	}
     }
@@ -1095,22 +1201,15 @@  gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
       array_expr = gfc_copy_expr (var);
       gfc_init_se (&se, NULL);
       se.want_pointer = 1;
-      if (array_expr->rank || attr.dimension
-	  || (attr.codimension && attr.allocatable
-	      && gfc_option.coarray == GFC_FCOARRAY_LIB))
+      if (array_expr->rank)
 	{
 	  gfc_add_class_array_ref (array_expr);
-	  if (array_expr->rank == 0)
-	    se.want_coarray = 1;
 	  se.descriptor_only = 1;
 	  gfc_conv_expr_descriptor (&se, array_expr);
 	  array = se.expr;
-	  if (! POINTER_TYPE_P (TREE_TYPE (array)))
-	    array = gfc_build_addr_expr (NULL, array);
 	}
       else
 	{
-	  gfc_clear_attr (&attr);
 	  gfc_add_data_component (array_expr);
 	  gfc_conv_expr (&se, array_expr);
 	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
@@ -1119,16 +1218,22 @@  gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 	      && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
 	    tmp = TREE_OPERAND (array, 0);
 
-	  /* attr: Argument is neither a pointer/allocatable,
-	     i.e. no copy back needed */
-	  gfc_init_se (&se, NULL);
-	  array = gfc_conv_scalar_to_descriptor (&se, array, attr);
-	  array = gfc_build_addr_expr (NULL, array);
+	  if (!attr.allocatable || !gfc_is_coarray (array_expr))
+	    {
+	      /* No copy back needed, hence set attr's allocatable/pointer
+		 to zero.  */
+	      gfc_clear_attr (&attr);
+	      gfc_init_se (&se, NULL);
+	      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+	    }
 	  gcc_assert (se.post.head == NULL_TREE);
 	}
       gfc_free_expr (array_expr);
     }
 
+  if (!POINTER_TYPE_P (TREE_TYPE (array)))
+    array = gfc_build_addr_expr (NULL, array);
+
   gfc_start_block (&block);
   gfc_add_block_to_block (&block, &se.pre);
   tmp = build_call_expr_loc (input_location,
@@ -1151,6 +1256,7 @@  gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
 {
   stmtblock_t null, non_null;
   tree cond, tmp, error;
+  bool finalizable;
 
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 			  build_int_cst (TREE_TYPE (pointer), 0));
@@ -1195,20 +1301,13 @@  gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
   gfc_start_block (&non_null);
 
   /* Free allocatable components.  */
-  if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+  finalizable = gfc_add_finalizer_call (&non_null, expr);
+  if (!finalizable && 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, tmp, 0);
       gfc_add_expr_to_block (&non_null, tmp);
     }
-  else if (ts.type == BT_CLASS
-	   && ts.u.derived->components->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);
-      gfc_add_expr_to_block (&non_null, tmp);
-    }
 
   tmp = build_call_expr_loc (input_location,
 			     builtin_decl_explicit (BUILT_IN_FREE), 1,
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
index 9b08129..65724fe 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
@@ -33,8 +33,10 @@  program alloc
         integer, allocatable :: a2(:)
     end type alloc2
 
-    type(alloc2) :: b
     integer :: i
+
+  BLOCK  ! To ensure that the allocatables are freed at the end of the scope
+    type(alloc2) :: b
     type(alloc2), allocatable :: c(:)
 
     if (allocated(b%a2) .OR. allocated(b%a1)) then
@@ -64,7 +66,7 @@  program alloc
     deallocate(c)
 
     ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope)
-
+  END BLOCK
 contains
 
     subroutine allocate_alloc2(b)
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
index 969e703..8003c05 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
@@ -19,9 +19,12 @@  Program test_constructor
         type(thytype), allocatable :: q(:)
     end type mytype
 
-    type (mytype) :: x

     type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
     integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
+

+  BLOCK ! Add scoping unit as the vars are otherwise implicitly SAVEd

+

+    type (mytype) :: x

     integer, allocatable :: yy(:,:)
     type (thytype), allocatable :: bar(:)
     integer :: i
@@ -70,7 +73,7 @@  Program test_constructor
 
     ! Check that passing the constructor to a procedure works
     call check_mytype (mytype(y, [foo, foo]))
-

+  END BLOCK

 contains
 
     subroutine check_mytype(x)
diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
index 3488c0d..fd0b4db 100644
--- a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
@@ -28,10 +28,12 @@  end type t4
 end module m
 
 use m
+block ! Start new scoping unit as otherwise the vars are implicitly SAVEd
 type(t1) :: na1, a1, aa1(:)
 type(t2) :: na2, a2, aa2(:)
 type(t3) :: na3, a3, aa3(:)
 type(t4) :: na4, a4, aa4(:)
+
 allocatable :: a1, a2, a3, a4, aa1, aa2, aa3,aa4
 
 if(allocated(a1)) call abort()
@@ -47,6 +49,7 @@  if(allocated(na1%b1)) call abort()
 if(allocated(na2%b2)) call abort()
 if(allocated(na3%b3)) call abort()
 if(allocated(na4%b4)) call abort()
+end block
 end
 
 ! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index d261973..f47ec87 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -11,11 +11,12 @@  type :: t
   integer, allocatable :: i(:)
 end type
 
+block ! New block as the main program implies SAVE
 type(t) :: a
 
 call init(a)
 call init(a)
-
+end block
 contains
 
   subroutine init(x)
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
index c0d06a4..926d531 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
@@ -4,6 +4,7 @@ 
 ! Allocate/deallocate with libcaf.
 !
 
+ subroutine test()
  integer(4), allocatable :: xx[:], yy(:)[:]
  integer :: stat
  character(len=200) :: errmsg
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
index 3aaff1e..472e0be 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
@@ -4,6 +4,7 @@ 
 ! Allocate/deallocate with libcaf.
 !
 
+ subroutine test()
  type t
  end type t
  class(t), allocatable :: xx[:], yy(:)[:]
diff --git a/gcc/testsuite/gfortran.dg/extends_14.f03 b/gcc/testsuite/gfortran.dg/extends_14.f03
index 876e8c7..15e38ff 100644
--- a/gcc/testsuite/gfortran.dg/extends_14.f03
+++ b/gcc/testsuite/gfortran.dg/extends_14.f03
@@ -16,12 +16,13 @@  program evolve_aflow
   type, extends(state_t) :: astate_t
   end type
 
+ block ! New scoping unit as "a"/"b" are otherwise implicitly SAVEd
   type(astate_t) :: a,b
 
   allocate(a%U(1000))
 
   a = b
-
+ end block
 end program 
 
 ! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_4.f90 b/gcc/testsuite/gfortran.dg/move_alloc_4.f90
index 4dc493f..b23ef70 100644
--- a/gcc/testsuite/gfortran.dg/move_alloc_4.f90
+++ b/gcc/testsuite/gfortran.dg/move_alloc_4.f90
@@ -10,13 +10,14 @@  program testmv3
     integer, allocatable  :: ia(:), ja(:)
   end type
 
+ block ! For auto-dealloc, as PROGRAM implies SAVE
   type(bar), allocatable :: sm,sm2
 
   allocate(sm)
   allocate(sm%ia(10),sm%ja(10))
 
   call move_alloc(sm2,sm)
-
+ end block
 end program testmv3 
 
 ! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_27.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03
index 28c44df..ce845a0 100644
--- a/gcc/testsuite/gfortran.dg/typebound_proc_27.f03
+++ b/gcc/testsuite/gfortran.dg/typebound_proc_27.f03
@@ -33,6 +33,7 @@  program prog
 
   use m
 
+ block ! Start new scoping unit as PROGRAM implies SAVE
   type(tx) :: this
   type(tx), target :: that
   type(tx), pointer :: p
@@ -64,6 +65,7 @@  program prog
   !print *,this%i
   if(any (this%i /= [8, 9])) call abort()
 
+ end block
 end program prog
 
 !
--- /dev/null	2013-05-30 08:32:37.588061020 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_12.f90	2013-05-30 12:09:03.928265984 +0200
@@ -0,0 +1,175 @@ 
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/37336
+!
+module m
+  implicit none
+  type t
+    integer :: i
+  contains
+    final :: fini, fini2
+  end type t
+  integer :: global_count1, global_count2
+contains
+  subroutine fini(x)
+    type(t) :: x
+    !print *, 'fini:',x%i
+    if (global_count1 == -1) call abort ()
+    if (x%i /= 42) call abort() 
+    x%i = 33
+    global_count1 = global_count1 + 1
+  end subroutine fini
+  subroutine fini2(x)
+    type(t) :: x(:)
+    !print *, 'fini2', x%i
+    if (global_count2 == -1) call abort ()
+    if (size(x) /= 5) call abort()
+    if (any (x%i /= [1,2,3,4,5]) .and. any (x%i /= [6,7,8,9,10])) call abort() 
+    x%i = 33
+    global_count2 = global_count2 + 10
+  end subroutine fini2
+end module m
+
+program pp
+  use m
+  implicit none
+  type(t), allocatable :: ya
+  class(t), allocatable :: yc
+  type(t), allocatable :: yaa(:)
+  class(t), allocatable :: yca(:)
+
+  type(t), allocatable :: ca[:]
+  class(t), allocatable :: cc[:]
+  type(t), allocatable :: caa(:)[:]
+  class(t), allocatable :: cca(:)[:]
+
+  global_count1 = -1
+  global_count2 = -1
+  allocate (ya, yc, yaa(5), yca(5))
+  global_count1 = 0
+  global_count2 = 0
+  ya%i = 42
+  yc%i = 42
+  yaa%i = [1,2,3,4,5]
+  yca%i = [1,2,3,4,5]
+
+  call foo(ya, yc, yaa, yca)
+  if (global_count1 /= 2) call abort ()
+  if (global_count2 /= 20) call abort ()
+
+  ! Coarray finalization
+  allocate (ca[*], cc[*], caa(5)[*], cca(5)[*])
+  global_count1 = 0
+  global_count2 = 0
+  ca%i = 42
+  cc%i = 42
+  caa%i = [1,2,3,4,5]
+  cca%i = [1,2,3,4,5]
+  deallocate (ca, cc, caa, cca)
+  if (global_count1 /= 2) call abort ()
+  if (global_count2 /= 20) call abort ()
+  global_count1 = -1
+  global_count2 = -1
+
+  block
+    type(t), allocatable :: za
+    class(t), allocatable :: zc
+    type(t), allocatable :: zaa(:)
+    class(t), allocatable :: zca(:)
+
+    ! Test intent(out) finalization
+    allocate (za, zc, zaa(5), zca(5))
+    global_count1 = 0
+    global_count2 = 0
+    za%i = 42
+    zc%i = 42
+    zaa%i = [1,2,3,4,5]
+    zca%i = [1,2,3,4,5]
+
+    call foo(za, zc, zaa, zca)
+    if (global_count1 /= 2) call abort ()
+    if (global_count2 /= 20) call abort ()
+
+    ! Test intent(out) finalization with optional
+    call foo_opt()
+    call opt()
+
+    ! Test intent(out) finalization with optional
+    allocate (za, zc, zaa(5), zca(5))
+    global_count1 = 0
+    global_count2 = 0
+    za%i = 42
+    zc%i = 42
+    zaa%i = [1,2,3,4,5]
+    zca%i = [1,2,3,4,5]
+
+    call foo_opt(za, zc, zaa, zca)
+    if (global_count1 /= 2) call abort ()
+    if (global_count2 /= 20) call abort ()
+
+    ! Test DEALLOCATE finalization
+    allocate (za, zc, zaa(5), zca(5))
+    global_count1 = 0
+    global_count2 = 0
+    za%i = 42
+    zc%i = 42
+    zaa%i = [1,2,3,4,5]
+    zca%i = [6,7,8,9,10]
+    deallocate (za, zc, zaa, zca)
+    if (global_count1 /= 2) call abort ()
+    if (global_count2 /= 20) call abort ()
+
+    ! Test end-of-scope finalization
+    allocate (za, zc, zaa(5), zca(5))
+    global_count1 = 0
+    global_count2 = 0
+    za%i = 42
+    zc%i = 42
+    zaa%i = [1,2,3,4,5]
+    zca%i = [6,7,8,9,10]
+  end block
+
+  if (global_count1 /= 2) call abort ()
+  if (global_count2 /= 20) call abort ()
+ 
+  ! Test that no end-of-scope finalization occurs
+  ! for SAVED variable in main
+  allocate (ya, yc, yaa(5), yca(5))
+  global_count1 = -1
+  global_count2 = -1
+
+contains
+
+  subroutine opt(xa, xc, xaa, xca)
+    type(t),  allocatable, optional :: xa
+    class(t), allocatable, optional :: xc
+    type(t),  allocatable, optional :: xaa(:)
+    class(t), allocatable, optional :: xca(:)
+    call foo_opt(xc, xc, xaa)
+    !call foo_opt(xa, xc, xaa, xca) ! FIXME: Fails (ICE) due to PR 57445
+  end subroutine opt
+  subroutine foo_opt(xa, xc, xaa, xca)
+    type(t),  allocatable, intent(out), optional :: xa
+    class(t), allocatable, intent(out), optional :: xc
+    type(t),  allocatable, intent(out), optional :: xaa(:)
+    class(t), allocatable, intent(out), optional :: xca(:)
+
+    if (.not. present(xa)) &
+      return
+    if (allocated (xa)) call abort ()
+    if (allocated (xc)) call abort ()
+    if (allocated (xaa)) call abort ()
+    if (allocated (xca)) call abort ()
+  end subroutine foo_opt
+  subroutine foo(xa, xc, xaa, xca)
+    type(t),  allocatable, intent(out) :: xa
+    class(t), allocatable, intent(out) :: xc
+    type(t),  allocatable, intent(out) :: xaa(:)
+    class(t), allocatable, intent(out) :: xca(:)
+    if (allocated (xa)) call abort ()
+    if (allocated (xc)) call abort ()
+    if (allocated (xaa)) call abort ()
+    if (allocated (xca)) call abort ()
+  end subroutine foo
+end program
--- /dev/null	2013-05-30 08:32:37.588061020 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_13.f90	2013-05-30 11:14:23.121847304 +0200
@@ -0,0 +1,161 @@ 
+! { dg-do run }
+!
+! PR fortran/37336
+!
+module m
+  implicit none
+  type t
+    integer :: i
+  contains
+    final :: fini3, fini2, fini_elm
+  end type t
+
+  type, extends(t) :: t2
+    integer :: j
+  contains
+    final :: f2ini2, f2ini_elm
+  end type t2
+
+  logical :: elem_call
+  logical :: rank2_call
+  logical :: rank3_call
+  integer :: cnt, cnt2
+  integer :: fini_call
+
+contains
+  subroutine fini2 (x)
+    type(t), intent(in), contiguous :: x(:,:)
+    if (.not. rank2_call) call abort ()
+    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+    !print *, 'fini2:', x%i
+    if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
+    fini_call = fini_call + 1
+  end subroutine
+
+  subroutine fini3 (x)
+    type(t), intent(in) :: x(2,2,*)
+    integer :: i,j,k
+    if (.not. elem_call) call abort ()
+    if (.not. rank3_call) call abort ()
+    if (cnt2 /= 9) call abort()
+    if (cnt /= 1) call abort()
+      do i = 1, 2
+        do j = 1, 2
+          do k = 1, 2
+            !print *, k,j,i,x(k,j,i)%i
+            if (x(k,j,i)%i /= k+10*j+100*i) call abort()
+          end do 
+        end do
+      end do
+    fini_call = fini_call + 1
+  end subroutine
+
+  impure elemental subroutine fini_elm (x)
+    type(t), intent(in) :: x
+    if (.not. elem_call) call abort ()
+    if (rank3_call) call abort ()
+    if (cnt2 /= 6) call abort()
+    if (cnt /= x%i) call abort()
+    !print *, 'fini_elm:', cnt, x%i
+    fini_call = fini_call + 1
+    cnt = cnt + 1
+  end subroutine
+
+  subroutine f2ini2 (x)
+    type(t2), intent(in), target :: x(:,:)
+    if (.not. rank2_call) call abort ()
+    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
+    !print *, 'f2ini2:', x%i
+    !print *, 'f2ini2:', x%j
+    if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
+    if (any (x%j /= 100*reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
+    fini_call = fini_call + 1
+  end subroutine
+
+  impure elemental subroutine f2ini_elm (x)
+    type(t2), intent(in) :: x
+    integer, parameter :: exprected(*) &
+            = [111, 112, 121, 122, 211, 212, 221, 222]
+
+    if (.not. elem_call) call abort ()
+    !print *, 'f2ini_elm:', cnt2, x%i, x%j
+    if (rank3_call) then
+      if (x%i /= exprected(cnt2)) call abort ()  
+      if (x%j /= 1000*exprected(cnt2)) call abort ()  
+    else
+      if (cnt2 /= x%i .or. cnt2*10 /= x%j) call abort()
+    end if
+    cnt2 = cnt2 + 1
+    fini_call = fini_call + 1
+  end subroutine
+end module m
+
+
+program test
+  use m
+  implicit none
+  class(t), save, allocatable :: y(:), z(:,:), zz(:,:,:)
+  target :: z, zz
+  integer :: i,j,k
+
+  elem_call = .false.
+  rank2_call = .false.
+  rank3_call = .false.
+  allocate (t2 :: y(5))
+  select type (y)
+    type is (t2)
+      do i = 1, 5
+        y(i)%i = i
+        y(i)%j = i*10
+      end do
+  end select
+  cnt = 1
+  cnt2 = 1
+  fini_call = 0
+  elem_call = .true.
+  deallocate (y)
+  if (fini_call /= 10) call abort ()
+
+  elem_call = .false.
+  rank2_call = .false.
+  rank3_call = .false.
+  allocate (t2 :: z(2,3))
+  select type (z)
+    type is (t2)
+      do i = 1, 3
+        do j = 1, 2
+          z(j,i)%i = j+10*i
+          z(j,i)%j = (j+10*i)*100
+        end do
+      end do
+  end select
+  cnt = 1
+  cnt2 = 1
+  fini_call = 0
+  rank2_call = .true.
+  deallocate (z)
+  if (fini_call /= 2) call abort ()
+
+  elem_call = .false.
+  rank2_call = .false.
+  rank3_call = .false.
+  allocate (t2 :: zz(2,2,2))
+  select type (zz)
+    type is (t2)
+      do i = 1, 2
+        do j = 1, 2
+          do k = 1, 2
+            zz(k,j,i)%i = k+10*j+100*i
+            zz(k,j,i)%j = (k+10*j+100*i)*1000
+          end do 
+        end do
+      end do
+  end select
+  cnt = 1
+  cnt2 = 1
+  fini_call = 0
+  rank3_call = .true.
+  elem_call = .true.
+  deallocate (zz)
+  if (fini_call /= 2*2*2+1) call abort ()
+end program test
--- /dev/null	2013-05-30 08:32:37.588061020 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_14.f90	2013-05-30 11:40:24.611148683 +0200
@@ -0,0 +1,220 @@ 
+! { dg-do compile }
+!
+! PR fortran/37336
+!
+! Started to fail when finalization was added.
+!
+! Contributed by  Ian Chivers  in PR fortran/44465
+! 
+module shape_module
+
+  type shape_type
+    integer   :: x_=0
+    integer   :: y_=0
+    contains
+    procedure , pass(this) :: getx
+    procedure , pass(this) :: gety
+    procedure , pass(this) :: setx
+    procedure , pass(this) :: sety
+    procedure , pass(this) :: moveto
+    procedure , pass(this) :: draw
+  end type shape_type
+
+interface assignment(=)
+  module procedure generic_shape_assign
+end interface
+
+contains
+
+  integer function getx(this)
+    implicit none
+    class (shape_type) , intent(in) :: this
+    getx=this%x_
+  end function getx
+
+  integer function gety(this)
+    implicit none
+    class (shape_type) , intent(in) :: this
+    gety=this%y_
+  end function gety
+
+  subroutine setx(this,x)
+    implicit none
+    class (shape_type), intent(inout) :: this
+    integer , intent(in) :: x
+    this%x_=x
+  end subroutine setx
+
+  subroutine sety(this,y)
+    implicit none
+    class (shape_type), intent(inout) :: this
+    integer , intent(in) :: y
+    this%y_=y
+  end subroutine sety
+
+  subroutine moveto(this,newx,newy)
+    implicit none
+    class (shape_type), intent(inout) :: this
+    integer , intent(in) :: newx
+    integer , intent(in) :: newy
+    this%x_=newx
+    this%y_=newy
+  end subroutine moveto
+
+  subroutine draw(this)
+    implicit none
+    class (shape_type), intent(in) :: this
+    print *,' x = ' , this%x_
+    print *,' y = ' , this%y_
+  end subroutine draw
+
+  subroutine generic_shape_assign(lhs,rhs)
+  implicit none
+    class (shape_type) , intent(out) , allocatable :: lhs
+    class (shape_type) , intent(in) :: rhs
+      print *,' In generic_shape_assign'
+      if ( allocated(lhs) ) then
+        deallocate(lhs)
+      end if
+      allocate(lhs,source=rhs)
+  end subroutine generic_shape_assign
+  
+end module shape_module
+
+! Circle_p.f90
+
+module circle_module
+
+use shape_module
+
+type , extends(shape_type) :: circle_type
+
+  integer :: radius_
+
+  contains
+
+  procedure , pass(this) :: getradius
+  procedure , pass(this) :: setradius
+  procedure , pass(this) :: draw => draw_circle
+
+end type circle_type
+
+  contains
+
+  integer function getradius(this)
+  implicit none
+  class (circle_type) , intent(in) :: this
+    getradius=this%radius_
+  end function getradius
+
+  subroutine setradius(this,radius)
+  implicit none
+  class (circle_type) , intent(inout) :: this
+  integer , intent(in) :: radius
+    this%radius_=radius
+  end subroutine setradius
+
+  subroutine draw_circle(this)
+  implicit none
+    class (circle_type), intent(in) :: this
+    print *,' x = ' , this%x_
+    print *,' y = ' , this%y_
+    print *,' radius = ' , this%radius_
+  end subroutine draw_circle
+
+end module circle_module
+
+
+! Rectangle_p.f90
+
+module rectangle_module
+
+use shape_module
+
+type , extends(shape_type) :: rectangle_type
+
+  integer :: width_
+  integer :: height_
+
+  contains
+
+  procedure , pass(this) :: getwidth
+  procedure , pass(this) :: setwidth
+  procedure , pass(this) :: getheight
+  procedure , pass(this) :: setheight
+  procedure , pass(this) :: draw => draw_rectangle
+
+end type rectangle_type
+
+  contains
+
+  integer function getwidth(this)
+  implicit none
+  class (rectangle_type) , intent(in) :: this
+    getwidth=this%width_
+  end function getwidth
+
+  subroutine setwidth(this,width)
+  implicit none
+  class (rectangle_type) , intent(inout) :: this
+  integer , intent(in) :: width
+    this%width_=width
+  end subroutine setwidth
+
+  integer function getheight(this)
+  implicit none
+  class (rectangle_type) , intent(in) :: this
+    getheight=this%height_
+  end function getheight
+
+  subroutine setheight(this,height)
+  implicit none
+  class (rectangle_type) , intent(inout) :: this
+  integer , intent(in) :: height
+    this%height_=height
+  end subroutine setheight
+
+  subroutine draw_rectangle(this)
+  implicit none
+    class (rectangle_type), intent(in) :: this
+    print *,' x = ' , this%x_
+    print *,' y = ' , this%y_
+    print *,' width = ' , this%width_
+    print *,' height = ' , this%height_
+
+  end subroutine draw_rectangle
+
+end module rectangle_module
+
+
+
+program polymorphic
+
+use shape_module
+use circle_module
+use rectangle_module
+
+implicit none
+
+type shape_w
+  class (shape_type) , allocatable :: shape_v
+end type shape_w
+
+type (shape_w) , dimension(3) :: p
+
+  print *,' shape '
+
+  p(1)%shape_v=shape_type(10,20)
+  call p(1)%shape_v%draw()
+
+  print *,' circle '
+
+  p(2)%shape_v=circle_type(100,200,300)
+  call p(2)%shape_v%draw()
+
+  print *,' rectangle '
+
+  p(3)%shape_v=rectangle_type(1000,2000,3000,4000)
+  call p(3)%shape_v%draw()
+
+end program polymorphic