diff options
author | Robert Dewar <dewar@adacore.com> | 2009-07-15 09:59:16 +0000 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-07-15 11:59:16 +0200 |
commit | 6f12117afc93e5af5f2cdb1cfc99e285a15f9a91 (patch) | |
tree | 7269667b0fc6e29ea066148c0a41903f090ce070 | |
parent | 3a3362620167fd31b30aa391bf6d84c45a3d6af2 (diff) | |
download | gcc-6f12117afc93e5af5f2cdb1cfc99e285a15f9a91.zip gcc-6f12117afc93e5af5f2cdb1cfc99e285a15f9a91.tar.gz gcc-6f12117afc93e5af5f2cdb1cfc99e285a15f9a91.tar.bz2 |
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
-rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
-rw-r--r-- | gcc/ada/debug.adb | 6 | ||||
-rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 7 | ||||
-rw-r--r-- | gcc/ada/lib-writ.adb | 9 | ||||
-rw-r--r-- | gcc/ada/lib-writ.ads | 10 | ||||
-rw-r--r-- | gcc/ada/opt.ads | 6 | ||||
-rw-r--r-- | gcc/ada/par.adb | 16 | ||||
-rw-r--r-- | gcc/ada/par_sco.adb | 956 | ||||
-rw-r--r-- | gcc/ada/par_sco.ads | 200 | ||||
-rw-r--r-- | gcc/ada/sem_warn.adb | 33 | ||||
-rw-r--r-- | gcc/ada/switch-c.adb | 8 | ||||
-rw-r--r-- | gcc/ada/usage.adb | 5 |
12 files changed, 1270 insertions, 9 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3c63782..bc2ccb0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d0b285a..5ae3979 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -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 diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 0f4082a..1dcb12f 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -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 \ diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index f248c05..44d8b33 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -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; ---------------------- diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index e0c0f34..2195f05 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -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 -- --------------------- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 906a782..ca5d7fb 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -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 diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 51029d6..0358040 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -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; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb new file mode 100644 index 0000000..3161c53 --- /dev/null +++ b/gcc/ada/par_sco.adb @@ -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; diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads new file mode 100644 index 0000000..273c11c --- /dev/null +++ b/gcc/ada/par_sco.ads @@ -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; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 7ca0b86..2b7ecf3 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -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. diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index b391ce3..6825f4e 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -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 => diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 47e7899..6b87db9 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -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"); |