exp_aggr.adb (Build_Record_Aggr_Code): Perform a conversion of the target to the type of the aggregate in the case...

2008-08-04  Gary Dismukes  <dismukes@adacore.com>

	* exp_aggr.adb (Build_Record_Aggr_Code): Perform a conversion of the
	target to the type of the aggregate in the case where the target object
	is class-wide.

	* exp_ch5.adb (Expand_Simple_Function_Return): When the function's
	result type is class-wide and inherently limited, and the expression
	has a specific type, create a return object of the specific type, for
	more efficient handling of returns of build-in-place aggregates (avoids
	conversions of the class-wide return object to the specific type on
	component assignments).

	* sem_ch6.adb (Check_Return_Subtype_Indication): Suppress the error
	about a type mismatch for a class-wide function with a return object
	having a specific type when the object declaration doesn't come from
	source. Such an object can result from the expansion of a simple return.

From-SVN: r138603

3 files changed, 47 insertions, 21 deletions

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index eaff8e8..bc3b954 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -2436,8 +2436,12 @@ package body Exp_Aggr is
       --  to the actual type of the aggregate, so that the proper components
       --  are visible. We know already that the types are compatible.
 
+      --  There should also be a comment here explaining why the conversion
+      --  is needed in the case of interfaces.???
+
       if Present (Etype (Lhs))
-        and then Is_Interface (Etype (Lhs))
+        and then (Is_Interface (Etype (Lhs))
+                   or else Is_Class_Wide_Type (Etype (Lhs)))
       then
          Target := Unchecked_Convert_To (Typ, Lhs);
       else
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 18ea8fe..729c126 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -3695,22 +3695,39 @@ package body Exp_Ch5 is
             Return_Object_Entity : constant Entity_Id :=
                                      Make_Defining_Identifier (Loc,
                                        New_Internal_Name ('R'));
+            Subtype_Ind : Node_Id;
 
-            Subtype_Ind : constant Node_Id := New_Occurrence_Of (R_Type, Loc);
+         begin
+            --  If the result type of the function is class-wide and the
+            --  expression has a specific type, then we use the expression's
+            --  type as the type of the return object. In cases where the
+            --  expression is an aggregate that is built in place, this avoids
+            --  the need for an expensive conversion of the return object to
+            --  the specific type on assignments to the individual components.
+
+            if Is_Class_Wide_Type (R_Type)
+              and then not Is_Class_Wide_Type (Etype (Exp))
+            then
+               Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc);
+            else
+               Subtype_Ind := New_Occurrence_Of (R_Type, Loc);
+            end if;
 
-            Obj_Decl : constant Node_Id :=
-                         Make_Object_Declaration (Loc,
-                           Defining_Identifier => Return_Object_Entity,
-                           Object_Definition   => Subtype_Ind,
-                           Expression          => Exp);
+            declare
+               Obj_Decl : constant Node_Id :=
+                            Make_Object_Declaration (Loc,
+                              Defining_Identifier => Return_Object_Entity,
+                              Object_Definition   => Subtype_Ind,
+                              Expression          => Exp);
 
-            Ext : constant Node_Id := Make_Extended_Return_Statement (Loc,
-                    Return_Object_Declarations => New_List (Obj_Decl));
+               Ext : constant Node_Id := Make_Extended_Return_Statement (Loc,
+                       Return_Object_Declarations => New_List (Obj_Decl));
 
-         begin
-            Rewrite (N, Ext);
-            Analyze (N);
-            return;
+            begin
+               Rewrite (N, Ext);
+               Analyze (N);
+               return;
+            end;
          end;
       end if;
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 1ab7982..384bd57 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -606,17 +606,22 @@ package body Sem_Ch6 is
          --  definition matches the class-wide type. This prevents rejection
          --  in the case where the object declaration is initialized by a call
          --  to a build-in-place function with a specific result type and the
-         --  object entity had its type changed to that specific type. (Note
-         --  that the ARG believes that return objects should be allowed to
-         --  have a type covered by a class-wide result type in any case, so
-         --  once that relaxation is made (see AI05-32), the above check for
-         --  type compatibility should be changed to test Covers rather than
-         --  equality, and then the following special test will no longer be
-         --  needed. ???)
+         --  object entity had its type changed to that specific type. This is
+         --  also allowed in the case where Obj_Decl does not come from source,
+         --  which can occur for an expansion of a simple return statement of
+         --  a build-in-place class-wide function when the result expression
+         --  has a specific type, because a return object with a specific type
+         --  is created. (Note that the ARG believes that return objects should
+         --  be allowed to have a type covered by a class-wide result type in
+         --  any case, so once that relaxation is made (see AI05-32), the above
+         --  check for type compatibility should be changed to test Covers
+         --  rather than equality, and the following special test will no
+         --  longer be needed. ???)
 
          elsif Is_Class_Wide_Type (R_Type)
            and then
-             R_Type = Etype (Object_Definition (Original_Node (Obj_Decl)))
+             (R_Type = Etype (Object_Definition (Original_Node (Obj_Decl)))
+               or else not Comes_From_Source (Obj_Decl))
          then
             null;