From 35a382b82d0c7a65e5974298af5b32a003ea1fcf Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 Oct 2010 10:35:07 +0000 Subject: [PATCH] decl.c (gnat_to_gnu_entity, [...]): Allow In Out/Out parameters for functions. * gcc-interface/decl.c (gnat_to_gnu_entity, case E_Function): Allow In Out/Out parameters for functions. * gcc-interface/trans.c (gnu_return_var_stack): New variable. (create_init_temporary): New static function. (Subprogram_Body_to_gnu): Handle In Out/Out parameters for functions. (call_to_gnu): Likewise. Use create_init_temporary in order to create temporaries for unaligned parameters and return value. If there is an unaligned In Out or Out parameter passed by reference, push a binding level if not already done. If a binding level has been pushed and the call is returning a value, create the call statement. (gnat_to_gnu) : Handle In Out/Out parameters for functions. From-SVN: r165914 --- gcc/ada/ChangeLog | 16 + gcc/ada/gcc-interface/decl.c | 25 +- gcc/ada/gcc-interface/trans.c | 344 +++++++++++++------- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gnat.dg/in_out_parameter2.adb | 24 ++ gcc/testsuite/gnat.dg/in_out_parameter3.adb | 42 +++ 6 files changed, 338 insertions(+), 118 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/in_out_parameter2.adb create mode 100644 gcc/testsuite/gnat.dg/in_out_parameter3.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 22b8675d3ba..7d3f1600a7a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2010-10-25 Richard Kenner + Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity, case E_Function): Allow + In Out/Out parameters for functions. + * gcc-interface/trans.c (gnu_return_var_stack): New variable. + (create_init_temporary): New static function. + (Subprogram_Body_to_gnu): Handle In Out/Out parameters for functions. + (call_to_gnu): Likewise. Use create_init_temporary in order to create + temporaries for unaligned parameters and return value. If there is an + unaligned In Out or Out parameter passed by reference, push a binding + level if not already done. If a binding level has been pushed and the + call is returning a value, create the call statement. + (gnat_to_gnu) : Handle In Out/Out parameters for + functions. + 2010-10-22 Ben Brosgol * gnat_rm.texi: Add chapter on Ada 2012 support. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 3dbb3b59063..8a284ea2f4f 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -3941,7 +3941,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) bool return_by_direct_ref_p = false; bool return_by_invisi_ref_p = false; bool return_unconstrained_p = false; - bool has_copy_in_out = false; bool has_stub = false; int parmnum; @@ -4194,15 +4193,31 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (copy_in_copy_out) { - if (!has_copy_in_out) + if (!gnu_cico_list) { - gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE); - gnu_return_type = make_node (RECORD_TYPE); + tree gnu_new_ret_type = make_node (RECORD_TYPE); + + /* If this is a function, we also need a field for the + return value to be placed. */ + if (TREE_CODE (gnu_return_type) != VOID_TYPE) + { + gnu_field + = create_field_decl (get_identifier ("RETVAL"), + gnu_return_type, + gnu_new_ret_type, NULL_TREE, + NULL_TREE, 0, 0); + Sloc_to_locus (Sloc (gnat_entity), + &DECL_SOURCE_LOCATION (gnu_field)); + gnu_field_list = gnu_field; + gnu_cico_list + = tree_cons (gnu_field, void_type_node, NULL_TREE); + } + + gnu_return_type = gnu_new_ret_type; TYPE_NAME (gnu_return_type) = get_identifier ("RETURN"); /* Set a default alignment to speed up accesses. */ TYPE_ALIGN (gnu_return_type) = get_mode_alignment (ptr_mode); - has_copy_in_out = true; } gnu_field diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index f1598364a7b..3156e77c603 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -165,6 +165,10 @@ static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack; 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; @@ -2445,9 +2449,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) 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; @@ -2470,10 +2477,14 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) && !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)); @@ -2499,15 +2510,38 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) /* 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. @@ -2649,9 +2683,33 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) 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))); } + +/* 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. @@ -2675,7 +2733,9 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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); @@ -2692,7 +2752,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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); @@ -2713,17 +2773,23 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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; @@ -2778,6 +2844,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) && (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 @@ -2837,26 +2904,28 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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); @@ -3034,62 +3103,10 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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/ @@ -3097,29 +3114,23 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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 @@ -3129,7 +3140,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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 @@ -3208,14 +3219,109 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) 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; } /* Subroutine of gnat_to_gnu to translate gnat_node, an @@ -4958,25 +5064,22 @@ gnat_to_gnu (Node_Id gnat_node) { 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 @@ -4998,8 +5101,7 @@ gnat_to_gnu (Node_Id gnat_node) { 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); @@ -5032,6 +5134,22 @@ gnat_to_gnu (Node_Id gnat_node) 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 76bd610acdd..429f334ae46 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-10-25 Eric Botcazou + + * gnat.dg/in_out_parameter2.adb: New test. + * gnat.dg/in_out_parameter3.adb: Likewise. + 2010-10-25 Jie Zhang g++.dg/opt/combine.c: New test. diff --git a/gcc/testsuite/gnat.dg/in_out_parameter2.adb b/gcc/testsuite/gnat.dg/in_out_parameter2.adb new file mode 100644 index 00000000000..1b5cc7e6abf --- /dev/null +++ b/gcc/testsuite/gnat.dg/in_out_parameter2.adb @@ -0,0 +1,24 @@ +-- { dg-do run } +-- { dg-options "-gnat12" } + +procedure In_Out_Parameter2 is + + function F (I : In Out Integer) return Boolean is + A : Integer := I; + begin + I := I + 1; + return (A > 0); + end; + + I : Integer := 0; + B : Boolean; + +begin + B := F (I); + if B then + raise Program_Error; + end if; + if I /= 1 then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/in_out_parameter3.adb b/gcc/testsuite/gnat.dg/in_out_parameter3.adb new file mode 100644 index 00000000000..dab3f8d52df --- /dev/null +++ b/gcc/testsuite/gnat.dg/in_out_parameter3.adb @@ -0,0 +1,42 @@ +-- { dg-do run } +-- { dg-options "-gnat12" } + +procedure In_Out_Parameter3 is + + type Arr is array (1..16) of Integer; + + type Rec1 is record + A : Arr; + B : Boolean; + end record; + + type Rec2 is record + R : Rec1; + end record; + pragma Pack (Rec2); + + function F (I : In Out Rec1) return Boolean is + A : Integer := I.A (1); + begin + I.A (1) := I.A (1) + 1; + return (A > 0); + end; + + I : Rec2 := (R => (A => (others => 0), B => True)); + B : Boolean; + +begin + B := F (I.R); + if B then + raise Program_Error; + end if; + if I.R.A (1) /= 1 then + raise Program_Error; + end if; + if F (I.R) = False then + raise Program_Error; + end if; + if I.R.A (1) /= 2 then + raise Program_Error; + end if; +end; -- 2.30.2