Patchwork [Ada] Optional section in ALI files for local cross-references

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 2, 2011, 2:51 p.m.
Message ID <20110802145105.GA12418@adacore.com>
Download mbox | patch
Permalink /patch/107937/
State New
Headers show

Comments

Arnaud Charlet - Aug. 2, 2011, 2:51 p.m.
In ALFA mode, generate an additional section in ALI files for so-called 'local'
cross-references, which 1) group the cross-references in each subprogram or
package; 2) add references to object definitions ('D' or 'I' with
initialization). This new section should be used in specific back-ends which
need to compute the set of global variables read/written directly or not by a
subprogram.

Tested on x86_64-pc-linux-gnu, committed on trunk

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

	* lib-writ.adb (Write_ALI): when ALFA mode is set, write local
	cross-references section in ALI.
	* lib-xref.adb, lib-xref.ads (Xref_Entry): add components Sub
	(enclosing subprogram), Slc (location of Sub) and Sun (unit number of
	Sub).
	(Enclosing_Subprogram_Or_Package): new function to return the enclosing
	subprogram or package entity of a node
	(Is_Local_Reference_Type): new function returns True for references
	selected in local cross-references.
	(Lt): function extracted from Lt in Output_References
	(Write_Entity_Name): function extracted from Output_References
	(Generate_Definition): generate reference with type 'D' for definition
	of objects (object declaration and parameter specification), with
	appropriate locations and units, for use in local cross-references.
	(Generate_Reference): update fields Sub, Slc and Sun. Keep newly created
	references of type 'I' for initialization in object definition.
	(Output_References): move part of function Lt and procedure
	Write_Entity_Name outside of the body. Ignore references of types 'D'
	and 'I' introduced for local cross-references.
	(Output_Local_References): new procedure to output the local
	cross-references sections.
	(Lref_Entity_Status): new array defining whether an entity is a local
	* sem_ch3.adb (Analyze_Object_Declaration): call Generate_Reference
	with 'I' type when initialization expression is present.
	* get_scos.adb, get_scos.ads: Correct comments and typos

Patch

Index: get_scos.adb
===================================================================
--- get_scos.adb	(revision 176998)
+++ get_scos.adb	(working copy)
@@ -2,11 +2,11 @@ 
 --                                                                          --
 --                         GNAT COMPILER COMPONENTS                         --
 --                                                                          --
---                             G E T _ S C O S                               --
+--                             G E T _ S C O S                              --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2009, Free Software Foundation, Inc.           --
+--           Copyright (C) 2009-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- --
Index: get_scos.ads
===================================================================
--- get_scos.ads	(revision 176998)
+++ get_scos.ads	(working copy)
@@ -2,11 +2,11 @@ 
 --                                                                          --
 --                         GNAT COMPILER COMPONENTS                         --
 --                                                                          --
---                             G E T _ S C O S                               --
+--                             G E T _ S C O S                              --
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---             Copyright (C) 2009, Free Software Foundation, Inc.           --
+--           Copyright (C) 2009-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- --
@@ -32,7 +32,7 @@ 
 
    with function Getc return Character is <>;
    --  Get next character, positioning the ALI file ready to read the following
-   --  character (equivalent to calling Skipc, then Nextc). If the end of file
+   --  character (equivalent to calling Nextc, then Skipc). If the end of file
    --  is encountered, the value Types.EOF is returned.
 
    with function Nextc return Character is <>;
@@ -54,5 +54,5 @@ 
 --  first character of the line following the SCO information (which will
 --  never start with a 'C').
 --
---  If a format error is detected in the input, then an exceptions is raised
+--  If a format error is detected in the input, then an exception is raised
 --  (Ada.IO_Exceptions.Data_Error), with the file positioned to the error.
Index: lib-writ.adb
===================================================================
--- lib-writ.adb	(revision 176998)
+++ lib-writ.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-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- --
@@ -1301,6 +1301,13 @@ 
          SCO_Output;
       end if;
 
+      --  Output references by subprogram
+
+      if ALFA_Mode then
+         Write_Info_EOL;
+         Output_Local_References;
+      end if;
+
       --  Output final blank line and we are done. This final blank line is
       --  probably junk, but we don't feel like making an incompatible change!
 
