some functions. See processing for N_Subprogram_Body. */
static GTY(()) VEC(tree,gc) *gnu_return_label_stack;
+/* Stack of variable for the return value of a function with copy-in/copy-out
+ parameters. See processing for N_Subprogram_Body. */
+static GTY(()) VEC(tree,gc) *gnu_return_var_stack;
+
/* Stack of LOOP_STMT nodes. */
static GTY(()) VEC(tree,gc) *gnu_loop_label_stack;
tree gnu_subprog_decl;
/* Its RESULT_DECL node. */
tree gnu_result_decl;
- /* The FUNCTION_TYPE node corresponding to the subprogram spec. */
+ /* Its FUNCTION_TYPE node. */
tree gnu_subprog_type;
+ /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
tree gnu_cico_list;
+ /* The entry in the CI_CO_LIST that represents a function return, if any. */
+ tree gnu_return_var_elmt = NULL_TREE;
tree gnu_result;
VEC(parm_attr,gc) *cache;
&& !present_gnu_tree (gnat_subprog_id));
gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
+ gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
+ if (gnu_cico_list)
+ gnu_return_var_elmt = value_member (void_type_node, gnu_cico_list);
/* If the function returns by invisible reference, make it explicit in the
- function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
- if (TREE_ADDRESSABLE (gnu_subprog_type))
+ function body. See gnat_to_gnu_entity, E_Subprogram_Type case.
+ Handle the explicit case here and the copy-in/copy-out case below. */
+ if (TREE_ADDRESSABLE (gnu_subprog_type) && !gnu_return_var_elmt)
{
TREE_TYPE (gnu_result_decl)
= build_reference_type (TREE_TYPE (gnu_result_decl));
/* If there are In Out or Out parameters, we need to ensure that the return
statement properly copies them out. We do this by making a new block and
converting any return into a goto to a label at the end of the block. */
- gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
if (gnu_cico_list)
{
+ tree gnu_return_var = NULL_TREE;
+
VEC_safe_push (tree, gc, gnu_return_label_stack,
create_artificial_label (input_location));
start_stmt_group ();
gnat_pushlevel ();
+ /* If this is a function with In Out or Out parameters, we also need a
+ variable for the return value to be placed. */
+ if (gnu_return_var_elmt)
+ {
+ tree gnu_return_type
+ = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
+
+ /* If the function returns by invisible reference, make it
+ explicit in the function body. See gnat_to_gnu_entity,
+ E_Subprogram_Type case. */
+ if (TREE_ADDRESSABLE (gnu_subprog_type))
+ gnu_return_type = build_reference_type (gnu_return_type);
+
+ gnu_return_var
+ = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
+ gnu_return_type, NULL_TREE, false, false,
+ false, false, NULL, gnat_subprog_id);
+ TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
+ }
+
+ VEC_safe_push (tree, gc, gnu_return_var_stack, gnu_return_var);
+
/* See whether there are parameters for which we don't have a GCC tree
yet. These must be Out parameters. Make a VAR_DECL for them and
put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
if (DECL_FUNCTION_STUB (gnu_subprog_decl))
build_function_stub (gnu_subprog_decl, gnat_subprog_id);
+ if (gnu_return_var_elmt)
+ TREE_VALUE (gnu_return_var_elmt) = void_type_node;
+
mark_out_of_scope (Defining_Unit_Name (Specification (gnat_node)));
}
\f
+
+/* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
+ Put the initialization statement into GNU_INIT_STMT and annotate it with
+ the SLOC of GNAT_NODE. Return the temporary variable. */
+
+static tree
+create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
+ Node_Id gnat_node)
+{
+ tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
+ TREE_TYPE (gnu_init), NULL_TREE, false,
+ false, false, false, NULL, Empty);
+ DECL_ARTIFICIAL (gnu_temp) = 1;
+ DECL_IGNORED_P (gnu_temp) = 1;
+
+ *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
+ set_expr_location_from_node (*gnu_init_stmt, gnat_node);
+
+ return gnu_temp;
+}
+
/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
tree gnu_name_list = NULL_TREE;
tree gnu_before_list = NULL_TREE;
tree gnu_after_list = NULL_TREE;
- tree gnu_call;
+ tree gnu_call, gnu_result;
+ bool returning_value = (Nkind (gnat_node) == N_Function_Call && !gnu_target);
+ bool pushed_binding_level = false;
bool went_into_elab_proc = false;
gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE);
gnat_actual = Next_Actual (gnat_actual))
add_stmt (gnat_to_gnu (gnat_actual));
- if (Nkind (gnat_node) == N_Function_Call && !gnu_target)
+ if (returning_value)
{
*gnu_result_type_p = TREE_TYPE (gnu_subprog_type);
return build1 (NULL_EXPR, TREE_TYPE (gnu_subprog_type), call_expr);
else
gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node)));
- /* If we are translating a statement, open a new nesting level that will
- surround it to declare the temporaries created for the call. */
- if (Nkind (gnat_node) == N_Procedure_Call_Statement || gnu_target)
+ /* If we are translating a statement, push a new binding level that will
+ surround it to declare the temporaries created for the call. Likewise
+ if we'll be returning a value and also have copy-in/copy-out parameters,
+ as we need to create statements to fetch their value after the call.
+
+ ??? We could do that unconditionally, but the middle-end doesn't seem
+ to be prepared to handle the construct in nested contexts. */
+ if (!returning_value || TYPE_CI_CO_LIST (gnu_subprog_type))
{
start_stmt_group ();
gnat_pushlevel ();
+ pushed_binding_level = true;
}
/* The lifetime of the temporaries created for the call ends with the call
so we can give them the scope of the elaboration routine at top level. */
- else if (!current_function_decl)
+ if (!current_function_decl)
{
current_function_decl = get_elaboration_procedure ();
went_into_elab_proc = true;
&& (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
&& !addressable_p (gnu_name, gnu_name_type))
{
+ bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
/* Do not issue warnings for CONSTRUCTORs since this is not a copy
TREE_TYPE (gnu_name))))
gnu_name = convert (gnu_name_type, gnu_name);
+ /* If we haven't pushed a binding level and this is an In Out or Out
+ parameter, push a new one. This is needed to wrap the copy-back
+ statements we'll be making below. */
+ if (!pushed_binding_level && !in_param)
+ {
+ start_stmt_group ();
+ gnat_pushlevel ();
+ pushed_binding_level = true;
+ }
+
/* Create an explicit temporary holding the copy. This ensures that
its lifetime is as narrow as possible around a statement. */
- gnu_temp = create_var_decl (create_tmp_var_name ("A"), NULL_TREE,
- TREE_TYPE (gnu_name), NULL_TREE,
- false, false, false, false, NULL, Empty);
- DECL_ARTIFICIAL (gnu_temp) = 1;
- DECL_IGNORED_P (gnu_temp) = 1;
+ gnu_temp
+ = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual);
/* But initialize it on the fly like for an implicit temporary as
we aren't necessarily dealing with a statement. */
- gnu_stmt
- = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_name);
- set_expr_location_from_node (gnu_stmt, gnat_actual);
-
- /* From now on, the real object is the temporary. */
gnu_name = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_name), gnu_stmt,
gnu_temp);
/* Set up to move the copy back to the original if needed. */
- if (Ekind (gnat_formal) != E_In_Parameter)
+ if (!in_param)
{
gnu_stmt = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
gnu_temp);
gnu_actual_vec);
set_expr_location_from_node (gnu_call, gnat_node);
- /* If it's a function call, the result is the call expression unless a target
- is specified, in which case we copy the result into the target and return
- the assignment statement. */
- if (Nkind (gnat_node) == N_Function_Call)
- {
- tree gnu_result = gnu_call;
-
- /* If the function returns an unconstrained array or by direct reference,
- we have to dereference the pointer. */
- if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
- || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
- gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
-
- if (gnu_target)
- {
- Node_Id gnat_parent = Parent (gnat_node);
- tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
- enum tree_code op_code;
-
- /* If range check is needed, emit code to generate it. */
- if (Do_Range_Check (gnat_node))
- gnu_result
- = emit_range_check (gnu_result, Etype (Name (gnat_parent)),
- gnat_parent);
-
- /* ??? If the return type has non-constant size, then force the
- return slot optimization as we would not be able to generate
- a temporary. Likewise if it was unconstrained as we would
- copy too much data. That's what has been done historically. */
- if (!TREE_CONSTANT (TYPE_SIZE (gnu_result_type))
- || (TYPE_IS_PADDING_P (gnu_result_type)
- && CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
- op_code = INIT_EXPR;
- else
- op_code = MODIFY_EXPR;
-
- gnu_result
- = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_result);
- add_stmt_with_node (gnu_result, gnat_parent);
- gnat_poplevel ();
- gnu_result = end_stmt_group ();
- }
- else
- {
- if (went_into_elab_proc)
- current_function_decl = NULL_TREE;
- *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
- }
-
- return gnu_result;
- }
-
- /* If this is the case where the GNAT tree contains a procedure call but the
- Ada procedure has copy-in/copy-out parameters, then the special parameter
- passing mechanism must be used. */
+ /* If this is a subprogram with copy-in/copy-out parameters, we need to
+ unpack the valued returned from the function into the In Out or Out
+ parameters. We deal with the function return (if this is an Ada
+ function) below. */
if (TYPE_CI_CO_LIST (gnu_subprog_type))
{
/* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
const int length = list_length (gnu_cico_list);
+ /* The call sequence must contain one and only one call, even though the
+ function is pure. Save the result into a temporary if needed. */
if (length > 1)
{
- tree gnu_temp, gnu_stmt;
-
- /* The call sequence must contain one and only one call, even though
- the function is pure. Save the result into a temporary. */
- gnu_temp = create_var_decl (create_tmp_var_name ("R"), NULL_TREE,
- TREE_TYPE (gnu_call), NULL_TREE, false,
- false, false, false, NULL, Empty);
- DECL_ARTIFICIAL (gnu_temp) = 1;
- DECL_IGNORED_P (gnu_temp) = 1;
-
- gnu_stmt
- = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_call);
- set_expr_location_from_node (gnu_stmt, gnat_node);
-
- /* Add the call statement to the list and start from its result. */
+ tree gnu_stmt;
+ gnu_call
+ = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node);
append_to_statement_list (gnu_stmt, &gnu_before_list);
- gnu_call = gnu_temp;
gnu_name_list = nreverse (gnu_name_list);
}
+ /* The first entry is for the actual return value if this is a
+ function, so skip it. */
+ if (TREE_VALUE (gnu_cico_list) == void_type_node)
+ gnu_cico_list = TREE_CHAIN (gnu_cico_list);
+
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
else
Present (gnat_actual);
gnat_formal = Next_Formal_With_Extras (gnat_formal),
gnat_actual = Next_Actual (gnat_actual))
- /* If we are dealing with a copy in copy out parameter, we must
+ /* If we are dealing with a copy-in/copy-out parameter, we must
retrieve its value from the record returned in the call. */
if (!(present_gnu_tree (gnat_formal)
&& TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
gnu_name_list = TREE_CHAIN (gnu_name_list);
}
}
- else
+
+ /* If this is a function call, the result is the call expression unless a
+ target is specified, in which case we copy the result into the target
+ and return the assignment statement. */
+ if (Nkind (gnat_node) == N_Function_Call)
+ {
+ tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
+
+ /* If this is a function with copy-in/copy-out parameters, extract the
+ return value from it and update the return type. */
+ if (TYPE_CI_CO_LIST (gnu_subprog_type))
+ {
+ tree gnu_elmt = value_member (void_type_node,
+ TYPE_CI_CO_LIST (gnu_subprog_type));
+ gnu_call = build_component_ref (gnu_call, NULL_TREE,
+ TREE_PURPOSE (gnu_elmt), false);
+ gnu_result_type = TREE_TYPE (gnu_call);
+ }
+
+ /* If the function returns an unconstrained array or by direct reference,
+ we have to dereference the pointer. */
+ if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
+ || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
+ gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
+
+ if (gnu_target)
+ {
+ Node_Id gnat_parent = Parent (gnat_node);
+ enum tree_code op_code;
+
+ /* If range check is needed, emit code to generate it. */
+ if (Do_Range_Check (gnat_node))
+ gnu_call
+ = emit_range_check (gnu_call, Etype (Name (gnat_parent)),
+ gnat_parent);
+
+ /* ??? If the return type has non-constant size, then force the
+ return slot optimization as we would not be able to generate
+ a temporary. Likewise if it was unconstrained as we would
+ copy too much data. That's what has been done historically. */
+ if (!TREE_CONSTANT (TYPE_SIZE (gnu_result_type))
+ || (TYPE_IS_PADDING_P (gnu_result_type)
+ && CONTAINS_PLACEHOLDER_P
+ (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type))))))
+ op_code = INIT_EXPR;
+ else
+ op_code = MODIFY_EXPR;
+
+ gnu_call
+ = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
+ set_expr_location_from_node (gnu_call, gnat_parent);
+ append_to_statement_list (gnu_call, &gnu_before_list);
+ }
+ else
+ *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
+ }
+
+ /* Otherwise, if this is a procedure call statement without copy-in/copy-out
+ parameters, the result is just the call statement. */
+ else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
append_to_statement_list (gnu_call, &gnu_before_list);
- append_to_statement_list (gnu_after_list, &gnu_before_list);
+ if (went_into_elab_proc)
+ current_function_decl = NULL_TREE;
- add_stmt (gnu_before_list);
- gnat_poplevel ();
- return end_stmt_group ();
+ /* If we have pushed a binding level, the result is the statement group.
+ Otherwise it's just the call expression. */
+ if (pushed_binding_level)
+ {
+ /* If we need a value and haven't created the call statement, do so. */
+ if (returning_value && !TYPE_CI_CO_LIST (gnu_subprog_type))
+ {
+ tree gnu_stmt;
+ gnu_call
+ = create_init_temporary ("R", gnu_call, &gnu_stmt, gnat_node);
+ append_to_statement_list (gnu_stmt, &gnu_before_list);
+ }
+ append_to_statement_list (gnu_after_list, &gnu_before_list);
+ add_stmt (gnu_before_list);
+ gnat_poplevel ();
+ gnu_result = end_stmt_group ();
+ }
+ else
+ return gnu_call;
+
+ /* If we need a value, make a COMPOUND_EXPR to return it; otherwise,
+ return the result. Deal specially with UNCONSTRAINED_ARRAY_REF. */
+ if (returning_value)
+ {
+ if (TREE_CODE (gnu_call) == UNCONSTRAINED_ARRAY_REF
+ || TREE_CODE (gnu_call) == INDIRECT_REF)
+ gnu_result = build1 (TREE_CODE (gnu_call), TREE_TYPE (gnu_call),
+ fold_build2 (COMPOUND_EXPR,
+ TREE_TYPE (TREE_OPERAND (gnu_call,
+ 0)),
+ gnu_result,
+ TREE_OPERAND (gnu_call, 0)));
+ else
+ gnu_result = fold_build2 (COMPOUND_EXPR, TREE_TYPE (gnu_call),
+ gnu_result, gnu_call);
+ }
+
+ return gnu_result;
}
\f
/* Subroutine of gnat_to_gnu to translate gnat_node, an
{
tree gnu_ret_val, gnu_ret_obj;
- /* If we have a return label defined, convert this into a branch to
- that label. The return proper will be handled elsewhere. */
- if (VEC_last (tree, gnu_return_label_stack))
- {
- gnu_result = build1 (GOTO_EXPR, void_type_node,
- VEC_last (tree, gnu_return_label_stack));
- /* When not optimizing, make sure the return is preserved. */
- if (!optimize && Comes_From_Source (gnat_node))
- DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0;
- break;
- }
-
/* If the subprogram is a function, we must return the expression. */
if (Present (Expression (gnat_node)))
{
tree gnu_subprog_type = TREE_TYPE (current_function_decl);
+ tree gnu_ret_type = TREE_TYPE (gnu_subprog_type);
tree gnu_result_decl = DECL_RESULT (current_function_decl);
gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
+ /* If this function has copy-in/copy-out parameters, get the real
+ variable and type for the return. See Subprogram_to_gnu. */
+ if (TYPE_CI_CO_LIST (gnu_subprog_type))
+ {
+ gnu_result_decl = VEC_last (tree, gnu_return_var_stack);
+ gnu_ret_type = TREE_TYPE (gnu_result_decl);
+ }
+
/* Do not remove the padding from GNU_RET_VAL if the inner type is
self-referential since we want to allocate the fixed size. */
if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
{
gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
- gnu_ret_val,
- TREE_TYPE (gnu_subprog_type),
+ gnu_ret_val, gnu_ret_type,
Procedure_To_Call (gnat_node),
Storage_Pool (gnat_node),
gnat_node, false);
gnu_ret_obj = NULL_TREE;
}
+ /* If we have a return label defined, convert this into a branch to
+ that label. The return proper will be handled elsewhere. */
+ if (VEC_last (tree, gnu_return_label_stack))
+ {
+ if (gnu_ret_obj)
+ add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj,
+ gnu_ret_val));
+
+ gnu_result = build1 (GOTO_EXPR, void_type_node,
+ VEC_last (tree, gnu_return_label_stack));
+ /* When not optimizing, make sure the return is preserved. */
+ if (!optimize && Comes_From_Source (gnat_node))
+ DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0;
+ break;
+ }
+
gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
}
break;
OSDN Git Service
