2011-09-02 Bob Duff <duff@adacore.com>

	* einfo.adb: (Has_Xref_Entry): Do not call
	Implementation_Base_Type. Lib.Xref has been
	rewritten to avoid the need for it, and it was costly.
	* s-htable.ads,s-htable.adb: (Present,Set_If_Not_Present): New
	functions in support of efficient xref.
	* lib-xref-alfa.adb: Misc changes related to Key component of
	type Xref_Entry.
	* lib-xref.adb: (Add_Entry,etc): Speed improvement.
	(New_Entry): Call Implementation_Base_Type, because Has_Xref_Entry
	no longer does. This is the one place where it is needed.

2011-09-02  Johannes Kanig  <kanig@adacore.com>

	* g-comlin.adb (Getopt): New optional argument Concatenate to have
	similar interface as the other Getopt function.

2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb: (Expand_Allocator_Expression): Do not generate
	a call to Set_Finalize_Address if there is no allocator available.
	* exp_util.adb: (Build_Allocate_Deallocate_Proc): Account for
	a case of allocator expansion where the allocator is not expanded but
	needs a custom allocate routine. Code reformatting.
	(Is_Finalizable_Transient): Remove local variables Has_Rens and
	Ren_Obj. Code reformatting.
	(Is_Renamed): Renamed to Is_Aliased. Add code to detect aliasing
	through the use of 'reference.
	* sem_ch4.adb: (Analyze_Allocator): Detect allocators generated
	as part of build-in-place expansion. They are intentionally marked as
	coming from source, but their parents are not.



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

11 files changed, 530 insertions, 298 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4ab69228bbb..8f63086a214 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,36 @@
+2011-09-02  Bob Duff  <duff@adacore.com>
+
+	* einfo.adb: (Has_Xref_Entry): Do not call
+	Implementation_Base_Type. Lib.Xref has been
+	rewritten to avoid the need for it, and it was costly.
+	* s-htable.ads,s-htable.adb: (Present,Set_If_Not_Present): New
+	functions in support of efficient xref.
+	* lib-xref-alfa.adb: Misc changes related to Key component of
+	type Xref_Entry.
+	* lib-xref.adb: (Add_Entry,etc): Speed improvement.
+	(New_Entry): Call Implementation_Base_Type, because Has_Xref_Entry
+	no longer does. This is the one place where it is needed.
+
+2011-09-02  Johannes Kanig  <kanig@adacore.com>
+
+	* g-comlin.adb (Getopt): New optional argument Concatenate to have
+	similar interface as the other Getopt function.
+
+2011-09-02  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch4.adb: (Expand_Allocator_Expression): Do not generate
+	a call to Set_Finalize_Address if there is no allocator available.
+	* exp_util.adb: (Build_Allocate_Deallocate_Proc): Account for
+	a case of allocator expansion where the allocator is not expanded but
+	needs a custom allocate routine. Code reformatting.
+	(Is_Finalizable_Transient): Remove local variables Has_Rens and
+	Ren_Obj. Code reformatting.
+	(Is_Renamed): Renamed to Is_Aliased. Add code to detect aliasing
+	through the use of 'reference.
+	* sem_ch4.adb: (Analyze_Allocator): Detect allocators generated
+	as part of build-in-place expansion. They are intentionally marked as
+	coming from source, but their parents are not.
+
 2011-09-02  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch10.adb (Analyze_With_Clause): If the library unit
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index dbe5c261073..494f31b9f1c 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -1599,7 +1599,7 @@ package body Einfo is
 
    function Has_Xref_Entry (Id : E) return B is
    begin
-      return Flag182 (Implementation_Base_Type (Id));
+      return Flag182 (Id);
    end Has_Xref_Entry;
 
    function Hiding_Loop_Variable (Id : E) return E is
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 65735b8d443..3c6754b26bb 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -1137,11 +1137,14 @@ package body Exp_Ch4 is
 
             --  Since .NET/JVM compilers do not support address arithmetic,
             --  this call is skipped. The same is done for CodePeer because
-            --  primitive Finalize_Address is never generated.
+            --  primitive Finalize_Address is never generated. Do not create
+            --  this call if there is no allocator available any more.
 
             if VM_Target = No_VM
               and then not CodePeer_Mode
               and then Present (Finalization_Master (PtrT))
+              and then Present (Temp_Decl)
+              and then Nkind (Expression (Temp_Decl)) = N_Allocator
             then
                Insert_Action (N,
                  Make_Set_Finalize_Address_Call
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index bc323a8afd4..65311f8eec3 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -494,13 +494,39 @@ package body Exp_Util is
             Expr := N;
          end if;
 
-         Ptr_Typ := Base_Type (Etype (Expr));
+         --  In certain cases an allocator with a qualified expression may
+         --  be relocated and used as the initialization expression of a
+         --  temporary:
+
+         --    before:
+         --       Obj : Ptr_Typ := new Desig_Typ'(...);
+
+         --    after:
+         --       Tmp : Ptr_Typ := new Desig_Typ'(...);
+         --       Obj : Ptr_Typ := Tmp;
+
+         --  Since the allocator is always marked as analyzed to avoid infinite
+         --  expansion, it will never be processed by this routine given that
+         --  the designated type needs finalization actions. Detect this case
+         --  and complete the expansion of the allocator.
+
+         if Nkind (Expr) = N_Identifier
+           and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+           and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
+         then
+            Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
+            return;
+         end if;
 
-         --  The allocator may have been rewritten into something else
+         --  The allocator may have been rewritten into something else in which
+         --  case the expansion performed by this routine does not apply.
 
-         if Nkind (Expr) = N_Allocator then
-            Proc_To_Call := Procedure_To_Call (Expr);
+         if Nkind (Expr) /= N_Allocator then
+            return;
          end if;
+
+         Ptr_Typ := Base_Type (Etype (Expr));
+         Proc_To_Call := Procedure_To_Call (Expr);
       end if;
 
       Pool_Id := Associated_Storage_Pool (Ptr_Typ);
@@ -3723,11 +3749,9 @@ package body Exp_Util is
      (Decl     : Node_Id;
       Rel_Node : Node_Id) return Boolean
    is
-      Obj_Id   : constant Entity_Id := Defining_Identifier (Decl);
-      Obj_Typ  : constant Entity_Id := Base_Type (Etype (Obj_Id));
-      Desig    : Entity_Id := Obj_Typ;
-      Has_Rens : Boolean   := True;
-      Ren_Obj  : Entity_Id;
+      Obj_Id  : constant Entity_Id := Defining_Identifier (Decl);
+      Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+      Desig   : Entity_Id := Obj_Typ;
 
       function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
       --  Determine whether transient object Trans_Id is initialized either
@@ -3741,14 +3765,15 @@ package body Exp_Util is
       --  value 1 and BIPaccess is not null. This case creates an aliasing
       --  between the returned value and the value denoted by BIPaccess.
 
-      function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
-      --  Determine whether transient object Trans_Id is allocated on the heap
-
-      function Is_Renamed
+      function Is_Aliased
         (Trans_Id   : Entity_Id;
          First_Stmt : Node_Id) return Boolean;
-      --  Determine whether transient object Trans_Id has been renamed in the
-      --  statement list starting from First_Stmt.
+      --  Determine whether transient object Trans_Id has been renamed or
+      --  aliased through 'reference in the statement list starting from
+      --  First_Stmt.
+
+      function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
+      --  Determine whether transient object Trans_Id is allocated on the heap
 
       ---------------------------
       -- Initialized_By_Access --
@@ -3849,30 +3874,14 @@ package body Exp_Util is
          return False;
       end Initialized_By_Aliased_BIP_Func_Call;
 
-      ------------------
-      -- Is_Allocated --
-      ------------------
-
-      function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
-         Expr : constant Node_Id := Expression (Parent (Trans_Id));
-
-      begin
-         return
-           Is_Access_Type (Etype (Trans_Id))
-             and then Present (Expr)
-             and then Nkind (Expr) = N_Allocator;
-      end Is_Allocated;
-
       ----------------
-      -- Is_Renamed --
+      -- Is_Aliased --
       ----------------
 
-      function Is_Renamed
+      function Is_Aliased
         (Trans_Id   : Entity_Id;
          First_Stmt : Node_Id) return Boolean
       is
-         Stmt : Node_Id;
-
          function Extract_Renamed_Object
            (Ren_Decl : Node_Id) return Entity_Id;
          --  Given an object renaming declaration, retrieve the entity of the
@@ -3918,26 +3927,30 @@ package body Exp_Util is
             return Empty;
          end Extract_Renamed_Object;
 
-      --  Start of processing for Is_Renamed
-
-      begin
-         --  If a previous invocation of this routine has determined that a
-         --  list has no renamings, then no point in repeating the same scan.
-
-         if not Has_Rens then
-            return False;
-         end if;
+         --  Local variables
 
-         --  Assume that the statement list does not have a renaming. This is a
-         --  minor optimization.
+         Expr    : Node_Id;
+         Ren_Obj : Entity_Id;
+         Stmt    : Node_Id;
 
-         Has_Rens := False;
+      --  Start of processing for Is_Aliased
 
+      begin
          Stmt := First_Stmt;
          while Present (Stmt) loop
-            if Nkind (Stmt) = N_Object_Renaming_Declaration then
-               Has_Rens := True;
-               Ren_Obj  := Extract_Renamed_Object (Stmt);
+            if Nkind (Stmt) = N_Object_Declaration then
+               Expr := Expression (Stmt);
+
+               if Present (Expr)
+                 and then Nkind (Expr) = N_Reference
+                 and then Nkind (Prefix (Expr)) = N_Identifier
+                 and then Entity (Prefix (Expr)) = Trans_Id
+               then
+                  return True;
+               end if;
+
+            elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
+               Ren_Obj := Extract_Renamed_Object (Stmt);
 
                if Present (Ren_Obj)
                  and then Ren_Obj = Trans_Id
@@ -3950,7 +3963,21 @@ package body Exp_Util is
          end loop;
 
          return False;
-      end Is_Renamed;
+      end Is_Aliased;
+
+      ------------------
+      -- Is_Allocated --
+      ------------------
+
+      function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
+         Expr : constant Node_Id := Expression (Parent (Trans_Id));
+
+      begin
+         return
+           Is_Access_Type (Etype (Trans_Id))
+             and then Present (Expr)
+             and then Nkind (Expr) = N_Allocator;
+      end Is_Allocated;
 
    --  Start of processing for Is_Finalizable_Transient
 
@@ -3967,6 +3994,11 @@ package body Exp_Util is
           and then Requires_Transient_Scope (Desig)
           and then Nkind (Rel_Node) /= N_Simple_Return_Statement
 
+         --  Do not consider renamed or 'reference-d transient objects because
+         --  the act of renaming extends the object's lifetime.
+
+          and then not Is_Aliased (Obj_Id, Decl)
+
          --  Do not consider transient objects allocated on the heap since they
          --  are attached to a finalization master.
 
@@ -3985,11 +4017,6 @@ package body Exp_Util is
 
           and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
 
-         --  Do not consider renamed transient objects because the act of
-         --  renaming extends the object's lifetime.
-
-          and then not Is_Renamed (Obj_Id, Decl)
-
          --  Do not consider conversions of tags to class-wide types
 
           and then not Is_Tag_To_CW_Conversion (Obj_Id);
diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb
index 43a6524eb61..cce88b9daed 100644
--- a/gcc/ada/g-comlin.adb
+++ b/gcc/ada/g-comlin.adb
@@ -3236,9 +3236,10 @@ package body GNAT.Command_Line is
    ------------
 
    procedure Getopt
-     (Config   : Command_Line_Configuration;
-      Callback : Switch_Handler := null;
-      Parser   : Opt_Parser     := Command_Line_Parser)
+     (Config      : Command_Line_Configuration;
+      Callback    : Switch_Handler := null;
+      Parser      : Opt_Parser := Command_Line_Parser;
+      Concatenate : Boolean := True)
    is
       Getopt_Switches : String_Access;
       C               : Character := ASCII.NUL;
@@ -3373,7 +3374,7 @@ package body GNAT.Command_Line is
 
       loop
          C := Getopt (Switches    => Getopt_Switches.all,
-                      Concatenate => True,
+                      Concatenate => Concatenate,
                       Parser      => Parser);
 
          if C = '*' then
diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads
index f1b21637d1b..f19d7baea5b 100644
--- a/gcc/ada/g-comlin.ads
+++ b/gcc/ada/g-comlin.ads
@@ -703,9 +703,10 @@ package GNAT.Command_Line is
    --  switch.
 
    procedure Getopt
-     (Config   : Command_Line_Configuration;
-      Callback : Switch_Handler := null;
-      Parser   : Opt_Parser := Command_Line_Parser);
+     (Config      : Command_Line_Configuration;
+      Callback    : Switch_Handler := null;
+      Parser      : Opt_Parser := Command_Line_Parser;
+      Concatenate : Boolean := True);
    --  Similar to the standard Getopt function.
    --  For each switch found on the command line, this calls Callback, if the
    --  switch is not handled automatically.
@@ -716,6 +717,9 @@ package GNAT.Command_Line is
    --  variable). This function will in fact never call [Callback] if all
    --  switches were handled automatically and there is nothing left to do.
    --
+   --  The option Concatenate is identical to the one of the standard Getopt
+   --  function.
+   --
    --  This procedure automatically adds -h and --help to the valid switches,
    --  to display the help message and raises Exit_From_Command_Line.
    --  If an invalid switch is specified on the command line, this procedure
diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb
index 25b7b79797c..8a29818f37c 100644
--- a/gcc/ada/lib-xref-alfa.adb
+++ b/gcc/ada/lib-xref-alfa.adb
@@ -456,10 +456,11 @@ package body Alfa is
          --  Second test: within same unit, sort by location of the scope of
          --  the entity definition.
 
-         elsif Get_Scope_Num (T1.Ent_Scope) /=
-           Get_Scope_Num (T2.Ent_Scope)
+         elsif Get_Scope_Num (T1.Key.Ent_Scope) /=
+           Get_Scope_Num (T2.Key.Ent_Scope)
          then
