1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2009-2024, 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 Sinfo
.Nodes
; use Sinfo
.Nodes
;
42 with Sinfo
.Utils
; use Sinfo
.Utils
;
43 with Sinput
; use Sinput
;
44 with Snames
; use Snames
;
47 with GNAT
.HTable
; use GNAT
.HTable
;
48 with GNAT
.Heap_Sort_G
;
50 package body Par_SCO
is
52 --------------------------
53 -- First-pass SCO table --
54 --------------------------
56 -- The Short_Circuit_And_Or pragma enables one to use AND and OR operators
57 -- in source code while the ones used with booleans will be interpreted as
58 -- their short circuit alternatives (AND THEN and OR ELSE). Thus, the true
59 -- meaning of these operators is known only after the semantic analysis.
61 -- However, decision SCOs include short circuit operators only. The SCO
62 -- information generation pass must be done before expansion, hence before
63 -- the semantic analysis. Because of this, the SCO information generation
64 -- is done in two passes.
66 -- The first one (SCO_Record_Raw, before semantic analysis) completes the
67 -- SCO_Raw_Table assuming all AND/OR operators are short circuit ones.
68 -- Then, the semantic analysis determines which operators are promoted to
69 -- short circuit ones. Finally, the second pass (SCO_Record_Filtered)
70 -- translates the SCO_Raw_Table to SCO_Table, taking care of removing the
71 -- remaining AND/OR operators and of adjusting decisions accordingly
72 -- (splitting decisions, removing empty ones, etc.).
74 type SCO_Generation_State_Type
is (None
, Raw
, Filtered
);
75 SCO_Generation_State
: SCO_Generation_State_Type
:= None
;
76 -- Keep track of the SCO generation state: this will prevent us from
77 -- running some steps multiple times (the second pass has to be started
78 -- from multiple places).
80 package SCO_Raw_Table
is new Table
.Table
81 (Table_Component_Type
=> SCO_Table_Entry
,
82 Table_Index_Type
=> Nat
,
85 Table_Increment
=> 300,
86 Table_Name
=> "Raw_Table");
88 -----------------------
89 -- Unit Number Table --
90 -----------------------
92 -- This table parallels the SCO_Unit_Table, keeping track of the unit
93 -- numbers corresponding to the entries made in this table, so that before
94 -- writing out the SCO information to the ALI file, we can fill in the
95 -- proper dependency numbers and file names.
97 -- Note that the zeroth entry is here for convenience in sorting the table;
98 -- the real lower bound is 1.
100 package SCO_Unit_Number_Table
is new Table
.Table
101 (Table_Component_Type
=> Unit_Number_Type
,
102 Table_Index_Type
=> SCO_Unit_Index
,
103 Table_Low_Bound
=> 0, -- see note above on sort
105 Table_Increment
=> 200,
106 Table_Name
=> "SCO_Unit_Number_Entry");
108 ------------------------------------------
109 -- Condition/Operator/Pragma Hash Table --
110 ------------------------------------------
112 -- We need to be able to get to conditions quickly for handling the calls
113 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
114 -- handle calls to Set_SCO_Pragma_Enabled (the same holds for operators and
115 -- Set_SCO_Logical_Operator). For this purpose we identify the conditions,
116 -- operators and pragmas in the table by their starting sloc, and use this
117 -- hash table to map from these sloc values to SCO_Table indexes.
119 type Header_Num
is new Integer range 0 .. 996;
120 -- Type for hash table headers
122 function Hash
(F
: Source_Ptr
) return Header_Num
;
123 -- Function to Hash source pointer value
125 function Equal
(F1
: Source_Ptr
; F2
: Source_Ptr
) return Boolean;
126 -- Function to test two keys for equality
128 function "<" (S1
: Source_Location
; S2
: Source_Location
) return Boolean;
129 -- Function to test for source locations order
131 package SCO_Raw_Hash_Table
is new Simple_HTable
132 (Header_Num
, Int
, 0, Source_Ptr
, Hash
, Equal
);
133 -- The actual hash table
135 --------------------------
136 -- Internal Subprograms --
137 --------------------------
139 function Has_Decision
(N
: Node_Id
) return Boolean;
140 -- N is the node for a subexpression. Returns True if the subexpression
141 -- contains a nested decision (i.e. either is a logical operator, or
142 -- contains a logical operator in its subtree).
144 -- This must be used in the first pass (SCO_Record_Raw) only: here AND/OR
145 -- operators are considered as short circuit, just in case the
146 -- Short_Circuit_And_Or pragma is used: only real short circuit operations
147 -- will be kept in the secord pass.
149 type Tristate
is (False, True, Unknown
);
151 function Is_Logical_Operator
(N
: Node_Id
) return Tristate
;
152 -- N is the node for a subexpression. This procedure determines whether N
153 -- is a logical operator: True for short circuit conditions, Unknown for OR
154 -- and AND (the Short_Circuit_And_Or pragma may be used) and False
155 -- otherwise. Note that in cases where True is returned, callers assume
156 -- Nkind (N) in N_Op.
158 function To_Source_Location
(S
: Source_Ptr
) return Source_Location
;
159 -- Converts Source_Ptr value to Source_Location (line/col) format
161 procedure Process_Decisions
164 Pragma_Sloc
: Source_Ptr
);
165 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
166 -- to output any decisions it contains. T is one of IEGPWX (for context of
167 -- expression: if/exit when/entry guard/pragma/while/expression). If T is
168 -- other than X, the node N is the if expression involved, and a decision
169 -- is always present (at the very least a simple decision is present at the
172 procedure Process_Decisions
175 Pragma_Sloc
: Source_Ptr
);
176 -- Calls above procedure for each element of the list L
178 procedure Set_Raw_Table_Entry
184 Pragma_Sloc
: Source_Ptr
:= No_Location
;
185 Pragma_Aspect_Name
: Name_Id
:= No_Name
);
186 -- Append an entry to SCO_Raw_Table with fields set as per arguments
188 type Dominant_Info
is record
190 -- F/T/S/E for a valid dominance marker, or ' ' for no dominant
193 -- Node providing the Sloc(s) for the dominance marker
195 No_Dominant
: constant Dominant_Info
:= (' ', Empty
);
197 procedure Record_Instance
(Id
: Instance_Id
; Inst_Sloc
: Source_Ptr
);
198 -- Add one entry from the instance table to the corresponding SCO table
200 procedure Traverse_Declarations_Or_Statements
202 D
: Dominant_Info
:= No_Dominant
;
203 P
: Node_Id
:= Empty
);
204 -- Process L, a list of statements or declarations dominated by D. If P is
205 -- present, it is processed as though it had been prepended to L.
207 function Traverse_Declarations_Or_Statements
209 D
: Dominant_Info
:= No_Dominant
;
210 P
: Node_Id
:= Empty
) return Dominant_Info
;
211 -- Same as above, and returns dominant information corresponding to the
212 -- last node with SCO in L.
214 -- The following Traverse_* routines perform appropriate calls to
215 -- Traverse_Declarations_Or_Statements to traverse specific node kinds.
216 -- Parameter D, when present, indicates the dominant of the first
217 -- declaration or statement within N.
219 procedure Traverse_Generic_Package_Declaration
(N
: Node_Id
);
221 procedure Traverse_Handled_Statement_Sequence
223 D
: Dominant_Info
:= No_Dominant
);
225 procedure Traverse_Package_Body
(N
: Node_Id
);
227 procedure Traverse_Package_Declaration
229 D
: Dominant_Info
:= No_Dominant
);
231 procedure Traverse_Subprogram_Or_Task_Body
233 D
: Dominant_Info
:= No_Dominant
);
235 procedure Traverse_Protected_Or_Task_Definition
(N
: Node_Id
);
237 -- Note regarding traversals: In a few cases where an Alternatives list is
238 -- involved, pragmas such as "pragma Page" may show up before the first
239 -- alternative. We skip them because we're out of statement or declaration
240 -- context, so these can't be pragmas of interest for SCO purposes, and
241 -- the regular alternative processing typically involves attribute queries
242 -- which aren't valid for a pragma.
244 procedure Write_SCOs_To_ALI_File
is new Put_SCOs
;
245 -- Write SCO information to the ALI file using routines in Lib.Util
252 procedure Dump_Entry
(Index
: Nat
; T
: SCO_Table_Entry
);
253 -- Dump a SCO table entry
259 procedure Dump_Entry
(Index
: Nat
; T
: SCO_Table_Entry
) is
266 Write_Str
(" C1 = '");
272 Write_Str
(" C2 = '");
277 if T
.From
/= No_Source_Location
then
278 Write_Str
(" From = ");
279 Write_Int
(Int
(T
.From
.Line
));
281 Write_Int
(Int
(T
.From
.Col
));
284 if T
.To
/= No_Source_Location
then
285 Write_Str
(" To = ");
286 Write_Int
(Int
(T
.To
.Line
));
288 Write_Int
(Int
(T
.To
.Col
));
294 Write_Str
(" False");
300 -- Start of processing for dsco
303 -- Dump SCO unit table
305 Write_Line
("SCO Unit Table");
306 Write_Line
("--------------");
308 for Index
in 1 .. SCO_Unit_Table
.Last
loop
310 UTE
: SCO_Unit_Table_Entry
renames SCO_Unit_Table
.Table
(Index
);
314 Write_Int
(Int
(Index
));
315 Write_Str
(" Dep_Num = ");
316 Write_Int
(Int
(UTE
.Dep_Num
));
317 Write_Str
(" From = ");
318 Write_Int
(Int
(UTE
.From
));
319 Write_Str
(" To = ");
320 Write_Int
(Int
(UTE
.To
));
322 Write_Str
(" File_Name = """);
324 if UTE
.File_Name
/= null then
325 Write_Str
(UTE
.File_Name
.all);
333 -- Dump SCO Unit number table if it contains any entries
335 if SCO_Unit_Number_Table
.Last
>= 1 then
337 Write_Line
("SCO Unit Number Table");
338 Write_Line
("---------------------");
340 for Index
in 1 .. SCO_Unit_Number_Table
.Last
loop
342 Write_Int
(Int
(Index
));
343 Write_Str
(". Unit_Number = ");
344 Write_Int
(Int
(SCO_Unit_Number_Table
.Table
(Index
)));
349 -- Dump SCO raw-table
352 Write_Line
("SCO Raw Table");
353 Write_Line
("---------");
355 if SCO_Generation_State
= Filtered
then
356 Write_Line
("Empty (free'd after second pass)");
358 for Index
in 1 .. SCO_Raw_Table
.Last
loop
359 Dump_Entry
(Index
, SCO_Raw_Table
.Table
(Index
));
363 -- Dump SCO table itself
366 Write_Line
("SCO Filtered Table");
367 Write_Line
("---------");
369 for Index
in 1 .. SCO_Table
.Last
loop
370 Dump_Entry
(Index
, SCO_Table
.Table
(Index
));
378 function Equal
(F1
: Source_Ptr
; F2
: Source_Ptr
) return Boolean is
387 function "<" (S1
: Source_Location
; S2
: Source_Location
) return Boolean is
389 return S1
.Line
< S2
.Line
390 or else (S1
.Line
= S2
.Line
and then S1
.Col
< S2
.Col
);
397 function Has_Decision
(N
: Node_Id
) return Boolean is
398 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
399 -- Determine if Nkind (N) indicates the presence of a decision (i.e. N
400 -- is a logical operator, which is a decision in itself, or an
401 -- IF-expression whose Condition attribute is a decision, or a
402 -- quantified expression, whose predicate is a decision).
408 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
410 -- If we are not sure this is a logical operator (AND and OR may be
411 -- turned into logical operators with the Short_Circuit_And_Or
412 -- pragma), assume it is. Putative decisions will be discarded if
413 -- needed in the second pass.
415 if Is_Logical_Operator
(N
) /= False
416 or else Nkind
(N
) = N_If_Expression
417 or else Nkind
(N
) = N_Quantified_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
(N
) in N_And_Then | N_Op_Not | N_Or_Else
then
464 elsif Nkind
(N
) in 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
)
486 while Present
(N
) loop
487 Process_Decisions
(N
, T
, Pragma_Sloc
);
490 end Process_Decisions
;
492 -- Version taking a node
494 Current_Pragma_Sloc
: Source_Ptr
:= No_Location
;
495 -- While processing a pragma, this is set to the sloc of the N_Pragma node
497 procedure Process_Decisions
500 Pragma_Sloc
: Source_Ptr
)
503 -- This is used to mark the location of a decision sequence in the SCO
504 -- table. We use it for backing out a simple decision in an expression
505 -- context that contains only NOT operators.
508 -- Likewise for the putative SCO_Raw_Hash_Table entries: see below
510 type Hash_Entry
is record
514 -- We must register all conditions/pragmas in SCO_Raw_Hash_Table.
515 -- However we cannot register them in the same time we are adding the
516 -- corresponding SCO entries to the raw table since we may discard them
517 -- later on. So instead we put all putative conditions into Hash_Entries
518 -- (see below) and register them once we are sure we keep them.
520 -- This data structure holds the conditions/pragmas to register in
521 -- SCO_Raw_Hash_Table.
523 package Hash_Entries
is new Table
.Table
524 (Table_Component_Type
=> Hash_Entry
,
525 Table_Index_Type
=> Nat
,
526 Table_Low_Bound
=> 1,
528 Table_Increment
=> 10,
529 Table_Name
=> "Hash_Entries");
530 -- Hold temporarily (i.e. free'd before returning) the Hash_Entry before
531 -- they are registered in SCO_Raw_Hash_Table.
533 X_Not_Decision
: Boolean;
534 -- This flag keeps track of whether a decision sequence in the SCO table
535 -- contains only NOT operators, and is for an expression context (T=X).
536 -- The flag will be set False if T is other than X, or if an operator
537 -- other than NOT is in the sequence.
539 procedure Output_Decision_Operand
(N
: Node_Id
);
540 -- The node N is the top level logical operator of a decision, or it is
541 -- one of the operands of a logical operator belonging to a single
542 -- complex decision. This routine outputs the sequence of table entries
543 -- corresponding to the node. Note that we do not process the sub-
544 -- operands to look for further decisions, that processing is done in
545 -- Process_Decision_Operand, because we can't get decisions mixed up in
546 -- the global table. Call has no effect if N is Empty.
548 procedure Output_Element
(N
: Node_Id
);
549 -- Node N is an operand of a logical operator that is not itself a
550 -- logical operator, or it is a simple decision. This routine outputs
551 -- the table entry for the element, with C1 set to ' '. Last is set
552 -- False, and an entry is made in the condition hash table.
554 procedure Output_Header
(T
: Character);
555 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
556 -- PRAGMA, and 'X' for the expression case.
558 procedure Process_Decision_Operand
(N
: Node_Id
);
559 -- This is called on node N, the top level node of a decision, or on one
560 -- of its operands or suboperands after generating the full output for
561 -- the complex decision. It process the suboperands of the decision
562 -- looking for nested decisions.
564 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
565 -- Processes one node in the traversal, looking for logical operators,
566 -- and if one is found, outputs the appropriate table entries.
568 -----------------------------
569 -- Output_Decision_Operand --
570 -----------------------------
572 procedure Output_Decision_Operand
(N
: Node_Id
) is
575 -- C1 holds a character that identifies the operation while C2
576 -- indicates whether we are sure (' ') or not ('?') this operation
577 -- belongs to the decision. '?' entries will be filtered out in the
578 -- second (SCO_Record_Filtered) pass.
588 T
:= Is_Logical_Operator
(N
);
593 if Nkind
(N
) = N_Op_Not
then
600 if Nkind
(N
) in N_Op_Or | N_Or_Else
then
602 else pragma Assert
(Nkind
(N
) in N_Op_And | N_And_Then
);
620 Hash_Entries
.Append
((Sloc
(N
), SCO_Raw_Table
.Last
));
622 Output_Decision_Operand
(L
);
623 Output_Decision_Operand
(Right_Opnd
(N
));
625 -- Not a logical operator
630 end Output_Decision_Operand
;
636 procedure Output_Element
(N
: Node_Id
) is
640 Sloc_Range
(N
, FSloc
, LSloc
);
647 Hash_Entries
.Append
((FSloc
, SCO_Raw_Table
.Last
));
654 procedure Output_Header
(T
: Character) is
655 Loc
: Source_Ptr
:= No_Location
;
656 -- Node whose Sloc is used for the decision
658 Nam
: Name_Id
:= No_Name
;
659 -- For the case of an aspect, aspect name
663 when 'I' |
'E' |
'W' |
'a' |
'A' =>
665 -- For IF, EXIT, WHILE, or aspects, the token SLOC is that of
666 -- the parent of the expression.
668 Loc
:= Sloc
(Parent
(N
));
670 if T
= 'a' or else T
= 'A' then
671 Nam
:= Chars
(Identifier
(Parent
(N
)));
676 -- For entry guard, the token sloc is from the N_Entry_Body.
677 -- For PRAGMA, we must get the location from the pragma node.
678 -- Argument N is the pragma argument, and we have to go up
679 -- two levels (through the pragma argument association) to
680 -- get to the pragma node itself. For the guard on a select
681 -- alternative, we do not have access to the token location for
682 -- the WHEN, so we use the first sloc of the condition itself.
683 -- First_Sloc gives the most sensible result, but we have to
684 -- beware of also using it when computing the dominance marker
685 -- sloc (in the Set_Statement_Entry procedure), as this is not
686 -- fully equivalent to the "To" sloc computed by
687 -- Sloc_Range (Guard, To, From).
689 if Nkind
(Parent
(N
)) in N_Accept_Alternative
690 | N_Delay_Alternative
691 | N_Terminate_Alternative
693 Loc
:= First_Sloc
(N
);
695 Loc
:= Sloc
(Parent
(Parent
(N
)));
700 -- For an expression, no Sloc
704 -- No other possibilities
716 Pragma_Sloc
=> Pragma_Sloc
,
717 Pragma_Aspect_Name
=> Nam
);
719 -- For an aspect specification, which will be rewritten into a
720 -- pragma, enter a hash table entry now.
723 Hash_Entries
.Append
((Loc
, SCO_Raw_Table
.Last
));
727 ------------------------------
728 -- Process_Decision_Operand --
729 ------------------------------
731 procedure Process_Decision_Operand
(N
: Node_Id
) is
733 if Is_Logical_Operator
(N
) /= False then
734 if Nkind
(N
) /= N_Op_Not
then
735 Process_Decision_Operand
(Left_Opnd
(N
));
736 X_Not_Decision
:= False;
739 Process_Decision_Operand
(Right_Opnd
(N
));
742 Process_Decisions
(N
, 'X', Pragma_Sloc
);
744 end Process_Decision_Operand
;
750 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
754 -- Aspect specifications have dedicated processings (see
755 -- Traverse_Aspects) so ignore them here, so that they are
756 -- processed only once.
758 when N_Aspect_Specification
=>
761 -- Logical operators, output table entries and then process
762 -- operands recursively to deal with nested conditions.
774 -- If outer level, then type comes from call, otherwise it
775 -- is more deeply nested and counts as X for expression.
777 if N
= Process_Decisions
.N
then
778 T
:= Process_Decisions
.T
;
783 -- Output header for sequence
785 X_Not_Decision
:= T
= 'X' and then Nkind
(N
) = N_Op_Not
;
786 Mark
:= SCO_Raw_Table
.Last
;
787 Mark_Hash
:= Hash_Entries
.Last
;
790 -- Output the decision
792 Output_Decision_Operand
(N
);
794 -- If the decision was in an expression context (T = 'X')
795 -- and contained only NOT operators, then we don't output
798 if X_Not_Decision
then
799 SCO_Raw_Table
.Set_Last
(Mark
);
800 Hash_Entries
.Set_Last
(Mark_Hash
);
802 -- Otherwise, set Last in last table entry to mark end
805 SCO_Raw_Table
.Table
(SCO_Raw_Table
.Last
).Last
:= True;
808 -- Process any embedded decisions
810 Process_Decision_Operand
(N
);
816 -- Really hard to believe this is correct given the special
817 -- handling for if expressions below ???
819 when N_Case_Expression
=>
822 -- If expression, processed like an if statement
824 when N_If_Expression
=>
826 Cond
: constant Node_Id
:= First
(Expressions
(N
));
827 Thnx
: constant Node_Id
:= Next
(Cond
);
828 Elsx
: constant Node_Id
:= Next
(Thnx
);
831 Process_Decisions
(Cond
, 'I', Pragma_Sloc
);
832 Process_Decisions
(Thnx
, 'X', Pragma_Sloc
);
833 Process_Decisions
(Elsx
, 'X', Pragma_Sloc
);
837 when N_Quantified_Expression
=>
839 Cond
: constant Node_Id
:= Condition
(N
);
840 I_Spec
: Node_Id
:= Empty
;
842 if Present
(Iterator_Specification
(N
)) then
843 I_Spec
:= Iterator_Specification
(N
);
845 I_Spec
:= Loop_Parameter_Specification
(N
);
847 Process_Decisions
(I_Spec
, 'X', Pragma_Sloc
);
848 Process_Decisions
(Cond
, 'W', Pragma_Sloc
);
852 -- All other cases, continue scan
859 procedure Traverse
is new Traverse_Proc
(Process_Node
);
861 -- Start of processing for Process_Decisions
870 -- See if we have simple decision at outer level and if so then
871 -- generate the decision entry for this simple decision. A simple
872 -- decision is a boolean expression (which is not a logical operator
873 -- or short circuit form) appearing as the operand of an IF, WHILE,
874 -- EXIT WHEN, or special PRAGMA construct.
876 if T
/= 'X' and then Is_Logical_Operator
(N
) = False then
880 -- Change Last in last table entry to True to mark end of
881 -- sequence, which is this case is only one element long.
883 SCO_Raw_Table
.Table
(SCO_Raw_Table
.Last
).Last
:= True;
888 -- Now we have the definitive set of SCO entries, register them in the
889 -- corresponding hash table.
891 for J
in 1 .. Hash_Entries
.Last
loop
892 SCO_Raw_Hash_Table
.Set
893 (Hash_Entries
.Table
(J
).Sloc
,
894 Hash_Entries
.Table
(J
).SCO_Index
);
898 end Process_Decisions
;
905 procedure Write_Info_Char
(C
: Character) renames Write_Char
;
906 -- Write one character;
908 procedure Write_Info_Initiate
(Key
: Character) renames Write_Char
;
909 -- Start new one and write one character;
911 procedure Write_Info_Nat
(N
: Nat
);
914 procedure Write_Info_Terminate
renames Write_Eol
;
915 -- Terminate current line
921 procedure Write_Info_Nat
(N
: Nat
) is
926 procedure Debug_Put_SCOs
is new Put_SCOs
;
928 -- Start of processing for pscos
934 ---------------------
935 -- Record_Instance --
936 ---------------------
938 procedure Record_Instance
(Id
: Instance_Id
; Inst_Sloc
: Source_Ptr
) is
939 Inst_Src
: constant Source_File_Index
:=
940 Get_Source_File_Index
(Inst_Sloc
);
942 SCO_Instance_Table
.Append
943 ((Inst_Dep_Num
=> Dependency_Num
(Unit
(Inst_Src
)),
944 Inst_Loc
=> To_Source_Location
(Inst_Sloc
),
945 Enclosing_Instance
=> SCO_Instance_Index
(Instance
(Inst_Src
))));
948 (SCO_Instance_Table
.Last
= SCO_Instance_Index
(Id
));
955 procedure SCO_Output
is
956 procedure Populate_SCO_Instance_Table
is
957 new Sinput
.Iterate_On_Instances
(Record_Instance
);
960 pragma Assert
(SCO_Generation_State
= Filtered
);
962 if Debug_Flag_Dot_OO
then
966 Populate_SCO_Instance_Table
;
968 -- Sort the unit tables based on dependency numbers
970 Unit_Table_Sort
: declare
971 function Lt
(Op1
: Natural; Op2
: Natural) return Boolean;
972 -- Comparison routine for sort call
974 procedure Move
(From
: Natural; To
: Natural);
975 -- Move routine for sort call
981 function Lt
(Op1
: Natural; Op2
: Natural) return Boolean is
985 (SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(Op1
)))
988 (SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(Op2
)));
995 procedure Move
(From
: Natural; To
: Natural) is
997 SCO_Unit_Table
.Table
(SCO_Unit_Index
(To
)) :=
998 SCO_Unit_Table
.Table
(SCO_Unit_Index
(From
));
999 SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(To
)) :=
1000 SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(From
));
1003 package Sorting
is new GNAT
.Heap_Sort_G
(Move
, Lt
);
1005 -- Start of processing for Unit_Table_Sort
1008 Sorting
.Sort
(Integer (SCO_Unit_Table
.Last
));
1009 end Unit_Table_Sort
;
1011 -- Loop through entries in the unit table to set file name and
1012 -- dependency number entries.
1014 for J
in 1 .. SCO_Unit_Table
.Last
loop
1016 U
: constant Unit_Number_Type
:= SCO_Unit_Number_Table
.Table
(J
);
1017 UTE
: SCO_Unit_Table_Entry
renames SCO_Unit_Table
.Table
(J
);
1020 Get_Name_String
(Reference_Name
(Source_Index
(U
)));
1021 UTE
.File_Name
:= new String'(Name_Buffer (1 .. Name_Len));
1022 UTE.Dep_Num := Dependency_Num (U);
1026 -- Now the tables are all setup for output to the ALI file
1028 Write_SCOs_To_ALI_File;
1031 -------------------------
1032 -- SCO_Pragma_Disabled --
1033 -------------------------
1035 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
1039 if Loc = No_Location then
1043 Index := SCO_Raw_Hash_Table.Get (Loc);
1045 -- The test here for zero is to deal with possible previous errors, and
1046 -- for the case of pragma statement SCOs, for which we always set the
1047 -- Pragma_Sloc even if the particular pragma cannot be specifically
1052 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
1062 -- Aspect decision (enabled)
1067 -- Aspect decision (not enabled)
1072 -- Nullified disabled SCO
1077 raise Program_Error;
1084 end SCO_Pragma_Disabled;
1086 --------------------
1087 -- SCO_Record_Raw --
1088 --------------------
1090 procedure SCO_Record_Raw (U : Unit_Number_Type) is
1091 procedure Traverse_Aux_Decls (N : Node_Id);
1092 -- Traverse the Aux_Decls_Node of compilation unit N
1094 ------------------------
1095 -- Traverse_Aux_Decls --
1096 ------------------------
1098 procedure Traverse_Aux_Decls (N : Node_Id) is
1099 ADN : constant Node_Id := Aux_Decls_Node (N);
1102 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
1103 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
1105 -- Declarations and Actions do not correspond to source constructs,
1106 -- they contain only nodes from expansion, so at this point they
1107 -- should still be empty:
1109 pragma Assert (No (Declarations (ADN)));
1110 pragma Assert (No (Actions (ADN)));
1111 end Traverse_Aux_Decls;
1118 -- Start of processing for SCO_Record_Raw
1121 -- It is legitimate to run this pass multiple times (once per unit) so
1122 -- run it even if it was already run before.
1124 pragma Assert (SCO_Generation_State in None .. Raw);
1125 SCO_Generation_State := Raw;
1127 -- Ignore call if not generating code and generating SCO's
1129 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
1133 -- Ignore call if this unit already recorded
1135 for J in 1 .. SCO_Unit_Number_Table.Last loop
1136 if U = SCO_Unit_Number_Table.Table (J) then
1141 -- Otherwise record starting entry
1143 From := SCO_Raw_Table.Last + 1;
1145 -- Get Unit (checking case of subunit)
1147 Lu := Unit (Cunit (U));
1149 if Nkind (Lu) = N_Subunit then
1150 Lu := Proper_Body (Lu);
1153 -- Traverse the unit
1155 Traverse_Aux_Decls (Cunit (U));
1158 when N_Generic_Instantiation
1159 | N_Generic_Package_Declaration
1161 | N_Package_Declaration
1164 | N_Subprogram_Declaration
1167 Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
1169 -- All other cases of compilation units (e.g. renamings), generate no
1176 -- Make entry for new unit in unit tables, we will fill in the file
1177 -- name and dependency numbers later.
1179 SCO_Unit_Table.Append (
1182 File_Index => Get_Source_File_Index (Sloc (Lu)),
1184 To => SCO_Raw_Table.Last));
1186 SCO_Unit_Number_Table.Append (U);
1189 -----------------------
1190 -- Set_SCO_Condition --
1191 -----------------------
1193 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
1195 -- SCO annotations are not processed after the filtering pass
1197 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1199 Constant_Condition_Code : constant array (Boolean) of Character :=
1200 (False => 'f
', True => 't
');
1202 Orig : constant Node_Id := Original_Node (Cond);
1208 Sloc_Range (Orig, Start, Dummy);
1209 Index := SCO_Raw_Hash_Table.Get (Start);
1211 -- Index can be zero for boolean expressions that do not have SCOs
1212 -- (simple decisions outside of a control flow structure), or in case
1213 -- of a previous error.
1219 pragma Assert (SCO_Raw_Table.Table (Index).C1 = ' ');
1220 SCO_Raw_Table.Table (Index).C2 := Constant_Condition_Code (Val);
1222 end Set_SCO_Condition;
1224 ------------------------------
1225 -- Set_SCO_Logical_Operator --
1226 ------------------------------
1228 procedure Set_SCO_Logical_Operator (Op : Node_Id) is
1230 -- SCO annotations are not processed after the filtering pass
1232 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1234 Orig : constant Node_Id := Original_Node (Op);
1235 Orig_Sloc : constant Source_Ptr := Sloc (Orig);
1236 Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
1239 -- All (putative) logical operators are supposed to have their own entry
1240 -- in the SCOs table. However, the semantic analysis may invoke this
1241 -- subprogram with nodes that are out of the SCO generation scope.
1244 SCO_Raw_Table.Table (Index).C2 := ' ';
1246 end Set_SCO_Logical_Operator;
1248 ----------------------------
1249 -- Set_SCO_Pragma_Enabled --
1250 ----------------------------
1252 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
1254 -- SCO annotations are not processed after the filtering pass
1256 pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
1261 -- Nothing to do if not generating SCO, or if we're not processing the
1262 -- original source occurrence of the pragma.
1264 if not (Generate_SCO
1265 and then In_Extended_Main_Source_Unit (Loc)
1266 and then not (In_Instance or In_Inlined_Body))
1271 -- Note: the reason we use the Sloc value as the key is that in the
1272 -- generic case, the call to this procedure is made on a copy of the
1273 -- original node, so we can't use the Node_Id value.
1275 Index := SCO_Raw_Hash_Table.Get (Loc);
1277 -- A zero index here indicates that semantic analysis found an
1278 -- activated pragma at Loc which does not have a corresponding pragma
1279 -- or aspect at the syntax level. This may occur in legitimate cases
1280 -- because of expanded code (such are Pre/Post conditions generated for
1281 -- formal parameter validity checks), or as a consequence of a previous
1289 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
1292 -- Note: may be called multiple times for the same sloc, so
1293 -- account for the fact that the entry may already have been
1297 -- Aspect (decision SCO)
1305 -- Pragma (statement SCO)
1308 pragma Assert (T.C2 = 'p
' or else T.C2 = 'P
');
1312 raise Program_Error;
1316 end Set_SCO_Pragma_Enabled;
1318 -------------------------
1319 -- Set_Raw_Table_Entry --
1320 -------------------------
1322 procedure Set_Raw_Table_Entry
1328 Pragma_Sloc : Source_Ptr := No_Location;
1329 Pragma_Aspect_Name : Name_Id := No_Name)
1331 pragma Assert (SCO_Generation_State = Raw);
1333 SCO_Raw_Table.Append
1336 From => To_Source_Location (From),
1337 To => To_Source_Location (To),
1339 Pragma_Sloc => Pragma_Sloc,
1340 Pragma_Aspect_Name => Pragma_Aspect_Name));
1341 end Set_Raw_Table_Entry;
1343 ------------------------
1344 -- To_Source_Location --
1345 ------------------------
1347 function To_Source_Location (S : Source_Ptr) return Source_Location is
1349 if S = No_Location then
1350 return No_Source_Location;
1353 (Line => Get_Logical_Line_Number (S),
1354 Col => Get_Column_Number (S));
1356 end To_Source_Location;
1358 -----------------------------------------
1359 -- Traverse_Declarations_Or_Statements --
1360 -----------------------------------------
1362 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
1363 -- holding statement and decision entries. These are declared globally
1364 -- since they are shared by recursive calls to this procedure.
1366 type SC_Entry is record
1372 -- Used to store a single entry in the following table, From:To represents
1373 -- the range of entries in the CS line entry, and typ is the type, with
1374 -- space meaning that no type letter will accompany the entry.
1376 package SC is new Table.Table
1377 (Table_Component_Type => SC_Entry,
1378 Table_Index_Type => Nat,
1379 Table_Low_Bound => 1,
1380 Table_Initial => 1000,
1381 Table_Increment => 200,
1382 Table_Name => "SCO_SC");
1383 -- Used to store statement components for a CS entry to be output as a
1384 -- result of the call to this procedure. SC.Last is the last entry stored,
1385 -- so the current statement sequence is represented by SC_Array (SC_First
1386 -- .. SC.Last), where SC_First is saved on entry to each recursive call to
1389 -- Extend_Statement_Sequence adds an entry to this array, and then
1390 -- Set_Statement_Entry clears the entries starting with SC_First, copying
1391 -- these entries to the main SCO output table. The reason that we do the
1392 -- temporary caching of results in this array is that we want the SCO table
1393 -- entries for a given CS line to be contiguous, and the processing may
1394 -- output intermediate entries such as decision entries.
1396 type SD_Entry is record
1402 -- Used to store a single entry in the following table. Nod is the node to
1403 -- be searched for decisions for the case of Process_Decisions_Defer with a
1404 -- node argument (with Lst set to No_List. Lst is the list to be searched
1405 -- for decisions for the case of Process_Decisions_Defer with a List
1406 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
1407 -- enclosing pragma, if any.
1409 package SD is new Table.Table
1410 (Table_Component_Type => SD_Entry,
1411 Table_Index_Type => Nat,
1412 Table_Low_Bound => 1,
1413 Table_Initial => 1000,
1414 Table_Increment => 200,
1415 Table_Name => "SCO_SD");
1416 -- Used to store possible decision information. Instead of calling the
1417 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
1418 -- which simply stores the arguments in this table. Then when we clear
1419 -- out a statement sequence using Set_Statement_Entry, after generating
1420 -- the CS lines for the statements, the entries in this table result in
1421 -- calls to Process_Decision. The reason for doing things this way is to
1422 -- ensure that decisions are output after the CS line for the statements
1423 -- in which the decisions occur.
1425 procedure Traverse_Declarations_Or_Statements
1427 D : Dominant_Info := No_Dominant;
1428 P : Node_Id := Empty)
1430 Discard_Dom : Dominant_Info;
1431 pragma Warnings (Off, Discard_Dom);
1433 Discard_Dom := Traverse_Declarations_Or_Statements (L, D, P);
1434 end Traverse_Declarations_Or_Statements;
1436 function Traverse_Declarations_Or_Statements
1438 D : Dominant_Info := No_Dominant;
1439 P : Node_Id := Empty) return Dominant_Info
1441 Current_Dominant : Dominant_Info := D;
1442 -- Dominance information for the current basic block
1444 Current_Test : Node_Id;
1445 -- Conditional node (N_If_Statement or N_Elsif being processed)
1449 SC_First : constant Nat := SC.Last + 1;
1450 SD_First : constant Nat := SD.Last + 1;
1451 -- Record first entries used in SC/SD at this recursive level
1453 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1454 -- Extend the current statement sequence to encompass the node N. Typ is
1455 -- the letter that identifies the type of statement/declaration that is
1456 -- being added to the sequence.
1458 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1459 pragma Inline (Process_Decisions_Defer);
1460 -- This routine is logically the same as Process_Decisions, except that
1461 -- the arguments are saved in the SD table for later processing when
1462 -- Set_Statement_Entry is called, which goes through the saved entries
1463 -- making the corresponding calls to Process_Decision. Note: the
1464 -- enclosing statement must have already been added to the current
1465 -- statement sequence, so that nested decisions are properly
1466 -- identified as such.
1468 procedure Process_Decisions_Defer (L : List_Id; T : Character);
1469 pragma Inline (Process_Decisions_Defer);
1470 -- Same case for list arguments, deferred call to Process_Decisions
1472 procedure Set_Statement_Entry;
1473 -- Output CS entries for all statements saved in table SC, and end the
1474 -- current CS sequence. Then output entries for all decisions nested in
1475 -- these statements, which have been deferred so far.
1477 procedure Traverse_One (N : Node_Id);
1478 -- Traverse one declaration or statement
1480 procedure Traverse_Aspects (N : Node_Id);
1481 -- Helper for Traverse_One: traverse N's aspect specifications
1483 procedure Traverse_Degenerate_Subprogram (N : Node_Id);
1484 -- Common code to handle null procedures and expression functions. Emit
1485 -- a SCO of the given Kind and N outside of the dominance flow.
1487 -------------------------------
1488 -- Extend_Statement_Sequence --
1489 -------------------------------
1491 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1495 To_Node : Node_Id := Empty;
1498 Sloc_Range (N, F, T);
1501 when N_Accept_Statement =>
1502 if Present (Parameter_Specifications (N)) then
1503 To_Node := Last (Parameter_Specifications (N));
1504 elsif Present (Entry_Index (N)) then
1505 To_Node := Entry_Index (N);
1507 To_Node := Entry_Direct_Name (N);
1510 when N_Case_Statement =>
1511 To_Node := Expression (N);
1516 To_Node := Condition (N);
1518 when N_Extended_Return_Statement =>
1519 To_Node := Last (Return_Object_Declarations (N));
1521 when N_Loop_Statement =>
1522 To_Node := Iteration_Scheme (N);
1524 when N_Asynchronous_Select
1525 | N_Conditional_Entry_Call
1526 | N_Selective_Accept
1527 | N_Single_Protected_Declaration
1528 | N_Single_Task_Declaration
1529 | N_Timed_Entry_Call
1533 when N_Protected_Type_Declaration
1534 | N_Task_Type_Declaration
1536 if Has_Aspects (N) then
1537 To_Node := Last (Aspect_Specifications (N));
1539 elsif Present (Discriminant_Specifications (N)) then
1540 To_Node := Last (Discriminant_Specifications (N));
1543 To_Node := Defining_Identifier (N);
1553 if Present (To_Node) then
1554 Sloc_Range (To_Node, Dummy, T);
1557 SC.Append ((N, F, T, Typ));
1558 end Extend_Statement_Sequence;
1560 -----------------------------
1561 -- Process_Decisions_Defer --
1562 -----------------------------
1564 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1566 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1567 end Process_Decisions_Defer;
1569 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1571 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1572 end Process_Decisions_Defer;
1574 -------------------------
1575 -- Set_Statement_Entry --
1576 -------------------------
1578 procedure Set_Statement_Entry is
1579 SC_Last : constant Int := SC.Last;
1580 SD_Last : constant Int := SD.Last;
1583 -- Output statement entries from saved entries in SC table
1585 for J in SC_First .. SC_Last loop
1586 if J = SC_First then
1588 if Current_Dominant /= No_Dominant then
1594 Sloc_Range (Current_Dominant.N, From, To);
1596 if Current_Dominant.K /= 'E
' then
1600 -- Be consistent with the location determined in
1603 if Current_Dominant.K = 'T
'
1604 and then Nkind (Parent (Current_Dominant.N))
1605 in N_Accept_Alternative
1606 | N_Delay_Alternative
1607 | N_Terminate_Alternative
1609 From := First_Sloc (Current_Dominant.N);
1614 C2 => Current_Dominant.K,
1618 Pragma_Sloc => No_Location,
1619 Pragma_Aspect_Name => No_Name);
1625 SCE : SC_Entry renames SC.Table (J);
1626 Pragma_Sloc : Source_Ptr := No_Location;
1627 Pragma_Aspect_Name : Name_Id := No_Name;
1630 -- For the case of a statement SCO for a pragma controlled by
1631 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1632 -- those of any nested decision) is emitted only if the pragma
1635 if SCE.Typ = 'p
' then
1636 Pragma_Sloc := SCE.From;
1637 SCO_Raw_Hash_Table.Set
1638 (Pragma_Sloc, SCO_Raw_Table.Last + 1);
1639 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
1640 pragma Assert (Pragma_Aspect_Name /= No_Name);
1642 elsif SCE.Typ = 'P
' then
1643 Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
1644 pragma Assert (Pragma_Aspect_Name /= No_Name);
1652 Last => (J = SC_Last),
1653 Pragma_Sloc => Pragma_Sloc,
1654 Pragma_Aspect_Name => Pragma_Aspect_Name);
1658 -- Last statement of basic block, if present, becomes new current
1661 if SC_Last >= SC_First then
1662 Current_Dominant := ('S
', SC.Table (SC_Last).N);
1665 -- Clear out used section of SC table
1667 SC.Set_Last (SC_First - 1);
1669 -- Output any embedded decisions
1671 for J in SD_First .. SD_Last loop
1673 SDE : SD_Entry renames SD.Table (J);
1676 if Present (SDE.Nod) then
1677 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1679 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1684 -- Clear out used section of SD table
1686 SD.Set_Last (SD_First - 1);
1687 end Set_Statement_Entry;
1689 ----------------------
1690 -- Traverse_Aspects --
1691 ----------------------
1693 procedure Traverse_Aspects (N : Node_Id) is
1699 AN := First (Aspect_Specifications (N));
1700 while Present (AN) loop
1701 AE := Expression (AN);
1705 case Get_Aspect_Id (AN) is
1707 -- Aspects rewritten into pragmas controlled by a Check_Policy:
1708 -- Current_Pragma_Sloc must be set to the sloc of the aspect
1709 -- specification. The corresponding pragma will have the same
1710 -- sloc. Note that Invariant, Pre, and Post will be enabled if
1711 -- the policy is Check; on the other hand, predicate aspects
1712 -- will be enabled for Check and Ignore (when Add_Predicate
1713 -- is called) because the actual checks occur in client units.
1714 -- When the assertion policy for Predicate is Disable, the
1715 -- SCO remains disabled, because Add_Predicate is never called.
1717 -- Pre/post can have checks in client units too because of
1718 -- inheritance, so should they receive the same treatment???
1720 when Aspect_Dynamic_Predicate
1723 | Aspect_Postcondition
1725 | Aspect_Precondition
1727 | Aspect_Static_Predicate
1728 | Aspect_Type_Invariant
1732 -- Other aspects: just process any decision nested in the
1733 -- aspect expression.
1736 if Has_Decision (AE) then
1741 if C1 /= ASCII.NUL then
1742 pragma Assert (Current_Pragma_Sloc = No_Location);
1744 if C1 = 'a
' or else C1 = 'A
' then
1745 Current_Pragma_Sloc := Sloc (AN);
1748 Process_Decisions_Defer (AE, C1);
1750 Current_Pragma_Sloc := No_Location;
1755 end Traverse_Aspects;
1757 ------------------------------------
1758 -- Traverse_Degenerate_Subprogram --
1759 ------------------------------------
1761 procedure Traverse_Degenerate_Subprogram (N : Node_Id) is
1763 -- Complete current sequence of statements
1765 Set_Statement_Entry;
1768 Saved_Dominant : constant Dominant_Info := Current_Dominant;
1769 -- Save last statement in current sequence as dominant
1772 -- Output statement SCO for degenerate subprogram body (null
1773 -- statement or freestanding expression) outside of the dominance
1776 Current_Dominant := No_Dominant;
1777 Extend_Statement_Sequence (N, Typ => 'X
');
1779 -- For the case of an expression-function, collect decisions
1780 -- embedded in the expression now.
1782 if Nkind (N) in N_Subexpr then
1783 Process_Decisions_Defer (N, 'X
');
1786 Set_Statement_Entry;
1788 -- Restore current dominant information designating last statement
1789 -- in previous sequence (i.e. make the dominance chain skip over
1790 -- the degenerate body).
1792 Current_Dominant := Saved_Dominant;
1794 end Traverse_Degenerate_Subprogram;
1800 procedure Traverse_One (N : Node_Id) is
1802 -- Initialize or extend current statement sequence. Note that for
1803 -- special cases such as IF and Case statements we will modify
1804 -- the range to exclude internal statements that should not be
1805 -- counted as part of the current statement sequence.
1809 -- Package declaration
1811 when N_Package_Declaration =>
1812 Set_Statement_Entry;
1813 Traverse_Package_Declaration (N, Current_Dominant);
1815 -- Generic package declaration
1817 when N_Generic_Package_Declaration =>
1818 Set_Statement_Entry;
1819 Traverse_Generic_Package_Declaration (N);
1823 when N_Package_Body =>
1824 Set_Statement_Entry;
1825 Traverse_Package_Body (N);
1827 -- Subprogram declaration or subprogram body stub
1829 when N_Expression_Function
1830 | N_Subprogram_Body_Stub
1831 | N_Subprogram_Declaration
1834 Spec : constant Node_Id := Specification (N);
1836 Process_Decisions_Defer
1837 (Parameter_Specifications (Spec), 'X
');
1839 -- Case of a null procedure: generate SCO for fictitious
1840 -- NULL statement located at the NULL keyword in the
1841 -- procedure specification.
1843 if Nkind (N) = N_Subprogram_Declaration
1844 and then Nkind (Spec) = N_Procedure_Specification
1845 and then Null_Present (Spec)
1847 Traverse_Degenerate_Subprogram (Null_Statement (Spec));
1849 -- Case of an expression function: generate a statement SCO
1850 -- for the expression (and then decision SCOs for any nested
1853 elsif Nkind (N) = N_Expression_Function then
1854 Traverse_Degenerate_Subprogram (Expression (N));
1858 -- Entry declaration
1860 when N_Entry_Declaration =>
1861 Process_Decisions_Defer (Parameter_Specifications (N), 'X
');
1863 -- Generic subprogram declaration
1865 when N_Generic_Subprogram_Declaration =>
1866 Process_Decisions_Defer
1867 (Generic_Formal_Declarations (N), 'X
');
1868 Process_Decisions_Defer
1869 (Parameter_Specifications (Specification (N)), 'X
');
1871 -- Task or subprogram body
1873 when N_Subprogram_Body
1876 Set_Statement_Entry;
1877 Traverse_Subprogram_Or_Task_Body (N);
1881 when N_Entry_Body =>
1883 Cond : constant Node_Id :=
1884 Condition (Entry_Body_Formal_Part (N));
1886 Inner_Dominant : Dominant_Info := No_Dominant;
1889 Set_Statement_Entry;
1891 if Present (Cond) then
1892 Process_Decisions_Defer (Cond, 'G
');
1894 -- For an entry body with a barrier, the entry body
1895 -- is dominated by a True evaluation of the barrier.
1897 Inner_Dominant := ('T
', N);
1900 Traverse_Subprogram_Or_Task_Body (N, Inner_Dominant);
1905 when N_Protected_Body =>
1906 Set_Statement_Entry;
1907 Traverse_Declarations_Or_Statements (Declarations (N));
1909 -- Exit statement, which is an exit statement in the SCO sense,
1910 -- so it is included in the current statement sequence, but
1911 -- then it terminates this sequence. We also have to process
1912 -- any decisions in the exit statement expression.
1914 when N_Exit_Statement =>
1915 Extend_Statement_Sequence (N, 'E
');
1916 Process_Decisions_Defer (Condition (N), 'E
');
1917 Set_Statement_Entry;
1919 -- If condition is present, then following statement is
1920 -- only executed if the condition evaluates to False.
1922 if Present (Condition (N)) then
1923 Current_Dominant := ('F
', N);
1925 Current_Dominant := No_Dominant;
1928 -- Label, which breaks the current statement sequence, but the
1929 -- label itself is not included in the next statement sequence,
1930 -- since it generates no code.
1933 Set_Statement_Entry;
1934 Current_Dominant := No_Dominant;
1936 -- Block statement, which breaks the current statement sequence
1938 when N_Block_Statement =>
1939 Set_Statement_Entry;
1941 -- The first statement in the handled sequence of statements
1942 -- is dominated by the elaboration of the last declaration.
1944 Current_Dominant := Traverse_Declarations_Or_Statements
1945 (L => Declarations (N),
1946 D => Current_Dominant);
1948 Traverse_Handled_Statement_Sequence
1949 (N => Handled_Statement_Sequence (N),
1950 D => Current_Dominant);
1952 -- If statement, which breaks the current statement sequence,
1953 -- but we include the condition in the current sequence.
1955 when N_If_Statement =>
1957 Extend_Statement_Sequence (N, 'I
');
1958 Process_Decisions_Defer (Condition (N), 'I
');
1959 Set_Statement_Entry;
1961 -- Now we traverse the statements in the THEN part
1963 Traverse_Declarations_Or_Statements
1964 (L => Then_Statements (N),
1967 -- Loop through ELSIF parts if present
1969 if Present (Elsif_Parts (N)) then
1971 Saved_Dominant : constant Dominant_Info :=
1974 Elif : Node_Id := First (Elsif_Parts (N));
1977 while Present (Elif) loop
1979 -- An Elsif is executed only if the previous test
1980 -- got a FALSE outcome.
1982 Current_Dominant := ('F
', Current_Test);
1984 -- Now update current test information
1986 Current_Test := Elif;
1988 -- We generate a statement sequence for the
1989 -- construct "ELSIF condition", so that we have
1990 -- a statement for the resulting decisions.
1992 Extend_Statement_Sequence (Elif, 'I
');
1993 Process_Decisions_Defer (Condition (Elif), 'I
');
1994 Set_Statement_Entry;
1996 -- An ELSIF part is never guaranteed to have
1997 -- been executed, following statements are only
1998 -- dominated by the initial IF statement.
2000 Current_Dominant := Saved_Dominant;
2002 -- Traverse the statements in the ELSIF
2004 Traverse_Declarations_Or_Statements
2005 (L => Then_Statements (Elif),
2012 -- Finally traverse the ELSE statements if present
2014 Traverse_Declarations_Or_Statements
2015 (L => Else_Statements (N),
2016 D => ('F
', Current_Test));
2018 -- CASE statement, which breaks the current statement sequence,
2019 -- but we include the expression in the current sequence.
2021 when N_Case_Statement =>
2022 Extend_Statement_Sequence (N, 'C
');
2023 Process_Decisions_Defer (Expression (N), 'X
');
2024 Set_Statement_Entry;
2026 -- Process case branches, all of which are dominated by the
2032 Alt := First_Non_Pragma (Alternatives (N));
2033 while Present (Alt) loop
2034 Traverse_Declarations_Or_Statements
2035 (L => Statements (Alt),
2036 D => Current_Dominant);
2043 when N_Accept_Statement =>
2044 Extend_Statement_Sequence (N, 'A
');
2045 Set_Statement_Entry;
2047 -- Process sequence of statements, dominant is the ACCEPT
2050 Traverse_Handled_Statement_Sequence
2051 (N => Handled_Statement_Sequence (N),
2052 D => Current_Dominant);
2056 when N_Selective_Accept =>
2057 Extend_Statement_Sequence (N, 'S
');
2058 Set_Statement_Entry;
2060 -- Process alternatives
2065 S_Dom : Dominant_Info;
2068 Alt := First (Select_Alternatives (N));
2069 while Present (Alt) loop
2070 S_Dom := Current_Dominant;
2071 Guard := Condition (Alt);
2073 if Present (Guard) then
2077 Pragma_Sloc => No_Location);
2078 Current_Dominant := ('T
', Guard);
2083 Current_Dominant := S_Dom;
2088 Traverse_Declarations_Or_Statements
2089 (L => Else_Statements (N),
2090 D => Current_Dominant);
2092 when N_Conditional_Entry_Call
2093 | N_Timed_Entry_Call
2095 Extend_Statement_Sequence (N, 'S
');
2096 Set_Statement_Entry;
2098 -- Process alternatives
2100 Traverse_One (Entry_Call_Alternative (N));
2102 if Nkind (N) = N_Timed_Entry_Call then
2103 Traverse_One (Delay_Alternative (N));
2105 Traverse_Declarations_Or_Statements
2106 (L => Else_Statements (N),
2107 D => Current_Dominant);
2110 when N_Asynchronous_Select =>
2111 Extend_Statement_Sequence (N, 'S
');
2112 Set_Statement_Entry;
2114 Traverse_One (Triggering_Alternative (N));
2115 Traverse_Declarations_Or_Statements
2116 (L => Statements (Abortable_Part (N)),
2117 D => Current_Dominant);
2119 when N_Accept_Alternative =>
2120 Traverse_Declarations_Or_Statements
2121 (L => Statements (N),
2122 D => Current_Dominant,
2123 P => Accept_Statement (N));
2125 when N_Entry_Call_Alternative =>
2126 Traverse_Declarations_Or_Statements
2127 (L => Statements (N),
2128 D => Current_Dominant,
2129 P => Entry_Call_Statement (N));
2131 when N_Delay_Alternative =>
2132 Traverse_Declarations_Or_Statements
2133 (L => Statements (N),
2134 D => Current_Dominant,
2135 P => Delay_Statement (N));
2137 when N_Triggering_Alternative =>
2138 Traverse_Declarations_Or_Statements
2139 (L => Statements (N),
2140 D => Current_Dominant,
2141 P => Triggering_Statement (N));
2143 when N_Terminate_Alternative =>
2145 -- It is dubious to emit a statement SCO for a TERMINATE
2146 -- alternative, since no code is actually executed if the
2147 -- alternative is selected -- the tasking runtime call just
2150 Extend_Statement_Sequence (N, ' ');
2151 Set_Statement_Entry;
2153 -- Unconditional exit points, which are included in the current
2154 -- statement sequence, but then terminate it
2156 when N_Goto_Statement
2158 | N_Requeue_Statement
2160 Extend_Statement_Sequence (N, ' ');
2161 Set_Statement_Entry;
2162 Current_Dominant := No_Dominant;
2164 -- Simple return statement. which is an exit point, but we
2165 -- have to process the return expression for decisions.
2167 when N_Simple_Return_Statement =>
2168 Extend_Statement_Sequence (N, ' ');
2169 Process_Decisions_Defer (Expression (N), 'X
');
2170 Set_Statement_Entry;
2171 Current_Dominant := No_Dominant;
2173 -- Extended return statement
2175 when N_Extended_Return_Statement =>
2176 Extend_Statement_Sequence (N, 'R
');
2177 Process_Decisions_Defer (Return_Object_Declarations (N), 'X
');
2178 Set_Statement_Entry;
2180 Traverse_Handled_Statement_Sequence
2181 (N => Handled_Statement_Sequence (N),
2182 D => Current_Dominant);
2184 Current_Dominant := No_Dominant;
2186 -- Loop ends the current statement sequence, but we include
2187 -- the iteration scheme if present in the current sequence.
2188 -- But the body of the loop starts a new sequence, since it
2189 -- may not be executed as part of the current sequence.
2191 when N_Loop_Statement =>
2193 ISC : constant Node_Id := Iteration_Scheme (N);
2194 Inner_Dominant : Dominant_Info := No_Dominant;
2197 if Present (ISC) then
2199 -- If iteration scheme present, extend the current
2200 -- statement sequence to include the iteration scheme
2201 -- and process any decisions it contains.
2205 if Present (Condition (ISC)) then
2206 Extend_Statement_Sequence (N, 'W
');
2207 Process_Decisions_Defer (Condition (ISC), 'W
');
2209 -- Set more specific dominant for inner statements
2210 -- (the control sloc for the decision is that of
2211 -- the WHILE token).
2213 Inner_Dominant := ('T
', ISC);
2218 Extend_Statement_Sequence (N, 'F
');
2219 Process_Decisions_Defer
2220 (Loop_Parameter_Specification (ISC), 'X
');
2224 Set_Statement_Entry;
2226 if Inner_Dominant = No_Dominant then
2227 Inner_Dominant := Current_Dominant;
2230 Traverse_Declarations_Or_Statements
2231 (L => Statements (N),
2232 D => Inner_Dominant);
2239 -- Record sloc of pragma (pragmas don't nest)
2241 pragma Assert (Current_Pragma_Sloc = No_Location);
2242 Current_Pragma_Sloc := Sloc (N);
2244 -- Processing depends on the kind of pragma
2247 Nam : constant Name_Id := Pragma_Name_Unmapped (N);
2249 First (Pragma_Argument_Associations (N));
2255 | Name_Assert_And_Cut
2258 | Name_Loop_Invariant
2259 | Name_Postcondition
2261 | Name_Type_Invariant
2264 -- For Assert/Check/Precondition/Postcondition, we
2265 -- must generate a P entry for the decision. Note
2266 -- that this is done unconditionally at this stage.
2267 -- Output for disabled pragmas is suppressed later
2268 -- on when we output the decision line in Put_SCOs,
2269 -- depending on setting by Set_SCO_Pragma_Enabled.
2272 or else Nam = Name_Type_Invariant
2273 or else Nam = Name_Invariant
2278 Process_Decisions_Defer (Expression (Arg), 'P
');
2281 -- Pre/postconditions can be inherited so SCO should
2282 -- never be deactivated???
2285 if Present (Arg) and then Present (Next (Arg)) then
2287 -- Case of a dyadic pragma Debug: first argument
2288 -- is a P decision, any nested decision in the
2289 -- second argument is an X decision.
2291 Process_Decisions_Defer (Expression (Arg), 'P
');
2295 Process_Decisions_Defer (Expression (Arg), 'X
');
2298 -- For all other pragmas, we generate decision entries
2299 -- for any embedded expressions, and the pragma is
2302 -- Should generate P decisions (not X) for assertion
2303 -- related pragmas: [{Static,Dynamic}_]Predicate???
2306 Process_Decisions_Defer (N, 'X
');
2310 -- Add statement SCO
2312 Extend_Statement_Sequence (N, Typ);
2314 Current_Pragma_Sloc := No_Location;
2317 -- Object declaration. Ignored if Prev_Ids is set, since the
2318 -- parser generates multiple instances of the whole declaration
2319 -- if there is more than one identifier declared, and we only
2320 -- want one entry in the SCOs, so we take the first, for which
2321 -- Prev_Ids is False.
2323 when N_Number_Declaration
2324 | N_Object_Declaration
2326 if not Prev_Ids (N) then
2327 Extend_Statement_Sequence (N, 'o
');
2329 if Has_Decision (N) then
2330 Process_Decisions_Defer (N, 'X
');
2334 -- All other cases, which extend the current statement sequence
2335 -- but do not terminate it, even if they have nested decisions.
2337 when N_Protected_Type_Declaration
2338 | N_Task_Type_Declaration
2340 Extend_Statement_Sequence (N, 't
');
2341 Process_Decisions_Defer (Discriminant_Specifications (N), 'X
');
2342 Set_Statement_Entry;
2344 Traverse_Protected_Or_Task_Definition (N);
2346 when N_Single_Protected_Declaration
2347 | N_Single_Task_Declaration
2349 Extend_Statement_Sequence (N, 'o
');
2350 Set_Statement_Entry;
2352 Traverse_Protected_Or_Task_Definition (N);
2356 -- Determine required type character code, or ASCII.NUL if
2357 -- no SCO should be generated for this node.
2360 NK : constant Node_Kind := Nkind (N);
2365 when N_Full_Type_Declaration
2366 | N_Incomplete_Type_Declaration
2367 | N_Private_Extension_Declaration
2368 | N_Private_Type_Declaration
2372 when N_Subtype_Declaration =>
2375 when N_Renaming_Declaration =>
2378 when N_Generic_Instantiation =>
2381 when N_Package_Body_Stub
2382 | N_Protected_Body_Stub
2383 | N_Representation_Clause
2385 | N_Use_Package_Clause
2390 when N_Procedure_Call_Statement =>
2394 if NK in N_Statement_Other_Than_Procedure_Call then
2401 if Typ /= ASCII.NUL then
2402 Extend_Statement_Sequence (N, Typ);
2406 -- Process any embedded decisions
2408 if Has_Decision (N) then
2409 Process_Decisions_Defer (N, 'X
');
2413 if Permits_Aspect_Specifications (N) then
2414 Traverse_Aspects (N);
2418 -- Start of processing for Traverse_Declarations_Or_Statements
2421 -- Process single prefixed node
2427 -- Loop through statements or declarations
2430 while Present (N) loop
2432 -- Note: For separate bodies, we see the tree after Par.Labl has
2433 -- introduced implicit labels, so we need to ignore those nodes.
2435 if Nkind (N) /= N_Implicit_Label_Declaration then
2442 -- End sequence of statements and flush deferred decisions
2444 if Present (P) or else Is_Non_Empty_List (L) then
2445 Set_Statement_Entry;
2448 return Current_Dominant;
2449 end Traverse_Declarations_Or_Statements;
2451 ------------------------------------------
2452 -- Traverse_Generic_Package_Declaration --
2453 ------------------------------------------
2455 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
2457 Process_Decisions (Generic_Formal_Declarations (N), 'X
', No_Location);
2458 Traverse_Package_Declaration (N);
2459 end Traverse_Generic_Package_Declaration;
2461 -----------------------------------------
2462 -- Traverse_Handled_Statement_Sequence --
2463 -----------------------------------------
2465 procedure Traverse_Handled_Statement_Sequence
2467 D : Dominant_Info := No_Dominant)
2472 -- For package bodies without a statement part, the parser adds an empty
2473 -- one, to normalize the representation. The null statement therein,
2474 -- which does not come from source, does not get a SCO.
2476 if Present (N) and then Comes_From_Source (N) then
2477 Traverse_Declarations_Or_Statements (Statements (N), D);
2479 if Present (Exception_Handlers (N)) then
2480 Handler := First_Non_Pragma (Exception_Handlers (N));
2481 while Present (Handler) loop
2482 Traverse_Declarations_Or_Statements
2483 (L => Statements (Handler),
2484 D => ('E
', Handler));
2489 end Traverse_Handled_Statement_Sequence;
2491 ---------------------------
2492 -- Traverse_Package_Body --
2493 ---------------------------
2495 procedure Traverse_Package_Body (N : Node_Id) is
2496 Dom : Dominant_Info;
2498 -- The first statement in the handled sequence of statements is
2499 -- dominated by the elaboration of the last declaration.
2501 Dom := Traverse_Declarations_Or_Statements (Declarations (N));
2503 Traverse_Handled_Statement_Sequence
2504 (Handled_Statement_Sequence (N), Dom);
2505 end Traverse_Package_Body;
2507 ----------------------------------
2508 -- Traverse_Package_Declaration --
2509 ----------------------------------
2511 procedure Traverse_Package_Declaration
2513 D : Dominant_Info := No_Dominant)
2515 Spec : constant Node_Id := Specification (N);
2516 Dom : Dominant_Info;
2520 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec), D);
2522 -- First private declaration is dominated by last visible declaration
2524 Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom);
2525 end Traverse_Package_Declaration;
2527 -------------------------------------------
2528 -- Traverse_Protected_Or_Task_Definition --
2529 -------------------------------------------
2531 procedure Traverse_Protected_Or_Task_Definition (N : Node_Id) is
2532 Dom_Info : Dominant_Info := ('S
', N);
2533 -- The first declaration is dominated by the protected or task [type]
2537 -- N's protected or task definition
2539 Priv_Decl : List_Id;
2541 -- Sync_Def's Visible_Declarations and Private_Declarations
2545 when N_Protected_Type_Declaration
2546 | N_Single_Protected_Declaration
2548 Sync_Def := Protected_Definition (N);
2550 when N_Single_Task_Declaration
2551 | N_Task_Type_Declaration
2553 Sync_Def := Task_Definition (N);
2556 raise Program_Error;
2559 -- Sync_Def may be Empty at least for empty Task_Type_Declarations.
2560 -- Querying Visible or Private_Declarations is invalid in this case.
2562 if Present (Sync_Def) then
2563 Vis_Decl := Visible_Declarations (Sync_Def);
2564 Priv_Decl := Private_Declarations (Sync_Def);
2566 Vis_Decl := No_List;
2567 Priv_Decl := No_List;
2570 Dom_Info := Traverse_Declarations_Or_Statements
2574 -- If visible declarations are present, the first private declaration
2575 -- is dominated by the last visible declaration.
2577 Traverse_Declarations_Or_Statements
2580 end Traverse_Protected_Or_Task_Definition;
2582 --------------------------------------
2583 -- Traverse_Subprogram_Or_Task_Body --
2584 --------------------------------------
2586 procedure Traverse_Subprogram_Or_Task_Body
2588 D : Dominant_Info := No_Dominant)
2590 Decls : constant List_Id := Declarations (N);
2591 Dom_Info : Dominant_Info := D;
2594 -- If declarations are present, the first statement is dominated by the
2595 -- last declaration.
2597 Dom_Info := Traverse_Declarations_Or_Statements
2598 (L => Decls, D => Dom_Info);
2600 Traverse_Handled_Statement_Sequence
2601 (N => Handled_Statement_Sequence (N),
2603 end Traverse_Subprogram_Or_Task_Body;
2605 -------------------------
2606 -- SCO_Record_Filtered --
2607 -------------------------
2609 procedure SCO_Record_Filtered is
2610 type Decision is record
2612 -- Type of the SCO decision (see comments for SCO_Table_Entry.C1)
2614 Sloc : Source_Location;
2617 -- Index in the SCO_Raw_Table for the root operator/condition for the
2618 -- expression that controls the decision.
2620 -- Decision descriptor: used to gather information about a candidate
2623 package Pending_Decisions is new Table.Table
2624 (Table_Component_Type => Decision,
2625 Table_Index_Type => Nat,
2626 Table_Low_Bound => 1,
2627 Table_Initial => 1000,
2628 Table_Increment => 200,
2629 Table_Name => "Filter_Pending_Decisions");
2630 -- Table used to hold decisions to process during the collection pass
2632 procedure Add_Expression_Tree (Idx : in out Nat);
2633 -- Add SCO raw table entries for the decision controlling expression
2634 -- tree starting at Idx to the filtered SCO table.
2636 procedure Collect_Decisions
2639 -- Collect decisions to add to the filtered SCO table starting at the
2640 -- D decision (including it and its nested operators/conditions). Set
2641 -- Next to the first node index passed the whole decision.
2643 procedure Compute_Range
2645 From : out Source_Location;
2646 To : out Source_Location);
2647 -- Compute the source location range for the expression tree starting at
2648 -- Idx in the SCO raw table. Store its bounds in From and To.
2650 function Is_Decision (Idx : Nat) return Boolean;
2651 -- Return if the expression tree starting at Idx has adjacent nested
2652 -- nodes that make a decision.
2654 procedure Process_Pending_Decisions
2655 (Original_Decision : SCO_Table_Entry);
2656 -- Complete the filtered SCO table using collected decisions. Output
2657 -- decisions inherit the pragma information from the original decision.
2659 procedure Search_Nested_Decisions (Idx : in out Nat);
2660 -- Collect decisions to add to the filtered SCO table starting at the
2661 -- node at Idx in the SCO raw table. This node must not be part of an
2662 -- already-processed decision. Set Idx to the first node index passed
2663 -- the whole expression tree.
2665 procedure Skip_Decision
2667 Process_Nested_Decisions : Boolean);
2668 -- Skip all the nodes that belong to the decision starting at Idx. If
2669 -- Process_Nested_Decision, call Search_Nested_Decisions on the first
2670 -- nested nodes that do not belong to the decision. Set Idx to the first
2671 -- node index passed the whole expression tree.
2673 -------------------------
2674 -- Add_Expression_Tree --
2675 -------------------------
2677 procedure Add_Expression_Tree (Idx : in out Nat) is
2678 Node_Idx : constant Nat := Idx;
2679 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
2680 From : Source_Location;
2681 To : Source_Location;
2687 -- This is a single condition. Add an entry for it and move on
2689 SCO_Table.Append (T);
2694 -- This is a NOT operator: add an entry for it and browse its
2697 SCO_Table.Append (T);
2699 Add_Expression_Tree (Idx);
2703 -- This must be an AND/OR/AND THEN/OR ELSE operator
2707 -- This is not a short circuit operator: consider this one
2708 -- and all its children as a single condition.
2710 Compute_Range (Idx, From, To);
2717 Pragma_Sloc => No_Location,
2718 Pragma_Aspect_Name => No_Name));
2721 -- This is a real short circuit operator: add an entry for
2722 -- it and browse its children.
2724 SCO_Table.Append (T);
2726 Add_Expression_Tree (Idx);
2727 Add_Expression_Tree (Idx);
2730 end Add_Expression_Tree;
2732 -----------------------
2733 -- Collect_Decisions --
2734 -----------------------
2736 procedure Collect_Decisions
2743 if D.Kind /= 'X
' or else Is_Decision (D.Top) then
2744 Pending_Decisions.Append (D);
2747 Skip_Decision (Idx, True);
2749 end Collect_Decisions;
2755 procedure Compute_Range
2757 From : out Source_Location;
2758 To : out Source_Location)
2760 Sloc_F : Source_Location := No_Source_Location;
2761 Sloc_T : Source_Location := No_Source_Location;
2763 procedure Process_One;
2764 -- Process one node of the tree, and recurse over children. Update
2765 -- Idx during the traversal.
2771 procedure Process_One is
2773 if Sloc_F = No_Source_Location
2775 SCO_Raw_Table.Table (Idx).From < Sloc_F
2777 Sloc_F := SCO_Raw_Table.Table (Idx).From;
2780 if Sloc_T = No_Source_Location
2782 Sloc_T < SCO_Raw_Table.Table (Idx).To
2784 Sloc_T := SCO_Raw_Table.Table (Idx).To;
2787 if SCO_Raw_Table.Table (Idx).C1 = ' ' then
2789 -- This is a condition: nothing special to do
2793 elsif SCO_Raw_Table.Table (Idx).C1 = '!' then
2795 -- The "not" operator has only one operand
2801 -- This is an AND THEN or OR ELSE logical operator: follow the
2802 -- left, then the right operands.
2811 -- Start of processing for Compute_Range
2823 function Is_Decision (Idx : Nat) return Boolean is
2829 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
2838 -- This is a decision iff the only operand of the NOT
2839 -- operator could be a standalone decision.
2845 -- This node is a logical operator (and thus could be a
2846 -- standalone decision) iff it is a short circuit
2855 -------------------------------
2856 -- Process_Pending_Decisions --
2857 -------------------------------
2859 procedure Process_Pending_Decisions
2860 (Original_Decision : SCO_Table_Entry)
2863 for Index in 1 .. Pending_Decisions.Last loop
2865 D : Decision renames Pending_Decisions.Table (Index);
2869 -- Add a SCO table entry for the decision itself
2871 pragma Assert (D.Kind /= ' ');
2874 ((To => No_Source_Location,
2879 Pragma_Sloc => Original_Decision.Pragma_Sloc,
2880 Pragma_Aspect_Name =>
2881 Original_Decision.Pragma_Aspect_Name));
2883 -- Then add ones for its nested operators/operands. Do not
2884 -- forget to tag its *last* entry as such.
2886 Add_Expression_Tree (Idx);
2887 SCO_Table.Table (SCO_Table.Last).Last := True;
2891 -- Clear the pending decisions list
2892 Pending_Decisions.Set_Last (0);
2893 end Process_Pending_Decisions;
2895 -----------------------------
2896 -- Search_Nested_Decisions --
2897 -----------------------------
2899 procedure Search_Nested_Decisions (Idx : in out Nat) is
2903 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2922 -- This is not a logical operator: start looking for
2923 -- nested decisions from here. Recurse over the left
2924 -- child and let the loop take care of the right one.
2927 Search_Nested_Decisions (Idx);
2930 -- We found a nested decision
2942 end Search_Nested_Decisions;
2948 procedure Skip_Decision
2950 Process_Nested_Decisions : Boolean)
2955 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
2966 -- This NOT operator belongs to the outside decision:
2972 if T.C2 = '?
' and then Process_Nested_Decisions then
2974 -- This is not a logical operator: start looking for
2975 -- nested decisions from here. Recurse over the left
2976 -- child and let the loop take care of the right one.
2978 Search_Nested_Decisions (Idx);
2981 -- This is a logical operator, so it belongs to the
2982 -- outside decision: skip its left child, then let the
2983 -- loop take care of the right one.
2985 Skip_Decision (Idx, Process_Nested_Decisions);
2992 -- Start of processing for SCO_Record_Filtered
2995 -- Filtering must happen only once: do nothing if it this pass was
2998 if SCO_Generation_State = Filtered then
3001 pragma Assert (SCO_Generation_State = Raw);
3002 SCO_Generation_State := Filtered;
3005 -- Loop through all SCO entries under SCO units
3007 for Unit_Idx in 1 .. SCO_Unit_Table.Last loop
3009 Unit : SCO_Unit_Table_Entry
3010 renames SCO_Unit_Table.Table (Unit_Idx);
3012 Idx : Nat := Unit.From;
3013 -- Index of the current SCO raw table entry
3015 New_From : constant Nat := SCO_Table.Last + 1;
3016 -- After copying SCO enties of interest to the final table, we
3017 -- will have to change the From/To indexes this unit targets.
3018 -- This constant keeps track of the new From index.
3021 while Idx <= Unit.To loop
3023 T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
3028 -- Decision (of any kind, including pragmas and aspects)
3030 when 'E
' | 'G
' | 'I
' | 'W
' | 'X
' | 'P
' | 'a
' | 'A
' =>
3031 if SCO_Pragma_Disabled (T.Pragma_Sloc) then
3033 -- Skip SCO entries for decisions in disabled
3034 -- constructs (pragmas or aspects).
3037 Skip_Decision (Idx, False);
3045 Process_Pending_Decisions (T);
3048 -- There is no translation/filtering to do for other kind
3049 -- of SCO items (statements, dominance markers, etc.).
3051 when '|
' | '&' | '!' | ' ' =>
3053 -- SCO logical operators and conditions cannot exist
3054 -- on their own: they must be inside a decision (such
3055 -- entries must have been skipped by
3056 -- Collect_Decisions).
3058 raise Program_Error;
3061 SCO_Table.Append (T);
3067 -- Now, update the SCO entry indexes in the unit entry
3069 Unit.From := New_From;
3070 Unit.To := SCO_Table.Last;
3074 -- Then clear the raw table to free bytes
3077 end SCO_Record_Filtered;