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 100 additions and 93 deletions
gcc/ada/sem_ch4.adb
...@@ -6414,6 +6414,10 @@ package body Sem_Ch4 is ...@@ -6414,6 +6414,10 @@ package body Sem_Ch4 is
-- corresponding record (base) type. -- corresponding record (base) type.
if Is_Concurrent_Type (Obj_Type) then 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)); Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
Elmt := First_Elmt (Primitive_Operations (Corr_Type)); Elmt := First_Elmt (Primitive_Operations (Corr_Type));
......
gcc/ada/sem_ch6.adb
...@@ -6599,12 +6599,6 @@ package body Sem_Ch6 is ...@@ -6599,12 +6599,6 @@ package body Sem_Ch6 is
In_Scope : Boolean; In_Scope : Boolean;
Typ : Entity_Id; 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 function Matches_Prefixed_View_Profile
(Prim_Params : List_Id; (Prim_Params : List_Id;
Iface_Params : List_Id) return Boolean; Iface_Params : List_Id) return Boolean;
...@@ -6613,39 +6607,6 @@ package body Sem_Ch6 is ...@@ -6613,39 +6607,6 @@ package body Sem_Ch6 is
-- Iface_Params. Also determine if the type of first parameter of -- Iface_Params. Also determine if the type of first parameter of
-- Iface_Params is an implemented interface. -- 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 -- -- Matches_Prefixed_View_Profile --
----------------------------------- -----------------------------------
...@@ -6723,15 +6684,15 @@ package body Sem_Ch6 is ...@@ -6723,15 +6684,15 @@ package body Sem_Ch6 is
Iface_Id := Defining_Identifier (Iface_Param); Iface_Id := Defining_Identifier (Iface_Param);
Iface_Typ := Find_Parameter_Type (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_Id := Defining_Identifier (Prim_Param);
Prim_Typ := Find_Parameter_Type (Prim_Param); Prim_Typ := Find_Parameter_Type (Prim_Param);
if Is_Access_Type (Prim_Typ) then if Ekind (Iface_Typ) = E_Anonymous_Access_Type
Prim_Typ := Directly_Designated_Type (Prim_Typ); 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; end if;
-- Case of multiple interface types inside a parameter profile -- Case of multiple interface types inside a parameter profile
...@@ -6864,60 +6825,63 @@ package body Sem_Ch6 is ...@@ -6864,60 +6825,63 @@ package body Sem_Ch6 is
while Present (Hom) loop while Present (Hom) loop
Subp := Hom; Subp := Hom;
-- Entries can override abstract or null interface if Subp = Def_Id
-- procedures or else not Is_Overloadable (Subp)
or else not Is_Primitive (Subp)
if Ekind (Def_Id) = E_Entry or else not Is_Dispatching_Operation (Subp)
and then Ekind (Subp) = E_Procedure or else not Is_Interface (Find_Dispatching_Type (Subp))
and then Nkind (Parent (Subp)) = N_Procedure_Specification
and then (Is_Abstract_Subprogram (Subp)
or else Null_Present (Parent (Subp)))
then then
while Present (Alias (Subp)) loop null;
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;
-- Procedures can override abstract or null interface -- Entries and procedures can override abstract or null
-- procedures -- 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 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 and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)), (Parameter_Specifications (Parent (Def_Id)),
Parameter_Specifications (Parent (Subp))) Parameter_Specifications (Parent (Subp)))
then then
Candidate := Subp; 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 declare
Overridden_Subp := Candidate; Formal : constant Node_Id := First_Formal (Candidate);
return;
end if; 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 -- Functions can override abstract interface functions
elsif Ekind (Def_Id) = E_Function elsif Ekind (Def_Id) = E_Function
and then Ekind (Subp) = 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 and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)), (Parameter_Specifications (Parent (Def_Id)),
Parameter_Specifications (Parent (Subp))) Parameter_Specifications (Parent (Subp)))
......
gcc/ada/sem_res.adb
...@@ -3218,16 +3218,48 @@ package body Sem_Res is ...@@ -3218,16 +3218,48 @@ package body Sem_Res is
-- or because it is a generic actual, so use base type to -- or because it is a generic actual, so use base type to
-- locate concurrent type. -- locate concurrent type.
if Is_Concurrent_Type (Etype (A)) A_Typ := Base_Type (Etype (A));
and then Etype (F) = F_Typ := Base_Type (Etype (F));
Corresponding_Record_Type (Base_Type (Etype (A)))
then declare
Rewrite (A, Full_A_Typ : Entity_Id;
Unchecked_Convert_To
(Corresponding_Record_Type (Etype (A)), A)); begin
end if; 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; end if;
A_Typ := Etype (A); A_Typ := Etype (A);
......
gcc/ada/sem_type.adb
...@@ -2106,11 +2106,18 @@ package body Sem_Type is ...@@ -2106,11 +2106,18 @@ package body Sem_Type is
-- to check whether it is a proper descendant. -- to check whether it is a proper descendant.
or else 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 Present (Corresponding_Record_Type (Etype (N)))
and then Covers (Typ, Corresponding_Record_Type (Etype (N)))) and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
or else 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) (not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type and then Ekind (Typ) /= E_Anonymous_Access_Type
and then Covers (Etype (N), Typ)); 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