-            return Get_Scope_Num (T1.Ent_Scope) < Get_Scope_Num (T2.Ent_Scope);
+            return Get_Scope_Num (T1.Key.Ent_Scope) <
+              Get_Scope_Num (T2.Key.Ent_Scope);
 
          --  Third test: within same unit and scope, sort by location of
          --  entity definition.
@@ -470,41 +471,47 @@ package body Alfa is
          --  Fourth test: if reference is in same unit as entity definition,
          --  sort first.
 
-         elsif T1.Lun /= T2.Lun and then T1.Ent_Scope_File = T1.Lun then
+         elsif
+           T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun
+         then
             return True;
-         elsif T1.Lun /= T2.Lun and then T2.Ent_Scope_File = T2.Lun then
+
+         elsif
+           T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun
+         then
             return False;
 
          --  Fifth test: if reference is in same unit and same scope as entity
          --  definition, sort first.
 
-         elsif T1.Ent_Scope_File = T1.Lun
-           and then T1.Ref_Scope /= T2.Ref_Scope
-           and then T1.Ent_Scope = T1.Ref_Scope
+         elsif T1.Ent_Scope_File = T1.Key.Lun
+           and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope
+           and then T1.Key.Ent_Scope = T1.Key.Ref_Scope
          then
             return True;
-         elsif T1.Ent_Scope_File = T1.Lun
-           and then T1.Ref_Scope /= T2.Ref_Scope
-           and then T2.Ent_Scope = T2.Ref_Scope
+         elsif T1.Ent_Scope_File = T1.Key.Lun
+           and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope
+           and then T2.Key.Ent_Scope = T2.Key.Ref_Scope
          then
             return False;
 
          --  Sixth test: for same entity, sort by reference location unit
 
-         elsif T1.Lun /= T2.Lun then
-            return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
+         elsif T1.Key.Lun /= T2.Key.Lun then
+            return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun);
 
          --  Seventh test: for same entity, sort by reference location scope
 
-         elsif Get_Scope_Num (T1.Ref_Scope) /=
-           Get_Scope_Num (T2.Ref_Scope)
+         elsif Get_Scope_Num (T1.Key.Ref_Scope) /=
+           Get_Scope_Num (T2.Key.Ref_Scope)
          then
-            return Get_Scope_Num (T1.Ref_Scope) < Get_Scope_Num (T2.Ref_Scope);
+            return Get_Scope_Num (T1.Key.Ref_Scope) <
+              Get_Scope_Num (T2.Key.Ref_Scope);
 
          --  Eighth test: order of location within referencing unit
 
-         elsif T1.Loc /= T2.Loc then
-            return T1.Loc < T2.Loc;
+         elsif T1.Key.Loc /= T2.Key.Loc then
+            return T1.Key.Loc < T2.Key.Loc;
 
          --  Finally, for two locations at the same address prefer the one that
          --  does NOT have the type 'r', so that a modification or extension
@@ -513,7 +520,7 @@ package body Alfa is
          --  in-out actuals, the read reference follows the modify reference.
 
          else
-            return T2.Typ = 'r';
+            return T2.Key.Typ = 'r';
          end if;
       end Lt;
 
@@ -563,7 +570,7 @@ package body Alfa is
 
          --  Set entity at this point with newly created "Heap" variable
 
-         Xrefs.Table (Xrefs.Last).Ent := Heap;
+         Xrefs.Table (Xrefs.Last).Key.Ent := Heap;
 
          Nrefs         := Nrefs + 1;
          Rnums (Nrefs) := Xrefs.Last;
@@ -637,13 +644,13 @@ package body Alfa is
          Nrefs := 0;
 
          for J in 1 .. NR loop
-            if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Ent))
-              and then Alfa_References (Xrefs.Table (Rnums (J)).Typ)
-              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ent_Scope)
-              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ref_Scope)
-              and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent)
-              and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Ent,
-                                          Xrefs.Table (Rnums (J)).Typ)
+            if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent))
+              and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ)
+              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope)
+              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope)
+              and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent)
+              and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent,
+                                          Xrefs.Table (Rnums (J)).Key.Typ)
             then
                Nrefs         := Nrefs + 1;
                Rnums (Nrefs) := Rnums (J);
@@ -695,12 +702,12 @@ package body Alfa is
          Prevt := 'm';
 
          for J in 1 .. NR loop
-            if Xrefs.Table (Rnums (J)).Loc /= Crloc
+            if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc
               or else (Prevt = 'm'
-                        and then Xrefs.Table (Rnums (J)).Typ = 'r')
+                        and then Xrefs.Table (Rnums (J)).Key.Typ = 'r')
             then
-               Crloc         := Xrefs.Table (Rnums (J)).Loc;
-               Prevt         := Xrefs.Table (Rnums (J)).Typ;
+               Crloc         := Xrefs.Table (Rnums (J)).Key.Loc;
+               Prevt         := Xrefs.Table (Rnums (J)).Key.Typ;
                Nrefs         := Nrefs + 1;
                Rnums (Nrefs) := Rnums (J);
             end if;
@@ -814,13 +821,13 @@ package body Alfa is
             --  construction of the scope table, or an erroneous scope for the
             --  current cross-reference.
 
-            pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope));
+            pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope));
 
             --  Update the range of cross references to which the current scope
             --  refers to. This may be the empty range only for the first scope
             --  considered.
 
-            if XE.Ent_Scope /= Cur_Scope then
+            if XE.Key.Ent_Scope /= Cur_Scope then
                Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref :=
                  From_Xref_Idx;
                Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref :=
@@ -828,39 +835,39 @@ package body Alfa is
                From_Xref_Idx := Alfa_Xref_Table.Last + 1;
             end if;
 
-            while XE.Ent_Scope /= Cur_Scope loop
+            while XE.Key.Ent_Scope /= Cur_Scope loop
                Cur_Scope_Idx := Cur_Scope_Idx + 1;
                pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last);
             end loop;
 
-            if XE.Ent /= Cur_Entity then
+            if XE.Key.Ent /= Cur_Entity then
                Cur_Entity_Name :=
-                 new String'(Unique_Name (XE.Ent));
+                 new String'(Unique_Name (XE.Key.Ent));
             end if;
 
