Skip to content

R
riscv-gcc-1
Commit 7ffbef99 by Arnaud Charlet Committed by Arnaud Charlet
Options

spark_xrefs.ads (Scope_Num): type refined to positive integers. 

2016-06-22  Arnaud Charlet  <charlet@adacore.com>

	* spark_xrefs.ads (Scope_Num): type refined to positive integers.
	* lib-xref-spark_specific.adb (Detect_And_Add_SPARK_Scope):
	moved into scope of Collect_SPARK_Xrefs.
	(Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs;
	now uses Dspec and Scope_Id from Collect_SPARK_Xrefs.
	(Collect_SPARK_Xrefs): refactored to avoid retraversing the list
	of scopes.
	(Traverse_Compilation_Unit): refactored as a generic procedure.
	* types.ads (Unit_Number_Type): range refined.

From-SVN: r237690
parent 71b23599
Showing with 377 additions and 415 deletions
gcc/ada/ChangeLog
2016-06-22 Arnaud Charlet <charlet@adacore.com>
* spark_xrefs.ads (Scope_Num): type refined to positive integers.
* lib-xref-spark_specific.adb (Detect_And_Add_SPARK_Scope):
moved into scope of Collect_SPARK_Xrefs.
(Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs;
now uses Dspec and Scope_Id from Collect_SPARK_Xrefs.
(Collect_SPARK_Xrefs): refactored to avoid retraversing the list
of scopes.
(Traverse_Compilation_Unit): refactored as a generic procedure.
* types.ads (Unit_Number_Type): range refined.
2016-06-22 Hristian Kirtchev <kirtchev@adacore.com> 2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
* lib-xref-spark_specific.adb, a-cuprqu.ads, sem_ch6.adb: Minor * lib-xref-spark_specific.adb, a-cuprqu.ads, sem_ch6.adb: Minor
......
gcc/ada/lib-xref-spark_specific.adb
...@@ -85,160 +85,68 @@ package body SPARK_Specific is ...@@ -85,160 +85,68 @@ package body SPARK_Specific is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Add_SPARK_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat); procedure Add_SPARK_File (Uspec, Ubody : Unit_Number_Type; Dspec : Nat);
-- Add file and corresponding scopes for unit to the tables -- Add file and corresponding scopes for unit to the tables
-- SPARK_File_Table and SPARK_Scope_Table. When two units are present for -- SPARK_File_Table and SPARK_Scope_Table. When two units are present
-- the same compilation unit, as it happens for library-level -- for the same compilation unit, as it happens for library-level
-- instantiations of generics, then Ubody /= Uspec, and all scopes are -- instantiations of generics, then Ubody is the number of the body
-- added to the same SPARK file. Otherwise Ubody = Uspec. -- unit; otherwise it is No_Unit.
procedure Add_SPARK_Scope (N : Node_Id);
-- Add scope N to the table SPARK_Scope_Table
procedure Add_SPARK_Xrefs; procedure Add_SPARK_Xrefs;
-- Filter table Xrefs to add all references used in SPARK to the table -- Filter table Xrefs to add all references used in SPARK to the table
-- SPARK_Xref_Table. -- SPARK_Xref_Table.
procedure Detect_And_Add_SPARK_Scope (N : Node_Id);
-- Call Add_SPARK_Scope on scopes
function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
-- Hash function for hash table -- Hash function for hash table
procedure Traverse_Declaration_Or_Statement generic
(N : Node_Id; with procedure Process (N : Node_Id) is <>;
Process : Node_Processing; procedure Traverse_Compilation_Unit (CU : Node_Id; Inside_Stubs : Boolean);
Inside_Stubs : Boolean); -- Call Process on all declarations in compilation unit CU. If
procedure Traverse_Declarations_Or_Statements -- Inside_Stubs is True, then the body of stubs is also traversed.
(L : List_Id; -- Generic declarations are ignored.
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Handled_Statement_Sequence
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Protected_Body
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Package_Body
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
procedure Traverse_Subprogram_Body
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
-- Traverse corresponding construct, calling Process on all declarations
-------------------- --------------------
-- Add_SPARK_File -- -- Add_SPARK_File --
-------------------- --------------------
procedure Add_SPARK_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat) is procedure Add_SPARK_File (Uspec, Ubody : Unit_Number_Type; Dspec : Nat) is
File : constant Source_File_Index := Source_Index (Uspec); File : constant Source_File_Index := Source_Index (Uspec);
From : Scope_Index; From : constant Scope_Index := SPARK_Scope_Table.Last + 1;
File_Name : String_Ptr; File_Name : String_Ptr;
Unit_File_Name : String_Ptr; Unit_File_Name : String_Ptr;
begin Scope_Id : Pos := 1;
-- Source file could be inexistant as a result of an error, if option
-- gnatQ is used.
if File = No_Source_File then procedure Add_SPARK_Scope (N : Node_Id);
return; -- Add scope N to the table SPARK_Scope_Table
end if;
-- Subunits are traversed as part of the top-level unit to which they procedure Detect_And_Add_SPARK_Scope (N : Node_Id);
-- belong. -- Call Add_SPARK_Scope on scopes
if Nkind (Unit (Cunit (Ubody))) = N_Subunit then
return;
end if;
From := SPARK_Scope_Table.Last + 1; ---------------------
-- Add_SPARK_Scope --
Traverse_Compilation_Unit ---------------------
(CU => Cunit (Ubody),
Process => Detect_And_Add_SPARK_Scope'Access,
Inside_Stubs => True);
-- When two units are present for the same compilation unit, as it procedure Add_SPARK_Scope (N : Node_Id) is
-- happens for library-level instantiations of generics, then add all E : constant Entity_Id := Defining_Entity (N);
-- scopes to the same SPARK file. Loc : constant Source_Ptr := Sloc (E);
if Ubody /= Uspec then -- The character describing the kind of scope is chosen to be the
Traverse_Compilation_Unit -- same as the one describing the corresponding entity in cross
(CU => Cunit (Uspec), -- references, see Xref_Entity_Letters in lib-xrefs.ads
Process => Detect_And_Add_SPARK_Scope'Access,
Inside_Stubs => True);
end if;
-- Update scope numbers Typ : Character;
declare
Scope_Id : Pos;
begin begin
Scope_Id := 1; -- Ignore scopes without a proper location
for Index in From .. SPARK_Scope_Table.Last loop
declare
S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Index);
begin
S.Scope_Num := Scope_Id;
S.File_Num := Dspec;
Scope_Id := Scope_Id + 1;
end;
end loop;
end;
-- Make entry for new file in file table
Get_Name_String (Reference_Name (File));
File_Name := new String'(Name_Buffer (1 .. Name_Len));
-- For subunits, also retrieve the file name of the unit. Only do so if
-- unit has an associated compilation unit.
if Present (Cunit (Unit (File))) if Sloc (N) = No_Location then
and then Nkind (Unit (Cunit (Unit (File)))) = N_Subunit return;
then end if;
Get_Name_String (Reference_Name (Main_Source_File));
Unit_File_Name := new String'(Name_Buffer (1 .. Name_Len));
else
Unit_File_Name := null;
end if;
SPARK_File_Table.Append (
(File_Name => File_Name,
Unit_File_Name => Unit_File_Name,
File_Num => Dspec,
From_Scope => From,
To_Scope => SPARK_Scope_Table.Last));
end Add_SPARK_File;
---------------------
-- Add_SPARK_Scope --
---------------------
procedure Add_SPARK_Scope (N : Node_Id) is
E : constant Entity_Id := Defining_Entity (N);
Loc : constant Source_Ptr := Sloc (E);
-- The character describing the kind of scope is chosen to be the same
-- as the one describing the corresponding entity in cross references,
-- see Xref_Entity_Letters in lib-xrefs.ads
Typ : Character;
begin
-- Ignore scopes without a proper location
if Sloc (N) = No_Location then
return;
end if;
case Ekind (E) is case Ekind (E) is
when E_Entry when E_Entry
| E_Entry_Family | E_Entry_Family
| E_Generic_Function | E_Generic_Function
...@@ -247,16 +155,16 @@ package body SPARK_Specific is ...@@ -247,16 +155,16 @@ package body SPARK_Specific is
| E_Package | E_Package
| E_Protected_Type | E_Protected_Type
| E_Task_Type | E_Task_Type
=> =>
Typ := Xref_Entity_Letters (Ekind (E)); Typ := Xref_Entity_Letters (Ekind (E));
when E_Function when E_Function
| E_Procedure | E_Procedure
=> =>
-- In SPARK we need to distinguish protected functions and -- In SPARK we need to distinguish protected functions and
-- procedures from ordinary subprograms, but there are no special -- procedures from ordinary subprograms, but there are no special
-- Xref letters for them. Since this distiction is only needed -- Xref letters for them. Since this distiction is only needed to
-- to detect protected calls, we pretend that such calls are entry -- detect protected calls, we pretend that such calls are entry
-- calls. -- calls.
if Ekind (Scope (E)) = E_Protected_Type then if Ekind (Scope (E)) = E_Protected_Type then
...@@ -269,7 +177,7 @@ package body SPARK_Specific is ...@@ -269,7 +177,7 @@ package body SPARK_Specific is
| E_Protected_Body | E_Protected_Body
| E_Subprogram_Body | E_Subprogram_Body
| E_Task_Body | E_Task_Body
=> =>
Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E))); Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
when E_Void => when E_Void =>
...@@ -282,24 +190,111 @@ package body SPARK_Specific is ...@@ -282,24 +190,111 @@ package body SPARK_Specific is
when others => when others =>
raise Program_Error; raise Program_Error;
end case; end case;
-- File_Num and Scope_Num are filled later. From_Xref and To_Xref are -- File_Num and Scope_Num are filled later. From_Xref and To_Xref
-- filled even later, but are initialized to represent an empty range. -- are filled even later, but are initialized to represent an empty
-- range.
SPARK_Scope_Table.Append (
(Scope_Name => new String'(Unique_Name (E)), SPARK_Scope_Table.Append
File_Num => 0, ((Scope_Name => new String'(Unique_Name (E)),
Scope_Num => 0, File_Num => Dspec,
Spec_File_Num => 0, Scope_Num => Scope_Id,
Spec_Scope_Num => 0, Spec_File_Num => 0,
Line => Nat (Get_Logical_Line_Number (Loc)), Spec_Scope_Num => 0,
Stype => Typ, Line => Nat (Get_Logical_Line_Number (Loc)),
Col => Nat (Get_Column_Number (Loc)), Stype => Typ,
From_Xref => 1, Col => Nat (Get_Column_Number (Loc)),
To_Xref => 0, From_Xref => 1,
Scope_Entity => E)); To_Xref => 0,
end Add_SPARK_Scope; Scope_Entity => E));
Scope_Id := Scope_Id + 1;
end Add_SPARK_Scope;
--------------------------------
-- Detect_And_Add_SPARK_Scope --
--------------------------------
procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is
begin
if Nkind_In (N, N_Entry_Body, -- entries
N_Entry_Declaration)
or else
Nkind_In (N, N_Package_Body, -- packages
N_Package_Body_Stub,
N_Package_Declaration)
or else
Nkind_In (N, N_Protected_Body, -- protected objects
N_Protected_Body_Stub,
N_Protected_Type_Declaration)
or else
Nkind_In (N, N_Subprogram_Body, -- subprograms
N_Subprogram_Body_Stub,
N_Subprogram_Declaration)
or else
Nkind_In (N, N_Task_Body, -- tasks
N_Task_Body_Stub,
N_Task_Type_Declaration)
then
Add_SPARK_Scope (N);
end if;
end Detect_And_Add_SPARK_Scope;
procedure Traverse_Scopes is new
Traverse_Compilation_Unit (Detect_And_Add_SPARK_Scope);
-- Start of processing for Add_SPARK_File
begin
-- Source file could be inexistant as a result of an error, if option
-- gnatQ is used.
if File = No_Source_File then
return;
end if;
-- Subunits are traversed as part of the top-level unit to which they
-- belong.
if Nkind (Unit (Cunit (Uspec))) = N_Subunit then
return;
end if;
Traverse_Scopes (CU => Cunit (Uspec), Inside_Stubs => True);
-- When two units are present for the same compilation unit, as it
-- happens for library-level instantiations of generics, then add all
-- scopes to the same SPARK file.
if Ubody /= No_Unit then
Traverse_Scopes (CU => Cunit (Ubody), Inside_Stubs => True);
end if;
-- Make entry for new file in file table
Get_Name_String (Reference_Name (File));
File_Name := new String'(Name_Buffer (1 .. Name_Len));
-- For subunits, also retrieve the file name of the unit. Only do so if
-- unit has an associated compilation unit.
if Present (Cunit (Unit (File)))
and then Nkind (Unit (Cunit (Unit (File)))) = N_Subunit
then
Get_Name_String (Reference_Name (Main_Source_File));
Unit_File_Name := new String'(Name_Buffer (1 .. Name_Len));
else
Unit_File_Name := null;
end if;
SPARK_File_Table.Append (
(File_Name => File_Name,
Unit_File_Name => Unit_File_Name,
File_Num => Dspec,
From_Scope => From,
To_Scope => SPARK_Scope_Table.Last));
end Add_SPARK_File;
--------------------- ---------------------
-- Add_SPARK_Xrefs -- -- Add_SPARK_Xrefs --
...@@ -905,8 +900,17 @@ package body SPARK_Specific is ...@@ -905,8 +900,17 @@ package body SPARK_Specific is
(Sdep_Table : Unit_Ref_Table; (Sdep_Table : Unit_Ref_Table;
Num_Sdep : Nat) Num_Sdep : Nat)
is is
D1 : Pos; Sdep, Sdep_Next : Pos;
D2 : Pos; -- Index of the current and next source dependency
Sdep_File : Pos;
-- Index of the file to which the scopes need to be assigned; for
-- library-level instances of generic units this points to the unit
-- of the body, because this is where references are assigned to.
Uspec, Ubody : Unit_Number_Type;
-- Unit numbers for the dependency spec and possibly its body (only in
-- the case of library-level instance of a generic package).
begin begin
-- Cross-references should have been computed first -- Cross-references should have been computed first
...@@ -917,70 +921,82 @@ package body SPARK_Specific is ...@@ -917,70 +921,82 @@ package body SPARK_Specific is
-- Generate file and scope SPARK cross-reference information -- Generate file and scope SPARK cross-reference information
D1 := 1; Sdep := 1;
while D1 <= Num_Sdep loop while Sdep <= Num_Sdep loop
-- In rare cases, when treating the library-level instantiation of a -- For library-level instantiation of a generic, two consecutive
-- generic, two consecutive units refer to the same compilation unit -- units refer to the same compilation unit node and entity (one to
-- node and entity. In that case, treat them as a single unit for the -- body, one to spec). In that case, treat them as a single unit for
-- sake of SPARK cross references by passing to Add_SPARK_File. -- the sake of SPARK cross references by passing to Add_SPARK_File.
if D1 < Num_Sdep if Sdep < Num_Sdep
and then Cunit_Entity (Sdep_Table (D1)) = and then Cunit_Entity (Sdep_Table (Sdep)) =
Cunit_Entity (Sdep_Table (D1 + 1)) Cunit_Entity (Sdep_Table (Sdep + 1))
then then
declare declare
Cunit1 : Node_Id renames Cunit (Sdep_Table (D1)); Cunit1 : Node_Id renames Cunit (Sdep_Table (Sdep));
Cunit2 : Node_Id renames Cunit (Sdep_Table (D1 + 1)); Cunit2 : Node_Id renames Cunit (Sdep_Table (Sdep + 1));
begin begin
-- Both Cunit point to compilation unit nodes -- Both Cunit point to compilation unit nodes
pragma Assert (Nkind (Cunit1) = N_Compilation_Unit
pragma Assert and then
(Nkind (Cunit1) = N_Compilation_Unit Nkind (Cunit2) = N_Compilation_Unit);
and then Nkind (Cunit2) = N_Compilation_Unit);
-- Do not depend on the sorting order, which is based on -- Do not depend on the sorting order, which is based on
-- Unit_Name and for library-level instances of nested -- Unit_Name and for library-level instances of nested
-- generic-packages they are equal. -- generic-packages they are equal.
-- If declaration comes before the body then just set D2 -- If declaration comes before the body
if Nkind (Unit (Cunit1)) = N_Package_Declaration if Nkind (Unit (Cunit1)) = N_Package_Declaration
and then Nkind (Unit (Cunit2)) = N_Package_Body and then
Nkind (Unit (Cunit2)) = N_Package_Body
then then
D2 := D1 + 1; Uspec := Sdep_Table (Sdep);
Ubody := Sdep_Table (Sdep + 1);
Sdep_File := Sdep + 1;
-- If body comes before declaration then set D2 and adjust D1 -- If body comes before declaration
elsif Nkind (Unit (Cunit1)) = N_Package_Body elsif Nkind (Unit (Cunit1)) = N_Package_Body
and then Nkind (Unit (Cunit2)) = N_Package_Declaration and then
Nkind (Unit (Cunit2)) = N_Package_Declaration
then then
D2 := D1; Uspec := Sdep_Table (Sdep + 1);
D1 := D1 + 1; Ubody := Sdep_Table (Sdep);
Sdep_File := Sdep;
-- Otherwise it is an error
else else
raise Program_Error; raise Program_Error;
end if; end if;
Sdep_Next := Sdep + 2;
end; end;
else else
D2 := D1; Uspec := Sdep_Table (Sdep);
Ubody := No_Unit;
Sdep_File := Sdep;
Sdep_Next := Sdep + 1;
end if; end if;
-- Skip dependencies with no entity node, e.g. configuration files -- Skip dependencies with no entity node, e.g. configuration files
-- with pragmas (.adc) or target description (.atp), since they -- with pragmas (.adc) or target description (.atp), since they
-- present no interest for SPARK cross references. -- present no interest for SPARK cross references.
if Present (Cunit_Entity (Sdep_Table (D1))) then if Present (Cunit_Entity (Uspec)) then
Add_SPARK_File Add_SPARK_File
(Ubody => Sdep_Table (D1), (Uspec => Uspec,
Uspec => Sdep_Table (D2), Ubody => Ubody,
Dspec => D2); Dspec => Sdep_File);
end if; end if;
-- ??? this needs a comment Sdep := Sdep_Next;
D1 := Pos'Max (D1, D2) + 1;
end loop; end loop;
-- Fill in the spec information when relevant -- Fill in the spec information when relevant
...@@ -1037,35 +1053,6 @@ package body SPARK_Specific is ...@@ -1037,35 +1053,6 @@ package body SPARK_Specific is
Add_SPARK_Xrefs; Add_SPARK_Xrefs;
end Collect_SPARK_Xrefs; end Collect_SPARK_Xrefs;
--------------------------------
-- Detect_And_Add_SPARK_Scope --
--------------------------------
procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is
begin
if Nkind_In (N, N_Entry_Body, -- entries
N_Entry_Declaration)
or else
Nkind_In (N, N_Package_Body, -- packages
N_Package_Body_Stub,
N_Package_Declaration)
or else
Nkind_In (N, N_Protected_Body, -- protected objects
N_Protected_Body_Stub,
N_Protected_Type_Declaration)
or else
Nkind_In (N, N_Subprogram_Body, -- subprograms
N_Subprogram_Body_Stub,
N_Subprogram_Declaration)
or else
Nkind_In (N, N_Task_Body, -- tasks
N_Task_Body_Stub,
N_Task_Type_Declaration)
then
Add_SPARK_Scope (N);
end if;
end Detect_And_Add_SPARK_Scope;
------------------------------------- -------------------------------------
-- Enclosing_Subprogram_Or_Package -- -- Enclosing_Subprogram_Or_Package --
------------------------------------- -------------------------------------
...@@ -1245,65 +1232,44 @@ package body SPARK_Specific is ...@@ -1245,65 +1232,44 @@ package body SPARK_Specific is
procedure Traverse_Compilation_Unit procedure Traverse_Compilation_Unit
(CU : Node_Id; (CU : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean) Inside_Stubs : Boolean)
is is
Lu : Node_Id; Lu : Node_Id;
begin procedure Traverse_Block (N : Node_Id);
-- Get Unit (checking case of subunit) procedure Traverse_Declarations_And_HSS (N : Node_Id);
procedure Traverse_Declaration_Or_Statement (N : Node_Id);
Lu := Unit (CU); procedure Traverse_Declarations_Or_Statements (L : List_Id);
procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
if Nkind (Lu) = N_Subunit then procedure Traverse_Package_Body (N : Node_Id);
Lu := Proper_Body (Lu); procedure Traverse_Visible_And_Private_Parts (N : Node_Id);
end if; procedure Traverse_Protected_Body (N : Node_Id);
procedure Traverse_Subprogram_Body (N : Node_Id);
-- Do not add scopes for generic units procedure Traverse_Task_Body (N : Node_Id);
if Nkind (Lu) = N_Package_Body -- Traverse corresponding construct, calling Process on all declarations
and then Ekind (Corresponding_Spec (Lu)) in Generic_Unit_Kind
then
return;
end if;
-- Call Process on all declarations
if Nkind (Lu) in N_Declaration
or else Nkind (Lu) in N_Later_Decl_Item
then
Process (Lu);
end if;
-- Traverse the unit --------------------
-- Traverse_Block --
--------------------
Traverse_Declaration_Or_Statement (Lu, Process, Inside_Stubs); procedure Traverse_Block (N : Node_Id) renames
end Traverse_Compilation_Unit; Traverse_Declarations_And_HSS;
--------------------------------------- ---------------------------------------
-- Traverse_Declaration_Or_Statement -- -- Traverse_Declaration_Or_Statement --
--------------------------------------- ---------------------------------------
procedure Traverse_Declaration_Or_Statement procedure Traverse_Declaration_Or_Statement (N : Node_Id)
(N : Node_Id; is
Process : Node_Processing; begin
Inside_Stubs : Boolean) case Nkind (N) is
is
begin
case Nkind (N) is
when N_Package_Declaration => when N_Package_Declaration =>
declare Traverse_Visible_And_Private_Parts (Specification (N));
Spec : constant Node_Id := Specification (N);
begin
Traverse_Declarations_Or_Statements
(Visible_Declarations (Spec), Process, Inside_Stubs);
Traverse_Declarations_Or_Statements
(Private_Declarations (Spec), Process, Inside_Stubs);
end;
when N_Package_Body => when N_Package_Body =>
if Ekind (Defining_Entity (N)) /= E_Generic_Package then if Ekind (Defining_Entity (N)) /= E_Generic_Package then
Traverse_Package_Body (N, Process, Inside_Stubs); Traverse_Package_Body (N);
end if; end if;
when N_Package_Body_Stub => when N_Package_Body_Stub =>
...@@ -1315,19 +1281,19 @@ package body SPARK_Specific is ...@@ -1315,19 +1281,19 @@ package body SPARK_Specific is
and then and then
Ekind (Defining_Entity (Body_N)) /= E_Generic_Package Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
then then
Traverse_Package_Body (Body_N, Process, Inside_Stubs); Traverse_Package_Body (Body_N);
end if; end if;
end; end;
end if; end if;
when N_Subprogram_Declaration => when N_Subprogram_Body =>
null;
when N_Entry_Body | N_Subprogram_Body =>
if not Is_Generic_Subprogram (Defining_Entity (N)) then if not Is_Generic_Subprogram (Defining_Entity (N)) then
Traverse_Subprogram_Body (N, Process, Inside_Stubs); Traverse_Subprogram_Body (N);
end if; end if;
when N_Entry_Body =>
Traverse_Subprogram_Body (N);
when N_Subprogram_Body_Stub => when N_Subprogram_Body_Stub =>
if Present (Library_Unit (N)) then if Present (Library_Unit (N)) then
declare declare
...@@ -1337,75 +1303,45 @@ package body SPARK_Specific is ...@@ -1337,75 +1303,45 @@ package body SPARK_Specific is
and then and then
not Is_Generic_Subprogram (Defining_Entity (Body_N)) not Is_Generic_Subprogram (Defining_Entity (Body_N))
then then
Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs); Traverse_Subprogram_Body (Body_N);
end if; end if;
end; end;
end if; end if;
when N_Protected_Body => when N_Protected_Body =>
Traverse_Protected_Body (N, Process, Inside_Stubs); Traverse_Protected_Body (N);
when N_Protected_Body_Stub => when N_Protected_Body_Stub =>
if Present (Library_Unit (N)) then if Present (Library_Unit (N)) then
declare if Inside_Stubs then
Body_N : constant Node_Id := Get_Body_From_Stub (N); Traverse_Protected_Body (Get_Body_From_Stub (N));
begin end if;
if Inside_Stubs then
Traverse_Declarations_Or_Statements
(Declarations (Body_N), Process, Inside_Stubs);
end if;
end;
end if; end if;
when N_Protected_Type_Declaration | N_Single_Protected_Declaration => when N_Protected_Type_Declaration | N_Single_Protected_Declaration =>
declare Traverse_Visible_And_Private_Parts (Protected_Definition (N));
Def : constant Node_Id := Protected_Definition (N);
begin
Traverse_Declarations_Or_Statements
(Visible_Declarations (Def), Process, Inside_Stubs);
Traverse_Declarations_Or_Statements
(Private_Declarations (Def), Process, Inside_Stubs);
end;
when N_Task_Definition => when N_Task_Definition =>
Traverse_Declarations_Or_Statements Traverse_Visible_And_Private_Parts (N);
(Visible_Declarations (N), Process, Inside_Stubs);
Traverse_Declarations_Or_Statements
(Private_Declarations (N), Process, Inside_Stubs);
when N_Task_Body => when N_Task_Body =>
Traverse_Declarations_Or_Statements Traverse_Task_Body (N);
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
when N_Task_Body_Stub => when N_Task_Body_Stub =>
if Present (Library_Unit (N)) then if Present (Library_Unit (N)) then
declare if Inside_Stubs then
Body_N : constant Node_Id := Get_Body_From_Stub (N); Traverse_Task_Body (Get_Body_From_Stub (N));
begin end if;
if Inside_Stubs then
Traverse_Declarations_Or_Statements
(Declarations (Body_N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (Body_N), Process,
Inside_Stubs);
end if;
end;
end if; end if;
when N_Block_Statement => when N_Block_Statement =>
Traverse_Declarations_Or_Statements Traverse_Block (N);
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
when N_If_Statement => when N_If_Statement =>
-- Traverse the statements in the THEN part -- Traverse the statements in the THEN part
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements (Then_Statements (N));
(Then_Statements (N), Process, Inside_Stubs);
-- Loop through ELSIF parts if present -- Loop through ELSIF parts if present
...@@ -1416,7 +1352,7 @@ package body SPARK_Specific is ...@@ -1416,7 +1352,7 @@ package body SPARK_Specific is
begin begin
while Present (Elif) loop while Present (Elif) loop
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements
(Then_Statements (Elif), Process, Inside_Stubs); (Then_Statements (Elif));
Next (Elif); Next (Elif);
end loop; end loop;
end; end;
...@@ -1424,8 +1360,7 @@ package body SPARK_Specific is ...@@ -1424,8 +1360,7 @@ package body SPARK_Specific is
-- Finally traverse the ELSE statements if present -- Finally traverse the ELSE statements if present
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements (Else_Statements (N));
(Else_Statements (N), Process, Inside_Stubs);
when N_Case_Statement => when N_Case_Statement =>
...@@ -1436,129 +1371,154 @@ package body SPARK_Specific is ...@@ -1436,129 +1371,154 @@ package body SPARK_Specific is
begin begin
Alt := First (Alternatives (N)); Alt := First (Alternatives (N));
while Present (Alt) loop while Present (Alt) loop
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements (Statements (Alt));
(Statements (Alt), Process, Inside_Stubs);
Next (Alt); Next (Alt);
end loop; end loop;
end; end;
when N_Extended_Return_Statement => when N_Extended_Return_Statement =>
Traverse_Handled_Statement_Sequence Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs); (Handled_Statement_Sequence (N));
when N_Loop_Statement => when N_Loop_Statement =>
Traverse_Declarations_Or_Statements Traverse_Declarations_Or_Statements (Statements (N));
(Statements (N), Process, Inside_Stubs);
-- Generic declarations are ignored -- Generic declarations are ignored
when others => when others =>
null; null;
end case; end case;
end Traverse_Declaration_Or_Statement; end Traverse_Declaration_Or_Statement;
----------------------------------------- -----------------------------------
-- Traverse_Declarations_Or_Statements -- -- Traverse_Declarations_And_HSS --
----------------------------------------- -----------------------------------
procedure Traverse_Declarations_Or_Statements procedure Traverse_Declarations_And_HSS (N : Node_Id)
(L : List_Id; is
Process : Node_Processing; begin
Inside_Stubs : Boolean) Traverse_Declarations_Or_Statements (Declarations (N));
is Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
N : Node_Id; end Traverse_Declarations_And_HSS;
begin -----------------------------------------
-- Loop through statements or declarations -- Traverse_Declarations_Or_Statements --
-----------------------------------------
N := First (L); procedure Traverse_Declarations_Or_Statements (L : List_Id)
while Present (N) loop is
-- Call Process on all declarations N : Node_Id;
if Nkind (N) in N_Declaration begin
-- Loop through statements or declarations
N := First (L);
while Present (N) loop
-- Call Process on all declarations
if Nkind (N) in N_Declaration
or else or else
Nkind (N) in N_Later_Decl_Item Nkind (N) in N_Later_Decl_Item
or else or else
Nkind (N) = N_Entry_Body Nkind (N) = N_Entry_Body
then then
Process (N); Process (N);
end if;
Traverse_Declaration_Or_Statement (N);
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 if;
end Traverse_Handled_Statement_Sequence;
Traverse_Declaration_Or_Statement (N, Process, Inside_Stubs); ---------------------------
-- Traverse_Package_Body --
---------------------------
Next (N); procedure Traverse_Package_Body (N : Node_Id) renames
end loop; Traverse_Declarations_And_HSS;
end Traverse_Declarations_Or_Statements;
----------------------------------------- -----------------------------
-- Traverse_Handled_Statement_Sequence -- -- Traverse_Protected_Body --
----------------------------------------- -----------------------------
procedure Traverse_Handled_Statement_Sequence procedure Traverse_Protected_Body (N : Node_Id) is
(N : Node_Id; begin
Process : Node_Processing; Traverse_Declarations_Or_Statements (Declarations (N));
Inside_Stubs : Boolean) end Traverse_Protected_Body;
is
Handler : Node_Id; ------------------------------
-- Traverse_Subprogram_Body --
------------------------------
procedure Traverse_Subprogram_Body (N : Node_Id) renames
Traverse_Declarations_And_HSS;
------------------------
-- Traverse_Task_Body --
------------------------
procedure Traverse_Task_Body (N : Node_Id) renames
Traverse_Declarations_And_HSS;
procedure Traverse_Visible_And_Private_Parts (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Visible_Declarations (N));
Traverse_Declarations_Or_Statements (Private_Declarations (N));
end Traverse_Visible_And_Private_Parts;
-- Start of processing for Traverse_Compilation_Unit
begin begin
if Present (N) then -- Get Unit (checking case of subunit)
Traverse_Declarations_Or_Statements
(Statements (N), Process, Inside_Stubs); Lu := Unit (CU);
if Present (Exception_Handlers (N)) then if Nkind (Lu) = N_Subunit then
Handler := First (Exception_Handlers (N)); Lu := Proper_Body (Lu);
while Present (Handler) loop
Traverse_Declarations_Or_Statements
(Statements (Handler), Process, Inside_Stubs);
Next (Handler);
end loop;
end if;
end if; end if;
end Traverse_Handled_Statement_Sequence;
--------------------------- -- Do not add scopes for generic units
-- Traverse_Package_Body --
---------------------------
procedure Traverse_Package_Body if Nkind (Lu) = N_Package_Body
(N : Node_Id; and then Ekind (Corresponding_Spec (Lu)) in Generic_Unit_Kind
Process : Node_Processing; then
Inside_Stubs : Boolean) is return;
begin end if;
Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N), Process, Inside_Stubs);
end Traverse_Package_Body;
-----------------------------
-- Traverse_Protected_Body --
-----------------------------
procedure Traverse_Protected_Body
(N : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean) is
begin
Traverse_Declarations_Or_Statements
(Declarations (N), Process, Inside_Stubs);
end Traverse_Protected_Body;
------------------------------ -- Call Process on all declarations
-- Traverse_Subprogram_Body --
------------------------------
procedure Traverse_Subprogram_Body if Nkind (Lu) in N_Declaration
(N : Node_Id; or else Nkind (Lu) in N_Later_Decl_Item
Process : Node_Processing; then
Inside_Stubs : Boolean) Process (Lu);
is end if;
begin
Traverse_Declarations_Or_Statements -- Traverse the unit
(Declarations (N), Process, Inside_Stubs);
Traverse_Handled_Statement_Sequence Traverse_Declaration_Or_Statement (Lu);
(Handled_Statement_Sequence (N), Process, Inside_Stubs); end Traverse_Compilation_Unit;
end Traverse_Subprogram_Body;
end SPARK_Specific; end SPARK_Specific;
gcc/ada/lib-xref.ads
...@@ -639,16 +639,6 @@ package Lib.Xref is ...@@ -639,16 +639,6 @@ package Lib.Xref is
-- This procedure is called to record a dereference. N is the location -- This procedure is called to record a dereference. N is the location
-- of the dereference. -- of the dereference.
type Node_Processing is access procedure (N : Node_Id);
procedure Traverse_Compilation_Unit
(CU : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
-- Call Process on all declarations in compilation unit CU. If
-- Inside_Stubs is True, then the body of stubs is also traversed.
-- Generic declarations are ignored.
procedure Collect_SPARK_Xrefs procedure Collect_SPARK_Xrefs
(Sdep_Table : Unit_Ref_Table; (Sdep_Table : Unit_Ref_Table;
Num_Sdep : Nat); Num_Sdep : Nat);
......
gcc/ada/spark_xrefs.ads
...@@ -285,7 +285,7 @@ package SPARK_Xrefs is ...@@ -285,7 +285,7 @@ package SPARK_Xrefs is
File_Num : Nat; File_Num : Nat;
-- Set to the file dependency number for the scope -- Set to the file dependency number for the scope
Scope_Num : Nat; Scope_Num : Pos;
-- Set to the scope number for the scope -- Set to the scope number for the scope
Spec_File_Num : Nat; Spec_File_Num : Nat;
......
gcc/ada/types.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -554,7 +554,7 @@ package Types is ...@@ -554,7 +554,7 @@ package Types is
-- Types used for Library Management -- -- Types used for Library Management --
--------------------------------------- ---------------------------------------
type Unit_Number_Type is new Int; type Unit_Number_Type is new Int range -1 .. Int'Last;
-- Unit number. The main source is unit 0, and subsidiary sources have -- Unit number. The main source is unit 0, and subsidiary sources have
-- non-zero numbers starting with 1. Unit numbers are used to index the -- non-zero numbers starting with 1. Unit numbers are used to index the
-- Units table in package Lib. -- Units table in package Lib.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment