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

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

diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index eca91e59820c093d49da7111d64d4bde9dfa00e6..94c4c5c060e2c7a0ea4689e4cf2a744419137a03 100644 (file)
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -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);