-            if XE.Ent = Heap then
+            if XE.Key.Ent = Heap then
                Alfa_Xref_Table.Append (
                  (Entity_Name => Cur_Entity_Name,
                   Entity_Line => 0,
-                  Etype       => Get_Entity_Type (XE.Ent),
+                  Etype       => Get_Entity_Type (XE.Key.Ent),
                   Entity_Col  => 0,
-                  File_Num    => Dependency_Num (XE.Lun),
-                  Scope_Num   => Get_Scope_Num (XE.Ref_Scope),
-                  Line        => Int (Get_Logical_Line_Number (XE.Loc)),
-                  Rtype       => XE.Typ,
-                  Col         => Int (Get_Column_Number (XE.Loc))));
+                  File_Num    => Dependency_Num (XE.Key.Lun),
+                  Scope_Num   => Get_Scope_Num (XE.Key.Ref_Scope),
+                  Line        => Int (Get_Logical_Line_Number (XE.Key.Loc)),
+                  Rtype       => XE.Key.Typ,
+                  Col         => Int (Get_Column_Number (XE.Key.Loc))));
 
             else
                Alfa_Xref_Table.Append (
                  (Entity_Name => Cur_Entity_Name,
                   Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
-                  Etype       => Get_Entity_Type (XE.Ent),
+                  Etype       => Get_Entity_Type (XE.Key.Ent),
                   Entity_Col  => Int (Get_Column_Number (XE.Def)),
-                  File_Num    => Dependency_Num (XE.Lun),
-                  Scope_Num   => Get_Scope_Num (XE.Ref_Scope),
-                  Line        => Int (Get_Logical_Line_Number (XE.Loc)),
-                  Rtype       => XE.Typ,
-                  Col         => Int (Get_Column_Number (XE.Loc))));
+                  File_Num    => Dependency_Num (XE.Key.Lun),
+                  Scope_Num   => Get_Scope_Num (XE.Key.Ref_Scope),
+                  Line        => Int (Get_Logical_Line_Number (XE.Key.Loc)),
+                  Rtype       => XE.Key.Typ,
+                  Col         => Int (Get_Column_Number (XE.Key.Loc))));
             end if;
          end Add_One_Xref;
       end loop;
@@ -1071,20 +1078,20 @@ package body Alfa is
 
          --  Entity is filled later on with the special "Heap" variable
 
-         Drefs.Table (Indx).Ent := Empty;
+         Drefs.Table (Indx).Key.Ent := Empty;
 
          Drefs.Table (Indx).Def := No_Location;
-         Drefs.Table (Indx).Loc := Ref;
-         Drefs.Table (Indx).Typ := Typ;
+         Drefs.Table (Indx).Key.Loc := Ref;
+         Drefs.Table (Indx).Key.Typ := Typ;
 
          --  It is as if the special "Heap" was defined in every scope where it
          --  is referenced.
 
-         Drefs.Table (Indx).Eun := Get_Source_Unit (Ref);
-         Drefs.Table (Indx).Lun := Get_Source_Unit (Ref);
+         Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref);
+         Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref);
 
-         Drefs.Table (Indx).Ref_Scope := Ref_Scope;
-         Drefs.Table (Indx).Ent_Scope := Ref_Scope;
+         Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope;
+         Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope;
          Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope);
       end if;
    end Generate_Dereference;
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 4bc7ed437a6..2dbf5ff23d2 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -44,6 +44,7 @@ with Stand;    use Stand;
 with Table;    use Table;
 
 with GNAT.Heap_Sort_G;
+with GNAT.HTable;
 
 package body Lib.Xref is
 
@@ -56,16 +57,13 @@ package body Lib.Xref is
 
    subtype Xref_Entry_Number is Int;
 
-   type Xref_Entry is record
+   type Xref_Key is record
+      --  These are the components of Xref_Entry that participate in hash
+      --  lookups.
+
       Ent : Entity_Id;
       --  Entity referenced (E parameter to Generate_Reference)
 
-      Def : Source_Ptr;
-      --  Original source location for entity being referenced. Note that these
-      --  values are used only during the output process, they are not set when
-      --  the entries are originally built. This is because private entities
-      --  can be swapped when the initial call is made.
-
       Loc : Source_Ptr;
       --  Location of reference (Original_Location (Sloc field of N parameter
       --  to Generate_Reference). Set to No_Location for the case of a
@@ -89,9 +87,22 @@ package body Lib.Xref is
       Ent_Scope : Entity_Id;
       --  Entity of the closest subprogram or package enclosing the definition,
       --  which should be located in the same file as the definition itself.
+   end record;
+
+   type Xref_Entry is record
+      Key : Xref_Key;
 
       Ent_Scope_File : Unit_Number_Type;
       --  File for entity Ent_Scope
+
+      Def : Source_Ptr;
+      --  Original source location for entity being referenced. Note that these
+      --  values are used only during the output process, they are not set when
+      --  the entries are originally built. This is because private entities
+      --  can be swapped when the initial call is made.
+
+      HTable_Next : Xref_Entry_Number;
+      --  For use only by Static_HTable
    end record;
 
    package Xrefs is new Table.Table (
@@ -102,6 +113,44 @@ package body Lib.Xref is
      Table_Increment      => Alloc.Xrefs_Increment,
      Table_Name           => "Xrefs");
 
+   --------------
+   -- Xref_Set --
+   --------------
+
+   --  We keep a set of xref entries, in order to avoid inserting duplicate
+   --  entries into the above Xrefs table. An entry is in Xref_Set if and only
+   --  if it is in Xrefs.
+
+   Num_Buckets : constant := 2**16;
+
+   subtype Header_Num is Integer range 0 .. Num_Buckets - 1;
+   type Null_Type is null record;
+   pragma Unreferenced (Null_Type);
+
+   function Hash (F : Xref_Entry_Number) return Header_Num;
+
+   function Equal (F1, F2 : Xref_Entry_Number) return Boolean;
+
+   procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number);
+
+   function  HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number;
+
+   function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number;
+
+   pragma Inline (Hash, Equal, HT_Set_Next, HT_Next, Get_Key);
+
+   package Xref_Set is new GNAT.HTable.Static_HTable (
+     Header_Num,
+     Element    => Xref_Entry,
+     Elmt_Ptr   => Xref_Entry_Number,
+     Null_Ptr   => 0,
+     Set_Next   => HT_Set_Next,
+     Next       => HT_Next,
+     Key        => Xref_Entry_Number,
+     Get_Key    => Get_Key,
+     Hash       => Hash,
+     Equal      => Equal);
+
    ----------------------
    -- Alfa Information --
    ----------------------
@@ -121,14 +170,51 @@ package body Lib.Xref is
    function Lt (T1, T2 : Xref_Entry) return Boolean;
    --  Order cross-references
 
+   procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type);
+   --  Add an entry to the tables of Xref_Entries, avoiding duplicates
+
+   ---------------
+   -- Add_Entry --
+   ---------------
+
+   procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type) is
+   begin
+      Xrefs.Increment_Last; -- tentative
+      Xrefs.Table (Xrefs.Last).Key := Key;
+
+      --  Set the entry in Xref_Set, and if newly set, keep the above
+      --  tentative increment.
+
+      if Xref_Set.Set_If_Not_Present (Xrefs.Last) then
+         Xrefs.Table (Xrefs.Last).Ent_Scope_File := Ent_Scope_File;
+         --  Leave Def and HTable_Next uninitialized
+
+         Set_Has_Xref_Entry (Key.Ent);
+
+      --  It was already in Xref_Set, so throw away the tentatively-added
+      --  entry
+
+      else
+         Xrefs.Decrement_Last;
+      end if;
+   end Add_Entry;
+
+   -----------
+   -- Equal --
+   -----------
+
+   function Equal (F1, F2 : Xref_Entry_Number) return Boolean is
+      Result : constant Boolean :=
+        Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;
+   begin
+      return Result;
+   end Equal;
+
    -------------------------
    -- Generate_Definition --
    -------------------------
 
    procedure Generate_Definition (E : Entity_Id) is
