git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

debug.adb: Add -gnatd.O to output SCO table 

2009-07-15  Robert Dewar  <dewar@adacore.com>

	* debug.adb: Add -gnatd.O to output SCO table

	* lib-writ.adb (Write_Unit_Information): Use SCO_Output to output SCO
	information.

	* lib-writ.ads: Document addition of SCO lines to ALI file

	* par_sco.ads, par_sco.adb: New files.

	* opt.ads (Generate_SCO): New switch

	* par.adb (Par): Call SCO_Record to record SCO information

	* sem_warn.adb (Warn_On_Constant_Condition): Adjust SCO condition

	* switch-c.adb: Recognize -gnateS to generate SCO information

	* usage.adb: Add line for -gnateS

	* gcc-interface/Make-lang.in: Add dependency on par_sco.o for gnat1

From-SVN: r149669
This commit is contained in:
Robert Dewar 2009-07-15 09:59:16 +00:00 committed by Arnaud Charlet
parent 3a33626201
commit 6f12117afc
12 changed files with 1270 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/ada/ChangeLog
View File

@ -1,3 +1,26 @@
2009-07-15 Robert Dewar <dewar@adacore.com>
* debug.adb: Add -gnatd.O to output SCO table
* lib-writ.adb (Write_Unit_Information): Use SCO_Output to output SCO
information.
* lib-writ.ads: Document addition of SCO lines to ALI file
* par_sco.ads, par_sco.adb: New files.
* opt.ads (Generate_SCO): New switch
* par.adb (Par): Call SCO_Record to record SCO information
* sem_warn.adb (Warn_On_Constant_Condition): Adjust SCO condition
* switch-c.adb: Recognize -gnateS to generate SCO information
* usage.adb: Add line for -gnateS
* gcc-interface/Make-lang.in: Add dependency on par_sco.o for gnat1
2009-07-15 Sergey Rybin <rybin@adacore.com>
* tree_in.ads, tree_io.ads: Add pragma Warnings Off/On for with clause

6
gcc/ada/debug.adb
View File

@ -126,13 +126,13 @@ package body Debug is
-- d.F
-- d.G
-- d.H
-- d.I Inspector mode
-- d.I SCIL generation mode
-- d.J
-- d.K
-- d.L
-- d.M
-- d.N
-- d.O
-- d.O Dump internal SCO table
-- d.P
-- d.Q
-- d.R
@ -559,6 +559,8 @@ package body Debug is
-- byte code, even in case of unsupported construct, for the sake
-- of static analysis tools.
-- d.O Dump internal SCO (Source Coverage Obligation) table in Par_Sco
-- d.S Force Optimize_Alignment (Space) mode as the default
-- d.T Force Optimize_Alignment (Time) mode as the default

7
gcc/ada/gcc-interface/Make-lang.in
View File

@ -139,7 +139,7 @@ GNAT_ADA_OBJS = ada/s-bitops.o ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-exc
ada/lib-load.o ada/lib-util.o ada/lib-xref.o ada/lib-writ.o ada/live.o \
ada/namet.o ada/namet-sp.o \
ada/nlists.o ada/nmake.o ada/opt.o ada/osint.o ada/osint-c.o \
ada/output.o \
ada/output.o ada/par_sco.o \
ada/par.o ada/prep.o ada/prepcomp.o ada/repinfo.o ada/restrict.o \
ada/rident.o ada/rtsfind.o \
ada/s-addope.o ada/s-assert.o ada/s-parame.o ada/s-stache.o \
@ -2765,6 +2765,11 @@ ada/par.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \
ada/widechar.ads
ada/par_sco.o : ada/par_sco.ads ada/par_sco.adb ada/types.ads \
ada/atree.ads ada/debug.ads ada/lib.ads ada/lib-util.ads ada/nlists.ads \
ada/output.ads ada/sinfo.ads ada/sinput.ads ada/table.ads \
ada/g-htable.ads ada/snames.ads
ada/prep.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/csets.ads \
ada/debug.ads ada/err_vars.ads ada/gnat.ads ada/g-dyntab.ads \

9
gcc/ada/lib-writ.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2009, 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- --
@ -38,6 +38,7 @@ with Opt; use Opt;
with Osint; use Osint;
with Osint.C; use Osint.C;
with Par;
with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Scn; use Scn;
@ -631,6 +632,12 @@ package body Lib.Writ is
end if;
end;
end loop;
-- Output SCO information if present
if Generate_SCO then
SCO_Output (Unit_Num);
end if;
end Write_Unit_Information;
----------------------

