diff options
Diffstat (limited to 'gcc/ada/gcc-interface')
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 135 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils.c | 37 |
2 files changed, 88 insertions, 84 deletions
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index bf9ac15..7031bfb 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -2455,40 +2455,48 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) begin_subprog_body (gnu_subprog_decl); - /* If there are 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 inner return into a goto to a label at the end of the block. */ + /* 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); - VEC_safe_push (tree, gc, gnu_return_label_stack, - gnu_cico_list - ? create_artificial_label (input_location) - : NULL_TREE); + if (gnu_cico_list) + { + VEC_safe_push (tree, gc, gnu_return_label_stack, + create_artificial_label (input_location)); + + start_stmt_group (); + gnat_pushlevel (); + + /* 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. + We can match up the entries because TYPE_CI_CO_LIST is in the order + of the parameters. */ + for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); + Present (gnat_param); + gnat_param = Next_Formal_With_Extras (gnat_param)) + if (!present_gnu_tree (gnat_param)) + { + tree gnu_cico_entry = gnu_cico_list; + + /* Skip any entries that have been already filled in; they must + correspond to In Out parameters. */ + while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry)) + gnu_cico_entry = TREE_CHAIN (gnu_cico_entry); + + /* Do any needed references for padded types. */ + TREE_VALUE (gnu_cico_entry) + = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), + gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); + } + } + else + VEC_safe_push (tree, gc, gnu_return_label_stack, NULL_TREE); /* Get a tree corresponding to the code for the subprogram. */ start_stmt_group (); gnat_pushlevel (); - /* See if there are any parameters for which we don't yet have GCC entities. - These must be for Out parameters for which we will be making VAR_DECL - nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty - entry as well. We can match up the entries because TYPE_CI_CO_LIST is in - the order of the parameters. */ - for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); - Present (gnat_param); - gnat_param = Next_Formal_With_Extras (gnat_param)) - if (!present_gnu_tree (gnat_param)) - { - /* Skip any entries that have been already filled in; they must - correspond to In Out parameters. */ - while (gnu_cico_list && TREE_VALUE (gnu_cico_list)) - gnu_cico_list = TREE_CHAIN (gnu_cico_list); - - /* Do any needed references for padded types. */ - TREE_VALUE (gnu_cico_list) - = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)), - gnat_to_gnu_entity (gnat_param, NULL_TREE, 1)); - } - /* On VMS, establish our condition handler to possibly turn a condition into the corresponding exception if the subprogram has a foreign convention or is exported. @@ -2513,6 +2521,40 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_poplevel (); gnu_result = end_stmt_group (); + /* If we are dealing with a return from an Ada procedure with parameters + passed by copy-in/copy-out, we need to return a record containing the + final values of these parameters. If the list contains only one entry, + return just that entry though. + + For a full description of the copy-in/copy-out parameter mechanism, see + the part of the gnat_to_gnu_entity routine dealing with the translation + of subprograms. + + We need to make a block that contains the definition of that label and + the copying of the return value. It first contains the function, then + the label and copy statement. */ + if (gnu_cico_list) + { + tree gnu_retval; + + add_stmt (gnu_result); + add_stmt (build1 (LABEL_EXPR, void_type_node, + VEC_last (tree, gnu_return_label_stack))); + + if (list_length (gnu_cico_list) == 1) + gnu_retval = TREE_VALUE (gnu_cico_list); + else + gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); + + add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval), + End_Label (Handled_Statement_Sequence (gnat_node))); + gnat_poplevel (); + gnu_result = end_stmt_group (); + } + + VEC_pop (tree, gnu_return_label_stack); + /* If we populated the parameter attributes cache, we need to make sure that the cached expressions are evaluated on all possible paths. */ cache = DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language->parm_attr_cache; @@ -2537,43 +2579,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnu_result = end_stmt_group (); } - /* If we are dealing with a return from an Ada procedure with parameters - passed by copy-in/copy-out, we need to return a record containing the - final values of these parameters. If the list contains only one entry, - return just that entry though. - - For a full description of the copy-in/copy-out parameter mechanism, see - the part of the gnat_to_gnu_entity routine dealing with the translation - of subprograms. - - We need to make a block that contains the definition of that label and - the copying of the return value. It first contains the function, then - the label and copy statement. */ - if (VEC_last (tree, gnu_return_label_stack)) - { - tree gnu_retval; - - start_stmt_group (); - gnat_pushlevel (); - add_stmt (gnu_result); - add_stmt (build1 (LABEL_EXPR, void_type_node, - VEC_last (tree, gnu_return_label_stack))); - - gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - if (list_length (gnu_cico_list) == 1) - gnu_retval = TREE_VALUE (gnu_cico_list); - else - gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), - gnu_cico_list); - - add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval), - End_Label (Handled_Statement_Sequence (gnat_node))); - gnat_poplevel (); - gnu_result = end_stmt_group (); - } - - VEC_pop (tree, gnu_return_label_stack); - /* Set the end location. */ Sloc_to_locus ((Present (End_Label (Handled_Statement_Sequence (gnat_node))) diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 98a1565..e1f7aab 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -473,14 +473,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) } else if (!DECL_EXTERNAL (decl)) { - tree block; - /* Fake PARM_DECLs go into the topmost block of the function. */ - if (TREE_CODE (decl) == PARM_DECL) - block = BLOCK_SUPERCONTEXT (current_binding_level->block); - else - block = current_binding_level->block; - DECL_CHAIN (decl) = BLOCK_VARS (block); - BLOCK_VARS (block) = decl; + DECL_CHAIN (decl) = BLOCK_VARS (current_binding_level->block); + BLOCK_VARS (current_binding_level->block) = decl; } } @@ -1907,6 +1901,13 @@ end_subprog_body (tree body) /* Mark the RESULT_DECL as being in this subprogram. */ DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + /* The body should be a BIND_EXPR whose BLOCK is the top-level one. */ + if (TREE_CODE (body) == BIND_EXPR) + { + BLOCK_SUPERCONTEXT (BIND_EXPR_BLOCK (body)) = fndecl; + DECL_INITIAL (fndecl) = BIND_EXPR_BLOCK (body); + } + DECL_SAVED_TREE (fndecl) = body; current_function_decl = DECL_CONTEXT (fndecl); @@ -3228,15 +3229,18 @@ build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call; tree gnu_stub_param, gnu_arg_types, gnu_param; tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog); - tree gnu_body; VEC(tree,gc) *gnu_param_vec = NULL; gnu_subprog_type = TREE_TYPE (gnu_subprog); + /* Initialize the information structure for the function. */ + allocate_struct_function (gnu_stub_decl, false); + set_cfun (NULL); + begin_subprog_body (gnu_stub_decl); - gnat_pushlevel (); start_stmt_group (); + gnat_pushlevel (); /* Loop over the parameters of the stub and translate any of them passed by descriptor into a by reference one. */ @@ -3258,8 +3262,6 @@ build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) VEC_safe_push (tree, gc, gnu_param_vec, gnu_param); } - gnu_body = end_stmt_group (); - /* Invoke the internal subprogram. */ gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type), gnu_subprog); @@ -3268,16 +3270,13 @@ build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) /* Propagate the return value, if any. */ if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type))) - append_to_statement_list (gnu_subprog_call, &gnu_body); + add_stmt (gnu_subprog_call); else - append_to_statement_list (build_return_expr (DECL_RESULT (gnu_stub_decl), - gnu_subprog_call), - &gnu_body); + add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl), + gnu_subprog_call)); gnat_poplevel (); - - allocate_struct_function (gnu_stub_decl, false); - end_subprog_body (gnu_body); + end_subprog_body (end_stmt_group ()); } /* Build a type to be used to represent an aliased object whose nominal type |