-      Loc  : Source_Ptr;
-      Indx : Nat;
-
    begin
       pragma Assert (Nkind (E) in N_Entity);
 
@@ -159,22 +245,15 @@ package body Lib.Xref is
          and then In_Extended_Main_Source_Unit (E)
          and then not Is_Internal_Name (Chars (E))
       then
-         Xrefs.Increment_Last;
-         Indx := Xrefs.Last;
-         Loc  := Original_Location (Sloc (E));
-
-         Xrefs.Table (Indx).Ent := E;
-         Xrefs.Table (Indx).Typ := ' ';
-         Xrefs.Table (Indx).Def := No_Location;
-         Xrefs.Table (Indx).Loc := No_Location;
-
-         Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
-
-         Xrefs.Table (Indx).Ref_Scope      := Empty;
-         Xrefs.Table (Indx).Ent_Scope      := Empty;
-         Xrefs.Table (Indx).Ent_Scope_File := No_Unit;
-
-         Set_Has_Xref_Entry (E);
+         Add_Entry
+           ((Ent => E,
+             Loc => No_Location,
+             Typ => ' ',
+             Eun => Get_Source_Unit (Original_Location (Sloc (E))),
+             Lun => No_Unit,
+             Ref_Scope => Empty,
+             Ent_Scope => Empty),
+            Ent_Scope_File => No_Unit);
 
          if In_Inlined_Body then
             Set_Referenced (E);
@@ -294,14 +373,16 @@ package body Lib.Xref is
       Set_Ref : Boolean   := True;
       Force   : Boolean   := False)
    is
-      Indx : Nat;
       Nod  : Node_Id;
       Ref  : Source_Ptr;
       Def  : Source_Ptr;
       Ent  : Entity_Id;
 
-      Ref_Scope     : Entity_Id;
-      Ent_Scope     : Entity_Id;
+      Actual_Typ  : Character := Typ;
+
+      Ref_Scope      : Entity_Id;
+      Ent_Scope      : Entity_Id;
+      Ent_Scope_File : Unit_Number_Type;
 
       Call   : Node_Id;
       Formal : Entity_Id;
@@ -865,34 +946,33 @@ package body Lib.Xref is
          Ref := Original_Location (Sloc (Nod));
          Def := Original_Location (Sloc (Ent));
 
-         Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N);
-         Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent);
-
-         Xrefs.Increment_Last;
-         Indx := Xrefs.Last;
-
-         Xrefs.Table (Indx).Loc := Ref;
-
-         --  Overriding operations are marked with 'P'
-
-         if Typ = 'p'
+         if Actual_Typ = 'p'
            and then Is_Subprogram (N)
            and then Present (Overridden_Operation (N))
          then
-            Xrefs.Table (Indx).Typ := 'P';
-         else
-            Xrefs.Table (Indx).Typ := Typ;
+            Actual_Typ := 'P';
          end if;
 
-         Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
-         Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
-         Xrefs.Table (Indx).Ent := Ent;
+         if Alfa_Mode then
+            Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N);
+            Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent);
+            Ent_Scope_File := Get_Source_Unit (Ent_Scope);
 
-         Xrefs.Table (Indx).Ref_Scope      := Ref_Scope;
-         Xrefs.Table (Indx).Ent_Scope      := Ent_Scope;
-         Xrefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ent_Scope);
+         else
+            Ref_Scope := Empty;
+            Ent_Scope := Empty;
+            Ent_Scope_File := No_Unit;
+         end if;
 
-         Set_Has_Xref_Entry (Ent);
+         Add_Entry
+           ((Ent => Ent,
+             Loc => Ref,
+             Typ => Actual_Typ,
+             Eun => Get_Source_Unit (Def),
+             Lun => Get_Source_Unit (Ref),
+             Ref_Scope => Ref_Scope,
+             Ent_Scope => Ent_Scope),
+            Ent_Scope_File => Ent_Scope_File);
       end if;
    end Generate_Reference;
 
@@ -957,6 +1037,49 @@ package body Lib.Xref is
       end loop;
    end Generate_Reference_To_Generic_Formals;
 
+   -------------
+   -- Get_Key --
+   -------------
+
+   function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number is
+   begin
+      return E;
+   end Get_Key;
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash (F : Xref_Entry_Number) return Header_Num is
+      --  It is unlikely to have two references to the same entity at the same
+      --  source location, so the hash function depends only on the Ent and Loc
+      --  fields.
+
+      XE : Xref_Entry renames Xrefs.Table (F);
+      type M is mod 2**32;
+      H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc);
+   begin
+      return Header_Num (H mod Num_Buckets);
+   end Hash;
+
+   -----------------
+   -- HT_Set_Next --
+   -----------------
+
+   procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number) is
+   begin
+      Xrefs.Table (E).HTable_Next := Next;
+   end HT_Set_Next;
+
+   -------------
+   -- HT_Next --
+   -------------
+
+   function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number is
+   begin
+      return Xrefs.Table (E).HTable_Next;
+   end HT_Next;
+
    ----------------
    -- Initialize --
    ----------------
@@ -974,8 +1097,8 @@ package body Lib.Xref is
    begin
       --  First test: if entity is in different unit, sort by unit
 
-      if T1.Eun /= T2.Eun then
-         return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
+      if T1.Key.Eun /= T2.Key.Eun then
+         return Dependency_Num (T1.Key.Eun) < Dependency_Num (T2.Key.Eun);
 
       --  Second test: within same unit, sort by entity Sloc
 
@@ -984,21 +1107,21 @@ package body Lib.Xref is
 
       --  Third test: sort definitions ahead of references
 
-      elsif T1.Loc = No_Location then
+      elsif T1.Key.Loc = No_Location then
          return True;
 
-      elsif T2.Loc = No_Location then
+      elsif T2.Key.Loc = No_Location then
          return False;
 
       --  Fourth test: for same entity, sort by reference location unit
 
-      elsif T1.Lun /= T2.Lun then
-         return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
+      elsif T1.Key.Lun /= T2.Key.Lun then
+         return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun);
 
       --  Fifth test: order of location within referencing unit
 
-      elsif T1.Loc /= T2.Loc then
-         return T1.Loc < T2.Loc;
+      elsif T1.Key.Loc /= T2.Key.Loc then
+         return T1.Key.Loc < T2.Key.Loc;
 
       --  Finally, for two locations at the same address, we prefer
       --  the one that does NOT have the type 'r' so that a modification
@@ -1008,7 +1131,7 @@ package body Lib.Xref is
       --  the modify reference.
 
       else
-         return T2.Typ = 'r';
+         return T2.Key.Typ = 'r';
       end if;
    end Lt;
 
@@ -1245,7 +1368,7 @@ package body Lib.Xref is
 
       begin
          for J in 1 .. Xrefs.Last loop
