URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [par_sco.adb] - Rev 716
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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;
Go to most recent revision | Compare with Previous | Blame | View Log