From patchwork Mon Dec 31 12:21:24 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [Fortran] FINAL (prep patches 3/5): Auxiliary functions for calling the FINAL wrapper Date: Mon, 31 Dec 2012 02:21:24 -0000 From: Tobias Burnus X-Patchwork-Id: 208851 Message-Id: <50E18344.6050007@net-b.de> To: gcc patches , gfortran 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 * 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);