--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
projects / platform / upstream / linaro-gcc.git / commitdiff