From 9d423476eac399bf3c1f63df5941c03020077977 Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 28 May 2008 15:34:05 +0000 Subject: 2008-05-28 Javier Miranda * sem_util.ads (Find_Overridden_Synchronized_Primitive): Removed. * sem_util.adb (Find_Overridden_Synchronized_Primitive): Removed. * sem_ch6.adb (Check_Synchronized_Overriding): Remove one formal. Add code that was previously located in Find_Overridden_Synchronized_Primitive because it is only used here. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@136105 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/sem_ch6.adb | 368 +++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 332 insertions(+), 36 deletions(-) (limited to 'gcc/ada/sem_ch6.adb') diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index afd6451e7ea..f376e955b37 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6203,7 +6203,6 @@ package body Sem_Ch6 is procedure Check_Synchronized_Overriding (Def_Id : Entity_Id; - First_Hom : 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 @@ -6398,22 +6397,198 @@ package body Sem_Ch6 is procedure Check_Synchronized_Overriding (Def_Id : Entity_Id; - First_Hom : Entity_Id; Overridden_Subp : out Entity_Id) is - Formal_Typ : Entity_Id; Ifaces_List : Elist_Id; In_Scope : Boolean; Typ : Entity_Id; + function Has_Correct_Formal_Mode + (Tag_Typ : Entity_Id; + Subp : Entity_Id) return Boolean; + -- For an overridden subprogram Subp, check whether the mode of its + -- first parameter is correct depending on the kind of Tag_Typ. + + 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. + + ----------------------------- + -- Has_Correct_Formal_Mode -- + ----------------------------- + + function Has_Correct_Formal_Mode + (Tag_Typ : Entity_Id; + Subp : Entity_Id) return Boolean + is + Formal : constant Node_Id := First_Formal (Subp); + + 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 (Subp) = E_Entry + or else Ekind (Subp) = E_Procedure) + and then Is_Protected_Type (Tag_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 + return False; + end if; + + -- 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. + + return True; + end Has_Correct_Formal_Mode; + + ----------------------------------- + -- 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); + + if Is_Access_Type (Iface_Typ) then + Iface_Typ := Directly_Designated_Type (Iface_Typ); + end if; + + Prim_Id := Defining_Identifier (Prim_Param); + Prim_Typ := Find_Parameter_Type (Prim_Param); + + if Is_Access_Type (Prim_Typ) then + Prim_Typ := Directly_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 + -- 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 + 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; @@ -6429,19 +6604,25 @@ package body Sem_Ch6 is Typ := Scope (Def_Id); In_Scope := True; - -- The subprogram may be a primitive of a concurrent type + -- The enclosing scope is not a synchronized type and the subprogram + -- has no formals - elsif Present (First_Formal (Def_Id)) then - Formal_Typ := Etype (First_Formal (Def_Id)); + 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 (Formal_Typ) then - Formal_Typ := Directly_Designated_Type (Formal_Typ); + if Is_Access_Type (Typ) then + Typ := Directly_Designated_Type (Typ); end if; - if Is_Concurrent_Type (Formal_Typ) - and then not Is_Generic_Actual_Type (Formal_Typ) + if Is_Concurrent_Type (Typ) + and then not Is_Generic_Actual_Type (Typ) then - Typ := Formal_Typ; In_Scope := False; -- This case occurs when the concurrent type is declared within @@ -6449,37 +6630,152 @@ package body Sem_Ch6 is -- built and used as the type of the first formal, we just have -- to retrieve the corresponding concurrent type. - elsif Is_Concurrent_Record_Type (Formal_Typ) - and then Present (Corresponding_Concurrent_Type (Formal_Typ)) + elsif Is_Concurrent_Record_Type (Typ) + and then Present (Corresponding_Concurrent_Type (Typ)) then - Typ := Corresponding_Concurrent_Type (Formal_Typ); + Typ := Corresponding_Concurrent_Type (Typ); In_Scope := False; else return; end if; - else + 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; - -- Gather all limited, protected and task interfaces that Typ - -- implements. There is no overriding to check if is an inherited - -- operation in a type derivation on for a generic actual. + -- Determine whether entry or subprogram Def_Id overrides a primitive + -- operation that belongs to one of the interfaces in Ifaces_List. - if Nkind (Parent (Typ)) /= N_Full_Type_Declaration - and then - not Nkind_In (Parent (Def_Id), N_Subtype_Declaration, - N_Task_Type_Declaration, - N_Protected_Type_Declaration) - then - Collect_Interfaces (Typ, Ifaces_List); + declare + Candidate : Entity_Id := Empty; + Hom : Entity_Id := Empty; + Iface_Typ : Entity_Id; + Subp : Entity_Id := Empty; + + begin + -- Traverse the homonym chain, looking at a potentially + -- overridden subprogram that belongs to an implemented + -- interface. + + Hom := Current_Entity_In_Scope (Def_Id); + while Present (Hom) loop + Subp := Hom; + + -- Entries can override abstract or null interface + -- procedures + + if Ekind (Def_Id) = E_Entry + and then Ekind (Subp) = E_Procedure + and then Nkind (Parent (Subp)) = N_Procedure_Specification + and then (Is_Abstract_Subprogram (Subp) + or else Null_Present (Parent (Subp))) + then + while Present (Alias (Subp)) loop + Subp := Alias (Subp); + end loop; + + if Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + then + Candidate := Subp; - if not Is_Empty_Elmt_List (Ifaces_List) then - Overridden_Subp := - Find_Overridden_Synchronized_Primitive - (Def_Id, First_Hom, Ifaces_List, In_Scope); + -- Absolute match + + if Has_Correct_Formal_Mode (Typ, Candidate) then + Overridden_Subp := Candidate; + return; + end if; + end if; + + -- Procedures can override abstract or null interface + -- procedures + + elsif Ekind (Def_Id) = E_Procedure + and then Ekind (Subp) = E_Procedure + and then Nkind (Parent (Subp)) = N_Procedure_Specification + and then (Is_Abstract_Subprogram (Subp) + or else Null_Present (Parent (Subp))) + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Subp))) + then + Candidate := Subp; + + -- Absolute match + + if Has_Correct_Formal_Mode (Typ, Candidate) then + Overridden_Subp := Candidate; + return; + end if; + + -- Functions can override abstract interface functions + + elsif Ekind (Def_Id) = E_Function + and then Ekind (Subp) = E_Function + and then Nkind (Parent (Subp)) = N_Function_Specification + and then Is_Abstract_Subprogram (Subp) + 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 + Overridden_Subp := Subp; + return; + 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. Do not emit an error if the Expander + -- is active since this error will be detected later on + -- after all concurrent types are expanded and all wrappers + -- are built. This check is meant for spec-only + -- compilations. + + if Present (Candidate) + and then not Expander_Active + then + Iface_Typ := + Find_Parameter_Type (Parent (First_Formal (Candidate))); + + -- Def_Id is primitive of a protected type, declared + -- inside the type, and the candidate is primitive of a + -- limited or synchronized interface. + + if In_Scope + and then Is_Protected_Type (Typ) + and then + (Is_Limited_Interface (Iface_Typ) + or else Is_Protected_Interface (Iface_Typ) + or else Is_Synchronized_Interface (Iface_Typ) + or else Is_Task_Interface (Iface_Typ)) + then + -- Must reword this message, comma before to in -gnatj + -- mode ??? + + Error_Msg_NE + ("first formal of & must be of mode `OUT`, `IN OUT`" + & " or access-to-variable", Typ, Candidate); + Error_Msg_N + ("\to be overridden by protected procedure or entry " + & "(RM 9.4(11.9/2))", Typ); + end if; end if; - end if; + + Overridden_Subp := Candidate; + return; + end; end Check_Synchronized_Overriding; ---------------------------- @@ -6532,7 +6828,7 @@ package body Sem_Ch6 is -- has an overriding indicator. if Comes_From_Source (S) then - Check_Synchronized_Overriding (S, Homonym (S), Overridden_Subp); + Check_Synchronized_Overriding (S, Overridden_Subp); Check_Overriding_Indicator (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp); end if; @@ -6609,7 +6905,7 @@ package body Sem_Ch6 is goto Add_New_Entity; end if; - Check_Synchronized_Overriding (S, E, Overridden_Subp); + Check_Synchronized_Overriding (S, Overridden_Subp); -- Loop through E and its homonyms to determine if any of them is -- the candidate for overriding by S. -- cgit v1.2.1