2010-06-23 Javier Miranda <miranda@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal
	entities for parent types that are interfaces. Needed in generics to
	handle formals that implement interfaces.
	(Derive_Subprograms): Add assertion for derivation of tagged types that
	do not cover interfaces. For generics, complete code that handles
	derivation of type that covers interfaces because the previous
	condition was weak (it required only name consistency; arguments were
	not checked). Add new code to locate primitives covering interfaces
	defined in generic units or instantiatons.
	* sem_util.adb (Has_Interfaces): Add missing support for derived types.
	* sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups.
	* exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of
	interfaces that are parents of the type because they share the primary
	dispatch table.
	(Register_Primitive): Do not register primitives of interfaces that
	are parents of the type.
	* sem_ch13.adb (Analyze_Freeze_Entity): Add documentation.
	* exp_cg.adb (Write_Type_Info): When displaying overriding of interface
	primitives skip primitives of interfaces that are parents of the type.

2010-06-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Eval_Attribute): If the prefix is an array, the
	attribute cannot be constant-folded if an index type is a formal type,
	or is derived from one.
	* checks.adb (Determine_Range): ditto.

2010-06-23  Arnaud Charlet  <charlet@adacore.com>

	* gnat_ugn.texi, gnatxref.adb: Add support for --ext switch.

2010-06-23  Bob Duff  <duff@adacore.com>

	* g-pehage.ads, g-pehage.adb (Put): Fix off-by-one bug.
	(Insert): Disallow nul characters.
	(misc output routines): Assert no nul characters.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161247 138bc75d-0d04-0410-961f-82ee72b054a4

13 files changed, 350 insertions, 135 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8230b7394c4..361182c438c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,42 @@
+2010-06-23  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal
+	entities for parent types that are interfaces. Needed in generics to
+	handle formals that implement interfaces.
+	(Derive_Subprograms): Add assertion for derivation of tagged types that
+	do not cover interfaces. For generics, complete code that handles
+	derivation of type that covers interfaces because the previous
+	condition was weak (it required only name consistency; arguments were
+	not checked). Add new code to locate primitives covering interfaces
+	defined in generic units or instantiatons.
+	* sem_util.adb (Has_Interfaces): Add missing support for derived types.
+	* sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups.
+	* exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of
+	interfaces that are parents of the type because they share the primary
+	dispatch table.
+	(Register_Primitive): Do not register primitives of interfaces that
+	are parents of the type.
+	* sem_ch13.adb (Analyze_Freeze_Entity): Add documentation.
+	* exp_cg.adb (Write_Type_Info): When displaying overriding of interface
+	primitives skip primitives of interfaces that are parents of the type.
+
+2010-06-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_attr.adb (Eval_Attribute): If the prefix is an array, the
+	attribute cannot be constant-folded if an index type is a formal type,
+	or is derived from one.
+	* checks.adb (Determine_Range): ditto.
+
+2010-06-23  Arnaud Charlet  <charlet@adacore.com>
+
+	* gnat_ugn.texi, gnatxref.adb: Add support for --ext switch.
+
+2010-06-23  Bob Duff  <duff@adacore.com>
+
+	* g-pehage.ads, g-pehage.adb (Put): Fix off-by-one bug.
+	(Insert): Disallow nul characters.
+	(misc output routines): Assert no nul characters.
+
 2010-06-23  Ed Schonberg  <schonberg@adacore.com>
 
 	* exp_ch4.adb: Use predefined unsigned type in all cases.
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index b6b1df415b3..9261a279882 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -3351,6 +3351,14 @@ package body Checks is
                         Indx := Next_Index (Indx);
                      end loop;
 
+                     --  if The index type is a formal type, or derived from
+                     --  one, the bounds are not static.
+
+                     if Is_Generic_Type (Root_Type (Etype (Indx))) then
+                        OK := False;
+                        return;
+                     end if;
+
                      Determine_Range
                        (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
                         Assume_Valid);
diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb
index c35391c116c..e7decc8f1e7 100644
--- a/gcc/ada/exp_cg.adb
+++ b/gcc/ada/exp_cg.adb
@@ -572,7 +572,11 @@ package body Exp_CG is
                   Prim_Op := Node (Prim_Elmt);
                   Int_Alias := Interface_Alias (Prim_Op);
 
-                  if Present (Int_Alias) and then (Alias (Prim_Op)) = Prim then
+                  if Present (Int_Alias)
+                    and then not Is_Ancestor
+                                   (Find_Dispatching_Type (Int_Alias), Typ)
+                    and then (Alias (Prim_Op)) = Prim
+                  then
                      Write_Char (',');
                      Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
                      Write_Char (':');
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index fd8fe730787..5a1f2496422 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -6014,6 +6014,9 @@ package body Exp_Disp is
             --  Look for primitive overriding an abstract interface subprogram
 
             if Present (Interface_Alias (Prim))
+              and then not
+                Is_Ancestor
+                  (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
             then
                Prim_Pos := DT_Position (Alias (Prim));
@@ -6721,6 +6724,13 @@ package body Exp_Disp is
 
          pragma Assert (Is_Interface (Iface_Typ));
 
+         --  No action needed for interfaces that are ancestors of Typ because
+         --  their primitives are located in the primary dispatch table.
+
+         if Is_Ancestor (Iface_Typ, Tag_Typ) then
+            return L;
+         end if;
+
          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
 
          if not Is_Ancestor (Iface_Typ, Tag_Typ)
diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb
index 6c63c82cb49..91344a0ed8c 100644
--- a/gcc/ada/g-pehage.adb
+++ b/gcc/ada/g-pehage.adb
@@ -145,6 +145,9 @@ package body GNAT.Perfect_Hash_Generators is
    --  Return a string which includes string Str or integer Int preceded by
    --  leading spaces if required by width W.
 
+   function Trim_Trailing_Nuls (Str : String) return String;
+   --  Return Str, but with trailing NUL characters removed.
+
    Output : File_Descriptor renames GNAT.OS_Lib.Standout;
    --  Shortcuts
 
@@ -524,6 +527,7 @@ package body GNAT.Perfect_Hash_Generators is
    ---------
 
    procedure Add (C : Character) is
+      pragma Assert (C /= ASCII.NUL);
    begin
       Line (Last + 1) := C;
       Last := Last + 1;
@@ -536,6 +540,11 @@ package body GNAT.Perfect_Hash_Generators is
    procedure Add (S : String) is
       Len : constant Natural := S'Length;
    begin
+      for J in S'Range loop
+         pragma Assert (S (J) /= ASCII.NUL);
+         null;
+      end loop;
+
       Line (Last + 1 .. Last + Len) := S;
       Last := Last + Len;
    end Add;
@@ -1261,6 +1270,11 @@ package body GNAT.Perfect_Hash_Generators is
          New_Line (Output);
       end if;
 
+      for J in Value'Range loop
+         pragma Assert (Value (J) /= ASCII.NUL);
+         null;
+      end loop;
+
       WT.Set_Last (NK);
       WT.Table (NK) := New_Word (Value);
       NK := NK + 1;
@@ -1726,6 +1740,11 @@ package body GNAT.Perfect_Hash_Generators is
    procedure Put (File : File_Descriptor; Str : String) is
       Len : constant Natural := Str'Length;
    begin
+      for J in Str'Range loop
+         pragma Assert (Str (J) /= ASCII.NUL);
+         null;
+      end loop;
+
       if Write (File, Str'Address, Len) /= Len then
          raise Program_Error;
       end if;
@@ -1768,13 +1787,12 @@ package body GNAT.Perfect_Hash_Generators is
          Last := 0;
       end if;
 
-      if Last + Len + 3 > Max then
+      if Last + Len + 3 >= Max then
          Flush;
       end if;
 
       if Last = 0 then
-         Line (Last + 1 .. Last + 5) := "     ";
-         Last := Last + 5;
+         Add ("     ");
 
          if F1 <= L1 then
             if C1 = F1 and then C2 = F2 then
@@ -1801,8 +1819,7 @@ package body GNAT.Perfect_Hash_Generators is
          Add (' ');
       end if;
 
-      Line (Last + 1 .. Last + Len) := S;
-      Last := Last + Len;
+      Add (S);
 
       if C2 = L2 then
          Add (')');
@@ -1869,7 +1886,8 @@ package body GNAT.Perfect_Hash_Generators is
          K := Get_Key (J);
          Put (File, Image (J, M),           F1, L1, J, 1, 3, 1);
          Put (File, Image (K.Edge, M),      F1, L1, J, 1, 3, 2);
-         Put (File, WT.Table (Initial (J)).all, F1, L1, J, 1, 3, 3);
+         Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
+                    F1, L1, J, 1, 3, 3);
       end loop;
    end Put_Initial_Keys;
 
@@ -1950,7 +1968,8 @@ package body GNAT.Perfect_Hash_Generators is
          K := Get_Key (J);
          Put (File, Image (J, M),           F1, L1, J, 1, 3, 1);
          Put (File, Image (K.Edge, M),      F1, L1, J, 1, 3, 2);
-         Put (File, WT.Table (Reduced (J)).all, F1, L1, J, 1, 3, 3);
+         Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
+                    F1, L1, J, 1, 3, 3);
       end loop;
    end Put_Reduced_Keys;
 