10
gcc/ada/lib-writ.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2009, 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- --
@ -579,6 +579,14 @@ package Lib.Writ is
-- the source file, so that this order is preserved by the binder
-- in constructing the set of linker arguments.
-- ------------------------------------
-- -- C Source Coverage Obligations --
-- -------------------------------------
-- Following the L lines (if any) are the SCO (Source Coverage Obligation)
-- lines if they are being generated. For the full format of these lines,
-- see the spec of Par_SCO.
---------------------
-- Reference Lines --
---------------------

6
gcc/ada/opt.ads
View File

@ -550,6 +550,12 @@ package Opt is
-- True when switch -gnateG is used. When True, create in a file
-- <source>.prep, if the source is preprocessed.
Generate_SCO : Boolean := False;
-- GNAT
-- True when switch -gnateS is used. When True, Source Coverage Obligation
-- (SCO) information is generated and output in the ALI file. See unit
-- Sem_SCO for full details.
Generating_Code : Boolean := False;
-- GNAT
-- True if the frontend finished its work and has called the backend to

16
gcc/ada/par.adb
View File

@ -35,6 +35,7 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
with Par_SCO; use Par_SCO;
with Scans; use Scans;
with Scn; use Scn;
with Sinput; use Sinput;
@ -51,6 +52,7 @@ with Tbuild; use Tbuild;
---------
function Par (Configuration_Pragmas : Boolean) return List_Id is
Num_Library_Units : Natural := 0;
-- Count number of units parsed (relevant only in syntax check only mode,
-- since in semantics check mode only a single unit is permitted anyway)
@ -1453,9 +1455,17 @@ begin
pragma Assert (Scope.Last = 0);
-- Remaining steps are to create implicit label declarations and to
-- load required subsidiary sources. These steps are required only
-- if we are doing semantic checking.
-- This is where we generate SCO output if required
if Generate_SCO
and then Operating_Mode = Generate_Code
then
SCO_Record (Current_Source_Unit);
end if;
-- Remaining steps are to create implicit label declarations and to load
-- required subsidiary sources. These steps are required only if we are
-- doing semantic checking.
if Operating_Mode /= Check_Syntax or else Debug_Flag_F then
Par.Labl;

956
gcc/ada/par_sco.adb Normal file
View File

