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;
-- 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 --
-----------------------------------
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);
+ 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
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)))
+ 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 Is_Interface (Find_Dispatching_Type (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;
-
- -- Absolute match
-
- if Has_Correct_Formal_Mode (Typ, Candidate) then
- Overridden_Subp := Candidate;
- return;
- end if;
- end if;
+ null;
- -- Procedures can override abstract or null interface
- -- procedures
+ -- Entries and procedures can override abstract or null
+ -- interface procedures
- elsif Ekind (Def_Id) = E_Procedure
+ elsif (Ekind (Def_Id) = E_Procedure
+ or else 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)))
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
Parameter_Specifications (Parent (Subp)))
then
Candidate := Subp;
- -- Absolute match
+ -- For an overridden subprogram Subp, check whether the mode
+ -- of its first parameter is correct depending on the kind
+ -- of synchronized type.
- if Has_Correct_Formal_Mode (Typ, Candidate) then
- Overridden_Subp := Candidate;
- return;
- end if;
+ 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 (Candidate) = E_Entry
+ or else Ekind (Candidate) = 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 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)))
-- or because it is a generic actual, so use base type to
-- locate concurrent type.
- if Is_Concurrent_Type (Etype (A))
- and then Etype (F) =
- Corresponding_Record_Type (Base_Type (Etype (A)))
- then
- Rewrite (A,
- Unchecked_Convert_To
- (Corresponding_Record_Type (Etype (A)), A));
- end if;
+ A_Typ := Base_Type (Etype (A));
+ F_Typ := Base_Type (Etype (F));
+
+ declare
+ Full_A_Typ : Entity_Id;
+
+ begin
+ if Present (Full_View (A_Typ)) then
+ Full_A_Typ := Base_Type (Full_View (A_Typ));
+ else
+ Full_A_Typ := A_Typ;
+ end if;
- Resolve (A, Etype (F));
+ -- Tagged synchronized type (case 1): the actual is a
+ -- concurrent type
+
+ if Is_Concurrent_Type (A_Typ)
+ and then Corresponding_Record_Type (A_Typ) = F_Typ
+ then
+ Rewrite (A,
+ Unchecked_Convert_To
+ (Corresponding_Record_Type (A_Typ), A));
+ Resolve (A, Etype (F));
+
+ -- Tagged synchronized type (case 2): the formal is a
+ -- concurrent type
+
+ elsif Ekind (Full_A_Typ) = E_Record_Type
+ and then Present
+ (Corresponding_Concurrent_Type (Full_A_Typ))
+ and then Is_Concurrent_Type (F_Typ)
+ and then Present (Corresponding_Record_Type (F_Typ))
+ and then Full_A_Typ = Corresponding_Record_Type (F_Typ)
+ then
+ Resolve (A, Corresponding_Record_Type (F_Typ));
+
+ -- Common case
+
+ else
+ Resolve (A, Etype (F));
+ end if;
+ end;
end if;
A_Typ := Etype (A);