===================================================================
@@ -473,14 +473,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_n
}
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, E
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, E
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, E
/* 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
===================================================================
@@ -2455,40 +2455,48 @@ Subprogram_Body_to_gnu (Node_Id gnat_nod
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_nod
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_nod
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)))