-            Ent := Xrefs.Table (J).Ent;
+            Ent := Xrefs.Table (J).Key.Ent;
 
             if Is_Type (Ent)
               and then Is_Tagged_Type (Ent)
@@ -1283,9 +1406,7 @@ package body Lib.Xref is
       Handle_Orphan_Type_References : declare
          J    : Nat;
          Tref : Entity_Id;
-         Indx : Nat;
          Ent  : Entity_Id;
-         Loc  : Source_Ptr;
 
          L, R : Character;
          pragma Warnings (Off, L);
@@ -1302,18 +1423,20 @@ package body Lib.Xref is
 
          procedure New_Entry (E : Entity_Id) is
          begin
-            if Present (E)
-              and then not Has_Xref_Entry (E)
+            pragma Assert (Present (E));
+
+            if not Has_Xref_Entry (Implementation_Base_Type (E))
               and then Sloc (E) > No_Location
             then
-               Xrefs.Increment_Last;
-               Indx := Xrefs.Last;
-               Loc  := Original_Location (Sloc (E));
-               Xrefs.Table (Indx).Ent := E;
-               Xrefs.Table (Indx).Loc := No_Location;
-               Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
-               Xrefs.Table (Indx).Lun := No_Unit;
-               Set_Has_Xref_Entry (E);
+               Add_Entry
+                 ((Ent => E,
+                   Loc => No_Location,
+                   Typ => Character'First,
+                   Eun => Get_Source_Unit (Original_Location (Sloc (E))),
+                   Lun => No_Unit,
+                   Ref_Scope => Empty,
+                   Ent_Scope => Empty),
+                  Ent_Scope_File => No_Unit);
             end if;
          end New_Entry;
 
@@ -1326,7 +1449,7 @@ package body Lib.Xref is
 
          J := 1;
          while J <= Xrefs.Last loop
-            Ent := Xrefs.Table (J).Ent;
+            Ent := Xrefs.Table (J).Key.Ent;
             Get_Type_Reference (Ent, Tref, L, R);
 
             if Present (Tref)
@@ -1393,15 +1516,15 @@ package body Lib.Xref is
                      Prim := Parent_Op (Node (Op));
 
                      if Present (Prim) then
-                        Xrefs.Increment_Last;
-                        Indx := Xrefs.Last;
-                        Loc  := Original_Location (Sloc (Prim));
-                        Xrefs.Table (Indx).Ent := Prim;
-                        Xrefs.Table (Indx).Loc := No_Location;
-                        Xrefs.Table (Indx).Eun :=
-                          Get_Source_Unit (Sloc (Prim));
-                        Xrefs.Table (Indx).Lun := No_Unit;
-                        Set_Has_Xref_Entry (Prim);
+                        Add_Entry
+                          ((Ent => Prim,
+                            Loc => No_Location,
+                            Typ => Character'First,
+                            Eun => Get_Source_Unit (Sloc (Prim)),
+                            Lun => No_Unit,
+                            Ref_Scope => Empty,
+                            Ent_Scope => Empty),
+                           Ent_Scope_File => No_Unit);
                      end if;
 
                      Next_Elmt (Op);
@@ -1418,9 +1541,8 @@ package body Lib.Xref is
 
       Output_Refs : declare
 
-         Nrefs : Nat := Xrefs.Last;
-         --  Number of references in table. This value may get reset (reduced)
-         --  when we eliminate duplicate reference entries.
+         Nrefs : constant Nat := Xrefs.Last;
+         --  Number of references in table
 
          Rnums : array (0 .. Nrefs) of Nat;
          --  This array contains numbers of references in the Xrefs table.
@@ -1523,37 +1645,13 @@ package body Lib.Xref is
          for J in 1 .. Nrefs loop
             Rnums (J) := J;
             Xrefs.Table (J).Def :=
-              Original_Location (Sloc (Xrefs.Table (J).Ent));
+              Original_Location (Sloc (Xrefs.Table (J).Key.Ent));
          end loop;
 
          --  Sort the references
 
          Sorting.Sort (Integer (Nrefs));
 
-         --  Eliminate duplicate entries
-
-         declare
-            NR : constant Nat := Nrefs;
-
-         begin
-            --  We need this test for NR because if we force ALI file
-            --  generation in case of errors detected, it may be the case
-            --  that Nrefs is 0, so we should not reset it here
-
-            if NR >= 2 then
-               Nrefs := 1;
-
-               for J in 2 .. NR loop
-                  if Xrefs.Table (Rnums (J)) /=
-                     Xrefs.Table (Rnums (Nrefs))
-                  then
-                     Nrefs := Nrefs + 1;
-                     Rnums (Nrefs) := Rnums (J);
-                  end if;
-               end loop;
-            end if;
-         end;
-
          --  Initialize loop through references
 
          Curxu  := No_Unit;
@@ -1773,7 +1871,7 @@ package body Lib.Xref is
             --  Start of processing for Output_One_Ref
 
             begin
-               Ent := XE.Ent;
+               Ent := XE.Key.Ent;
                Ctyp := Xref_Entity_Letters (Ekind (Ent));
 
                --  Skip reference if it is the only reference to an entity,
@@ -1782,10 +1880,10 @@ package body Lib.Xref is
                --  consisting only of packages with END lines, where no
                --  entity from the package is actually referenced.
 
