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

gcc/ada/ChangeLog

+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

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

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 \

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;
 
       ----------------------

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 --
    ---------------------

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

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;

gcc/ada/par_sco.adb

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;

gcc/ada/par_sco.ads

+------------------------------------------------------------------------------
+--                                                                          --
+--                         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;

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.
 

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 =>

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");