From 42f11e4c26a824c2fa4b8f9bfc9e4af69fe86dc8 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 2 May 2016 12:18:12 +0200 Subject: [PATCH] [multiple changes] 2016-05-02 Hristian Kirtchev * exp_prag.adb, comperr.adb: Minor reformatting. 2016-05-02 Ed Schonberg * exp_pakd.adb (Rj_Unchecked_Convert_To): Do not perform an unchecked conversion if the source size is 0 (indicating that its RM size is unknown). This will happen with packed arrays of non-discrete types, in which case the component type is known to match. 2016-05-02 Arnaud Charlet * debug.adb: Reserve -gnatd.V. 2016-05-02 Javier Miranda * sem_ch3.adb (Process_Full_View): Remove from visibility wrappers of synchronized types to avoid spurious errors with their wrapped entity. * exp_ch9.adb (Build_Wrapper_Spec): Do not generate the wrapper if no interface primitive is covered by the subprogram and this is not a primitive declared between two views; see Process_Full_View. (Build_Protected_Sub_Specification): Link the dispatching subprogram with its original non-dispatching protected subprogram since their names differ. (Expand_N_Protected_Type_Declaration): If a protected subprogram overrides an interface primitive then do not build a wrapper if it was already built. * einfo.ads, einfo.adb (Original_Protected_Subprogram): New attribute. * sem_ch4.adb (Names_Match): New subprogram. * sem_ch6.adb (Check_Synchronized_Overriding): Moved to library level and defined in the public part of the package to invoke it from Exp_Ch9.Build_Wrapper_Spec (Has_Matching_Entry_Or_Subprogram): New subprogram. (Report_Conflict): New subprogram. From-SVN: r235739 --- gcc/ada/ChangeLog | 38 ++ gcc/ada/comperr.adb | 5 +- gcc/ada/debug.adb | 8 +- gcc/ada/einfo.adb | 16 + gcc/ada/einfo.ads | 11 + gcc/ada/exp_ch9.adb | 121 +++--- gcc/ada/exp_pakd.adb | 7 +- gcc/ada/exp_prag.adb | 4 +- gcc/ada/sem_ch3.adb | 7 + gcc/ada/sem_ch4.adb | 39 +- gcc/ada/sem_ch6.adb | 895 ++++++++++++++++++++++++++++--------------- gcc/ada/sem_ch6.ads | 11 +- 12 files changed, 791 insertions(+), 371 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4997791b118..8acbbb3ec32 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2016-05-02 Hristian Kirtchev + + * exp_prag.adb, comperr.adb: Minor reformatting. + +2016-05-02 Ed Schonberg + + * exp_pakd.adb (Rj_Unchecked_Convert_To): Do not perform an + unchecked conversion if the source size is 0 (indicating that + its RM size is unknown). This will happen with packed arrays of + non-discrete types, in which case the component type is known + to match. + +2016-05-02 Arnaud Charlet + + * debug.adb: Reserve -gnatd.V. + +2016-05-02 Javier Miranda + + * sem_ch3.adb (Process_Full_View): Remove from visibility + wrappers of synchronized types to avoid spurious errors with + their wrapped entity. + * exp_ch9.adb (Build_Wrapper_Spec): Do not generate the wrapper + if no interface primitive is covered by the subprogram and this is + not a primitive declared between two views; see Process_Full_View. + (Build_Protected_Sub_Specification): Link the dispatching + subprogram with its original non-dispatching protected subprogram + since their names differ. + (Expand_N_Protected_Type_Declaration): + If a protected subprogram overrides an interface primitive then + do not build a wrapper if it was already built. + * einfo.ads, einfo.adb (Original_Protected_Subprogram): New attribute. + * sem_ch4.adb (Names_Match): New subprogram. + * sem_ch6.adb (Check_Synchronized_Overriding): Moved + to library level and defined in the public part of the + package to invoke it from Exp_Ch9.Build_Wrapper_Spec + (Has_Matching_Entry_Or_Subprogram): New subprogram. + (Report_Conflict): New subprogram. + 2016-05-02 Jerome Lambourg * s-unstyp.ads: Code cleanups. diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 7838cc49948..f7061d51c29 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -467,8 +467,9 @@ package body Comperr is Main := Unit (Cunit (Main_Unit)); case Nkind (Main) is - when N_Subprogram_Declaration | N_Subprogram_Body | - N_Package_Declaration => + when N_Package_Declaration | + N_Subprogram_Body | + N_Subprogram_Declaration => Unit_Name := Defining_Unit_Name (Specification (Main)); when N_Package_Body => diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index f39691304af..a4e83a9fad7 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -139,7 +139,7 @@ package body Debug is -- d.S Force Optimize_Alignment (Space) -- d.T Force Optimize_Alignment (Time) -- d.U Ignore indirect calls for static elaboration - -- d.V + -- d.V Do not verify validity of SCIL files (CodePeer mode) -- d.W Print out debugging information for Walk_Library_Items -- d.X Old treatment of indexing aspects -- d.Y @@ -686,6 +686,12 @@ package body Debug is -- reverts to the behavior of earlier compilers, which ignored -- indirect calls. + -- d.V Do not verify the validity of SCIL files (CodePeer mode). When + -- generating SCIL files for CodePeer, by default we verify that the + -- SCIL is well formed before saving it on disk. This switch can be + -- used to disable this checking, either to improve speed or to shut + -- down a false positive detected during the verification. + -- d.W Print out debugging information for Walk_Library_Items, including -- the order in which units are walked. This is primarily for use in -- debugging CodePeer mode. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 378b75711ec..e66ca79aa7c 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -274,6 +274,7 @@ package body Einfo is -- SPARK_Pragma Node40 + -- Original_Protected_Subprogram Node41 -- SPARK_Aux_Pragma Node41 --------------------------------------------- @@ -2837,6 +2838,11 @@ package body Einfo is return Node21 (Id); end Original_Array_Type; + function Original_Protected_Subprogram (Id : E) return N is + begin + return Node41 (Id); + end Original_Protected_Subprogram; + function Original_Record_Component (Id : E) return E is begin pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); @@ -5900,6 +5906,12 @@ package body Einfo is Set_Node21 (Id, V); end Set_Original_Array_Type; + procedure Set_Original_Protected_Subprogram (Id : E; V : N) is + begin + pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); + Set_Node41 (Id, V); + end Set_Original_Protected_Subprogram; + procedure Set_Original_Record_Component (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); @@ -10483,6 +10495,10 @@ package body Einfo is E_Task_Type => Write_Str ("SPARK_Aux_Pragma"); + when E_Function | + E_Procedure => + Write_Str ("Original_Protected_Subprogram"); + when others => Write_Str ("Field41??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 9e289592448..901e2ef937e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3647,6 +3647,11 @@ package Einfo is -- points to the original array type for which this is the packed -- array implementation type. +-- Original_Protected_Subprogram (Node41) +-- Defined in functions and procedures. Set only on internally built +-- dispatching subprograms of protected types to reference their original +-- non-dispatching protected subprogram since their names differ. + -- Original_Record_Component (Node22) -- Defined in components, including discriminants. The usage depends -- on whether the record is a base type and whether it is tagged. @@ -5923,6 +5928,7 @@ package Einfo is -- Class_Wide_Preconds (List38) -- Class_Wide_Postconds (List39) -- SPARK_Pragma (Node40) + -- Original_Protected_Subprogram (Node41) -- Body_Needed_For_SAL (Flag40) -- Contains_Ignored_Ghost_Code (Flag279) -- Default_Expressions_Processed (Flag108) @@ -6234,6 +6240,7 @@ package Einfo is -- Class_Wide_Preconds (List38) -- Class_Wide_Postconds (List39) -- SPARK_Pragma (Node40) + -- Original_Protected_Subprogram (Node41) -- Body_Needed_For_SAL (Flag40) -- Contains_Ignored_Ghost_Code (Flag279) -- Delay_Cleanups (Flag114) @@ -7127,6 +7134,7 @@ package Einfo is function Optimize_Alignment_Time (Id : E) return B; function Original_Access_Type (Id : E) return E; function Original_Array_Type (Id : E) return E; + function Original_Protected_Subprogram (Id : E) return N; function Original_Record_Component (Id : E) return E; function Overlays_Constant (Id : E) return B; function Overridden_Operation (Id : E) return E; @@ -7801,6 +7809,7 @@ package Einfo is procedure Set_Optimize_Alignment_Time (Id : E; V : B := True); procedure Set_Original_Access_Type (Id : E; V : E); procedure Set_Original_Array_Type (Id : E; V : E); + procedure Set_Original_Protected_Subprogram (Id : E; V : N); procedure Set_Original_Record_Component (Id : E; V : E); procedure Set_Overlays_Constant (Id : E; V : B := True); procedure Set_Overridden_Operation (Id : E; V : E); @@ -8628,6 +8637,7 @@ package Einfo is pragma Inline (Optimize_Alignment_Time); pragma Inline (Original_Access_Type); pragma Inline (Original_Array_Type); + pragma Inline (Original_Protected_Subprogram); pragma Inline (Original_Record_Component); pragma Inline (Overlays_Constant); pragma Inline (Overridden_Operation); @@ -9093,6 +9103,7 @@ package Einfo is pragma Inline (Set_Optimize_Alignment_Time); pragma Inline (Set_Original_Access_Type); pragma Inline (Set_Original_Array_Type); + pragma Inline (Set_Original_Protected_Subprogram); pragma Inline (Set_Original_Record_Component); pragma Inline (Set_Overlays_Constant); pragma Inline (Set_Overridden_Operation); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index faa1d8cafd0..e48b9839064 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -2443,13 +2443,6 @@ package body Exp_Ch9 is Obj_Typ : Entity_Id; Formals : List_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Subp_Id); - First_Param : Node_Id; - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; - Iface_Op : Entity_Id; - Iface_Op_Elmt : Elmt_Id; - function Overriding_Possible (Iface_Op : Entity_Id; Wrapper : Entity_Id) return Boolean; @@ -2631,6 +2624,16 @@ package body Exp_Ch9 is return New_Formals; end Replicate_Formals; + -- Local variables + + Loc : constant Source_Ptr := Sloc (Subp_Id); + First_Param : Node_Id := Empty; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Op : Entity_Id; + Iface_Op_Elmt : Elmt_Id; + Overridden_Subp : Entity_Id; + -- Start of processing for Build_Wrapper_Spec begin @@ -2638,17 +2641,24 @@ package body Exp_Ch9 is pragma Assert (Is_Tagged_Type (Obj_Typ)); + -- Check if this subprogram has a profile that matches some interface + -- primitive + + Check_Synchronized_Overriding (Subp_Id, Overridden_Subp); + + if Present (Overridden_Subp) then + First_Param := + First (Parameter_Specifications (Parent (Overridden_Subp))); + -- An entry or a protected procedure can override a routine where the -- controlling formal is either IN OUT, OUT or is of access-to-variable -- type. Since the wrapper must have the exact same signature as that of -- the overridden subprogram, we try to find the overriding candidate -- and use its controlling formal. - First_Param := Empty; - -- Check every implemented interface - if Present (Interfaces (Obj_Typ)) then + elsif Present (Interfaces (Obj_Typ)) then Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); Search : while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); @@ -2684,40 +2694,14 @@ package body Exp_Ch9 is end loop Search; end if; - -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by - -- this subprogram and this is not a primitive declared between two - -- views then force the generation of a wrapper. As an optimization, - -- previous versions of the frontend avoid generating the wrapper; - -- however, the wrapper facilitates locating and reporting an error - -- when a duplicate declaration is found later. See example in - -- AI05-0090-1. + -- Do not generate the wrapper if no interface primitive is covered by + -- the subprogram and it is not a primitive declared declared between + -- two views (see Process_Full_View). if No (First_Param) and then not Is_Private_Primitive_Subprogram (Subp_Id) then - if Is_Task_Type - (Corresponding_Concurrent_Type (Obj_Typ)) - then - First_Param := - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), - In_Present => True, - Out_Present => False, - Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); - - -- For entries and procedures of protected types the mode of - -- the controlling argument must be in-out. - - else - First_Param := - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Name_uO), - In_Present => True, - Out_Present => (Ekind (Subp_Id) /= E_Function), - Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); - end if; + return Empty; end if; declare @@ -4229,6 +4213,15 @@ package body Exp_Ch9 is Make_Defining_Identifier (Loc, Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); + -- Reference the original non-dispatching subprogram since the analysis + -- of the object.operation notation may need its original name (see + -- Sem_Ch4.Names_Match). + + if Mode = Dispatching_Mode then + Set_Ekind (New_Id, Ekind (Def_Id)); + Set_Original_Protected_Subprogram (New_Id, Def_Id); + end if; + -- The unprotected operation carries the user code, and debugging -- information must be generated for it, even though this spec does -- not come from source. It is also convenient to allow gdb to step @@ -9653,22 +9646,50 @@ package body Exp_Ch9 is Current_Node := Sub; -- Generate an overriding primitive operation specification for - -- this subprogram if the protected type implements an interface. + -- this subprogram if the protected type implements an interface + -- and Build_Wrapper_Spec did not not generate its wrapper. if Ada_Version >= Ada_2005 and then Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) then - Sub := - Make_Subprogram_Declaration (Loc, - Specification => - Build_Protected_Sub_Specification - (Comp, Prot_Typ, Dispatching_Mode)); + declare + Prim_Elmt : Elmt_Id; + Prim_Op : Node_Id; + Found : Boolean := False; - Insert_After (Current_Node, Sub); - Analyze (Sub); + begin + Prim_Elmt := + First_Elmt + (Primitive_Operations + (Corresponding_Record_Type (Prot_Typ))); - Current_Node := Sub; + while Present (Prim_Elmt) loop + Prim_Op := Node (Prim_Elmt); + + if Is_Primitive_Wrapper (Prim_Op) + and then (Wrapped_Entity (Prim_Op)) + = Defining_Entity (Specification (Comp)) + then + Found := True; + exit; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + if not Found then + Sub := + Make_Subprogram_Declaration (Loc, + Specification => + Build_Protected_Sub_Specification + (Comp, Prot_Typ, Dispatching_Mode)); + Insert_After (Current_Node, Sub); + Analyze (Sub); + + Current_Node := Sub; + end if; + end; end if; -- If a pragma Interrupt_Handler applies, build and add a call to diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index c8ba68a17d0..ea82596b820 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -2298,9 +2298,12 @@ package body Exp_Pakd is -- convert to a modular type of the source length, since otherwise, on -- a big-endian machine, we get left-justification. We do it for little- -- endian machines as well, because there might be junk bits that are - -- not cleared if the type is not numeric. + -- not cleared if the type is not numeric. This can be done only if the + -- source siz is different from 0 (i.e. known), otherwise we must trust + -- the type declarations (case of non-discrete components). - if Source_Siz /= Target_Siz + if Source_Siz /= 0 + and then Source_Siz /= Target_Siz and then not Is_Discrete_Type (Source_Typ) then Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src); diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index ac1aa8c24f0..62de26ba026 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -884,8 +884,8 @@ package body Exp_Prag is Set_Expression (Decl, Pref); Analyze (Decl); - -- Otherwise add an assignment statement to temporary - -- using prefix as RHS. + -- Otherwise add an assignment statement to temporary using + -- prefix as RHS. else Analyze (Decl); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 46079c5f6e9..df0293c8525 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -19835,6 +19835,13 @@ package body Sem_Ch3 is Curr_Nod := Wrap_Spec; Analyze (Wrap_Spec); + + -- Remove the wrapper from visibility to avoid + -- spurious conflict with the wrapped entity. + + Set_Is_Immediately_Visible + (Defining_Entity (Specification (Wrap_Spec)), + False); end if; Next_Elmt (Prim_Elmt); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c867cf64b87..73fa52199ca 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -8817,6 +8817,15 @@ package body Sem_Ch4 is -- is visible a direct call to it will dispatch to the private one, -- which is therefore a valid candidate. + function Names_Match + (Obj_Type : Entity_Id; + Prim_Op : Entity_Id; + Subprog : Entity_Id) return Boolean; + -- Return True if the names of Prim_Op and Subprog match. If Obj_Type + -- is a protected type then compare also the original name of Prim_Op + -- with the name of Subprog (since the expander may have added a + -- prefix to its original name --see Exp_Ch9.Build_Selected_Name). + function Valid_First_Argument_Of (Op : Entity_Id) return Boolean; -- Verify that the prefix, dereferenced if need be, is a valid -- controlling argument in a call to Op. The remaining actuals @@ -8993,6 +9002,34 @@ package body Sem_Ch4 is and then not Is_Hidden (Visible_Op); end Is_Private_Overriding; + ----------------- + -- Names_Match -- + ----------------- + + function Names_Match + (Obj_Type : Entity_Id; + Prim_Op : Entity_Id; + Subprog : Entity_Id) return Boolean is + begin + -- Common case: exact match + + if Chars (Prim_Op) = Chars (Subprog) then + return True; + + -- For protected type primitives the expander may have built the + -- name of the dispatching primitive prepending the type name to + -- avoid conflicts with the name of the protected subprogram (see + -- Exp_Ch9.Build_Selected_Name). + + elsif Is_Protected_Type (Obj_Type) then + return Present (Original_Protected_Subprogram (Prim_Op)) + and then Chars (Original_Protected_Subprogram (Prim_Op)) + = Chars (Subprog); + end if; + + return False; + end Names_Match; + ----------------------------- -- Valid_First_Argument_Of -- ----------------------------- @@ -9059,7 +9096,7 @@ package body Sem_Ch4 is while Present (Elmt) loop Prim_Op := Node (Elmt); - if Chars (Prim_Op) = Chars (Subprog) + if Names_Match (Obj_Type, Prim_Op, Subprog) and then Present (First_Formal (Prim_Op)) and then Valid_First_Argument_Of (Prim_Op) and then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 06937225957..d7647a3c1bf 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6463,6 +6463,341 @@ package body Sem_Ch6 is Get_Inst => Get_Inst); end Check_Subtype_Conformant; + ----------------------------------- + -- Check_Synchronized_Overriding -- + ----------------------------------- + + procedure Check_Synchronized_Overriding + (Def_Id : Entity_Id; + Overridden_Subp : out Entity_Id) + is + Ifaces_List : Elist_Id; + In_Scope : Boolean; + Typ : Entity_Id; + + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean; + -- Determine whether a subprogram's parameter profile Prim_Params + -- matches that of a potentially overridden interface subprogram + -- Iface_Params. Also determine if the type of first parameter of + -- Iface_Params is an implemented interface. + + ----------------------------------- + -- Matches_Prefixed_View_Profile -- + ----------------------------------- + + function Matches_Prefixed_View_Profile + (Prim_Params : List_Id; + Iface_Params : List_Id) return Boolean + is + Iface_Id : Entity_Id; + Iface_Param : Node_Id; + Iface_Typ : Entity_Id; + Prim_Id : Entity_Id; + Prim_Param : Node_Id; + Prim_Typ : Entity_Id; + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean; + -- Determine if Iface is implemented by the current task or + -- protected type. + + -------------------- + -- Is_Implemented -- + -------------------- + + function Is_Implemented + (Ifaces_List : Elist_Id; + Iface : Entity_Id) return Boolean + is + Iface_Elmt : Elmt_Id; + + begin + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + + return False; + end Is_Implemented; + + -- Start of processing for Matches_Prefixed_View_Profile + + begin + Iface_Param := First (Iface_Params); + Iface_Typ := Etype (Defining_Identifier (Iface_Param)); + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Designated_Type (Iface_Typ); + end if; + + Prim_Param := First (Prim_Params); + + -- The first parameter of the potentially overridden subprogram + -- must be an interface implemented by Prim. + + if not Is_Interface (Iface_Typ) + or else not Is_Implemented (Ifaces_List, Iface_Typ) + then + return False; + end if; + + -- The checks on the object parameters are done, move onto the + -- rest of the parameters. + + if not In_Scope then + Prim_Param := Next (Prim_Param); + end if; + + Iface_Param := Next (Iface_Param); + while Present (Iface_Param) and then Present (Prim_Param) loop + Iface_Id := Defining_Identifier (Iface_Param); + Iface_Typ := Find_Parameter_Type (Iface_Param); + + Prim_Id := Defining_Identifier (Prim_Param); + Prim_Typ := Find_Parameter_Type (Prim_Param); + + if Ekind (Iface_Typ) = E_Anonymous_Access_Type + and then Ekind (Prim_Typ) = E_Anonymous_Access_Type + and then Is_Concurrent_Type (Designated_Type (Prim_Typ)) + then + Iface_Typ := Designated_Type (Iface_Typ); + Prim_Typ := Designated_Type (Prim_Typ); + end if; + + -- Case of multiple interface types inside a parameter profile + + -- (Obj_Param : in out Iface; ...; Param : Iface) + + -- If the interface type is implemented, then the matching type + -- in the primitive should be the implementing record type. + + if Ekind (Iface_Typ) = E_Record_Type + and then Is_Interface (Iface_Typ) + and then Is_Implemented (Ifaces_List, Iface_Typ) + then + if Prim_Typ /= Typ then + return False; + end if; + + -- The two parameters must be both mode and subtype conformant + + elsif Ekind (Iface_Id) /= Ekind (Prim_Id) + or else not + Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) + then + return False; + end if; + + Next (Iface_Param); + Next (Prim_Param); + end loop; + + -- One of the two lists contains more parameters than the other + + if Present (Iface_Param) or else Present (Prim_Param) then + return False; + end if; + + return True; + end Matches_Prefixed_View_Profile; + + -- Start of processing for Check_Synchronized_Overriding + + begin + Overridden_Subp := Empty; + + -- Def_Id must be an entry or a subprogram. We should skip predefined + -- primitives internally generated by the frontend; however at this + -- stage predefined primitives are still not fully decorated. As a + -- minor optimization we skip here internally generated subprograms. + + if (Ekind (Def_Id) /= E_Entry + and then Ekind (Def_Id) /= E_Function + and then Ekind (Def_Id) /= E_Procedure) + or else not Comes_From_Source (Def_Id) + then + return; + end if; + + -- Search for the concurrent declaration since it contains the list + -- of all implemented interfaces. In this case, the subprogram is + -- declared within the scope of a protected or a task type. + + if Present (Scope (Def_Id)) + and then Is_Concurrent_Type (Scope (Def_Id)) + and then not Is_Generic_Actual_Type (Scope (Def_Id)) + then + Typ := Scope (Def_Id); + In_Scope := True; + + -- The enclosing scope is not a synchronized type and the subprogram + -- has no formals. + + elsif No (First_Formal (Def_Id)) then + return; + + -- The subprogram has formals and hence it may be a primitive of a + -- concurrent type. + + else + Typ := Etype (First_Formal (Def_Id)); + + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); + end if; + + if Is_Concurrent_Type (Typ) + and then not Is_Generic_Actual_Type (Typ) + then + In_Scope := False; + + -- This case occurs when the concurrent type is declared within + -- a generic unit. As a result the corresponding record has been + -- built and used as the type of the first formal, we just have + -- to retrieve the corresponding concurrent type. + + elsif Is_Concurrent_Record_Type (Typ) + and then not Is_Class_Wide_Type (Typ) + and then Present (Corresponding_Concurrent_Type (Typ)) + then + Typ := Corresponding_Concurrent_Type (Typ); + In_Scope := False; + + else + return; + end if; + end if; + + -- There is no overriding to check if is an inherited operation in a + -- type derivation on for a generic actual. + + Collect_Interfaces (Typ, Ifaces_List); + + if Is_Empty_Elmt_List (Ifaces_List) then + return; + end if; + + -- Determine whether entry or subprogram Def_Id overrides a primitive + -- operation that belongs to one of the interfaces in Ifaces_List. + + declare + Candidate : Entity_Id := Empty; + Hom : Entity_Id := Empty; + Subp : Entity_Id := Empty; + + begin + -- Traverse the homonym chain, looking for a potentially + -- overridden subprogram that belongs to an implemented + -- interface. + + Hom := Current_Entity_In_Scope (Def_Id); + while Present (Hom) loop + Subp := Hom; + + if Subp = Def_Id + or else not Is_Overloadable (Subp) + or else not Is_Primitive (Subp) + or else not Is_Dispatching_Operation (Subp) + or else not Present (Find_Dispatching_Type (Subp)) + or else not Is_Interface (Find_Dispatching_Type (Subp)) + then + null; + + -- Entries and procedures can override abstract or null + -- interface procedures. + + elsif (Ekind (Def_Id) = E_Procedure + or else Ekind (Def_Id) = E_Entry) + and then Ekind (Subp) = E_Procedure + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + then + Candidate := Subp; + + -- For an overridden subprogram Subp, check whether the mode + -- of its first parameter is correct depending on the kind + -- of synchronized type. + + declare + Formal : constant Node_Id := First_Formal (Candidate); + + begin + -- In order for an entry or a protected procedure to + -- override, the first parameter of the overridden + -- routine must be of mode "out", "in out" or + -- access-to-variable. + + if Ekind_In (Candidate, E_Entry, E_Procedure) + and then Is_Protected_Type (Typ) + and then Ekind (Formal) /= E_In_Out_Parameter + and then Ekind (Formal) /= E_Out_Parameter + and then Nkind (Parameter_Type (Parent (Formal))) /= + N_Access_Definition + then + null; + + -- All other cases are OK since a task entry or routine + -- does not have a restriction on the mode of the first + -- parameter of the overridden interface routine. + + else + Overridden_Subp := Candidate; + return; + end if; + end; + + -- Functions can override abstract interface functions + + elsif Ekind (Def_Id) = E_Function + and then Ekind (Subp) = E_Function + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + and then Etype (Result_Definition (Parent (Def_Id))) = + Etype (Result_Definition (Parent (Subp))) + then + Candidate := Subp; + + -- If an inherited subprogram is implemented by a protected + -- function, then the first parameter of the inherited + -- subprogram shall be of mode in, but not an + -- access-to-variable parameter (RM 9.4(11/9) + + if Present (First_Formal (Subp)) + and then Ekind (First_Formal (Subp)) = E_In_Parameter + and then + (not Is_Access_Type (Etype (First_Formal (Subp))) + or else + Is_Access_Constant (Etype (First_Formal (Subp)))) + then + Overridden_Subp := Subp; + return; + end if; + end if; + + Hom := Homonym (Hom); + end loop; + + -- After examining all candidates for overriding, we are left with + -- the best match which is a mode incompatible interface routine. + + if In_Scope and then Present (Candidate) then + Error_Msg_PT (Def_Id, Candidate); + end if; + + Overridden_Subp := Candidate; + return; + end; + end Check_Synchronized_Overriding; + --------------------------- -- Check_Type_Conformant -- --------------------------- @@ -9000,14 +9335,14 @@ package body Sem_Ch6 is -- type, and set Is_Primitive to True (otherwise set to False). Set the -- corresponding flag on the entity itself for later use. - procedure Check_Synchronized_Overriding - (Def_Id : Entity_Id; - Overridden_Subp : out Entity_Id); - -- First determine if Def_Id is an entry or a subprogram either defined - -- in the scope of a task or protected type, or is a primitive of such - -- a type. Check whether Def_Id overrides a subprogram of an interface - -- implemented by the synchronized type, return the overridden entity - -- or Empty. + function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean; + -- True if a) E is a subprogram whose first formal is a concurrent type + -- defined in the scope of E that has some entry or subprogram whose + -- profile matches E, or b) E is an internally built dispatching + -- subprogram of a protected type and there is a matching subprogram + -- defined in the enclosing scope of the protected type, or c) E is + -- an entry of a synchronized type and a matching procedure has been + -- previously defined in the enclosing scope of the synchronized type. function Is_Private_Declaration (E : Entity_Id) return Boolean; -- Check that E is declared in the private part of the current package, @@ -9025,6 +9360,9 @@ package body Sem_Ch6 is -- function is conservative given that the converse is only true within -- instances that contain accidental overloadings. + procedure Report_Conflict (S : Entity_Id; E : Entity_Id); + -- Report conflict between entities S and E. + ------------------------------------ -- Check_For_Primitive_Subprogram -- ------------------------------------ @@ -9350,340 +9688,256 @@ package body Sem_Ch6 is end if; end Check_For_Primitive_Subprogram; - ----------------------------------- - -- Check_Synchronized_Overriding -- - ----------------------------------- + -------------------------------------- + -- Has_Matching_Entry_Or_Subprogram -- + -------------------------------------- - procedure Check_Synchronized_Overriding - (Def_Id : Entity_Id; - Overridden_Subp : out Entity_Id) + function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean is - Ifaces_List : Elist_Id; - In_Scope : Boolean; - Typ : Entity_Id; - - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean; - -- Determine whether a subprogram's parameter profile Prim_Params - -- matches that of a potentially overridden interface subprogram - -- Iface_Params. Also determine if the type of first parameter of - -- Iface_Params is an implemented interface. - - ----------------------------------- - -- Matches_Prefixed_View_Profile -- - ----------------------------------- - - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean + function Check_Conforming_Parameters + (E1_Param : Node_Id; + E2_Param : Node_Id) return Boolean; + -- Starting from the given parameters, check that all the parameters + -- of two entries or subprograms are are subtype conformant. Used to + -- skip the check on the controlling argument. + + function Matching_Entry_Or_Subprogram + (Conc_Typ : Entity_Id; + Subp : Entity_Id) return Entity_Id; + -- Return the first entry or subprogram of the given concurrent type + -- whose name matches the name of Subp and has a profile conformant + -- with Subp; return Empty if not found. + + function Matching_Dispatching_Subprogram + (Conc_Typ : Entity_Id; + Ent : Entity_Id) return Entity_Id; + -- Return the first dispatching primitive of Conc_Type defined in the + -- enclosing scope of Conc_Type (ie. before the full definition of + -- this concurrent type) whose name matches the entry Ent and has a + -- profile conformant with the profile of the corresponding (not yet + -- built) dispatching primitive of Ent; return Empty if not found. + + function Matching_Original_Protected_Subprogram + (Prot_Typ : Entity_Id; + Subp : Entity_Id) return Entity_Id; + -- Return the first subprogram defined in the enclosing scope of + -- Prot_Typ (before the full definition of this protected type) + -- whose name matches the original name of Subp and has a profile + -- conformant with the profile of Subp; return Empty if not found. + + --------------------------------- + -- Check_Confirming_Parameters -- + --------------------------------- + + function Check_Conforming_Parameters + (E1_Param : Node_Id; + E2_Param : Node_Id) return Boolean is - Iface_Id : Entity_Id; - Iface_Param : Node_Id; - Iface_Typ : Entity_Id; - Prim_Id : Entity_Id; - Prim_Param : Node_Id; - Prim_Typ : Entity_Id; - - function Is_Implemented - (Ifaces_List : Elist_Id; - Iface : Entity_Id) return Boolean; - -- Determine if Iface is implemented by the current task or - -- protected type. - - -------------------- - -- Is_Implemented -- - -------------------- - - function Is_Implemented - (Ifaces_List : Elist_Id; - Iface : Entity_Id) return Boolean - is - Iface_Elmt : Elmt_Id; - - begin - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) loop - if Node (Iface_Elmt) = Iface then - return True; - end if; - - Next_Elmt (Iface_Elmt); - end loop; - - return False; - end Is_Implemented; - - -- Start of processing for Matches_Prefixed_View_Profile + Param_E1 : Node_Id := E1_Param; + Param_E2 : Node_Id := E2_Param; begin - Iface_Param := First (Iface_Params); - Iface_Typ := Etype (Defining_Identifier (Iface_Param)); - - if Is_Access_Type (Iface_Typ) then - Iface_Typ := Designated_Type (Iface_Typ); - end if; - - Prim_Param := First (Prim_Params); - - -- The first parameter of the potentially overridden subprogram - -- must be an interface implemented by Prim. - - if not Is_Interface (Iface_Typ) - or else not Is_Implemented (Ifaces_List, Iface_Typ) - then - return False; - end if; - - -- The checks on the object parameters are done, move onto the - -- rest of the parameters. - - if not In_Scope then - Prim_Param := Next (Prim_Param); - end if; - - Iface_Param := Next (Iface_Param); - while Present (Iface_Param) and then Present (Prim_Param) loop - Iface_Id := Defining_Identifier (Iface_Param); - Iface_Typ := Find_Parameter_Type (Iface_Param); - - Prim_Id := Defining_Identifier (Prim_Param); - Prim_Typ := Find_Parameter_Type (Prim_Param); - - if Ekind (Iface_Typ) = E_Anonymous_Access_Type - and then Ekind (Prim_Typ) = E_Anonymous_Access_Type - and then Is_Concurrent_Type (Designated_Type (Prim_Typ)) - then - Iface_Typ := Designated_Type (Iface_Typ); - Prim_Typ := Designated_Type (Prim_Typ); - end if; - - -- Case of multiple interface types inside a parameter profile - - -- (Obj_Param : in out Iface; ...; Param : Iface) - - -- If the interface type is implemented, then the matching type - -- in the primitive should be the implementing record type. - - if Ekind (Iface_Typ) = E_Record_Type - and then Is_Interface (Iface_Typ) - and then Is_Implemented (Ifaces_List, Iface_Typ) - then - if Prim_Typ /= Typ then - return False; - end if; - - -- The two parameters must be both mode and subtype conformant - - elsif Ekind (Iface_Id) /= Ekind (Prim_Id) + while Present (Param_E1) and then Present (Param_E2) loop + if Ekind (Defining_Identifier (Param_E1)) + /= Ekind (Defining_Identifier (Param_E2)) or else not - Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) + Conforming_Types (Find_Parameter_Type (Param_E1), + Find_Parameter_Type (Param_E2), + Subtype_Conformant) then return False; end if; - Next (Iface_Param); - Next (Prim_Param); + Next (Param_E1); + Next (Param_E2); end loop; - -- One of the two lists contains more parameters than the other + -- The candidate is not valid if one of the two lists contains + -- more parameters than the other - if Present (Iface_Param) or else Present (Prim_Param) then - return False; - end if; + return No (Param_E1) and then No (Param_E2); + end Check_Conforming_Parameters; - return True; - end Matches_Prefixed_View_Profile; - - -- Start of processing for Check_Synchronized_Overriding - - begin - Overridden_Subp := Empty; - - -- Def_Id must be an entry or a subprogram. We should skip predefined - -- primitives internally generated by the frontend; however at this - -- stage predefined primitives are still not fully decorated. As a - -- minor optimization we skip here internally generated subprograms. - - if (Ekind (Def_Id) /= E_Entry - and then Ekind (Def_Id) /= E_Function - and then Ekind (Def_Id) /= E_Procedure) - or else not Comes_From_Source (Def_Id) - then - return; - end if; + ---------------------------------- + -- Matching_Entry_Or_Subprogram -- + ---------------------------------- - -- Search for the concurrent declaration since it contains the list - -- of all implemented interfaces. In this case, the subprogram is - -- declared within the scope of a protected or a task type. - - if Present (Scope (Def_Id)) - and then Is_Concurrent_Type (Scope (Def_Id)) - and then not Is_Generic_Actual_Type (Scope (Def_Id)) - then - Typ := Scope (Def_Id); - In_Scope := True; - - -- The enclosing scope is not a synchronized type and the subprogram - -- has no formals. - - elsif No (First_Formal (Def_Id)) then - return; + function Matching_Entry_Or_Subprogram + (Conc_Typ : Entity_Id; + Subp : Entity_Id) return Entity_Id + is + E : Entity_Id; - -- The subprogram has formals and hence it may be a primitive of a - -- concurrent type. + begin + E := First_Entity (Conc_Typ); + while Present (E) loop + if Chars (Subp) = Chars (E) + and then (Ekind (E) = E_Entry or else Is_Subprogram (E)) + and then + Check_Conforming_Parameters + (First (Parameter_Specifications (Parent (E))), + Next (First (Parameter_Specifications (Parent (Subp))))) + then + return E; + end if; - else - Typ := Etype (First_Formal (Def_Id)); + Next_Entity (E); + end loop; - if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); - end if; + return Empty; + end Matching_Entry_Or_Subprogram; - if Is_Concurrent_Type (Typ) - and then not Is_Generic_Actual_Type (Typ) - then - In_Scope := False; + ------------------------------------- + -- Matching_Dispatching_Subprogram -- + ------------------------------------- - -- This case occurs when the concurrent type is declared within - -- a generic unit. As a result the corresponding record has been - -- built and used as the type of the first formal, we just have - -- to retrieve the corresponding concurrent type. + function Matching_Dispatching_Subprogram + (Conc_Typ : Entity_Id; + Ent : Entity_Id) return Entity_Id + is + E : Entity_Id; - elsif Is_Concurrent_Record_Type (Typ) - and then not Is_Class_Wide_Type (Typ) - and then Present (Corresponding_Concurrent_Type (Typ)) - then - Typ := Corresponding_Concurrent_Type (Typ); - In_Scope := False; + begin + -- Search for entities in the enclosing scope of this synchonized + -- type - else - return; - end if; - end if; + pragma Assert (Is_Concurrent_Type (Conc_Typ)); + Push_Scope (Scope (Conc_Typ)); + E := Current_Entity_In_Scope (Ent); + Pop_Scope; - -- There is no overriding to check if is an inherited operation in a - -- type derivation on for a generic actual. + while Present (E) loop + if Scope (E) = Scope (Conc_Typ) + and then Comes_From_Source (E) + and then Ekind (E) = E_Procedure + and then Present (First_Entity (E)) + and then Is_Controlling_Formal (First_Entity (E)) + and then Etype (First_Entity (E)) = Conc_Typ + and then + Check_Conforming_Parameters + (First (Parameter_Specifications (Parent (Ent))), + Next (First (Parameter_Specifications (Parent (E))))) + then + return E; + end if; - Collect_Interfaces (Typ, Ifaces_List); + E := Homonym (E); + end loop; - if Is_Empty_Elmt_List (Ifaces_List) then - return; - end if; + return Empty; + end Matching_Dispatching_Subprogram; - -- Determine whether entry or subprogram Def_Id overrides a primitive - -- operation that belongs to one of the interfaces in Ifaces_List. + -------------------------------------------- + -- Matching_Original_Protected_Subprogram -- + -------------------------------------------- - declare - Candidate : Entity_Id := Empty; - Hom : Entity_Id := Empty; - Subp : Entity_Id := Empty; + function Matching_Original_Protected_Subprogram + (Prot_Typ : Entity_Id; + Subp : Entity_Id) return Entity_Id + is + ICF : constant Boolean := + Is_Controlling_Formal (First_Entity (Subp)); + E : Entity_Id; begin - -- Traverse the homonym chain, looking for a potentially - -- overridden subprogram that belongs to an implemented - -- interface. - - Hom := Current_Entity_In_Scope (Def_Id); - while Present (Hom) loop - Subp := Hom; - - if Subp = Def_Id - or else not Is_Overloadable (Subp) - or else not Is_Primitive (Subp) - or else not Is_Dispatching_Operation (Subp) - or else not Present (Find_Dispatching_Type (Subp)) - or else not Is_Interface (Find_Dispatching_Type (Subp)) - then - null; - - -- Entries and procedures can override abstract or null - -- interface procedures. + -- Temporarily decorate the first parameter of Subp as controlling + -- formal; required to invoke Subtype_Conformant() - elsif (Ekind (Def_Id) = E_Procedure - or else Ekind (Def_Id) = E_Entry) - and then Ekind (Subp) = E_Procedure - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; + Set_Is_Controlling_Formal (First_Entity (Subp)); - -- For an overridden subprogram Subp, check whether the mode - -- of its first parameter is correct depending on the kind - -- of synchronized type. - - declare - Formal : constant Node_Id := First_Formal (Candidate); - - begin - -- In order for an entry or a protected procedure to - -- override, the first parameter of the overridden - -- routine must be of mode "out", "in out" or - -- access-to-variable. - - if Ekind_In (Candidate, E_Entry, E_Procedure) - and then Is_Protected_Type (Typ) - and then Ekind (Formal) /= E_In_Out_Parameter - and then Ekind (Formal) /= E_Out_Parameter - and then Nkind (Parameter_Type (Parent (Formal))) /= - N_Access_Definition - then - null; + E := + Current_Entity_In_Scope (Original_Protected_Subprogram (Subp)); - -- All other cases are OK since a task entry or routine - -- does not have a restriction on the mode of the first - -- parameter of the overridden interface routine. + while Present (E) loop + if Scope (E) = Scope (Prot_Typ) + and then Comes_From_Source (E) + and then Ekind (Subp) = Ekind (E) + and then Present (First_Entity (E)) + and then Is_Controlling_Formal (First_Entity (E)) + and then Etype (First_Entity (E)) = Prot_Typ + and then Subtype_Conformant (Subp, E, + Skip_Controlling_Formals => True) + then + Set_Is_Controlling_Formal (First_Entity (Subp), ICF); + return E; + end if; - else - Overridden_Subp := Candidate; - return; - end if; - end; + E := Homonym (E); + end loop; - -- Functions can override abstract interface functions + Set_Is_Controlling_Formal (First_Entity (Subp), ICF); + return Empty; + end Matching_Original_Protected_Subprogram; - elsif Ekind (Def_Id) = E_Function - and then Ekind (Subp) = E_Function - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - and then Etype (Result_Definition (Parent (Def_Id))) = - Etype (Result_Definition (Parent (Subp))) - then - Candidate := Subp; + -- Start of processing for Has_Matching_Entry_Or_Subprogram - -- If an inherited subprogram is implemented by a protected - -- function, then the first parameter of the inherited - -- subprogram shall be of mode in, but not an - -- access-to-variable parameter (RM 9.4(11/9) + begin + -- Case 1: E is a subprogram whose first formal is a concurrent type + -- defined in the scope of E that has an entry or subprogram whose + -- profile matches E. + + if Comes_From_Source (E) + and then Is_Subprogram (E) + and then Present (First_Entity (E)) + and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) + then + if Scope (E) = + Scope (Corresponding_Concurrent_Type ( + Etype (First_Entity (E)))) + and then + Present + (Matching_Entry_Or_Subprogram + (Corresponding_Concurrent_Type (Etype (First_Entity (E))), + Subp => E)) + then + Report_Conflict (E, + Matching_Entry_Or_Subprogram + (Corresponding_Concurrent_Type (Etype (First_Entity (E))), + Subp => E)); + return True; + end if; - if Present (First_Formal (Subp)) - and then Ekind (First_Formal (Subp)) = E_In_Parameter - and then - (not Is_Access_Type (Etype (First_Formal (Subp))) - or else - Is_Access_Constant (Etype (First_Formal (Subp)))) - then - Overridden_Subp := Subp; - return; - end if; - end if; + -- Case 2: E is an internally built dispatching subprogram of a + -- protected type and there is a subprogram defined in the enclosing + -- scope of the protected type that has the original name of E and + -- its profile is conformant with the profile of E. We check the + -- name of the original protected subprogram associated with E since + -- the expander builds dispatching primitives of protected functions + -- and procedures with other name (see Exp_Ch9.Build_Selected_Name). - Hom := Homonym (Hom); - end loop; + elsif not Comes_From_Source (E) + and then Is_Subprogram (E) + and then Present (First_Entity (E)) + and then Is_Concurrent_Record_Type (Etype (First_Entity (E))) + and then Present (Original_Protected_Subprogram (E)) + and then + Present + (Matching_Original_Protected_Subprogram + (Corresponding_Concurrent_Type (Etype (First_Entity (E))), + Subp => E)) + then + Report_Conflict (E, + Matching_Original_Protected_Subprogram + (Corresponding_Concurrent_Type (Etype (First_Entity (E))), + Subp => E)); + return True; - -- After examining all candidates for overriding, we are left with - -- the best match which is a mode incompatible interface routine. + -- Case : E is an entry of a synchronized type and a matching + -- procedure has been previously defined in the enclosing scope + -- of the synchronzed type. - if In_Scope and then Present (Candidate) then - Error_Msg_PT (Def_Id, Candidate); - end if; + elsif Comes_From_Source (E) + and then Ekind (E) = E_Entry + and then + Present (Matching_Dispatching_Subprogram (Current_Scope, E)) + then + Report_Conflict (E, + Matching_Dispatching_Subprogram (Current_Scope, E)); + return True; + end if; - Overridden_Subp := Candidate; - return; - end; - end Check_Synchronized_Overriding; + return False; + end Has_Matching_Entry_Or_Subprogram; ---------------------------- -- Is_Private_Declaration -- @@ -9732,6 +9986,24 @@ package body Sem_Ch6 is or else DT_Position (AO) = DT_Position (AN); end Is_Overriding_Alias; + --------------------- + -- Report_Conflict -- + --------------------- + + procedure Report_Conflict (S : Entity_Id; E : Entity_Id) is + begin + Error_Msg_Sloc := Sloc (E); + + -- Generate message, with useful additional warning if in generic + + if Is_Generic_Unit (E) then + Error_Msg_N ("previous generic unit cannot be overloaded", S); + Error_Msg_N ("\& conflicts with declaration#", S); + else + Error_Msg_N ("& conflicts with declaration#", S); + end if; + end Report_Conflict; + -- Start of processing for New_Overloaded_Entity begin @@ -9788,6 +10060,15 @@ package body Sem_Ch6 is return; end if; + -- For synchronized types check conflicts of this entity with + -- previously defined entities. + + if Ada_Version >= Ada_2005 + and then Has_Matching_Entry_Or_Subprogram (S) + then + return; + end if; + -- If there is no homonym then this is definitely not overriding if No (E) then @@ -9864,17 +10145,7 @@ package body Sem_Ch6 is return; else - Error_Msg_Sloc := Sloc (E); - - -- Generate message, with useful additional warning if in generic - - if Is_Generic_Unit (E) then - Error_Msg_N ("previous generic unit cannot be overloaded", S); - Error_Msg_N ("\& conflicts with declaration#", S); - else - Error_Msg_N ("& conflicts with declaration#", S); - end if; - + Report_Conflict (S, E); return; end if; diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index ff24ed83acc..d0c1e5c67e0 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -122,6 +122,15 @@ package Sem_Ch6 is -- formal access-to-subprogram type, indicating that mapping of types -- is needed. + procedure Check_Synchronized_Overriding + (Def_Id : Entity_Id; + Overridden_Subp : out Entity_Id); + -- First determine if Def_Id is an entry or a subprogram either defined + -- in the scope of a task or protected type, or is a primitive of such + -- a type. Check whether Def_Id overrides a subprogram of an interface + -- implemented by the synchronized type, return the overridden entity + -- or Empty. + procedure Check_Type_Conformant (New_Id : Entity_Id; Old_Id : Entity_Id; -- 2.30.2