trans.c (gfc_build_final_call): New function.

2013-01-04  Tobias Burnus  <burnus@net-b.de>

        * trans.c (gfc_build_final_call): New function.
        * trans.h (gfc_build_final_call, gfc_conv_scalar_to_descriptor):
        New function prototypes.
        * trans-expr.c (gfc_conv_scalar_to_descriptor): Renamed from
        conv_scalar_to_descriptor, removed static attribute.
        (gfc_conv_procedure_call): Honor renaming.

From-SVN: r194919

gcc/fortran/ChangeLog

 2013-01-04  Tobias Burnus  <burnus@net-b.de>
 
+	* trans.c (gfc_build_final_call): New function.
+	* trans.h (gfc_build_final_call, gfc_conv_scalar_to_descriptor):
+	New function prototypes.
+	* trans-expr.c (gfc_conv_scalar_to_descriptor): Renamed from
+	conv_scalar_to_descriptor, removed static attribute.
+	(gfc_conv_procedure_call): Honor renaming.
+
+2013-01-04  Tobias Burnus  <burnus@net-b.de>
+
 	* intrinsic.c (add_functions): New internal intrinsic
 	function GFC_PREFIX ("stride").
 	* gfortran.h (gfc_isym_id): Add GFC_ISYM_STRIDE.

gcc/fortran/trans-expr.c

 /* Expression translation
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011, 2012
+   2011, 2012, 2013
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -61,8 +61,8 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
 				    akind, !(attr.pointer || attr.target));
 }
 
-static tree
-conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
+tree
+gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 {
   tree desc, type;
 
@@ -4355,8 +4355,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      if (TREE_CODE (tmp) == ADDR_EXPR
 			  && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
 			tmp = TREE_OPERAND (tmp, 0);
-		      parmse.expr = conv_scalar_to_descriptor (&parmse, tmp,
-							       fsym->attr);
+		      parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
+								   fsym->attr);
 		      parmse.expr = gfc_build_addr_expr (NULL_TREE,
 							 parmse.expr);
 		    }

gcc/fortran/trans.c

 /* Code translation -- generate GCC trees from gfc_code.
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011, 2012 Free Software Foundation, Inc.
+   2011, 2012, 2013 Free Software Foundation, Inc.
    Contributed by Paul Brook
 
 This file is part of GCC.
@@ -1023,6 +1023,116 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 }
 
 
+/* Build a call to a FINAL procedure, which finalizes "var".  */
+
+tree
+gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
+		      bool fini_coarray, gfc_expr *class_size)
+{
+  stmtblock_t block;
+  gfc_se se;
+  tree final_fndecl, array, size, tmp;
+
+  gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
+  gcc_assert (var);
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr (&se, final_wrapper);
+  final_fndecl = se.expr;
+  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
+
+  if (ts.type == BT_DERIVED)
+    {
+      tree elem_size;
+
+      gcc_assert (!class_size);
+      elem_size = gfc_typenode_for_spec (&ts);
+      elem_size = TYPE_SIZE_UNIT (elem_size);
+      size = fold_convert (gfc_array_index_type, elem_size);
+
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      if (var->rank || gfc_expr_attr (var).dimension)
+	{
+	  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
+	{
+	  symbol_attribute attr;
+	  gfc_clear_attr (&attr);
+	  gfc_conv_expr (&se, var);
+	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+	  array = se.expr;
+	  if (TREE_CODE (array) == ADDR_EXPR
+	      && 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);
+	  gcc_assert (se.post.head == NULL_TREE);
+	}
+    }
+  else
+    {
+      gfc_expr *array_expr;
+      gcc_assert (class_size);
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, class_size);
+      gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+      size = se.expr;
+
+      array_expr = gfc_copy_expr (var);
+      gfc_add_data_component (array_expr);
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      if (array_expr->rank || gfc_expr_attr (array_expr).dimension)
+	{
+	  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
+	{
+	  symbol_attribute attr;
+
+	  gfc_clear_attr (&attr);
+	  gfc_conv_expr (&se, array_expr);
+	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+	  array = se.expr;
+	  if (TREE_CODE (array) == ADDR_EXPR
+	      && 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);
+	  gcc_assert (se.post.head == NULL_TREE);
+	}
+      gfc_free_expr (array_expr);
+    }
+
+  gfc_start_block (&block);
+  gfc_add_block_to_block (&block, &se.pre);
+  tmp = build_call_expr_loc (input_location,
+			     final_fndecl, 3, array,
+			     size, fini_coarray ? boolean_true_node
+						: boolean_false_node);
+  gfc_add_block_to_block (&block, &se.post);
+  gfc_add_expr_to_block (&block, tmp);
+  return gfc_finish_block (&block);
+}
+
+
 /* Generate code for deallocation of allocatable scalars (variables or
    components). Before the object itself is freed, any allocatable
    subcomponents are being deallocated.  */

gcc/fortran/trans.h

 /* Header for code translation functions
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011, 2012
+   2011, 2012, 2013
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -352,6 +352,8 @@ 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 *, bool,
+			   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,
@@ -403,6 +405,9 @@ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr);
 void gfc_conv_expr_reference (gfc_se * se, gfc_expr *);
 void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
 
+tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
+
+
 /* trans-expr.c */
 void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
 tree gfc_string_to_single_character (tree len, tree str, int kind);