@@ -2337,7 +2356,8 @@ package body GNAT.Perfect_Hash_Generators is
                     Same_Keys_Sets_Table (J).First ..
                     Same_Keys_Sets_Table (J).Last
                   loop
-                     Put (Output, WT.Table (Reduced (K)).all);
+                     Put (Output,
+                          Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
                      New_Line (Output);
                   end loop;
                   Put (Output, "--");
@@ -2488,6 +2508,20 @@ package body GNAT.Perfect_Hash_Generators is
       return S;
    end Sum;
 
+   ------------------------
+   -- Trim_Trailing_Nuls --
+   ------------------------
+
+   function Trim_Trailing_Nuls (Str : String) return String is
+   begin
+      for J in Str'Range loop
+         if Str (J) = ASCII.NUL then
+            return Str (Str'First .. J - 1);
+         end if;
+      end loop;
+      return Str;
+   end Trim_Trailing_Nuls;
+
    ---------------
    -- Type_Size --
    ---------------
diff --git a/gcc/ada/g-pehage.ads b/gcc/ada/g-pehage.ads
index 24f5bcff1b2..63a5b900930 100644
--- a/gcc/ada/g-pehage.ads
+++ b/gcc/ada/g-pehage.ads
@@ -116,7 +116,7 @@ package GNAT.Perfect_Hash_Generators is
    --  Deallocate the internal structures and the words table
 
    procedure Insert (Value : String);
-   --  Insert a new word in the table
+   --  Insert a new word into the table. ASCII.NUL characters are not allowed.
 
    Too_Many_Tries : exception;
    --  Raised after Tries unsuccessful runs
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index e93e287c40f..a786e2fe6e8 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -11909,6 +11909,13 @@ Do not look for sources in the system default directory.
 @cindex @option{-nostdlib} (@command{gnatxref})
 Do not look for library files in the system default directory.
 
+@item --ext=@var{extension}
+@cindex @option{--ext} (@command{gnatxref})
+Specify an alternate ali file extension. The default is @code{ali} and other
+extensions (e.g. @code{sli} for SPARK library files) may be specified via this
+switch. Note that if this switch overrides the default, which means that only
+the new extension will be considered.
+
 @item --RTS=@var{rts-path}
 @cindex @option{--RTS} (@command{gnatxref})
 Specifies the default location of the runtime library. Same meaning as the
diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb
index 2cccc0f1f51..c20ef175564 100644
--- a/gcc/ada/gnatxref.adb
+++ b/gcc/ada/gnatxref.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2010, 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- --
@@ -52,6 +52,9 @@ procedure Gnatxref is
    RTS_Specified : String_Access := null;
    --  Used to detect multiple use of --RTS= switch
 
+   EXT_Specified : String_Access := null;
+   --  Used to detect multiple use of --ext= switch
+
    procedure Parse_Cmd_Line;
    --  Parse every switch on the command line
 
@@ -79,7 +82,7 @@ procedure Gnatxref is
       loop
          case
            GNAT.Command_Line.Getopt
-             ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS=")
+             ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS= -ext=")
          is
             when ASCII.NUL =>
                exit;
@@ -140,43 +143,70 @@ procedure Gnatxref is
 
                --  Check that it is the first time we see this switch
 
-               if RTS_Specified = null then
-                  RTS_Specified := new String'(GNAT.Command_Line.Parameter);
+               if Full_Switch = "-RTS" then
+                  if RTS_Specified = null then
+                     RTS_Specified := new String'(GNAT.Command_Line.Parameter);
 
-               elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
-                  Osint.Fail ("--RTS cannot be specified multiple times");
-               end if;
+                  elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
+                     Osint.Fail ("--RTS cannot be specified multiple times");
+                  end if;
 
-               Opt.No_Stdinc  := True;
-               Opt.RTS_Switch := True;
+                  Opt.No_Stdinc  := True;
+                  Opt.RTS_Switch := True;
 
-               declare
-                  Src_Path_Name : constant String_Ptr :=
-                                    Get_RTS_Search_Dir
-                                      (GNAT.Command_Line.Parameter, Include);
+                  declare
+                     Src_Path_Name : constant String_Ptr :=
+                                       Get_RTS_Search_Dir
+                                         (GNAT.Command_Line.Parameter,
+                                          Include);
 
-                  Lib_Path_Name : constant String_Ptr :=
-                                    Get_RTS_Search_Dir
-                                      (GNAT.Command_Line.Parameter, Objects);
+                     Lib_Path_Name : constant String_Ptr :=
+                                       Get_RTS_Search_Dir
+                                         (GNAT.Command_Line.Parameter,
+                                          Objects);
 
-               begin
-                  if Src_Path_Name /= null and then Lib_Path_Name /= null then
-                     Add_Search_Dirs (Src_Path_Name, Include);
-                     Add_Search_Dirs (Lib_Path_Name, Objects);
+                  begin
+                     if Src_Path_Name /= null
+                       and then Lib_Path_Name /= null
+                     then
+                        Add_Search_Dirs (Src_Path_Name, Include);
+                        Add_Search_Dirs (Lib_Path_Name, Objects);
+
+                     elsif Src_Path_Name = null
+                       and then Lib_Path_Name = null
+                     then
+                        Osint.Fail ("RTS path not valid: missing " &
+                                    "adainclude and adalib directories");
+
+                     elsif Src_Path_Name = null then
+                        Osint.Fail ("RTS path not valid: missing " &
+                                    "adainclude directory");
 
-                  elsif Src_Path_Name = null and then Lib_Path_Name = null then
-                     Osint.Fail ("RTS path not valid: missing " &
-                                 "adainclude and adalib directories");
+                     elsif  Lib_Path_Name = null then
+                        Osint.Fail ("RTS path not valid: missing " &
+                                    "adalib directory");
+                     end if;
+                  end;
 
-                  elsif Src_Path_Name = null then
-                     Osint.Fail ("RTS path not valid: missing " &
-                                 "adainclude directory");
+               elsif GNAT.Command_Line.Full_Switch = "-ext" then
 
-                  elsif  Lib_Path_Name = null then
-                     Osint.Fail ("RTS path not valid: missing " &
-                                 "adalib directory");
+                  --  Check that it is the first time we see this switch
+
+                  if EXT_Specified = null then
+                     EXT_Specified := new String'(GNAT.Command_Line.Parameter);
+
+                  elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then
+                     Osint.Fail ("--ext cannot be specified multiple times");
                   end if;
-               end;
+
+                  if EXT_Specified'Length
+                    = Osint.ALI_Default_Suffix'Length
+                  then
+                     Osint.ALI_Suffix := EXT_Specified.all'Access;
+                  else
+                     Osint.Fail ("--ext argument must have 3 characters");
+                  end if;
+               end if;
 
             when others =>
                Write_Usage;
@@ -239,6 +269,7 @@ procedure Gnatxref is
                 & " directory");
       Put_Line ("   -nostdlib Don't look for library files in the system"
                 & " default directory");
+      Put_Line ("   --ext=xxx Specify alternate ali file extension");
       Put_Line ("   --RTS=dir specify the default source and object search"
                 & " path");
       Put_Line ("   -p file   Use file as the default project file");
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 1b9fcf3ded2..8b5fd1313da 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -5633,10 +5633,10 @@ package body Sem_Attr is
             while Present (N) loop
                Static := Static and then Is_Static_Subtype (Etype (N));
 
-               --  If however the index type is generic, attributes cannot
-               --  be folded.
+               --  If however the index type is generic, or derived from
+               --  one, attributes cannot be folded.
 
-               if Is_Generic_Type (Etype (N))
+               if Is_Generic_Type (Root_Type (Etype (N)))
                  and then Id /= Attribute_Component_Size
                then
                   return;
@@ -6205,13 +6205,13 @@ package body Sem_Attr is
          Ind : Node_Id;
 
       begin
-         --  In the case of a generic index type, the bounds may appear static
-         --  but the computation is not meaningful in this case, and may
-         --  generate a spurious warning.
+         --  If any index type is a formal type, or derived from one, the
+         --  bounds are not static. Treating them as static can produce
+         --  spurious warnings or improper constant folding.
 
          Ind := First_Index (P_Type);
          while Present (Ind) loop
-            if Is_Generic_Type (Etype (Ind)) then
+            if Is_Generic_Type (Root_Type (Etype (Ind))) then
                return;
             end if;
 
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 5a375f5831c..cf151e9d721 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -2366,7 +2366,9 @@ package body Sem_Ch13 is
       --  code because their main purpose was to provide support to initialize
       --  the secondary dispatch tables. They are now generated also when
       --  compiling with no code generation to provide ASIS the relationship
-      --  between interface primitives and tagged type primitives.
+      --  between interface primitives and tagged type primitives. They are
+      --  also used to locate primitives covering interfaces when processing
+      --  generics (see Derive_Subprograms).
 
       if Ada_Version >= Ada_05
         and then Ekind (E) = E_Record_Type
@@ -2374,6 +2376,12 @@ package body Sem_Ch13 is
         and then not Is_Interface (E)
         and then Has_Interfaces (E)
       then
+         --  This would be a good common place to call the routine that checks
+         --  overriding of interface primitives (and thus factorize calls to
+         --  Check_Abstract_Overriding located at different contexts in the
+         --  compiler). However, this is not possible because it causes
+         --  spurious errors in case of late overriding.
+
          Add_Internal_Interface_Entities (E);
       end if;
    end Analyze_Freeze_Entity;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index c71e69dda79..37856403451 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -68,6 +68,7 @@ with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;
 with Stand;    use Stand;
 with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
 with Snames;   use Snames;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
@@ -1537,90 +1538,92 @@ package body Sem_Ch3 is
       while Present (Iface_Elmt) loop
          Iface := Node (Iface_Elmt);
 
-         --  Exclude from this processing interfaces that are parents of
-         --  Tagged_Type because their primitives are located in the primary
-         --  dispatch table (and hence no auxiliary internal entities are
-         --  required to handle secondary dispatch tables in such case).
+         --  Originally we excluded here from this processing interfaces that
+         --  are parents of Tagged_Type because their primitives are located
+         --  in the primary dispatch table (and hence no auxiliary internal
+         --  entities are required to handle secondary dispatch tables in such
+         --  case). However, these auxiliary entities are also required to
+         --  handle derivations of interfaces in formals of generics (see
+         --  Derive_Subprograms).
 
-         if not Is_Ancestor (Iface, Tagged_Type) then
-            Elmt := First_Elmt (Primitive_Operations (Iface));
-            while Present (Elmt) loop
-               Iface_Prim := Node (Elmt);
+         Elmt := First_Elmt (Primitive_Operations (Iface));
+         while Present (Elmt) loop
+            Iface_Prim := Node (Elmt);
 
-               if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
-                  Prim :=
-                    Find_Primitive_Covering_Interface
-                      (Tagged_Type => Tagged_Type,
-                       Iface_Prim  => Iface_Prim);
+            if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
+               Prim :=
+                 Find_Primitive_Covering_Interface
+                   (Tagged_Type => Tagged_Type,
+                    Iface_Prim  => Iface_Prim);
 
-                  if No (Prim) then
+               if No (Prim) then
 
-                     --  In some rare cases, a name conflict may have kept the
-                     --  operation completely hidden. Look for it in the list
-                     --  of primitive operations of the type.
+                  --  In some rare cases, a name conflict may have kept the
+                  --  operation completely hidden. Look for it in the list
+                  --  of primitive operations of the type.
 
-                     declare
-                        El : Elmt_Id;
-                     begin
-                        El := First_Elmt (Primitive_Operations (Tagged_Type));
-                        while Present (El) loop
-                           Prim := Node (El);
-                           exit when Is_Subprogram (Prim)
-                             and then Alias (Prim) = Iface_Prim;
-                           Next_Elmt (El);
-                        end loop;
+                  declare
+                     El : Elmt_Id;
 
-                        --  If the operation was not explicitly overridden, it
-                        --  should have been inherited as an abstract operation
-                        --  so Prim can not be Empty at this stage.
+                  begin
+                     El := First_Elmt (Primitive_Operations (Tagged_Type));
+                     while Present (El) loop
+                        Prim := Node (El);
+                        exit when Is_Subprogram (Prim)
+                          and then Alias (Prim) = Iface_Prim;
+                        Next_Elmt (El);
+                     end loop;
 
-                        if No (El) then
-                           raise Program_Error;
-                        end if;
-                     end;
-                  end if;
+                     --  If the operation was not explicitly overridden, it
+                     --  should have been inherited as an abstract operation
+                     --  so Prim can not be Empty at this stage.
 
-                  Derive_Subprogram
-                    (New_Subp     => New_Subp,
-                     Parent_Subp  => Iface_Prim,
-                     Derived_Type => Tagged_Type,
-                     Parent_Type  => Iface);
-
-                  --  Ada 2005 (AI-251): Decorate internal entity Iface_Subp
-                  --  associated with interface types. These entities are
-                  --  only registered in the list of primitives of its
-                  --  corresponding tagged type because they are only used
-                  --  to fill the contents of the secondary dispatch tables.
-                  --  Therefore they are removed from the homonym chains.
-
-                  Set_Is_Hidden (New_Subp);
-                  Set_Is_Internal (New_Subp);
-                  Set_Alias (New_Subp, Prim);
-                  Set_Is_Abstract_Subprogram (New_Subp,
-                    Is_Abstract_Subprogram (Prim));
-                  Set_Interface_Alias (New_Subp, Iface_Prim);
-
-                  --  Internal entities associated with interface types are
-                  --  only registered in the list of primitives of the tagged
-                  --  type. They are only used to fill the contents of the
-                  --  secondary dispatch tables. Therefore they are not needed
-                  --  in the homonym chains.
-
-                  Remove_Homonym (New_Subp);
-
-                  --  Hidden entities associated with interfaces must have set
-                  --  the Has_Delay_Freeze attribute to ensure that, in case of
-                  --  locally defined tagged types (or compiling with static
-                  --  dispatch tables generation disabled) the corresponding
-                  --  entry of the secondary dispatch table is filled when
-                  --  such an entity is frozen.
-
-                  Set_Has_Delayed_Freeze (New_Subp);
+                     if No (El) then
+                        raise Program_Error;
+                     end if;
+                  end;
                end if;
 
-               Next_Elmt (Elmt);
-            end loop;
-         end if;
+               Derive_Subprogram
+                 (New_Subp     => New_Subp,
+                  Parent_Subp  => Iface_Prim,
+                  Derived_Type => Tagged_Type,
+                  Parent_Type  => Iface);
+
+               --  Ada 2005 (AI-251): Decorate internal entity Iface_Subp
+               --  associated with interface types. These entities are
+               --  only registered in the list of primitives of its
+               --  corresponding tagged type because they are only used
+               --  to fill the contents of the secondary dispatch tables.
+               --  Therefore they are removed from the homonym chains.
+
+               Set_Is_Hidden (New_Subp);
+               Set_Is_Internal (New_Subp);
+               Set_Alias (New_Subp, Prim);
+               Set_Is_Abstract_Subprogram
+                 (New_Subp, Is_Abstract_Subprogram (Prim));
+               Set_Interface_Alias (New_Subp, Iface_Prim);
+
+               --  Internal entities associated with interface types are
+               --  only registered in the list of primitives of the tagged
+               --  type. They are only used to fill the contents of the
+               --  secondary dispatch tables. Therefore they are not needed
+               --  in the homonym chains.
+
+               Remove_Homonym (New_Subp);
+
+               --  Hidden entities associated with interfaces must have set
+               --  the Has_Delay_Freeze attribute to ensure that, in case of
+               --  locally defined tagged types (or compiling with static
+               --  dispatch tables generation disabled) the corresponding
+               --  entry of the secondary dispatch table is filled when
+               --  such an entity is frozen.
+
+               Set_Has_Delayed_Freeze (New_Subp);
+            end if;
+
+            Next_Elmt (Elmt);
+         end loop;
 
          Next_Elmt (Iface_Elmt);
       end loop;
@@ -11955,7 +11958,7 @@ package body Sem_Ch3 is
       --  non-abstract tagged types that can reference abstract primitives
       --  through its Alias attribute are the internal entities that have
       --  attribute Interface_Alias, and these entities are generated later
-      --  by Freeze_Record_Type).
+      --  by Add_Internal_Interface_Entities).
 
       if In_Private_Part (Current_Scope)
         and then Is_Abstract_Type (Parent_Type)
