From patchwork Mon Oct 25 10:27:33 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Eric Botcazou X-Patchwork-Id: 69084 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8C410B70B8 for ; Mon, 25 Oct 2010 21:36:02 +1100 (EST) Received: (qmail 8187 invoked by alias); 25 Oct 2010 10:36:00 -0000 Received: (qmail 7367 invoked by uid 22791); 25 Oct 2010 10:35:57 -0000 X-SWARE-Spam-Status: No, hits=-0.8 required=5.0 tests=AWL, BAYES_20, KAM_ADVERT2, TW_TM X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 25 Oct 2010 10:35:50 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 51813CB029D for ; Mon, 25 Oct 2010 12:35:47 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id f9CiLkQ8PAot for ; Mon, 25 Oct 2010 12:35:47 +0200 (CEST) Received: from [192.168.1.2] (bon31-9-83-155-120-49.fbx.proxad.net [83.155.120.49]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mel.act-europe.fr (Postfix) with ESMTP id CD97BCB0295 for ; Mon, 25 Oct 2010 12:35:46 +0200 (CEST) From: Eric Botcazou To: gcc-patches@gcc.gnu.org Subject: [Ada] Implement In Out and Out parameters for functions Date: Mon, 25 Oct 2010 12:27:33 +0200 User-Agent: KMail/1.9.9 MIME-Version: 1.0 Message-Id: <201010251227.33458.ebotcazou@adacore.com> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This implements In Out and Out parameters for functions, which is a new Ada 2012 feature. Tested on i586-suse-linux, applied on the mainline. 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-25 Eric Botcazou * gnat.dg/in_out_parameter2.adb: New test. * gnat.dg/in_out_parameter3.adb: Likewise. Index: gcc-interface/decl.c =================================================================== --- gcc-interface/decl.c (revision 165910) +++ gcc-interface/decl.c (working copy) @@ -3941,7 +3941,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entit 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_entit 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 Index: gcc-interface/trans.c =================================================================== --- gcc-interface/trans.c (revision 165910) +++ gcc-interface/trans.c (working copy) @@ -165,6 +165,10 @@ static GTY(()) VEC(tree,gc) *gnu_elab_pr 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_nod 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_nod && !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_nod /* 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_nod 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 *gn 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 *gn 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 *gn 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 *gn && (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 *gn 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 *gn 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 *gn 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 *gn 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 *gn 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;