Skip to content

R
riscv-gcc-1
Commit 15e4986c by Javier Miranda Committed by Arnaud Charlet
Options

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
parent e84e11ba
Showing with 91 additions and 84 deletions
gcc/ada/sem_ch4.adb
......@@ -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));
......
gcc/ada/sem_ch6.adb
......@@ -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
-- 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;
-- 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;
end if;
declare
Formal : constant Node_Id := First_Formal (Candidate);
-- Procedures can override abstract or null interface
-- procedures
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.
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)))
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
Candidate := Subp;
null;
-- Absolute match
-- 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.
if Has_Correct_Formal_Mode (Typ, Candidate) then
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)))
......
gcc/ada/sem_res.adb
......@@ -3218,17 +3218,49 @@ 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)))
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;
-- 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 (Etype (A)), A));
end if;
(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);
F_Typ := Etype (F);
......
gcc/ada/sem_type.adb
......@@ -2106,11 +2106,18 @@ 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
and then Covers (Etype (N), Typ));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment