1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2009, 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 Atree
; use Atree
;
27 with Debug
; use Debug
;
29 with Lib
.Util
; use Lib
.Util
;
30 with Namet
; use Namet
;
31 with Nlists
; use Nlists
;
33 with Output
; use Output
;
36 with Sinfo
; use Sinfo
;
37 with Sinput
; use Sinput
;
38 with Snames
; use Snames
;
41 with GNAT
.HTable
; use GNAT
.HTable
;
42 with GNAT
.Heap_Sort_G
;
44 package body Par_SCO
is
46 -----------------------
47 -- Unit Number Table --
48 -----------------------
50 -- This table parallels the SCO_Unit_Table, keeping track of the unit
51 -- numbers corresponding to the entries made in this table, so that before
52 -- writing out the SCO information to the ALI file, we can fill in the
53 -- proper dependency numbers and file names.
55 -- Note that the zero'th entry is here for convenience in sorting the
56 -- table, the real lower bound is 1.
58 package SCO_Unit_Number_Table
is new Table
.Table
(
59 Table_Component_Type
=> Unit_Number_Type
,
60 Table_Index_Type
=> SCO_Unit_Index
,
61 Table_Low_Bound
=> 0, -- see note above on sort
63 Table_Increment
=> 200,
64 Table_Name
=> "SCO_Unit_Number_Entry");
66 --------------------------
67 -- Condition Hash Table --
68 --------------------------
70 -- We need to be able to get to conditions quickly for handling the calls
71 -- to Set_SCO_Condition efficiently. For this purpose we identify the
72 -- conditions in the table by their starting sloc, and use the following
73 -- hash table to map from these starting sloc values to SCO_Table indexes.
75 type Header_Num
is new Integer range 0 .. 996;
76 -- Type for hash table headers
78 function Hash
(F
: Source_Ptr
) return Header_Num
;
79 -- Function to Hash source pointer value
81 function Equal
(F1
, F2
: Source_Ptr
) return Boolean;
82 -- Function to test two keys for equality
84 package Condition_Hash_Table
is new Simple_HTable
85 (Header_Num
, Int
, 0, Source_Ptr
, Hash
, Equal
);
86 -- The actual hash table
88 --------------------------
89 -- Internal Subprograms --
90 --------------------------
92 function Has_Decision
(N
: Node_Id
) return Boolean;
93 -- N is the node for a subexpression. Returns True if the subexpression
94 -- contains a nested decision (i.e. either is a logical operator, or
95 -- contains a logical operator in its subtree).
97 function Is_Logical_Operator
(N
: Node_Id
) return Boolean;
98 -- N is the node for a subexpression. This procedure just tests N to see
99 -- if it is a logical operator (including short circuit conditions, but
100 -- excluding OR and AND) and returns True if so, False otherwise, it does
101 -- no other processing.
103 procedure Process_Decisions
(N
: Node_Id
; T
: Character);
104 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
105 -- to output any decisions it contains. T is one of IEPWX (for context of
106 -- expresion: if/exit when/pragma/while/expression). If T is other than X,
107 -- then a decision is always present (at the very least a simple decision
108 -- is present at the top level).
110 procedure Process_Decisions
(L
: List_Id
; T
: Character);
111 -- Calls above procedure for each element of the list L
113 procedure Set_Table_Entry
119 -- Append an entry to SCO_Table with fields set as per arguments
121 procedure Traverse_Declarations_Or_Statements
(L
: List_Id
);
122 procedure Traverse_Generic_Package_Declaration
(N
: Node_Id
);
123 procedure Traverse_Handled_Statement_Sequence
(N
: Node_Id
);
124 procedure Traverse_Package_Body
(N
: Node_Id
);
125 procedure Traverse_Package_Declaration
(N
: Node_Id
);
126 procedure Traverse_Subprogram_Body
(N
: Node_Id
);
127 -- Traverse the corresponding construct, generating SCO table entries
129 procedure Write_SCOs_To_ALI_File
is new Put_SCOs
;
130 -- Write SCO information to the ALI file using routines in Lib.Util
138 -- Dump SCO unit table
140 Write_Line
("SCO Unit Table");
141 Write_Line
("--------------");
143 for Index
in 1 .. SCO_Unit_Table
.Last
loop
145 UTE
: SCO_Unit_Table_Entry
renames SCO_Unit_Table
.Table
(Index
);
149 Write_Int
(Int
(Index
));
150 Write_Str
(". Dep_Num = ");
151 Write_Int
(Int
(UTE
.Dep_Num
));
152 Write_Str
(" From = ");
153 Write_Int
(Int
(UTE
.From
));
154 Write_Str
(" To = ");
155 Write_Int
(Int
(UTE
.To
));
157 Write_Str
(" File_Name = """);
159 if UTE
.File_Name
/= null then
160 Write_Str
(UTE
.File_Name
.all);
168 -- Dump SCO Unit number table if it contains any entries
170 if SCO_Unit_Number_Table
.Last
>= 1 then
172 Write_Line
("SCO Unit Number Table");
173 Write_Line
("---------------------");
175 for Index
in 1 .. SCO_Unit_Number_Table
.Last
loop
177 Write_Int
(Int
(Index
));
178 Write_Str
(". Unit_Number = ");
179 Write_Int
(Int
(SCO_Unit_Number_Table
.Table
(Index
)));
184 -- Dump SCO table itself
187 Write_Line
("SCO Table");
188 Write_Line
("---------");
190 for Index
in 1 .. SCO_Table
.Last
loop
192 T
: SCO_Table_Entry
renames SCO_Table
.Table
(Index
);
200 Write_Str
(" C1 = '");
206 Write_Str
(" C2 = '");
211 if T
.From
/= No_Source_Location
then
212 Write_Str
(" From = ");
213 Write_Int
(Int
(T
.From
.Line
));
215 Write_Int
(Int
(T
.From
.Col
));
218 if T
.To
/= No_Source_Location
then
219 Write_Str
(" To = ");
220 Write_Int
(Int
(T
.To
.Line
));
222 Write_Int
(Int
(T
.To
.Col
));
228 Write_Str
(" False");
240 function Equal
(F1
, F2
: Source_Ptr
) return Boolean is
249 function Has_Decision
(N
: Node_Id
) return Boolean is
251 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
257 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
259 if Is_Logical_Operator
(N
) then
266 function Traverse
is new Traverse_Func
(Check_Node
);
268 -- Start of processing for Has_Decision
271 return Traverse
(N
) = Abandon
;
278 function Hash
(F
: Source_Ptr
) return Header_Num
is
280 return Header_Num
(Nat
(F
) mod 997);
287 procedure Initialize
is
289 SCO_Unit_Number_Table
.Init
;
291 -- Set dummy 0'th entry in place for sort
293 SCO_Unit_Number_Table
.Increment_Last
;
296 -------------------------
297 -- Is_Logical_Operator --
298 -------------------------
300 function Is_Logical_Operator
(N
: Node_Id
) return Boolean is
302 return Nkind_In
(N
, N_Op_Xor
,
306 end Is_Logical_Operator
;
308 -----------------------
309 -- Process_Decisions --
310 -----------------------
312 -- Version taking a list
314 procedure Process_Decisions
(L
: List_Id
; T
: Character) is
319 while Present
(N
) loop
320 Process_Decisions
(N
, T
);
324 end Process_Decisions
;
326 -- Version taking a node
328 procedure Process_Decisions
(N
: Node_Id
; T
: Character) is
330 function Process_Node
(N
: Node_Id
) return Traverse_Result
;
331 -- Processes one node in the traversal, looking for logical operators,
332 -- and if one is found, outputs the appropriate table entries.
334 procedure Output_Decision_Operand
(N
: Node_Id
);
335 -- The node N is the top level logical operator of a decision, or it is
336 -- one of the operands of a logical operator belonging to a single
337 -- complex decision. This routine outputs the sequence of table entries
338 -- corresponding to the node. Note that we do not process the sub-
339 -- operands to look for further decisions, that processing is done in
340 -- Process_Decision_Operand, because we can't get decisions mixed up in
341 -- the global table. Call has no effect if N is Empty.
343 procedure Output_Element
(N
: Node_Id
; T
: Character);
344 -- Node N is an operand of a logical operator that is not itself a
345 -- logical operator, or it is a simple decision. This routine outputs
346 -- the table entry for the element, with C1 set to T (' ' for one of
347 -- the elements of a complex decision, or 'I'/'W'/'E' for a simple
348 -- decision (from an IF, WHILE, or EXIT WHEN). Last is set to False,
349 -- and an entry is made in the condition hash table.
351 procedure Process_Decision_Operand
(N
: Node_Id
);
352 -- This is called on node N, the top level node of a decision, or on one
353 -- of its operands or suboperands after generating the full output for
354 -- the complex decision. It process the suboperands of the decision
355 -- looking for nested decisions.
357 -----------------------------
358 -- Output_Decision_Operand --
359 -----------------------------
361 procedure Output_Decision_Operand
(N
: Node_Id
) is
371 elsif Is_Logical_Operator
(N
) then
372 if Nkind
(N
) = N_Op_Not
then
379 if Nkind
(N
) = N_Op_Xor
then
381 elsif Nkind_In
(N
, N_Op_Or
, N_Or_Else
) then
388 Set_Table_Entry
(C
, ' ', No_Location
, No_Location
, False);
390 Output_Decision_Operand
(L
);
391 Output_Decision_Operand
(Right_Opnd
(N
));
393 -- Not a logical operator
396 Output_Element
(N
, ' ');
398 end Output_Decision_Operand
;
404 procedure Output_Element
(N
: Node_Id
; T
: Character) is
408 Sloc_Range
(N
, FSloc
, LSloc
);
409 Set_Table_Entry
(T
, 'c', FSloc
, LSloc
, False);
410 Condition_Hash_Table
.Set
(FSloc
, SCO_Table
.Last
);
413 ------------------------------
414 -- Process_Decision_Operand --
415 ------------------------------
417 procedure Process_Decision_Operand
(N
: Node_Id
) is
419 if Is_Logical_Operator
(N
) then
420 if Nkind
(N
) /= N_Op_Not
then
421 Process_Decision_Operand
(Left_Opnd
(N
));
424 Process_Decision_Operand
(Right_Opnd
(N
));
427 Process_Decisions
(N
, 'X');
429 end Process_Decision_Operand
;
435 function Process_Node
(N
: Node_Id
) return Traverse_Result
is
439 -- Logical operators, output table entries and then process
440 -- operands recursively to deal with nested conditions.
450 -- If outer level, then type comes from call, otherwise it
451 -- is more deeply nested and counts as X for expression.
453 if N
= Process_Decisions
.N
then
454 T
:= Process_Decisions
.T
;
459 -- Output header for sequence
461 Set_Table_Entry
(T
, ' ', No_Location
, No_Location
, False);
463 -- Output the decision
465 Output_Decision_Operand
(N
);
467 -- Change Last in last table entry to True to mark end
469 SCO_Table
.Table
(SCO_Table
.Last
).Last
:= True;
471 -- Process any embedded decisions
473 Process_Decision_Operand
(N
);
477 -- Conditional expression, processed like an if statement
479 when N_Conditional_Expression
=>
481 Cond
: constant Node_Id
:= First
(Expressions
(N
));
482 Thnx
: constant Node_Id
:= Next
(Cond
);
483 Elsx
: constant Node_Id
:= Next
(Thnx
);
485 Process_Decisions
(Cond
, 'I');
486 Process_Decisions
(Thnx
, 'X');
487 Process_Decisions
(Elsx
, 'X');
491 -- All other cases, continue scan
499 procedure Traverse
is new Traverse_Proc
(Process_Node
);
501 -- Start of processing for Process_Decisions
508 -- See if we have simple decision at outer level and if so then
509 -- generate the decision entry for this simple decision. A simple
510 -- decision is a boolean expression (which is not a logical operator
511 -- or short circuit form) appearing as the operand of an IF, WHILE
512 -- or EXIT WHEN construct.
514 if T
/= 'X' and then not Is_Logical_Operator
(N
) then
515 Output_Element
(N
, T
);
517 -- Change Last in last table entry to True to mark end of
518 -- sequence, which is this case is only one element long.
520 SCO_Table
.Table
(SCO_Table
.Last
).Last
:= True;
524 end Process_Decisions
;
532 procedure Write_Info_Char
(C
: Character) renames Write_Char
;
533 -- Write one character;
535 procedure Write_Info_Initiate
(Key
: Character) renames Write_Char
;
536 -- Start new one and write one character;
538 procedure Write_Info_Nat
(N
: Nat
);
541 procedure Write_Info_Terminate
renames Write_Eol
;
542 -- Terminate current line
548 procedure Write_Info_Nat
(N
: Nat
) is
553 procedure Debug_Put_SCOs
is new Put_SCOs
;
555 -- Start of processing for pscos
565 procedure SCO_Output
is
567 if Debug_Flag_Dot_OO
then
571 -- Sort the unit tables based on dependency numbers
573 Unit_Table_Sort
: declare
575 function Lt
(Op1
, Op2
: Natural) return Boolean;
576 -- Comparison routine for sort call
578 procedure Move
(From
: Natural; To
: Natural);
579 -- Move routine for sort call
585 function Lt
(Op1
, Op2
: Natural) return Boolean is
589 (SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(Op1
)))
592 (SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(Op2
)));
599 procedure Move
(From
: Natural; To
: Natural) is
601 SCO_Unit_Table
.Table
(SCO_Unit_Index
(To
)) :=
602 SCO_Unit_Table
.Table
(SCO_Unit_Index
(From
));
603 SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(To
)) :=
604 SCO_Unit_Number_Table
.Table
(SCO_Unit_Index
(From
));
607 package Sorting
is new GNAT
.Heap_Sort_G
(Move
, Lt
);
609 -- Start of processing for Unit_Table_Sort
612 Sorting
.Sort
(Integer (SCO_Unit_Table
.Last
));
615 -- Loop through entries in the unit table to set file name and
616 -- dependency number entries.
618 for J
in 1 .. SCO_Unit_Table
.Last
loop
620 U
: constant Unit_Number_Type
:= SCO_Unit_Number_Table
.Table
(J
);
621 UTE
: SCO_Unit_Table_Entry
renames SCO_Unit_Table
.Table
(J
);
623 Get_Name_String
(Reference_Name
(Source_Index
(U
)));
624 UTE
.File_Name
:= new String'(Name_Buffer (1 .. Name_Len));
625 UTE.Dep_Num := Dependency_Num (U);
629 -- Now the tables are all setup for output to the ALI file
631 Write_SCOs_To_ALI_File;
638 procedure SCO_Record (U : Unit_Number_Type) is
643 -- Ignore call if not generating code and generating SCO's
645 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
649 -- Ignore call if this unit already recorded
651 for J in 1 .. SCO_Unit_Number_Table.Last loop
652 if U = SCO_Unit_Number_Table.Table (J) then
657 -- Otherwise record starting entry
659 From := SCO_Table.Last + 1;
661 -- Get Unit (checking case of subunit)
663 Lu := Unit (Cunit (U));
665 if Nkind (Lu) = N_Subunit then
666 Lu := Proper_Body (Lu);
671 if Nkind (Lu) = N_Subprogram_Body then
672 Traverse_Subprogram_Body (Lu);
674 elsif Nkind (Lu) = N_Package_Declaration then
675 Traverse_Package_Declaration (Lu);
677 elsif Nkind (Lu) = N_Package_Body then
678 Traverse_Package_Body (Lu);
680 elsif Nkind (Lu) = N_Generic_Package_Declaration then
681 Traverse_Generic_Package_Declaration (Lu);
683 -- For anything else, the only issue is default expressions for
684 -- parameters, where we have to worry about possible embedded decisions
688 Process_Decisions (Lu, 'X
');
691 -- Make entry for new unit in unit tables, we will fill in the file
692 -- name and dependency numbers later.
694 SCO_Unit_Table.Append (
698 To => SCO_Table.Last));
700 SCO_Unit_Number_Table.Append (U);
703 -----------------------
704 -- Set_SCO_Condition --
705 -----------------------
707 procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is
708 Index : constant Nat := Condition_Hash_Table.Get (First_Loc);
711 SCO_Table.Table (Index).C2 := Typ;
713 end Set_SCO_Condition;
715 ---------------------
716 -- Set_Table_Entry --
717 ---------------------
719 procedure Set_Table_Entry
726 function To_Source_Location (S : Source_Ptr) return Source_Location;
727 -- Converts Source_Ptr value to Source_Location (line/col) format
729 ------------------------
730 -- To_Source_Location --
731 ------------------------
733 function To_Source_Location (S : Source_Ptr) return Source_Location is
735 if S = No_Location then
736 return No_Source_Location;
739 (Line => Get_Logical_Line_Number (S),
740 Col => Get_Column_Number (S));
742 end To_Source_Location;
744 -- Start of processing for Set_Table_Entry
750 From => To_Source_Location (From),
751 To => To_Source_Location (To),
755 -----------------------------------------
756 -- Traverse_Declarations_Or_Statements --
757 -----------------------------------------
759 procedure Traverse_Declarations_Or_Statements (L : List_Id) is
763 type SC_Entry is record
768 -- Used to store a single entry in the following array
770 SC_Array : array (Nat range 1 .. 10_000) of SC_Entry;
772 -- Used to store statement components for a CS entry to be output
773 -- as a result of the call to this procedure. SC_Last is the last
774 -- entry stored, so the current statement sequence is represented
775 -- by SC_Array (1 .. SC_Last). Extend_Statement_Sequence adds an
776 -- entry to this array, and Set_Statement_Entry clears it, copying
777 -- the entries to the main SCO output table. The reason that we do
778 -- the temporary caching of results in this array is that we want
779 -- the SCO table entries for a given CS line to be contiguous, and
780 -- the processing may output intermediate entries such as decision
781 -- entries. Note that the limit of 10_000 here is arbitrary, but does
782 -- not cause any trouble, if we encounter more than 10_000 statements
783 -- we simply break the current CS sequence at that point, which is
784 -- harmless, since this is only used for back annotation and it is
785 -- not critical that back annotation always work in all cases. Anyway
786 -- exceeding 10,000 statements in a basic block is very unlikely.
788 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
789 -- Extend the current statement sequence to encompass the node N. Typ
790 -- is the letter that identifies the type of statement/declaration that
791 -- is being added to the sequence.
793 procedure Extend_Statement_Sequence
797 -- This version extends the current statement sequence with an entry
798 -- that starts with the first token of From, and ends with the last
799 -- token of To. It is used for example in a CASE statement to cover
800 -- the range from the CASE token to the last token of the expression.
802 procedure Set_Statement_Entry;
803 -- If Start is No_Location, does nothing, otherwise outputs a SCO_Table
804 -- statement entry for the range Start-Stop and then sets both Start
805 -- and Stop to No_Location. Unconditionally sets Term to True. This is
806 -- called when we find a statement or declaration that generates its
807 -- own table entry, so that we must end the current statement sequence.
809 -------------------------
810 -- Set_Statement_Entry --
811 -------------------------
813 procedure Set_Statement_Entry is
818 for J in 1 .. SC_Last loop
827 C2 => SC_Array (J).Typ,
828 From => SC_Array (J).From,
829 To => SC_Array (J).To,
830 Last => (J = SC_Last));
835 end Set_Statement_Entry;
837 -------------------------------
838 -- Extend_Statement_Sequence --
839 -------------------------------
841 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
843 -- Clear out statement sequence if array full
845 if SC_Last = SC_Array'Last then
848 SC_Last := SC_Last + 1;
854 (N, SC_Array (SC_Last).From, SC_Array (SC_Last).To);
855 SC_Array (SC_Last).Typ := Typ;
856 end Extend_Statement_Sequence;
858 procedure Extend_Statement_Sequence
864 -- Clear out statement sequence if array full
866 if SC_Last = SC_Array'Last then
869 SC_Last := SC_Last + 1;
874 Sloc_Range (From, SC_Array (SC_Last).From, Dummy);
875 Sloc_Range (To, Dummy, SC_Array (SC_Last).To);
876 SC_Array (SC_Last).Typ := Typ;
877 end Extend_Statement_Sequence;
879 -- Start of processing for Traverse_Declarations_Or_Statements
882 if Is_Non_Empty_List (L) then
885 -- Loop through statements or declarations
888 while Present (N) loop
890 -- Initialize or extend current statement sequence. Note that for
891 -- special cases such as IF and Case statements we will modify
892 -- the range to exclude internal statements that should not be
893 -- counted as part of the current statement sequence.
897 -- Package declaration
899 when N_Package_Declaration =>
901 Traverse_Package_Declaration (N);
903 -- Generic package declaration
905 when N_Generic_Package_Declaration =>
907 Traverse_Generic_Package_Declaration (N);
911 when N_Package_Body =>
913 Traverse_Package_Body (N);
915 -- Subprogram declaration
917 when N_Subprogram_Declaration =>
920 (Parameter_Specifications (Specification (N)), 'X
');
922 -- Generic subprogram declaration
924 when N_Generic_Subprogram_Declaration =>
926 Process_Decisions (Generic_Formal_Declarations (N), 'X
');
928 (Parameter_Specifications (Specification (N)), 'X
');
932 when N_Subprogram_Body =>
934 Traverse_Subprogram_Body (N);
936 -- Exit statement, which is an exit statement in the SCO sense,
937 -- so it is included in the current statement sequence, but
938 -- then it terminates this sequence. We also have to process
939 -- any decisions in the exit statement expression.
941 when N_Exit_Statement =>
942 Extend_Statement_Sequence (N, ' ');
944 Process_Decisions (Condition (N), 'E
');
946 -- Label, which breaks the current statement sequence, but the
947 -- label itself is not included in the next statement sequence,
948 -- since it generates no code.
953 -- Block statement, which breaks the current statement sequence
955 when N_Block_Statement =>
957 Traverse_Declarations_Or_Statements (Declarations (N));
958 Traverse_Handled_Statement_Sequence
959 (Handled_Statement_Sequence (N));
961 -- If statement, which breaks the current statement sequence,
962 -- but we include the condition in the current sequence.
964 when N_If_Statement =>
965 Extend_Statement_Sequence (N, Condition (N), 'I
');
967 Process_Decisions (Condition (N), 'I
');
968 Traverse_Declarations_Or_Statements (Then_Statements (N));
970 if Present (Elsif_Parts (N)) then
972 Elif : Node_Id := First (Elsif_Parts (N));
974 while Present (Elif) loop
975 Process_Decisions (Condition (Elif), 'I
');
976 Traverse_Declarations_Or_Statements
977 (Then_Statements (Elif));
983 Traverse_Declarations_Or_Statements (Else_Statements (N));
985 -- Case statement, which breaks the current statement sequence,
986 -- but we include the expression in the current sequence.
988 when N_Case_Statement =>
989 Extend_Statement_Sequence (N, Expression (N), 'C
');
991 Process_Decisions (Expression (N), 'X
');
993 -- Process case branches
999 Alt := First (Alternatives (N));
1000 while Present (Alt) loop
1001 Traverse_Declarations_Or_Statements (Statements (Alt));
1006 -- Unconditional exit points, which are included in the current
1007 -- statement sequence, but then terminate it
1009 when N_Requeue_Statement |
1011 N_Raise_Statement =>
1012 Extend_Statement_Sequence (N, ' ');
1013 Set_Statement_Entry;
1015 -- Simple return statement. which is an exit point, but we
1016 -- have to process the return expression for decisions.
1018 when N_Simple_Return_Statement =>
1019 Extend_Statement_Sequence (N, ' ');
1020 Set_Statement_Entry;
1021 Process_Decisions (Expression (N), 'X
');
1023 -- Extended return statement
1025 when N_Extended_Return_Statement =>
1027 Odecl : constant Node_Id :=
1028 First (Return_Object_Declarations (N));
1030 if Present (Expression (Odecl)) then
1031 Extend_Statement_Sequence
1032 (N, Expression (Odecl), 'R
');
1033 Process_Decisions (Expression (Odecl), 'X
');
1037 Traverse_Handled_Statement_Sequence
1038 (Handled_Statement_Sequence (N));
1040 -- Loop ends the current statement sequence, but we include
1041 -- the iteration scheme if present in the current sequence.
1042 -- But the body of the loop starts a new sequence, since it
1043 -- may not be executed as part of the current sequence.
1045 when N_Loop_Statement =>
1046 if Present (Iteration_Scheme (N)) then
1048 -- If iteration scheme present, extend the current
1049 -- statement sequence to include the iteration scheme
1050 -- and process any decisions it contains.
1053 ISC : constant Node_Id := Iteration_Scheme (N);
1058 if Present (Condition (ISC)) then
1059 Extend_Statement_Sequence (N, ISC, 'W
');
1060 Process_Decisions (Condition (ISC), 'W
');
1065 Extend_Statement_Sequence (N, ISC, 'F
');
1067 (Loop_Parameter_Specification (ISC), 'X
');
1072 Set_Statement_Entry;
1073 Traverse_Declarations_Or_Statements (Statements (N));
1078 Extend_Statement_Sequence (N, 'P
');
1080 -- For pragmas Assert, Check, Precondition, and
1081 -- Postcondition, we generate decision entries for the
1082 -- condition only if the pragma is enabled. For now, we just
1083 -- check Assertions_Enabled, which will be set to reflect
1084 -- the presence of -gnata.
1086 -- Later we should move processing of the relevant pragmas
1087 -- to Par_Prag, and properly set the flag Pragma_Enabled at
1088 -- parse time, so that we can check this flag instead ???
1090 -- For all other pragmas, we always generate decision
1091 -- entries for any embedded expressions.
1094 Nam : constant Name_Id :=
1095 Chars (Pragma_Identifier (N));
1096 Arg : Node_Id := First (Pragma_Argument_Associations (N));
1102 Name_Postcondition =>
1104 if Nam = Name_Check then
1108 if Assertions_Enabled then
1109 Process_Decisions (Expression (Arg), 'P
');
1113 Process_Decisions (N, 'X
');
1117 -- All other cases, which extend the current statement sequence
1118 -- but do not terminate it, even if they have nested decisions.
1122 -- Determine required type character code
1129 when N_Full_Type_Declaration |
1130 N_Incomplete_Type_Declaration |
1131 N_Private_Type_Declaration |
1132 N_Private_Extension_Declaration =>
1135 when N_Subtype_Declaration =>
1138 when N_Object_Declaration =>
1141 when N_Renaming_Declaration =>
1144 when N_Generic_Instantiation =>
1151 Extend_Statement_Sequence (N, Typ);
1154 -- Process any embedded decisions
1156 if Has_Decision (N) then
1157 Process_Decisions (N, 'X
');
1164 Set_Statement_Entry;
1166 end Traverse_Declarations_Or_Statements;
1168 ------------------------------------------
1169 -- Traverse_Generic_Package_Declaration --
1170 ------------------------------------------
1172 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
1174 Process_Decisions (Generic_Formal_Declarations (N), 'X
');
1175 Traverse_Package_Declaration (N);
1176 end Traverse_Generic_Package_Declaration;
1178 -----------------------------------------
1179 -- Traverse_Handled_Statement_Sequence --
1180 -----------------------------------------
1182 procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
1187 -- For package bodies without a statement part, the parser adds an empty
1188 -- one, to normalize the representation. The null statement therein,
1189 -- which does not come from source, does not get a SCO.
1191 if Present (N) and then Comes_From_Source (N) then
1192 Traverse_Declarations_Or_Statements (Statements (N));
1194 if Present (Exception_Handlers (N)) then
1195 Handler := First (Exception_Handlers (N));
1196 while Present (Handler) loop
1197 Traverse_Declarations_Or_Statements (Statements (Handler));
1202 end Traverse_Handled_Statement_Sequence;
1204 ---------------------------
1205 -- Traverse_Package_Body --
1206 ---------------------------
1208 procedure Traverse_Package_Body (N : Node_Id) is
1210 Traverse_Declarations_Or_Statements (Declarations (N));
1211 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1212 end Traverse_Package_Body;
1214 ----------------------------------
1215 -- Traverse_Package_Declaration --
1216 ----------------------------------
1218 procedure Traverse_Package_Declaration (N : Node_Id) is
1219 Spec : constant Node_Id := Specification (N);
1221 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
1222 Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
1223 end Traverse_Package_Declaration;
1225 ------------------------------
1226 -- Traverse_Subprogram_Body --
1227 ------------------------------
1229 procedure Traverse_Subprogram_Body (N : Node_Id) is
1231 Traverse_Declarations_Or_Statements (Declarations (N));
1232 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1233 end Traverse_Subprogram_Body;