Index: lib-xref.adb
===================================================================
--- lib-xref.adb	(revision 177031)
+++ lib-xref.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-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- --
@@ -62,6 +62,9 @@ 
       Ent : Entity_Id;
       --  Entity referenced (E parameter to Generate_Reference)
 
+      Sub : Entity_Id;
+      --  Entity of the closest enclosing subprogram or package
+
       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
@@ -73,12 +76,18 @@ 
       --  to Generate_Reference). Set to No_Location for the case of a
       --  defining occurrence.
 
+      Slc : Source_Ptr;
+      --  Original source location for entity Sub
+
       Typ : Character;
       --  Reference type (Typ param to Generate_Reference)
 
       Eun : Unit_Number_Type;
       --  Unit number corresponding to Ent
 
+      Sun : Unit_Number_Type;
+      --  Unit number corresponding to Sub
+
       Lun : Unit_Number_Type;
       --  Unit number corresponding to Loc. Value is undefined and not
       --  referenced if Loc is set to No_Location.
@@ -97,12 +106,71 @@ 
    --  Local Subprograms --
    ------------------------
 
+   function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id;
+   --  Return the closest enclosing subprogram of package
+
+   function Is_Local_Reference_Type (Typ : Character) return Boolean;
+   --  Return whether Typ is a suitable reference type for a local reference
+
    procedure Generate_Prim_Op_References (Typ : Entity_Id);
    --  For a tagged type, generate implicit references to its primitive
    --  operations, for source navigation. This is done right before emitting
    --  cross-reference information rather than at the freeze point of the type
    --  in order to handle late bodies that are primitive operations.
 
+   function Lt (T1, T2 : Xref_Entry) return Boolean;
+   --  Order cross-references
+
+   procedure Write_Entity_Name (E : Entity_Id; Cursrc : Source_Buffer_Ptr);
+   --  Output entity name for E. We use the occurrence from the actual
+   --  source program at the definition point.
+
+   -------------------------------------
+   -- Enclosing_Subprogram_Or_Package --
+   -------------------------------------
+
+   function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id
+   is
+      Result : Entity_Id;
+
+   begin
+      Result := N;
+      loop
+         exit when No (Result);
+
+         case Nkind (Result) is
+            when N_Package_Specification =>
+               Result := Defining_Unit_Name (Result);
+               exit;
+
+            when N_Package_Body =>
+               Result := Corresponding_Spec (Result);
+               exit;
+
+            when N_Subprogram_Specification =>
+               Result := Defining_Unit_Name (Result);
+               exit;
+
+            when N_Subprogram_Declaration =>
+               Result := Defining_Unit_Name (Specification (Result));
+               exit;
+
+            when N_Subprogram_Body =>
+               Result := Defining_Unit_Name (Specification (Result));
+               exit;
+
+            when others =>
+               Result := Parent (Result);
+         end case;
+      end loop;
+
+      if Nkind (Result) = N_Defining_Program_Unit_Name then
+         Result := Defining_Identifier (Result);
+      end if;
+
+      return Result;
+   end Enclosing_Subprogram_Or_Package;
+
    -------------------------
    -- Generate_Definition --
    -------------------------
@@ -146,11 +214,39 @@ 
          Loc  := Original_Location (Sloc (E));
 
          Xrefs.Table (Indx).Ent := E;