-               if XE.Typ = 'e'
+               if XE.Key.Typ = 'e'
                  and then Ent /= Curent
                  and then (Refno = Nrefs or else
-                             Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
+                             Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
                  and then
                    not In_Extended_Main_Source_Unit (Ent)
                then
@@ -1795,7 +1893,7 @@ package body Lib.Xref is
                --  For private type, get full view type
 
                if Ctyp = '+'
-                 and then Present (Full_View (XE.Ent))
+                 and then Present (Full_View (XE.Key.Ent))
                then
                   Ent := Underlying_Type (Ent);
 
@@ -1813,15 +1911,15 @@ package body Lib.Xref is
                --  For variable reference, get corresponding type
 
                if Ctyp = '*' then
-                  Ent := Etype (XE.Ent);
+                  Ent := Etype (XE.Key.Ent);
                   Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
 
                   --  If variable is private type, get full view type
 
                   if Ctyp = '+'
-                    and then Present (Full_View (Etype (XE.Ent)))
+                    and then Present (Full_View (Etype (XE.Key.Ent)))
                   then
-                     Ent := Underlying_Type (Etype (XE.Ent));
+                     Ent := Underlying_Type (Etype (XE.Key.Ent));
 
                      if Present (Ent) then
                         Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
@@ -1839,13 +1937,13 @@ package body Lib.Xref is
                   --  Special handling for access parameters and objects of
                   --  an anonymous access type.
 
-                  if Ekind_In (Etype (XE.Ent),
+                  if Ekind_In (Etype (XE.Key.Ent),
                                E_Anonymous_Access_Type,
                                E_Anonymous_Access_Subprogram_Type,
                                E_Anonymous_Access_Protected_Subprogram_Type)
                   then
-                     if Is_Formal (XE.Ent)
-                       or else Ekind_In (XE.Ent, E_Variable, E_Constant)
+                     if Is_Formal (XE.Key.Ent)
+                       or else Ekind_In (XE.Key.Ent, E_Variable, E_Constant)
                      then
                         Ctyp := 'p';
                      end if;
@@ -1859,8 +1957,8 @@ package body Lib.Xref is
 
                --  Special handling for abstract types and operations
 
-               if Is_Overloadable (XE.Ent)
-                 and then Is_Abstract_Subprogram (XE.Ent)
+               if Is_Overloadable (XE.Key.Ent)
+                 and then Is_Abstract_Subprogram (XE.Key.Ent)
                then
                   if Ctyp = 'U' then
                      Ctyp := 'x';            --  Abstract procedure
@@ -1869,10 +1967,10 @@ package body Lib.Xref is
                      Ctyp := 'y';            --  Abstract function
                   end if;
 
-               elsif Is_Type (XE.Ent)
-                 and then Is_Abstract_Type (XE.Ent)
+               elsif Is_Type (XE.Key.Ent)
+                 and then Is_Abstract_Type (XE.Key.Ent)
                then
-                  if Is_Interface (XE.Ent) then
+                  if Is_Interface (XE.Key.Ent) then
                      Ctyp := 'h';
 
                   elsif Ctyp = 'R' then
@@ -1887,41 +1985,42 @@ package body Lib.Xref is
                --  Suppress references to object definitions, used for local
                --  references.
 
-                 or else XE.Typ = 'D'
-                 or else XE.Typ = 'I'
+                 or else XE.Key.Typ = 'D'
+                 or else XE.Key.Typ = 'I'
 
                --  Suppress self references, except for bodies that act as
                --  specs.
 
-                 or else (XE.Loc = XE.Def
+                 or else (XE.Key.Loc = XE.Def
                            and then
-                             (XE.Typ /= 'b'
-                               or else not Is_Subprogram (XE.Ent)))
+                             (XE.Key.Typ /= 'b'
+                               or else not Is_Subprogram (XE.Key.Ent)))
 
                --  Also suppress definitions of body formals (we only
                --  treat these as references, and the references were
                --  separately recorded).
 
-                 or else (Is_Formal (XE.Ent)
-                           and then Present (Spec_Entity (XE.Ent)))
+                 or else (Is_Formal (XE.Key.Ent)
+                           and then Present (Spec_Entity (XE.Key.Ent)))
                then
                   null;
 
                else
                   --  Start new Xref section if new xref unit
 
-                  if XE.Eun /= Curxu then
+                  if XE.Key.Eun /= Curxu then
                      if Write_Info_Col > 1 then
                         Write_Info_EOL;
                      end if;
 
-                     Curxu := XE.Eun;
+                     Curxu := XE.Key.Eun;
 
                      Write_Info_Initiate ('X');
                      Write_Info_Char (' ');
-                     Write_Info_Nat (Dependency_Num (XE.Eun));
+                     Write_Info_Nat (Dependency_Num (XE.Key.Eun));
                      Write_Info_Char (' ');
-                     Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
+                     Write_Info_Name
+                       (Reference_Name (Source_Index (XE.Key.Eun)));
                   end if;
 
                   --  Start new Entity line if new entity. Note that we
@@ -1932,14 +2031,14 @@ package body Lib.Xref is
 
                   if No (Curent)
                     or else
-                      (XE.Ent /= Curent
+                      (XE.Key.Ent /= Curent
                          and then
-                           (Name_Change (XE.Ent) or else XE.Def /= Curdef))
+                           (Name_Change (XE.Key.Ent) or else XE.Def /= Curdef))
                   then
-                     Curent := XE.Ent;
+                     Curent := XE.Key.Ent;
                      Curdef := XE.Def;
 
-                     Get_Unqualified_Name_String (Chars (XE.Ent));
+                     Get_Unqualified_Name_String (Chars (XE.Key.Ent));
                      Curlen := Name_Len;
                      Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
 
@@ -2051,7 +2150,7 @@ package body Lib.Xref is
 
                      declare
                         Ent_Name : constant String :=
-                                     Exact_Source_Name (Sloc (XE.Ent));
+                                     Exact_Source_Name (Sloc (XE.Key.Ent));
                      begin
                         for C in Ent_Name'Range loop
                            Write_Info_Char (Ent_Name (C));
@@ -2060,22 +2159,22 @@ package body Lib.Xref is
 
                      --  See if we have a renaming reference
 
-                     if Is_Object (XE.Ent)
-                       and then Present (Renamed_Object (XE.Ent))
+                     if Is_Object (XE.Key.Ent)
+                       and then Present (Renamed_Object (XE.Key.Ent))
                      then
-                        Rref := Renamed_Object (XE.Ent);
+                        Rref := Renamed_Object (XE.Key.Ent);
 
-                     elsif Is_Overloadable (XE.Ent)
-                       and then Nkind (Parent (Declaration_Node (XE.Ent))) =
-                                            N_Subprogram_Renaming_Declaration
+                     elsif Is_Overloadable (XE.Key.Ent)
+                       and then Nkind (Parent (Declaration_Node (XE.Key.Ent)))
+                                           = N_Subprogram_Renaming_Declaration
                      then
-                        Rref := Name (Parent (Declaration_Node (XE.Ent)));
+                        Rref := Name (Parent (Declaration_Node (XE.Key.Ent)));
 
-                     elsif Ekind (XE.Ent) = E_Package
-                       and then Nkind (Declaration_Node (XE.Ent)) =
+                     elsif Ekind (XE.Key.Ent) = E_Package
+                       and then Nkind (Declaration_Node (XE.Key.Ent)) =
                                          N_Package_Renaming_Declaration
                      then
-                        Rref := Name (Declaration_Node (XE.Ent));
+                        Rref := Name (Declaration_Node (XE.Key.Ent));
 
                      else
                         Rref := Empty;
@@ -2128,12 +2227,13 @@ package body Lib.Xref is
                      --  Write out information about generic parent, if entity
                      --  is an instance.
 
-                     if  Is_Generic_Instance (XE.Ent) then
+                     if  Is_Generic_Instance (XE.Key.Ent) then
                         declare
                            Gen_Par : constant Entity_Id :=
                                        Generic_Parent
                                          (Specification
-                                            (Unit_Declaration_Node (XE.Ent)));
+                                            (Unit_Declaration_Node
+                                               (XE.Key.Ent)));
                            Loc     : constant Source_Ptr := Sloc (Gen_Par);
                            Gen_U   : constant Unit_Number_Type :=
                                        Get_Source_Unit (Loc);
@@ -2154,15 +2254,16 @@ package body Lib.Xref is
 
                      --  See if we have a type reference and if so output
 
-                     Check_Type_Reference (XE.Ent, False);
+                     Check_Type_Reference (XE.Key.Ent, False);
 
                      --  Additional information for types with progenitors
 
-                     if Is_Record_Type (XE.Ent)
-                       and then Present (Interfaces (XE.Ent))
+                     if Is_Record_Type (XE.Key.Ent)
+                       and then Present (Interfaces (XE.Key.Ent))
                      then
                         declare
-                           Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
+                           Elmt : Elmt_Id :=
+                                    First_Elmt (Interfaces (XE.Key.Ent));
                         begin
                            while Present (Elmt) loop
                               Check_Type_Reference (Node (Elmt), True);
@@ -2173,11 +2274,11 @@ package body Lib.Xref is
                      --  For array types, list index types as well. (This is
                      --  not C, indexes have distinct types).
 
-                     elsif Is_Array_Type (XE.Ent) then
+                     elsif Is_Array_Type (XE.Key.Ent) then
                         declare
                            Indx : Node_Id;
                         begin
-                           Indx := First_Index (XE.Ent);
+                           Indx := First_Index (XE.Key.Ent);
                            while Present (Indx) loop
                               Check_Type_Reference
                                 (First_Subtype (Etype (Indx)), True);
@@ -2189,10 +2290,11 @@ package body Lib.Xref is
                      --  If the entity is an overriding operation, write info
                      --  on operation that was overridden.
 
-                     if Is_Subprogram (XE.Ent)
-                       and then Present (Overridden_Operation (XE.Ent))
+                     if Is_Subprogram (XE.Key.Ent)
+                       and then Present (Overridden_Operation (XE.Key.Ent))
                      then
-                        Output_Overridden_Op (Overridden_Operation (XE.Ent));
+                        Output_Overridden_Op
+                          (Overridden_Operation (XE.Key.Ent));
                      end if;
 
                      --  End of processing for entity output
@@ -2204,13 +2306,13 @@ package body Lib.Xref is
                   --  as the previous one, or it is a read-reference that
                   --  indicates that the entity is an in-out actual in a call.
 
-                  if XE.Loc /= No_Location
+                  if XE.Key.Loc /= No_Location
                     and then
-                      (XE.Loc /= Crloc
-                        or else (Prevt = 'm' and then  XE.Typ = 'r'))
+                      (XE.Key.Loc /= Crloc
+                        or else (Prevt = 'm' and then  XE.Key.Typ = 'r'))
                   then
-                     Crloc := XE.Loc;
-                     Prevt := XE.Typ;
+                     Crloc := XE.Key.Loc;
+                     Prevt := XE.Key.Typ;
 
                      --  Start continuation if line full, else blank
 
@@ -2223,25 +2325,26 @@ package body Lib.Xref is
 
                      --  Output file number if changed
 
-                     if XE.Lun /= Curru then
-                        Curru := XE.Lun;
+                     if XE.Key.Lun /= Curru then
+                        Curru := XE.Key.Lun;
                         Write_Info_Nat (Dependency_Num (Curru));
                         Write_Info_Char ('|');
                      end if;
 
-                     Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Loc)));
-                     Write_Info_Char (XE.Typ);
+                     Write_Info_Nat
+                       (Int (Get_Logical_Line_Number (XE.Key.Loc)));
+                     Write_Info_Char (XE.Key.Typ);
 
