[multiple changes]

2011-08-03  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat_ugn.texi: Document -Wstack-usage.
	* gcc-interface/misc.c (enumerate_modes): Add guard for ghost FP modes.

2011-08-03  Thomas Quinot  <quinot@adacore.com>

	* sem_prag.adb Issue an error (not a warning) when a C++ type does not
	have keyword LIMITED.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* alfa.adb, alfa.ads, alfa_test.adb: New files.
	* ali.adb (Known_ALI_Lines): add 'C' lines (SCO) and 'F' lines (ALFA)
	(Scan_ALI): do not issue a fatal error if parsing known lines after Xref
	section (does not happen in compiler, only if code directly calls
	Scan_ALI).
	* get_alfa.adb, get_alfa.ads: New files.
	* lib-writ.adb, lib-writ.ads (Write_ALI): output ALFA information if
	needed.
	* lib-xref-alfa.adb: New file.
	* lib-xref.adb, lib-xref.ads
	(Xref_Entry): redefine information needed in cross-references for ALFA.
	Push ALFA treatments in separated local package.
	(Enclosing_Subpragram_Or_Package): treat specially subprogram
	identifiers. Return entity of package body instead of spec. Return
	Empty for a scope with no location.
	(Generate_Reference): adapt to new components for ALFA information.
	Remove the need for D references on definitions.
	(Is_Local_Reference): moved to ALFA local package
	(Output_References): extract subfunction as Extract_Source_Name
	(Output_Local_References): remove procedure, replaced by filtering of
	cross-references in package ALFA and printing in Put_ALFA.
	(Write_Entity_Name): remove procedure
	* lib.adb, lib.ads (Extract_Source_Name): extract here function to
	print exact name of entity as it appears in source file
	(Unit_Ref_Table): make type public for use in Lib.Xref.ALFA
	* put_alfa.adb, put_alfa.ads: New files.
	* xref_lib.adb (Search_Xref): protect read of cross-references against
	reading other sections of the ALI file, in gnatxref
	(Search): protect read of cross-references against reading other
	sections of the ALI file, in gnatfind.
	* gcc-interface/Make-lang.in: Update dependencies.

2011-08-03  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb: Minor reformatting.

2011-08-03  Jose Ruiz  <ruiz@adacore.com>

	* s-inmaop-vxworks.adb (Setup_Interrupt_Mask): Do nothing instead of
	raising an exception.

2011-08-03  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Set_String_Literal_Subtype): if index type is an integer
	type, always use 1 as the lower bound or string, even if lower bound of
	context is not static, to handle properly null strings in a non-static
	context.

2011-08-03  Bob Duff  <duff@adacore.com>

	* sem_prag.adb (Resolve_Aggregate): An array aggregate with 'others' is
	always legal on the right-hand side of an assignment statement; there
	is always an applicable index constraint in this case. Therefore, the
	check for Pkind = N_Assignment_Statement is now unconditional -- it
	doesn't depend on whether Is_Constrained (Typ).

From-SVN: r177239

1 files changed, 938 insertions, 0 deletions

diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb
new file mode 100644
index 0000000..a5dca53
--- /dev/null
+++ b/gcc/ada/lib-xref-alfa.adb
@@ -0,0 +1,938 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                        L I B . X R E F . A L F A                         --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--             Copyright (C) 2011, 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- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license.          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with ALFA;        use ALFA;
+with Einfo;       use Einfo;
+with Put_ALFA;
+with GNAT.HTable;
+
+separate (Lib.Xref)
+package body ALFA is
+
+   ---------------------
+   -- Local Constants --
+   ---------------------
+
+   --  True for each entity kind used in ALFA
+   ALFA_Entities : constant array (Entity_Kind) of Boolean :=
+     (E_Void                                       => False,
+      E_Variable                                   => True,
+      E_Component                                  => False,
+      E_Constant                                   => True,
+      E_Discriminant                               => False,
+
+      E_Loop_Parameter                             => True,
+      E_In_Parameter                               => True,
+      E_Out_Parameter                              => True,
+      E_In_Out_Parameter                           => True,
+      E_Generic_In_Out_Parameter                   => False,
+
+      E_Generic_In_Parameter                       => False,
+      E_Named_Integer                              => False,
+      E_Named_Real                                 => False,
+      E_Enumeration_Type                           => False,
+      E_Enumeration_Subtype                        => False,
+
+      E_Signed_Integer_Type                        => False,
+      E_Signed_Integer_Subtype                     => False,
+      E_Modular_Integer_Type                       => False,
+      E_Modular_Integer_Subtype                    => False,
+      E_Ordinary_Fixed_Point_Type                  => False,
+
+      E_Ordinary_Fixed_Point_Subtype               => False,
+      E_Decimal_Fixed_Point_Type                   => False,
+      E_Decimal_Fixed_Point_Subtype                => False,
+      E_Floating_Point_Type                        => False,
+      E_Floating_Point_Subtype                     => False,
+
+      E_Access_Type                                => False,
+      E_Access_Subtype                             => False,
+      E_Access_Attribute_Type                      => False,
+      E_Allocator_Type                             => False,
+      E_General_Access_Type                        => False,
+
+      E_Access_Subprogram_Type                     => False,
+      E_Access_Protected_Subprogram_Type           => False,
+      E_Anonymous_Access_Subprogram_Type           => False,
+      E_Anonymous_Access_Protected_Subprogram_Type => False,
+      E_Anonymous_Access_Type                      => False,
+
+      E_Array_Type                                 => False,
+      E_Array_Subtype                              => False,
+      E_String_Type                                => False,
+      E_String_Subtype                             => False,
+      E_String_Literal_Subtype                     => False,
+
+      E_Class_Wide_Type                            => False,
+      E_Class_Wide_Subtype                         => False,
+      E_Record_Type                                => False,
+      E_Record_Subtype                             => False,
+      E_Record_Type_With_Private                   => False,
+
+      E_Record_Subtype_With_Private                => False,
+      E_Private_Type                               => False,
+      E_Private_Subtype                            => False,
+      E_Limited_Private_Type                       => False,
+      E_Limited_Private_Subtype                    => False,
+
+      E_Incomplete_Type                            => False,
+      E_Incomplete_Subtype                         => False,
+      E_Task_Type                                  => False,
+      E_Task_Subtype                               => False,
+      E_Protected_Type                             => False,
+
+      E_Protected_Subtype                          => False,
+      E_Exception_Type                             => False,
+      E_Subprogram_Type                            => False,
+      E_Enumeration_Literal                        => False,
+      E_Function                                   => True,
+
+      E_Operator                                   => True,
+      E_Procedure                                  => True,
+      E_Entry                                      => False,
+      E_Entry_Family                               => False,
+      E_Block                                      => False,
+
+      E_Entry_Index_Parameter                      => False,
+      E_Exception                                  => False,
+      E_Generic_Function                           => False,
+      E_Generic_Package                            => False,
+      E_Generic_Procedure                          => False,
+
+      E_Label                                      => False,
+      E_Loop                                       => False,
+      E_Return_Statement                           => False,
+      E_Package                                    => False,
+
+      E_Package_Body                               => False,
+      E_Protected_Object                           => False,
+      E_Protected_Body                             => False,
+      E_Task_Body                                  => False,
+      E_Subprogram_Body                            => False);
+
+   --  True for each reference type used in ALFA
+   ALFA_References : constant array (Character) of Boolean :=
+     ('m' => True,
+      'r' => True,
+      's' => True,
+      others => False);
+
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Add_ALFA_File (U : Unit_Number_Type; D : Nat);
+   --  Add file U and all scopes in U to the tables ALFA_File_Table and
+   --  ALFA_Scope_Table.
+
+   procedure Add_ALFA_Scope (N : Node_Id);
+   --  Add scope N to the table ALFA_Scope_Table
+
+   procedure Add_ALFA_Xrefs;
+   --  Filter table Xrefs to add all references used in ALFA to the table
+   --  ALFA_Xref_Table.
+
+   procedure Traverse_Declarations_Or_Statements  (L : List_Id);
+   procedure Traverse_Handled_Statement_Sequence  (N : Node_Id);
+   procedure Traverse_Package_Body                (N : Node_Id);
+   procedure Traverse_Package_Declaration         (N : Node_Id);
+   procedure Traverse_Subprogram_Body             (N : Node_Id);
+   --  Traverse the corresponding construct, generating ALFA scope table
+   --  entries.
+
+   -------------------
+   -- Add_ALFA_File --
+   -------------------
+
+   procedure Add_ALFA_File (U : Unit_Number_Type; D : Nat) is
+      Lu   : Node_Id;
+      From : Scope_Index;
+
+      S : constant Source_File_Index := Source_Index (U);
+   begin
+      --  Source file could be inexistant as a result of an error, if option
+      --  gnatQ is used.
+
+      if S = No_Source_File then
+         return;
+      end if;
+
+      From := ALFA_Scope_Table.Last + 1;
+
+      --  Get Unit (checking case of subunit)
+
+      Lu := Unit (Cunit (U));
+
+      if Nkind (Lu) = N_Subunit then
+         Lu := Proper_Body (Lu);
+      end if;
+
+      --  Traverse the unit
+
+      if Nkind (Lu) = N_Subprogram_Body then
+         Traverse_Subprogram_Body (Lu);
+
+      elsif Nkind (Lu) = N_Subprogram_Declaration then
+         Add_ALFA_Scope (Lu);
+
+      elsif Nkind (Lu) = N_Package_Declaration then
+         Traverse_Package_Declaration (Lu);
+
+      elsif Nkind (Lu) = N_Package_Body then
+         Traverse_Package_Body (Lu);
+
+      --  ??? TBD
+
+      elsif Nkind (Lu) = N_Generic_Package_Declaration then
+         null;
+
+      --  ??? TBD
+
+      elsif Nkind (Lu) in N_Generic_Instantiation then
+         null;
+
+      --  All other cases of compilation units (e.g. renamings), generate
+      --  no ALFA information.
+
+      else
+         null;
+      end if;
+
+      --  Update scope numbers
+
+      for S in From .. ALFA_Scope_Table.Last loop
+         declare
+            E : Entity_Id renames ALFA_Scope_Table.Table (S).Scope_Entity;
+         begin
+            if Lib.Get_Source_Unit (E) = U then
+               ALFA_Scope_Table.Table (S).Scope_Num := Int (S - From) + 1;
+               ALFA_Scope_Table.Table (S).File_Num  := D;
+
+            else
+               --  Remove scope S which is not located in unit U, for example
+               --  for scope inside generics that get instantiated.
+
+               for J in S .. ALFA_Scope_Table.Last - 1 loop
+                  ALFA_Scope_Table.Table (J) := ALFA_Scope_Table.Table (J + 1);
+               end loop;
+               ALFA_Scope_Table.Set_Last (ALFA_Scope_Table.Last - 1);
+            end if;
+         end;
+      end loop;
+
+      --  Make entry for new file in file table
+
+      Get_Name_String (Reference_Name (S));
+
+      ALFA_File_Table.Append (
+        (File_Name  => new String'(Name_Buffer (1 .. Name_Len)),
+         File_Num   => D,
+         From_Scope => From,
+         To_Scope   => ALFA_Scope_Table.Last));
+   end Add_ALFA_File;
+
+   --------------------
+   -- Add_ALFA_Scope --
+   --------------------
+
+   procedure Add_ALFA_Scope (N : Node_Id) is
+      E   : constant Entity_Id  := Defining_Entity (N);
+      Loc : constant Source_Ptr := Sloc (E);
+      Typ : Character;
+
+   begin
+      --  Ignore scopes without a proper location
+
+      if Sloc (N) = No_Location then
+         return;
+      end if;
+
+      case Ekind (E) is
+         when E_Function =>
+            Typ := 'V';
+
+         when E_Procedure =>
+            Typ := 'U';
+
+         when E_Subprogram_Body =>
+            declare
+               Spec : Node_Id;
+
+            begin
+               Spec := Parent (E);
+
+               if Nkind (Spec) = N_Defining_Program_Unit_Name then
+                  Spec := Parent (Spec);
+               end if;
+
+               if Nkind (Spec) = N_Function_Specification then
+                  Typ := 'V';
+               else
+                  pragma Assert
+                    (Nkind (Spec) = N_Procedure_Specification);
+                  Typ := 'U';
+               end if;
+            end;
+
+         when E_Package | E_Package_Body =>
+            Typ := 'K';
+
+         when E_Void =>
+            --  Compilation of prj-attr.adb with -gnatn creates a node with
+            --  entity E_Void for the package defined at a-charac.ads16:13
+
+            --  ??? TBD
+
+            return;
+
+         when others =>
+            raise Program_Error;
+      end case;
+
+      --  File_Num and Scope_Num are filled later. From_Xref and To_Xref are
+      --  filled even later, but are initialized to represent an empty range.
+
+      ALFA_Scope_Table.Append (
+        (Scope_Name   => new String'(Exact_Source_Name (Sloc (E))),
+         File_Num     => 0,
+         Scope_Num    => 0,
+         Line         => Nat (Get_Logical_Line_Number (Loc)),
+         Stype        => Typ,
+         Col          => Nat (Get_Column_Number (Loc)),
+         From_Xref    => 1,
+         To_Xref      => 0,
+         Scope_Entity => E));
+   end Add_ALFA_Scope;
+
+   --------------------
+   -- Add_ALFA_Xrefs --
+   --------------------
+
+   procedure Add_ALFA_Xrefs is
+      Prev_Scope_Idx  : Scope_Index;
+      Cur_Scope_Idx   : Scope_Index;
+      From_Xref_Idx   : Xref_Index;
+      Cur_Entity      : Entity_Id;
+      Cur_Entity_Name : String_Ptr;
+
+      package Scopes is
+         No_Scope : constant Nat := 0;
+         function Get_Scope_Num (N : Entity_Id) return Nat;
+         procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
+      end Scopes;
+
+      package body Scopes is
+         type Scope is record
+            Num    : Nat;
+            Entity : Entity_Id;
+         end record;
+
+         type Scope_Hashed is range 0 .. 255;
+
+         function Scope_Hash (E : Entity_Id) return Scope_Hashed;
+
+         function Scope_Hash (E : Entity_Id) return Scope_Hashed is
+            Value  : constant Int := Int (E);
+            Modulo : constant Int := Int (Scope_Hashed'Last) + 1;
+         begin
+            return Scope_Hashed (Value - (Value / Modulo) * Modulo);
+         end Scope_Hash;
+
+         package Scopes is new GNAT.HTable.Simple_HTable
+           (Header_Num => Scope_Hashed,
+            Element    => Scope,
+            No_Element => (Num => No_Scope, Entity => Empty),
+            Key        => Entity_Id,
+            Hash       => Scope_Hash,
+            Equal      => "=");
+
+         function Get_Scope_Num (N : Entity_Id) return Nat is
+         begin
+            return Scopes.Get (N).Num;
+         end Get_Scope_Num;
+
+         procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is
+         begin
+            Scopes.Set (K => N, E => Scope'(Num => Num, Entity => N));
+         end Set_Scope_Num;
+      end Scopes;
+
+      use Scopes;
+
+      Nrefs : Nat := Xrefs.Last;
+      --  Number of references in table. This value may get reset (reduced)
+      --  when we eliminate duplicate reference entries as well as references
+      --  not suitable for local cross-references.
+
+      Rnums : array (0 .. Nrefs) of Nat;
+      --  This array contains numbers of references in the Xrefs table. This
+      --  list is sorted in output order. The extra 0'th entry is convenient
+      --  for the call to sort. When we sort the table, we move the entries in
+      --  Rnums around, but we do not move the original table entries.
+
+      function Lt (Op1, Op2 : Natural) return Boolean;
+      --  Comparison function for Sort call
+
+      procedure Move (From : Natural; To : Natural);
+      --  Move procedure for Sort call
+
+      package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+      --------
+      -- Lt --
+      --------
+
+      function Lt (Op1, Op2 : Natural) return Boolean is
+         T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1)));
+         T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2)));
+
+      begin
+         --  First test: if entity is in different unit, sort by unit. Notice
+         --  that we use Ent_Scope_File rather than Eun, as Eun may refer to
+         --  the file where the generic scope is defined, and it may be
+         --  different from the file where the enclosing scope is defined. It
+         --  is the latter which matters for a correct order here.
+
+         if T1.Ent_Scope_File /= T2.Ent_Scope_File then
+            return Dependency_Num (T1.Ent_Scope_File) <
+              Dependency_Num (T2.Ent_Scope_File);
+
+         --  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)
+         then
+            return Get_Scope_Num (T1.Ent_Scope) < Get_Scope_Num (T2.Ent_Scope);
+
+         --  Third test: within same unit and scope, sort by location of
+         --  entity definition.
+
+         elsif T1.Def /= T2.Def then
+            return T1.Def < T2.Def;
+
+         --  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
+            return True;
+         elsif T1.Lun /= T2.Lun and then T2.Ent_Scope_File = T2.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
+         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
+         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);
+
+         --  Seventh test: for same entity, sort by reference location scope
+
+         elsif Get_Scope_Num (T1.Ref_Scope) /=
+           Get_Scope_Num (T2.Ref_Scope)
+         then
+            return Get_Scope_Num (T1.Ref_Scope) < Get_Scope_Num (T2.Ref_Scope);
+
+         --  Eighth test: order of location within referencing unit
+
+         elsif T1.Loc /= T2.Loc then
+            return T1.Loc < T2.Loc;
+
+         --  Finally, for two locations at the same address, we prefer the one
+         --  that does NOT have the type 'r' so that a modification or
+         --  extension takes preference, when there are more than one reference
+         --  at the same location. As a result, in the case of entities that
+         --  are in-out actuals, the read reference follows the modify
+         --  reference.
+
+         else
+            return T2.Typ = 'r';
+         end if;
+      end Lt;
+
+      ----------
+      -- Move --
+      ----------
+
+      procedure Move (From : Natural; To : Natural) is
+      begin
+         Rnums (Nat (To)) := Rnums (Nat (From));
+      end Move;
+
+      --  Start of processing for Add_ALFA_Xrefs
+   begin
+
+      for J in ALFA_Scope_Table.First .. ALFA_Scope_Table.Last loop
+         Set_Scope_Num (N   => ALFA_Scope_Table.Table (J).Scope_Entity,
+                        Num => ALFA_Scope_Table.Table (J).Scope_Num);
+      end loop;
+
+      --  Set up the pointer vector for the sort
+
+      for J in 1 .. Nrefs loop
+         Rnums (J) := J;
+      end loop;
+
+      --  Eliminate entries not appropriate for ALFA. Should be prior to
+      --  sorting cross-references, as it discards useless references which do
+      --  not have a proper format for the comparison function (like no
+      --  location).
+
+      Eliminate_Before_Sort : declare
+         NR : Nat;
+
+         function Is_ALFA_Scope (E : Entity_Id) return Boolean;
+         --  Return whether the entity or reference scope is adequate
+
+         -------------------
+         -- Is_ALFA_Scope --
+         -------------------
+
+         function Is_ALFA_Scope (E : Entity_Id) return Boolean is
+         begin
+            return Present (E)
+              and then not Is_Generic_Unit (E)
+              and then Renamed_Entity (E) = Empty
+              and then Get_Scope_Num (E) /= No_Scope;
+         end Is_ALFA_Scope;
+
+         --  Start of processing for Eliminate_Before_Sort
+      begin
+
+         NR    := Nrefs;
+         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)
+            then
+               Nrefs         := Nrefs + 1;
+               Rnums (Nrefs) := Rnums (J);
+            end if;
+         end loop;
+      end Eliminate_Before_Sort;
+
+      --  Sort the references
+
+      Sorting.Sort (Integer (Nrefs));
+
+      Eliminate_After_Sort : declare
+         NR    : Nat;
+
+         Crloc : Source_Ptr;
+         --  Current reference location
+
+         Prevt : Character;
+         --  reference kind of previous reference
+
+      begin
+         --  Eliminate duplicate entries
+
+         --  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 Nrefs >= 2 then
+            NR    := Nrefs;
+            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;
+
+         --  Eliminate the reference if it is at the same location as the
+         --  previous one, unless it is a read-reference that indicates that
+         --  the entity is an in-out actual in a call.
+
+         NR    := Nrefs;
+         Nrefs := 0;
+         Crloc := No_Location;
+         Prevt := 'm';
+
+         for J in 1 .. NR loop
+            if Xrefs.Table (Rnums (J)).Loc /= Crloc
+              or else (Prevt = 'm'
+                        and then Xrefs.Table (Rnums (J)).Typ = 'r')
+            then
+               Crloc         := Xrefs.Table (Rnums (J)).Loc;
+               Prevt         := Xrefs.Table (Rnums (J)).Typ;
+               Nrefs         := Nrefs + 1;
+               Rnums (Nrefs) := Rnums (J);
+            end if;
+         end loop;
+      end Eliminate_After_Sort;
+
+      --  Initialize loop
+
+      Prev_Scope_Idx := 1;
+      Cur_Scope_Idx  := 1;
+      From_Xref_Idx  := 1;
+      Cur_Entity     := Empty;
+
+      if ALFA_Scope_Table.Last /= 0 then
+         ALFA_Scope_Table.Table (1).From_Xref := 1;
+      end if;
+
+      --  Loop to output references
+
+      for Refno in 1 .. Nrefs loop
+         Add_One_Xref : declare
+
+            -----------------------
+            -- Local Subprograms --
+            -----------------------
+
+            function Cur_Scope return Node_Id;
+            --  Return the scope entity which corresponds to index
+            --  Cur_Scope_Idx in table ALFA_Scope_Table.
+
+            function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;
+            --  Check whether entity E is in ALFA_Scope_Table at index
+            --  Cur_Scope_Idx or higher.
+
+            function Is_Past_Scope_Entity (E : Entity_Id) return Boolean;
+            --  Check whether entity E is in ALFA_Scope_Table at index strictly
+            --  lower than Cur_Scope_Idx.
+
+            ---------------
+            -- Cur_Scope --
+            ---------------
+
+            function Cur_Scope return Node_Id is
+            begin
+               return ALFA_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity;
+            end Cur_Scope;
+
+            ----------------------------
+            -- Is_Future_Scope_Entity --
+            ----------------------------
+
+            function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is
+            begin
+               for J in Cur_Scope_Idx .. ALFA_Scope_Table.Last loop
+                  if E = ALFA_Scope_Table.Table (J).Scope_Entity then
+                     return True;
+                  end if;
+               end loop;
+
+               --  If this assertion fails, this means that the scope which we
+               --  are looking for has been treated already, which reveals a
+               --  problem in the order of cross-references.
+
+               pragma Assert (not Is_Past_Scope_Entity (E));
+
+               return False;
+            end Is_Future_Scope_Entity;
+
+            --------------------------
+            -- Is_Past_Scope_Entity --
+            --------------------------
+
+            function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is
+            begin
+               for J in ALFA_Scope_Table.First .. Cur_Scope_Idx - 1 loop
+                  if E = ALFA_Scope_Table.Table (J).Scope_Entity then
+                     return True;
+                  end if;
+               end loop;
+
+               return False;
+            end Is_Past_Scope_Entity;
+
+            ---------------------
+            -- Local Variables --
+            ---------------------
+
+            XE  : Xref_Entry renames Xrefs.Table (Rnums (Refno));
+
+         begin
+            --  If this assertion fails, this means that the scope which we
+            --  are looking for is not in ALFA scope table, which reveals
+            --  either a problem in the construction of the scope table, or an
+            --  erroneous scope for the current cross-reference.
+
+            pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope));
+
+            if XE.Ent_Scope /= Cur_Scope then
+               ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref :=
+                 From_Xref_Idx;
+               From_Xref_Idx := ALFA_Xref_Table.Last + 1;
+            end if;
+
+            while XE.Ent_Scope /= Cur_Scope loop
+               Cur_Scope_Idx := Cur_Scope_Idx + 1;
+               pragma Assert (Cur_Scope_Idx <= ALFA_Scope_Table.Last);
+            end loop;
+
+            if Prev_Scope_Idx /= Cur_Scope_Idx
+              and then ALFA_Xref_Table.Last /= 0
+            then
+               ALFA_Scope_Table.Table (Prev_Scope_Idx).To_Xref :=
+                 ALFA_Xref_Table.Last;
+               Prev_Scope_Idx := Cur_Scope_Idx;
+            end if;
+
+            if XE.Ent /= Cur_Entity then
+               Cur_Entity_Name :=
+                 new String'(Exact_Source_Name (Sloc (XE.Ent)));
+            end if;
+
+            ALFA_Xref_Table.Append (
+              (Entity_Name => Cur_Entity_Name,
+               Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
+               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))));
+         end Add_One_Xref;
+      end loop;
+
+      ALFA_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx;
+      ALFA_Scope_Table.Table (Cur_Scope_Idx).To_Xref   := ALFA_Xref_Table.Last;
+   end Add_ALFA_Xrefs;
+
+   ------------------
+   -- Collect_ALFA --
+   ------------------
+
+   procedure Collect_ALFA (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is
+   begin
+      --  Cross-references should have been computed first
+
+      pragma Assert (Xrefs.Last /= 0);
+
+      Initialize_ALFA_Tables;
+
+      --  Generate file and scope ALFA information
+
+      for D in 1 .. Num_Sdep loop
+
+         --  Ignore file for System
+
+         if Units.Table (Sdep_Table (D)).Source_Index /=
+           System_Source_File_Index
+         then
+            Add_ALFA_File (U => Sdep_Table (D), D => D);
+         end if;
+      end loop;
+
+      --  Generate cross reference ALFA information
+
+      Add_ALFA_Xrefs;
+   end Collect_ALFA;
+
+   -----------------------------------------
+   -- Traverse_Declarations_Or_Statements --
+   -----------------------------------------
+
+   procedure Traverse_Declarations_Or_Statements (L : List_Id) is
+      N : Node_Id;
+
+   begin
+      --  Loop through statements or declarations
+
+      N := First (L);
+      while Present (N) loop
+         case Nkind (N) is
+
+            --  Package declaration
+
+            when N_Package_Declaration =>
+               Traverse_Package_Declaration (N);
+
+            --  Generic package declaration ??? TBD
+
+            when N_Generic_Package_Declaration =>
+               null;
+
+            --  Package body
+
+            when N_Package_Body =>
+               if Ekind (Defining_Entity (N)) /= E_Generic_Package then
+                  Traverse_Package_Body (N);
+               end if;
+
+            --  Subprogram declaration
+
+            when N_Subprogram_Declaration =>
+               Add_ALFA_Scope (N);
+
+            --  Generic subprogram declaration ??? TBD
+
+            when N_Generic_Subprogram_Declaration =>
+               null;
+
+            --  Subprogram body
+
+            when N_Subprogram_Body =>
+               if not Is_Generic_Subprogram (Defining_Entity (N)) then
+                  Traverse_Subprogram_Body (N);
+               end if;
+
+            --  Block statement
+
+            when N_Block_Statement =>
+               Traverse_Declarations_Or_Statements (Declarations (N));
+               Traverse_Handled_Statement_Sequence
+                 (Handled_Statement_Sequence (N));
+
+            when N_If_Statement =>
+
+               --  Traverse the statements in the THEN part
+
+               Traverse_Declarations_Or_Statements (Then_Statements (N));
+
+               --  Loop through ELSIF parts if present
+
+               if Present (Elsif_Parts (N)) then
+                  declare
+                     Elif : Node_Id := First (Elsif_Parts (N));
+
+                  begin
+                     while Present (Elif) loop
+                        Traverse_Declarations_Or_Statements
+                          (Then_Statements (Elif));
+                        Next (Elif);
+                     end loop;
+                  end;
+               end if;
+
+               --  Finally traverse the ELSE statements if present
+
+               Traverse_Declarations_Or_Statements (Else_Statements (N));
+
+            --  Case statement
+
+            when N_Case_Statement =>
+
+               --  Process case branches
+
+               declare
+                  Alt : Node_Id;
+               begin
+                  Alt := First (Alternatives (N));
+                  while Present (Alt) loop
+                     Traverse_Declarations_Or_Statements (Statements (Alt));
+                     Next (Alt);
+                  end loop;
+               end;
+
+            --  Extended return statement
+
+            when N_Extended_Return_Statement =>
+               Traverse_Handled_Statement_Sequence
+                 (Handled_Statement_Sequence (N));
+
+            --  Loop
+
+            when N_Loop_Statement =>
+               Traverse_Declarations_Or_Statements (Statements (N));
+
+            when others =>
+               null;
+         end case;
+
+         Next (N);
+      end loop;
+   end Traverse_Declarations_Or_Statements;
+
+   -----------------------------------------
+   -- Traverse_Handled_Statement_Sequence --
+   -----------------------------------------
+
+   procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
+      Handler : Node_Id;
+
+   begin
+      if Present (N) then
+         Traverse_Declarations_Or_Statements (Statements (N));
+
+         if Present (Exception_Handlers (N)) then
+            Handler := First (Exception_Handlers (N));
+            while Present (Handler) loop
+               Traverse_Declarations_Or_Statements (Statements (Handler));
+               Next (Handler);
+            end loop;
+         end if;
+      end if;
+   end Traverse_Handled_Statement_Sequence;
+
+   ---------------------------
+   -- Traverse_Package_Body --
+   ---------------------------
+
+   procedure Traverse_Package_Body (N : Node_Id) is
+   begin
+      Add_ALFA_Scope (N);
+      Traverse_Declarations_Or_Statements (Declarations (N));
+      Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
+   end Traverse_Package_Body;
+
+   ----------------------------------
+   -- Traverse_Package_Declaration --
+   ----------------------------------
+
+   procedure Traverse_Package_Declaration (N : Node_Id) is
+      Spec : constant Node_Id := Specification (N);
+   begin
+      Add_ALFA_Scope (N);
+      Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
+      Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
+   end Traverse_Package_Declaration;
+
+   ------------------------------
+   -- Traverse_Subprogram_Body --
+   ------------------------------
+
+   procedure Traverse_Subprogram_Body (N : Node_Id) is
+   begin
+      Add_ALFA_Scope (N);
+      Traverse_Declarations_Or_Statements (Declarations (N));
+      Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
+   end Traverse_Subprogram_Body;
+
+end ALFA;