@ -0,0 +1,956 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P A R _ S C O --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Debug; use Debug;
with Lib; use Lib;
with Lib.Util; use Lib.Util;
with Nlists; use Nlists;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Table;
with GNAT.HTable; use GNAT.HTable;
package body Par_SCO is
---------------
-- SCO_Table --
---------------
-- Internal table used to store recorded SCO values. Table is populated by
-- calls to SCO_Record, and entries may be modified by Set_SCO_Condition.
type SCO_Table_Entry is record
From : Source_Ptr;
To : Source_Ptr;
C1 : Character;
C2 : Character;
Last : Boolean;
end record;
package SCO_Table is new Table.Table (
Table_Component_Type => SCO_Table_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 500,
Table_Increment => 300,
Table_Name => "SCO_Table_Entry");
-- The SCO_Table_Entry values appear as follows:
-- Statements
-- C1 = 'S'
-- C2 = ' '
-- From = starting sloc
-- To = ending sloc
-- Last = unused
-- Entry
-- C1 = 'Y'
-- C2 = ' '
-- From = starting sloc
-- To = ending sloc
-- Last = unused
-- Exit
-- C1 = 'T'
-- C2 = ' '
-- From = starting sloc
-- To = ending sloc
-- Last = unused
-- Simple Decision
-- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression)
-- C2 = 'c', 't', or 'f'
-- From = starting sloc
-- To = ending sloc
-- Last = True
-- Complex Decision
-- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression)
-- C2 = ' '
-- From = No_Location
-- To = No_Location
-- Last = False
-- Operator
-- C1 = '!', '^', '&', '|'
-- C2 = ' '
-- From = No_Location
-- To = No_Location
-- Last = False
-- Element
-- C1 = ' '
-- C2 = 'c', 't', or 'f' (condition/true/false)
-- From = starting sloc
-- To = ending sloc
-- Last = False for all but the last entry, True for last entry
-- Note: the sequence starting with a decision, and continuing with
-- operators and elements up to and including the first one labeled with
-- Last=True, indicate the sequence to be output for a complex decision
-- on a single CD decision line.
----------------
-- Unit Table --
----------------
-- This table keeps track of the units and the corresponding starting index
-- in the SCO table. The ending index is either one less than the starting
-- index of the next table entry, or, for the last table entry, it is
-- SCO_Table.Last.
type SCO_Unit_Table_Entry is record
Unit : Unit_Number_Type;
Index : Int;
end record;
package SCO_Unit_Table is new Table.Table (
Table_Component_Type => SCO_Unit_Table_Entry,
Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 200,
Table_Name => "SCO_Unit_Table_Entry");
--------------------------
-- Condition Hash Table --
--------------------------
-- We need to be able to get to conditions quickly for handling the calls
-- to Set_SCO_Condition efficiently. For this purpose we identify the
-- conditions in the table by their starting sloc, and use the following
-- hash table to map from these starting sloc values to SCO_Table indexes.
type Header_Num is new Integer range 0 .. 996;
-- Type for hash table headers
function Hash (F : Source_Ptr) return Header_Num;
-- Function to Hash source pointer value
function Equal (F1, F2 : Source_Ptr) return Boolean;
-- Function to test two keys for equality
package Condition_Hash_Table is new Simple_HTable
(Header_Num, Int, 0, Source_Ptr, Hash, Equal);
-- The actual hash table
--------------------------
-- Internal Subprograms --
--------------------------
function Has_Decision (N : Node_Id) return Boolean;
-- N is the node for a subexpression. Returns True if the subexpression
-- contains a nested decision (i.e. either is a logical operator, or
-- contains a logical operator in its subtree).
function Is_Logical_Operator (N : Node_Id) return Boolean;
-- N is the node for a subexpression. This procedure just tests N to see
-- if it is a logical operator (including short circuit conditions) and
-- returns True if so, False otherwise, it does no other processing.
procedure Process_Decisions (N : Node_Id; T : Character);
-- If N is Empty, has no effect. Otherwise scans the tree for the node N,
-- to output any decisions it contains. T is one of IEWX (for context of
-- expresion: if/while/when-exit/expression). If T is other than X, then
-- the node is always a decision a decision is always present (at the very
-- least a simple decision is present at the top level).
procedure Set_Table_Entry
(C1 : Character;
C2 : Character;
From : Source_Ptr;
To : Source_Ptr;
Last : Boolean);
-- Append an entry to SCO_Table with fields set as per arguments
procedure Traverse_Declarations_Or_Statements (L : List_Id);
procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
procedure Traverse_Package_Body (N : Node_Id);
procedure Traverse_Package_Declaration (N : Node_Id);
procedure Traverse_Subprogram_Body (N : Node_Id);
-- Traverse the corresponding construct, generating SCO table entries
procedure dsco;
-- Debug routine to dump SCO table
----------
-- dsco --
----------
procedure dsco is
begin
Write_Line ("SCO Unit Table");
Write_Line ("--------------");
for Index in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop
Write_Str (" ");
Write_Int (Index);
Write_Str (". Unit = ");
Write_Int (Int (SCO_Unit_Table.Table (Index).Unit));
Write_Str (" Index = ");
Write_Int (Int (SCO_Unit_Table.Table (Index).Index));
Write_Eol;
end loop;
Write_Eol;
Write_Line ("SCO Table");
Write_Line ("---------");
for Index in SCO_Table.First .. SCO_Table.Last loop
declare
T : SCO_Table_Entry renames SCO_Table.Table (Index);
begin
Write_Str (" ");
Write_Int (Index);
Write_Str (". C1 = '");
Write_Char (T.C1);
Write_Str ("' C2 = '");
Write_Char (T.C2);
Write_Str ("' From = ");
Write_Location (T.From);
Write_Str (" To = ");
Write_Location (T.To);
Write_Str (" Last = ");
if T.Last then
Write_Str (" True");
else
Write_Str (" False");
end if;
Write_Eol;
end;
end loop;
end dsco;
-----------
-- Equal --
-----------
function Equal (F1, F2 : Source_Ptr) return Boolean is
begin
return F1 = F2;
end Equal;
------------------
-- Has_Decision --
------------------
function Has_Decision (N : Node_Id) return Boolean is
function Check_Node (N : Node_Id) return Traverse_Result;
----------------
-- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
begin
if Is_Logical_Operator (N) then
return Abandon;
else
return OK;
end if;
end Check_Node;
function Traverse is new Traverse_Func (Check_Node);
-- Start of processing for Has_Decision
begin
return Traverse (N) = Abandon;
end Has_Decision;
----------
-- Hash --
----------
function Hash (F : Source_Ptr) return Header_Num is
begin
return Header_Num (Nat (F) mod 997);
end Hash;
----------
-- Init --
----------
procedure Init is
begin
null;
end Init;
-------------------------
-- Is_Logical_Operator --
-------------------------
function Is_Logical_Operator (N : Node_Id) return Boolean is
begin
return Nkind_In (N, N_Op_And,
N_Op_Or,
N_Op_Xor,
N_Op_Not,
N_And_Then,
N_Or_Else);
end Is_Logical_Operator;
-----------------------
-- Process_Decisions --
-----------------------
procedure Process_Decisions
(N : Node_Id;
T : Character)
is
function Process_Node (N : Node_Id) return Traverse_Result;
-- Processes one node in the traversal, looking for logical operators,
-- and if one is found, outputs the appropriate table entries.
procedure Output_Decision_Operand (N : Node_Id);
-- The node N is the top level logical operator of a decision, or it is
-- one of the operands of a logical operator belonging to a single
-- complex decision. This routine outputs the sequence of table entries
-- corresponding to the node. Note that we do not process the sub-
-- operands to look for further decisions, that processing is done in
-- Process_Decision_Operand, because we can't get decisions mixed up in
-- the global table. Call has no effect if N is Empty.
procedure Output_Element (N : Node_Id; T : Character);
-- Node N is an operand of a logical operator that is not itself a
-- logical operator, or it is a simple decision. This routine outputs
-- the table entry for the element, with C1 set to T (' ' for one of
-- the elements of a complex decision, or 'I'/'W'/'E' for a simple
-- decision (from an IF, WHILE, or EXIT WHEN). Last is set to False,
-- and an entry is made in the condition hash table.
procedure Process_Decision_Operand (N : Node_Id);
-- This is called on node N, the top level node of a decision, or on one
-- of its operands or suboperands after generating the full output for
-- the complex decision. It process the suboperands of the decision
-- looking for nested decisions.
-----------------------------
-- Output_Decision_Operand --
-----------------------------
procedure Output_Decision_Operand (N : Node_Id) is
C : Character;
L : Node_Id;
FSloc : Source_Ptr;
LSloc : Source_Ptr;
begin
if No (N) then
return;
-- Logical operator
elsif Is_Logical_Operator (N) then
if Nkind (N) = N_Op_Not then
C := '!';
L := Empty;
else
L := Left_Opnd (N);
if Nkind (N) = N_Op_Xor then
C := '^';
elsif Nkind_In (N, N_Op_Or, N_Or_Else) then
C := '|';
else
C := '&';
end if;
end if;
Sloc_Range (N, FSloc, LSloc);
Set_Table_Entry (C, ' ', FSloc, LSloc, False);
Output_Decision_Operand (L);
Output_Decision_Operand (Right_Opnd (N));
-- Not a logical operator
else
Output_Element (N, ' ');
end if;
end Output_Decision_Operand;
--------------------
-- Output_Element --
--------------------
procedure Output_Element (N : Node_Id; T : Character) is
FSloc : Source_Ptr;
LSloc : Source_Ptr;
begin
Sloc_Range (N, FSloc, LSloc);
Set_Table_Entry (T, 'c', FSloc, LSloc, False);
Condition_Hash_Table.Set (FSloc, SCO_Table.Last);
end Output_Element;
------------------------------
-- Process_Decision_Operand --
------------------------------
procedure Process_Decision_Operand (N : Node_Id) is
begin
if Is_Logical_Operator (N) then
if Nkind (N) /= N_Op_Not then
Process_Decision_Operand (Left_Opnd (N));
end if;
Process_Decision_Operand (Right_Opnd (N));
else
Process_Decisions (N, 'X');
end if;
end Process_Decision_Operand;
------------------
-- Process_Node --
------------------
function Process_Node (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
-- Logical operators and short circuit forms, output table
-- entries and then process operands recursively to deal with
-- nested conditions.
when N_And_Then |
N_Or_Else |
N_Op_And |
N_Op_Or |
N_Op_Xor |
N_Op_Not =>
declare
T : Character;
begin
-- If outer level, then type comes from call, otherwise it
-- is more deeply nested and counts as X for expression.
if N = Process_Decisions.N then
T := Process_Decisions.T;
else
T := 'X';
end if;
-- Output header for sequence
Set_Table_Entry (T, ' ', No_Location, No_Location, False);
-- Output the decision
Output_Decision_Operand (N);
-- Change Last in last table entry to True to mark end
SCO_Table.Table (SCO_Table.Last).Last := True;
-- Process any embedded decisions
Process_Decision_Operand (N);
return Skip;
end;
-- Conditional expression, processed like an if statement
when N_Conditional_Expression =>
declare
Cond : constant Node_Id := First (Expressions (N));
Thnx : constant Node_Id := Next (Cond);
Elsx : constant Node_Id := Next (Thnx);
begin
Process_Decisions (Cond, 'I');
Process_Decisions (Thnx, 'X');
Process_Decisions (Elsx, 'X');
return Skip;
end;
-- All other cases, continue scan
when others =>
return OK;
end case;
end Process_Node;
procedure Traverse is new Traverse_Proc (Process_Node);
-- Start of processing for Process_Decisions
begin
if No (N) then
return;
end if;
-- See if we have simple decision at outer level and if so then
-- generate the decision entry for this simple decision. A simple
-- decision is a boolean expression (which is not a logical operator
-- or short circuit form) appearing as the operand of an IF, WHILE
-- or EXIT WHEN construct.
if T /= 'X' and then not Is_Logical_Operator (N) then
Output_Element (N, T);
-- Change Last in last table entry to True to mark end of
-- sequence, which is this case is only one element long.
SCO_Table.Table (SCO_Table.Last).Last := True;
end if;
Traverse (N);
end Process_Decisions;
----------------
-- SCO_Output --
----------------
procedure SCO_Output (U : Unit_Number_Type) is
Start : Nat;
Stop : Nat;
procedure Output_Range (From : Source_Ptr; To : Source_Ptr);
-- Outputs Sloc range in line:col-line:col format (for now we do not
-- worry about generic instantiations???)
------------------
-- Output_Range --
------------------
procedure Output_Range (From : Source_Ptr; To : Source_Ptr) is
begin
Write_Info_Nat (Int (Get_Logical_Line_Number (From)));
Write_Info_Char (':');
Write_Info_Nat (Int (Get_Column_Number (From)));
Write_Info_Char ('-');
Write_Info_Nat (Int (Get_Logical_Line_Number (To)));
Write_Info_Char (':');
Write_Info_Nat (Int (Get_Column_Number (To)));
end Output_Range;
-- Start of processing for SCO_Output
begin
if Debug_Flag_Dot_OO then
dsco;
end if;
-- Find entry in unit table and set Start/Stop bounds in SCO table
for J in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop
if U = SCO_Unit_Table.Table (J).Unit then
Start := SCO_Unit_Table.Table (J).Index;
if J = SCO_Unit_Table.Last then
Stop := SCO_Table.Last;
else
Stop := SCO_Unit_Table.Table (J + 1).Index - 1;
end if;
exit;
end if;
-- Seems like we should find the unit, but for now ignore ???
return;
end loop;
-- Loop through relevant entries in SCO table, outputting C lines
while Start <= Stop loop
declare
T : SCO_Table_Entry renames SCO_Table.Table (Start);
begin
Write_Info_Initiate ('C');
Write_Info_Char (T.C1);
case T.C1 is
-- Statements, entry, exit
when 'S' | 'Y' | 'T' =>
Write_Info_Char (' ');
Output_Range (T.From, T.To);
-- Decision
when 'I' | 'E' | 'W' | 'X' =>
if T.C2 = ' ' then
Start := Start + 1;
end if;
-- Loop through table entries for this decision
loop
declare
T : SCO_Table_Entry renames SCO_Table.Table (Start);
begin
Write_Info_Char (' ');
if T.C1 = '!' or else
T.C1 = '^' or else
T.C1 = '&' or else
T.C1 = '|'
then
Write_Info_Char (T.C1);
else
Write_Info_Char (T.C2);
Output_Range (T.From, T.To);
end if;
exit when T.Last;
Start := Start + 1;
end;
end loop;
when others =>
raise Program_Error;
end case;
Write_Info_Terminate;
end;
exit when Start = Stop;
Start := Start + 1;
pragma Assert (Start <= Stop);
end loop;
end SCO_Output;
----------------
-- SCO_Record --
----------------
procedure SCO_Record (U : Unit_Number_Type) is
Cu : constant Node_Id := Cunit (U);
Lu : constant Node_Id := Unit (Cu);
begin
SCO_Unit_Table.Append ((Unit => U, Index => SCO_Table.Last + 1));
-- Traverse the unit
if Nkind (Lu) = N_Subprogram_Body then
Traverse_Subprogram_Body (Lu);
elsif Nkind (Lu) = N_Package_Declaration then
Traverse_Package_Declaration (Lu);
elsif Nkind (Lu) = N_Package_Body then
Traverse_Package_Body (Lu);
-- Ignore subprogram specifications
-- Also for now, ignore generic declarations and instantiations
else
null;
end if;
end SCO_Record;
-----------------------
-- Set_SCO_Condition --
-----------------------
procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is
Index : constant Nat := Condition_Hash_Table.Get (First_Loc);
begin
if Index /= 0 then
SCO_Table.Table (Index).C2 := Typ;
end if;
end Set_SCO_Condition;
---------------------
-- Set_Table_Entry --
---------------------
procedure Set_Table_Entry
(C1 : Character;
C2 : Character;
From : Source_Ptr;
To : Source_Ptr;
Last : Boolean)
is
begin
SCO_Table.Append ((C1 => C1,
C2 => C2,
From => From,
To => To,
Last => Last));
end Set_Table_Entry;
-----------------------------------------
-- Traverse_Declarations_Or_Statements --
-----------------------------------------
procedure Traverse_Declarations_Or_Statements (L : List_Id) is
N : Node_Id;
Start : Source_Ptr;
Dummy : Source_Ptr;
Stop : Source_Ptr;
From : Source_Ptr;
To : Source_Ptr;
Term : Boolean;
-- Set False if current entity terminates statement list
procedure Set_Statement_Entry;
-- If Start is No_Location, does nothing, otherwise outputs a SCO_Table
-- statement entry for the range Start-Stop and then sets both Start
-- and Stop to No_Location. Unconditionally sets Term to True. This is
-- called when we find a statement or declaration that generates its
-- own table entry, so that we must end the current statement sequence.
-------------------------
-- Set_Statement_Entry --
-------------------------
procedure Set_Statement_Entry is
begin
Term := True;
if Start /= No_Location then
Set_Table_Entry ('S', ' ', Start, Stop, False);
Start := No_Location;
Stop := No_Location;
end if;
end Set_Statement_Entry;
-- Start of processing for Traverse_Declarations_Or_Statements
begin
if Is_Non_Empty_List (L) then
N := First (L);
Start := No_Location;
-- Loop through statements or declarations
while Present (N) loop
Term := False;
case Nkind (N) is
-- Package declaration
when N_Package_Declaration =>
Set_Statement_Entry;
Traverse_Package_Declaration (N);
-- Package body
when N_Package_Body =>
Set_Statement_Entry;
Traverse_Package_Body (N);
-- Subprogram_Body
when N_Subprogram_Body =>
Set_Statement_Entry;
Traverse_Subprogram_Body (N);
-- Exit statement
when N_Exit_Statement =>
Set_Statement_Entry;
Process_Decisions (Condition (N), 'E');
-- This is an exit point
Sloc_Range (N, From, To);
Set_Table_Entry ('T', ' ', From, To, False);
-- Block statement
when N_Block_Statement =>
Set_Statement_Entry;
Traverse_Declarations_Or_Statements (Declarations (N));
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N));
-- If statement
when N_If_Statement =>
Set_Statement_Entry;
Process_Decisions (Condition (N), 'I');
Traverse_Declarations_Or_Statements (Then_Statements (N));
if Present (Elsif_Parts (N)) then
declare
Elif : Node_Id := First (Elsif_Parts (N));
begin
while Present (Elif) loop
Process_Decisions (Condition (Elif), 'I');
Traverse_Declarations_Or_Statements
(Then_Statements (Elif));
Next (Elif);
end loop;
end;
end if;
Traverse_Declarations_Or_Statements (Else_Statements (N));
-- Unconditional exit points
when N_Requeue_Statement |
N_Goto_Statement |
N_Raise_Statement =>
Set_Statement_Entry;
Sloc_Range (N, From, To);
Set_Table_Entry ('T', ' ', From, To, False);
-- Simple return statement
when N_Simple_Return_Statement =>
Set_Statement_Entry;
-- Process possible return expression
Process_Decisions (Expression (N), 'X');
-- Return is an exit point
Sloc_Range (N, From, To);
Set_Table_Entry ('T', ' ', From, To, False);
-- Extended return statement
when N_Extended_Return_Statement =>
Set_Statement_Entry;
Traverse_Declarations_Or_Statements
(Return_Object_Declarations (N));
Traverse_Handled_Statement_Sequence
(Handled_Statement_Sequence (N));
-- Return is an exit point
Sloc_Range (N, From, To);
Set_Table_Entry ('T', ' ', From, To, False);
-- Loop
when N_Loop_Statement =>
-- Even if not a while loop, we want a new statement seq
Set_Statement_Entry;
if Present (Iteration_Scheme (N)) then
Process_Decisions
(Condition (Iteration_Scheme (N)), 'W');
end if;
Traverse_Declarations_Or_Statements (Statements (N));
-- All other cases
when others =>
if Has_Decision (N) then
Set_Statement_Entry;
Process_Decisions (N, 'X');
end if;
end case;
-- If that element did not terminate the current sequence of
-- statements, then establish or extend this sequence.
if not Term then
if Start = No_Location then
Sloc_Range (N, Start, Stop);
else
Sloc_Range (N, Dummy, Stop);
end if;
end if;
Next (N);
end loop;
Set_Statement_Entry;
end if;
end Traverse_Declarations_Or_Statements;
-----------------------------------------
-- Traverse_Handled_Statement_Sequence --
-----------------------------------------
procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
Handler : Node_Id;
begin
if Present (N) then
Traverse_Declarations_Or_Statements (Statements (N));
if Present (Exception_Handlers (N)) then
Handler := First (Exception_Handlers (N));
while Present (Handler) loop
Traverse_Declarations_Or_Statements (Statements (Handler));
Next (Handler);
end loop;
end if;
end if;
end Traverse_Handled_Statement_Sequence;
---------------------------
-- Traverse_Package_Body --
---------------------------
procedure Traverse_Package_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
end Traverse_Package_Body;
----------------------------------
-- Traverse_Package_Declaration --
----------------------------------
procedure Traverse_Package_Declaration (N : Node_Id) is
Spec : constant Node_Id := Specification (N);
begin
Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
end Traverse_Package_Declaration;
------------------------------
-- Traverse_Subprogram_Body --
------------------------------
procedure Traverse_Subprogram_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
end Traverse_Subprogram_Body;
end Par_SCO;

