------------------------------------------------------------------------------ -- -- -- 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 is Start : Nat; Stop : Nat; U : Unit_Number_Type; 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; -- Loop through entries in the unit table for J in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop U := SCO_Unit_Table.Table (J).Unit; if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then Write_Info_Initiate ('C'); Write_Info_Char (' '); Write_Info_Nat (Dependency_Num (U)); Write_Info_Char (' '); Write_Info_Name (Reference_Name (Source_Index (U))); Write_Info_Terminate; 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; -- 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 if; 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, since nothing to cover. -- Also ignore instantiations, since again, nothing to cover. -- Also for now, ignore generic declarations ??? 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;