-         Xrefs.Table (Indx).Def := No_Location;
-         Xrefs.Table (Indx).Loc := No_Location;
-         Xrefs.Table (Indx).Typ := ' ';
+
+         if ALFA_Mode
+           and then Nkind_In (Parent (E),
+                              N_Object_Declaration,
+                              N_Parameter_Specification)
+         then
+            --  In ALFA mode, define precise 'D' references for object
+            --  definition.
+
+            declare
+               Sub : constant Entity_Id := Enclosing_Subprogram_Or_Package (E);
+               Slc : constant Source_Ptr := Original_Location (Sloc (Sub));
+               Sun : constant Unit_Number_Type := Get_Source_Unit (Slc);
+            begin
+               Xrefs.Table (Indx).Typ := 'D';
+               Xrefs.Table (Indx).Sub := Sub;
+               Xrefs.Table (Indx).Def := Loc;
+               Xrefs.Table (Indx).Loc := Loc;
+               Xrefs.Table (Indx).Slc := Slc;
+               Xrefs.Table (Indx).Lun := Get_Source_Unit (Loc);
+               Xrefs.Table (Indx).Sun := Sun;
+            end;
+         else
+            Xrefs.Table (Indx).Typ := ' ';
+            Xrefs.Table (Indx).Sub := Empty;
+            Xrefs.Table (Indx).Def := No_Location;
+            Xrefs.Table (Indx).Loc := No_Location;
+            Xrefs.Table (Indx).Slc := No_Location;
+            Xrefs.Table (Indx).Lun := No_Unit;
+            Xrefs.Table (Indx).Sun := No_Unit;
+         end if;
+
          Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
-         Xrefs.Table (Indx).Lun := No_Unit;
          Set_Has_Xref_Entry (E);
 
          if In_Inlined_Body then
@@ -275,7 +371,9 @@ 
       Nod  : Node_Id;
       Ref  : Source_Ptr;
       Def  : Source_Ptr;
+      Slc  : Source_Ptr;
       Ent  : Entity_Id;
+      Sub  : Entity_Id;
 
       Call   : Node_Id;
       Formal : Entity_Id;
@@ -495,6 +593,7 @@ 
 
       if not In_Extended_Main_Source_Unit (N) then
          if Typ = 'e'
+           or else Typ = 'I'
            or else Typ = 'p'
            or else Typ = 'i'
            or else Typ = 'k'
@@ -835,13 +934,17 @@ 
 
          --  Record reference to entity
 
+         Sub := Enclosing_Subprogram_Or_Package (N);
+
          Ref := Original_Location (Sloc (Nod));
          Def := Original_Location (Sloc (Ent));
+         Slc := Original_Location (Sloc (Sub));
 
          Xrefs.Increment_Last;
          Indx := Xrefs.Last;
 
          Xrefs.Table (Indx).Loc := Ref;
+         Xrefs.Table (Indx).Slc := Slc;
 
          --  Overriding operations are marked with 'P'
 
@@ -856,7 +959,9 @@ 
 
          Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
          Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
+         Xrefs.Table (Indx).Sun := Get_Source_Unit (Slc);
          Xrefs.Table (Indx).Ent := Ent;
+         Xrefs.Table (Indx).Sub := Sub;
          Set_Has_Xref_Entry (Ent);
       end if;
    end Generate_Reference;
@@ -931,6 +1036,62 @@ 
       Xrefs.Init;
    end Initialize;
 
+   -----------------------------
+   -- Is_Local_Reference_Type --
+   -----------------------------
+
+   function Is_Local_Reference_Type (Typ : Character) return Boolean is
+   begin
+      return Typ = 'r' or else Typ = 'm' or else Typ = 's'
+        or else Typ = 'I' or else Typ = 'D';
+   end Is_Local_Reference_Type;
+
+   --------
+   -- Lt --
+   --------
+
+   function Lt (T1, T2 : Xref_Entry) return Boolean 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);
+
+      --  Second test: within same unit, sort by entity Sloc
+
+      elsif T1.Def /= T2.Def then
+         return T1.Def < T2.Def;
+
+      --  Third test: sort definitions ahead of references
+
+      elsif T1.Loc = No_Location then
+         return True;
+
+      elsif T2.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);
+
+      --  Fifth 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;
+
    -----------------------
    -- Output_References --
    -----------------------
@@ -1409,44 +1570,7 @@ 
             T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
 
          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);
-
-            --  Second test: within same unit, sort by entity Sloc
-
-            elsif T1.Def /= T2.Def then
-               return T1.Def < T2.Def;
-
-            --  Third test: sort definitions ahead of references
-
-            elsif T1.Loc = No_Location then
-               return True;
-
-            elsif T2.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);
-
-            --  Fifth 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;
+            return Lt (T1, T2);
          end Lt;
 
          ----------
@@ -1852,17 +1976,28 @@ 
                   end if;
                end if;
 
