From: Arnaud Charlet Date: Thu, 9 Sep 2010 10:01:41 +0000 (+0200) Subject: [multiple changes] X-Git-Tag: releases/gcc-4.6.0~4512 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=e5a58facaa37aff59eb40fc59b0cf8cdc724cb6f;p=thirdparty%2Fgcc.git [multiple changes] 2010-09-09 Ed Schonberg * sem_ch6.adb: Improve error message on untagged equality. * sem.adb (Semantics): Include subprogram bodies that act as spec. 2010-09-09 Javier Miranda * sem_ch13.adb, exp_ch13.adb: Undo previous change, unneeded. From-SVN: r164062 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e7c9e7de6894..c6e3b6213ea6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2010-09-09 Ed Schonberg + + * sem_ch6.adb: Improve error message on untagged equality. + * sem.adb (Semantics): Include subprogram bodies that act as spec. + +2010-09-09 Javier Miranda + + * sem_ch13.adb, exp_ch13.adb: Undo previous change, unneeded. + 2010-09-09 Robert Dewar * sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b11170cb6071..93303f9a21c2 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -312,6 +312,12 @@ package body Exp_Ch3 is -- invoking the inherited subprogram's parent subprogram and extended -- with a null association list. + function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id; + -- Ada 2005 (AI-251): Makes specs for null procedures associated with any + -- null procedures inherited from an interface type that have not been + -- overridden. Only one null procedure will be created for a given set of + -- inherited null procedures with homographic profiles. + function Predef_Spec_Or_Body (Loc : Source_Ptr; Tag_Typ : Entity_Id; @@ -5882,8 +5888,8 @@ package body Exp_Ch3 is -- user-defined equality function). Used to pass this entity from -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. - Wrapper_Decl_List : List_Id := No_List; - Wrapper_Body_List : List_Id := No_List; + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; -- Start of processing for Expand_Freeze_Record_Type @@ -6086,6 +6092,20 @@ package body Exp_Ch3 is Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); end if; + -- Ada 2005 (AI-251): For a nonabstract type extension, build + -- null procedure declarations for each set of homographic null + -- procedures that are inherited from interface types but not + -- overridden. This is done to ensure that the dispatch table + -- entry associated with such null primitives are properly filled. + + if Ada_Version >= Ada_05 + and then Etype (Def_Id) /= Def_Id + and then not Is_Abstract_Type (Def_Id) + and then Has_Interfaces (Def_Id) + then + Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id)); + end if; + Set_Is_Frozen (Def_Id); Set_All_DT_Position (Def_Id); @@ -8004,6 +8024,95 @@ package body Exp_Ch3 is end if; end Make_Eq_If; + ------------------------------- + -- Make_Null_Procedure_Specs -- + ------------------------------- + + function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is + Decl_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Tag_Typ); + Formal : Entity_Id; + Formal_List : List_Id; + New_Param_Spec : Node_Id; + Parent_Subp : Entity_Id; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Prim_Elmt) loop + Subp := Node (Prim_Elmt); + + -- If a null procedure inherited from an interface has not been + -- overridden, then we build a null procedure declaration to + -- override the inherited procedure. + + Parent_Subp := Alias (Subp); + + if Present (Parent_Subp) + and then Is_Null_Interface_Primitive (Parent_Subp) + then + Formal_List := No_List; + Formal := First_Formal (Subp); + + if Present (Formal) then + Formal_List := New_List; + + while Present (Formal) loop + + -- Copy the parameter spec including default expressions + + New_Param_Spec := + New_Copy_Tree (Parent (Formal), New_Sloc => Loc); + + -- Generate a new defining identifier for the new formal. + -- required because New_Copy_Tree does not duplicate + -- semantic fields (except itypes). + + Set_Defining_Identifier (New_Param_Spec, + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal))); + + -- For controlling arguments we must change their + -- parameter type to reference the tagged type (instead + -- of the interface type) + + if Is_Controlling_Formal (Formal) then + if Nkind (Parameter_Type (Parent (Formal))) + = N_Identifier + then + Set_Parameter_Type (New_Param_Spec, + New_Occurrence_Of (Tag_Typ, Loc)); + + else pragma Assert + (Nkind (Parameter_Type (Parent (Formal))) + = N_Access_Definition); + Set_Subtype_Mark (Parameter_Type (New_Param_Spec), + New_Occurrence_Of (Tag_Typ, Loc)); + end if; + end if; + + Append (New_Param_Spec, Formal_List); + + Next_Formal (Formal); + end loop; + end if; + + Append_To (Decl_List, + Make_Subprogram_Declaration (Loc, + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subp)), + Parameter_Specifications => Formal_List, + Null_Present => True))); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + return Decl_List; + end Make_Null_Procedure_Specs; + ------------------------------------- -- Make_Predefined_Primitive_Specs -- ------------------------------------- diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index f5c7629b401e..45f7216a5ca2 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1454,14 +1454,16 @@ package body Sem is -- Do analysis, and then append the compilation unit onto the -- Comp_Unit_List, if appropriate. This is done after analysis, so -- if this unit depends on some others, they have already been - -- appended. We ignore bodies, except for the main unit itself. We - -- have also to guard against ill-formed subunits that have an - -- improper context. + -- appended. We ignore bodies, except for the main unit itself, and + -- for subprogram bodies that act as specs. We have also to guard + -- against ill-formed subunits that have an improper context. Do_Analyze; if Present (Comp_Unit) and then Nkind (Unit (Comp_Unit)) in N_Proper_Body + and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body + or else not Acts_As_Spec (Comp_Unit)) and then not In_Extended_Main_Source_Unit (Comp_Unit) then null; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9d322f5dc424..5f067ccc2616 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -44,7 +44,6 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; -with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -2357,106 +2356,6 @@ package body Sem_Ch13 is procedure Analyze_Freeze_Entity (N : Node_Id) is E : constant Entity_Id := Entity (N); - function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id; - -- Ada 2005 (AI-251): Makes specs for null procedures associated with - -- null procedures inherited from interface types that have not been - -- overridden. Only one null procedure will be created for a given set - -- of inherited null procedures with homographic profiles. - - ------------------------------- - -- Make_Null_Procedure_Specs -- - ------------------------------- - - function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id - is - Decl_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Tag_Typ); - Formal : Entity_Id; - Formal_List : List_Id; - New_Param_Spec : Node_Id; - Parent_Subp : Entity_Id; - Prim_Elmt : Elmt_Id; - Proc_Decl : Node_Id; - Subp : Entity_Id; - - begin - Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); - while Present (Prim_Elmt) loop - Subp := Node (Prim_Elmt); - - -- If a null procedure inherited from an interface has not been - -- overridden, then we build a null procedure declaration to - -- override the inherited procedure. - - Parent_Subp := Alias (Subp); - - if Present (Parent_Subp) - and then Is_Null_Interface_Primitive (Parent_Subp) - then - Formal_List := No_List; - Formal := First_Formal (Subp); - - if Present (Formal) then - Formal_List := New_List; - - while Present (Formal) loop - - -- Copy the parameter spec including default expressions - - New_Param_Spec := - New_Copy_Tree (Parent (Formal), New_Sloc => Loc); - - -- Generate a new defining identifier for the new formal. - -- required because New_Copy_Tree does not duplicate - -- semantic fields (except itypes). - - Set_Defining_Identifier (New_Param_Spec, - Make_Defining_Identifier (Sloc (Formal), - Chars => Chars (Formal))); - - -- For controlling arguments we must change their - -- parameter type to reference the tagged type (instead - -- of the interface type) - - if Is_Controlling_Formal (Formal) then - if Nkind (Parameter_Type (Parent (Formal))) = - N_Identifier - then - Set_Parameter_Type (New_Param_Spec, - New_Occurrence_Of (Tag_Typ, Loc)); - - else pragma Assert - (Nkind (Parameter_Type (Parent (Formal))) - = N_Access_Definition); - Set_Subtype_Mark (Parameter_Type (New_Param_Spec), - New_Occurrence_Of (Tag_Typ, Loc)); - end if; - end if; - - Append (New_Param_Spec, Formal_List); - - Next_Formal (Formal); - end loop; - end if; - - Proc_Decl := - Make_Subprogram_Declaration (Loc, - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Chars (Subp)), - Parameter_Specifications => Formal_List, - Null_Present => True)); - Append_To (Decl_List, Proc_Decl); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - - return Decl_List; - end Make_Null_Procedure_Specs; - - -- Start of processing for Analyze_Freeze_Entity - begin -- For tagged types covering interfaces add internal entities that link -- the primitives of the interfaces with the primitives that cover them. @@ -2475,21 +2374,6 @@ package body Sem_Ch13 is and then not Is_Interface (E) and then Has_Interfaces (E) then - -- Add specs of non-overridden null interface primitives. During - -- semantic analysis this is required to ensure consistency of the - -- contents of the list of primitives of the tagged type. Routine - -- Add_Internal_Interface_Entities will take care of adding to such - -- list the internal entities that link each interface primitive with - -- the primitive of Tagged_Type that covers it; hence these specs - -- must be added before invoking Add_Internal_Interface_Entities. - -- In the expansion this consistency is required to ensure that the - -- dispatch table slots associated with non-overridden null interface - -- primitives are properly filled. - - if not Is_Abstract_Type (E) then - Insert_Actions (N, Make_Null_Procedure_Specs (E)); - end if; - -- This would be a good common place to call the routine that checks -- overriding of interface primitives (and thus factorize calls to -- Check_Abstract_Overriding located at different contexts in the diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index c456bbe0fa89..95ee36fe6fc8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -166,6 +166,13 @@ package body Sem_Ch6 is -- True otherwise. Proc is the entity for the procedure case and is used -- in posting the warning message. + procedure Check_Untagged_Equality (Eq_Op : Entity_Id); + -- In Ada 2012, a primitive equality operator on an untagged record type + -- must appear before the type is frozen, and have the same visibility as + -- that of the type. This procedure checks that this rule is met, and + -- otherwise emits an error on the subprogram declaration and a warning + -- on the earlier freeze point if it is easy to locate. + procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first visible -- entity with that name. @@ -5789,6 +5796,51 @@ package body Sem_Ch6 is end if; end Enter_Overloaded_Entity; + ----------------------------- + -- Check_Untagged_Equality -- + ----------------------------- + + procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is + Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); + Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); + Obj_Decl : Node_Id; + + begin + if Nkind (Decl) = N_Subprogram_Declaration + and then Is_Record_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + if Is_Frozen (Typ) then + Error_Msg_NE + ("equality operator must be declared " + & "before type& is frozen", Eq_Op, Typ); + + Obj_Decl := Next (Parent (Typ)); + while Present (Obj_Decl) + and then Obj_Decl /= Decl + loop + if Nkind (Obj_Decl) = N_Object_Declaration + and then Etype (Defining_Identifier (Obj_Decl)) = Typ + then + Error_Msg_NE ("type& is frozen by declaration?", + Obj_Decl, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this " + & "point ('R'M 4.5.2 (9.8)) (Ada2012))?", Obj_Decl); + exit; + end if; + + Next (Obj_Decl); + end loop; + + elsif not In_Same_List (Parent (Typ), Decl) + and then not Is_Limited_Type (Typ) + then + Error_Msg_N ("equality operator appears too late", Eq_Op); + end if; + end if; + end Check_Untagged_Equality; + ----------------------------- -- Find_Corresponding_Spec -- ----------------------------- @@ -7975,32 +8027,9 @@ package body Sem_Ch6 is then Make_Inequality_Operator (S); - -- In Ada 2012, a primitive equality operator on a record type - -- must appear before the type is frozen, and have the same - -- visibility as the type. - - declare - Typ : constant Entity_Id := Etype (First_Formal (S)); - Decl : constant Node_Id := Unit_Declaration_Node (S); - - begin - if Ada_Version >= Ada_12 - and then Nkind (Decl) = N_Subprogram_Declaration - and then Is_Record_Type (Typ) - then - if Is_Frozen (Typ) then - Error_Msg_NE - ("equality operator must be declared " - & "before type& is frozen", S, Typ); - - elsif not In_Same_List (Parent (Typ), Decl) - and then not Is_Limited_Type (Typ) - then - Error_Msg_N - ("equality operator appears too late", S); - end if; - end if; - end; + if Ada_Version >= Ada_12 then + Check_Untagged_Equality (S); + end if; end if; end New_Overloaded_Entity;