diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/par_sco.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/par_sco.adb | 2246 |
1 files changed, 0 insertions, 2246 deletions
diff --git a/gcc-4.8/gcc/ada/par_sco.adb b/gcc-4.8/gcc/ada/par_sco.adb deleted file mode 100644 index 54fe0ddb8..000000000 --- a/gcc-4.8/gcc/ada/par_sco.adb +++ /dev/null @@ -1,2246 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P A R _ S C O -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2012, 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 Aspects; use Aspects; -with Atree; use Atree; -with Debug; use Debug; -with Errout; use Errout; -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 Sem; use Sem; -with Sem_Util; use Sem_Util; -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. - - function To_Source_Location (S : Source_Ptr) return Source_Location; - -- Converts Source_Ptr value to Source_Location (line/col) format - - 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 if 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_Aspect_Name : Name_Id := No_Name); - -- 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 Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr); - -- Add one entry from the instance table to the corresponding SCO table - - procedure Traverse_Declarations_Or_Statements - (L : List_Id; - D : Dominant_Info := No_Dominant; - P : Node_Id := Empty); - -- Process L, a list of statements or declarations dominated by D. - -- If P is present, it is processed as though it had been prepended to L. - - function Traverse_Declarations_Or_Statements - (L : List_Id; - D : Dominant_Info := No_Dominant; - P : Node_Id := Empty) return Dominant_Info; - -- Same as above, and returns dominant information corresponding to the - -- last node with SCO in L. - - -- The following Traverse_* routines perform appropriate calls to - -- Traverse_Declarations_Or_Statements to traverse specific node kinds. - -- Parameter D, when present, indicates the dominant of the first - -- declaration or statement within N. - - -- Why is Traverse_Sync_Definition commented specificaly and - -- the others are not??? - - 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; - D : Dominant_Info := No_Dominant); - procedure Traverse_Subprogram_Or_Task_Body - (N : Node_Id; - D : Dominant_Info := No_Dominant); - - procedure Traverse_Sync_Definition (N : Node_Id); - -- Traverse a protected definition or task definition - - 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 - - Nam : Name_Id := No_Name; - -- For the case of an aspect, aspect name - - begin - case T is - when 'I' | 'E' | 'W' | 'a' | 'A' => - - -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of - -- the parent of the expression. - - Loc := Sloc (Parent (N)); - - if T = 'a' or else T = 'A' then - Nam := Chars (Identifier (Parent (N))); - end if; - - when 'G' | 'P' => - - -- For entry guard, 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. For the guard on a select - -- alternative, we do not have access to the token location for - -- the WHEN, so we use the first sloc of the condition itself - -- (note: we use First_Sloc, not Sloc, because this is what is - -- referenced by dominance markers). - - -- Doesn't this requirement of using First_Sloc need to be - -- documented in the spec ??? - - if Nkind_In (Parent (N), N_Accept_Alternative, - N_Delay_Alternative, - N_Terminate_Alternative) - then - Loc := First_Sloc (N); - else - Loc := Sloc (Parent (Parent (N))); - end if; - - 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, - Pragma_Aspect_Name => Nam); - - -- For an aspect specification, which will be rewritten into a - -- pragma, enter a hash table entry now. - - if T = 'a' then - Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last); - end if; - 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 - - -- Really hard to believe this is correct given the special - -- handling for if expressions below ??? - - when N_Case_Expression => - return OK; -- ??? - - -- If expression, processed like an if statement - - when N_If_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; - - --------------------- - -- Record_Instance -- - --------------------- - - procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is - Inst_Src : constant Source_File_Index := - Get_Source_File_Index (Inst_Sloc); - begin - SCO_Instance_Table.Append - ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)), - Inst_Loc => To_Source_Location (Inst_Sloc), - Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src)))); - pragma Assert - (SCO_Instance_Table.Last = SCO_Instance_Index (Id)); - end Record_Instance; - - ---------------- - -- SCO_Output -- - ---------------- - - procedure SCO_Output is - procedure Populate_SCO_Instance_Table is - new Sinput.Iterate_On_Instances (Record_Instance); - - SCO_Index : Nat; - - begin - if Debug_Flag_Dot_OO then - dsco; - end if; - - Populate_SCO_Instance_Table; - - -- 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; - - -- Stamp out SCO entries for decisions in disabled constructs (pragmas - -- or aspects). - - SCO_Index := 1; - while SCO_Index <= SCO_Table.Last loop - if Is_Decision (SCO_Table.Table (SCO_Index).C1) - and then SCO_Pragma_Disabled - (SCO_Table.Table (SCO_Index).Pragma_Sloc) - then - loop - SCO_Table.Table (SCO_Index).C1 := ASCII.NUL; - exit when SCO_Table.Table (SCO_Index).Last; - SCO_Index := SCO_Index + 1; - end loop; - end if; - - SCO_Index := SCO_Index + 1; - 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 - case T.C1 is - when 'S' => - -- Pragma statement - - return T.C2 = 'p'; - - when 'A' => - -- Aspect decision (enabled) - - return False; - - when 'a' => - -- Aspect decision (not enabled) - - return True; - - when ASCII.NUL => - -- Nullified disabled SCO - - return True; - - when others => - raise Program_Error; - end case; - 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; - - procedure Traverse_Aux_Decls (N : Node_Id); - -- Traverse the Aux_Decl_Nodes of compilation unit N - - ------------------------ - -- Traverse_Aux_Decls -- - ------------------------ - - procedure Traverse_Aux_Decls (N : Node_Id) is - ADN : constant Node_Id := Aux_Decls_Node (N); - begin - Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); - Traverse_Declarations_Or_Statements (Declarations (ADN)); - Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); - end Traverse_Aux_Decls; - - -- Start of processing for SCO_Record - - 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 - - Traverse_Aux_Decls (Cunit (U)); - - case Nkind (Lu) is - when - N_Package_Declaration | - N_Package_Body | - N_Subprogram_Declaration | - N_Subprogram_Body | - N_Generic_Package_Declaration | - N_Protected_Body | - N_Task_Body | - N_Generic_Instantiation => - - Traverse_Declarations_Or_Statements (L => No_List, P => 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); - - -- Index can be zero for boolean expressions that do not have SCOs - -- (simple decisions outside of a control flow structure), or in case - -- of a previous error. - - if Index = 0 then - return; - - else - 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 - -- Nothing to do if not generating SCO, or if we're not processing the - -- original source occurrence of the pragma. - - if not (Generate_SCO - and then In_Extended_Main_Source_Unit (Loc) - and then not (In_Instance or In_Inlined_Body)) - then - return; - end if; - - -- 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); - - -- A zero index here indicates that semantic analysis found an - -- activated pragma at Loc which does not have a corresponding pragma - -- or aspect at the syntax level. This may occur in legitimate cases - -- because of expanded code (such are Pre/Post conditions generated for - -- formal parameter validity checks), or as a consequence of a previous - -- error. - - if Index = 0 then - return; - - else - declare - T : SCO_Table_Entry renames SCO_Table.Table (Index); - - begin - -- Note: may be called multiple times for the same sloc, so - -- account for the fact that the entry may already have been - -- marked enabled. - - case T.C1 is - -- Aspect (decision SCO) - - when 'a' => - T.C1 := 'A'; - - when 'A' => - null; - - -- Pragma (statement SCO) - - when 'S' => - pragma Assert (T.C2 = 'p' or else T.C2 = 'P'); - T.C2 := 'P'; - - when others => - raise Program_Error; - end case; - 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_Aspect_Name : Name_Id := No_Name) - is - 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_Aspect_Name => Pragma_Aspect_Name)); - end Set_Table_Entry; - - ------------------------ - -- 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; - - ----------------------------------------- - -- 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; - P : Node_Id := Empty) - is - Discard_Dom : Dominant_Info; - pragma Warnings (Off, Discard_Dom); - begin - Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P); - end Traverse_Declarations_Or_Statements; - - function Traverse_Declarations_Or_Statements - (L : List_Id; - D : Dominant_Info := No_Dominant; - P : Node_Id := Empty) return Dominant_Info - 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; - - 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 Set_Statement_Entry; - -- Output CS entries for all statements saved in table SC, and end the - -- current CS sequence. Then output entries for all decisions nested in - -- these statements, which have been deferred so far. - - 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 - - procedure Traverse_One (N : Node_Id); - -- Traverse one declaration or statement - - procedure Traverse_Aspects (N : Node_Id); - -- Helper for Traverse_One: traverse N's aspect specifications - - ------------------------- - -- 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_Aspect_Name => No_Name); - end; - end if; - end if; - - declare - SCE : SC_Entry renames SC.Table (J); - Pragma_Sloc : Source_Ptr := No_Location; - Pragma_Aspect_Name : Name_Id := No_Name; - 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_Aspect_Name := Pragma_Name (SCE.N); - pragma Assert (Pragma_Aspect_Name /= No_Name); - - elsif SCE.Typ = 'P' then - Pragma_Aspect_Name := Pragma_Name (SCE.N); - pragma Assert (Pragma_Aspect_Name /= No_Name); - 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_Aspect_Name => Pragma_Aspect_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; - Dummy : Source_Ptr; - To_Node : Node_Id := Empty; - - begin - Sloc_Range (N, F, T); - - case Nkind (N) is - when N_Accept_Statement => - if Present (Parameter_Specifications (N)) then - To_Node := Last (Parameter_Specifications (N)); - elsif Present (Entry_Index (N)) then - To_Node := Entry_Index (N); - end if; - - when N_Case_Statement => - To_Node := Expression (N); - - when N_If_Statement | N_Elsif_Part => - To_Node := Condition (N); - - when N_Extended_Return_Statement => - To_Node := Last (Return_Object_Declarations (N)); - - when N_Loop_Statement => - To_Node := Iteration_Scheme (N); - - when N_Selective_Accept | - N_Timed_Entry_Call | - N_Conditional_Entry_Call | - N_Asynchronous_Select | - N_Single_Protected_Declaration | - N_Single_Task_Declaration => - T := F; - - when N_Protected_Type_Declaration | N_Task_Type_Declaration => - if Has_Aspects (N) then - To_Node := Last (Aspect_Specifications (N)); - - elsif Present (Discriminant_Specifications (N)) then - To_Node := Last (Discriminant_Specifications (N)); - - else - To_Node := Defining_Identifier (N); - end if; - - when others => - null; - - end case; - - if Present (To_Node) then - Sloc_Range (To_Node, Dummy, T); - end if; - - SC.Append ((N, 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; - - ---------------------- - -- Traverse_Aspects -- - ---------------------- - - procedure Traverse_Aspects (N : Node_Id) is - AN : Node_Id; - AE : Node_Id; - C1 : Character; - - begin - AN := First (Aspect_Specifications (N)); - while Present (AN) loop - AE := Expression (AN); - - -- SCOs are generated before semantic analysis/expansion: - -- PPCs are not split yet. - - pragma Assert (not Split_PPC (AN)); - - C1 := ASCII.NUL; - - case Get_Aspect_Id (Chars (Identifier (AN))) is - - -- Aspects rewritten into pragmas controlled by a Check_Policy: - -- Current_Pragma_Sloc must be set to the sloc of the aspect - -- specification. The corresponding pragma will have the same - -- sloc. - - when Aspect_Pre | - Aspect_Precondition | - Aspect_Post | - Aspect_Postcondition | - Aspect_Invariant => - - C1 := 'a'; - - -- Aspects whose checks are generated in client units, - -- regardless of whether or not the check is activated in the - -- unit which contains the declaration: create decision as - -- unconditionally enabled aspect (but still make a pragma - -- entry since Set_SCO_Pragma_Enabled will be called when - -- analyzing actual checks, possibly in other units). - - -- Pre/post can have checks in client units too because of - -- inheritance, so should they be moved here??? - - when Aspect_Predicate | - Aspect_Static_Predicate | - Aspect_Dynamic_Predicate | - Aspect_Type_Invariant => - - C1 := 'A'; - - -- Other aspects: just process any decision nested in the - -- aspect expression. - - when others => - - if Has_Decision (AE) then - C1 := 'X'; - end if; - - end case; - - if C1 /= ASCII.NUL then - pragma Assert (Current_Pragma_Sloc = No_Location); - - if C1 = 'a' or else C1 = 'A' then - Current_Pragma_Sloc := Sloc (AN); - end if; - - Process_Decisions_Defer (AE, C1); - - Current_Pragma_Sloc := No_Location; - end if; - - Next (AN); - end loop; - end Traverse_Aspects; - - ------------------ - -- Traverse_One -- - ------------------ - - procedure Traverse_One (N : Node_Id) is - begin - -- 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, Current_Dominant); - - -- 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 | N_Subprogram_Body_Stub => - 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_Declarations_Or_Statements (Declarations (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; - - -- The first statement in the handled sequence of statements - -- is dominated by the elaboration of the last declaration. - - Current_Dominant := 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, '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, '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, '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; - - -- ACCEPT statement - - when N_Accept_Statement => - Extend_Statement_Sequence (N, 'A'); - Set_Statement_Entry; - - -- Process sequence of statements, dominant is the ACCEPT - -- statement. - - Traverse_Handled_Statement_Sequence - (N => Handled_Statement_Sequence (N), - D => Current_Dominant); - - -- SELECT - - when N_Selective_Accept => - Extend_Statement_Sequence (N, 'S'); - Set_Statement_Entry; - - -- Process alternatives - - declare - Alt : Node_Id; - Guard : Node_Id; - S_Dom : Dominant_Info; - - begin - Alt := First (Select_Alternatives (N)); - while Present (Alt) loop - S_Dom := Current_Dominant; - Guard := Condition (Alt); - - if Present (Guard) then - Process_Decisions - (Guard, - 'G', - Pragma_Sloc => No_Location); - Current_Dominant := ('T', Guard); - end if; - - Traverse_One (Alt); - - Current_Dominant := S_Dom; - Next (Alt); - end loop; - end; - - Traverse_Declarations_Or_Statements - (L => Else_Statements (N), - D => Current_Dominant); - - when N_Timed_Entry_Call | N_Conditional_Entry_Call => - Extend_Statement_Sequence (N, 'S'); - Set_Statement_Entry; - - -- Process alternatives - - Traverse_One (Entry_Call_Alternative (N)); - - if Nkind (N) = N_Timed_Entry_Call then - Traverse_One (Delay_Alternative (N)); - else - Traverse_Declarations_Or_Statements - (L => Else_Statements (N), - D => Current_Dominant); - end if; - - when N_Asynchronous_Select => - Extend_Statement_Sequence (N, 'S'); - Set_Statement_Entry; - - Traverse_One (Triggering_Alternative (N)); - Traverse_Declarations_Or_Statements - (L => Statements (Abortable_Part (N)), - D => Current_Dominant); - - when N_Accept_Alternative => - Traverse_Declarations_Or_Statements - (L => Statements (N), - D => Current_Dominant, - P => Accept_Statement (N)); - - when N_Entry_Call_Alternative => - Traverse_Declarations_Or_Statements - (L => Statements (N), - D => Current_Dominant, - P => Entry_Call_Statement (N)); - - when N_Delay_Alternative => - Traverse_Declarations_Or_Statements - (L => Statements (N), - D => Current_Dominant, - P => Delay_Statement (N)); - - when N_Triggering_Alternative => - Traverse_Declarations_Or_Statements - (L => Statements (N), - D => Current_Dominant, - P => Triggering_Statement (N)); - - when N_Terminate_Alternative => - - -- It is dubious to emit a statement SCO for a TERMINATE - -- alternative, since no code is actually executed if the - -- alternative is selected -- the tasking runtime call just - -- never returns??? - - Extend_Statement_Sequence (N, ' '); - Set_Statement_Entry; - - -- 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, '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, '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, '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_Assert_And_Cut | - Name_Assume | - Name_Check | - Name_Loop_Invariant | - 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'; - - -- Pre/postconditions can be inherited so SCO should - -- never be deactivated??? - - 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. - - -- Should generate P decisions (not X) for assertion - -- related pragmas: [Type_]Invariant, - -- [{Static,Dynamic}_]Predicate??? - - 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 SCOs, 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 N_Protected_Type_Declaration | N_Task_Type_Declaration => - Extend_Statement_Sequence (N, 't'); - Process_Decisions_Defer (Discriminant_Specifications (N), 'X'); - Set_Statement_Entry; - - Traverse_Sync_Definition (N); - - when N_Single_Protected_Declaration | N_Single_Task_Declaration => - Extend_Statement_Sequence (N, 'o'); - Set_Statement_Entry; - - Traverse_Sync_Definition (N); - - 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 | - N_Package_Body_Stub | - N_Task_Body_Stub | - N_Protected_Body_Stub => - 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; - - -- Process aspects if present - - Traverse_Aspects (N); - end Traverse_One; - - -- Start of processing for Traverse_Declarations_Or_Statements - - begin - -- Process single prefixed node - - if Present (P) then - Traverse_One (P); - end if; - - -- Loop through statements or declarations - - if Is_Non_Empty_List (L) then - N := First (L); - while Present (N) loop - Traverse_One (N); - Next (N); - end loop; - - end if; - - -- End sequence of statements and flush deferred decisions - - if Present (P) or else Is_Non_Empty_List (L) then - Set_Statement_Entry; - end if; - - return Current_Dominant; - 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', 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 - Dom : Dominant_Info; - begin - -- The first statement in the handled sequence of statements is - -- dominated by the elaboration of the last declaration. - - Dom := Traverse_Declarations_Or_Statements (Declarations (N)); - - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Dom); - end Traverse_Package_Body; - - ---------------------------------- - -- Traverse_Package_Declaration -- - ---------------------------------- - - procedure Traverse_Package_Declaration - (N : Node_Id; - D : Dominant_Info := No_Dominant) - is - Spec : constant Node_Id := Specification (N); - Dom : Dominant_Info; - - begin - Dom := - Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D); - - -- First private declaration is dominated by last visible declaration - - Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom); - end Traverse_Package_Declaration; - - ------------------------------ - -- Traverse_Sync_Definition -- - ------------------------------ - - procedure Traverse_Sync_Definition (N : Node_Id) is - Dom_Info : Dominant_Info := ('S', N); - -- The first declaration is dominated by the protected or task [type] - -- declaration. - - Sync_Def : Node_Id; - -- N's protected or task definition - - Vis_Decl : List_Id; - -- Sync_Def's Visible_Declarations - - begin - case Nkind (N) is - when N_Single_Protected_Declaration | N_Protected_Type_Declaration => - Sync_Def := Protected_Definition (N); - - when N_Single_Task_Declaration | N_Task_Type_Declaration => - Sync_Def := Task_Definition (N); - - when others => - raise Program_Error; - end case; - - Vis_Decl := Visible_Declarations (Sync_Def); - - Dom_Info := Traverse_Declarations_Or_Statements - (L => Vis_Decl, - D => Dom_Info); - - -- If visible declarations are present, the first private declaration - -- is dominated by the last visible declaration. - - Traverse_Declarations_Or_Statements - (L => Private_Declarations (Sync_Def), - D => Dom_Info); - end Traverse_Sync_Definition; - - -------------------------------------- - -- Traverse_Subprogram_Or_Task_Body -- - -------------------------------------- - - procedure Traverse_Subprogram_Or_Task_Body - (N : Node_Id; - D : Dominant_Info := No_Dominant) - is - Decls : constant List_Id := Declarations (N); - Dom_Info : Dominant_Info := D; - begin - -- If declarations are present, the first statement is dominated by the - -- last declaration. - - Dom_Info := Traverse_Declarations_Or_Statements - (L => Decls, D => Dom_Info); - - Traverse_Handled_Statement_Sequence - (N => Handled_Statement_Sequence (N), - D => Dom_Info); - end Traverse_Subprogram_Or_Task_Body; - -end Par_SCO; |