mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-08 19:20:44 +08:00
sem_type.adb (Has_Compatible_Type): Complete support for synchronized types when...
2008-07-31 Javier Miranda <miranda@adacore.com> * sem_type.adb (Has_Compatible_Type): Complete support for synchronized types when the candidate type is a synchronized type. * sem_res.adb (Resolve_Actuals): Reorganize code handling synchronized types, and complete management of synchronized types adding missing code to handle formal that is a synchronized type. * sem_ch4.adb (Try_Primitive_Operation): Avoid testing attributes that are not available and cause the compiler to blowup. Found compiling test with switch -gnatc * sem_ch6.adb (Check_Synchronized_Overriding): Remove local subprogram Has_Correct_Formal_Mode plus code cleanup. From-SVN: r138400
This commit is contained in:
Javier Miranda
Arnaud Charlet
parent
e84e11ba0a
commit
15e4986cda
@ -6414,6 +6414,10 @@ package body Sem_Ch4 is
|
||||
-- corresponding record (base) type.
|
||||
|
||||
if Is_Concurrent_Type (Obj_Type) then
|
||||
if not Present (Corresponding_Record_Type (Obj_Type)) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
|
||||
Elmt := First_Elmt (Primitive_Operations (Corr_Type));
|
||||
|
||||
|
||||
@ -6599,12 +6599,6 @@ package body Sem_Ch6 is
|
||||
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;
|
||||
@ -6613,39 +6607,6 @@ package body Sem_Ch6 is
|
||||
-- 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 --
|
||||
-----------------------------------
|
||||
@ -6723,15 +6684,15 @@ package body Sem_Ch6 is
|
||||
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
|
||||
@ -6864,60 +6825,63 @@ package body Sem_Ch6 is
|
||||
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;
|
||||
null;
|
||||
|
||||
if Matches_Prefixed_View_Profile
|
||||
(Parameter_Specifications (Parent (Def_Id)),
|
||||
Parameter_Specifications (Parent (Subp)))
|
||||
then
|
||||
Candidate := Subp;
|
||||
-- Entries and procedures can override abstract or null
|
||||
-- interface procedures
|
||||
|
||||
-- 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
|
||||
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)))
|
||||
|
||||
@ -3218,16 +3218,48 @@ package body Sem_Res is
|
||||
-- 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));
|
||||
|
||||
Resolve (A, 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;
|
||||
|
||||
-- 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);
|
||||
|
||||
@ -2106,10 +2106,17 @@ package body Sem_Type is
|
||||
-- to check whether it is a proper descendant.
|
||||
|
||||
or else
|
||||
(Is_Concurrent_Type (Etype (N))
|
||||
(Is_Record_Type (Typ)
|
||||
and then Is_Concurrent_Type (Etype (N))
|
||||
and then Present (Corresponding_Record_Type (Etype (N)))
|
||||
and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
|
||||
|
||||
or else
|
||||
(Is_Concurrent_Type (Typ)
|
||||
and then Is_Record_Type (Etype (N))
|
||||
and then Present (Corresponding_Record_Type (Typ))
|
||||
and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
|
||||
|
||||
or else
|
||||
(not Is_Tagged_Type (Typ)
|
||||
and then Ekind (Typ) /= E_Anonymous_Access_Type
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user