-                     if Is_Overloadable (XE.Ent)
-                       and then Is_Imported (XE.Ent)
-                       and then XE.Typ = 'b'
+                     if Is_Overloadable (XE.Key.Ent)
+                       and then Is_Imported (XE.Key.Ent)
+                       and then XE.Key.Typ = 'b'
                      then
-                        Output_Import_Export_Info (XE.Ent);
+                        Output_Import_Export_Info (XE.Key.Ent);
                      end if;
 
-                     Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
+                     Write_Info_Nat (Int (Get_Column_Number (XE.Key.Loc)));
 
-                     Output_Instantiation_Refs (Sloc (XE.Ent));
+                     Output_Instantiation_Refs (Sloc (XE.Key.Ent));
                   end if;
                end if;
             end Output_One_Ref;
@@ -2254,4 +2357,9 @@ package body Lib.Xref is
       end Output_Refs;
    end Output_References;
 
+begin
+   --  Reset is necessary because Elmt_Ptr does not default to Null_Ptr,
+   --  because it's not an access type.
+
+   Xref_Set.Reset;
 end Lib.Xref;
diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb
index 898081c1f26..68a4ac30d04 100644
--- a/gcc/ada/s-htable.adb
+++ b/gcc/ada/s-htable.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                    Copyright (C) 1995-2010, AdaCore                      --
+--                    Copyright (C) 1995-2011, AdaCore                      --
 --                                                                          --
 -- 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- --
@@ -121,6 +121,15 @@ package body System.HTable is
          return Iterator_Ptr;
       end Get_Non_Null;
 
+      -------------
+      -- Present --
+      -------------
+
+      function Present (K : Key) return Boolean is
+      begin
+         return Get (K) /= Null_Ptr;
+      end Present;
+
       ------------
       -- Remove --
       ------------
@@ -181,6 +190,32 @@ package body System.HTable is
          Table (Index) := E;
       end Set;
 
+      ------------------------
+      -- Set_If_Not_Present --
+      ------------------------
+
+      function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
+         K     : constant Key := Get_Key (E);
+         Index : constant Header_Num := Hash (K);
+         Elmt  : Elmt_Ptr := Table (Index);
+
+      begin
+         loop
+            if Elmt = Null_Ptr then
+               Set_Next (E, Table (Index));
+               Table (Index) := E;
+
+               return True;
+
+            elsif Equal (Get_Key (Elmt), K) then
+               return False;
+
+            else
+               Elmt := Next (Elmt);
+            end if;
+         end loop;
+      end Set_If_Not_Present;
+
    end Static_HTable;
 
    -------------------
diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads
index 58def27b1b4..29fb5fbd163 100644
--- a/gcc/ada/s-htable.ads
+++ b/gcc/ada/s-htable.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                     Copyright (C) 1995-2010, AdaCore                     --
+--                     Copyright (C) 1995-2011, AdaCore                     --
 --                                                                          --
 -- 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- --
@@ -183,6 +183,14 @@ package System.HTable is
       --  Returns the latest inserted element pointer with the given Key
       --  or null if none.
 
+      function Present (K : Key) return Boolean;
+      --  True if an element whose Get_Key is K is in the table
+
+      function Set_If_Not_Present (E : Elmt_Ptr) return Boolean;
+      --  If Present (Get_Key (E)), returns False. Otherwise, does Set (E), and
+      --  then returns True. Present (Get_Key (E)) is always True afterward,
+      --  and the result True indicates E is newly Set.
+
       procedure Remove (K : Key);
       --  Removes the latest inserted element pointer associated with the
       --  given key if any, does nothing if none.
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index e5299b2211c..3f049643287 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -490,8 +490,14 @@ package body Sem_Ch4 is
 
          Resolve (Expression (E), Type_Id);
 
+         --  Allocators generated by the build-in-place expansion mechanism
+         --  are explicitly marked as coming from source but do not need to be
+         --  checked for limited initialization. To exclude this case, ensure
+         --  that the parent of the allocator is a source node.
+
          if Is_Limited_Type (Type_Id)
            and then Comes_From_Source (N)
+           and then Comes_From_Source (Parent (N))
            and then not In_Instance_Body
          then
             if not OK_For_Limited_Init (Type_Id, Expression (E)) then