diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/par_sco.adb')
-rw-r--r-- | gcc-4.7/gcc/ada/par_sco.adb | 1767 |
1 files changed, 1767 insertions, 0 deletions
diff --git a/gcc-4.7/gcc/ada/par_sco.adb b/gcc-4.7/gcc/ada/par_sco.adb new file mode 100644 index 000000000..28fa18681 --- /dev/null +++ b/gcc-4.7/gcc/ada/par_sco.adb @@ -0,0 +1,1767 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R _ S C O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2011, 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 Namet; use Namet; +with Nlists; use Nlists; +with Opt; use Opt; +with Output; use Output; +with Put_SCOs; +with SCOs; use SCOs; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with Table; + +with GNAT.HTable; use GNAT.HTable; +with GNAT.Heap_Sort_G; + +package body Par_SCO is + + ----------------------- + -- Unit Number Table -- + ----------------------- + + -- This table parallels the SCO_Unit_Table, keeping track of the unit + -- numbers corresponding to the entries made in this table, so that before + -- writing out the SCO information to the ALI file, we can fill in the + -- proper dependency numbers and file names. + + -- Note that the zero'th entry is here for convenience in sorting the + -- table, the real lower bound is 1. + + package SCO_Unit_Number_Table is new Table.Table ( + Table_Component_Type => Unit_Number_Type, + Table_Index_Type => SCO_Unit_Index, + Table_Low_Bound => 0, -- see note above on sort + Table_Initial => 20, + Table_Increment => 200, + Table_Name => "SCO_Unit_Number_Entry"); + + --------------------------------- + -- Condition/Pragma Hash Table -- + --------------------------------- + + -- We need to be able to get to conditions quickly for handling the calls + -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to + -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify + -- the conditions and pragmas in the table by their starting sloc, and use + -- this hash table to map from these 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_Pragma_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, but + -- excluding OR and AND) and returns True if so, False otherwise, it does + -- no other processing. + + procedure Process_Decisions + (N : Node_Id; + T : Character; + Pragma_Sloc : Source_Ptr); + -- 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 IEGPWX (for context of + -- expression: if/exit when/entry guard/pragma/while/expression). If T is + -- other than X, the node N is the conditional expression involved, and 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; + Pragma_Sloc : Source_Ptr); + -- Calls above procedure for each element of the list L + + procedure Set_Table_Entry + (C1 : Character; + C2 : Character; + From : Source_Ptr; + To : Source_Ptr; + Last : Boolean; + Pragma_Sloc : Source_Ptr := No_Location; + Pragma_Name : Pragma_Id := Unknown_Pragma); + -- Append an entry to SCO_Table with fields set as per arguments + + type Dominant_Info is record + K : Character; + -- F/T/S/E for a valid dominance marker, or ' ' for no dominant + + N : Node_Id; + -- Node providing the sloc(s) for the dominance marker + end record; + No_Dominant : constant Dominant_Info := (' ', Empty); + + procedure Traverse_Declarations_Or_Statements + (L : List_Id; + D : Dominant_Info := No_Dominant); + + procedure Traverse_Generic_Instantiation (N : Node_Id); + procedure Traverse_Generic_Package_Declaration (N : Node_Id); + procedure Traverse_Handled_Statement_Sequence + (N : Node_Id; + D : Dominant_Info := No_Dominant); + procedure Traverse_Package_Body (N : Node_Id); + procedure Traverse_Package_Declaration (N : Node_Id); + procedure Traverse_Protected_Body (N : Node_Id); + procedure Traverse_Subprogram_Or_Task_Body + (N : Node_Id; + D : Dominant_Info := No_Dominant); + procedure Traverse_Subprogram_Declaration (N : Node_Id); + -- Traverse the corresponding construct, generating SCO table entries + + procedure Write_SCOs_To_ALI_File is new Put_SCOs; + -- Write SCO information to the ALI file using routines in Lib.Util + + ---------- + -- dsco -- + ---------- + + procedure dsco is + begin + -- Dump SCO unit table + + Write_Line ("SCO Unit Table"); + Write_Line ("--------------"); + + for Index in 1 .. SCO_Unit_Table.Last loop + declare + UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index); + + begin + Write_Str (" "); + Write_Int (Int (Index)); + Write_Str (". Dep_Num = "); + Write_Int (Int (UTE.Dep_Num)); + Write_Str (" From = "); + Write_Int (Int (UTE.From)); + Write_Str (" To = "); + Write_Int (Int (UTE.To)); + + Write_Str (" File_Name = """); + + if UTE.File_Name /= null then + Write_Str (UTE.File_Name.all); + end if; + + Write_Char ('"'); + Write_Eol; + end; + end loop; + + -- Dump SCO Unit number table if it contains any entries + + if SCO_Unit_Number_Table.Last >= 1 then + Write_Eol; + Write_Line ("SCO Unit Number Table"); + Write_Line ("---------------------"); + + for Index in 1 .. SCO_Unit_Number_Table.Last loop + Write_Str (" "); + Write_Int (Int (Index)); + Write_Str (". Unit_Number = "); + Write_Int (Int (SCO_Unit_Number_Table.Table (Index))); + Write_Eol; + end loop; + end if; + + -- Dump SCO table itself + + Write_Eol; + Write_Line ("SCO Table"); + Write_Line ("---------"); + + for Index in 1 .. SCO_Table.Last loop + declare + T : SCO_Table_Entry renames SCO_Table.Table (Index); + + begin + Write_Str (" "); + Write_Int (Index); + Write_Char ('.'); + + if T.C1 /= ' ' then + Write_Str (" C1 = '"); + Write_Char (T.C1); + Write_Char ('''); + end if; + + if T.C2 /= ' ' then + Write_Str (" C2 = '"); + Write_Char (T.C2); + Write_Char ('''); + end if; + + if T.From /= No_Source_Location then + Write_Str (" From = "); + Write_Int (Int (T.From.Line)); + Write_Char (':'); + Write_Int (Int (T.From.Col)); + end if; + + if T.To /= No_Source_Location then + Write_Str (" To = "); + Write_Int (Int (T.To.Line)); + Write_Char (':'); + Write_Int (Int (T.To.Col)); + end if; + + 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; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SCO_Unit_Number_Table.Init; + + -- Set dummy 0'th entry in place for sort + + SCO_Unit_Number_Table.Increment_Last; + end Initialize; + + ------------------------- + -- Is_Logical_Operator -- + ------------------------- + + function Is_Logical_Operator (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Op_Not, + N_And_Then, + N_Or_Else); + end Is_Logical_Operator; + + ----------------------- + -- Process_Decisions -- + ----------------------- + + -- Version taking a list + + procedure Process_Decisions + (L : List_Id; + T : Character; + Pragma_Sloc : Source_Ptr) + is + N : Node_Id; + begin + if L /= No_List then + N := First (L); + while Present (N) loop + Process_Decisions (N, T, Pragma_Sloc); + Next (N); + end loop; + end if; + end Process_Decisions; + + -- Version taking a node + + Current_Pragma_Sloc : Source_Ptr := No_Location; + -- While processing a pragma, this is set to the sloc of the N_Pragma node + + procedure Process_Decisions + (N : Node_Id; + T : Character; + Pragma_Sloc : Source_Ptr) + is + Mark : Nat; + -- This is used to mark the location of a decision sequence in the SCO + -- table. We use it for backing out a simple decision in an expression + -- context that contains only NOT operators. + + X_Not_Decision : Boolean; + -- This flag keeps track of whether a decision sequence in the SCO table + -- contains only NOT operators, and is for an expression context (T=X). + -- The flag will be set False if T is other than X, or if an operator + -- other than NOT is in the sequence. + + 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); + -- 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 ' '. Last is set + -- False, and an entry is made in the condition hash table. + + procedure Output_Header (T : Character); + -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/ + -- PRAGMA, and 'X' for the expression case. + + 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; + + 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_In (N, N_Op_Or, N_Or_Else) then + C := '|'; + else + C := '&'; + end if; + end if; + + Set_Table_Entry + (C1 => C, + C2 => ' ', + From => Sloc (N), + To => No_Location, + Last => 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) is + FSloc : Source_Ptr; + LSloc : Source_Ptr; + begin + Sloc_Range (N, FSloc, LSloc); + Set_Table_Entry + (C1 => ' ', + C2 => 'c', + From => FSloc, + To => LSloc, + Last => False); + Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last); + end Output_Element; + + ------------------- + -- Output_Header -- + ------------------- + + procedure Output_Header (T : Character) is + Loc : Source_Ptr := No_Location; + -- Node whose sloc is used for the decision + + begin + case T is + when 'I' | 'E' | 'W' => + + -- For IF, EXIT, WHILE, the token SLOC can be found from + -- the SLOC of the parent of the expression. + + Loc := Sloc (Parent (N)); + + when 'G' | 'P' => + + -- For entry, the token sloc is from the N_Entry_Body. For + -- PRAGMA, we must get the location from the pragma node. + -- Argument N is the pragma argument, and we have to go up two + -- levels (through the pragma argument association) to get to + -- the pragma node itself. + + Loc := Sloc (Parent (Parent (N))); + + when 'X' => + + -- For an expression, no Sloc + + null; + + -- No other possibilities + + when others => + raise Program_Error; + end case; + + Set_Table_Entry + (C1 => T, + C2 => ' ', + From => Loc, + To => No_Location, + Last => False, + Pragma_Sloc => Pragma_Sloc); + end Output_Header; + + ------------------------------ + -- 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)); + X_Not_Decision := False; + end if; + + Process_Decision_Operand (Right_Opnd (N)); + + else + Process_Decisions (N, 'X', Pragma_Sloc); + 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, output table entries and then process + -- operands recursively to deal with nested conditions. + + when N_And_Then | + N_Or_Else | + 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 + + X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; + Mark := SCO_Table.Last; + Output_Header (T); + + -- Output the decision + + Output_Decision_Operand (N); + + -- If the decision was in an expression context (T = 'X') + -- and contained only NOT operators, then we don't output + -- it, so delete it. + + if X_Not_Decision then + SCO_Table.Set_Last (Mark); + + -- Otherwise, set Last in last table entry to mark end + + else + SCO_Table.Table (SCO_Table.Last).Last := True; + end if; + + -- Process any embedded decisions + + Process_Decision_Operand (N); + return Skip; + end; + + -- Case expression + + when N_Case_Expression => + return OK; -- ??? + + -- 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', Pragma_Sloc); + Process_Decisions (Thnx, 'X', Pragma_Sloc); + Process_Decisions (Elsx, 'X', Pragma_Sloc); + 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, + -- EXIT WHEN, or special PRAGMA construct. + + if T /= 'X' and then not Is_Logical_Operator (N) then + Output_Header (T); + Output_Element (N); + + -- 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; + + ----------- + -- pscos -- + ----------- + + procedure pscos is + + procedure Write_Info_Char (C : Character) renames Write_Char; + -- Write one character; + + procedure Write_Info_Initiate (Key : Character) renames Write_Char; + -- Start new one and write one character; + + procedure Write_Info_Nat (N : Nat); + -- Write value of N + + procedure Write_Info_Terminate renames Write_Eol; + -- Terminate current line + + -------------------- + -- Write_Info_Nat -- + -------------------- + + procedure Write_Info_Nat (N : Nat) is + begin + Write_Int (N); + end Write_Info_Nat; + + procedure Debug_Put_SCOs is new Put_SCOs; + + -- Start of processing for pscos + + begin + Debug_Put_SCOs; + end pscos; + + ---------------- + -- SCO_Output -- + ---------------- + + procedure SCO_Output is + begin + if Debug_Flag_Dot_OO then + dsco; + end if; + + -- Sort the unit tables based on dependency numbers + + 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_Number_Table.Table (SCO_Unit_Index (Op1))) + < + Dependency_Num + (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2))); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + SCO_Unit_Table.Table (SCO_Unit_Index (To)) := + SCO_Unit_Table.Table (SCO_Unit_Index (From)); + SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) := + SCO_Unit_Number_Table.Table (SCO_Unit_Index (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 to set file name and + -- dependency number entries. + + for J in 1 .. SCO_Unit_Table.Last loop + declare + U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J); + UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J); + begin + Get_Name_String (Reference_Name (Source_Index (U))); + UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len)); + UTE.Dep_Num := Dependency_Num (U); + end; + end loop; + + -- Now the tables are all setup for output to the ALI file + + Write_SCOs_To_ALI_File; + end SCO_Output; + + ------------------------- + -- SCO_Pragma_Disabled -- + ------------------------- + + function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is + Index : Nat; + + begin + if Loc = No_Location then + return False; + end if; + + Index := Condition_Pragma_Hash_Table.Get (Loc); + + -- The test here for zero is to deal with possible previous errors, and + -- for the case of pragma statement SCOs, for which we always set the + -- Pragma_Sloc even if the particular pragma cannot be specifically + -- disabled. + + if Index /= 0 then + declare + T : SCO_Table_Entry renames SCO_Table.Table (Index); + begin + pragma Assert (T.C1 = 'S'); + return T.C2 = 'p'; + end; + + else + return False; + end if; + end SCO_Pragma_Disabled; + + ---------------- + -- SCO_Record -- + ---------------- + + procedure SCO_Record (U : Unit_Number_Type) is + Lu : Node_Id; + From : Nat; + + begin + -- 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_Number_Table.Last loop + if U = SCO_Unit_Number_Table.Table (J) 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 + + case Nkind (Lu) is + when N_Protected_Body => + Traverse_Protected_Body (Lu); + + when N_Subprogram_Body | N_Task_Body => + Traverse_Subprogram_Or_Task_Body (Lu); + + when N_Subprogram_Declaration => + Traverse_Subprogram_Declaration (Lu); + + when N_Package_Declaration => + Traverse_Package_Declaration (Lu); + + when N_Package_Body => + Traverse_Package_Body (Lu); + + when N_Generic_Package_Declaration => + Traverse_Generic_Package_Declaration (Lu); + + when N_Generic_Instantiation => + Traverse_Generic_Instantiation (Lu); + + when others => + + -- All other cases of compilation units (e.g. renamings), generate + -- no SCO information. + + null; + end case; + + -- Make entry for new unit in unit tables, we will fill in the file + -- name and dependency numbers later. + + SCO_Unit_Table.Append ( + (Dep_Num => 0, + File_Name => null, + From => From, + To => SCO_Table.Last)); + + SCO_Unit_Number_Table.Append (U); + end SCO_Record; + + ----------------------- + -- Set_SCO_Condition -- + ----------------------- + + procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is + Orig : constant Node_Id := Original_Node (Cond); + Index : Nat; + Start : Source_Ptr; + Dummy : Source_Ptr; + + Constant_Condition_Code : constant array (Boolean) of Character := + (False => 'f', True => 't'); + begin + Sloc_Range (Orig, Start, Dummy); + Index := Condition_Pragma_Hash_Table.Get (Start); + + -- The test here for zero is to deal with possible previous errors + + if Index /= 0 then + pragma Assert (SCO_Table.Table (Index).C1 = ' '); + SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val); + end if; + end Set_SCO_Condition; + + ---------------------------- + -- Set_SCO_Pragma_Enabled -- + ---------------------------- + + procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is + Index : Nat; + + begin + -- Note: the reason we use the Sloc value as the key is that in the + -- generic case, the call to this procedure is made on a copy of the + -- original node, so we can't use the Node_Id value. + + Index := Condition_Pragma_Hash_Table.Get (Loc); + + -- The test here for zero is to deal with possible previous errors + + if Index /= 0 then + declare + T : SCO_Table_Entry renames SCO_Table.Table (Index); + + begin + -- Called multiple times for the same sloc (need to allow for + -- C2 = 'P') ??? + + pragma Assert (T.C1 = 'S' + and then + (T.C2 = 'p' or else T.C2 = 'P')); + T.C2 := 'P'; + end; + end if; + end Set_SCO_Pragma_Enabled; + + --------------------- + -- Set_Table_Entry -- + --------------------- + + procedure Set_Table_Entry + (C1 : Character; + C2 : Character; + From : Source_Ptr; + To : Source_Ptr; + Last : Boolean; + Pragma_Sloc : Source_Ptr := No_Location; + Pragma_Name : Pragma_Id := Unknown_Pragma) + is + function To_Source_Location (S : Source_Ptr) return Source_Location; + -- Converts Source_Ptr value to Source_Location (line/col) format + + ------------------------ + -- To_Source_Location -- + ------------------------ + + function To_Source_Location (S : Source_Ptr) return Source_Location is + begin + if S = No_Location then + return No_Source_Location; + else + return + (Line => Get_Logical_Line_Number (S), + Col => Get_Column_Number (S)); + end if; + end To_Source_Location; + + -- Start of processing for Set_Table_Entry + + begin + SCO_Table.Append + ((C1 => C1, + C2 => C2, + From => To_Source_Location (From), + To => To_Source_Location (To), + Last => Last, + Pragma_Sloc => Pragma_Sloc, + Pragma_Name => Pragma_Name)); + end Set_Table_Entry; + + ----------------------------------------- + -- Traverse_Declarations_Or_Statements -- + ----------------------------------------- + + -- Tables used by Traverse_Declarations_Or_Statements for temporarily + -- holding statement and decision entries. These are declared globally + -- since they are shared by recursive calls to this procedure. + + type SC_Entry is record + N : Node_Id; + From : Source_Ptr; + To : Source_Ptr; + Typ : Character; + end record; + -- Used to store a single entry in the following table, From:To represents + -- the range of entries in the CS line entry, and typ is the type, with + -- space meaning that no type letter will accompany the entry. + + package SC is new Table.Table ( + Table_Component_Type => SC_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SC"); + -- Used to store statement components for a CS entry to be output + -- as a result of the call to this procedure. SC.Last is the last + -- entry stored, so the current statement sequence is represented + -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on + -- entry to each recursive call to the routine. + -- + -- Extend_Statement_Sequence adds an entry to this array, and then + -- Set_Statement_Entry clears the entries starting with SC_First, + -- copying these entries to the main SCO output table. The reason that + -- we do the temporary caching of results in this array is that we want + -- the SCO table entries for a given CS line to be contiguous, and the + -- processing may output intermediate entries such as decision entries. + + type SD_Entry is record + Nod : Node_Id; + Lst : List_Id; + Typ : Character; + Plo : Source_Ptr; + end record; + -- Used to store a single entry in the following table. Nod is the node to + -- be searched for decisions for the case of Process_Decisions_Defer with a + -- node argument (with Lst set to No_List. Lst is the list to be searched + -- for decisions for the case of Process_Decisions_Defer with a List + -- argument (in which case Nod is set to Empty). Plo is the sloc of the + -- enclosing pragma, if any. + + package SD is new Table.Table ( + Table_Component_Type => SD_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SD"); + -- Used to store possible decision information. Instead of calling the + -- Process_Decisions procedures directly, we call Process_Decisions_Defer, + -- which simply stores the arguments in this table. Then when we clear + -- out a statement sequence using Set_Statement_Entry, after generating + -- the CS lines for the statements, the entries in this table result in + -- calls to Process_Decision. The reason for doing things this way is to + -- ensure that decisions are output after the CS line for the statements + -- in which the decisions occur. + + procedure Traverse_Declarations_Or_Statements + (L : List_Id; + D : Dominant_Info := No_Dominant) + is + Current_Dominant : Dominant_Info := D; + -- Dominance information for the current basic block + + Current_Test : Node_Id; + -- Conditional node (N_If_Statement or N_Elsiif being processed + + N : Node_Id; + Dummy : Source_Ptr; + + SC_First : constant Nat := SC.Last + 1; + SD_First : constant Nat := SD.Last + 1; + -- Record first entries used in SC/SD at this recursive level + + procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); + -- Extend the current statement sequence to encompass the node N. Typ + -- is the letter that identifies the type of statement/declaration that + -- is being added to the sequence. + + procedure Extend_Statement_Sequence + (From : Node_Id; + To : Node_Id; + Typ : Character); + -- This version extends the current statement sequence with an entry + -- that starts with the first token of From, and ends with the last + -- token of To. It is used for example in a CASE statement to cover + -- the range from the CASE token to the last token of the expression. + + procedure Set_Statement_Entry; + -- Output CS entries for all statements saved in table SC, and end the + -- current CS sequence. + + procedure Process_Decisions_Defer (N : Node_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- This routine is logically the same as Process_Decisions, except that + -- the arguments are saved in the SD table, for later processing when + -- Set_Statement_Entry is called, which goes through the saved entries + -- making the corresponding calls to Process_Decision. + + procedure Process_Decisions_Defer (L : List_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- Same case for list arguments, deferred call to Process_Decisions + + ------------------------- + -- Set_Statement_Entry -- + ------------------------- + + procedure Set_Statement_Entry is + SC_Last : constant Int := SC.Last; + SD_Last : constant Int := SD.Last; + + begin + -- Output statement entries from saved entries in SC table + + for J in SC_First .. SC_Last loop + if J = SC_First then + + if Current_Dominant /= No_Dominant then + declare + From, To : Source_Ptr; + begin + Sloc_Range (Current_Dominant.N, From, To); + if Current_Dominant.K /= 'E' then + To := No_Location; + end if; + Set_Table_Entry + (C1 => '>', + C2 => Current_Dominant.K, + From => From, + To => To, + Last => False, + Pragma_Sloc => No_Location, + Pragma_Name => Unknown_Pragma); + end; + end if; + end if; + + declare + SCE : SC_Entry renames SC.Table (J); + Pragma_Sloc : Source_Ptr := No_Location; + Pragma_Name : Pragma_Id := Unknown_Pragma; + begin + -- For the case of a statement SCO for a pragma controlled by + -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and + -- those of any nested decision) is emitted only if the pragma + -- is enabled. + + if SCE.Typ = 'p' then + Pragma_Sloc := SCE.From; + Condition_Pragma_Hash_Table.Set + (Pragma_Sloc, SCO_Table.Last + 1); + Pragma_Name := Get_Pragma_Id (Sinfo.Pragma_Name (SCE.N)); + + elsif SCE.Typ = 'P' then + Pragma_Name := Get_Pragma_Id (Sinfo.Pragma_Name (SCE.N)); + end if; + + Set_Table_Entry + (C1 => 'S', + C2 => SCE.Typ, + From => SCE.From, + To => SCE.To, + Last => (J = SC_Last), + Pragma_Sloc => Pragma_Sloc, + Pragma_Name => Pragma_Name); + end; + end loop; + + -- Last statement of basic block, if present, becomes new current + -- dominant. + + if SC_Last >= SC_First then + Current_Dominant := ('S', SC.Table (SC_Last).N); + end if; + + -- Clear out used section of SC table + + SC.Set_Last (SC_First - 1); + + -- Output any embedded decisions + + for J in SD_First .. SD_Last loop + declare + SDE : SD_Entry renames SD.Table (J); + begin + if Present (SDE.Nod) then + Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo); + else + Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo); + end if; + end; + end loop; + + -- Clear out used section of SD table + + SD.Set_Last (SD_First - 1); + end Set_Statement_Entry; + + ------------------------------- + -- Extend_Statement_Sequence -- + ------------------------------- + + procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is + F : Source_Ptr; + T : Source_Ptr; + begin + Sloc_Range (N, F, T); + SC.Append ((N, F, T, Typ)); + end Extend_Statement_Sequence; + + procedure Extend_Statement_Sequence + (From : Node_Id; + To : Node_Id; + Typ : Character) + is + F : Source_Ptr; + T : Source_Ptr; + begin + Sloc_Range (From, F, Dummy); + Sloc_Range (To, Dummy, T); + SC.Append ((From, F, T, Typ)); + end Extend_Statement_Sequence; + + ----------------------------- + -- Process_Decisions_Defer -- + ----------------------------- + + procedure Process_Decisions_Defer (N : Node_Id; T : Character) is + begin + SD.Append ((N, No_List, T, Current_Pragma_Sloc)); + end Process_Decisions_Defer; + + procedure Process_Decisions_Defer (L : List_Id; T : Character) is + begin + SD.Append ((Empty, L, T, Current_Pragma_Sloc)); + end Process_Decisions_Defer; + + -- Start of processing for Traverse_Declarations_Or_Statements + + begin + if Is_Non_Empty_List (L) then + + -- Loop through statements or declarations + + N := First (L); + while Present (N) loop + + -- Initialize or extend current statement sequence. Note that for + -- special cases such as IF and Case statements we will modify + -- the range to exclude internal statements that should not be + -- counted as part of the current statement sequence. + + case Nkind (N) is + + -- Package declaration + + when N_Package_Declaration => + 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 => + Process_Decisions_Defer + (Parameter_Specifications (Specification (N)), 'X'); + + -- Generic subprogram declaration + + when N_Generic_Subprogram_Declaration => + Process_Decisions_Defer + (Generic_Formal_Declarations (N), 'X'); + Process_Decisions_Defer + (Parameter_Specifications (Specification (N)), 'X'); + + -- Task or subprogram body + + when N_Task_Body | N_Subprogram_Body => + Set_Statement_Entry; + Traverse_Subprogram_Or_Task_Body (N); + + -- Entry body + + when N_Entry_Body => + declare + Cond : constant Node_Id := + Condition (Entry_Body_Formal_Part (N)); + Inner_Dominant : Dominant_Info := No_Dominant; + begin + Set_Statement_Entry; + + if Present (Cond) then + Process_Decisions_Defer (Cond, 'G'); + + -- For an entry body with a barrier, the entry body + -- is dominanted by a True evaluation of the barrier. + + Inner_Dominant := ('T', N); + end if; + + Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant); + end; + + -- Protected body + + when N_Protected_Body => + Set_Statement_Entry; + Traverse_Protected_Body (N); + + -- Exit statement, which is an exit statement in the SCO sense, + -- so it is included in the current statement sequence, but + -- then it terminates this sequence. We also have to process + -- any decisions in the exit statement expression. + + when N_Exit_Statement => + Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Condition (N), 'E'); + Set_Statement_Entry; + + -- If condition is present, then following statement is + -- only executed if the condition evaluates to False. + + if Present (Condition (N)) then + Current_Dominant := ('F', N); + else + Current_Dominant := No_Dominant; + end if; + + -- Label, which breaks the current statement sequence, but the + -- label itself is not included in the next statement sequence, + -- since it generates no code. + + when N_Label => + Set_Statement_Entry; + Current_Dominant := No_Dominant; + + -- Block statement, which breaks the current statement sequence + + when N_Block_Statement => + Set_Statement_Entry; + Traverse_Declarations_Or_Statements + (L => Declarations (N), + D => Current_Dominant); + Traverse_Handled_Statement_Sequence + (N => Handled_Statement_Sequence (N), + D => Current_Dominant); + + -- If statement, which breaks the current statement sequence, + -- but we include the condition in the current sequence. + + when N_If_Statement => + Current_Test := N; + Extend_Statement_Sequence (N, Condition (N), 'I'); + Process_Decisions_Defer (Condition (N), 'I'); + Set_Statement_Entry; + + -- Now we traverse the statements in the THEN part + + Traverse_Declarations_Or_Statements + (L => Then_Statements (N), + D => ('T', N)); + + -- Loop through ELSIF parts if present + + if Present (Elsif_Parts (N)) then + declare + Saved_Dominant : constant Dominant_Info := + Current_Dominant; + Elif : Node_Id := First (Elsif_Parts (N)); + + begin + while Present (Elif) loop + + -- An Elsif is executed only if the previous test + -- got a FALSE outcome. + + Current_Dominant := ('F', Current_Test); + + -- Now update current test information + + Current_Test := Elif; + + -- We generate a statement sequence for the + -- construct "ELSIF condition", so that we have + -- a statement for the resulting decisions. + + Extend_Statement_Sequence + (Elif, Condition (Elif), 'I'); + Process_Decisions_Defer (Condition (Elif), 'I'); + Set_Statement_Entry; + + -- An ELSIF part is never guaranteed to have + -- been executed, following statements are only + -- dominated by the initial IF statement. + + Current_Dominant := Saved_Dominant; + + -- Traverse the statements in the ELSIF + + Traverse_Declarations_Or_Statements + (L => Then_Statements (Elif), + D => ('T', Elif)); + Next (Elif); + end loop; + end; + end if; + + -- Finally traverse the ELSE statements if present + + Traverse_Declarations_Or_Statements + (L => Else_Statements (N), + D => ('F', Current_Test)); + + -- Case statement, which breaks the current statement sequence, + -- but we include the expression in the current sequence. + + when N_Case_Statement => + Extend_Statement_Sequence (N, Expression (N), 'C'); + Process_Decisions_Defer (Expression (N), 'X'); + Set_Statement_Entry; + + -- Process case branches, all of which are dominated by the + -- CASE statement. + + declare + Alt : Node_Id; + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Traverse_Declarations_Or_Statements + (L => Statements (Alt), + D => Current_Dominant); + Next (Alt); + end loop; + end; + + -- Unconditional exit points, which are included in the current + -- statement sequence, but then terminate it + + when N_Requeue_Statement | + N_Goto_Statement | + N_Raise_Statement => + Extend_Statement_Sequence (N, ' '); + Set_Statement_Entry; + Current_Dominant := No_Dominant; + + -- Simple return statement. which is an exit point, but we + -- have to process the return expression for decisions. + + when N_Simple_Return_Statement => + Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Expression (N), 'X'); + Set_Statement_Entry; + Current_Dominant := No_Dominant; + + -- Extended return statement + + when N_Extended_Return_Statement => + Extend_Statement_Sequence + (N, Last (Return_Object_Declarations (N)), 'R'); + Process_Decisions_Defer + (Return_Object_Declarations (N), 'X'); + Set_Statement_Entry; + + Traverse_Handled_Statement_Sequence + (N => Handled_Statement_Sequence (N), + D => Current_Dominant); + + Current_Dominant := No_Dominant; + + -- Loop ends the current statement sequence, but we include + -- the iteration scheme if present in the current sequence. + -- But the body of the loop starts a new sequence, since it + -- may not be executed as part of the current sequence. + + when N_Loop_Statement => + declare + ISC : constant Node_Id := Iteration_Scheme (N); + Inner_Dominant : Dominant_Info := No_Dominant; + + begin + if Present (ISC) then + + -- If iteration scheme present, extend the current + -- statement sequence to include the iteration scheme + -- and process any decisions it contains. + + -- While loop + + if Present (Condition (ISC)) then + Extend_Statement_Sequence (N, ISC, 'W'); + Process_Decisions_Defer (Condition (ISC), 'W'); + + -- Set more specific dominant for inner statements + -- (the control sloc for the decision is that of + -- the WHILE token). + + Inner_Dominant := ('T', ISC); + + -- For loop + + else + Extend_Statement_Sequence (N, ISC, 'F'); + Process_Decisions_Defer + (Loop_Parameter_Specification (ISC), 'X'); + end if; + end if; + + Set_Statement_Entry; + + if Inner_Dominant = No_Dominant then + Inner_Dominant := Current_Dominant; + end if; + + Traverse_Declarations_Or_Statements + (L => Statements (N), + D => Inner_Dominant); + end; + + -- Pragma + + when N_Pragma => + + -- Record sloc of pragma (pragmas don't nest) + + pragma Assert (Current_Pragma_Sloc = No_Location); + Current_Pragma_Sloc := Sloc (N); + + -- Processing depends on the kind of pragma + + declare + Nam : constant Name_Id := Pragma_Name (N); + Arg : Node_Id := First (Pragma_Argument_Associations (N)); + Typ : Character; + + begin + case Nam is + when Name_Assert | + Name_Check | + Name_Precondition | + Name_Postcondition => + + -- For Assert/Check/Precondition/Postcondition, we + -- must generate a P entry for the decision. Note + -- that this is done unconditionally at this stage. + -- Output for disabled pragmas is suppressed later + -- on when we output the decision line in Put_SCOs, + -- depending on setting by Set_SCO_Pragma_Enabled. + + if Nam = Name_Check then + Next (Arg); + end if; + + Process_Decisions_Defer (Expression (Arg), 'P'); + Typ := 'p'; + + when Name_Debug => + if Present (Arg) and then Present (Next (Arg)) then + + -- Case of a dyadic pragma Debug: first argument + -- is a P decision, any nested decision in the + -- second argument is an X decision. + + Process_Decisions_Defer (Expression (Arg), 'P'); + Next (Arg); + end if; + + Process_Decisions_Defer (Expression (Arg), 'X'); + Typ := 'p'; + + -- For all other pragmas, we generate decision entries + -- for any embedded expressions, and the pragma is + -- never disabled. + + when others => + Process_Decisions_Defer (N, 'X'); + Typ := 'P'; + end case; + + -- Add statement SCO + + Extend_Statement_Sequence (N, Typ); + + Current_Pragma_Sloc := No_Location; + end; + + -- Object declaration. Ignored if Prev_Ids is set, since the + -- parser generates multiple instances of the whole declaration + -- if there is more than one identifier declared, and we only + -- want one entry in the SCO's, so we take the first, for which + -- Prev_Ids is False. + + when N_Object_Declaration => + if not Prev_Ids (N) then + Extend_Statement_Sequence (N, 'o'); + + if Has_Decision (N) then + Process_Decisions_Defer (N, 'X'); + end if; + end if; + + -- All other cases, which extend the current statement sequence + -- but do not terminate it, even if they have nested decisions. + + when others => + + -- Determine required type character code, or ASCII.NUL if + -- no SCO should be generated for this node. + + declare + Typ : Character; + + begin + case Nkind (N) is + when N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Private_Type_Declaration | + N_Private_Extension_Declaration => + Typ := 't'; + + when N_Subtype_Declaration => + Typ := 's'; + + when N_Renaming_Declaration => + Typ := 'r'; + + when N_Generic_Instantiation => + Typ := 'i'; + + when N_Representation_Clause | + N_Use_Package_Clause | + N_Use_Type_Clause => + Typ := ASCII.NUL; + + when others => + Typ := ' '; + end case; + + if Typ /= ASCII.NUL then + Extend_Statement_Sequence (N, Typ); + end if; + end; + + -- Process any embedded decisions + + if Has_Decision (N) then + Process_Decisions_Defer (N, 'X'); + end if; + end case; + + Next (N); + end loop; + + Set_Statement_Entry; + end if; + end Traverse_Declarations_Or_Statements; + + ------------------------------------ + -- Traverse_Generic_Instantiation -- + ------------------------------------ + + procedure Traverse_Generic_Instantiation (N : Node_Id) is + First : Source_Ptr; + Last : Source_Ptr; + + begin + -- First we need a statement entry to cover the instantiation + + Sloc_Range (N, First, Last); + Set_Table_Entry + (C1 => 'S', + C2 => ' ', + From => First, + To => Last, + Last => True); + + -- Now output any embedded decisions + + Process_Decisions (N, 'X', No_Location); + end Traverse_Generic_Instantiation; + + ------------------------------------------ + -- Traverse_Generic_Package_Declaration -- + ------------------------------------------ + + procedure Traverse_Generic_Package_Declaration (N : Node_Id) is + begin + Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location); + Traverse_Package_Declaration (N); + end Traverse_Generic_Package_Declaration; + + ----------------------------------------- + -- Traverse_Handled_Statement_Sequence -- + ----------------------------------------- + + procedure Traverse_Handled_Statement_Sequence + (N : Node_Id; + D : Dominant_Info := No_Dominant) + is + Handler : Node_Id; + + begin + -- For package bodies without a statement part, the parser adds an empty + -- one, to normalize the representation. The null statement therein, + -- which does not come from source, does not get a SCO. + + if Present (N) and then Comes_From_Source (N) then + Traverse_Declarations_Or_Statements (Statements (N), D); + + if Present (Exception_Handlers (N)) then + Handler := First (Exception_Handlers (N)); + while Present (Handler) loop + Traverse_Declarations_Or_Statements + (L => Statements (Handler), + D => ('E', 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_Protected_Body -- + ----------------------------- + + procedure Traverse_Protected_Body (N : Node_Id) is + begin + Traverse_Declarations_Or_Statements (Declarations (N)); + end Traverse_Protected_Body; + + -------------------------------------- + -- Traverse_Subprogram_Or_Task_Body -- + -------------------------------------- + + procedure Traverse_Subprogram_Or_Task_Body + (N : Node_Id; + D : Dominant_Info := No_Dominant) + is + begin + Traverse_Declarations_Or_Statements (Declarations (N), D); + Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N), D); + end Traverse_Subprogram_Or_Task_Body; + + ------------------------------------- + -- Traverse_Subprogram_Declaration -- + ------------------------------------- + + procedure Traverse_Subprogram_Declaration (N : Node_Id) is + ADN : constant Node_Id := Aux_Decls_Node (Parent (N)); + begin + Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); + Traverse_Declarations_Or_Statements (Declarations (ADN)); + Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); + end Traverse_Subprogram_Declaration; + +end Par_SCO; |