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