[Ada] Implement In Out and Out parameters for functions

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;