diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/par_sco.adb')
-rw-r--r-- | gcc-4.8.3/gcc/ada/par_sco.adb | 2246 |
1 files changed, 2246 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/par_sco.adb b/gcc-4.8.3/gcc/ada/par_sco.adb new file mode 100644 index 000000000..54fe0ddb8 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/par_sco.adb @@ -0,0 +1,2246 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |