From: Gary Dismukes Date: Mon, 4 Aug 2008 10:23:16 +0000 (+0200) Subject: exp_aggr.adb (Build_Record_Aggr_Code): Perform a conversion of the target to the... X-Git-Tag: releases/gcc-4.4.0~3422 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=05a76b51fb58e10f74e5f4fe613dc5b40fae44d8;p=thirdparty%2Fgcc.git 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 * 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 --- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index eaff8e89a9eb..bc3b954fb6c3 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 18ea8fe44db4..729c126f4d61 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 1ab798240a0c..384bd5790074 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;