OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR ada/15604 (Ambiguous aggregate -- Accepts invalid)

Browse Source 
2005-11-14  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	PR ada/15604

	* sem_type.adb (Covers): In an inlined body, a composite type matches
	a private type whose full view is a composite type.
	(Interface_Present_In_Ancestor): Protect the frontend against
	previously detected errors to ensure that its compilation
	with assertions enabled gives the same output that its
	compilation without assertions.
	(Interface_Present_In_Ancestor): Add support for private types.
	Change name In_Actual to In_Generic_Actual (clean up)
	(Disambiguate): New predicate In_Actual, to recognize expressions that
	appear in the renaming declaration generated for generic actuals, and
	which must be resolved in the outer context.

From-SVN: r107006
This commit is contained in:
Ed Schonberg 2005-11-15 15:03:56 +01:00 committed by Arnaud Charlet
parent 9ebe37436f
commit 861d669e3d
1 changed files with 73 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
gcc/ada/sem_type.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -913,7 +913,10 @@ package body Sem_Type is
and then
Designated_Type (T1) = Designated_Type (T2))
or else (T1 = Any_Access
and then Is_Access_Type (Underlying_Type (T2))))
and then Is_Access_Type (Underlying_Type (T2)))
or else (T2 = Any_Composite
and then
Is_Composite_Type (Underlying_Type (T1))))
then
return True;
@ -979,6 +982,13 @@ package body Sem_Type is
-- Determine whether one of the candidates is an operation inherited by
-- a type that is derived from an actual in an instantiation.
function In_Generic_Actual (Exp : Node_Id) return Boolean;
-- Determine whether the expression is part of a generic actual. At
-- the time the actual is resolved the scope is already that of the
-- instance, but conceptually the resolution of the actual takes place
-- in the enclosing context, and no special disambiguation rules should
-- be applied.
function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
-- Determine whether a subprogram is an actual in an enclosing instance.
-- An overloading between such a subprogram and one declared outside the
@ -1009,6 +1019,34 @@ package body Sem_Type is
-- pathology in the other direction with calls whose multiple overloaded
-- actuals make them truly unresolvable.
------------------------
-- In_Generic_Actual --
------------------------
function In_Generic_Actual (Exp : Node_Id) return Boolean is
Par : constant Node_Id := Parent (Exp);
begin
if No (Par) then
return False;
elsif Nkind (Par) in N_Declaration then
if Nkind (Par) = N_Object_Declaration
or else Nkind (Par) = N_Object_Renaming_Declaration
then
return Present (Corresponding_Generic_Association (Par));
else
return False;
end if;
elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
return False;
else
return In_Generic_Actual (Parent (Par));
end if;
end In_Generic_Actual;
---------------------------
-- Inherited_From_Actual --
---------------------------
@ -1372,7 +1410,9 @@ package body Sem_Type is
-- case the resolution was to the explicit declaration in the
-- generic, and remains so in the instance.
elsif In_Instance then
elsif In_Instance
and then not In_Generic_Actual (N)
then
if Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement
then
@ -1801,7 +1841,16 @@ package body Sem_Type is
return True;
end if;
E := Typ;
-- Handle private types
if Present (Full_View (Typ))
and then not Is_Concurrent_Type (Full_View (Typ))
then
E := Full_View (Typ);
else
E := Typ;
end if;
loop
if Present (Abstract_Interfaces (E))
and then Present (Abstract_Interfaces (E))
@ -1819,7 +1868,12 @@ package body Sem_Type is
end loop;
end if;
exit when Etype (E) = E;
exit when Etype (E) = E
-- Handle private types
or else (Present (Full_View (Etype (E)))
and then Full_View (Etype (E)) = E);
-- Check if the current type is a direct derivation of the
-- interface
@ -1828,14 +1882,20 @@ package body Sem_Type is
return True;
end if;
-- Climb to the immediate ancestor
-- Climb to the immediate ancestor handling private types
E := Etype (E);
if Present (Full_View (Etype (E))) then
E := Full_View (Etype (E));
else
E := Etype (E);
end if;
end loop;
return False;
end Iface_Present_In_Ancestor;
-- Start of processing for Interface_Present_In_Ancestor
begin
if Is_Access_Type (Typ) then
Target_Typ := Etype (Directly_Designated_Type (Typ));
@ -1879,6 +1939,12 @@ package body Sem_Type is
if Ekind (Target_Typ) = E_Incomplete_Type then
pragma Assert (Present (Non_Limited_View (Target_Typ)));
Target_Typ := Non_Limited_View (Target_Typ);
-- Protect the frontend against previously detected errors
if Ekind (Target_Typ) = E_Incomplete_Type then
return False;
end if;
end if;
return Iface_Present_In_Ancestor (Target_Typ);