200
gcc/ada/par_sco.ads Normal file
View File

@ -0,0 +1,200 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P A R _ S C O --
-- --
-- S p e c --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains the routines used to deal with generation and output
-- of Soure Coverage Obligations (SCO's) used for coverage analysis purposes.
with Types; use Types;
package Par_SCO is
----------------
-- SCO Format --
----------------
-- Source coverage obligations are generated on a unit-by-unit basis in the
-- ALI file, using lines that start with the identifying character C. These
-- lines are generated if the -gnatC switch is set.
-- Sloc Ranges
-- In several places in the SCO lines, Sloc ranges appear. These are used
-- to indicate the first and last Sloc of some construct in the tree and
-- they have the form:
-- line:col-line:col ??? do we need generic instantiation stuff ???
-- Statements
-- For the purpose of SCO generation, the notion of statement includes
-- simple statements and also the following declaration types:
-- type_declaration
-- subtype_declaration
-- object_declaration
-- renaming_declaration
-- generic_instantiation
-- ??? is this list complete ???
-- ??? what is the exact story on complex statements such as blocks ???
-- ??? are the simple statements inside sufficient ???
-- Statement lines
-- These lines correspond to a sequence of one or more statements which
-- are always exeecuted in sequence, The first statement may be an entry
-- point (e.g. statement after a label), and the last statement may be
-- an exit point (e.g. an exit statement), but no other entry or exit
-- points may occur within the sequence of statements. The idea is that
-- the sequence can be treated as a single unit from a coverage point of
-- view, if any of the code for the statement sequence is executed, this
-- corresponds to coverage of the entire statement sequence. The form of
-- a statement line in the ALI file is:
-- CS sloc-range
-- Entry points
-- An entry point is a statement to which control may be passed other
-- than by falling into the statement for above. Examples are the first
-- statement of the body of a loop, and the statement following a label.
-- The form of an entry point in the ALI file is:
-- CY sloc-range
-- Exit points
-- An exit point is a statement that causes transfer of control. Examples
-- are exit statements, raise statements and return statements. The form
-- of an exit point in the ALI file is:
-- CT sloc-range
-- Decisions
-- Decisions represent the most significant section of the SCO lines
-- Note: in the following description, logical operator includes the
-- short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN,
-- or OR ELSE).
-- Decisions are either simple or complex. A simple decision is a boolean
-- expresssion that occurs in the context of a control structure in the
-- source program, including WHILE, IF, EXIT WHEN. Note that a boolean
-- expression in any other context, e.g. on the right side of an
-- assignment, is not considered to be a decision.
-- A complex decision is an occurrence of a logical operator which is not
-- itself an operand of some other logical operator. If any operand of
-- the logical operator is itself a logical operator, this is not a
-- separate decision, it is part of the same decision.
-- So for example, if we have
-- A, B, C, D : Boolean;
-- function F (Arg : Boolean) return Boolean);
-- ...
-- A and then (B or else F (C and then D))
-- There are two (complex) decisions here:
-- 1. X and then (Y or else Z)
-- where X = A, Y = B, and Z = F (C and then D)
-- 2. C and then D
-- For each decision, a decision line is generated with the form:
-- C* expression
-- Here * is one of the following characters:
-- I decision in IF statement or conditional expression
-- E decision in EXIT WHEN statement
-- W decision in WHILE iteration scheme
-- X decision appearing in some other expression context
-- The expression is a prefix polish form indicating the structure of
-- the decision, including logical operators and short circuit forms.
-- The following is a grammar showing the structure of expression:
-- expression ::= term (if expr is not logical operator)
-- expression ::= & term term (if expr is AND or AND THEN)
-- expression ::= | term term (if expr is OR or OR ELSE)
-- expression ::= ^ term term (if expr is XOR)
-- expression ::= !term (if expr is NOT)
-- term ::= element
-- term ::= expression
-- element ::= outcome sloc-range
-- outcome is one of the following letters:
-- c condition
-- t true condition
-- f false condition
-- where t/f are used to mark a condition that has been recognized by
-- the compiler as always being true or false.
-- & indicates either AND or AND THEN connecting two conditions. In the
-- context of couverture we only permit AND THEN in the source in any
-- case, so & can always be understood to be AND THEN.
-- | indicates either OR or OR ELSE connection two conditions. In the
-- context of couverture we only permit OR ELSE in the source in any
-- case, so | can always be understood to be OR ELSE.
-- ^ indicates XOR connecting two conditions. In the context of
-- couverture, we do not permit XOR, so this will never appear.
-- ! indicates NOT applied to the expression.
-----------------
-- Subprograms --
-----------------
procedure Init;
-- Initialize internal tables for a new compilation
procedure SCO_Record (U : Unit_Number_Type);
-- This procedure scans the tree for the unit identified by U, populating
-- internal tables recording the SCO information. Note that this is done
-- before any semantic analysis/expansion happens.
procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character);
-- This procedure is called during semantic analysis to record a condition
-- which has been identified as always True (Typ = 't') or always False
-- (Typ = 'f') by the compiler. The condition is identified by the
-- First_Sloc value in the original tree.
procedure SCO_Output (U : Unit_Number_Type);
-- Outputs SCO lines for unit U in the ALI file, as recorded by a previous
-- call to SCO_Record, possibly modified by calls to Set_SCO_Condition.
end Par_SCO;

