1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2009-2016, 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
;
49 package body Par_SCO
is
51 --------------------------
52 -- First-pass SCO table --
53 --------------------------
55 -- The Short_Circuit_And_Or pragma enables one to use AND and OR operators
56 -- in source code while the ones used with booleans will be interpreted as
57 -- their short circuit alternatives (AND THEN and OR ELSE). Thus, the true
58 -- meaning of these operators is known only after the semantic analysis.
60 -- However, decision SCOs include short circuit operators only. The SCO
61 -- information generation pass must be done before expansion, hence before
62 -- the semantic analysis. Because of this, the SCO information generation
63 -- is done in two passes.
65 -- The first one (SCO_Record_Raw, before semantic analysis) completes the
66 -- SCO_Raw_Table assuming all AND/OR operators are short circuit ones.
67 -- Then, the semantic analysis determines which operators are promoted to
68 -- short circuit ones. Finally, the second pass (SCO_Record_Filtered)
69 -- translates the SCO_Raw_Table to SCO_Table, taking care of removing the
70 -- remaining AND/OR operators and of adjusting decisions accordingly
71 -- (splitting decisions, removing empty ones, etc.).
73 type SCO_Generation_State_Type
is (None
, Raw
, Filtered
);
74 SCO_Generation_State
: SCO_Generation_State_Type
:= None
;
75 -- Keep track of the SCO generation state: this will prevent us from
76 -- running some steps multiple times (the second pass has to be started
77 -- from multiple places).
79 package SCO_Raw_Table
is new GNAT
.Table
80 (Table_Component_Type
=> SCO_Table_Entry
,
81 Table_Index_Type
=> Nat
,
84 Table_Increment
=> 300);
86 -----------------------
87 -- Unit Number Table --
88 -----------------------
90 -- This table parallels the SCO_Unit_Table, keeping track of the unit
91 -- numbers corresponding to the entries made in this table, so that before
92 -- writing out the SCO information to the ALI file, we can fill in the
93 -- proper dependency numbers and file names.
95 -- Note that the zero'th entry is here for convenience in sorting the
96 -- table, the real lower bound is 1.
98 package SCO_Unit_Number_Table
is new Table
.Table
99 (Table_Component_Type
=> Unit_Number_Type
,
100 Table_Index_Type
=> SCO_Unit_Index
,
101 Table_Low_Bound
=> 0, -- see note above on sort
103 Table_Increment
=> 200,
104 Table_Name
=> "SCO_Unit_Number_Entry");
106 ------------------------------------------
107 -- Condition/Operator/Pragma Hash Table --
108 ------------------------------------------
110 -- We need to be able to get to conditions quickly for handling the calls
111 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
112 -- handle calls to Set_SCO_Pragma_Enabled (the same holds for operators and
113 -- Set_SCO_Logical_Operator). For this purpose we identify the conditions,
114 -- operators and pragmas in the table by their starting sloc, and use this
115 -- hash table to map from these sloc values to SCO_Table indexes.
117 type Header_Num
is new Integer range 0 .. 996;
118 -- Type for hash table headers
120 function Hash
(F
: Source_Ptr
) return Header_Num
;
121 -- Function to Hash source pointer value
123 function Equal
(F1
: Source_Ptr
; F2
: Source_Ptr
) return Boolean;
124 -- Function to test two keys for equality
126 function "<" (S1
: Source_Location
; S2
: Source_Location
) return Boolean;
127 -- Function to test for source locations order
129 package SCO_Raw_Hash_Table
is new Simple_HTable
130 (Header_Num
, Int
, 0, Source_Ptr
, Hash
, Equal
);
131 -- The actual hash table
133 --------------------------
134 -- Internal Subprograms --
135 --------------------------
137 function Has_Decision
(N
: Node_Id
) return Boolean;
138 -- N is the node for a subexpression. Returns True if the subexpression
139 -- contains a nested decision (i.e. either is a logical operator, or
140 -- contains a logical operator in its subtree).
142 -- This must be used in the first pass (SCO_Record_Raw) only: here AND/OR
143 -- operators are considered as short circuit, just in case the
144 -- Short_Circuit_And_Or pragma is used: only real short circuit operations
145 -- will be kept in the secord pass.
147 type Tristate
is (False, True, Unknown
);
149 function Is_Logical_Operator
(N
: Node_Id
) return Tristate
;
150 -- N is the node for a subexpression. This procedure determines whether N
151 -- is a logical operator: True for short circuit conditions, Unknown for OR
152 -- and AND (the Short_Circuit_And_Or pragma may be used) and False
153 -- otherwise. Note that in cases where True is returned, callers assume
154 -- Nkind (N) in N_Op.
156 function To_Source_Location
(S
: Source_Ptr
) return Source_Location
;
157 -- Converts Source_Ptr value to Source_Location (line/col) format
159 procedure Process_Decisions
162 Pragma_Sloc
: Source_Ptr
);
163 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
164 -- to output any decisions it contains. T is one of IEGPWX (for context of
165 -- expression: if/exit when/entry guard/pragma/while/expression). If T is
166 -- other than X, the node N is the if expression involved, and a decision
167 -- is always present (at the very least a simple decision is present at the
170 procedure Process_Decisions
173 Pragma_Sloc
: Source_Ptr
);
174 -- Calls above procedure for each element of the list L
176 procedure Set_Raw_Table_Entry
182 Pragma_Sloc
: Source_Ptr
:= No_Location
;
183 Pragma_Aspect_Name
: Name_Id
:= No_Name
);
184 -- Append an entry to SCO_Raw_Table with fields set as per arguments
186 type Dominant_Info
is record
188 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant
191 -- Node providing the Sloc(s) for the dominance marker
193 No_Dominant
: constant Dominant_Info
:= (' ', Empty
);
195 procedure Record_Instance
(Id
: Instance_Id
; Inst_Sloc
: Source_Ptr
);
196 -- Add one entry from the instance table to the corresponding SCO table
198 procedure Traverse_Declarations_Or_Statements
200 D
: Dominant_Info
:= No_Dominant
;
201 P
: Node_Id
:= Empty
);
202 -- Process L, a list of statements or declarations dominated by D. If P is
203 -- present, it is processed as though it had been prepended to L.
205 function Traverse_Declarations_Or_Statements
207 D
: Dominant_Info
:= No_Dominant
;
208 P
: Node_Id
:= Empty
) return Dominant_Info
;
209 -- Same as above, and returns dominant information corresponding to the
210 -- last node with SCO in L.
212 -- The following Traverse_* routines perform appropriate calls to
213 -- Traverse_Declarations_Or_Statements to traverse specific node kinds.
214 -- Parameter D, when present, indicates the dominant of the first
215 -- declaration or statement within N.
217 -- Why is Traverse_Sync_Definition commented specificaly and
218 -- the others are not???
220 procedure Traverse_Generic_Package_Declaration
(N
: Node_Id
);
222 procedure Traverse_Handled_Statement_Sequence
224 D
: Dominant_Info
:= No_Dominant
);
226 procedure Traverse_Package_Body
(N
: Node_Id
);
228 procedure Traverse_Package_Declaration
230 D
: Dominant_Info
:= No_Dominant
);
232 procedure Traverse_Subprogram_Or_Task_Body
234 D
: Dominant_Info
:= No_Dominant
);
236 procedure Traverse_Sync_Definition
(N
: Node_Id
);
237 -- Traverse a protected definition or task definition
239 -- Note regarding traversals: In a few cases where an Alternatives list is
240 -- involved, pragmas such as "pragma Page" may show up before the first
241 -- alternative. We skip them because we're out of statement or declaration
242 -- context, so these can't be pragmas of interest for SCO purposes, and
243 -- the regular alternative processing typically involves attribute queries
244 -- which aren't valid for a pragma.
246 procedure Write_SCOs_To_ALI_File
is new Put_SCOs
;
247 -- Write SCO information to the ALI file using routines in Lib.Util
254 procedure Dump_Entry
(Index
: Nat
; T
: SCO_Table_Entry
);
255 -- Dump a SCO table entry
261 procedure Dump_Entry
(Index
: Nat
; T
: SCO_Table_Entry
) is
268 Write_Str
(" C1 = '");
274 Write_Str
(" C2 = '");
279 if T
.From
/= No_Source_Location
then
280 Write_Str
(" From = ");
281 Write_Int
(Int
(T
.From
.Line
));
283 Write_Int
(Int
(T
.From
.Col
));
286 if T
.To
/= No_Source_Location
then
287 Write_Str
(" To = ");
288 Write_Int
(Int
(T
.To
.Line
));
290 Write_Int
(Int
(T
.To
.Col
));
296 Write_Str
(" False");
302 -- Start of processing for dsco
305 -- Dump SCO unit table
307 Write_Line
("SCO Unit Table");
308 Write_Line
("--------------");
310 for Index
in 1 .. SCO_Unit_Table
.Last
loop
312 UTE
: SCO_Unit_Table_Entry
renames SCO_Unit_Table
.Table
(Index
);
316 Write_Int
(Int
(Index
));
317 Write_Str
(" Dep_Num = ");
318 Write_Int
(Int
(UTE
.Dep_Num
));
319 Write_Str
(" From = ");
320 Write_Int
(Int
(UTE
.From
));
321 Write_Str
(" To = ");
322 Write_Int
(Int
(UTE
.To
));
324 Write_Str
(" File_Name = """);
326 if UTE
.File_Name
/= null then
327 Write_Str
(UTE
.File_Name
.all);
335 -- Dump SCO Unit number table if it contains any entries
337 if SCO_Unit_Number_Table
.Last
>= 1 then
339 Write_Line
("SCO Unit Number Table");
340 Write_Line
("---------------------");
342 for Index
in 1 .. SCO_Unit_Number_Table
.Last
loop
344 Write_Int
(Int
(Index
));
345 Write_Str
(". Unit_Number = ");
346 Write_Int
(Int
(SCO_Unit_Number_Table
.Table
(Index
)));
351 -- Dump SCO raw-table
354 Write_Line
("SCO Raw Table");
355 Write_Line
("---------");
357 if SCO_Generation_State
= Filtered
then
358 Write_Line
("Empty (free'd after second pass)");
360 for Index
in 1 .. SCO_Raw_Table
.Last
loop
361 Dump_Entry
(Index
, SCO_Raw_Table
.Table
(Index
));
365 -- Dump SCO table itself
368 Write_Line
("SCO Filtered Table");
369 Write_Line
("---------");
371 for Index
in 1 .. SCO_Table
.Last
loop
372 Dump_Entry
(Index
, SCO_Table
.Table
(Index
));
380 function Equal
(F1
: Source_Ptr
; F2
: Source_Ptr
) return Boolean is
389 function "<" (S1
: Source_Location
; S2
: Source_Location
) return Boolean is
391 return S1
.Line
< S2
.Line
392 or else (S1
.Line
= S2
.Line
and then S1
.Col
< S2
.Col
);
399 function Has_Decision
(N
: Node_Id
) return Boolean is
400 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
401 -- Determine if Nkind (N) indicates the presence of a decision (i.e. N
402 -- is a logical operator, which is a decision in itself, or an
403 -- IF-expression whose Condition attribute is a decision).
409 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
411 -- If we are not sure this is a logical operator (AND and OR may be
412 -- turned into logical operators with the Short_Circuit_And_Or
413 -- pragma), assume it is. Putative decisions will be discarded if
414 -- needed in the secord pass.
416 if Is_Logical_Operator
(N
) /= False
417 or else Nkind
(N
) = N_If_Expression
425 function Traverse
is new Traverse_Func
(Check_Node
);
427 -- Start of processing for Has_Decision
430 return Traverse
(N
) = Abandon
;
437 function Hash
(F
: Source_Ptr
) return Header_Num
is
439 return Header_Num
(Nat
(F
) mod 997);
446 procedure Initialize
is
448 SCO_Unit_Number_Table
.Init
;
450 -- The SCO_Unit_Number_Table entry with index 0 is intentionally set
451 -- aside to be used as temporary for sorting.
453 SCO_Unit_Number_Table
.Increment_Last
;
456 -------------------------
457 -- Is_Logical_Operator --
458 -------------------------
460 function Is_Logical_Operator
(N
: Node_Id
) return Tristate
is
462 if Nkind_In
(N
, N_And_Then
, N_Op_Not
, N_Or_Else
) then
464 elsif Nkind_In
(N
, N_Op_And
, N_Op_Or
) then
469 end Is_Logical_Operator
;
471 -----------------------
472 -- Process_Decisions --
473 -----------------------
475 -- Version taking a list
477 procedure Process_Decisions
480 Pragma_Sloc
: Source_Ptr
)
487 while Present
(N
) loop
488 Process_Decisions
(N
, T
, Pragma_Sloc
);
492 end Process_Decisions
;
494 -- Version taking a node
496 Current_Pragma_Sloc
: Source_Ptr
:= No_Location
;
497 -- While processing a pragma, this is set to the sloc of the N_Pragma node
499 procedure Process_Decisions
502 Pragma_Sloc
: Source_Ptr
)
505 -- This is used to mark the location of a decision sequence in the SCO
506 -- table. We use it for backing out a simple decision in an expression
507 -- context that contains only NOT operators.
510 -- Likewise for the putative SCO_Raw_Hash_Table entries: see below
512 type Hash_Entry
is record
516 -- We must register all conditions/pragmas in SCO_Raw_Hash_Table.
517 -- However we cannot register them in the same time we are adding the
518 -- corresponding SCO entries to the raw table since we may discard them
519 -- later on. So instead we put all putative conditions into Hash_Entries
520 -- (see below) and register them once we are sure we keep them.
522 -- This data structure holds the conditions/pragmas to register in
523 -- SCO_Raw_Hash_Table.
525 package Hash_Entries
is new Table
.Table
526 (Table_Component_Type
=> Hash_Entry
,
527 Table_Index_Type
=> Nat
,
528 Table_Low_Bound
=> 1,
530 Table_Increment
=> 10,
531 Table_Name
=> "Hash_Entries");
532 -- Hold temporarily (i.e. free'd before returning) the Hash_Entry before
533 -- they are registered in SCO_Raw_Hash_Table.
535 X_Not_Decision
: Boolean;
536 -- This flag keeps track of whether a decision sequence in the SCO table
537 -- contains only NOT operators, and is for an expression context (T=X).
538 -- The flag will be set False if T is other than X, or if an operator
539 -- other than NOT is in the sequence.
541 procedure Output_Decision_Operand
(N
: Node_Id
);
542 -- The node N is the top level logical operator of a decision, or it is
543 -- one of the operands of a logical operator belonging to a single
544 -- complex decision. This routine outputs the sequence of table entries
545 -- corresponding to the node. Note that we do not process the sub-
546 -- operands to look for further decisions, that processing is done in
547 -- Process_Decision_Operand, because we can't get decisions mixed up in
548 -- the global table. Call has no effect if N is Empty.
550 procedure Output_Element
(N
: Node_Id
);
551 -- Node N is an operand of a logical operator that is not itself a
552 -- logical operator, or it is a simple decision. This routine outputs
553 -- the table entry for the element, with C1 set to ' '. Last is set
554 -- False, and an entry is made in the condition hash table.
556 procedure Output_Header
(T
: Character);
557 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
558 -- PRAGMA, and 'X' for the expression case.
560 procedure Process_Decision_Operand
(N
: Node_Id
);
561 -- This is called on node N, the top level node of a decision, or on one
562 -- of its operands or suboperands after generating the full output for
563 -- the complex decision. It process the suboperands of the decision
564 -- looking for nested decisions.
566 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
567 -- Processes one node in the traversal, looking for logical operators,
568 -- and if one is found, outputs the appropriate table entries.
570 -----------------------------
571 -- Output_Decision_Operand --
572 -----------------------------
574 procedure Output_Decision_Operand
(N
: Node_Id
) is
577 -- C1 holds a character that identifies the operation while C2
578 -- indicates whether we are sure (' ') or not ('?') this operation
579 -- belongs to the decision. '?' entries will be filtered out in the
580 -- second (SCO_Record_Filtered) pass.
590 T
:= Is_Logical_Operator
(N
);
595 if Nkind
(N
) = N_Op_Not
then
602 if Nkind_In
(N
, N_Op_Or
, N_Or_Else
) then
604 else pragma Assert
(Nkind_In
(N
, N_Op_And
, N_And_Then
));
622 Hash_Entries
.Append
((Sloc
(N
), SCO_Raw_Table
.Last
));
624 Output_Decision_Operand
(L
);
625 Output_Decision_Operand
(Right_Opnd
(N
));
627 -- Not a logical operator
632 end Output_Decision_Operand
;
638 procedure Output_Element
(N
: Node_Id
) is
642 Sloc_Range
(N
, FSloc
, LSloc
);
649 Hash_Entries
.Append
((FSloc
, SCO_Raw_Table
.Last
));
656 procedure Output_Header
(T
: Character) is
657 Loc
: Source_Ptr
:= No_Location
;
658 -- Node whose Sloc is used for the decision
660 Nam
: Name_Id
:= No_Name
;
661 -- For the case of an aspect, aspect name
665 when 'I' |
'E' |
'W' |
'a' |
'A' =>
667 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
668 -- the parent of the expression.
670 Loc
:= Sloc
(Parent
(N
));
672 if T
= 'a' or else T
= 'A' then
673 Nam
:= Chars
(Identifier
(Parent
(N
)));
678 -- For entry guard, the token sloc is from the N_Entry_Body.
679 -- For PRAGMA, we must get the location from the pragma node.
680 -- Argument N is the pragma argument, and we have to go up
681 -- two levels (through the pragma argument association) to
682 -- get to the pragma node itself. For the guard on a select
683 -- alternative, we do not have access to the token location for
684 -- the WHEN, so we use the first sloc of the condition itself
685 -- (note: we use First_Sloc, not Sloc, because this is what is
686 -- referenced by dominance markers).
688 -- Doesn't this requirement of using First_Sloc need to be
689 -- documented in the spec ???
691 if Nkind_In
(Parent
(N
), N_Accept_Alternative
,
693 N_Terminate_Alternative
)
695 Loc
:= First_Sloc
(N
);
697 Loc
:= Sloc
(Parent
(Parent
(N
)));
702 -- For an expression, no Sloc
706 -- No other possibilities
718 Pragma_Sloc
=> Pragma_Sloc
,
719 Pragma_Aspect_Name
=> Nam
);
721 -- For an aspect specification, which will be rewritten into a
722 -- pragma, enter a hash table entry now.
725 Hash_Entries
.Append
((Loc
, SCO_Raw_Table
.Last
));
729 ------------------------------
730 -- Process_Decision_Operand --
731 ------------------------------
733 procedure Process_Decision_Operand
(N
: Node_Id
) is
735 if Is_Logical_Operator
(N
) /= False then
736 if Nkind
(N
) /= N_Op_Not
then
737 Process_Decision_Operand
(Left_Opnd
(N
));
738 X_Not_Decision
:= False;
741 Process_Decision_Operand
(Right_Opnd
(N
));
744 Process_Decisions
(N
, 'X', Pragma_Sloc
);
746 end Process_Decision_Operand
;
752 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
756 -- Logical operators, output table entries and then process
757 -- operands recursively to deal with nested conditions.
769 -- If outer level, then type comes from call, otherwise it
770 -- is more deeply nested and counts as X for expression.
772 if N
= Process_Decisions
.N
then
773 T
:= Process_Decisions
.T
;
778 -- Output header for sequence
780 X_Not_Decision
:= T
= 'X' and then Nkind
(N
) = N_Op_Not
;
781 Mark
:= SCO_Raw_Table
.Last
;
782 Mark_Hash
:= Hash_Entries
.Last
;
785 -- Output the decision
787 Output_Decision_Operand
(N
);
789 -- If the decision was in an expression context (T = 'X')
790 -- and contained only NOT operators, then we don't output
793 if X_Not_Decision
then
794 SCO_Raw_Table
.Set_Last
(Mark
);
795 Hash_Entries
.Set_Last
(Mark_Hash
);
797 -- Otherwise, set Last in last table entry to mark end
800 SCO_Raw_Table
.Table
(SCO_Raw_Table
.Last
).Last
:= True;
803 -- Process any embedded decisions
805 Process_Decision_Operand
(N
);
811 -- Really hard to believe this is correct given the special
812 -- handling for if expressions below ???
814 when N_Case_Expression
=>
817 -- If expression, processed like an if statement
819 when N_If_Expression
=>
821 Cond
: constant Node_Id
:= First
(Expressions
(N
));
822 Thnx
: constant Node_Id
:= Next
(Cond
);
823 Elsx
: constant Node_Id
:= Next
(Thnx
);
826 Process_Decisions
(Cond
, 'I', Pragma_Sloc
);
827 Process_Decisions
(Thnx
, 'X', Pragma_Sloc
);
828 Process_Decisions
(Elsx
, 'X', Pragma_Sloc
);
832 -- All other cases, continue scan
839 procedure Traverse
is new Traverse_Proc
(Process_Node
);
841 -- Start of processing for Process_Decisions
850 -- See if we have simple decision at outer level and if so then
851 -- generate the decision entry for this simple decision. A simple
852 -- decision is a boolean expression (which is not a logical operator
853 -- or short circuit form) appearing as the operand of an IF, WHILE,
854 -- EXIT WHEN, or special PRAGMA construct.
856 if T
/= 'X' and then Is_Logical_Operator
(N
) = False then
860 -- Change Last in last table entry to True to mark end of
861 -- sequence, which is this case is only one element long.
863 SCO_Raw_Table
.Table
(SCO_Raw_Table
.Last
).Last
:= True;
868 -- Now we have the definitive set of SCO entries, register them in the
869 -- corresponding hash table.
871 for J
in 1 .. Hash_Entries
.Last
loop
872 SCO_Raw_Hash_Table
.Set
873 (Hash_Entries
.Table
(J
).Sloc
,
874 Hash_Entries
.Table
(J
).SCO_Index
);
878 end Process_Decisions
;
885 procedure Write_Info_Char
(C
: Character) renames Write_Char
;
886 -- Write one character;
888 procedure Write_Info_Initiate
(Key
: Character) renames Write_Char
;
889 -- Start new one and write one character;
891 procedure Write_Info_Nat
(N
: Nat
);
894 procedure Write_Info_Terminate
renames Write_Eol
;
895 -- Terminate current line
901 procedure Write_Info_Nat
(N
: Nat
) is
906 procedure Debug_Put_SCOs
is new Put_SCOs
;
908 -- Start of processing for pscos
914 ---------------------
915 -- Record_Instance --
916 ---------------------
918 procedure Record_Instance
(Id
: Instance_Id
; Inst_Sloc
: Source_Ptr
) is
919 Inst_Src
: constant Source_File_Index
:=
920 Get_Source_File_Index
(Inst_Sloc
);
922 SCO_Instance_Table
.Append
923 ((Inst_Dep_Num
=> Dependency_Num
(Unit
(Inst_Src
)),
924 Inst_Loc
=> To_Source_Location
(Inst_Sloc
),
925 Enclosing_Instance
=> SCO_Instance_Index
(Instance
(Inst_Src
))));
928 (SCO_Instance_Table
.Last
= SCO_Instance_Index
(Id
));
935 procedure SCO_Output
is
936 procedure Populate_SCO_Instance_Table
is
937 new Sinput
.Iterate_On_Instances
(Record_Instance
);
940 pragma Assert
(SCO_Generation_State
= Filtered
);
942 if Debug_Flag_Dot_OO
then
946 Populate_SCO_Instance_Table
;
948 -- Sort the unit tables based on dependency numbers
950 Unit_Table_Sort
: declare
951 function Lt
(Op1
: Natural; Op2
: Natural) return Boolean;
952 -- Comparison routine for sort call
954 procedure Move
(From
: Natural; To
: Natural);
955 -- Move routine for sort call
961 function Lt
(Op1
: Natural; Op2
: Natural) return Boolean is
965 (SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(Op1
)))
968 (SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(Op2
)));
975 procedure Move
(From
: Natural; To
: Natural) is
977 SCO_Unit_Table
.Table
(SCO_Unit_Index
(To
)) :=
978 SCO_Unit_Table
.Table
(SCO_Unit_Index
(From
));
979 SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(To
)) :=
980 SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(From
));
983 package Sorting
is new GNAT
.Heap_Sort_G
(Move
, Lt
);
985 -- Start of processing for Unit_Table_Sort
988 Sorting
.Sort
(Integer (SCO_Unit_Table
.Last
));
991 -- Loop through entries in the unit table to set file name and
992 -- dependency number entries.
994 for J
in 1 .. SCO_Unit_Table
.Last
loop
996 U
: constant Unit_Number_Type
:= SCO_Unit_Number_Table
.Table
(J
);
997 UTE
: SCO_Unit_Table_Entry
renames SCO_Unit_Table
.Table
(J
);
1000 Get_Name_String
(Reference_Name
(Source_Index
(U
)));
1001 UTE
.File_Name
:= new String'(Name_Buffer (1 .. Name_Len));
1002 UTE.Dep_Num := Dependency_Num (U);
1006 -- Now the tables are all setup for output to the ALI file
1008 Write_SCOs_To_ALI_File;
1011 -------------------------
1012 -- SCO_Pragma_Disabled --
1013 -------------------------
1015 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
1019 if Loc = No_Location then
1023 Index := SCO_Raw_Hash_Table.Get (Loc);
1025 -- The test here for zero is to deal with possible previous errors, and
1026 -- for the case of pragma statement SCOs, for which we always set the
1027 -- Pragma_Sloc even if the particular pragma cannot be specifically
1032 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
1042 -- Aspect decision (enabled)
1047 -- Aspect decision (not enabled)
1052 -- Nullified disabled SCO
1057 raise Program_Error;
1064 end SCO_Pragma_Disabled;
1066 --------------------
1067 -- SCO_Record_Raw --
1068 --------------------
1070 procedure SCO_Record_Raw (U : Unit_Number_Type) is
1071 procedure Traverse_Aux_Decls (N : Node_Id);
1072 -- Traverse the Aux_Decls_Node of compilation unit N
1074 ------------------------
1075 -- Traverse_Aux_Decls --
1076 ------------------------
1078 procedure Traverse_Aux_Decls (N : Node_Id) is
1079 ADN : constant Node_Id := Aux_Decls_Node (N);
1082 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
1083 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
1085 -- Declarations and Actions do not correspond to source constructs,
1086 -- they contain only nodes from expansion, so at this point they
1087 -- should still be empty:
1089 pragma Assert (No (Declarations (ADN)));
1090 pragma Assert (No (Actions (ADN)));
1091 end Traverse_Aux_Decls;
1098 -- Start of processing for SCO_Record_Raw
1101 -- It is legitimate to run this pass multiple times (once per unit) so
1102 -- run it even if it was already run before.
1104 pragma Assert (SCO_Generation_State in None .. Raw);
1105 SCO_Generation_State := Raw;
1107 -- Ignore call if not generating code and generating SCO's
1109 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
1113 -- Ignore call if this unit already recorded
1115 for J in 1 .. SCO_Unit_Number_Table.Last loop
1116 if U = SCO_Unit_Number_Table.Table (J) then
1121 -- Otherwise record starting entry
1123 From := SCO_Raw_Table.Last + 1;
1125 -- Get Unit (checking case of subunit)
1127 Lu := Unit (Cunit (U));
1129 if Nkind (Lu) = N_Subunit then
1130 Lu := Proper_Body (Lu);
1133 -- Traverse the unit
1135 Traverse_Aux_Decls (Cunit (U));
1138 when N_Generic_Instantiation
1139 | N_Generic_Package_Declaration
1141 | N_Package_Declaration
1144 | N_Subprogram_Declaration
1147 Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
1149 -- All other cases of compilation units (e.g. renamings), generate no
1156 -- Make entry for new unit in unit tables, we will fill in the file
1157 -- name and dependency numbers later.
1159 SCO_Unit_Table.Append (
1162 File_Index => Get_Source_File_Index (Sloc (Lu)),
1164 To => SCO_Raw_Table.Last));
1166 SCO_Unit_Number_Table.Append (U);
1169 -----------------------
1170 -- Set_SCO_Condition --
1171 -----------------------
1173 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
1175 -- SCO annotations are not processed after the filtering pass
1177 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1179 Constant_Condition_Code : constant array (Boolean) of Character :=
1180 (False => 'f
', True => 't
');
1182 Orig : constant Node_Id := Original_Node (Cond);
1188 Sloc_Range (Orig, Start, Dummy);
1189 Index := SCO_Raw_Hash_Table.Get (Start);
1191 -- Index can be zero for boolean expressions that do not have SCOs
1192 -- (simple decisions outside of a control flow structure), or in case
1193 -- of a previous error.
1199 pragma Assert (SCO_Raw_Table.Table (Index).C1 = ' ');
1200 SCO_Raw_Table.Table (Index).C2 := Constant_Condition_Code (Val);
1202 end Set_SCO_Condition;
1204 ------------------------------
1205 -- Set_SCO_Logical_Operator --
1206 ------------------------------
1208 procedure Set_SCO_Logical_Operator (Op : Node_Id) is
1210 -- SCO annotations are not processed after the filtering pass
1212 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1214 Orig : constant Node_Id := Original_Node (Op);
1215 Orig_Sloc : constant Source_Ptr := Sloc (Orig);
1216 Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
1219 -- All (putative) logical operators are supposed to have their own entry
1220 -- in the SCOs table. However, the semantic analysis may invoke this
1221 -- subprogram with nodes that are out of the SCO generation scope.
1224 SCO_Raw_Table.Table (Index).C2 := ' ';
1226 end Set_SCO_Logical_Operator;
1228 ----------------------------
1229 -- Set_SCO_Pragma_Enabled --
1230 ----------------------------
1232 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
1234 -- SCO annotations are not processed after the filtering pass
1236 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1241 -- Nothing to do if not generating SCO, or if we're not processing the
1242 -- original source occurrence of the pragma.
1244 if not (Generate_SCO
1245 and then In_Extended_Main_Source_Unit (Loc)
1246 and then not (In_Instance or In_Inlined_Body))
1251 -- Note: the reason we use the Sloc value as the key is that in the
1252 -- generic case, the call to this procedure is made on a copy of the
1253 -- original node, so we can't use the Node_Id value.
1255 Index := SCO_Raw_Hash_Table.Get (Loc);
1257 -- A zero index here indicates that semantic analysis found an
1258 -- activated pragma at Loc which does not have a corresponding pragma
1259 -- or aspect at the syntax level. This may occur in legitimate cases
1260 -- because of expanded code (such are Pre/Post conditions generated for
1261 -- formal parameter validity checks), or as a consequence of a previous
1269 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
1272 -- Note: may be called multiple times for the same sloc, so
1273 -- account for the fact that the entry may already have been
1277 -- Aspect (decision SCO)
1285 -- Pragma (statement SCO)
1288 pragma Assert (T.C2 = 'p
' or else T.C2 = 'P
');
1292 raise Program_Error;
1296 end Set_SCO_Pragma_Enabled;
1298 -------------------------
1299 -- Set_Raw_Table_Entry --
1300 -------------------------
1302 procedure Set_Raw_Table_Entry
1308 Pragma_Sloc : Source_Ptr := No_Location;
1309 Pragma_Aspect_Name : Name_Id := No_Name)
1311 pragma Assert (SCO_Generation_State = Raw);
1313 SCO_Raw_Table.Append
1316 From => To_Source_Location (From),
1317 To => To_Source_Location (To),
1319 Pragma_Sloc => Pragma_Sloc,
1320 Pragma_Aspect_Name => Pragma_Aspect_Name));
1321 end Set_Raw_Table_Entry;
1323 ------------------------
1324 -- To_Source_Location --
1325 ------------------------
1327 function To_Source_Location (S : Source_Ptr) return Source_Location is
1329 if S = No_Location then
1330 return No_Source_Location;
1333 (Line => Get_Logical_Line_Number (S),
1334 Col => Get_Column_Number (S));
1336 end To_Source_Location;
1338 -----------------------------------------
1339 -- Traverse_Declarations_Or_Statements --
1340 -----------------------------------------
1342 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
1343 -- holding statement and decision entries. These are declared globally
1344 -- since they are shared by recursive calls to this procedure.
1346 type SC_Entry is record
1352 -- Used to store a single entry in the following table, From:To represents
1353 -- the range of entries in the CS line entry, and typ is the type, with
1354 -- space meaning that no type letter will accompany the entry.
1356 package SC is new Table.Table
1357 (Table_Component_Type => SC_Entry,
1358 Table_Index_Type => Nat,
1359 Table_Low_Bound => 1,
1360 Table_Initial => 1000,
1361 Table_Increment => 200,
1362 Table_Name => "SCO_SC");
1363 -- Used to store statement components for a CS entry to be output as a
1364 -- result of the call to this procedure. SC.Last is the last entry stored,
1365 -- so the current statement sequence is represented by SC_Array (SC_First
1366 -- .. SC.Last), where SC_First is saved on entry to each recursive call to
1369 -- Extend_Statement_Sequence adds an entry to this array, and then
1370 -- Set_Statement_Entry clears the entries starting with SC_First, copying
1371 -- these entries to the main SCO output table. The reason that we do the
1372 -- temporary caching of results in this array is that we want the SCO table
1373 -- entries for a given CS line to be contiguous, and the processing may
1374 -- output intermediate entries such as decision entries.
1376 type SD_Entry is record
1382 -- Used to store a single entry in the following table. Nod is the node to
1383 -- be searched for decisions for the case of Process_Decisions_Defer with a
1384 -- node argument (with Lst set to No_List. Lst is the list to be searched
1385 -- for decisions for the case of Process_Decisions_Defer with a List
1386 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
1387 -- enclosing pragma, if any.
1389 package SD is new Table.Table
1390 (Table_Component_Type => SD_Entry,
1391 Table_Index_Type => Nat,
1392 Table_Low_Bound => 1,
1393 Table_Initial => 1000,
1394 Table_Increment => 200,
1395 Table_Name => "SCO_SD");
1396 -- Used to store possible decision information. Instead of calling the
1397 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
1398 -- which simply stores the arguments in this table. Then when we clear
1399 -- out a statement sequence using Set_Statement_Entry, after generating
1400 -- the CS lines for the statements, the entries in this table result in
1401 -- calls to Process_Decision. The reason for doing things this way is to
1402 -- ensure that decisions are output after the CS line for the statements
1403 -- in which the decisions occur.
1405 procedure Traverse_Declarations_Or_Statements
1407 D : Dominant_Info := No_Dominant;
1408 P : Node_Id := Empty)
1410 Discard_Dom : Dominant_Info;
1411 pragma Warnings (Off, Discard_Dom);
1413 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P);
1414 end Traverse_Declarations_Or_Statements;
1416 function Traverse_Declarations_Or_Statements
1418 D : Dominant_Info := No_Dominant;
1419 P : Node_Id := Empty) return Dominant_Info
1421 Current_Dominant : Dominant_Info := D;
1422 -- Dominance information for the current basic block
1424 Current_Test : Node_Id;
1425 -- Conditional node (N_If_Statement or N_Elsiif being processed
1429 SC_First : constant Nat := SC.Last + 1;
1430 SD_First : constant Nat := SD.Last + 1;
1431 -- Record first entries used in SC/SD at this recursive level
1433 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1434 -- Extend the current statement sequence to encompass the node N. Typ
1435 -- is the letter that identifies the type of statement/declaration that
1436 -- is being added to the sequence.
1438 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1439 pragma Inline (Process_Decisions_Defer);
1440 -- This routine is logically the same as Process_Decisions, except that
1441 -- the arguments are saved in the SD table for later processing when
1442 -- Set_Statement_Entry is called, which goes through the saved entries
1443 -- making the corresponding calls to Process_Decision.
1445 procedure Process_Decisions_Defer (L : List_Id; T : Character);
1446 pragma Inline (Process_Decisions_Defer);
1447 -- Same case for list arguments, deferred call to Process_Decisions
1449 procedure Set_Statement_Entry;
1450 -- Output CS entries for all statements saved in table SC, and end the
1451 -- current CS sequence. Then output entries for all decisions nested in
1452 -- these statements, which have been deferred so far.
1454 procedure Traverse_One (N : Node_Id);
1455 -- Traverse one declaration or statement
1457 procedure Traverse_Aspects (N : Node_Id);
1458 -- Helper for Traverse_One: traverse N's aspect specifications
1460 -------------------------------
1461 -- Extend_Statement_Sequence --
1462 -------------------------------
1464 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1468 To_Node : Node_Id := Empty;
1471 Sloc_Range (N, F, T);
1474 when N_Accept_Statement =>
1475 if Present (Parameter_Specifications (N)) then
1476 To_Node := Last (Parameter_Specifications (N));
1477 elsif Present (Entry_Index (N)) then
1478 To_Node := Entry_Index (N);
1481 when N_Case_Statement =>
1482 To_Node := Expression (N);
1487 To_Node := Condition (N);
1489 when N_Extended_Return_Statement =>
1490 To_Node := Last (Return_Object_Declarations (N));
1492 when N_Loop_Statement =>
1493 To_Node := Iteration_Scheme (N);
1495 when N_Asynchronous_Select
1496 | N_Conditional_Entry_Call
1497 | N_Selective_Accept
1498 | N_Single_Protected_Declaration
1499 | N_Single_Task_Declaration
1500 | N_Timed_Entry_Call
1504 when N_Protected_Type_Declaration
1505 | N_Task_Type_Declaration
1507 if Has_Aspects (N) then
1508 To_Node := Last (Aspect_Specifications (N));
1510 elsif Present (Discriminant_Specifications (N)) then
1511 To_Node := Last (Discriminant_Specifications (N));
1514 To_Node := Defining_Identifier (N);
1521 if Present (To_Node) then
1522 Sloc_Range (To_Node, Dummy, T);
1525 SC.Append ((N, F, T, Typ));
1526 end Extend_Statement_Sequence;
1528 -----------------------------
1529 -- Process_Decisions_Defer --
1530 -----------------------------
1532 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1534 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1535 end Process_Decisions_Defer;
1537 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1539 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1540 end Process_Decisions_Defer;
1542 -------------------------
1543 -- Set_Statement_Entry --
1544 -------------------------
1546 procedure Set_Statement_Entry is
1547 SC_Last : constant Int := SC.Last;
1548 SD_Last : constant Int := SD.Last;
1551 -- Output statement entries from saved entries in SC table
1553 for J in SC_First .. SC_Last loop
1554 if J = SC_First then
1556 if Current_Dominant /= No_Dominant then
1562 Sloc_Range (Current_Dominant.N, From, To);
1564 if Current_Dominant.K /= 'E
' then
1570 C2 => Current_Dominant.K,
1574 Pragma_Sloc => No_Location,
1575 Pragma_Aspect_Name => No_Name);
1581 SCE : SC_Entry renames SC.Table (J);
1582 Pragma_Sloc : Source_Ptr := No_Location;
1583 Pragma_Aspect_Name : Name_Id := No_Name;
1586 -- For the case of a statement SCO for a pragma controlled by
1587 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1588 -- those of any nested decision) is emitted only if the pragma
1591 if SCE.Typ = 'p
' then
1592 Pragma_Sloc := SCE.From;
1593 SCO_Raw_Hash_Table.Set
1594 (Pragma_Sloc, SCO_Raw_Table.Last + 1);
1595 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
1596 pragma Assert (Pragma_Aspect_Name /= No_Name);
1598 elsif SCE.Typ = 'P
' then
1599 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
1600 pragma Assert (Pragma_Aspect_Name /= No_Name);
1608 Last => (J = SC_Last),
1609 Pragma_Sloc => Pragma_Sloc,
1610 Pragma_Aspect_Name => Pragma_Aspect_Name);
1614 -- Last statement of basic block, if present, becomes new current
1617 if SC_Last >= SC_First then
1618 Current_Dominant := ('S
', SC.Table (SC_Last).N);
1621 -- Clear out used section of SC table
1623 SC.Set_Last (SC_First - 1);
1625 -- Output any embedded decisions
1627 for J in SD_First .. SD_Last loop
1629 SDE : SD_Entry renames SD.Table (J);
1632 if Present (SDE.Nod) then
1633 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1635 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1640 -- Clear out used section of SD table
1642 SD.Set_Last (SD_First - 1);
1643 end Set_Statement_Entry;
1645 ----------------------
1646 -- Traverse_Aspects --
1647 ----------------------
1649 procedure Traverse_Aspects (N : Node_Id) is
1655 AN := First (Aspect_Specifications (N));
1656 while Present (AN) loop
1657 AE := Expression (AN);
1659 -- SCOs are generated before semantic analysis/expansion:
1660 -- PPCs are not split yet.
1662 pragma Assert (not Split_PPC (AN));
1666 case Get_Aspect_Id (AN) is
1668 -- Aspects rewritten into pragmas controlled by a Check_Policy:
1669 -- Current_Pragma_Sloc must be set to the sloc of the aspect
1670 -- specification. The corresponding pragma will have the same
1673 when Aspect_Invariant
1675 | Aspect_Postcondition
1677 | Aspect_Precondition
1678 | Aspect_Type_Invariant
1682 -- Aspects whose checks are generated in client units,
1683 -- regardless of whether or not the check is activated in the
1684 -- unit which contains the declaration: create decision as
1685 -- unconditionally enabled aspect (but still make a pragma
1686 -- entry since Set_SCO_Pragma_Enabled will be called when
1687 -- analyzing actual checks, possibly in other units).
1689 -- Pre/post can have checks in client units too because of
1690 -- inheritance, so should they be moved here???
1692 when Aspect_Dynamic_Predicate
1694 | Aspect_Static_Predicate
1698 -- Other aspects: just process any decision nested in the
1699 -- aspect expression.
1702 if Has_Decision (AE) then
1707 if C1 /= ASCII.NUL then
1708 pragma Assert (Current_Pragma_Sloc = No_Location);
1710 if C1 = 'a
' or else C1 = 'A
' then
1711 Current_Pragma_Sloc := Sloc (AN);
1714 Process_Decisions_Defer (AE, C1);
1716 Current_Pragma_Sloc := No_Location;
1721 end Traverse_Aspects;
1727 procedure Traverse_One (N : Node_Id) is
1729 -- Initialize or extend current statement sequence. Note that for
1730 -- special cases such as IF and Case statements we will modify
1731 -- the range to exclude internal statements that should not be
1732 -- counted as part of the current statement sequence.
1736 -- Package declaration
1738 when N_Package_Declaration =>
1739 Set_Statement_Entry;
1740 Traverse_Package_Declaration (N, Current_Dominant);
1742 -- Generic package declaration
1744 when N_Generic_Package_Declaration =>
1745 Set_Statement_Entry;
1746 Traverse_Generic_Package_Declaration (N);
1750 when N_Package_Body =>
1751 Set_Statement_Entry;
1752 Traverse_Package_Body (N);
1754 -- Subprogram declaration or subprogram body stub
1756 when N_Subprogram_Body_Stub
1757 | N_Subprogram_Declaration
1759 Process_Decisions_Defer
1760 (Parameter_Specifications (Specification (N)), 'X
');
1762 -- Entry declaration
1764 when N_Entry_Declaration =>
1765 Process_Decisions_Defer (Parameter_Specifications (N), 'X
');
1767 -- Generic subprogram declaration
1769 when N_Generic_Subprogram_Declaration =>
1770 Process_Decisions_Defer
1771 (Generic_Formal_Declarations (N), 'X
');
1772 Process_Decisions_Defer
1773 (Parameter_Specifications (Specification (N)), 'X
');
1775 -- Task or subprogram body
1777 when N_Subprogram_Body
1780 Set_Statement_Entry;
1781 Traverse_Subprogram_Or_Task_Body (N);
1785 when N_Entry_Body =>
1787 Cond : constant Node_Id :=
1788 Condition (Entry_Body_Formal_Part (N));
1790 Inner_Dominant : Dominant_Info := No_Dominant;
1793 Set_Statement_Entry;
1795 if Present (Cond) then
1796 Process_Decisions_Defer (Cond, 'G
');
1798 -- For an entry body with a barrier, the entry body
1799 -- is dominanted by a True evaluation of the barrier.
1801 Inner_Dominant := ('T
', N);
1804 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
1809 when N_Protected_Body =>
1810 Set_Statement_Entry;
1811 Traverse_Declarations_Or_Statements (Declarations (N));
1813 -- Exit statement, which is an exit statement in the SCO sense,
1814 -- so it is included in the current statement sequence, but
1815 -- then it terminates this sequence. We also have to process
1816 -- any decisions in the exit statement expression.
1818 when N_Exit_Statement =>
1819 Extend_Statement_Sequence (N, 'E
');
1820 Process_Decisions_Defer (Condition (N), 'E
');
1821 Set_Statement_Entry;
1823 -- If condition is present, then following statement is
1824 -- only executed if the condition evaluates to False.
1826 if Present (Condition (N)) then
1827 Current_Dominant := ('F
', N);
1829 Current_Dominant := No_Dominant;
1832 -- Label, which breaks the current statement sequence, but the
1833 -- label itself is not included in the next statement sequence,
1834 -- since it generates no code.
1837 Set_Statement_Entry;
1838 Current_Dominant := No_Dominant;
1840 -- Block statement, which breaks the current statement sequence
1842 when N_Block_Statement =>
1843 Set_Statement_Entry;
1845 -- The first statement in the handled sequence of statements
1846 -- is dominated by the elaboration of the last declaration.
1848 Current_Dominant := Traverse_Declarations_Or_Statements
1849 (L => Declarations (N),
1850 D => Current_Dominant);
1852 Traverse_Handled_Statement_Sequence
1853 (N => Handled_Statement_Sequence (N),
1854 D => Current_Dominant);
1856 -- If statement, which breaks the current statement sequence,
1857 -- but we include the condition in the current sequence.
1859 when N_If_Statement =>
1861 Extend_Statement_Sequence (N, 'I
');
1862 Process_Decisions_Defer (Condition (N), 'I
');
1863 Set_Statement_Entry;
1865 -- Now we traverse the statements in the THEN part
1867 Traverse_Declarations_Or_Statements
1868 (L => Then_Statements (N),
1871 -- Loop through ELSIF parts if present
1873 if Present (Elsif_Parts (N)) then
1875 Saved_Dominant : constant Dominant_Info :=
1878 Elif : Node_Id := First (Elsif_Parts (N));
1881 while Present (Elif) loop
1883 -- An Elsif is executed only if the previous test
1884 -- got a FALSE outcome.
1886 Current_Dominant := ('F
', Current_Test);
1888 -- Now update current test information
1890 Current_Test := Elif;
1892 -- We generate a statement sequence for the
1893 -- construct "ELSIF condition", so that we have
1894 -- a statement for the resulting decisions.
1896 Extend_Statement_Sequence (Elif, 'I
');
1897 Process_Decisions_Defer (Condition (Elif), 'I
');
1898 Set_Statement_Entry;
1900 -- An ELSIF part is never guaranteed to have
1901 -- been executed, following statements are only
1902 -- dominated by the initial IF statement.
1904 Current_Dominant := Saved_Dominant;
1906 -- Traverse the statements in the ELSIF
1908 Traverse_Declarations_Or_Statements
1909 (L => Then_Statements (Elif),
1916 -- Finally traverse the ELSE statements if present
1918 Traverse_Declarations_Or_Statements
1919 (L => Else_Statements (N),
1920 D => ('F
', Current_Test));
1922 -- CASE statement, which breaks the current statement sequence,
1923 -- but we include the expression in the current sequence.
1925 when N_Case_Statement =>
1926 Extend_Statement_Sequence (N, 'C
');
1927 Process_Decisions_Defer (Expression (N), 'X
');
1928 Set_Statement_Entry;
1930 -- Process case branches, all of which are dominated by the
1936 Alt := First_Non_Pragma (Alternatives (N));
1937 while Present (Alt) loop
1938 Traverse_Declarations_Or_Statements
1939 (L => Statements (Alt),
1940 D => Current_Dominant);
1947 when N_Accept_Statement =>
1948 Extend_Statement_Sequence (N, 'A
');
1949 Set_Statement_Entry;
1951 -- Process sequence of statements, dominant is the ACCEPT
1954 Traverse_Handled_Statement_Sequence
1955 (N => Handled_Statement_Sequence (N),
1956 D => Current_Dominant);
1960 when N_Selective_Accept =>
1961 Extend_Statement_Sequence (N, 'S
');
1962 Set_Statement_Entry;
1964 -- Process alternatives
1969 S_Dom : Dominant_Info;
1972 Alt := First (Select_Alternatives (N));
1973 while Present (Alt) loop
1974 S_Dom := Current_Dominant;
1975 Guard := Condition (Alt);
1977 if Present (Guard) then
1981 Pragma_Sloc => No_Location);
1982 Current_Dominant := ('T
', Guard);
1987 Current_Dominant := S_Dom;
1992 Traverse_Declarations_Or_Statements
1993 (L => Else_Statements (N),
1994 D => Current_Dominant);
1996 when N_Conditional_Entry_Call
1997 | N_Timed_Entry_Call
1999 Extend_Statement_Sequence (N, 'S
');
2000 Set_Statement_Entry;
2002 -- Process alternatives
2004 Traverse_One (Entry_Call_Alternative (N));
2006 if Nkind (N) = N_Timed_Entry_Call then
2007 Traverse_One (Delay_Alternative (N));
2009 Traverse_Declarations_Or_Statements
2010 (L => Else_Statements (N),
2011 D => Current_Dominant);
2014 when N_Asynchronous_Select =>
2015 Extend_Statement_Sequence (N, 'S
');
2016 Set_Statement_Entry;
2018 Traverse_One (Triggering_Alternative (N));
2019 Traverse_Declarations_Or_Statements
2020 (L => Statements (Abortable_Part (N)),
2021 D => Current_Dominant);
2023 when N_Accept_Alternative =>
2024 Traverse_Declarations_Or_Statements
2025 (L => Statements (N),
2026 D => Current_Dominant,
2027 P => Accept_Statement (N));
2029 when N_Entry_Call_Alternative =>
2030 Traverse_Declarations_Or_Statements
2031 (L => Statements (N),
2032 D => Current_Dominant,
2033 P => Entry_Call_Statement (N));
2035 when N_Delay_Alternative =>
2036 Traverse_Declarations_Or_Statements
2037 (L => Statements (N),
2038 D => Current_Dominant,
2039 P => Delay_Statement (N));
2041 when N_Triggering_Alternative =>
2042 Traverse_Declarations_Or_Statements
2043 (L => Statements (N),
2044 D => Current_Dominant,
2045 P => Triggering_Statement (N));
2047 when N_Terminate_Alternative =>
2049 -- It is dubious to emit a statement SCO for a TERMINATE
2050 -- alternative, since no code is actually executed if the
2051 -- alternative is selected -- the tasking runtime call just
2054 Extend_Statement_Sequence (N, ' ');
2055 Set_Statement_Entry;
2057 -- Unconditional exit points, which are included in the current
2058 -- statement sequence, but then terminate it
2060 when N_Goto_Statement
2062 | N_Requeue_Statement
2064 Extend_Statement_Sequence (N, ' ');
2065 Set_Statement_Entry;
2066 Current_Dominant := No_Dominant;
2068 -- Simple return statement. which is an exit point, but we
2069 -- have to process the return expression for decisions.
2071 when N_Simple_Return_Statement =>
2072 Extend_Statement_Sequence (N, ' ');
2073 Process_Decisions_Defer (Expression (N), 'X
');
2074 Set_Statement_Entry;
2075 Current_Dominant := No_Dominant;
2077 -- Extended return statement
2079 when N_Extended_Return_Statement =>
2080 Extend_Statement_Sequence (N, 'R
');
2081 Process_Decisions_Defer (Return_Object_Declarations (N), 'X
');
2082 Set_Statement_Entry;
2084 Traverse_Handled_Statement_Sequence
2085 (N => Handled_Statement_Sequence (N),
2086 D => Current_Dominant);
2088 Current_Dominant := No_Dominant;
2090 -- Loop ends the current statement sequence, but we include
2091 -- the iteration scheme if present in the current sequence.
2092 -- But the body of the loop starts a new sequence, since it
2093 -- may not be executed as part of the current sequence.
2095 when N_Loop_Statement =>
2097 ISC : constant Node_Id := Iteration_Scheme (N);
2098 Inner_Dominant : Dominant_Info := No_Dominant;
2101 if Present (ISC) then
2103 -- If iteration scheme present, extend the current
2104 -- statement sequence to include the iteration scheme
2105 -- and process any decisions it contains.
2109 if Present (Condition (ISC)) then
2110 Extend_Statement_Sequence (N, 'W
');
2111 Process_Decisions_Defer (Condition (ISC), 'W
');
2113 -- Set more specific dominant for inner statements
2114 -- (the control sloc for the decision is that of
2115 -- the WHILE token).
2117 Inner_Dominant := ('T
', ISC);
2122 Extend_Statement_Sequence (N, 'F
');
2123 Process_Decisions_Defer
2124 (Loop_Parameter_Specification (ISC), 'X
');
2128 Set_Statement_Entry;
2130 if Inner_Dominant = No_Dominant then
2131 Inner_Dominant := Current_Dominant;
2134 Traverse_Declarations_Or_Statements
2135 (L => Statements (N),
2136 D => Inner_Dominant);
2143 -- Record sloc of pragma (pragmas don't nest)
2145 pragma Assert (Current_Pragma_Sloc = No_Location);
2146 Current_Pragma_Sloc := Sloc (N);
2148 -- Processing depends on the kind of pragma
2151 Nam : constant Name_Id := Pragma_Name_Unmapped (N);
2153 First (Pragma_Argument_Associations (N));
2159 | Name_Assert_And_Cut
2162 | Name_Loop_Invariant
2163 | Name_Postcondition
2166 -- For Assert/Check/Precondition/Postcondition, we
2167 -- must generate a P entry for the decision. Note
2168 -- that this is done unconditionally at this stage.
2169 -- Output for disabled pragmas is suppressed later
2170 -- on when we output the decision line in Put_SCOs,
2171 -- depending on setting by Set_SCO_Pragma_Enabled.
2173 if Nam = Name_Check then
2177 Process_Decisions_Defer (Expression (Arg), 'P
');
2180 -- Pre/postconditions can be inherited so SCO should
2181 -- never be deactivated???
2184 if Present (Arg) and then Present (Next (Arg)) then
2186 -- Case of a dyadic pragma Debug: first argument
2187 -- is a P decision, any nested decision in the
2188 -- second argument is an X decision.
2190 Process_Decisions_Defer (Expression (Arg), 'P
');
2194 Process_Decisions_Defer (Expression (Arg), 'X
');
2197 -- For all other pragmas, we generate decision entries
2198 -- for any embedded expressions, and the pragma is
2201 -- Should generate P decisions (not X) for assertion
2202 -- related pragmas: [Type_]Invariant,
2203 -- [{Static,Dynamic}_]Predicate???
2206 Process_Decisions_Defer (N, 'X
');
2210 -- Add statement SCO
2212 Extend_Statement_Sequence (N, Typ);
2214 Current_Pragma_Sloc := No_Location;
2217 -- Object declaration. Ignored if Prev_Ids is set, since the
2218 -- parser generates multiple instances of the whole declaration
2219 -- if there is more than one identifier declared, and we only
2220 -- want one entry in the SCOs, so we take the first, for which
2221 -- Prev_Ids is False.
2223 when N_Number_Declaration
2224 | N_Object_Declaration
2226 if not Prev_Ids (N) then
2227 Extend_Statement_Sequence (N, 'o
');
2229 if Has_Decision (N) then
2230 Process_Decisions_Defer (N, 'X
');
2234 -- All other cases, which extend the current statement sequence
2235 -- but do not terminate it, even if they have nested decisions.
2237 when N_Protected_Type_Declaration
2238 | N_Task_Type_Declaration
2240 Extend_Statement_Sequence (N, 't
');
2241 Process_Decisions_Defer (Discriminant_Specifications (N), 'X
');
2242 Set_Statement_Entry;
2244 Traverse_Sync_Definition (N);
2246 when N_Single_Protected_Declaration
2247 | N_Single_Task_Declaration
2249 Extend_Statement_Sequence (N, 'o
');
2250 Set_Statement_Entry;
2252 Traverse_Sync_Definition (N);
2256 -- Determine required type character code, or ASCII.NUL if
2257 -- no SCO should be generated for this node.
2260 NK : constant Node_Kind := Nkind (N);
2265 when N_Full_Type_Declaration
2266 | N_Incomplete_Type_Declaration
2267 | N_Private_Extension_Declaration
2268 | N_Private_Type_Declaration
2272 when N_Subtype_Declaration =>
2275 when N_Renaming_Declaration =>
2278 when N_Generic_Instantiation =>
2281 when N_Package_Body_Stub
2282 | N_Protected_Body_Stub
2283 | N_Representation_Clause
2285 | N_Use_Package_Clause
2290 when N_Procedure_Call_Statement =>
2294 if NK in N_Statement_Other_Than_Procedure_Call then
2301 if Typ /= ASCII.NUL then
2302 Extend_Statement_Sequence (N, Typ);
2306 -- Process any embedded decisions
2308 if Has_Decision (N) then
2309 Process_Decisions_Defer (N, 'X
');
2313 -- Process aspects if present
2315 Traverse_Aspects (N);
2318 -- Start of processing for Traverse_Declarations_Or_Statements
2321 -- Process single prefixed node
2327 -- Loop through statements or declarations
2329 if Is_Non_Empty_List (L) then
2331 while Present (N) loop
2333 -- Note: For separate bodies, we see the tree after Par.Labl has
2334 -- introduced implicit labels, so we need to ignore those nodes.
2336 if Nkind (N) /= N_Implicit_Label_Declaration then
2345 -- End sequence of statements and flush deferred decisions
2347 if Present (P) or else Is_Non_Empty_List (L) then
2348 Set_Statement_Entry;
2351 return Current_Dominant;
2352 end Traverse_Declarations_Or_Statements;
2354 ------------------------------------------
2355 -- Traverse_Generic_Package_Declaration --
2356 ------------------------------------------
2358 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
2360 Process_Decisions (Generic_Formal_Declarations (N), 'X
', No_Location);
2361 Traverse_Package_Declaration (N);
2362 end Traverse_Generic_Package_Declaration;
2364 -----------------------------------------
2365 -- Traverse_Handled_Statement_Sequence --
2366 -----------------------------------------
2368 procedure Traverse_Handled_Statement_Sequence
2370 D : Dominant_Info := No_Dominant)
2375 -- For package bodies without a statement part, the parser adds an empty
2376 -- one, to normalize the representation. The null statement therein,
2377 -- which does not come from source, does not get a SCO.
2379 if Present (N) and then Comes_From_Source (N) then
2380 Traverse_Declarations_Or_Statements (Statements (N), D);
2382 if Present (Exception_Handlers (N)) then
2383 Handler := First_Non_Pragma (Exception_Handlers (N));
2384 while Present (Handler) loop
2385 Traverse_Declarations_Or_Statements
2386 (L => Statements (Handler),
2387 D => ('E
', Handler));
2392 end Traverse_Handled_Statement_Sequence;
2394 ---------------------------
2395 -- Traverse_Package_Body --
2396 ---------------------------
2398 procedure Traverse_Package_Body (N : Node_Id) is
2399 Dom : Dominant_Info;
2401 -- The first statement in the handled sequence of statements is
2402 -- dominated by the elaboration of the last declaration.
2404 Dom := Traverse_Declarations_Or_Statements (Declarations (N));
2406 Traverse_Handled_Statement_Sequence
2407 (Handled_Statement_Sequence (N), Dom);
2408 end Traverse_Package_Body;
2410 ----------------------------------
2411 -- Traverse_Package_Declaration --
2412 ----------------------------------
2414 procedure Traverse_Package_Declaration
2416 D : Dominant_Info := No_Dominant)
2418 Spec : constant Node_Id := Specification (N);
2419 Dom : Dominant_Info;
2423 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
2425 -- First private declaration is dominated by last visible declaration
2427 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
2428 end Traverse_Package_Declaration;
2430 ------------------------------
2431 -- Traverse_Sync_Definition --
2432 ------------------------------
2434 procedure Traverse_Sync_Definition (N : Node_Id) is
2435 Dom_Info : Dominant_Info := ('S
', N);
2436 -- The first declaration is dominated by the protected or task [type]
2440 -- N's protected or task definition
2442 Priv_Decl : List_Id;
2444 -- Sync_Def's Visible_Declarations and Private_Declarations
2448 when N_Protected_Type_Declaration
2449 | N_Single_Protected_Declaration
2451 Sync_Def := Protected_Definition (N);
2453 when N_Single_Task_Declaration
2454 | N_Task_Type_Declaration
2456 Sync_Def := Task_Definition (N);
2459 raise Program_Error;
2462 -- Sync_Def may be Empty at least for empty Task_Type_Declarations.
2463 -- Querying Visible or Private_Declarations is invalid in this case.
2465 if Present (Sync_Def) then
2466 Vis_Decl := Visible_Declarations (Sync_Def);
2467 Priv_Decl := Private_Declarations (Sync_Def);
2469 Vis_Decl := No_List;
2470 Priv_Decl := No_List;
2473 Dom_Info := Traverse_Declarations_Or_Statements
2477 -- If visible declarations are present, the first private declaration
2478 -- is dominated by the last visible declaration.
2480 Traverse_Declarations_Or_Statements
2483 end Traverse_Sync_Definition;
2485 --------------------------------------
2486 -- Traverse_Subprogram_Or_Task_Body --
2487 --------------------------------------
2489 procedure Traverse_Subprogram_Or_Task_Body
2491 D : Dominant_Info := No_Dominant)
2493 Decls : constant List_Id := Declarations (N);
2494 Dom_Info : Dominant_Info := D;
2497 -- If declarations are present, the first statement is dominated by the
2498 -- last declaration.
2500 Dom_Info := Traverse_Declarations_Or_Statements
2501 (L => Decls, D => Dom_Info);
2503 Traverse_Handled_Statement_Sequence
2504 (N => Handled_Statement_Sequence (N),
2506 end Traverse_Subprogram_Or_Task_Body;
2508 -------------------------
2509 -- SCO_Record_Filtered --
2510 -------------------------
2512 procedure SCO_Record_Filtered is
2513 type Decision is record
2515 -- Type of the SCO decision (see comments for SCO_Table_Entry.C1)
2517 Sloc : Source_Location;
2520 -- Index in the SCO_Raw_Table for the root operator/condition for the
2521 -- expression that controls the decision.
2523 -- Decision descriptor: used to gather information about a candidate
2526 package Pending_Decisions is new Table.Table
2527 (Table_Component_Type => Decision,
2528 Table_Index_Type => Nat,
2529 Table_Low_Bound => 1,
2530 Table_Initial => 1000,
2531 Table_Increment => 200,
2532 Table_Name => "Filter_Pending_Decisions");
2533 -- Table used to hold decisions to process during the collection pass
2535 procedure Add_Expression_Tree (Idx : in out Nat);
2536 -- Add SCO raw table entries for the decision controlling expression
2537 -- tree starting at Idx to the filtered SCO table.
2539 procedure Collect_Decisions
2542 -- Collect decisions to add to the filtered SCO table starting at the
2543 -- D decision (including it and its nested operators/conditions). Set
2544 -- Next to the first node index passed the whole decision.
2546 procedure Compute_Range
2548 From : out Source_Location;
2549 To : out Source_Location);
2550 -- Compute the source location range for the expression tree starting at
2551 -- Idx in the SCO raw table. Store its bounds in From and To.
2553 function Is_Decision (Idx : Nat) return Boolean;
2554 -- Return if the expression tree starting at Idx has adjacent nested
2555 -- nodes that make a decision.
2557 procedure Process_Pending_Decisions
2558 (Original_Decision : SCO_Table_Entry);
2559 -- Complete the filtered SCO table using collected decisions. Output
2560 -- decisions inherit the pragma information from the original decision.
2562 procedure Search_Nested_Decisions (Idx : in out Nat);
2563 -- Collect decisions to add to the filtered SCO table starting at the
2564 -- node at Idx in the SCO raw table. This node must not be part of an
2565 -- already-processed decision. Set Idx to the first node index passed
2566 -- the whole expression tree.
2568 procedure Skip_Decision
2570 Process_Nested_Decisions : Boolean);
2571 -- Skip all the nodes that belong to the decision starting at Idx. If
2572 -- Process_Nested_Decision, call Search_Nested_Decisions on the first
2573 -- nested nodes that do not belong to the decision. Set Idx to the first
2574 -- node index passed the whole expression tree.
2576 -------------------------
2577 -- Add_Expression_Tree --
2578 -------------------------
2580 procedure Add_Expression_Tree (Idx : in out Nat) is
2581 Node_Idx : constant Nat := Idx;
2582 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
2583 From : Source_Location;
2584 To : Source_Location;
2590 -- This is a single condition. Add an entry for it and move on
2592 SCO_Table.Append (T);
2597 -- This is a NOT operator: add an entry for it and browse its
2600 SCO_Table.Append (T);
2602 Add_Expression_Tree (Idx);
2606 -- This must be an AND/OR/AND THEN/OR ELSE operator
2610 -- This is not a short circuit operator: consider this one
2611 -- and all its children as a single condition.
2613 Compute_Range (Idx, From, To);
2620 Pragma_Sloc => No_Location,
2621 Pragma_Aspect_Name => No_Name));
2624 -- This is a real short circuit operator: add an entry for
2625 -- it and browse its children.
2627 SCO_Table.Append (T);
2629 Add_Expression_Tree (Idx);
2630 Add_Expression_Tree (Idx);
2633 end Add_Expression_Tree;
2635 -----------------------
2636 -- Collect_Decisions --
2637 -----------------------
2639 procedure Collect_Decisions
2646 if D.Kind /= 'X
' or else Is_Decision (D.Top) then
2647 Pending_Decisions.Append (D);
2650 Skip_Decision (Idx, True);
2652 end Collect_Decisions;
2658 procedure Compute_Range
2660 From : out Source_Location;
2661 To : out Source_Location)
2663 Sloc_F : Source_Location := No_Source_Location;
2664 Sloc_T : Source_Location := No_Source_Location;
2666 procedure Process_One;
2667 -- Process one node of the tree, and recurse over children. Update
2668 -- Idx during the traversal.
2674 procedure Process_One is
2676 if Sloc_F = No_Source_Location
2678 SCO_Raw_Table.Table (Idx).From < Sloc_F
2680 Sloc_F := SCO_Raw_Table.Table (Idx).From;
2683 if Sloc_T = No_Source_Location
2685 Sloc_T < SCO_Raw_Table.Table (Idx).To
2687 Sloc_T := SCO_Raw_Table.Table (Idx).To;
2690 if SCO_Raw_Table.Table (Idx).C1 = ' ' then
2692 -- This is a condition: nothing special to do
2696 elsif SCO_Raw_Table.Table (Idx).C1 = '!' then
2698 -- The "not" operator has only one operand
2704 -- This is an AND THEN or OR ELSE logical operator: follow the
2705 -- left, then the right operands.
2714 -- Start of processing for Compute_Range
2726 function Is_Decision (Idx : Nat) return Boolean is
2732 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
2741 -- This is a decision iff the only operand of the NOT
2742 -- operator could be a standalone decision.
2748 -- This node is a logical operator (and thus could be a
2749 -- standalone decision) iff it is a short circuit
2758 -------------------------------
2759 -- Process_Pending_Decisions --
2760 -------------------------------
2762 procedure Process_Pending_Decisions
2763 (Original_Decision : SCO_Table_Entry)
2766 for Index in 1 .. Pending_Decisions.Last loop
2768 D : Decision renames Pending_Decisions.Table (Index);
2772 -- Add a SCO table entry for the decision itself
2774 pragma Assert (D.Kind /= ' ');
2777 ((To => No_Source_Location,
2782 Pragma_Sloc => Original_Decision.Pragma_Sloc,
2783 Pragma_Aspect_Name =>
2784 Original_Decision.Pragma_Aspect_Name));
2786 -- Then add ones for its nested operators/operands. Do not
2787 -- forget to tag its *last* entry as such.
2789 Add_Expression_Tree (Idx);
2790 SCO_Table.Table (SCO_Table.Last).Last := True;
2794 -- Clear the pending decisions list
2795 Pending_Decisions.Set_Last (0);
2796 end Process_Pending_Decisions;
2798 -----------------------------
2799 -- Search_Nested_Decisions --
2800 -----------------------------
2802 procedure Search_Nested_Decisions (Idx : in out Nat) is
2806 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2825 -- This is not a logical operator: start looking for
2826 -- nested decisions from here. Recurse over the left
2827 -- child and let the loop take care of the right one.
2830 Search_Nested_Decisions (Idx);
2833 -- We found a nested decision
2845 end Search_Nested_Decisions;
2851 procedure Skip_Decision
2853 Process_Nested_Decisions : Boolean)
2858 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2869 -- This NOT operator belongs to the outside decision:
2875 if T.C2 = '?
' and then Process_Nested_Decisions then
2877 -- This is not a logical operator: start looking for
2878 -- nested decisions from here. Recurse over the left
2879 -- child and let the loop take care of the right one.
2881 Search_Nested_Decisions (Idx);
2884 -- This is a logical operator, so it belongs to the
2885 -- outside decision: skip its left child, then let the
2886 -- loop take care of the right one.
2888 Skip_Decision (Idx, Process_Nested_Decisions);
2895 -- Start of processing for SCO_Record_Filtered
2898 -- Filtering must happen only once: do nothing if it this pass was
2901 if SCO_Generation_State = Filtered then
2904 pragma Assert (SCO_Generation_State = Raw);
2905 SCO_Generation_State := Filtered;
2908 -- Loop through all SCO entries under SCO units
2910 for Unit_Idx in 1 .. SCO_Unit_Table.Last loop
2912 Unit : SCO_Unit_Table_Entry
2913 renames SCO_Unit_Table.Table (Unit_Idx);
2915 Idx : Nat := Unit.From;
2916 -- Index of the current SCO raw table entry
2918 New_From : constant Nat := SCO_Table.Last + 1;
2919 -- After copying SCO enties of interest to the final table, we
2920 -- will have to change the From/To indexes this unit targets.
2921 -- This constant keeps track of the new From index.
2924 while Idx <= Unit.To loop
2926 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2931 -- Decision (of any kind, including pragmas and aspects)
2933 when 'E
' | 'G
' | 'I
' | 'W
' | 'X
' | 'P
' | 'a
' | 'A
' =>
2934 if SCO_Pragma_Disabled (T.Pragma_Sloc) then
2936 -- Skip SCO entries for decisions in disabled
2937 -- constructs (pragmas or aspects).
2940 Skip_Decision (Idx, False);
2948 Process_Pending_Decisions (T);
2951 -- There is no translation/filtering to do for other kind
2952 -- of SCO items (statements, dominance markers, etc.).
2954 when '|
' | '&' | '!' | ' ' =>
2956 -- SCO logical operators and conditions cannot exist
2957 -- on their own: they must be inside a decision (such
2958 -- entries must have been skipped by
2959 -- Collect_Decisions).
2961 raise Program_Error;
2964 SCO_Table.Append (T);
2970 -- Now, update the SCO entry indexes in the unit entry
2972 Unit.From := New_From;
2973 Unit.To := SCO_Table.Last;
2977 -- Then clear the raw table to free bytes
2980 end SCO_Record_Filtered;