with Lib; use Lib;
with Lib.Util; use Lib.Util;
with Nlists; use Nlists;
+with Opt; use Opt;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Table;
-with GNAT.HTable; use GNAT.HTable;
+with GNAT.HTable; use GNAT.HTable;
+with GNAT.Heap_Sort_G;
package body Par_SCO is
-- 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.
+ -- This table keeps track of the units and the corresponding starting and
+ -- ending indexes (From, To) in the SCO table. Note that entry zero is
+ -- unused, it is for convenience in calling the sort routine.
type SCO_Unit_Table_Entry is record
- Unit : Unit_Number_Type;
- Index : Int;
+ Unit : Unit_Number_Type;
+ From : Nat;
+ To : Nat;
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_Low_Bound => 0,
Table_Initial => 20,
Table_Increment => 200,
Table_Name => "SCO_Unit_Table_Entry");
-- 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 Process_Decisions (L : List_Id; T : Character);
+ -- Calls above procedure for each element of the list L
+
procedure Set_Table_Entry
(C1 : Character;
C2 : Character;
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);
+ procedure Traverse_Declarations_Or_Statements (L : List_Id);
+ procedure Traverse_Generic_Package_Declaration (N : Node_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;
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_Str (" From = ");
+ Write_Int (Int (SCO_Unit_Table.Table (Index).From));
+ Write_Str (" To = ");
+ Write_Int (Int (SCO_Unit_Table.Table (Index).To));
Write_Eol;
end loop;
return Header_Num (Nat (F) mod 997);
end Hash;
- ----------
- -- Init --
- ----------
+ ----------------
+ -- Initialize --
+ ----------------
- procedure Init is
+ procedure Initialize is
begin
- null;
- end Init;
+ SCO_Unit_Table.Init;
+ SCO_Unit_Table.Increment_Last;
+ SCO_Table.Init;
+ end Initialize;
-------------------------
-- Is_Logical_Operator --
-- Process_Decisions --
-----------------------
- procedure Process_Decisions
- (N : Node_Id;
- T : Character)
- is
+ -- Version taking a list
+
+ procedure Process_Decisions (L : List_Id; T : Character) is
+ N : Node_Id;
+ begin
+ if L /= No_List then
+ N := First (L);
+ while Present (N) loop
+ Process_Decisions (N, T);
+ Next (N);
+ end loop;
+ end if;
+ end Process_Decisions;
+
+ -- Version taking a node
+
+ 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.
dsco;
end if;
+ -- Sort the unit table
+
+ Unit_Table_Sort : declare
+
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ -- Comparison routine for sort call
+
+ procedure Move (From : Natural; To : Natural);
+ -- Move routine for sort call
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ return Dependency_Num (SCO_Unit_Table.Table (Nat (Op1)).Unit) <
+ Dependency_Num (SCO_Unit_Table.Table (Nat (Op2)).Unit);
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ SCO_Unit_Table.Table (Nat (To)) :=
+ SCO_Unit_Table.Table (Nat (From));
+ end Move;
+
+ package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
+
+ -- Start of processing for Unit_Table_Sort
+
+ begin
+ Sorting.Sort (Integer (SCO_Unit_Table.Last));
+ end Unit_Table_Sort;
+
-- Loop through entries in the unit table
- for J in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop
+ for J in 1 .. 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;
+ -- Output header line preceded by blank line
- Start := SCO_Unit_Table.Table (J).Index;
+ Write_Info_Terminate;
+ 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;
- if J = SCO_Unit_Table.Last then
- Stop := SCO_Table.Last;
- else
- Stop := SCO_Unit_Table.Table (J + 1).Index - 1;
- end if;
+ Start := SCO_Unit_Table.Table (J).From;
+ Stop := SCO_Unit_Table.Table (J).To;
- -- Loop through relevant entries in SCO table, outputting C lines
+ -- Loop through relevant entries in SCO table, outputting C lines
- while Start <= Stop loop
- declare
- T : SCO_Table_Entry renames SCO_Table.Table (Start);
+ while Start <= Stop loop
+ declare
+ T : SCO_Table_Entry renames SCO_Table.Table (Start);
- begin
- Write_Info_Initiate ('C');
- Write_Info_Char (T.C1);
+ begin
+ Write_Info_Initiate ('C');
+ Write_Info_Char (T.C1);
- case T.C1 is
+ case T.C1 is
- -- Statements, entry, exit
+ -- Statements, entry, exit
when 'S' | 'Y' | 'T' =>
Write_Info_Char (' ');
when others =>
raise Program_Error;
- end case;
+ end case;
- Write_Info_Terminate;
- end;
+ Write_Info_Terminate;
+ end;
- exit when Start = Stop;
- Start := Start + 1;
+ exit when Start = Stop;
+ Start := Start + 1;
- pragma Assert (Start <= Stop);
- end loop;
- end if;
+ pragma Assert (Start <= Stop);
+ end loop;
end loop;
end SCO_Output;
----------------
procedure SCO_Record (U : Unit_Number_Type) is
- Cu : constant Node_Id := Cunit (U);
- Lu : constant Node_Id := Unit (Cu);
+ Lu : Node_Id;
+ From : Nat;
begin
- SCO_Unit_Table.Append ((Unit => U, Index => SCO_Table.Last + 1));
+ -- Ignore call if not generating code and generating SCO's
+
+ if not (Generate_SCO and then Operating_Mode = Generate_Code) then
+ return;
+ end if;
+
+ -- Ignore call if this unit already recorded
+
+ for J in 1 .. SCO_Unit_Table.Last loop
+ if SCO_Unit_Table.Table (J).Unit = U then
+ return;
+ end if;
+ end loop;
+
+ -- Otherwise record starting entry
+
+ From := SCO_Table.Last + 1;
+
+ -- Get Unit (checking case of subunit)
+
+ Lu := Unit (Cunit (U));
+
+ if Nkind (Lu) = N_Subunit then
+ Lu := Proper_Body (Lu);
+ end if;
-- Traverse the unit
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 ???
+ elsif Nkind (Lu) = N_Generic_Package_Declaration then
+ Traverse_Generic_Package_Declaration (Lu);
+
+ -- For anything else, the only issue is default expressions for
+ -- parameters, where we have to worry about possible embedded decisions
+ -- but nothing else.
else
- null;
+ Process_Decisions (Lu, 'X');
end if;
+
+ -- Make entry for new unit in unit table
+
+ SCO_Unit_Table.Append ((Unit => U, From => From, To => SCO_Table.Last));
end SCO_Record;
-----------------------
Set_Statement_Entry;
Traverse_Package_Declaration (N);
+ -- Generic package declaration
+
+ when N_Generic_Package_Declaration =>
+ Set_Statement_Entry;
+ Traverse_Generic_Package_Declaration (N);
+
-- Package body
when N_Package_Body =>
Set_Statement_Entry;
Traverse_Package_Body (N);
+ -- Subprogram declaration
+
+ when N_Subprogram_Declaration =>
+ Set_Statement_Entry;
+ Process_Decisions
+ (Parameter_Specifications (Specification (N)), 'X');
+
+ -- Generic subprogram declaration
+
+ when N_Generic_Subprogram_Declaration =>
+ Set_Statement_Entry;
+ Process_Decisions (Generic_Formal_Declarations (N), 'X');
+ Process_Decisions
+ (Parameter_Specifications (Specification (N)), 'X');
+
-- Subprogram_Body
when N_Subprogram_Body =>
end if;
end Traverse_Declarations_Or_Statements;
+ ------------------------------------------
+ -- Traverse_Generic_Package_Declaration --
+ ------------------------------------------
+
+ procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
+ begin
+ Process_Decisions (Generic_Formal_Declarations (N), 'X');
+ Traverse_Package_Declaration (N);
+ end Traverse_Generic_Package_Declaration;
+
-----------------------------------------
-- Traverse_Handled_Statement_Sequence --
-----------------------------------------
-----------------------------
procedure Warn_On_Known_Condition (C : Node_Id) is
- P : Node_Id;
- Orig : constant Node_Id := Original_Node (C);
+ P : Node_Id;
+ Orig : constant Node_Id := Original_Node (C);
+ Test_Result : Boolean;
+
+ function Is_Known_Branch return Boolean;
+ -- If the type of the condition is Boolean, the constant value of the
+ -- condition is a boolean literal. If the type is a derived boolean
+ -- type, the constant is wrapped in a type conversion of the derived
+ -- literal. If the value of the condition is not a literal, no warnings
+ -- can be produced. This function returns True if the result can be
+ -- determined, and Test_Result is set True/False accordingly. Otherwise
+ -- False is returned, and Test_Result is unchanged.
procedure Track (N : Node_Id; Loc : Node_Id);
-- Adds continuation warning(s) pointing to reason (assignment or test)
-- enough is known about the value to issue the warning). N is the node
-- which is judged to have a known value. Loc is the warning location.
+ ---------------------
+ -- Is_Known_Branch --
+ ---------------------
+
+ function Is_Known_Branch return Boolean is
+ begin
+ if Etype (C) = Standard_Boolean
+ and then Is_Entity_Name (C)
+ and then
+ (Entity (C) = Standard_False or else Entity (C) = Standard_True)
+ then
+ Test_Result := Entity (C) = Standard_True;
+ return True;
+
+ elsif Is_Boolean_Type (Etype (C))
+ and then Nkind (C) = N_Unchecked_Type_Conversion
+ and then Is_Entity_Name (Expression (C))
+ and then Ekind (Entity (Expression (C))) = E_Enumeration_Literal
+ then
+ Test_Result :=
+ Chars (Entity (Expression (C))) = Chars (Standard_True);
+ return True;
+
+ else
+ return False;
+ end if;
+ end Is_Known_Branch;
+
-----------
-- Track --
-----------
if Generate_SCO
and then Comes_From_Source (Orig)
- and then Is_Entity_Name (C)
+ and then Is_Known_Branch
then
declare
Start : Source_Ptr;
begin
Sloc_Range (Orig, Start, Dummy);
-
- Atrue := Entity (C) = Standard_True;
+ Atrue := Test_Result;
if Present (Parent (C))
and then Nkind (Parent (C)) = N_Op_Not
end if;
if Constant_Condition_Warnings
- and then Nkind (C) = N_Identifier
- and then
- (Entity (C) = Standard_False or else Entity (C) = Standard_True)
+ and then Is_Known_Branch
and then Comes_From_Source (Original_Node (C))
and then not In_Instance
then
if not Operand_Has_Warnings_Suppressed (C) then
declare
- True_Branch : Boolean := Entity (C) = Standard_True;
+ True_Branch : Boolean := Test_Result;
Cond : Node_Id := C;
begin
projects / platform / upstream / linaro-gcc.git / commitdiff