33
gcc/ada/sem_warn.adb
View File

@ -33,6 +33,7 @@ with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Par_SCO; use Par_SCO;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
@ -3307,7 +3308,8 @@ package body Sem_Warn is
-----------------------------
procedure Warn_On_Known_Condition (C : Node_Id) is
P : Node_Id;
P : Node_Id;
Orig : constant Node_Id := Original_Node (C);
procedure Track (N : Node_Id; Loc : Node_Id);
-- Adds continuation warning(s) pointing to reason (assignment or test)
@ -3356,6 +3358,35 @@ package body Sem_Warn is
-- Start of processing for Warn_On_Known_Condition
begin
-- Adjust SCO condition if from source
if Comes_From_Source (Orig) then
declare
Start : Source_Ptr;
Dummy : Source_Ptr;
Typ : Character;
Atrue : Boolean;
begin
Sloc_Range (Orig, Start, Dummy);
Atrue := Entity (C) = Standard_True;
if Present (Parent (C))
and then Nkind (Parent (C)) = N_Op_Not
then
Atrue := not Atrue;
end if;
if Atrue then
Typ := 't';
else
Typ := 'f';
end if;
Set_SCO_Condition (Start, Typ);
end;
end if;
-- Argument replacement in an inlined body can make conditions static.
-- Do not emit warnings in this case.

8
gcc/ada/switch-c.adb
View File

@ -462,11 +462,19 @@ package body Switch.C is
Ptr := Max + 1;
-- -gnatez ???
when 'z' =>
Store_Switch := False;
Disable_Switch_Storing;
Ptr := Ptr + 1;
-- -gnateS (Store SCO information)
when 'S' =>
Generate_SCO := True;
Ptr := Ptr + 1;
-- All other -gnate? switches are unassigned
when others =>

5
gcc/ada/usage.adb
View File

@ -202,6 +202,11 @@ begin
Write_Switch_Char ("ep=?");
Write_Line ("Specify preprocessing data file, e.g. -gnatep=prep.data");
-- Line for -gnateS switch
Write_Switch_Char ("eS");
Write_Line ("Generate SCO (Source Coverage Obligation) information");
-- Line for -gnatE switch
Write_Switch_Char ("E");