-               --  Only output reference if interesting type of entity, and
-               --  suppress self references, except for bodies that act as
-               --  specs. Also suppress definitions of body formals (we only
-               --  treat these as references, and the references were
-               --  separately recorded).
+               --  Only output reference if interesting type of entity
 
                if Ctyp = ' '
+
+               --  Suppress references to object definitions, used for local
+               --  references.
+
+                 or else XE.Typ = 'D'
+                 or else XE.Typ = 'I'
+
+               --  Suppress self references, except for bodies that act as
+               --  specs.
+
                  or else (XE.Loc = XE.Def
                             and then
                               (XE.Typ /= 'b'
                                 or else not Is_Subprogram (XE.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)))
                then
@@ -2253,4 +2388,433 @@ 
       end Output_Refs;
    end Output_References;
 
+   -----------------------------
+   -- Output_Local_References --
+   -----------------------------
+
+   procedure Output_Local_References is
+
+      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.
+
+      Curxu : Unit_Number_Type;
+      --  Current xref unit
+
+      Curru : Unit_Number_Type;
+      --  Current reference unit for one entity
+
+      Cursu : Unit_Number_Type;
+      --  Current reference unit for one enclosing subprogram
+
+      Cursrc : Source_Buffer_Ptr;
+      --  Current xref unit source text
+
+      Cursub : Entity_Id;
+      --  Current enclosing subprogram
+
+      Curent : Entity_Id;
+      --  Current entity
+
+      Curnam : String (1 .. Name_Buffer'Length);
+      Curlen : Natural;
+      --  Simple name and length of current entity
+
+      Curdef : Source_Ptr;
+      --  Original source location for current entity
+
+      Crloc : Source_Ptr;
+      --  Current reference location
+
+      Ctyp  : Character;
+      --  Entity type character
+
+      Prevt : Character;
+      --  Reference kind of previous reference
+
+      function Lt (Op1, Op2 : Natural) return Boolean;
+      --  Comparison function for Sort call
+
+      function Name_Change (X : Entity_Id) return Boolean;
+      --  Determines if entity X has a different simple name from Curent
+
+      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 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
+         T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
+
+      begin
+         if T1.Slc = No_Location then
+            return True;
+
+         elsif T2.Slc = No_Location then
+            return False;
+
+         elsif T1.Sun /= T2.Sun then
+            return Dependency_Num (T1.Sun) < Dependency_Num (T2.Sun);
+
+         elsif T1.Slc /= T2.Slc then
+            return T1.Slc < T2.Slc;
+
+         else
+            return Lt (T1, T2);
+         end if;
+      end Lt;
+
+      ----------
+      -- Move --
+      ----------
+
+      procedure Move (From : Natural; To : Natural) is
+      begin
+         Rnums (Nat (To)) := Rnums (Nat (From));
+      end Move;
+
+      -----------------
+      -- Name_Change --
+      -----------------
+
+      --  Why a string comparison here??? Why not compare Name_Id values???
+
+      function Name_Change (X : Entity_Id) return Boolean is
+      begin
+         Get_Unqualified_Name_String (Chars (X));
+
+         if Name_Len /= Curlen then
+            return True;
+         else
+            return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
+         end if;
+      end Name_Change;
+
+      --  Start of processing for Output_Subprogram_References
+   begin
+
+      --  Replace enclosing subprogram pointer by corresponding specification
+      --  when appropriate. This could not be done before as the information
+      --  was not always available when registering references.
+
+      for J in 1 .. Xrefs.Last loop
+         if Present (Xrefs.Table (J).Sub) then
+            declare
+               N   : constant Node_Id :=
+                       Parent (Parent (Xrefs.Table (J).Sub));
+               Sub : Entity_Id;
+               Slc : Source_Ptr;
+               Sun : Unit_Number_Type;
+            begin
+               if Nkind (N) = N_Subprogram_Body
+                 and then not Acts_As_Spec (N)
+               then
+                  Sub := Corresponding_Spec (N);
+
+                  if Nkind (Sub) = N_Defining_Program_Unit_Name then
+                     Sub := Defining_Identifier (Sub);
+                  end if;
+
+                  Slc := Original_Location (Sloc (Sub));
+                  Sun := Get_Source_Unit (Slc);
+
+                  Xrefs.Table (J).Sub := Sub;
+                  Xrefs.Table (J).Slc := Slc;
+                  Xrefs.Table (J).Sun := Sun;
+               end if;
+            end;
+         end if;
+      end loop;
+
+      --  Set up the pointer vector for the sort
+
+      for J in 1 .. Nrefs loop
+         Rnums (J) := J;
+      end loop;
+
+      --  Sort the references
+
+      Sorting.Sort (Integer (Nrefs));
+
+      declare
+         NR : Nat;
+
+      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 entries not appropriate for local references
+
+         NR    := Nrefs;
+         Nrefs := 0;
+
+         for J in 1 .. NR loop
+            if Lref_Entity_Status (Ekind (Xrefs.Table (Rnums (J)).Ent))
+              and then Is_Local_Reference_Type (Xrefs.Table (Rnums (J)).Typ)
+            then
+               Nrefs         := Nrefs + 1;
+               Rnums (Nrefs) := Rnums (J);
+            end if;
+         end loop;
+      end;
+
+      --  Initialize loop through references
+
+      Curxu  := No_Unit;
+      Cursub := Empty;
+      Curent := Empty;
+      Curdef := No_Location;
+      Curru  := No_Unit;
+      Cursu  := No_Unit;
+      Crloc  := No_Location;
+      Prevt  := 'm';
+
+      --  Loop to output references
+
+      for Refno in 1 .. Nrefs loop
+         Output_One_Ref : declare
+            Ent : Entity_Id;
+            XE  : Xref_Entry renames Xrefs.Table (Rnums (Refno));
+            --  The current entry to be accessed
+
+         begin
+            Ent  := XE.Ent;
+            Ctyp := Xref_Entity_Letters (Ekind (Ent));
+
+            --  Start new Unit section if subprogram in new unit
+
+            if XE.Sun /= Cursu then
+               if Write_Info_Col > 1 then
+                  Write_Info_EOL;
+               end if;
+
+               Cursu := XE.Sun;
+
+               Write_Info_Initiate ('F');
+               Write_Info_Char (' ');
+               Write_Info_Nat (Dependency_Num (XE.Sun));
+               Write_Info_Char (' ');
+               Write_Info_Name (Reference_Name (Source_Index (XE.Sun)));
+               Write_Info_EOL;
+            end if;
+
+            --  Start new Subprogram section if new subprogram
+
+            if XE.Sub /= Cursub then
+               if Write_Info_Col > 1 then
+                  Write_Info_EOL;
+               end if;
+
+               Cursub := XE.Sub;
+               Cursrc := Source_Text (Source_Index (Cursu));
+
+               Write_Info_Initiate ('S');
+               Write_Info_Char (' ');
+               Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Slc)));
+               Write_Info_Char (Xref_Entity_Letters (Ekind (XE.Sub)));
+               Write_Info_Nat (Int (Get_Column_Number (XE.Slc)));
+               Write_Info_Char (' ');
+               Write_Entity_Name (XE.Sub, Cursrc);
+
+               --  Indicate that the entity is in the unit of the current
+               --  local xref section.
+
+               Curru := Cursu;
+
+               --  End of processing for subprogram output
+
+               Curxu  := No_Unit;
+               Curent := Empty;
+            end if;
+
+            --  Start new Xref section if new xref unit
+
+            if XE.Eun /= Curxu then
+               if Write_Info_Col > 1 then
+                  Write_Info_EOL;
+               end if;
+
+               Curxu  := XE.Eun;
+               Cursrc := Source_Text (Source_Index (Curxu));
+
+               Write_Info_Initiate ('X');
+               Write_Info_Char (' ');
+               Write_Info_Nat (Dependency_Num (XE.Eun));
+               Write_Info_Char (' ');
+               Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
+
+               --  End of processing for Xref section output
+
+               Curru := Cursu;
+            end if;
+
+            --  Start new Entity line if new entity. Note that we
+            --  consider two entities the same if they have the same
+            --  name and source location. This causes entities in
+            --  instantiations to be treated as though they referred
+            --  to the template.
+
+            if No (Curent)
+              or else
+                (XE.Ent /= Curent
+                 and then
+                   (Name_Change (XE.Ent) or else XE.Def /= Curdef))
+            then
+               Curent := XE.Ent;
+               Curdef := XE.Def;
+
+               Get_Unqualified_Name_String (Chars (XE.Ent));
+               Curlen := Name_Len;
+               Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
+
+               if Write_Info_Col > 1 then
+                  Write_Info_EOL;
+               end if;
+
+               --  Write line and column number information
+
+               Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Def)));
+               Write_Info_Char (Ctyp);
+               Write_Info_Nat  (Int (Get_Column_Number (XE.Def)));
+               Write_Info_Char (' ');
+
+               --  Output entity name
+
+               Write_Entity_Name (XE.Ent, Cursrc);
+
+               --  End of processing for entity output
+
+               Crloc := No_Location;
+            end if;
+
+            --  Output the reference if it is not as the same location
+            --  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
+              and then
+                (XE.Loc /= Crloc
+                 or else (Prevt = 'm' and then XE.Typ = 'r'))
+            then
+               Crloc := XE.Loc;
+               Prevt := XE.Typ;
+
+               --  Start continuation if line full, else blank
+
+               if Write_Info_Col > 72 then
+                  Write_Info_EOL;
+                  Write_Info_Initiate ('.');
+               end if;
+
+               Write_Info_Char (' ');
+
+               --  Output file number if changed
+
+               if XE.Lun /= Curru then
+                  Curru := XE.Lun;
+                  Write_Info_Nat (Dependency_Num (Curru));
+                  Write_Info_Char ('|');
+               end if;
+
+               --  Write line and column number information
+
+               Write_Info_Nat  (Int (Get_Logical_Line_Number (XE.Loc)));
+               Write_Info_Char (XE.Typ);
+               Write_Info_Nat  (Int (Get_Column_Number (XE.Loc)));
+            end if;
+         end Output_One_Ref;
+      end loop;
+
+      Write_Info_EOL;
+   end Output_Local_References;
+
+   -----------------------
+   -- Write_Entity_Name --
+   -----------------------
+
+   procedure Write_Entity_Name (E : Entity_Id; Cursrc : Source_Buffer_Ptr) is
+      P, P2 : Source_Ptr;
+      --  Used to index into source buffer to get entity name
+
+      WC    : Char_Code;
+      Err   : Boolean;
+      pragma Warnings (Off, WC);
+      pragma Warnings (Off, Err);
+
+   begin
+      P := Original_Location (Sloc (E));
+
+      --  Entity is character literal
+
+      if Cursrc (P) = ''' then
+         Write_Info_Char (Cursrc (P));
+         Write_Info_Char (Cursrc (P + 1));
+         Write_Info_Char (Cursrc (P + 2));
+
+         --  Entity is operator symbol
+
+      elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
+         Write_Info_Char (Cursrc (P));
+
+         P2 := P;
+         loop
+            P2 := P2 + 1;
+            Write_Info_Char (Cursrc (P2));
+            exit when Cursrc (P2) = Cursrc (P);
+         end loop;
+
+         --  Entity is identifier
+
+      else
+         loop
+            if Is_Start_Of_Wide_Char (Cursrc, P) then
+               Scan_Wide (Cursrc, P, WC, Err);
+            elsif not Identifier_Char (Cursrc (P)) then
+               exit;
+            else
+               P := P + 1;
+            end if;
+         end loop;
+
+         --  Write out the identifier by copying the exact
+         --  source characters used in its declaration. Note
+         --  that this means wide characters will be in their
+         --  original encoded form.
+
+         for J in
+           Original_Location (Sloc (E)) .. P - 1
+         loop
+            Write_Info_Char (Cursrc (J));
+         end loop;
+      end if;
+   end Write_Entity_Name;
+
 end Lib.Xref;
Index: lib-xref.ads
===================================================================
--- lib-xref.ads	(revision 176998)
+++ lib-xref.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1998-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-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- --
@@ -44,7 +44,7 @@ 
    --        This header precedes xref information (entities/references from
    --        the unit), identified by dependency number and file name. The
    --        dependency number is the index into the generated D lines and
-   --        is ones origin (i.e. 2 = reference to second generated D line).
+   --        its origin is one (i.e. 2 = reference to second generated D line).
 
    --        Note that the filename here will reflect the original name if
    --        a Source_Reference pragma was encountered (since all line number
@@ -52,7 +52,7 @@ 
 
    --  The lines following the header look like
 
-   --  line type col level entity renameref instref typeref overref ref  ref
+   --  line type col level entity renameref instref typeref overref ref ref
 
    --        line is the line number of the referenced entity. The name of
    --        the entity starts in column col. Columns are numbered from one,
@@ -69,7 +69,7 @@ 
 
    --        level is a single character that separates the col and
    --        entity fields. It is an asterisk (*) for a top level library
-   --        entity that is publicly visible, as well for an entity declared
+   --        entity that is publicly visible, as well as for an entity declared
    --        in the visible part of a generic package, the plus sign (+) for
    --        a C/C++ static entity, and space otherwise.
 
@@ -172,9 +172,11 @@ 
    --              b = body entity
    --              c = completion of private or incomplete type
    --              d = discriminant of type
+   --              D = object definition
    --              e = end of spec
    --              H = abstract type
    --              i = implicit reference
+   --              I = object definition with initialization
    --              k = implicit reference to parent unit in child unit
    --              l = label on END line
    --              m = modification
@@ -567,6 +569,134 @@ 
    --    y     abstract function               entry or entry family
    --    z     generic formal parameter        (unused)
 
+   -------------------------------------------------------------
+   -- Format of Local Cross-Reference Information in ALI File --
+   -------------------------------------------------------------
+
+   --  Local cross-reference sections follow the cross-reference section in an
+   --  ALI file, so that they need not be read by gnatbind, gnatmake etc.
+
+   --  A local cross-reference section has a header of the form
+
+   --     S line type col entity
+
+   --        These precisely define a subprogram or package, with the same
+   --        components as described for cross-reference sections.
+
+   --  These sections are grouped in chapters for each unit introduced by
+
+   --     F dependency-number filename
+
+   --  Each section groups a number of cross-reference sub-sections introduced
+   --  by
+
+   --     X dependency-number filename
+
+   --  Inside each cross-reference sub-section, there are a number of
+   --  references like
+
+   --     line type col entity ref ref ...
+
+   -----------------------------------
+   -- Local-Reference Entity Filter --
+   -----------------------------------
+
+   Lref_Entity_Status : 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);
+
    --------------------------------------
    -- Handling of Imported Subprograms --
    --------------------------------------
@@ -611,17 +741,8 @@ 
    --  This procedure is called to record a reference. N is the location
    --  of the reference and E is the referenced entity. Typ is one of:
    --
-   --    'b'  body entity
-   --    'c'  completion of incomplete or private type (see below)
-   --    'e'  end of construct
-   --    'i'  implicit reference
-   --    'l'  label on end line
-   --    'm'  modification
-   --    'p'  primitive operation
-   --    'r'  standard reference
-   --    't'  end of body
-   --    'x'  type extension
-   --    ' '  dummy reference (see below)
+   --    a character already described in the description of ref entries above
+   --    ' ' for dummy reference (see below)
    --
    --  Note: all references to incomplete or private types are to the
    --  original (incomplete or private type) declaration. The full
@@ -675,6 +796,9 @@ 
    procedure Output_References;
    --  Output references to the current ali file
 
+   procedure Output_Local_References;
+   --  Output references in each subprogram of the current ali file
+
    procedure Initialize;
    --  Initialize internal tables
 
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 177157)
+++ sem_ch3.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-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- --
@@ -3701,6 +3701,10 @@ 
       if Has_Aspects (N) then
          Analyze_Aspect_Specifications (N, Id);
       end if;
+
+      if ALFA_Mode and then Present (Expression (Original_Node (N))) then
+         Generate_Reference (Id, Id, 'I');
+      end if;
    end Analyze_Object_Declaration;
 
    ---------------------------