@@ -12734,6 +12737,12 @@ package body Sem_Ch3 is
             --  corresponding operations of the actual.
 
             else
+               pragma Assert (No (Node (Act_Elmt))
+                 or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
+                            and then
+                          Type_Conformant (Subp, Node (Act_Elmt),
+                                           Skip_Controlling_Formals => True)));
+
                Derive_Subprogram
                  (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
 
@@ -12839,7 +12848,11 @@ package body Sem_Ch3 is
               or else
                 (Present (Generic_Actual)
                   and then Present (Act_Subp)
-                  and then not Primitive_Names_Match (Subp, Act_Subp))
+                  and then not
+                    (Primitive_Names_Match (Subp, Act_Subp)
+                       and then
+                     Type_Conformant (Subp, Act_Subp,
+                                      Skip_Controlling_Formals => True)))
             then
                pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual));
 
@@ -12849,14 +12862,73 @@ package body Sem_Ch3 is
 
                --  Handle entities associated with interface primitives
 
-               if Present (Alias (Subp))
-                 and then Is_Interface (Find_Dispatching_Type (Alias (Subp)))
+               if Present (Alias_Subp)
+                 and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
                  and then not Is_Predefined_Dispatching_Operation (Subp)
                then
+                  --  Search for the primitive in the homonym chain
+
                   Act_Subp :=
                     Find_Primitive_Covering_Interface
                       (Tagged_Type => Generic_Actual,
-                       Iface_Prim  => Subp);
+                       Iface_Prim  => Alias_Subp);
+
+                  --  Previous search may not locate primitives covering
+                  --  interfaces defined in generics units or instantiations.
+                  --  (it fails if the covering primitive has formals whose
+                  --  type is also defined in generics or instantiations).
+                  --  In such case we search in the list of primitives of the
+                  --  generic actual for the internal entity that links the
+                  --  interface primitive and the covering primitive.
+
+                  if No (Act_Subp)
+                    and then Is_Generic_Type (Parent_Type)
+                  then
+                     --  This code has been designed to handle only generic
+                     --  formals that implement interfaces that are defined
+                     --  in a generic unit or instantiation. If this code is
+                     --  needed for other cases we must review it because
+                     --  (given that it relies on Original_Location to locate
+                     --  the primitive of Generic_Actual that covers the
+                     --  interface) it could leave linked through attribute
+                     --  Alias entities of unrelated instantiations).
+
+                     pragma Assert
+                       (Is_Generic_Unit
+                          (Scope (Find_Dispatching_Type (Alias_Subp)))
+                       or else
+                        Instantiation_Depth
+                          (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
+
+                     declare
+                        Iface_Prim_Loc : constant Source_Ptr :=
+                                         Original_Location (Sloc (Alias_Subp));
+                        Elmt      : Elmt_Id;
+                        Prim      : Entity_Id;
+                     begin
+                        Elmt :=
+                          First_Elmt (Primitive_Operations (Generic_Actual));
+
+                        Search : while Present (Elmt) loop
+                           Prim := Node (Elmt);
+
+                           if Present (Interface_Alias (Prim))
+                             and then Original_Location
+                                        (Sloc (Interface_Alias (Prim)))
+                                       = Iface_Prim_Loc
+                           then
+                              Act_Subp := Alias (Prim);
+                              exit Search;
+                           end if;
+
+                           Next_Elmt (Elmt);
+                        end loop Search;
+                     end;
+                  end if;
+
+                  pragma Assert (Present (Act_Subp)
+                    or else Is_Abstract_Type (Generic_Actual)
+                    or else Serious_Errors_Detected > 0);
 
                --  Handle predefined primitives plus the rest of user-defined
                --  primitives
@@ -12874,6 +12946,10 @@ package body Sem_Ch3 is
 
                      Next_Elmt (Act_Elmt);
                   end loop;
+
+                  if No (Act_Elmt) then
+                     Act_Subp := Empty;
+                  end if;
                end if;
             end if;
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index b09f91e585a..7121b67832e 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4568,7 +4568,7 @@ package body Sem_Ch6 is
 
             elsif Must_Override (Spec) then
                if Is_Overriding_Operation (Subp) then
-                  Set_Is_Overriding_Operation (Subp);
+                  null;
 
                elsif not Can_Override then
                   Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
@@ -6477,8 +6477,8 @@ package body Sem_Ch6 is
         or else Etype (Prim) = Etype (Iface_Prim)
         or else not Has_Controlling_Result (Prim)
       then
-         return Type_Conformant (Prim, Iface_Prim,
-                  Skip_Controlling_Formals => True);
+         return Type_Conformant
+                  (Iface_Prim, Prim, Skip_Controlling_Formals => True);
 
       --  Case of a function returning an interface, or an access to one.
       --  Check that the return types correspond.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 81046af05da..f96b45b1754 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -4497,15 +4497,13 @@ package body Sem_Util is
      (T             : Entity_Id;
       Use_Full_View : Boolean := True) return Boolean
    is
-      Typ : Entity_Id;
+      Typ : Entity_Id := Base_Type (T);
 
    begin
       --  Handle concurrent types
 
-      if Is_Concurrent_Type (T) then
-         Typ := Corresponding_Record_Type (T);
-      else
-         Typ := T;
+      if Is_Concurrent_Type (Typ) then
+         Typ := Corresponding_Record_Type (Typ);
       end if;
 
       if not Present (Typ)