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 <m...@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
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;
---------------------------
