This patch adds one auxiliary functions, which will be used when
invoking the finalization wrapper. It is currently unused.
Build on x86-64-gnu-linux.
OK for the trunk?
Tobias
2012-12-31 Tobias Burnus <bur...@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.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 452f2bc..ed95739 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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 +4356,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);
}
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 70f06ff..9296e06 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -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/allocatble,
+ 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. */
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 1779575..2818fae 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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);
