From: charlet Date: Mon, 13 Jul 2009 12:17:53 +0000 (+0000) Subject: 2009-07-13 Emmanuel Briot X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=dffd0a90b889a398f1ebdf22558d592248439ec8 2009-07-13 Emmanuel Briot * prj-err.adb (Error_Msg): One more case where a message should be considered as a warning. * gnatcmd.adb (GNATCmd): Fix previous change, which negated a test. 2009-07-13 Thomas Quinot * exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze calling stubs in the (library level) scope of the RCI locator, where it is attached, not in the caller's scope. 2009-07-13 Javier Miranda * sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide interface object declarations we delay the generation of the equivalent record type declarations until its expansion because there are cases in which they are not required. * sem_util.adb (Implements_Interface): Add missing support for subtypes. * sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus addition of assertion. * exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide interface types require no equivalent constrained type declarations because the expanded code only references the tag component associated with the interface. (Find_Interface_Tag): Improve management of interfaces that are ancestors of tagged types. * exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of class-wide object declarations to add missing support to statically displace the pointer to the object to reference the tag component associated with the interface. * exp_disp.adb (Make_Tags) Avoid generation of internally generated auxiliary types associated with user-defined dispatching calls if the type has no user-defined primitives. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149574 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7975955fccc..ac910fde2ea 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2009-07-13 Emmanuel Briot + + * prj-err.adb (Error_Msg): One more case where a message should be + considered as a warning. + + * gnatcmd.adb (GNATCmd): Fix previous change, which negated a test. + +2009-07-13 Thomas Quinot + + * exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze + calling stubs in the (library level) scope of the RCI locator, where it + is attached, not in the caller's scope. + +2009-07-13 Javier Miranda + + * sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide + interface object declarations we delay the generation of the equivalent + record type declarations until its expansion because there are cases in + which they are not required. + + * sem_util.adb (Implements_Interface): Add missing support for subtypes. + + * sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus + addition of assertion. + + * exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide + interface types require no equivalent constrained type declarations + because the expanded code only references the tag component associated + with the interface. + (Find_Interface_Tag): Improve management of interfaces that are + ancestors of tagged types. + + * exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of + class-wide object declarations to add missing support to statically + displace the pointer to the object to reference the tag component + associated with the interface. + + * exp_disp.adb (Make_Tags) Avoid generation of internally generated + auxiliary types associated with user-defined dispatching calls if the + type has no user-defined primitives. + 2009-07-13 Vasiliy Fofanov * mingw32.h: Make it explicit that we need XP or later. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d33698d55ec..92bcc03bdab 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4497,6 +4497,196 @@ package body Exp_Ch3 is return; + -- Ada 2005 (AI-251): Rewrite the expression that initializes a + -- class-wide object to ensure that we copy the full object, + -- unless we are targetting a VM where interfaces are handled by + -- VM itself. Note that if the root type of Typ is an ancestor + -- of Expr's type, both types share the same dispatch table and + -- there is no need to displace the pointer. + + elsif Comes_From_Source (N) + and then Is_Interface (Typ) + then + pragma Assert (Is_Class_Wide_Type (Typ)); + + if Tagged_Type_Expansion then + declare + Iface : constant Entity_Id := Root_Type (Typ); + Expr_N : Node_Id := Expr; + Expr_Typ : Entity_Id; + + Decl_1 : Node_Id; + Decl_2 : Node_Id; + New_Expr : Node_Id; + + begin + -- If the original node of the expression was a conversion + -- to this specific class-wide interface type then we + -- restore the original node to generate code that + -- statically displaces the pointer to the interface + -- component. + + if not Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Unchecked_Type_Conversion + and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion + and then Etype (Original_Node (Expr_N)) = Typ + then + Rewrite (Expr_N, Original_Node (Expression (N))); + end if; + + -- Avoid expansion of redundant interface conversion + + if Is_Interface (Etype (Expr_N)) + and then Nkind (Expr_N) = N_Type_Conversion + and then Etype (Expr_N) = Typ + then + Expr_N := Expression (Expr_N); + Set_Expression (N, Expr_N); + end if; + + Expr_Typ := Base_Type (Etype (Expr_N)); + + if Is_Class_Wide_Type (Expr_Typ) then + Expr_Typ := Root_Type (Expr_Typ); + end if; + + -- Replace + -- CW : I'Class := Obj; + -- by + -- Tmp : T := Obj; + -- CW : I'Class renames TiC!(Tmp.I_Tag); + + if Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Identifier + and then not Is_Interface (Expr_Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => + Unchecked_Convert_To (Expr_Typ, + Relocate_Node (Expr_N))); + + -- Statically reference the tag associated with the + -- interface + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Selector_Name => + New_Reference_To + (Find_Interface_Tag (Expr_Typ, Iface), + Loc)))); + + -- General case: + + -- Replace + -- IW : I'Class := Obj; + -- by + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is ; + -- Temp : CW := CW!(Obj'Address); + -- IW : I'Class renames Displace (Temp, I'Tag); + + else + -- Generate the equivalent record type + + Expand_Subtype_From_Expr + (N => N, + Unc_Type => Typ, + Subtype_Indic => Object_Definition (N), + Exp => Expression (N)); + + if not Is_Interface (Etype (Expression (N))) then + New_Expr := Relocate_Node (Expression (N)); + else + New_Expr := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expression (N)), + Attribute_Name => Name_Address))); + end if; + + Decl_1 := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Object_Definition => + New_Occurrence_Of + (Etype (Object_Definition (N)), Loc), + Expression => + Unchecked_Convert_To + (Etype (Object_Definition (N)), New_Expr)); + + Decl_2 := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('D')), + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Name => + Unchecked_Convert_To (Typ, + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Identifier (Decl_1), Loc), + Attribute_Name => Name_Address), + + Unchecked_Convert_To (RTE (RE_Tag), + New_Reference_To + (Node + (First_Elmt + (Access_Disp_Table (Iface))), + Loc)))))))); + end if; + + Insert_Action (N, Decl_1); + Rewrite (N, Decl_2); + Analyze (N); + + -- Replace internal identifier of Decl_2 by the identifier + -- found in the sources. We also have to exchange entities + -- containing their defining identifiers to ensure the + -- correct replacement of the object declaration by this + -- object renaming declaration (because such definings + -- identifier have been previously added by Enter_Name to + -- the current scope). We must preserve the homonym chain + -- of the source entity as well. + + Set_Chars (Defining_Identifier (N), Chars (Def_Id)); + Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); + Exchange_Entities (Defining_Identifier (N), Def_Id); + end; + end if; + + return; + else -- In most cases, we must check that the initial value meets any -- constraint imposed by the declared type. However, there is one @@ -4530,119 +4720,6 @@ package body Exp_Ch3 is end if; end if; - -- Ada 2005 (AI-251): Rewrite the expression that initializes a - -- class-wide object to ensure that we copy the full object, - -- unless we are targetting a VM where interfaces are handled by - -- VM itself. Note that if the root type of Typ is an ancestor - -- of Expr's type, both types share the same dispatch table and - -- there is no need to displace the pointer. - - -- Replace - -- CW : I'Class := Obj; - -- by - -- Temp : I'Class := I'Class (Base_Address (Obj'Address)); - -- CW : I'Class renames Displace (Temp, I'Tag); - - if Is_Interface (Typ) - and then Is_Class_Wide_Type (Typ) - and then - (Is_Class_Wide_Type (Etype (Expr)) - or else - not Is_Ancestor (Root_Type (Typ), Etype (Expr))) - and then Comes_From_Source (Def_Id) - and then Tagged_Type_Expansion - then - declare - Decl_1 : Node_Id; - Decl_2 : Node_Id; - - begin - Decl_1 := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - - Object_Definition => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Root_Type (Etype (Def_Id)), Loc), - Attribute_Name => Name_Class), - - Expression => - Unchecked_Convert_To - (Class_Wide_Type (Root_Type (Etype (Def_Id))), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Base_Address), - Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Expr), - Attribute_Name => Name_Address))))))); - - Insert_Action (N, Decl_1); - - Decl_2 := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Root_Type (Etype (Def_Id)), Loc), - Attribute_Name => Name_Class), - - Name => - Unchecked_Convert_To ( - Class_Wide_Type (Root_Type (Etype (Def_Id))), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Displace), Loc), - - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (Decl_1), Loc), - Attribute_Name => Name_Address), - - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To - (Node - (First_Elmt - (Access_Disp_Table - (Root_Type (Typ)))), - Loc)))))))); - - Rewrite (N, Decl_2); - Analyze (N); - - -- Replace internal identifier of Decl_2 by the identifier - -- found in the sources. We also have to exchange entities - -- containing their defining identifiers to ensure the - -- correct replacement of the object declaration by this - -- object renaming declaration (because such definings - -- identifier have been previously added by Enter_Name to - -- the current scope). We must preserve the homonym chain - -- of the source entity as well. - - Set_Chars (Defining_Identifier (N), Chars (Def_Id)); - Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); - Exchange_Entities (Defining_Identifier (N), Def_Id); - - return; - end; - end if; - -- If the type is controlled and not inherently limited, then -- the target is adjusted after the copy and attached to the -- finalization list. However, no adjustment is done in the case diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 54f66919cb8..99f918b7477 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6118,64 +6118,71 @@ package body Exp_Disp is end loop; end if; - -- 3) At the end of Access_Disp_Table we add the entity of an access - -- type declaration. It is used by Build_Get_Prim_Op_Address to - -- expand dispatching calls through the primary dispatch table. + -- 3) At the end of Access_Disp_Table, if the type has user-defined + -- primitives, we add the entity of an access type declaration that + -- is used by Build_Get_Prim_Op_Address to expand dispatching calls + -- through the primary dispatch table. + + if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then + Analyze_List (Result); -- Generate: -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; -- type Typ_DT_Acc is access Typ_DT; - declare - Name_DT_Prims : constant Name_Id := - New_External_Name (Tname, 'G'); - Name_DT_Prims_Acc : constant Name_Id := - New_External_Name (Tname, 'H'); - DT_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_DT_Prims); - DT_Prims_Acc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Name_DT_Prims_Acc); - begin - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims, - Type_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Make_Integer_Literal (Loc, - DT_Entry_Count - (First_Tag_Component (Typ))))), - Component_Definition => - Make_Component_Definition (Loc, - Subtype_Indication => - New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); + else + declare + Name_DT_Prims : constant Name_Id := + New_External_Name (Tname, 'G'); + Name_DT_Prims_Acc : constant Name_Id := + New_External_Name (Tname, 'H'); + DT_Prims : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims); + DT_Prims_Acc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Name_DT_Prims_Acc); + begin + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims, + Type_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Reference_To (RTE (RE_Prim_Ptr), Loc))))); - Append_To (Result, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => DT_Prims_Acc, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (DT_Prims, Loc)))); + Append_To (Result, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => DT_Prims_Acc, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (DT_Prims, Loc)))); - Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); + Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ)); - -- Analyze the resulting list and suppress the generation of the - -- Init_Proc associated with the above array declaration because - -- we never use such type in object declarations; this type is only - -- used to simplify the expansion associated with dispatching calls. + -- Analyze the resulting list and suppress the generation of the + -- Init_Proc associated with the above array declaration because + -- this type is never used in object declarations. It is only used + -- to simplify the expansion associated with dispatching calls. - Analyze_List (Result); - Set_Suppress_Init_Proc (Base_Type (DT_Prims)); + Analyze_List (Result); + Set_Suppress_Init_Proc (Base_Type (DT_Prims)); - -- Mark entity of dispatch table. Required by the backend to handle - -- the properly. + -- Mark entity of dispatch table. Required by the back end to + -- handle them properly. - Set_Is_Dispatch_Table_Entity (DT_Prims); - end; + Set_Is_Dispatch_Table_Entity (DT_Prims); + end; + end if; Set_Ekind (DT_Ptr, E_Constant); Set_Is_Tag (DT_Ptr); diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index f13c8a45eef..d975657f4a1 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -2755,11 +2755,11 @@ package body Exp_Dist is --------------------------------------------- procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); Called_Subprogram : constant Entity_Id := Entity (Name (N)); RCI_Package : constant Entity_Id := Scope (Called_Subprogram); - Loc : constant Source_Ptr := Sloc (N); - RCI_Locator : Node_Id; - RCI_Cache : Entity_Id; + RCI_Locator_Decl : Node_Id; + RCI_Locator : Entity_Id; Calling_Stubs : Node_Id; E_Calling_Stubs : Entity_Id; @@ -2767,41 +2767,35 @@ package body Exp_Dist is E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); if E_Calling_Stubs = Empty then - RCI_Cache := RCI_Locator_Table.Get (RCI_Package); - - if RCI_Cache = Empty then - RCI_Locator := - RCI_Package_Locator - (Loc, Specification (Unit_Declaration_Node (RCI_Package))); - Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); - - -- The RCI_Locator package is inserted at the top level in the - -- current unit, and must appear in the proper scope, so that it - -- is not prematurely removed by the GCC back-end. + RCI_Locator := RCI_Locator_Table.Get (RCI_Package); - declare - Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); - - begin - if Ekind (Scop) = E_Package_Body then - Push_Scope (Spec_Entity (Scop)); + -- The RCI_Locator package and calling stub are is inserted at the + -- top level in the current unit, and must appear in the proper scope + -- so that it is not prematurely removed by the GCC back end. - elsif Ekind (Scop) = E_Subprogram_Body then - Push_Scope - (Corresponding_Spec (Unit_Declaration_Node (Scop))); - - else - Push_Scope (Scop); - end if; - - Analyze (RCI_Locator); - Pop_Scope; - end; + declare + Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + begin + if Ekind (Scop) = E_Package_Body then + Push_Scope (Spec_Entity (Scop)); + elsif Ekind (Scop) = E_Subprogram_Body then + Push_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); + else + Push_Scope (Scop); + end if; + end; - RCI_Cache := Defining_Unit_Name (RCI_Locator); + if RCI_Locator = Empty then + RCI_Locator_Decl := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); + Analyze (RCI_Locator_Decl); + RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); else - RCI_Locator := Parent (RCI_Cache); + RCI_Locator_Decl := Parent (RCI_Locator); end if; Calling_Stubs := Build_Subprogram_Calling_Stubs @@ -2811,10 +2805,12 @@ package body Exp_Dist is Asynchronous => Nkind (N) = N_Procedure_Call_Statement and then Is_Asynchronous (Called_Subprogram), - Locator => RCI_Cache, + Locator => RCI_Locator, New_Name => New_Internal_Name ('S')); - Insert_After (RCI_Locator, Calling_Stubs); + Insert_After (RCI_Locator_Decl, Calling_Stubs); Analyze (Calling_Stubs); + Pop_Scope; + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 21183b2109e..e8a1fdd3dbc 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1350,6 +1350,17 @@ package body Exp_Util is Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type))); end if; + -- Renamings of class-wide interface types require no equivalent + -- constrained type declarations because we only need to reference + -- the tag component associated with the interface. + + elsif Present (N) + and then Nkind (N) = N_Object_Renaming_Declaration + and then Is_Interface (Unc_Type) + then + pragma Assert (Is_Class_Wide_Type (Unc_Type)); + null; + -- In Ada95, nothing to be done if the type of the expression is -- limited, because in this case the expression cannot be copied, -- and its use can only be by reference. @@ -1371,16 +1382,6 @@ package body Exp_Util is then null; - -- For limited interfaces, nothing to be done - - -- This branch may be redundant once the limited interface issue is - -- sorted out??? - - elsif Is_Interface (Exp_Typ) - and then Is_Limited_Interface (Exp_Typ) - then - null; - -- For limited objects initialized with build in place function calls, -- nothing to be done; otherwise we prematurely introduce an N_Reference -- node in the expression initializing the object, which breaks the @@ -1546,15 +1547,10 @@ package body Exp_Util is AI : Node_Id; begin - -- Check if the interface is an immediate ancestor of the type and - -- therefore shares the main tag. + -- This routine does not handle the case in which the interface is an + -- ancestor of Typ. That case is handled by the enclosing subprogram. - if Typ = Iface then - pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); - AI_Tag := First_Tag_Component (Typ); - Found := True; - return; - end if; + pragma Assert (Typ /= Iface); -- Climb to the root type handling private types @@ -1632,9 +1628,20 @@ package body Exp_Util is Typ := Corresponding_Record_Type (Typ); end if; - Find_Tag (Typ); - pragma Assert (Found); - return AI_Tag; + -- If the interface is an ancestor of the type, then it shared the + -- primary dispatch table. + + if Is_Ancestor (Iface, Typ) then + pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag)); + return First_Tag_Component (Typ); + + -- Otherwise we need to search for its associated tag component + + else + Find_Tag (Typ); + pragma Assert (Found); + return AI_Tag; + end if; end Find_Interface_Tag; ------------------ diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index fabf31ecaca..c3ec70c241a 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -2117,16 +2117,16 @@ begin end if; end loop; - -- If the naming scheme of the project file is not standard, - -- and if the file name ends with the spec suffix, then - -- indicate to gnatstub the name of the body file with - -- a -o switch. + -- If the project file naming scheme is not standard, and if + -- the file name ends with the spec suffix, then indicate to + -- gnatstub the name of the body file with a -o switch. - if Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then + if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then if File_Index /= 0 then declare Spec : constant String := - Base_Name (Last_Switches.Table (File_Index).all); + Base_Name + (Last_Switches.Table (File_Index).all); Last : Natural := Spec'Last; begin @@ -2193,8 +2193,7 @@ begin end if; -- For gnat check, -rules and the following switches need to be the - -- last options. So, we move all these switches to table - -- Rules_Switches. + -- last options, so move all these switches to table Rules_Switches. if The_Command = Check then declare diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb index abe4224f098..c0fa09b220c 100644 --- a/gcc/ada/prj-err.adb +++ b/gcc/ada/prj-err.adb @@ -113,7 +113,9 @@ package body Prj.Err is -- Let the application know there was an error if Flags.Report_Error /= null then - Flags.Report_Error (Project, Is_Warning => Msg (Msg'First) = '?'); + Flags.Report_Error + (Project, + Is_Warning => Msg (Msg'First) = '?' or Msg (Msg'First) = '<'); end if; end Error_Msg; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9c289e75136..00c40e7677b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -590,8 +590,8 @@ package body Sem_Ch3 is function Is_Progenitor (Iface : Entity_Id; - Typ : Entity_Id) return Boolean; - -- Determine whether type Typ implements interface Iface. This requires + Typ : Entity_Id) return Boolean; + -- Determine whether the interface Iface is implemented by Typ. It requires -- traversing the list of abstract interfaces of the type, as well as that -- of the ancestor types. The predicate is used to determine when a formal -- in the signature of an inherited operation must carry the derived type. @@ -2725,6 +2725,13 @@ package body Sem_Ch3 is then Act_T := Etype (E); + -- In case of class-wide interface object declarations we delay + -- the generation of the equivalent record type declarations until + -- its expansion because there are cases in they are not required. + + elsif Is_Interface (T) then + null; + else Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); Act_T := Find_Type_Of_Object (Object_Definition (N), N); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index f64df6f9823..705f428716a 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -105,15 +105,13 @@ package body Sem_Disp is begin Formal := First_Formal (Subp); - while Present (Formal) loop Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); if Present (Ctrl_Type) then - -- When the controlling type is concurrent and declared within a - -- generic or inside an instance, use its corresponding record - -- type. + -- When controlling type is concurrent and declared within a + -- generic or inside an instance use corresponding record type. if Is_Concurrent_Type (Ctrl_Type) and then Present (Corresponding_Record_Type (Ctrl_Type)) @@ -124,7 +122,7 @@ package body Sem_Disp is if Ctrl_Type = Typ then Set_Is_Controlling_Formal (Formal); - -- Ada 2005 (AI-231): Anonymous access types used in + -- Ada 2005 (AI-231): Anonymous access types that are used in -- controlling parameters exclude null because it is necessary -- to read the tag to dispatch, and null has no tag. @@ -178,7 +176,10 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - if Present (Etype (Subp)) then + if Ekind (Subp) = E_Function + or else + Ekind (Subp) = E_Generic_Function + then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then @@ -426,14 +427,12 @@ package body Sem_Disp is else Par := Parent (N); - while Present (Par) loop - - if (Nkind (Par) = N_Function_Call or else - Nkind (Par) = N_Procedure_Call_Statement or else - Nkind (Par) = N_Assignment_Statement or else - Nkind (Par) = N_Op_Eq or else - Nkind (Par) = N_Op_Ne) + if Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement, + N_Assignment_Statement, + N_Op_Eq, + N_Op_Ne) and then Is_Tagged_Type (Etype (Subp)) then return; @@ -471,11 +470,10 @@ package body Sem_Disp is -- Find a controlling argument, if any if Present (Parameter_Associations (N)) then - Actual := First_Actual (N); - Subp_Entity := Entity (Name (N)); - Formal := First_Formal (Subp_Entity); + Actual := First_Actual (N); + Formal := First_Formal (Subp_Entity); while Present (Actual) loop Control := Find_Controlling_Arg (Actual); exit when Present (Control); @@ -544,7 +542,6 @@ package body Sem_Disp is end if; Actual := First_Actual (N); - while Present (Actual) loop if Actual /= Control then @@ -866,7 +863,7 @@ package body Sem_Disp is -- If the type is already frozen, the overriding is not allowed -- except when Old_Subp is not a dispatching operation (which can -- occur when Old_Subp was inherited by an untagged type). However, - -- a body with no previous spec freezes the type "after" its + -- a body with no previous spec freezes the type *after* its -- declaration, and therefore is a legal overriding (unless the type -- has already been frozen). Only the first such body is legal. @@ -880,7 +877,7 @@ package body Sem_Disp is then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); - Decl_Item : Node_Id := Next (Parent (Tagged_Type)); + Decl_Item : Node_Id; begin -- ??? The checks here for whether the type has been @@ -899,6 +896,7 @@ package body Sem_Disp is -- then the type has been frozen already so the overriding -- primitive is illegal. + Decl_Item := Next (Parent (Tagged_Type)); while Present (Decl_Item) and then (Decl_Item /= Subp_Body) loop @@ -1166,8 +1164,10 @@ package body Sem_Disp is elsif Has_Controlled_Component (Tagged_Type) and then (Chars (Subp) = Name_Initialize - or else Chars (Subp) = Name_Adjust - or else Chars (Subp) = Name_Finalize) + or else + Chars (Subp) = Name_Adjust + or else + Chars (Subp) = Name_Finalize) then declare F_Node : constant Node_Id := Freeze_Node (Tagged_Type); @@ -1187,13 +1187,13 @@ package body Sem_Disp is TSS_Deep_Finalize); begin - -- Remove previous controlled function, which was constructed - -- and analyzed when the type was frozen. This requires - -- removing the body of the redefined primitive, as well as - -- its specification if needed (there is no spec created for - -- Deep_Initialize, see exp_ch3.adb). We must also dismantle - -- the exception information that may have been generated for - -- it when front end zero-cost tables are enabled. + -- Remove previous controlled function which was constructed and + -- analyzed when the type was frozen. This requires removing the + -- body of the redefined primitive, as well as its specification + -- if needed (there is no spec created for Deep_Initialize, see + -- exp_ch3.adb). We must also dismantle the exception information + -- that may have been generated for it when front end zero-cost + -- tables are enabled. for J in D_Names'Range loop Old_P := TSS (Tagged_Type, D_Names (J)); @@ -1217,9 +1217,9 @@ package body Sem_Disp is Build_Late_Proc (Tagged_Type, Chars (Subp)); - -- The new operation is added to the actions of the freeze - -- node for the type, but this node has already been analyzed, - -- so we must retrieve and analyze explicitly the new body. + -- The new operation is added to the actions of the freeze node + -- for the type, but this node has already been analyzed, so we + -- must retrieve and analyze explicitly the new body. if Present (F_Node) and then Present (Actions (F_Node)) @@ -1264,14 +1264,10 @@ package body Sem_Disp is F1 := First_Formal (Proc); F2 := First_Formal (Subp); - while Present (F1) and then Present (F2) loop - if Ekind (Etype (F1)) = E_Anonymous_Access_Type then - if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then return False; - elsif Designated_Type (Etype (F1)) = Parent_Typ and then Designated_Type (Etype (F2)) /= Full then @@ -1304,11 +1300,8 @@ package body Sem_Disp is Op1 := First_Elmt (Old_Prim); Op2 := First_Elmt (New_Prim); - while Present (Op1) and then Present (Op2) loop - if Derives_From (Node (Op1)) then - if No (Prev) then -- Avoid adding it to the list of primitives if already there! @@ -1371,6 +1364,7 @@ package body Sem_Disp is then declare Formal : Entity_Id; + begin Formal := First_Formal (Old_Subp); while Present (Formal) loop @@ -1397,8 +1391,8 @@ package body Sem_Disp is -- Otherwise, update its alias and other attributes. if Present (Alias (Old_Subp)) - and then Nkind (Unit_Declaration_Node (Old_Subp)) - /= N_Subprogram_Renaming_Declaration + and then Nkind (Unit_Declaration_Node (Old_Subp)) /= + N_Subprogram_Renaming_Declaration then Set_Alias (Old_Subp, Alias (Subp)); @@ -1461,24 +1455,22 @@ package body Sem_Disp is Typ := Etype (N); if Is_Access_Type (Typ) then - -- In the case of an Access attribute, use the type of - -- the prefix, since in the case of an actual for an - -- access parameter, the attribute's type may be of a - -- specific designated type, even though the prefix - -- type is class-wide. + + -- In the case of an Access attribute, use the type of the prefix, + -- since in the case of an actual for an access parameter, the + -- attribute's type may be of a specific designated type, even + -- though the prefix type is class-wide. if Nkind (N) = N_Attribute_Reference then Typ := Etype (Prefix (N)); - -- An allocator is dispatching if the type of qualified - -- expression is class_wide, in which case this is the - -- controlling type. + -- An allocator is dispatching if the type of qualified expression + -- is class_wide, in which case this is the controlling type. elsif Nkind (Orig_Node) = N_Allocator and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression then Typ := Etype (Expression (Orig_Node)); - else Typ := Designated_Type (Typ); end if; @@ -1560,6 +1552,7 @@ package body Sem_Disp is end if; end if; + pragma Assert (not Is_Dispatching_Operation (Subp)); return Empty; end Find_Dispatching_Type; @@ -1800,9 +1793,9 @@ package body Sem_Disp is elsif Nkind (Actual) = N_Identifier and then Nkind (Original_Node (Actual)) = N_Function_Call then - -- Call rewritten as object declaration when stack-checking - -- is enabled. Propagate tag to expression in declaration, which - -- is original call. + -- Call rewritten as object declaration when stack-checking is + -- enabled. Propagate tag to expression in declaration, which is + -- original call. Call_Node := Expression (Parent (Entity (Actual))); @@ -1823,8 +1816,8 @@ package body Sem_Disp is Call_Node := Expression (Actual); end if; - -- Do not set the Controlling_Argument if already set. This happens - -- in the special case of _Input (see Exp_Attr, case Input). + -- Do not set the Controlling_Argument if already set. This happens in + -- the special case of _Input (see Exp_Attr, case Input). if No (Controlling_Argument (Call_Node)) then Set_Controlling_Argument (Call_Node, Control); @@ -1841,8 +1834,8 @@ package body Sem_Disp is end loop; -- Expansion of dispatching calls is suppressed when VM_Target, because - -- the VM back-ends directly handle the generation of dispatching - -- calls and would have to undo any expansion to an indirect call. + -- the VM back-ends directly handle the generation of dispatching calls + -- and would have to undo any expansion to an indirect call. if Tagged_Type_Expansion then Expand_Dispatching_Call (Call_Node); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5ff2d7c0341..2bba1030289 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4937,26 +4937,22 @@ package body Sem_Util is is Ifaces_List : Elist_Id; Elmt : Elmt_Id; - Iface : Entity_Id; - Typ : Entity_Id; + Iface : Entity_Id := Base_Type (Iface_Ent); + Typ : Entity_Id := Base_Type (Typ_Ent); begin - if Is_Class_Wide_Type (Typ_Ent) then - Typ := Etype (Typ_Ent); - else - Typ := Typ_Ent; - end if; - - if Is_Class_Wide_Type (Iface_Ent) then - Iface := Etype (Iface_Ent); - else - Iface := Iface_Ent; + if Is_Class_Wide_Type (Typ) then + Typ := Root_Type (Typ); end if; if not Has_Interfaces (Typ) then return False; end if; + if Is_Class_Wide_Type (Iface) then + Iface := Root_Type (Iface); + end if; + Collect_Interfaces (Typ, Ifaces_List); Elmt := First_Elmt (Ifaces_List);