FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sem_type.adb (Add_One_Interp): If node is an indirect call...

Browse source 
2006-10-31  Ed Schonberg  <schonberg@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_type.adb (Add_One_Interp): If node is an indirect call, preserve
	subprogram type to provide better diagnostics in case of ambiguity.
	(Covers): Handle coverage of formal and actual anonymous access types in
	the context of generic instantiation.
	(Covers/Interface_Present_In_Ancestors): Use the base type to manage
	abstract interface types; this is required to handle concurrent types
	with discriminants and abstract interface types.
	(Covers): Include type coverage of both regular incomplete subtypes and
	incomplete subtypes of incomplete type visibles through a limited with
	clause.

From-SVN: r118311
This commit is contained in:
Ed Schonberg 2006-10-31 19:09:49 +01:00 • committed by Arnaud Charlet
parent 29797f340d
commit 60573ca25a
1 changed files with 100 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

140
gcc/ada/sem_type.adb
View file

@ -35,10 +35,11 @@ with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
with Sem_Disp; use Sem_Disp;
with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Sinfo; use Sinfo;
@ -394,9 +395,9 @@ package body Sem_Type is
-- because otherwise we have a dummy between the two subprograms that
-- are in fact the same.
if Present (DTC_Entity (Abstract_Interface_Alias (E)))
and then Etype (DTC_Entity (Abstract_Interface_Alias (E)))
/= RTE (RE_Tag)
if not Is_Ancestor
(Find_Dispatching_Type (Abstract_Interface_Alias (E)),
Find_Dispatching_Type (E))
then
Add_One_Interp (N, Abstract_Interface_Alias (E), T);
end if;
@ -447,6 +448,24 @@ package body Sem_Type is
then
Add_Entry (Entity (Name (N)), Etype (N));
-- If this is an indirect call there will be no name associated
-- with the previous entry. To make diagnostics clearer, save
-- Subprogram_Type of first interpretation, so that the error will
-- point to the anonymous access to subprogram, not to the result
-- type of the call itself.
elsif (Nkind (N)) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
and then Is_Overloaded (Name (N))
then
declare
I : Interp_Index;
It : Interp;
begin
Get_First_Interp (Name (N), I, It);
Add_Entry (It.Nam, Etype (N));
end;
else
-- Overloaded prefix in indexed or selected component,
-- or call whose name is an expression or another call.
@ -735,36 +754,45 @@ package body Sem_Type is
and then Is_Interface (Etype (T1))
and then Is_Tagged_Type (T2)
then
if Interface_Present_In_Ancestor (Typ => T2,
if Interface_Present_In_Ancestor (Typ => T2,
Iface => Etype (T1))
then
return True;
end if;
elsif Present (Abstract_Interfaces (T2)) then
declare
E : Entity_Id;
Elmt : Elmt_Id;
begin
if Is_Concurrent_Type (BT2) then
E := Corresponding_Record_Type (BT2);
else
E := BT2;
end if;
-- Ada 2005 (AI-251): A class-wide abstract interface type T1
-- covers an object T2 that implements a direct derivation of T1.
-- Note: test for presence of E is defense against previous error.
declare
E : Elmt_Id := First_Elmt (Abstract_Interfaces (T2));
begin
while Present (E) loop
if Is_Ancestor (Etype (T1), Node (E)) then
if Present (E)
and then Present (Abstract_Interfaces (E))
then
Elmt := First_Elmt (Abstract_Interfaces (E));
while Present (Elmt) loop
if Is_Ancestor (Etype (T1), Node (Elmt)) then
return True;
end if;
Next_Elmt (E);
Next_Elmt (Elmt);
end loop;
end;
end if;
-- We should also check the case in which T1 is an ancestor of
-- some implemented interface???
return False;
else
return False;
end if;
end;
-- In a dispatching call the actual may be class-wide
@ -959,7 +987,7 @@ package body Sem_Type is
-- If the expected type is the non-limited view of a type, the
-- expression may have the limited view.
if Ekind (T1) = E_Incomplete_Type then
if Is_Incomplete_Type (T1) then
return Covers (Non_Limited_View (T1), T2);
elsif Ekind (T1) = E_Class_Wide_Type then
@ -975,7 +1003,7 @@ package body Sem_Type is
-- either type might have a limited view. Checks performed elsewhere
-- verify that the context type is the non-limited view.
if Ekind (T2) = E_Incomplete_Type then
if Is_Incomplete_Type (T2) then
return Covers (T1, Non_Limited_View (T2));
elsif Ekind (T2) = E_Class_Wide_Type then
@ -985,6 +1013,38 @@ package body Sem_Type is
return False;
end if;
-- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
elsif Ekind (T1) = E_Incomplete_Subtype then
return Covers (Full_View (Etype (T1)), T2);
elsif Ekind (T2) = E_Incomplete_Subtype then
return Covers (T1, Full_View (Etype (T2)));
-- Ada 2005 (AI-423): Coverage of formal anonymous access types
-- and actual anonymous access types in the context of generic
-- instantiation. We have the following situation:
-- generic
-- type Formal is private;
-- Formal_Obj : access Formal; -- T1
-- package G is ...
-- package P is
-- type Actual is ...
-- Actual_Obj : access Actual; -- T2
-- package Instance is new G (Formal => Actual,
-- Formal_Obj => Actual_Obj);
elsif Ada_Version >= Ada_05
and then Ekind (T1) = E_Anonymous_Access_Type
and then Ekind (T2) = E_Anonymous_Access_Type
and then Is_Generic_Type (Directly_Designated_Type (T1))
and then Get_Instance_Of (Directly_Designated_Type (T1)) =
Directly_Designated_Type (T2)
then
return True;
-- Otherwise it doesn't cover!
else
@ -1354,9 +1414,9 @@ package body Sem_Type is
-- operating in an earlier mode, in which case we discard the Ada
-- 2005 entity, so that we get proper Ada 95 overload resolution.
if Is_Ada_2005 (Nam1) then
if Is_Ada_2005_Only (Nam1) then
return It2;
elsif Is_Ada_2005 (Nam2) then
elsif Is_Ada_2005_Only (Nam2) then
return It1;
end if;
end if;
@ -2050,12 +2110,12 @@ package body Sem_Type is
-- list of interfaces (available in the parent of the concurrent type)
if Is_Concurrent_Type (Target_Typ) then
if Present (Interface_List (Parent (Target_Typ))) then
if Present (Interface_List (Parent (Base_Type (Target_Typ)))) then
declare
AI : Node_Id;
begin
AI := First (Interface_List (Parent (Target_Typ)));
AI := First (Interface_List (Parent (Base_Type (Target_Typ))));
while Present (AI) loop
if Etype (AI) = Iface then
return True;
@ -2304,11 +2364,11 @@ package body Sem_Type is
and then Scope (It.Typ) /= Standard_Standard
then
Error_Msg_Sloc := Sloc (Parent (It.Typ));
Error_Msg_NE (" & (inherited) declared#!", Err, It.Nam);
Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
else
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_NE (" & declared#!", Err, It.Nam);
Error_Msg_NE ("\\& declared#!", Err, It.Nam);
end if;
Get_Next_Interp (Index, It);
@ -2792,6 +2852,21 @@ package body Sem_Type is
end if;
end Valid_Comparison_Arg;
----------------------
-- Write_Interp_Ref --
----------------------
procedure Write_Interp_Ref (Map_Ptr : Int) is
begin
Write_Str (" Node: ");
Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
Write_Str (" Index: ");
Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
Write_Str (" Next: ");
Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
Write_Eol;
end Write_Interp_Ref;
---------------------
-- Write_Overloads --
---------------------
@ -2832,19 +2907,4 @@ package body Sem_Type is
end if;
end Write_Overloads;
----------------------
-- Write_Interp_Ref --
----------------------
procedure Write_Interp_Ref (Map_Ptr : Int) is
begin
Write_Str (" Node: ");
Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
Write_Str (" Index: ");
Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
Write_Str (" Next: ");
Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
Write_Eol;
end Write_Interp_Ref;
end Sem_Type;