1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2009-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Errout; use Errout;
31 with Lib.Util; use Lib.Util;
32 with Namet; use Namet;
33 with Nlists; use Nlists;
35 with Output; use Output;
39 with Sem_Util; use Sem_Util;
40 with Sinfo; use Sinfo;
41 with Sinput; use Sinput;
42 with Snames; use Snames;
45 with GNAT.HTable; use GNAT.HTable;
46 with GNAT.Heap_Sort_G;
48 package body Par_SCO is
50 -----------------------
51 -- Unit Number Table --
52 -----------------------
54 -- This table parallels the SCO_Unit_Table, keeping track of the unit
55 -- numbers corresponding to the entries made in this table, so that before
56 -- writing out the SCO information to the ALI file, we can fill in the
57 -- proper dependency numbers and file names.
59 -- Note that the zero'th entry is here for convenience in sorting the
60 -- table, the real lower bound is 1.
62 package SCO_Unit_Number_Table is new Table.Table (
63 Table_Component_Type => Unit_Number_Type,
64 Table_Index_Type => SCO_Unit_Index,
65 Table_Low_Bound => 0, -- see note above on sort
67 Table_Increment => 200,
68 Table_Name => "SCO_Unit_Number_Entry");
70 ---------------------------------
71 -- Condition/Pragma Hash Table --
72 ---------------------------------
74 -- We need to be able to get to conditions quickly for handling the calls
75 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
76 -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the
77 -- conditions and pragmas in the table by their starting sloc, and use this
78 -- hash table to map from these sloc values to SCO_Table indexes.
80 type Header_Num is new Integer range 0 .. 996;
81 -- Type for hash table headers
83 function Hash (F : Source_Ptr) return Header_Num;
84 -- Function to Hash source pointer value
86 function Equal (F1, F2 : Source_Ptr) return Boolean;
87 -- Function to test two keys for equality
89 package Condition_Pragma_Hash_Table is new Simple_HTable
90 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
91 -- The actual hash table
93 --------------------------
94 -- Internal Subprograms --
95 --------------------------
97 function Has_Decision (N : Node_Id) return Boolean;
98 -- N is the node for a subexpression. Returns True if the subexpression
99 -- contains a nested decision (i.e. either is a logical operator, or
100 -- contains a logical operator in its subtree).
102 function Is_Logical_Operator (N : Node_Id) return Boolean;
103 -- N is the node for a subexpression. This procedure just tests N to see
104 -- if it is a logical operator (including short circuit conditions, but
105 -- excluding OR and AND) and returns True if so, False otherwise, it does
106 -- no other processing.
108 function To_Source_Location (S : Source_Ptr) return Source_Location;
109 -- Converts Source_Ptr value to Source_Location (line/col) format
111 procedure Process_Decisions
114 Pragma_Sloc : Source_Ptr);
115 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
116 -- to output any decisions it contains. T is one of IEGPWX (for context of
117 -- expression: if/exit when/entry guard/pragma/while/expression). If T is
118 -- other than X, the node N is the if expression involved, and a decision
119 -- is always present (at the very least a simple decision is present at the
122 procedure Process_Decisions
125 Pragma_Sloc : Source_Ptr);
126 -- Calls above procedure for each element of the list L
128 procedure Set_Table_Entry
134 Pragma_Sloc : Source_Ptr := No_Location;
135 Pragma_Aspect_Name : Name_Id := No_Name);
136 -- Append an entry to SCO_Table with fields set as per arguments
138 type Dominant_Info is record
140 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant
143 -- Node providing the Sloc(s) for the dominance marker
145 No_Dominant : constant Dominant_Info := (' ', Empty);
147 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr);
148 -- Add one entry from the instance table to the corresponding SCO table
150 procedure Traverse_Declarations_Or_Statements
152 D : Dominant_Info := No_Dominant;
153 P : Node_Id := Empty);
154 -- Process L, a list of statements or declarations dominated by D.
155 -- If P is present, it is processed as though it had been prepended to L.
157 function Traverse_Declarations_Or_Statements
159 D : Dominant_Info := No_Dominant;
160 P : Node_Id := Empty) return Dominant_Info;
161 -- Same as above, and returns dominant information corresponding to the
162 -- last node with SCO in L.
164 -- The following Traverse_* routines perform appropriate calls to
165 -- Traverse_Declarations_Or_Statements to traverse specific node kinds.
166 -- Parameter D, when present, indicates the dominant of the first
167 -- declaration or statement within N.
169 -- Why is Traverse_Sync_Definition commented specificaly and
170 -- the others are not???
172 procedure Traverse_Generic_Package_Declaration (N : Node_Id);
173 procedure Traverse_Handled_Statement_Sequence
175 D : Dominant_Info := No_Dominant);
176 procedure Traverse_Package_Body (N : Node_Id);
177 procedure Traverse_Package_Declaration
179 D : Dominant_Info := No_Dominant);
180 procedure Traverse_Subprogram_Or_Task_Body
182 D : Dominant_Info := No_Dominant);
184 procedure Traverse_Sync_Definition (N : Node_Id);
185 -- Traverse a protected definition or task definition
187 procedure Write_SCOs_To_ALI_File is new Put_SCOs;
188 -- Write SCO information to the ALI file using routines in Lib.Util
196 -- Dump SCO unit table
198 Write_Line ("SCO Unit Table");
199 Write_Line ("--------------");
201 for Index in 1 .. SCO_Unit_Table.Last loop
203 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
207 Write_Int (Int (Index));
208 Write_Str (". Dep_Num = ");
209 Write_Int (Int (UTE.Dep_Num));
210 Write_Str (" From = ");
211 Write_Int (Int (UTE.From));
212 Write_Str (" To = ");
213 Write_Int (Int (UTE.To));
215 Write_Str (" File_Name = """);
217 if UTE.File_Name /= null then
218 Write_Str (UTE.File_Name.all);
226 -- Dump SCO Unit number table if it contains any entries
228 if SCO_Unit_Number_Table.Last >= 1 then
230 Write_Line ("SCO Unit Number Table");
231 Write_Line ("---------------------");
233 for Index in 1 .. SCO_Unit_Number_Table.Last loop
235 Write_Int (Int (Index));
236 Write_Str (". Unit_Number = ");
237 Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
242 -- Dump SCO table itself
245 Write_Line ("SCO Table");
246 Write_Line ("---------");
248 for Index in 1 .. SCO_Table.Last loop
250 T : SCO_Table_Entry renames SCO_Table.Table (Index);
258 Write_Str (" C1 = '");
264 Write_Str (" C2 = '");
269 if T.From /= No_Source_Location then
270 Write_Str (" From = ");
271 Write_Int (Int (T.From.Line));
273 Write_Int (Int (T.From.Col));
276 if T.To /= No_Source_Location then
277 Write_Str (" To = ");
278 Write_Int (Int (T.To.Line));
280 Write_Int (Int (T.To.Col));
286 Write_Str (" False");
298 function Equal (F1, F2 : Source_Ptr) return Boolean is
307 function Has_Decision (N : Node_Id) return Boolean is
309 function Check_Node (N : Node_Id) return Traverse_Result;
315 function Check_Node (N : Node_Id) return Traverse_Result is
317 if Is_Logical_Operator (N) then
324 function Traverse is new Traverse_Func (Check_Node);
326 -- Start of processing for Has_Decision
329 return Traverse (N) = Abandon;
336 function Hash (F : Source_Ptr) return Header_Num is
338 return Header_Num (Nat (F) mod 997);
345 procedure Initialize is
347 SCO_Unit_Number_Table.Init;
349 -- Set dummy 0'th entry in place for sort
351 SCO_Unit_Number_Table.Increment_Last;
354 -------------------------
355 -- Is_Logical_Operator --
356 -------------------------
358 function Is_Logical_Operator (N : Node_Id) return Boolean is
360 return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else);
361 end Is_Logical_Operator;
363 -----------------------
364 -- Process_Decisions --
365 -----------------------
367 -- Version taking a list
369 procedure Process_Decisions
372 Pragma_Sloc : Source_Ptr)
378 while Present (N) loop
379 Process_Decisions (N, T, Pragma_Sloc);
383 end Process_Decisions;
385 -- Version taking a node
387 Current_Pragma_Sloc : Source_Ptr := No_Location;
388 -- While processing a pragma, this is set to the sloc of the N_Pragma node
390 procedure Process_Decisions
393 Pragma_Sloc : Source_Ptr)
396 -- This is used to mark the location of a decision sequence in the SCO
397 -- table. We use it for backing out a simple decision in an expression
398 -- context that contains only NOT operators.
400 X_Not_Decision : Boolean;
401 -- This flag keeps track of whether a decision sequence in the SCO table
402 -- contains only NOT operators, and is for an expression context (T=X).
403 -- The flag will be set False if T is other than X, or if an operator
404 -- other than NOT is in the sequence.
406 function Process_Node (N : Node_Id) return Traverse_Result;
407 -- Processes one node in the traversal, looking for logical operators,
408 -- and if one is found, outputs the appropriate table entries.
410 procedure Output_Decision_Operand (N : Node_Id);
411 -- The node N is the top level logical operator of a decision, or it is
412 -- one of the operands of a logical operator belonging to a single
413 -- complex decision. This routine outputs the sequence of table entries
414 -- corresponding to the node. Note that we do not process the sub-
415 -- operands to look for further decisions, that processing is done in
416 -- Process_Decision_Operand, because we can't get decisions mixed up in
417 -- the global table. Call has no effect if N is Empty.
419 procedure Output_Element (N : Node_Id);
420 -- Node N is an operand of a logical operator that is not itself a
421 -- logical operator, or it is a simple decision. This routine outputs
422 -- the table entry for the element, with C1 set to ' '. Last is set
423 -- False, and an entry is made in the condition hash table.
425 procedure Output_Header (T : Character);
426 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
427 -- PRAGMA, and 'X' for the expression case.
429 procedure Process_Decision_Operand (N : Node_Id);
430 -- This is called on node N, the top level node of a decision, or on one
431 -- of its operands or suboperands after generating the full output for
432 -- the complex decision. It process the suboperands of the decision
433 -- looking for nested decisions.
435 -----------------------------
436 -- Output_Decision_Operand --
437 -----------------------------
439 procedure Output_Decision_Operand (N : Node_Id) is
449 elsif Is_Logical_Operator (N) then
450 if Nkind (N) = N_Op_Not then
457 if Nkind_In (N, N_Op_Or, N_Or_Else) then
471 Output_Decision_Operand (L);
472 Output_Decision_Operand (Right_Opnd (N));
474 -- Not a logical operator
479 end Output_Decision_Operand;
485 procedure Output_Element (N : Node_Id) is
489 Sloc_Range (N, FSloc, LSloc);
496 Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last);
503 procedure Output_Header (T : Character) is
504 Loc : Source_Ptr := No_Location;
505 -- Node whose Sloc is used for the decision
507 Nam : Name_Id := No_Name;
508 -- For the case of an aspect, aspect name
512 when 'I' | 'E' | 'W' | 'a' | 'A' =>
514 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
515 -- the parent of the expression.
517 Loc := Sloc (Parent (N));
519 if T = 'a' or else T = 'A' then
520 Nam := Chars (Identifier (Parent (N)));
525 -- For entry guard, the token sloc is from the N_Entry_Body.
526 -- For PRAGMA, we must get the location from the pragma node.
527 -- Argument N is the pragma argument, and we have to go up
528 -- two levels (through the pragma argument association) to
529 -- get to the pragma node itself. For the guard on a select
530 -- alternative, we do not have access to the token location for
531 -- the WHEN, so we use the first sloc of the condition itself
532 -- (note: we use First_Sloc, not Sloc, because this is what is
533 -- referenced by dominance markers).
535 -- Doesn't this requirement of using First_Sloc need to be
536 -- documented in the spec ???
538 if Nkind_In (Parent (N), N_Accept_Alternative,
540 N_Terminate_Alternative)
542 Loc := First_Sloc (N);
544 Loc := Sloc (Parent (Parent (N)));
549 -- For an expression, no Sloc
553 -- No other possibilities
565 Pragma_Sloc => Pragma_Sloc,
566 Pragma_Aspect_Name => Nam);
568 -- For an aspect specification, which will be rewritten into a
569 -- pragma, enter a hash table entry now.
572 Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
576 ------------------------------
577 -- Process_Decision_Operand --
578 ------------------------------
580 procedure Process_Decision_Operand (N : Node_Id) is
582 if Is_Logical_Operator (N) then
583 if Nkind (N) /= N_Op_Not then
584 Process_Decision_Operand (Left_Opnd (N));
585 X_Not_Decision := False;
588 Process_Decision_Operand (Right_Opnd (N));
591 Process_Decisions (N, 'X', Pragma_Sloc);
593 end Process_Decision_Operand;
599 function Process_Node (N : Node_Id) return Traverse_Result is
603 -- Logical operators, output table entries and then process
604 -- operands recursively to deal with nested conditions.
606 when N_And_Then | N_Or_Else | N_Op_Not =>
611 -- If outer level, then type comes from call, otherwise it
612 -- is more deeply nested and counts as X for expression.
614 if N = Process_Decisions.N then
615 T := Process_Decisions.T;
620 -- Output header for sequence
622 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
623 Mark := SCO_Table.Last;
626 -- Output the decision
628 Output_Decision_Operand (N);
630 -- If the decision was in an expression context (T = 'X')
631 -- and contained only NOT operators, then we don't output
634 if X_Not_Decision then
635 SCO_Table.Set_Last (Mark);
637 -- Otherwise, set Last in last table entry to mark end
640 SCO_Table.Table (SCO_Table.Last).Last := True;
643 -- Process any embedded decisions
645 Process_Decision_Operand (N);
651 -- Really hard to believe this is correct given the special
652 -- handling for if expressions below ???
654 when N_Case_Expression =>
657 -- If expression, processed like an if statement
659 when N_If_Expression =>
661 Cond : constant Node_Id := First (Expressions (N));
662 Thnx : constant Node_Id := Next (Cond);
663 Elsx : constant Node_Id := Next (Thnx);
665 Process_Decisions (Cond, 'I', Pragma_Sloc);
666 Process_Decisions (Thnx, 'X', Pragma_Sloc);
667 Process_Decisions (Elsx, 'X', Pragma_Sloc);
671 -- All other cases, continue scan
679 procedure Traverse is new Traverse_Proc (Process_Node);
681 -- Start of processing for Process_Decisions
688 -- See if we have simple decision at outer level and if so then
689 -- generate the decision entry for this simple decision. A simple
690 -- decision is a boolean expression (which is not a logical operator
691 -- or short circuit form) appearing as the operand of an IF, WHILE,
692 -- EXIT WHEN, or special PRAGMA construct.
694 if T /= 'X' and then not Is_Logical_Operator (N) then
698 -- Change Last in last table entry to True to mark end of
699 -- sequence, which is this case is only one element long.
701 SCO_Table.Table (SCO_Table.Last).Last := True;
705 end Process_Decisions;
713 procedure Write_Info_Char (C : Character) renames Write_Char;
714 -- Write one character;
716 procedure Write_Info_Initiate (Key : Character) renames Write_Char;
717 -- Start new one and write one character;
719 procedure Write_Info_Nat (N : Nat);
722 procedure Write_Info_Terminate renames Write_Eol;
723 -- Terminate current line
729 procedure Write_Info_Nat (N : Nat) is
734 procedure Debug_Put_SCOs is new Put_SCOs;
736 -- Start of processing for pscos
742 ---------------------
743 -- Record_Instance --
744 ---------------------
746 procedure Record_Instance (Id : Instance_Id; Inst_Sloc : Source_Ptr) is
747 Inst_Src : constant Source_File_Index :=
748 Get_Source_File_Index (Inst_Sloc);
750 SCO_Instance_Table.Append
751 ((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)),
752 Inst_Loc => To_Source_Location (Inst_Sloc),
753 Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
755 (SCO_Instance_Table.Last = SCO_Instance_Index (Id));
762 procedure SCO_Output is
763 procedure Populate_SCO_Instance_Table is
764 new Sinput.Iterate_On_Instances (Record_Instance);
769 if Debug_Flag_Dot_OO then
773 Populate_SCO_Instance_Table;
775 -- Sort the unit tables based on dependency numbers
777 Unit_Table_Sort : declare
779 function Lt (Op1, Op2 : Natural) return Boolean;
780 -- Comparison routine for sort call
782 procedure Move (From : Natural; To : Natural);
783 -- Move routine for sort call
789 function Lt (Op1, Op2 : Natural) return Boolean is
793 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
796 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
803 procedure Move (From : Natural; To : Natural) is
805 SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
806 SCO_Unit_Table.Table (SCO_Unit_Index (From));
807 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
808 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
811 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
813 -- Start of processing for Unit_Table_Sort
816 Sorting.Sort (Integer (SCO_Unit_Table.Last));
819 -- Loop through entries in the unit table to set file name and
820 -- dependency number entries.
822 for J in 1 .. SCO_Unit_Table.Last loop
824 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
825 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
827 Get_Name_String (Reference_Name (Source_Index (U)));
828 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
829 UTE.Dep_Num := Dependency_Num (U);
833 -- Stamp out SCO entries for decisions in disabled constructs (pragmas
837 while SCO_Index <= SCO_Table.Last loop
838 if Is_Decision (SCO_Table.Table (SCO_Index).C1)
839 and then SCO_Pragma_Disabled
840 (SCO_Table.Table (SCO_Index).Pragma_Sloc)
843 SCO_Table.Table (SCO_Index).C1 := ASCII.NUL;
844 exit when SCO_Table.Table (SCO_Index).Last;
845 SCO_Index := SCO_Index + 1;
849 SCO_Index := SCO_Index + 1;
852 -- Now the tables are all setup for output to the ALI file
854 Write_SCOs_To_ALI_File;
857 -------------------------
858 -- SCO_Pragma_Disabled --
859 -------------------------
861 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
865 if Loc = No_Location then
869 Index := Condition_Pragma_Hash_Table.Get (Loc);
871 -- The test here for zero is to deal with possible previous errors, and
872 -- for the case of pragma statement SCOs, for which we always set the
873 -- Pragma_Sloc even if the particular pragma cannot be specifically
878 T : SCO_Table_Entry renames SCO_Table.Table (Index);
887 -- Aspect decision (enabled)
892 -- Aspect decision (not enabled)
897 -- Nullified disabled SCO
909 end SCO_Pragma_Disabled;
915 procedure SCO_Record (U : Unit_Number_Type) is
919 procedure Traverse_Aux_Decls (N : Node_Id);
920 -- Traverse the Aux_Decls_Node of compilation unit N
922 ------------------------
923 -- Traverse_Aux_Decls --
924 ------------------------
926 procedure Traverse_Aux_Decls (N : Node_Id) is
927 ADN : constant Node_Id := Aux_Decls_Node (N);
929 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
930 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
932 -- Declarations and Actions do not correspond to source constructs,
933 -- they contain only nodes from expansion, so at this point they
934 -- should still be empty:
936 pragma Assert (No (Declarations (ADN)));
937 pragma Assert (No (Actions (ADN)));
938 end Traverse_Aux_Decls;
940 -- Start of processing for SCO_Record
943 -- Ignore call if not generating code and generating SCO's
945 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
949 -- Ignore call if this unit already recorded
951 for J in 1 .. SCO_Unit_Number_Table.Last loop
952 if U = SCO_Unit_Number_Table.Table (J) then
957 -- Otherwise record starting entry
959 From := SCO_Table.Last + 1;
961 -- Get Unit (checking case of subunit)
963 Lu := Unit (Cunit (U));
965 if Nkind (Lu) = N_Subunit then
966 Lu := Proper_Body (Lu);
971 Traverse_Aux_Decls (Cunit (U));
975 N_Package_Declaration |
977 N_Subprogram_Declaration |
979 N_Generic_Package_Declaration |
982 N_Generic_Instantiation =>
984 Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
988 -- All other cases of compilation units (e.g. renamings), generate
989 -- no SCO information.
994 -- Make entry for new unit in unit tables, we will fill in the file
995 -- name and dependency numbers later.
997 SCO_Unit_Table.Append (
1001 To => SCO_Table.Last));
1003 SCO_Unit_Number_Table.Append (U);
1006 -----------------------
1007 -- Set_SCO_Condition --
1008 -----------------------
1010 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
1011 Orig : constant Node_Id := Original_Node (Cond);
1016 Constant_Condition_Code : constant array (Boolean) of Character :=
1017 (False => 'f', True => 't');
1019 Sloc_Range (Orig, Start, Dummy);
1020 Index := Condition_Pragma_Hash_Table.Get (Start);
1022 -- Index can be zero for boolean expressions that do not have SCOs
1023 -- (simple decisions outside of a control flow structure), or in case
1024 -- of a previous error.
1030 pragma Assert (SCO_Table.Table (Index).C1 = ' ');
1031 SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val);
1033 end Set_SCO_Condition;
1035 ----------------------------
1036 -- Set_SCO_Pragma_Enabled --
1037 ----------------------------
1039 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
1043 -- Nothing to do if not generating SCO, or if we're not processing the
1044 -- original source occurrence of the pragma.
1046 if not (Generate_SCO
1047 and then In_Extended_Main_Source_Unit (Loc)
1048 and then not (In_Instance or In_Inlined_Body))
1053 -- Note: the reason we use the Sloc value as the key is that in the
1054 -- generic case, the call to this procedure is made on a copy of the
1055 -- original node, so we can't use the Node_Id value.
1057 Index := Condition_Pragma_Hash_Table.Get (Loc);
1059 -- A zero index here indicates that semantic analysis found an
1060 -- activated pragma at Loc which does not have a corresponding pragma
1061 -- or aspect at the syntax level. This may occur in legitimate cases
1062 -- because of expanded code (such are Pre/Post conditions generated for
1063 -- formal parameter validity checks), or as a consequence of a previous
1071 T : SCO_Table_Entry renames SCO_Table.Table (Index);
1074 -- Note: may be called multiple times for the same sloc, so
1075 -- account for the fact that the entry may already have been
1079 -- Aspect (decision SCO)
1087 -- Pragma (statement SCO)
1090 pragma Assert (T.C2 = 'p' or else T.C2 = 'P');
1094 raise Program_Error;
1098 end Set_SCO_Pragma_Enabled;
1100 ---------------------
1101 -- Set_Table_Entry --
1102 ---------------------
1104 procedure Set_Table_Entry
1110 Pragma_Sloc : Source_Ptr := No_Location;
1111 Pragma_Aspect_Name : Name_Id := No_Name)
1117 From => To_Source_Location (From),
1118 To => To_Source_Location (To),
1120 Pragma_Sloc => Pragma_Sloc,
1121 Pragma_Aspect_Name => Pragma_Aspect_Name));
1122 end Set_Table_Entry;
1124 ------------------------
1125 -- To_Source_Location --
1126 ------------------------
1128 function To_Source_Location (S : Source_Ptr) return Source_Location is
1130 if S = No_Location then
1131 return No_Source_Location;
1134 (Line => Get_Logical_Line_Number (S),
1135 Col => Get_Column_Number (S));
1137 end To_Source_Location;
1139 -----------------------------------------
1140 -- Traverse_Declarations_Or_Statements --
1141 -----------------------------------------
1143 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
1144 -- holding statement and decision entries. These are declared globally
1145 -- since they are shared by recursive calls to this procedure.
1147 type SC_Entry is record
1153 -- Used to store a single entry in the following table, From:To represents
1154 -- the range of entries in the CS line entry, and typ is the type, with
1155 -- space meaning that no type letter will accompany the entry.
1157 package SC is new Table.Table (
1158 Table_Component_Type => SC_Entry,
1159 Table_Index_Type => Nat,
1160 Table_Low_Bound => 1,
1161 Table_Initial => 1000,
1162 Table_Increment => 200,
1163 Table_Name => "SCO_SC");
1164 -- Used to store statement components for a CS entry to be output
1165 -- as a result of the call to this procedure. SC.Last is the last
1166 -- entry stored, so the current statement sequence is represented
1167 -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on
1168 -- entry to each recursive call to the routine.
1170 -- Extend_Statement_Sequence adds an entry to this array, and then
1171 -- Set_Statement_Entry clears the entries starting with SC_First,
1172 -- copying these entries to the main SCO output table. The reason that
1173 -- we do the temporary caching of results in this array is that we want
1174 -- the SCO table entries for a given CS line to be contiguous, and the
1175 -- processing may output intermediate entries such as decision entries.
1177 type SD_Entry is record
1183 -- Used to store a single entry in the following table. Nod is the node to
1184 -- be searched for decisions for the case of Process_Decisions_Defer with a
1185 -- node argument (with Lst set to No_List. Lst is the list to be searched
1186 -- for decisions for the case of Process_Decisions_Defer with a List
1187 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
1188 -- enclosing pragma, if any.
1190 package SD is new Table.Table (
1191 Table_Component_Type => SD_Entry,
1192 Table_Index_Type => Nat,
1193 Table_Low_Bound => 1,
1194 Table_Initial => 1000,
1195 Table_Increment => 200,
1196 Table_Name => "SCO_SD");
1197 -- Used to store possible decision information. Instead of calling the
1198 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
1199 -- which simply stores the arguments in this table. Then when we clear
1200 -- out a statement sequence using Set_Statement_Entry, after generating
1201 -- the CS lines for the statements, the entries in this table result in
1202 -- calls to Process_Decision. The reason for doing things this way is to
1203 -- ensure that decisions are output after the CS line for the statements
1204 -- in which the decisions occur.
1206 procedure Traverse_Declarations_Or_Statements
1208 D : Dominant_Info := No_Dominant;
1209 P : Node_Id := Empty)
1211 Discard_Dom : Dominant_Info;
1212 pragma Warnings (Off, Discard_Dom);
1214 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P);
1215 end Traverse_Declarations_Or_Statements;
1217 function Traverse_Declarations_Or_Statements
1219 D : Dominant_Info := No_Dominant;
1220 P : Node_Id := Empty) return Dominant_Info
1222 Current_Dominant : Dominant_Info := D;
1223 -- Dominance information for the current basic block
1225 Current_Test : Node_Id;
1226 -- Conditional node (N_If_Statement or N_Elsiif being processed
1230 SC_First : constant Nat := SC.Last + 1;
1231 SD_First : constant Nat := SD.Last + 1;
1232 -- Record first entries used in SC/SD at this recursive level
1234 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1235 -- Extend the current statement sequence to encompass the node N. Typ
1236 -- is the letter that identifies the type of statement/declaration that
1237 -- is being added to the sequence.
1239 procedure Set_Statement_Entry;
1240 -- Output CS entries for all statements saved in table SC, and end the
1241 -- current CS sequence. Then output entries for all decisions nested in
1242 -- these statements, which have been deferred so far.
1244 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1245 pragma Inline (Process_Decisions_Defer);
1246 -- This routine is logically the same as Process_Decisions, except that
1247 -- the arguments are saved in the SD table for later processing when
1248 -- Set_Statement_Entry is called, which goes through the saved entries
1249 -- making the corresponding calls to Process_Decision.
1251 procedure Process_Decisions_Defer (L : List_Id; T : Character);
1252 pragma Inline (Process_Decisions_Defer);
1253 -- Same case for list arguments, deferred call to Process_Decisions
1255 procedure Traverse_One (N : Node_Id);
1256 -- Traverse one declaration or statement
1258 procedure Traverse_Aspects (N : Node_Id);
1259 -- Helper for Traverse_One: traverse N's aspect specifications
1261 -------------------------
1262 -- Set_Statement_Entry --
1263 -------------------------
1265 procedure Set_Statement_Entry is
1266 SC_Last : constant Int := SC.Last;
1267 SD_Last : constant Int := SD.Last;
1270 -- Output statement entries from saved entries in SC table
1272 for J in SC_First .. SC_Last loop
1273 if J = SC_First then
1275 if Current_Dominant /= No_Dominant then
1277 From, To : Source_Ptr;
1279 Sloc_Range (Current_Dominant.N, From, To);
1280 if Current_Dominant.K /= 'E' then
1285 C2 => Current_Dominant.K,
1289 Pragma_Sloc => No_Location,
1290 Pragma_Aspect_Name => No_Name);
1296 SCE : SC_Entry renames SC.Table (J);
1297 Pragma_Sloc : Source_Ptr := No_Location;
1298 Pragma_Aspect_Name : Name_Id := No_Name;
1300 -- For the case of a statement SCO for a pragma controlled by
1301 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1302 -- those of any nested decision) is emitted only if the pragma
1305 if SCE.Typ = 'p' then
1306 Pragma_Sloc := SCE.From;
1307 Condition_Pragma_Hash_Table.Set
1308 (Pragma_Sloc, SCO_Table.Last + 1);
1309 Pragma_Aspect_Name := Pragma_Name (SCE.N);
1310 pragma Assert (Pragma_Aspect_Name /= No_Name);
1312 elsif SCE.Typ = 'P' then
1313 Pragma_Aspect_Name := Pragma_Name (SCE.N);
1314 pragma Assert (Pragma_Aspect_Name /= No_Name);
1322 Last => (J = SC_Last),
1323 Pragma_Sloc => Pragma_Sloc,
1324 Pragma_Aspect_Name => Pragma_Aspect_Name);
1328 -- Last statement of basic block, if present, becomes new current
1331 if SC_Last >= SC_First then
1332 Current_Dominant := ('S', SC.Table (SC_Last).N);
1335 -- Clear out used section of SC table
1337 SC.Set_Last (SC_First - 1);
1339 -- Output any embedded decisions
1341 for J in SD_First .. SD_Last loop
1343 SDE : SD_Entry renames SD.Table (J);
1345 if Present (SDE.Nod) then
1346 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1348 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1353 -- Clear out used section of SD table
1355 SD.Set_Last (SD_First - 1);
1356 end Set_Statement_Entry;
1358 -------------------------------
1359 -- Extend_Statement_Sequence --
1360 -------------------------------
1362 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1366 To_Node : Node_Id := Empty;
1369 Sloc_Range (N, F, T);
1372 when N_Accept_Statement =>
1373 if Present (Parameter_Specifications (N)) then
1374 To_Node := Last (Parameter_Specifications (N));
1375 elsif Present (Entry_Index (N)) then
1376 To_Node := Entry_Index (N);
1379 when N_Case_Statement =>
1380 To_Node := Expression (N);
1382 when N_If_Statement | N_Elsif_Part =>
1383 To_Node := Condition (N);
1385 when N_Extended_Return_Statement =>
1386 To_Node := Last (Return_Object_Declarations (N));
1388 when N_Loop_Statement =>
1389 To_Node := Iteration_Scheme (N);
1391 when N_Selective_Accept |
1392 N_Timed_Entry_Call |
1393 N_Conditional_Entry_Call |
1394 N_Asynchronous_Select |
1395 N_Single_Protected_Declaration |
1396 N_Single_Task_Declaration =>
1399 when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
1400 if Has_Aspects (N) then
1401 To_Node := Last (Aspect_Specifications (N));
1403 elsif Present (Discriminant_Specifications (N)) then
1404 To_Node := Last (Discriminant_Specifications (N));
1407 To_Node := Defining_Identifier (N);
1415 if Present (To_Node) then
1416 Sloc_Range (To_Node, Dummy, T);
1419 SC.Append ((N, F, T, Typ));
1420 end Extend_Statement_Sequence;
1422 -----------------------------
1423 -- Process_Decisions_Defer --
1424 -----------------------------
1426 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1428 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1429 end Process_Decisions_Defer;
1431 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1433 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1434 end Process_Decisions_Defer;
1436 ----------------------
1437 -- Traverse_Aspects --
1438 ----------------------
1440 procedure Traverse_Aspects (N : Node_Id) is
1446 AN := First (Aspect_Specifications (N));
1447 while Present (AN) loop
1448 AE := Expression (AN);
1450 -- SCOs are generated before semantic analysis/expansion:
1451 -- PPCs are not split yet.
1453 pragma Assert (not Split_PPC (AN));
1457 case Get_Aspect_Id (AN) is
1459 -- Aspects rewritten into pragmas controlled by a Check_Policy:
1460 -- Current_Pragma_Sloc must be set to the sloc of the aspect
1461 -- specification. The corresponding pragma will have the same
1465 Aspect_Precondition |
1467 Aspect_Postcondition |
1472 -- Aspects whose checks are generated in client units,
1473 -- regardless of whether or not the check is activated in the
1474 -- unit which contains the declaration: create decision as
1475 -- unconditionally enabled aspect (but still make a pragma
1476 -- entry since Set_SCO_Pragma_Enabled will be called when
1477 -- analyzing actual checks, possibly in other units).
1479 -- Pre/post can have checks in client units too because of
1480 -- inheritance, so should they be moved here???
1482 when Aspect_Predicate |
1483 Aspect_Static_Predicate |
1484 Aspect_Dynamic_Predicate |
1485 Aspect_Type_Invariant =>
1489 -- Other aspects: just process any decision nested in the
1490 -- aspect expression.
1494 if Has_Decision (AE) then
1500 if C1 /= ASCII.NUL then
1501 pragma Assert (Current_Pragma_Sloc = No_Location);
1503 if C1 = 'a' or else C1 = 'A' then
1504 Current_Pragma_Sloc := Sloc (AN);
1507 Process_Decisions_Defer (AE, C1);
1509 Current_Pragma_Sloc := No_Location;
1514 end Traverse_Aspects;
1520 procedure Traverse_One (N : Node_Id) is
1522 -- Initialize or extend current statement sequence. Note that for
1523 -- special cases such as IF and Case statements we will modify
1524 -- the range to exclude internal statements that should not be
1525 -- counted as part of the current statement sequence.
1529 -- Package declaration
1531 when N_Package_Declaration =>
1532 Set_Statement_Entry;
1533 Traverse_Package_Declaration (N, Current_Dominant);
1535 -- Generic package declaration
1537 when N_Generic_Package_Declaration =>
1538 Set_Statement_Entry;
1539 Traverse_Generic_Package_Declaration (N);
1543 when N_Package_Body =>
1544 Set_Statement_Entry;
1545 Traverse_Package_Body (N);
1547 -- Subprogram declaration or subprogram body stub
1549 when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
1550 Process_Decisions_Defer
1551 (Parameter_Specifications (Specification (N)), 'X');
1553 -- Entry declaration
1555 when N_Entry_Declaration =>
1556 Process_Decisions_Defer (Parameter_Specifications (N), 'X');
1558 -- Generic subprogram declaration
1560 when N_Generic_Subprogram_Declaration =>
1561 Process_Decisions_Defer
1562 (Generic_Formal_Declarations (N), 'X');
1563 Process_Decisions_Defer
1564 (Parameter_Specifications (Specification (N)), 'X');
1566 -- Task or subprogram body
1568 when N_Task_Body | N_Subprogram_Body =>
1569 Set_Statement_Entry;
1570 Traverse_Subprogram_Or_Task_Body (N);
1574 when N_Entry_Body =>
1576 Cond : constant Node_Id :=
1577 Condition (Entry_Body_Formal_Part (N));
1579 Inner_Dominant : Dominant_Info := No_Dominant;
1582 Set_Statement_Entry;
1584 if Present (Cond) then
1585 Process_Decisions_Defer (Cond, 'G');
1587 -- For an entry body with a barrier, the entry body
1588 -- is dominanted by a True evaluation of the barrier.
1590 Inner_Dominant := ('T', N);
1593 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
1598 when N_Protected_Body =>
1599 Set_Statement_Entry;
1600 Traverse_Declarations_Or_Statements (Declarations (N));
1602 -- Exit statement, which is an exit statement in the SCO sense,
1603 -- so it is included in the current statement sequence, but
1604 -- then it terminates this sequence. We also have to process
1605 -- any decisions in the exit statement expression.
1607 when N_Exit_Statement =>
1608 Extend_Statement_Sequence (N, 'E');
1609 Process_Decisions_Defer (Condition (N), 'E');
1610 Set_Statement_Entry;
1612 -- If condition is present, then following statement is
1613 -- only executed if the condition evaluates to False.
1615 if Present (Condition (N)) then
1616 Current_Dominant := ('F', N);
1618 Current_Dominant := No_Dominant;
1621 -- Label, which breaks the current statement sequence, but the
1622 -- label itself is not included in the next statement sequence,
1623 -- since it generates no code.
1626 Set_Statement_Entry;
1627 Current_Dominant := No_Dominant;
1629 -- Block statement, which breaks the current statement sequence
1631 when N_Block_Statement =>
1632 Set_Statement_Entry;
1634 -- The first statement in the handled sequence of statements
1635 -- is dominated by the elaboration of the last declaration.
1637 Current_Dominant := Traverse_Declarations_Or_Statements
1638 (L => Declarations (N),
1639 D => Current_Dominant);
1641 Traverse_Handled_Statement_Sequence
1642 (N => Handled_Statement_Sequence (N),
1643 D => Current_Dominant);
1645 -- If statement, which breaks the current statement sequence,
1646 -- but we include the condition in the current sequence.
1648 when N_If_Statement =>
1650 Extend_Statement_Sequence (N, 'I');
1651 Process_Decisions_Defer (Condition (N), 'I');
1652 Set_Statement_Entry;
1654 -- Now we traverse the statements in the THEN part
1656 Traverse_Declarations_Or_Statements
1657 (L => Then_Statements (N),
1660 -- Loop through ELSIF parts if present
1662 if Present (Elsif_Parts (N)) then
1664 Saved_Dominant : constant Dominant_Info :=
1667 Elif : Node_Id := First (Elsif_Parts (N));
1670 while Present (Elif) loop
1672 -- An Elsif is executed only if the previous test
1673 -- got a FALSE outcome.
1675 Current_Dominant := ('F', Current_Test);
1677 -- Now update current test information
1679 Current_Test := Elif;
1681 -- We generate a statement sequence for the
1682 -- construct "ELSIF condition", so that we have
1683 -- a statement for the resulting decisions.
1685 Extend_Statement_Sequence (Elif, 'I');
1686 Process_Decisions_Defer (Condition (Elif), 'I');
1687 Set_Statement_Entry;
1689 -- An ELSIF part is never guaranteed to have
1690 -- been executed, following statements are only
1691 -- dominated by the initial IF statement.
1693 Current_Dominant := Saved_Dominant;
1695 -- Traverse the statements in the ELSIF
1697 Traverse_Declarations_Or_Statements
1698 (L => Then_Statements (Elif),
1705 -- Finally traverse the ELSE statements if present
1707 Traverse_Declarations_Or_Statements
1708 (L => Else_Statements (N),
1709 D => ('F', Current_Test));
1711 -- CASE statement, which breaks the current statement sequence,
1712 -- but we include the expression in the current sequence.
1714 when N_Case_Statement =>
1715 Extend_Statement_Sequence (N, 'C');
1716 Process_Decisions_Defer (Expression (N), 'X');
1717 Set_Statement_Entry;
1719 -- Process case branches, all of which are dominated by the
1725 Alt := First (Alternatives (N));
1726 while Present (Alt) loop
1727 Traverse_Declarations_Or_Statements
1728 (L => Statements (Alt),
1729 D => Current_Dominant);
1736 when N_Accept_Statement =>
1737 Extend_Statement_Sequence (N, 'A');
1738 Set_Statement_Entry;
1740 -- Process sequence of statements, dominant is the ACCEPT
1743 Traverse_Handled_Statement_Sequence
1744 (N => Handled_Statement_Sequence (N),
1745 D => Current_Dominant);
1749 when N_Selective_Accept =>
1750 Extend_Statement_Sequence (N, 'S');
1751 Set_Statement_Entry;
1753 -- Process alternatives
1758 S_Dom : Dominant_Info;
1761 Alt := First (Select_Alternatives (N));
1762 while Present (Alt) loop
1763 S_Dom := Current_Dominant;
1764 Guard := Condition (Alt);
1766 if Present (Guard) then
1770 Pragma_Sloc => No_Location);
1771 Current_Dominant := ('T', Guard);
1776 Current_Dominant := S_Dom;
1781 Traverse_Declarations_Or_Statements
1782 (L => Else_Statements (N),
1783 D => Current_Dominant);
1785 when N_Timed_Entry_Call | N_Conditional_Entry_Call =>
1786 Extend_Statement_Sequence (N, 'S');
1787 Set_Statement_Entry;
1789 -- Process alternatives
1791 Traverse_One (Entry_Call_Alternative (N));
1793 if Nkind (N) = N_Timed_Entry_Call then
1794 Traverse_One (Delay_Alternative (N));
1796 Traverse_Declarations_Or_Statements
1797 (L => Else_Statements (N),
1798 D => Current_Dominant);
1801 when N_Asynchronous_Select =>
1802 Extend_Statement_Sequence (N, 'S');
1803 Set_Statement_Entry;
1805 Traverse_One (Triggering_Alternative (N));
1806 Traverse_Declarations_Or_Statements
1807 (L => Statements (Abortable_Part (N)),
1808 D => Current_Dominant);
1810 when N_Accept_Alternative =>
1811 Traverse_Declarations_Or_Statements
1812 (L => Statements (N),
1813 D => Current_Dominant,
1814 P => Accept_Statement (N));
1816 when N_Entry_Call_Alternative =>
1817 Traverse_Declarations_Or_Statements
1818 (L => Statements (N),
1819 D => Current_Dominant,
1820 P => Entry_Call_Statement (N));
1822 when N_Delay_Alternative =>
1823 Traverse_Declarations_Or_Statements
1824 (L => Statements (N),
1825 D => Current_Dominant,
1826 P => Delay_Statement (N));
1828 when N_Triggering_Alternative =>
1829 Traverse_Declarations_Or_Statements
1830 (L => Statements (N),
1831 D => Current_Dominant,
1832 P => Triggering_Statement (N));
1834 when N_Terminate_Alternative =>
1836 -- It is dubious to emit a statement SCO for a TERMINATE
1837 -- alternative, since no code is actually executed if the
1838 -- alternative is selected -- the tasking runtime call just
1841 Extend_Statement_Sequence (N, ' ');
1842 Set_Statement_Entry;
1844 -- Unconditional exit points, which are included in the current
1845 -- statement sequence, but then terminate it
1847 when N_Requeue_Statement |
1849 N_Raise_Statement =>
1850 Extend_Statement_Sequence (N, ' ');
1851 Set_Statement_Entry;
1852 Current_Dominant := No_Dominant;
1854 -- Simple return statement. which is an exit point, but we
1855 -- have to process the return expression for decisions.
1857 when N_Simple_Return_Statement =>
1858 Extend_Statement_Sequence (N, ' ');
1859 Process_Decisions_Defer (Expression (N), 'X');
1860 Set_Statement_Entry;
1861 Current_Dominant := No_Dominant;
1863 -- Extended return statement
1865 when N_Extended_Return_Statement =>
1866 Extend_Statement_Sequence (N, 'R');
1867 Process_Decisions_Defer
1868 (Return_Object_Declarations (N), 'X');
1869 Set_Statement_Entry;
1871 Traverse_Handled_Statement_Sequence
1872 (N => Handled_Statement_Sequence (N),
1873 D => Current_Dominant);
1875 Current_Dominant := No_Dominant;
1877 -- Loop ends the current statement sequence, but we include
1878 -- the iteration scheme if present in the current sequence.
1879 -- But the body of the loop starts a new sequence, since it
1880 -- may not be executed as part of the current sequence.
1882 when N_Loop_Statement =>
1884 ISC : constant Node_Id := Iteration_Scheme (N);
1885 Inner_Dominant : Dominant_Info := No_Dominant;
1888 if Present (ISC) then
1890 -- If iteration scheme present, extend the current
1891 -- statement sequence to include the iteration scheme
1892 -- and process any decisions it contains.
1896 if Present (Condition (ISC)) then
1897 Extend_Statement_Sequence (N, 'W');
1898 Process_Decisions_Defer (Condition (ISC), 'W');
1900 -- Set more specific dominant for inner statements
1901 -- (the control sloc for the decision is that of
1902 -- the WHILE token).
1904 Inner_Dominant := ('T', ISC);
1909 Extend_Statement_Sequence (N, 'F');
1910 Process_Decisions_Defer
1911 (Loop_Parameter_Specification (ISC), 'X');
1915 Set_Statement_Entry;
1917 if Inner_Dominant = No_Dominant then
1918 Inner_Dominant := Current_Dominant;
1921 Traverse_Declarations_Or_Statements
1922 (L => Statements (N),
1923 D => Inner_Dominant);
1930 -- Record sloc of pragma (pragmas don't nest)
1932 pragma Assert (Current_Pragma_Sloc = No_Location);
1933 Current_Pragma_Sloc := Sloc (N);
1935 -- Processing depends on the kind of pragma
1938 Nam : constant Name_Id := Pragma_Name (N);
1940 First (Pragma_Argument_Associations (N));
1946 Name_Assert_And_Cut |
1949 Name_Loop_Invariant |
1951 Name_Postcondition =>
1953 -- For Assert/Check/Precondition/Postcondition, we
1954 -- must generate a P entry for the decision. Note
1955 -- that this is done unconditionally at this stage.
1956 -- Output for disabled pragmas is suppressed later
1957 -- on when we output the decision line in Put_SCOs,
1958 -- depending on setting by Set_SCO_Pragma_Enabled.
1960 if Nam = Name_Check then
1964 Process_Decisions_Defer (Expression (Arg), 'P');
1967 -- Pre/postconditions can be inherited so SCO should
1968 -- never be deactivated???
1971 if Present (Arg) and then Present (Next (Arg)) then
1973 -- Case of a dyadic pragma Debug: first argument
1974 -- is a P decision, any nested decision in the
1975 -- second argument is an X decision.
1977 Process_Decisions_Defer (Expression (Arg), 'P');
1981 Process_Decisions_Defer (Expression (Arg), 'X');
1984 -- For all other pragmas, we generate decision entries
1985 -- for any embedded expressions, and the pragma is
1988 -- Should generate P decisions (not X) for assertion
1989 -- related pragmas: [Type_]Invariant,
1990 -- [{Static,Dynamic}_]Predicate???
1993 Process_Decisions_Defer (N, 'X');
1997 -- Add statement SCO
1999 Extend_Statement_Sequence (N, Typ);
2001 Current_Pragma_Sloc := No_Location;
2004 -- Object declaration. Ignored if Prev_Ids is set, since the
2005 -- parser generates multiple instances of the whole declaration
2006 -- if there is more than one identifier declared, and we only
2007 -- want one entry in the SCOs, so we take the first, for which
2008 -- Prev_Ids is False.
2010 when N_Object_Declaration | N_Number_Declaration =>
2011 if not Prev_Ids (N) then
2012 Extend_Statement_Sequence (N, 'o');
2014 if Has_Decision (N) then
2015 Process_Decisions_Defer (N, 'X');
2019 -- All other cases, which extend the current statement sequence
2020 -- but do not terminate it, even if they have nested decisions.
2022 when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
2023 Extend_Statement_Sequence (N, 't');
2024 Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
2025 Set_Statement_Entry;
2027 Traverse_Sync_Definition (N);
2029 when N_Single_Protected_Declaration | N_Single_Task_Declaration =>
2030 Extend_Statement_Sequence (N, 'o');
2031 Set_Statement_Entry;
2033 Traverse_Sync_Definition (N);
2037 -- Determine required type character code, or ASCII.NUL if
2038 -- no SCO should be generated for this node.
2041 NK : constant Node_Kind := Nkind (N);
2046 when N_Full_Type_Declaration |
2047 N_Incomplete_Type_Declaration |
2048 N_Private_Type_Declaration |
2049 N_Private_Extension_Declaration =>
2052 when N_Subtype_Declaration =>
2055 when N_Renaming_Declaration =>
2058 when N_Generic_Instantiation =>
2061 when N_Representation_Clause |
2062 N_Use_Package_Clause |
2064 N_Package_Body_Stub |
2066 N_Protected_Body_Stub =>
2069 when N_Procedure_Call_Statement =>
2073 if NK in N_Statement_Other_Than_Procedure_Call then
2080 if Typ /= ASCII.NUL then
2081 Extend_Statement_Sequence (N, Typ);
2085 -- Process any embedded decisions
2087 if Has_Decision (N) then
2088 Process_Decisions_Defer (N, 'X');
2092 -- Process aspects if present
2094 Traverse_Aspects (N);
2097 -- Start of processing for Traverse_Declarations_Or_Statements
2100 -- Process single prefixed node
2106 -- Loop through statements or declarations
2108 if Is_Non_Empty_List (L) then
2110 while Present (N) loop
2112 -- Note: For separate bodies, we see the tree after Par.Labl has
2113 -- introduced implicit labels, so we need to ignore those nodes.
2115 if Nkind (N) /= N_Implicit_Label_Declaration then
2124 -- End sequence of statements and flush deferred decisions
2126 if Present (P) or else Is_Non_Empty_List (L) then
2127 Set_Statement_Entry;
2130 return Current_Dominant;
2131 end Traverse_Declarations_Or_Statements;
2133 ------------------------------------------
2134 -- Traverse_Generic_Package_Declaration --
2135 ------------------------------------------
2137 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
2139 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
2140 Traverse_Package_Declaration (N);
2141 end Traverse_Generic_Package_Declaration;
2143 -----------------------------------------
2144 -- Traverse_Handled_Statement_Sequence --
2145 -----------------------------------------
2147 procedure Traverse_Handled_Statement_Sequence
2149 D : Dominant_Info := No_Dominant)
2154 -- For package bodies without a statement part, the parser adds an empty
2155 -- one, to normalize the representation. The null statement therein,
2156 -- which does not come from source, does not get a SCO.
2158 if Present (N) and then Comes_From_Source (N) then
2159 Traverse_Declarations_Or_Statements (Statements (N), D);
2161 if Present (Exception_Handlers (N)) then
2162 Handler := First (Exception_Handlers (N));
2163 while Present (Handler) loop
2164 Traverse_Declarations_Or_Statements
2165 (L => Statements (Handler),
2166 D => ('E', Handler));
2171 end Traverse_Handled_Statement_Sequence;
2173 ---------------------------
2174 -- Traverse_Package_Body --
2175 ---------------------------
2177 procedure Traverse_Package_Body (N : Node_Id) is
2178 Dom : Dominant_Info;
2180 -- The first statement in the handled sequence of statements is
2181 -- dominated by the elaboration of the last declaration.
2183 Dom := Traverse_Declarations_Or_Statements (Declarations (N));
2185 Traverse_Handled_Statement_Sequence
2186 (Handled_Statement_Sequence (N), Dom);
2187 end Traverse_Package_Body;
2189 ----------------------------------
2190 -- Traverse_Package_Declaration --
2191 ----------------------------------
2193 procedure Traverse_Package_Declaration
2195 D : Dominant_Info := No_Dominant)
2197 Spec : constant Node_Id := Specification (N);
2198 Dom : Dominant_Info;
2202 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
2204 -- First private declaration is dominated by last visible declaration
2206 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
2207 end Traverse_Package_Declaration;
2209 ------------------------------
2210 -- Traverse_Sync_Definition --
2211 ------------------------------
2213 procedure Traverse_Sync_Definition (N : Node_Id) is
2214 Dom_Info : Dominant_Info := ('S', N);
2215 -- The first declaration is dominated by the protected or task [type]
2219 -- N's protected or task definition
2222 -- Sync_Def's Visible_Declarations
2226 when N_Single_Protected_Declaration | N_Protected_Type_Declaration =>
2227 Sync_Def := Protected_Definition (N);
2229 when N_Single_Task_Declaration | N_Task_Type_Declaration =>
2230 Sync_Def := Task_Definition (N);
2233 raise Program_Error;
2236 Vis_Decl := Visible_Declarations (Sync_Def);
2238 Dom_Info := Traverse_Declarations_Or_Statements
2242 -- If visible declarations are present, the first private declaration
2243 -- is dominated by the last visible declaration.
2245 Traverse_Declarations_Or_Statements
2246 (L => Private_Declarations (Sync_Def),
2248 end Traverse_Sync_Definition;
2250 --------------------------------------
2251 -- Traverse_Subprogram_Or_Task_Body --
2252 --------------------------------------
2254 procedure Traverse_Subprogram_Or_Task_Body
2256 D : Dominant_Info := No_Dominant)
2258 Decls : constant List_Id := Declarations (N);
2259 Dom_Info : Dominant_Info := D;
2261 -- If declarations are present, the first statement is dominated by the
2262 -- last declaration.
2264 Dom_Info := Traverse_Declarations_Or_Statements
2265 (L => Decls, D => Dom_Info);
2267 Traverse_Handled_Statement_Sequence
2268 (N => Handled_Statement_Sequence (N),
2270 end Traverse_Subprogram_Or_Task_Body;