1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2009-2011, 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/Pragma Hash Table --
68 ---------------------------------
70 -- We need to be able to get to conditions quickly for handling the calls
71 -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to
72 -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify
73 -- the conditions and pragmas in the table by their starting sloc, and use
74 -- this hash table to map from these sloc values to SCO_Table indexes.
76 type Header_Num is new Integer range 0 .. 996;
77 -- Type for hash table headers
79 function Hash (F : Source_Ptr) return Header_Num;
80 -- Function to Hash source pointer value
82 function Equal (F1, F2 : Source_Ptr) return Boolean;
83 -- Function to test two keys for equality
85 package Condition_Pragma_Hash_Table is new Simple_HTable
86 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
87 -- The actual hash table
89 --------------------------
90 -- Internal Subprograms --
91 --------------------------
93 function Has_Decision (N : Node_Id) return Boolean;
94 -- N is the node for a subexpression. Returns True if the subexpression
95 -- contains a nested decision (i.e. either is a logical operator, or
96 -- contains a logical operator in its subtree).
98 function Is_Logical_Operator (N : Node_Id) return Boolean;
99 -- N is the node for a subexpression. This procedure just tests N to see
100 -- if it is a logical operator (including short circuit conditions, but
101 -- excluding OR and AND) and returns True if so, False otherwise, it does
102 -- no other processing.
104 procedure Process_Decisions
107 Pragma_Sloc : Source_Ptr);
108 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
109 -- to output any decisions it contains. T is one of IEGPWX (for context of
110 -- expression: if/exit when/entry guard/pragma/while/expression). If T is
111 -- other than X, the node N is the conditional expression involved, and a
112 -- decision is always present (at the very least a simple decision is
113 -- present at the top level).
115 procedure Process_Decisions
118 Pragma_Sloc : Source_Ptr);
119 -- Calls above procedure for each element of the list L
121 procedure Set_Table_Entry
127 Pragma_Sloc : Source_Ptr := No_Location;
128 Pragma_Name : Pragma_Id := Unknown_Pragma);
129 -- Append an entry to SCO_Table with fields set as per arguments
131 procedure Traverse_Declarations_Or_Statements (L : List_Id);
132 procedure Traverse_Generic_Instantiation (N : Node_Id);
133 procedure Traverse_Generic_Package_Declaration (N : Node_Id);
134 procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
135 procedure Traverse_Package_Body (N : Node_Id);
136 procedure Traverse_Package_Declaration (N : Node_Id);
137 procedure Traverse_Protected_Body (N : Node_Id);
138 procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id);
139 procedure Traverse_Subprogram_Declaration (N : Node_Id);
140 -- Traverse the corresponding construct, generating SCO table entries
142 procedure Write_SCOs_To_ALI_File is new Put_SCOs;
143 -- Write SCO information to the ALI file using routines in Lib.Util
151 -- Dump SCO unit table
153 Write_Line ("SCO Unit Table");
154 Write_Line ("--------------");
156 for Index in 1 .. SCO_Unit_Table.Last loop
158 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
162 Write_Int (Int (Index));
163 Write_Str (". Dep_Num = ");
164 Write_Int (Int (UTE.Dep_Num));
165 Write_Str (" From = ");
166 Write_Int (Int (UTE.From));
167 Write_Str (" To = ");
168 Write_Int (Int (UTE.To));
170 Write_Str (" File_Name = """);
172 if UTE.File_Name /= null then
173 Write_Str (UTE.File_Name.all);
181 -- Dump SCO Unit number table if it contains any entries
183 if SCO_Unit_Number_Table.Last >= 1 then
185 Write_Line ("SCO Unit Number Table");
186 Write_Line ("---------------------");
188 for Index in 1 .. SCO_Unit_Number_Table.Last loop
190 Write_Int (Int (Index));
191 Write_Str (". Unit_Number = ");
192 Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
197 -- Dump SCO table itself
200 Write_Line ("SCO Table");
201 Write_Line ("---------");
203 for Index in 1 .. SCO_Table.Last loop
205 T : SCO_Table_Entry renames SCO_Table.Table (Index);
213 Write_Str (" C1 = '");
219 Write_Str (" C2 = '");
224 if T.From /= No_Source_Location then
225 Write_Str (" From = ");
226 Write_Int (Int (T.From.Line));
228 Write_Int (Int (T.From.Col));
231 if T.To /= No_Source_Location then
232 Write_Str (" To = ");
233 Write_Int (Int (T.To.Line));
235 Write_Int (Int (T.To.Col));
241 Write_Str (" False");
253 function Equal (F1, F2 : Source_Ptr) return Boolean is
262 function Has_Decision (N : Node_Id) return Boolean is
264 function Check_Node (N : Node_Id) return Traverse_Result;
270 function Check_Node (N : Node_Id) return Traverse_Result is
272 if Is_Logical_Operator (N) then
279 function Traverse is new Traverse_Func (Check_Node);
281 -- Start of processing for Has_Decision
284 return Traverse (N) = Abandon;
291 function Hash (F : Source_Ptr) return Header_Num is
293 return Header_Num (Nat (F) mod 997);
300 procedure Initialize is
302 SCO_Unit_Number_Table.Init;
304 -- Set dummy 0'th entry in place for sort
306 SCO_Unit_Number_Table.Increment_Last;
309 -------------------------
310 -- Is_Logical_Operator --
311 -------------------------
313 function Is_Logical_Operator (N : Node_Id) return Boolean is
315 return Nkind_In (N, N_Op_Not,
318 end Is_Logical_Operator;
320 -----------------------
321 -- Process_Decisions --
322 -----------------------
324 -- Version taking a list
326 procedure Process_Decisions
329 Pragma_Sloc : Source_Ptr)
335 while Present (N) loop
336 Process_Decisions (N, T, Pragma_Sloc);
340 end Process_Decisions;
342 -- Version taking a node
344 Current_Pragma_Sloc : Source_Ptr := No_Location;
345 -- While processing a pragma, this is set to the sloc of the N_Pragma node
347 procedure Process_Decisions
350 Pragma_Sloc : Source_Ptr)
353 -- This is used to mark the location of a decision sequence in the SCO
354 -- table. We use it for backing out a simple decision in an expression
355 -- context that contains only NOT operators.
357 X_Not_Decision : Boolean;
358 -- This flag keeps track of whether a decision sequence in the SCO table
359 -- contains only NOT operators, and is for an expression context (T=X).
360 -- The flag will be set False if T is other than X, or if an operator
361 -- other than NOT is in the sequence.
363 function Process_Node (N : Node_Id) return Traverse_Result;
364 -- Processes one node in the traversal, looking for logical operators,
365 -- and if one is found, outputs the appropriate table entries.
367 procedure Output_Decision_Operand (N : Node_Id);
368 -- The node N is the top level logical operator of a decision, or it is
369 -- one of the operands of a logical operator belonging to a single
370 -- complex decision. This routine outputs the sequence of table entries
371 -- corresponding to the node. Note that we do not process the sub-
372 -- operands to look for further decisions, that processing is done in
373 -- Process_Decision_Operand, because we can't get decisions mixed up in
374 -- the global table. Call has no effect if N is Empty.
376 procedure Output_Element (N : Node_Id);
377 -- Node N is an operand of a logical operator that is not itself a
378 -- logical operator, or it is a simple decision. This routine outputs
379 -- the table entry for the element, with C1 set to ' '. Last is set
380 -- False, and an entry is made in the condition hash table.
382 procedure Output_Header (T : Character);
383 -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/
384 -- PRAGMA, and 'X' for the expression case.
386 procedure Process_Decision_Operand (N : Node_Id);
387 -- This is called on node N, the top level node of a decision, or on one
388 -- of its operands or suboperands after generating the full output for
389 -- the complex decision. It process the suboperands of the decision
390 -- looking for nested decisions.
392 -----------------------------
393 -- Output_Decision_Operand --
394 -----------------------------
396 procedure Output_Decision_Operand (N : Node_Id) is
406 elsif Is_Logical_Operator (N) then
407 if Nkind (N) = N_Op_Not then
414 if Nkind_In (N, N_Op_Or, N_Or_Else) then
428 Output_Decision_Operand (L);
429 Output_Decision_Operand (Right_Opnd (N));
431 -- Not a logical operator
436 end Output_Decision_Operand;
442 procedure Output_Element (N : Node_Id) is
446 Sloc_Range (N, FSloc, LSloc);
453 Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last);
460 procedure Output_Header (T : Character) is
461 Loc : Source_Ptr := No_Location;
462 -- Node whose sloc is used for the decision
466 when 'I' | 'E' | 'W' =>
468 -- For IF, EXIT, WHILE, the token SLOC can be found from
469 -- the SLOC of the parent of the expression.
471 Loc := Sloc (Parent (N));
475 -- For entry, the token sloc is from the N_Entry_Body. For
476 -- PRAGMA, we must get the location from the pragma node.
477 -- Argument N is the pragma argument, and we have to go up two
478 -- levels (through the pragma argument association) to get to
479 -- the pragma node itself.
481 Loc := Sloc (Parent (Parent (N)));
485 -- For an expression, no Sloc
489 -- No other possibilities
501 Pragma_Sloc => Pragma_Sloc);
504 ------------------------------
505 -- Process_Decision_Operand --
506 ------------------------------
508 procedure Process_Decision_Operand (N : Node_Id) is
510 if Is_Logical_Operator (N) then
511 if Nkind (N) /= N_Op_Not then
512 Process_Decision_Operand (Left_Opnd (N));
513 X_Not_Decision := False;
516 Process_Decision_Operand (Right_Opnd (N));
519 Process_Decisions (N, 'X', Pragma_Sloc);
521 end Process_Decision_Operand;
527 function Process_Node (N : Node_Id) return Traverse_Result is
531 -- Logical operators, output table entries and then process
532 -- operands recursively to deal with nested conditions.
542 -- If outer level, then type comes from call, otherwise it
543 -- is more deeply nested and counts as X for expression.
545 if N = Process_Decisions.N then
546 T := Process_Decisions.T;
551 -- Output header for sequence
553 X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
554 Mark := SCO_Table.Last;
557 -- Output the decision
559 Output_Decision_Operand (N);
561 -- If the decision was in an expression context (T = 'X')
562 -- and contained only NOT operators, then we don't output
565 if X_Not_Decision then
566 SCO_Table.Set_Last (Mark);
568 -- Otherwise, set Last in last table entry to mark end
571 SCO_Table.Table (SCO_Table.Last).Last := True;
574 -- Process any embedded decisions
576 Process_Decision_Operand (N);
582 when N_Case_Expression =>
585 -- Conditional expression, processed like an if statement
587 when N_Conditional_Expression =>
589 Cond : constant Node_Id := First (Expressions (N));
590 Thnx : constant Node_Id := Next (Cond);
591 Elsx : constant Node_Id := Next (Thnx);
593 Process_Decisions (Cond, 'I', Pragma_Sloc);
594 Process_Decisions (Thnx, 'X', Pragma_Sloc);
595 Process_Decisions (Elsx, 'X', Pragma_Sloc);
599 -- All other cases, continue scan
607 procedure Traverse is new Traverse_Proc (Process_Node);
609 -- Start of processing for Process_Decisions
616 -- See if we have simple decision at outer level and if so then
617 -- generate the decision entry for this simple decision. A simple
618 -- decision is a boolean expression (which is not a logical operator
619 -- or short circuit form) appearing as the operand of an IF, WHILE,
620 -- EXIT WHEN, or special PRAGMA construct.
622 if T /= 'X' and then not Is_Logical_Operator (N) then
626 -- Change Last in last table entry to True to mark end of
627 -- sequence, which is this case is only one element long.
629 SCO_Table.Table (SCO_Table.Last).Last := True;
633 end Process_Decisions;
641 procedure Write_Info_Char (C : Character) renames Write_Char;
642 -- Write one character;
644 procedure Write_Info_Initiate (Key : Character) renames Write_Char;
645 -- Start new one and write one character;
647 procedure Write_Info_Nat (N : Nat);
650 procedure Write_Info_Terminate renames Write_Eol;
651 -- Terminate current line
657 procedure Write_Info_Nat (N : Nat) is
662 procedure Debug_Put_SCOs is new Put_SCOs;
664 -- Start of processing for pscos
674 procedure SCO_Output is
676 if Debug_Flag_Dot_OO then
680 -- Sort the unit tables based on dependency numbers
682 Unit_Table_Sort : declare
684 function Lt (Op1, Op2 : Natural) return Boolean;
685 -- Comparison routine for sort call
687 procedure Move (From : Natural; To : Natural);
688 -- Move routine for sort call
694 function Lt (Op1, Op2 : Natural) return Boolean is
698 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
701 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
708 procedure Move (From : Natural; To : Natural) is
710 SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
711 SCO_Unit_Table.Table (SCO_Unit_Index (From));
712 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
713 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
716 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
718 -- Start of processing for Unit_Table_Sort
721 Sorting.Sort (Integer (SCO_Unit_Table.Last));
724 -- Loop through entries in the unit table to set file name and
725 -- dependency number entries.
727 for J in 1 .. SCO_Unit_Table.Last loop
729 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
730 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
732 Get_Name_String (Reference_Name (Source_Index (U)));
733 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
734 UTE.Dep_Num := Dependency_Num (U);
738 -- Now the tables are all setup for output to the ALI file
740 Write_SCOs_To_ALI_File;
743 -------------------------
744 -- SCO_Pragma_Disabled --
745 -------------------------
747 function SCO_Pragma_Disabled (Loc : Source_Ptr) return Boolean is
751 if Loc = No_Location then
755 Index := Condition_Pragma_Hash_Table.Get (Loc);
757 -- The test here for zero is to deal with possible previous errors, and
758 -- for the case of pragma statement SCOs, for which we always set the
759 -- Pragma_Sloc even if the particular pragma cannot be specifically
764 T : SCO_Table_Entry renames SCO_Table.Table (Index);
766 pragma Assert (T.C1 = 'S' or else T.C1 = 's');
773 end SCO_Pragma_Disabled;
779 procedure SCO_Record (U : Unit_Number_Type) is
784 -- Ignore call if not generating code and generating SCO's
786 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
790 -- Ignore call if this unit already recorded
792 for J in 1 .. SCO_Unit_Number_Table.Last loop
793 if U = SCO_Unit_Number_Table.Table (J) then
798 -- Otherwise record starting entry
800 From := SCO_Table.Last + 1;
802 -- Get Unit (checking case of subunit)
804 Lu := Unit (Cunit (U));
806 if Nkind (Lu) = N_Subunit then
807 Lu := Proper_Body (Lu);
813 when N_Protected_Body =>
814 Traverse_Protected_Body (Lu);
816 when N_Subprogram_Body | N_Task_Body =>
817 Traverse_Subprogram_Or_Task_Body (Lu);
819 when N_Subprogram_Declaration =>
820 Traverse_Subprogram_Declaration (Lu);
822 when N_Package_Declaration =>
823 Traverse_Package_Declaration (Lu);
825 when N_Package_Body =>
826 Traverse_Package_Body (Lu);
828 when N_Generic_Package_Declaration =>
829 Traverse_Generic_Package_Declaration (Lu);
831 when N_Generic_Instantiation =>
832 Traverse_Generic_Instantiation (Lu);
836 -- All other cases of compilation units (e.g. renamings), generate
837 -- no SCO information.
842 -- Make entry for new unit in unit tables, we will fill in the file
843 -- name and dependency numbers later.
845 SCO_Unit_Table.Append (
849 To => SCO_Table.Last));
851 SCO_Unit_Number_Table.Append (U);
854 -----------------------
855 -- Set_SCO_Condition --
856 -----------------------
858 procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is
859 Orig : constant Node_Id := Original_Node (Cond);
864 Constant_Condition_Code : constant array (Boolean) of Character :=
865 (False => 'f', True => 't');
867 Sloc_Range (Orig, Start, Dummy);
868 Index := Condition_Pragma_Hash_Table.Get (Start);
870 -- The test here for zero is to deal with possible previous errors
873 pragma Assert (SCO_Table.Table (Index).C1 = ' ');
874 SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val);
876 end Set_SCO_Condition;
878 ----------------------------
879 -- Set_SCO_Pragma_Enabled --
880 ----------------------------
882 procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is
886 -- Note: the reason we use the Sloc value as the key is that in the
887 -- generic case, the call to this procedure is made on a copy of the
888 -- original node, so we can't use the Node_Id value.
890 Index := Condition_Pragma_Hash_Table.Get (Loc);
892 -- The test here for zero is to deal with possible previous errors
896 T : SCO_Table_Entry renames SCO_Table.Table (Index);
899 -- Called multiple times for the same sloc (need to allow for
902 pragma Assert ((T.C1 = 'S' or else T.C1 = 's')
904 (T.C2 = 'p' or else T.C2 = 'P'));
908 end Set_SCO_Pragma_Enabled;
910 ---------------------
911 -- Set_Table_Entry --
912 ---------------------
914 procedure Set_Table_Entry
920 Pragma_Sloc : Source_Ptr := No_Location;
921 Pragma_Name : Pragma_Id := Unknown_Pragma)
923 function To_Source_Location (S : Source_Ptr) return Source_Location;
924 -- Converts Source_Ptr value to Source_Location (line/col) format
926 ------------------------
927 -- To_Source_Location --
928 ------------------------
930 function To_Source_Location (S : Source_Ptr) return Source_Location is
932 if S = No_Location then
933 return No_Source_Location;
936 (Line => Get_Logical_Line_Number (S),
937 Col => Get_Column_Number (S));
939 end To_Source_Location;
941 -- Start of processing for Set_Table_Entry
947 From => To_Source_Location (From),
948 To => To_Source_Location (To),
950 Pragma_Sloc => Pragma_Sloc,
951 Pragma_Name => Pragma_Name));
954 -----------------------------------------
955 -- Traverse_Declarations_Or_Statements --
956 -----------------------------------------
958 -- Tables used by Traverse_Declarations_Or_Statements for temporarily
959 -- holding statement and decision entries. These are declared globally
960 -- since they are shared by recursive calls to this procedure.
962 type SC_Entry is record
968 -- Used to store a single entry in the following table, From:To represents
969 -- the range of entries in the CS line entry, and typ is the type, with
970 -- space meaning that no type letter will accompany the entry.
972 package SC is new Table.Table (
973 Table_Component_Type => SC_Entry,
974 Table_Index_Type => Nat,
975 Table_Low_Bound => 1,
976 Table_Initial => 1000,
977 Table_Increment => 200,
978 Table_Name => "SCO_SC");
979 -- Used to store statement components for a CS entry to be output
980 -- as a result of the call to this procedure. SC.Last is the last
981 -- entry stored, so the current statement sequence is represented
982 -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on
983 -- entry to each recursive call to the routine.
985 -- Extend_Statement_Sequence adds an entry to this array, and then
986 -- Set_Statement_Entry clears the entries starting with SC_First,
987 -- copying these entries to the main SCO output table. The reason that
988 -- we do the temporary caching of results in this array is that we want
989 -- the SCO table entries for a given CS line to be contiguous, and the
990 -- processing may output intermediate entries such as decision entries.
992 type SD_Entry is record
998 -- Used to store a single entry in the following table. Nod is the node to
999 -- be searched for decisions for the case of Process_Decisions_Defer with a
1000 -- node argument (with Lst set to No_List. Lst is the list to be searched
1001 -- for decisions for the case of Process_Decisions_Defer with a List
1002 -- argument (in which case Nod is set to Empty). Plo is the sloc of the
1003 -- enclosing pragma, if any.
1005 package SD is new Table.Table (
1006 Table_Component_Type => SD_Entry,
1007 Table_Index_Type => Nat,
1008 Table_Low_Bound => 1,
1009 Table_Initial => 1000,
1010 Table_Increment => 200,
1011 Table_Name => "SCO_SD");
1012 -- Used to store possible decision information. Instead of calling the
1013 -- Process_Decisions procedures directly, we call Process_Decisions_Defer,
1014 -- which simply stores the arguments in this table. Then when we clear
1015 -- out a statement sequence using Set_Statement_Entry, after generating
1016 -- the CS lines for the statements, the entries in this table result in
1017 -- calls to Process_Decision. The reason for doing things this way is to
1018 -- ensure that decisions are output after the CS line for the statements
1019 -- in which the decisions occur.
1021 procedure Traverse_Declarations_Or_Statements (L : List_Id) is
1025 SC_First : constant Nat := SC.Last + 1;
1026 SD_First : constant Nat := SD.Last + 1;
1027 -- Record first entries used in SC/SD at this recursive level
1029 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
1030 -- Extend the current statement sequence to encompass the node N. Typ
1031 -- is the letter that identifies the type of statement/declaration that
1032 -- is being added to the sequence.
1034 procedure Extend_Statement_Sequence
1038 -- This version extends the current statement sequence with an entry
1039 -- that starts with the first token of From, and ends with the last
1040 -- token of To. It is used for example in a CASE statement to cover
1041 -- the range from the CASE token to the last token of the expression.
1043 procedure Set_Statement_Entry;
1044 -- If Start is No_Location, does nothing, otherwise outputs a SCO_Table
1045 -- statement entry for the range Start-Stop and then sets both Start
1046 -- and Stop to No_Location.
1047 -- What are Start and Stop??? This comment seems completely unrelated
1048 -- to the implementation!???
1049 -- Unconditionally sets Term to True. What is Term???
1050 -- This is called when we find a statement or declaration that generates
1051 -- its own table entry, so that we must end the current statement
1054 procedure Process_Decisions_Defer (N : Node_Id; T : Character);
1055 pragma Inline (Process_Decisions_Defer);
1056 -- This routine is logically the same as Process_Decisions, except that
1057 -- the arguments are saved in the SD table, for later processing when
1058 -- Set_Statement_Entry is called, which goes through the saved entries
1059 -- making the corresponding calls to Process_Decision.
1061 procedure Process_Decisions_Defer (L : List_Id; T : Character);
1062 pragma Inline (Process_Decisions_Defer);
1063 -- Same case for list arguments, deferred call to Process_Decisions
1065 -------------------------
1066 -- Set_Statement_Entry --
1067 -------------------------
1069 procedure Set_Statement_Entry is
1071 SC_Last : constant Int := SC.Last;
1072 SD_Last : constant Int := SD.Last;
1075 -- Output statement entries from saved entries in SC table
1077 for J in SC_First .. SC_Last loop
1078 if J = SC_First then
1085 SCE : SC_Entry renames SC.Table (J);
1086 Pragma_Sloc : Source_Ptr := No_Location;
1087 Pragma_Name : Pragma_Id := Unknown_Pragma;
1089 -- For the case of a statement SCO for a pragma controlled by
1090 -- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
1091 -- those of any nested decision) is emitted only if the pragma
1094 if SCE.Typ = 'p' then
1095 Pragma_Sloc := SCE.From;
1096 Condition_Pragma_Hash_Table.Set
1097 (Pragma_Sloc, SCO_Table.Last + 1);
1098 Pragma_Name := Get_Pragma_Id (Sinfo.Pragma_Name (SCE.N));
1100 elsif SCE.Typ = 'P' then
1101 Pragma_Name := Get_Pragma_Id (Sinfo.Pragma_Name (SCE.N));
1109 Last => (J = SC_Last),
1110 Pragma_Sloc => Pragma_Sloc,
1111 Pragma_Name => Pragma_Name);
1115 -- Clear out used section of SC table
1117 SC.Set_Last (SC_First - 1);
1119 -- Output any embedded decisions
1121 for J in SD_First .. SD_Last loop
1123 SDE : SD_Entry renames SD.Table (J);
1125 if Present (SDE.Nod) then
1126 Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
1128 Process_Decisions (SDE.Lst, SDE.Typ, SDE.Plo);
1133 -- Clear out used section of SD table
1135 SD.Set_Last (SD_First - 1);
1136 end Set_Statement_Entry;
1138 -------------------------------
1139 -- Extend_Statement_Sequence --
1140 -------------------------------
1142 procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
1146 Sloc_Range (N, F, T);
1147 SC.Append ((N, F, T, Typ));
1148 end Extend_Statement_Sequence;
1150 procedure Extend_Statement_Sequence
1158 Sloc_Range (From, F, Dummy);
1159 Sloc_Range (To, Dummy, T);
1160 SC.Append ((From, F, T, Typ));
1161 end Extend_Statement_Sequence;
1163 -----------------------------
1164 -- Process_Decisions_Defer --
1165 -----------------------------
1167 procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
1169 SD.Append ((N, No_List, T, Current_Pragma_Sloc));
1170 end Process_Decisions_Defer;
1172 procedure Process_Decisions_Defer (L : List_Id; T : Character) is
1174 SD.Append ((Empty, L, T, Current_Pragma_Sloc));
1175 end Process_Decisions_Defer;
1177 -- Start of processing for Traverse_Declarations_Or_Statements
1180 if Is_Non_Empty_List (L) then
1182 -- Loop through statements or declarations
1185 while Present (N) loop
1187 -- Initialize or extend current statement sequence. Note that for
1188 -- special cases such as IF and Case statements we will modify
1189 -- the range to exclude internal statements that should not be
1190 -- counted as part of the current statement sequence.
1194 -- Package declaration
1196 when N_Package_Declaration =>
1197 Set_Statement_Entry;
1198 Traverse_Package_Declaration (N);
1200 -- Generic package declaration
1202 when N_Generic_Package_Declaration =>
1203 Set_Statement_Entry;
1204 Traverse_Generic_Package_Declaration (N);
1208 when N_Package_Body =>
1209 Set_Statement_Entry;
1210 Traverse_Package_Body (N);
1212 -- Subprogram declaration
1214 when N_Subprogram_Declaration =>
1215 Process_Decisions_Defer
1216 (Parameter_Specifications (Specification (N)), 'X');
1218 -- Generic subprogram declaration
1220 when N_Generic_Subprogram_Declaration =>
1221 Process_Decisions_Defer
1222 (Generic_Formal_Declarations (N), 'X');
1223 Process_Decisions_Defer
1224 (Parameter_Specifications (Specification (N)), 'X');
1226 -- Task or subprogram body
1228 when N_Task_Body | N_Subprogram_Body =>
1229 Set_Statement_Entry;
1230 Traverse_Subprogram_Or_Task_Body (N);
1234 when N_Entry_Body =>
1236 Cond : constant Node_Id :=
1237 Condition (Entry_Body_Formal_Part (N));
1240 Set_Statement_Entry;
1242 if Present (Cond) then
1243 Process_Decisions_Defer (Cond, 'G');
1246 Traverse_Subprogram_Or_Task_Body (N);
1251 when N_Protected_Body =>
1252 Set_Statement_Entry;
1253 Traverse_Protected_Body (N);
1255 -- Exit statement, which is an exit statement in the SCO sense,
1256 -- so it is included in the current statement sequence, but
1257 -- then it terminates this sequence. We also have to process
1258 -- any decisions in the exit statement expression.
1260 when N_Exit_Statement =>
1261 Extend_Statement_Sequence (N, ' ');
1262 Process_Decisions_Defer (Condition (N), 'E');
1263 Set_Statement_Entry;
1265 -- Label, which breaks the current statement sequence, but the
1266 -- label itself is not included in the next statement sequence,
1267 -- since it generates no code.
1270 Set_Statement_Entry;
1272 -- Block statement, which breaks the current statement sequence
1274 when N_Block_Statement =>
1275 Set_Statement_Entry;
1276 Traverse_Declarations_Or_Statements (Declarations (N));
1277 Traverse_Handled_Statement_Sequence
1278 (Handled_Statement_Sequence (N));
1280 -- If statement, which breaks the current statement sequence,
1281 -- but we include the condition in the current sequence.
1283 when N_If_Statement =>
1284 Extend_Statement_Sequence (N, Condition (N), 'I');
1285 Process_Decisions_Defer (Condition (N), 'I');
1286 Set_Statement_Entry;
1288 -- Now we traverse the statements in the THEN part
1290 Traverse_Declarations_Or_Statements (Then_Statements (N));
1292 -- Loop through ELSIF parts if present
1294 if Present (Elsif_Parts (N)) then
1296 Elif : Node_Id := First (Elsif_Parts (N));
1299 while Present (Elif) loop
1301 -- We generate a statement sequence for the
1302 -- construct "ELSIF condition", so that we have
1303 -- a statement for the resulting decisions.
1305 Extend_Statement_Sequence
1306 (Elif, Condition (Elif), 'I');
1307 Process_Decisions_Defer (Condition (Elif), 'I');
1308 Set_Statement_Entry;
1310 -- Traverse the statements in the ELSIF
1312 Traverse_Declarations_Or_Statements
1313 (Then_Statements (Elif));
1319 -- Finally traverse the ELSE statements if present
1321 Traverse_Declarations_Or_Statements (Else_Statements (N));
1323 -- Case statement, which breaks the current statement sequence,
1324 -- but we include the expression in the current sequence.
1326 when N_Case_Statement =>
1327 Extend_Statement_Sequence (N, Expression (N), 'C');
1328 Process_Decisions_Defer (Expression (N), 'X');
1329 Set_Statement_Entry;
1331 -- Process case branches
1336 Alt := First (Alternatives (N));
1337 while Present (Alt) loop
1338 Traverse_Declarations_Or_Statements (Statements (Alt));
1343 -- Unconditional exit points, which are included in the current
1344 -- statement sequence, but then terminate it
1346 when N_Requeue_Statement |
1348 N_Raise_Statement =>
1349 Extend_Statement_Sequence (N, ' ');
1350 Set_Statement_Entry;
1352 -- Simple return statement. which is an exit point, but we
1353 -- have to process the return expression for decisions.
1355 when N_Simple_Return_Statement =>
1356 Extend_Statement_Sequence (N, ' ');
1357 Process_Decisions_Defer (Expression (N), 'X');
1358 Set_Statement_Entry;
1360 -- Extended return statement
1362 when N_Extended_Return_Statement =>
1363 Extend_Statement_Sequence
1364 (N, Last (Return_Object_Declarations (N)), 'R');
1365 Process_Decisions_Defer
1366 (Return_Object_Declarations (N), 'X');
1367 Set_Statement_Entry;
1369 Traverse_Handled_Statement_Sequence
1370 (Handled_Statement_Sequence (N));
1372 -- Loop ends the current statement sequence, but we include
1373 -- the iteration scheme if present in the current sequence.
1374 -- But the body of the loop starts a new sequence, since it
1375 -- may not be executed as part of the current sequence.
1377 when N_Loop_Statement =>
1378 if Present (Iteration_Scheme (N)) then
1380 -- If iteration scheme present, extend the current
1381 -- statement sequence to include the iteration scheme
1382 -- and process any decisions it contains.
1385 ISC : constant Node_Id := Iteration_Scheme (N);
1390 if Present (Condition (ISC)) then
1391 Extend_Statement_Sequence (N, ISC, 'W');
1392 Process_Decisions_Defer (Condition (ISC), 'W');
1397 Extend_Statement_Sequence (N, ISC, 'F');
1398 Process_Decisions_Defer
1399 (Loop_Parameter_Specification (ISC), 'X');
1404 Set_Statement_Entry;
1405 Traverse_Declarations_Or_Statements (Statements (N));
1411 -- Record sloc of pragma (pragmas don't nest)
1413 pragma Assert (Current_Pragma_Sloc = No_Location);
1414 Current_Pragma_Sloc := Sloc (N);
1416 -- Processing depends on the kind of pragma
1419 Nam : constant Name_Id := Pragma_Name (N);
1420 Arg : Node_Id := First (Pragma_Argument_Associations (N));
1428 Name_Postcondition =>
1430 -- For Assert/Check/Precondition/Postcondition, we
1431 -- must generate a P entry for the decision. Note
1432 -- that this is done unconditionally at this stage.
1433 -- Output for disabled pragmas is suppressed later
1434 -- on when we output the decision line in Put_SCOs,
1435 -- depending on setting by Set_SCO_Pragma_Enabled.
1437 if Nam = Name_Check then
1441 Process_Decisions_Defer (Expression (Arg), 'P');
1445 if Present (Arg) and then Present (Next (Arg)) then
1447 -- Case of a dyadic pragma Debug: first argument
1448 -- is a P decision, any nested decision in the
1449 -- second argument is an X decision.
1451 Process_Decisions_Defer (Expression (Arg), 'P');
1455 Process_Decisions_Defer (Expression (Arg), 'X');
1458 -- For all other pragmas, we generate decision entries
1459 -- for any embedded expressions, and the pragma is
1463 Process_Decisions_Defer (N, 'X');
1467 -- Add statement SCO
1469 Extend_Statement_Sequence (N, Typ);
1471 Current_Pragma_Sloc := No_Location;
1474 -- Object declaration. Ignored if Prev_Ids is set, since the
1475 -- parser generates multiple instances of the whole declaration
1476 -- if there is more than one identifier declared, and we only
1477 -- want one entry in the SCO's, so we take the first, for which
1478 -- Prev_Ids is False.
1480 when N_Object_Declaration =>
1481 if not Prev_Ids (N) then
1482 Extend_Statement_Sequence (N, 'o');
1484 if Has_Decision (N) then
1485 Process_Decisions_Defer (N, 'X');
1489 -- All other cases, which extend the current statement sequence
1490 -- but do not terminate it, even if they have nested decisions.
1494 -- Determine required type character code, or ASCII.NUL if
1495 -- no SCO should be generated for this node.
1502 when N_Full_Type_Declaration |
1503 N_Incomplete_Type_Declaration |
1504 N_Private_Type_Declaration |
1505 N_Private_Extension_Declaration =>
1508 when N_Subtype_Declaration =>
1511 when N_Renaming_Declaration =>
1514 when N_Generic_Instantiation =>
1517 when N_Representation_Clause |
1518 N_Use_Package_Clause |
1519 N_Use_Type_Clause =>
1526 if Typ /= ASCII.NUL then
1527 Extend_Statement_Sequence (N, Typ);
1531 -- Process any embedded decisions
1533 if Has_Decision (N) then
1534 Process_Decisions_Defer (N, 'X');
1541 Set_Statement_Entry;
1543 end Traverse_Declarations_Or_Statements;
1545 ------------------------------------
1546 -- Traverse_Generic_Instantiation --
1547 ------------------------------------
1549 procedure Traverse_Generic_Instantiation (N : Node_Id) is
1554 -- First we need a statement entry to cover the instantiation
1556 Sloc_Range (N, First, Last);
1564 -- Now output any embedded decisions
1566 Process_Decisions (N, 'X', No_Location);
1567 end Traverse_Generic_Instantiation;
1569 ------------------------------------------
1570 -- Traverse_Generic_Package_Declaration --
1571 ------------------------------------------
1573 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
1575 Process_Decisions (Generic_Formal_Declarations (N), 'X', No_Location);
1576 Traverse_Package_Declaration (N);
1577 end Traverse_Generic_Package_Declaration;
1579 -----------------------------------------
1580 -- Traverse_Handled_Statement_Sequence --
1581 -----------------------------------------
1583 procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
1587 -- For package bodies without a statement part, the parser adds an empty
1588 -- one, to normalize the representation. The null statement therein,
1589 -- which does not come from source, does not get a SCO.
1591 if Present (N) and then Comes_From_Source (N) then
1592 Traverse_Declarations_Or_Statements (Statements (N));
1594 if Present (Exception_Handlers (N)) then
1595 Handler := First (Exception_Handlers (N));
1596 while Present (Handler) loop
1597 Traverse_Declarations_Or_Statements (Statements (Handler));
1602 end Traverse_Handled_Statement_Sequence;
1604 ---------------------------
1605 -- Traverse_Package_Body --
1606 ---------------------------
1608 procedure Traverse_Package_Body (N : Node_Id) is
1610 Traverse_Declarations_Or_Statements (Declarations (N));
1611 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1612 end Traverse_Package_Body;
1614 ----------------------------------
1615 -- Traverse_Package_Declaration --
1616 ----------------------------------
1618 procedure Traverse_Package_Declaration (N : Node_Id) is
1619 Spec : constant Node_Id := Specification (N);
1621 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
1622 Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
1623 end Traverse_Package_Declaration;
1625 -----------------------------
1626 -- Traverse_Protected_Body --
1627 -----------------------------
1629 procedure Traverse_Protected_Body (N : Node_Id) is
1631 Traverse_Declarations_Or_Statements (Declarations (N));
1632 end Traverse_Protected_Body;
1634 --------------------------------------
1635 -- Traverse_Subprogram_Or_Task_Body --
1636 --------------------------------------
1638 procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id) is
1640 Traverse_Declarations_Or_Statements (Declarations (N));
1641 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1642 end Traverse_Subprogram_Or_Task_Body;
1644 -------------------------------------
1645 -- Traverse_Subprogram_Declaration --
1646 -------------------------------------
1648 procedure Traverse_Subprogram_Declaration (N : Node_Id) is
1649 ADN : constant Node_Id := Aux_Decls_Node (Parent (N));
1651 Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
1652 Traverse_Declarations_Or_Statements (Declarations (ADN));
1653 Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
1654 end Traverse_Subprogram_Declaration;