From 4d2fc0014ea682cb02e9a899fef9a19aee760346 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 9 Sep 2010 09:47:53 +0000 Subject: [PATCH] 2010-09-09 Javier Miranda * sem_ch3.adb (Derive_Subprogram): The code that checks if a dispatching primitive covers some interface primitive is incomplete. Replace such code by the invocation of a new subprogram that provides this functionality. * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation. * sem_ch6.adb (Check_Missing_Return): Minor reformating (Check_Convention): Complete if-statement conditition when reporting errors (to avoid assertion failure). * sem_ch13.adb (Make_Null_Procedure_Specs): This routine was previously located in exp_ch3. Relocated inside Analyze_Freeze_Entity. (Analyze_Freeze_Entity): Invoke routine that adds the spec of non overridden null interface primitives. * sem_type.adb (Is_Ancestor): If the parent of the partial view of a private type is an interface then use the parent of its full view to climb to its ancestor type. * sem_disp.ads, sem_disp.adb (Covers_Some_Interface): New subprogram. (Check_Dispatching_Operation): Extend assertion to handle wrappers of null interface primitives. (Is_Null_Interface_Primitive): New subprogram. * exp_ch3.adb (Make_Null_Procedure_Specs): Removed. (Expand_Freeze_Record_Type): Do not generate specs of null interface subprograms because they are now generated by Analyze_Freeze_Entity. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@164059 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 25 ++++++++++ gcc/ada/exp_ch3.adb | 135 --------------------------------------------------- gcc/ada/sem_ch13.adb | 116 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_ch3.adb | 26 ++-------- gcc/ada/sem_ch6.adb | 6 ++- gcc/ada/sem_ch6.ads | 8 +-- gcc/ada/sem_disp.adb | 101 +++++++++++++++++++++++++++++++++++++- gcc/ada/sem_disp.ads | 8 +++ gcc/ada/sem_type.adb | 14 +++++- 9 files changed, 274 insertions(+), 165 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fd0ab2a..2a3e1a5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2010-09-09 Javier Miranda + + * sem_ch3.adb (Derive_Subprogram): The code that checks if a + dispatching primitive covers some interface primitive is incomplete. + Replace such code by the invocation of a new subprogram that provides + this functionality. + * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation. + * sem_ch6.adb (Check_Missing_Return): Minor reformating + (Check_Convention): Complete if-statement conditition when reporting + errors (to avoid assertion failure). + * sem_ch13.adb (Make_Null_Procedure_Specs): This routine was previously + located in exp_ch3. Relocated inside Analyze_Freeze_Entity. + (Analyze_Freeze_Entity): Invoke routine that adds the spec of non + overridden null interface primitives. + * sem_type.adb (Is_Ancestor): If the parent of the partial view of a + private type is an interface then use the parent of its full view to + climb to its ancestor type. + * sem_disp.ads, sem_disp.adb (Covers_Some_Interface): New subprogram. + (Check_Dispatching_Operation): Extend assertion to handle wrappers of + null interface primitives. + (Is_Null_Interface_Primitive): New subprogram. + * exp_ch3.adb (Make_Null_Procedure_Specs): Removed. + (Expand_Freeze_Record_Type): Do not generate specs of null interface + subprograms because they are now generated by Analyze_Freeze_Entity. + 2010-09-09 Robert Dewar * a-calfor.adb, sem_ch3.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 8fc874c..ae4213c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -312,14 +312,6 @@ package body Exp_Ch3 is -- invoking the inherited subprogram's parent subprogram and extended -- with a null association list. - procedure Make_Null_Procedure_Specs - (Tag_Typ : Entity_Id; - Decl_List : out 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; @@ -5886,7 +5878,6 @@ package body Exp_Ch3 is Wrapper_Decl_List : List_Id := No_List; Wrapper_Body_List : List_Id := No_List; - Null_Proc_Decl_List : List_Id := No_List; -- Start of processing for Expand_Freeze_Record_Type @@ -6089,20 +6080,6 @@ 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) - then - Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List); - Insert_Actions (N, Null_Proc_Decl_List); - end if; - Set_Is_Frozen (Def_Id); Set_All_DT_Position (Def_Id); @@ -8021,118 +7998,6 @@ package body Exp_Ch3 is end if; end Make_Eq_If; - ------------------------------- - -- Make_Null_Procedure_Specs -- - ------------------------------- - - procedure Make_Null_Procedure_Specs - (Tag_Typ : Entity_Id; - Decl_List : out List_Id) - is - 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; - - function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean; - -- Returns True if E is a null procedure that is an interface primitive - - --------------------------------- - -- Is_Null_Interface_Primitive -- - --------------------------------- - - function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is - begin - return Comes_From_Source (E) - and then Is_Dispatching_Operation (E) - and then Ekind (E) = E_Procedure - and then Null_Present (Parent (E)) - and then Is_Interface (Find_Dispatching_Type (E)); - end Is_Null_Interface_Primitive; - - -- Start of processing for Make_Null_Procedure_Specs - - begin - Decl_List := New_List; - 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); - Analyze (Proc_Decl); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end Make_Null_Procedure_Specs; - ------------------------------------- -- Make_Predefined_Primitive_Specs -- ------------------------------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5f067cc..8744911 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -44,6 +44,7 @@ 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; @@ -2356,6 +2357,106 @@ 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. @@ -2374,6 +2475,21 @@ 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_ch3.adb b/gcc/ada/sem_ch3.adb index 6015eae..c99cdfe 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -12284,10 +12284,6 @@ package body Sem_Ch3 is end if; end Set_Derived_Name; - -- Local variables - - Parent_Overrides_Interface_Primitive : Boolean := False; - -- Start of processing for Derive_Subprogram begin @@ -12295,23 +12291,6 @@ package body Sem_Ch3 is New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); Set_Ekind (New_Subp, Ekind (Parent_Subp)); - -- Check whether the parent overrides an interface primitive - - if Is_Overriding_Operation (Parent_Subp) then - declare - E : Entity_Id := Parent_Subp; - begin - while Present (Overridden_Operation (E)) loop - E := Ultimate_Alias (Overridden_Operation (E)); - end loop; - - Parent_Overrides_Interface_Primitive := - Is_Dispatching_Operation (E) - and then Present (Find_Dispatching_Type (E)) - and then Is_Interface (Find_Dispatching_Type (E)); - end; - end if; - -- Check whether the inherited subprogram is a private operation that -- should be inherited but not yet made visible. Such subprograms can -- become visible at a later point (e.g., the private part of a public @@ -12380,7 +12359,10 @@ package body Sem_Ch3 is -- overrides an interface primitive because interface primitives -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) - elsif Parent_Overrides_Interface_Primitive then + elsif Ada_Version >= Ada_05 + and then Is_Dispatching_Operation (Parent_Subp) + and then Covers_Some_Interface (Parent_Subp) + then Set_Derived_Name; -- Otherwise, the type is inheriting a private operation, so enter diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index baf5398..7c6704c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1714,7 +1714,7 @@ package body Sem_Ch6 is and then Present (Spec_Id) and then No_Return (Spec_Id) then - Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); + Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); end if; end Check_Missing_Return; @@ -4037,7 +4037,9 @@ package body Sem_Ch6 is Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); Error_Msg_Sloc := Sloc (Op); - if Comes_From_Source (Op) then + if Comes_From_Source (Op) + or else No (Alias (Op)) + then if not Is_Overriding_Operation (Op) then Error_Msg_N ("\\primitive % defined #", Typ); else diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 5752c21..057544c 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -183,9 +183,9 @@ package Sem_Ch6 is (Tagged_Type : Entity_Id; Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean; - -- Returns true if both primitives have a matching name and they are also - -- type conformant. Special management is done for functions returning - -- interfaces. + -- Returns true if both primitives have a matching name, they are type + -- conformant, and Prim is defined in the scope of Tagged_Type. Special + -- management is done for functions returning interfaces. function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index a21337b..6984693 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -91,6 +91,81 @@ package body Sem_Disp is Append_Unique_Elmt (New_Op, List); end Add_Dispatching_Operation; + --------------------------- + -- Covers_Some_Interface -- + --------------------------- + + function Covers_Some_Interface (Prim : Entity_Id) return Boolean is + Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim); + Elmt : Elmt_Id; + E : Entity_Id; + + begin + pragma Assert (Is_Dispatching_Operation (Prim)); + + -- Although this is a dispatching primitive we must check if its + -- dispatching type is available because it may be the primitive + -- of a private type not defined as tagged in its partial view. + + if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then + + -- If the tagged type is frozen then the internal entities associated + -- with interfaces are available in the list of primitives of the + -- tagged type and can be used to speed up this search. + + if Is_Frozen (Tagged_Type) then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + E := Node (Elmt); + + if Present (Interface_Alias (E)) + and then Alias (E) = Prim + then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Otherwise we must collect all the interface primitives and check + -- if the Prim will override some interface primitive. + + else + declare + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Prim : Entity_Id; + + begin + Collect_Interfaces (Tagged_Type, Ifaces_List); + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if Chars (E) = Chars (Prim) + and then Is_Interface_Conformant + (Tagged_Type, Iface_Prim, Prim) + then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + end if; + + return False; + end Covers_Some_Interface; + ------------------------------- -- Check_Controlling_Formals -- ------------------------------- @@ -794,7 +869,10 @@ package body Sem_Disp is -- type by Make_Controlling_Function_Wrappers. However, attribute -- Is_Dispatching_Operation must be set to true. - -- 2. Subprograms associated with stream attributes (built by + -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface + -- primitives. + + -- 3. Subprograms associated with stream attributes (built by -- New_Stream_Subprogram) if Present (Old_Subp) @@ -805,9 +883,17 @@ package body Sem_Disp is ((Ekind (Subp) = E_Function and then Is_Dispatching_Operation (Old_Subp) and then Is_Null_Extension (Base_Type (Etype (Subp)))) + or else + (Ekind (Subp) = E_Procedure + and then Is_Dispatching_Operation (Old_Subp) + and then Present (Alias (Old_Subp)) + and then Is_Null_Interface_Primitive + (Ultimate_Alias (Old_Subp))) or else Get_TSS_Name (Subp) = TSS_Stream_Read or else Get_TSS_Name (Subp) = TSS_Stream_Write); + Check_Controlling_Formals (Tagged_Type, Subp); + Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); Set_Is_Dispatching_Operation (Subp); end if; @@ -1602,6 +1688,19 @@ package body Sem_Disp is end if; end Is_Dynamically_Tagged; + --------------------------------- + -- Is_Null_Interface_Primitive -- + --------------------------------- + + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is + begin + return Comes_From_Source (E) + and then Is_Dispatching_Operation (E) + and then Ekind (E) = E_Procedure + and then Null_Present (Parent (E)) + and then Is_Interface (Find_Dispatching_Type (E)); + end Is_Null_Interface_Primitive; + -------------------------- -- Is_Tag_Indeterminate -- -------------------------- diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index 3877826..1888a68 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -66,6 +66,11 @@ package Sem_Disp is -- of "OldSubp" is adjusted to point to the inherited procedure of the -- full view because it is always this one which has to be called. + function Covers_Some_Interface (Prim : Entity_Id) return Boolean; + -- Returns true if Prim covers some interface primitive of its associated + -- tagged type. The tagged type of Prim must be frozen when this function + -- is invoked. + function Find_Controlling_Arg (N : Node_Id) return Node_Id; -- Returns the actual controlling argument if N is dynamically tagged, -- and Empty if it is not dynamically tagged. @@ -87,6 +92,9 @@ package Sem_Disp is -- an expression of a class_Wide type, or a call to a function with -- controlling result where at least one operand is dynamically tagged. + function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean; + -- Returns True if E is a null procedure that is an interface primitive + function Is_Tag_Indeterminate (N : Node_Id) return Boolean; -- An expression is tag-indeterminate if it is a call that dispatches -- on result, and all controlling operands are also indeterminate. diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 8f77157..083f4c8 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2619,7 +2619,19 @@ package body Sem_Type is return True; elsif Etype (Par) /= Par then - Par := Etype (Par); + + -- If this is a private type and its parent is an interface + -- then use the parent of the full view (which is a type that + -- implements such interface) + + if Is_Private_Type (Par) + and then Is_Interface (Etype (Par)) + and then Present (Full_View (Par)) + then + Par := Etype (Full_View (Par)); + else + Par := Etype (Par); + end if; else return False; end if; -- 2.7.4