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 Nlists; use Nlists;
31 with Output; use Output;
32 with Sinfo; use Sinfo;
33 with Sinput; use Sinput;
36 with GNAT.HTable; use GNAT.HTable;
38 package body Par_SCO is
44 -- Internal table used to store recorded SCO values. Table is populated by
45 -- calls to SCO_Record, and entries may be modified by Set_SCO_Condition.
47 type SCO_Table_Entry is record
55 package SCO_Table is new Table.Table (
56 Table_Component_Type => SCO_Table_Entry,
57 Table_Index_Type => Nat,
60 Table_Increment => 300,
61 Table_Name => "SCO_Table_Entry");
63 -- The SCO_Table_Entry values appear as follows:
68 -- From = starting sloc
75 -- From = starting sloc
82 -- From = starting sloc
87 -- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression)
88 -- C2 = 'c', 't', or 'f'
89 -- From = starting sloc
94 -- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression)
101 -- C1 = '!', '^', '&', '|'
103 -- From = No_Location
109 -- C2 = 'c', 't', or 'f' (condition/true/false)
110 -- From = starting sloc
112 -- Last = False for all but the last entry, True for last entry
114 -- Note: the sequence starting with a decision, and continuing with
115 -- operators and elements up to and including the first one labeled with
116 -- Last=True, indicate the sequence to be output for a complex decision
117 -- on a single CD decision line.
123 -- This table keeps track of the units and the corresponding starting index
124 -- in the SCO table. The ending index is either one less than the starting
125 -- index of the next table entry, or, for the last table entry, it is
128 type SCO_Unit_Table_Entry is record
129 Unit : Unit_Number_Type;
133 package SCO_Unit_Table is new Table.Table (
134 Table_Component_Type => SCO_Unit_Table_Entry,
135 Table_Index_Type => Int,
136 Table_Low_Bound => 1,
138 Table_Increment => 200,
139 Table_Name => "SCO_Unit_Table_Entry");
141 --------------------------
142 -- Condition Hash Table --
143 --------------------------
145 -- We need to be able to get to conditions quickly for handling the calls
146 -- to Set_SCO_Condition efficiently. For this purpose we identify the
147 -- conditions in the table by their starting sloc, and use the following
148 -- hash table to map from these starting sloc values to SCO_Table indexes.
150 type Header_Num is new Integer range 0 .. 996;
151 -- Type for hash table headers
153 function Hash (F : Source_Ptr) return Header_Num;
154 -- Function to Hash source pointer value
156 function Equal (F1, F2 : Source_Ptr) return Boolean;
157 -- Function to test two keys for equality
159 package Condition_Hash_Table is new Simple_HTable
160 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
161 -- The actual hash table
163 --------------------------
164 -- Internal Subprograms --
165 --------------------------
167 function Has_Decision (N : Node_Id) return Boolean;
168 -- N is the node for a subexpression. Returns True if the subexpression
169 -- contains a nested decision (i.e. either is a logical operator, or
170 -- contains a logical operator in its subtree).
172 function Is_Logical_Operator (N : Node_Id) return Boolean;
173 -- N is the node for a subexpression. This procedure just tests N to see
174 -- if it is a logical operator (including short circuit conditions) and
175 -- returns True if so, False otherwise, it does no other processing.
177 procedure Process_Decisions (N : Node_Id; T : Character);
178 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
179 -- to output any decisions it contains. T is one of IEWX (for context of
180 -- expresion: if/while/when-exit/expression). If T is other than X, then
181 -- the node is always a decision a decision is always present (at the very
182 -- least a simple decision is present at the top level).
184 procedure Set_Table_Entry
190 -- Append an entry to SCO_Table with fields set as per arguments
192 procedure Traverse_Declarations_Or_Statements (L : List_Id);
193 procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
194 procedure Traverse_Package_Body (N : Node_Id);
195 procedure Traverse_Package_Declaration (N : Node_Id);
196 procedure Traverse_Subprogram_Body (N : Node_Id);
197 -- Traverse the corresponding construct, generating SCO table entries
200 -- Debug routine to dump SCO table
208 Write_Line ("SCO Unit Table");
209 Write_Line ("--------------");
211 for Index in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop
214 Write_Str (". Unit = ");
215 Write_Int (Int (SCO_Unit_Table.Table (Index).Unit));
216 Write_Str (" Index = ");
217 Write_Int (Int (SCO_Unit_Table.Table (Index).Index));
222 Write_Line ("SCO Table");
223 Write_Line ("---------");
225 for Index in SCO_Table.First .. SCO_Table.Last loop
227 T : SCO_Table_Entry renames SCO_Table.Table (Index);
232 Write_Str (". C1 = '");
234 Write_Str ("' C2 = '");
236 Write_Str ("' From = ");
237 Write_Location (T.From);
238 Write_Str (" To = ");
239 Write_Location (T.To);
240 Write_Str (" Last = ");
245 Write_Str (" False");
257 function Equal (F1, F2 : Source_Ptr) return Boolean is
266 function Has_Decision (N : Node_Id) return Boolean is
268 function Check_Node (N : Node_Id) return Traverse_Result;
274 function Check_Node (N : Node_Id) return Traverse_Result is
276 if Is_Logical_Operator (N) then
283 function Traverse is new Traverse_Func (Check_Node);
285 -- Start of processing for Has_Decision
288 return Traverse (N) = Abandon;
295 function Hash (F : Source_Ptr) return Header_Num is
297 return Header_Num (Nat (F) mod 997);
309 -------------------------
310 -- Is_Logical_Operator --
311 -------------------------
313 function Is_Logical_Operator (N : Node_Id) return Boolean is
315 return Nkind_In (N, N_Op_And,
321 end Is_Logical_Operator;
323 -----------------------
324 -- Process_Decisions --
325 -----------------------
327 procedure Process_Decisions
331 function Process_Node (N : Node_Id) return Traverse_Result;
332 -- Processes one node in the traversal, looking for logical operators,
333 -- and if one is found, outputs the appropriate table entries.
335 procedure Output_Decision_Operand (N : Node_Id);
336 -- The node N is the top level logical operator of a decision, or it is
337 -- one of the operands of a logical operator belonging to a single
338 -- complex decision. This routine outputs the sequence of table entries
339 -- corresponding to the node. Note that we do not process the sub-
340 -- operands to look for further decisions, that processing is done in
341 -- Process_Decision_Operand, because we can't get decisions mixed up in
342 -- the global table. Call has no effect if N is Empty.
344 procedure Output_Element (N : Node_Id; T : Character);
345 -- Node N is an operand of a logical operator that is not itself a
346 -- logical operator, or it is a simple decision. This routine outputs
347 -- the table entry for the element, with C1 set to T (' ' for one of
348 -- the elements of a complex decision, or 'I'/'W'/'E' for a simple
349 -- decision (from an IF, WHILE, or EXIT WHEN). Last is set to False,
350 -- and an entry is made in the condition hash table.
352 procedure Process_Decision_Operand (N : Node_Id);
353 -- This is called on node N, the top level node of a decision, or on one
354 -- of its operands or suboperands after generating the full output for
355 -- the complex decision. It process the suboperands of the decision
356 -- looking for nested decisions.
358 -----------------------------
359 -- Output_Decision_Operand --
360 -----------------------------
362 procedure Output_Decision_Operand (N : Node_Id) is
375 elsif Is_Logical_Operator (N) then
376 if Nkind (N) = N_Op_Not then
383 if Nkind (N) = N_Op_Xor then
385 elsif Nkind_In (N, N_Op_Or, N_Or_Else) then
392 Sloc_Range (N, FSloc, LSloc);
393 Set_Table_Entry (C, ' ', FSloc, LSloc, False);
395 Output_Decision_Operand (L);
396 Output_Decision_Operand (Right_Opnd (N));
398 -- Not a logical operator
401 Output_Element (N, ' ');
403 end Output_Decision_Operand;
409 procedure Output_Element (N : Node_Id; T : Character) is
413 Sloc_Range (N, FSloc, LSloc);
414 Set_Table_Entry (T, 'c', FSloc, LSloc, False);
415 Condition_Hash_Table.Set (FSloc, SCO_Table.Last);
418 ------------------------------
419 -- Process_Decision_Operand --
420 ------------------------------
422 procedure Process_Decision_Operand (N : Node_Id) is
424 if Is_Logical_Operator (N) then
425 if Nkind (N) /= N_Op_Not then
426 Process_Decision_Operand (Left_Opnd (N));
429 Process_Decision_Operand (Right_Opnd (N));
432 Process_Decisions (N, 'X');
434 end Process_Decision_Operand;
440 function Process_Node (N : Node_Id) return Traverse_Result is
444 -- Logical operators and short circuit forms, output table
445 -- entries and then process operands recursively to deal with
446 -- nested conditions.
459 -- If outer level, then type comes from call, otherwise it
460 -- is more deeply nested and counts as X for expression.
462 if N = Process_Decisions.N then
463 T := Process_Decisions.T;
468 -- Output header for sequence
470 Set_Table_Entry (T, ' ', No_Location, No_Location, False);
472 -- Output the decision
474 Output_Decision_Operand (N);
476 -- Change Last in last table entry to True to mark end
478 SCO_Table.Table (SCO_Table.Last).Last := True;
480 -- Process any embedded decisions
482 Process_Decision_Operand (N);
486 -- Conditional expression, processed like an if statement
488 when N_Conditional_Expression =>
490 Cond : constant Node_Id := First (Expressions (N));
491 Thnx : constant Node_Id := Next (Cond);
492 Elsx : constant Node_Id := Next (Thnx);
494 Process_Decisions (Cond, 'I');
495 Process_Decisions (Thnx, 'X');
496 Process_Decisions (Elsx, 'X');
500 -- All other cases, continue scan
508 procedure Traverse is new Traverse_Proc (Process_Node);
510 -- Start of processing for Process_Decisions
517 -- See if we have simple decision at outer level and if so then
518 -- generate the decision entry for this simple decision. A simple
519 -- decision is a boolean expression (which is not a logical operator
520 -- or short circuit form) appearing as the operand of an IF, WHILE
521 -- or EXIT WHEN construct.
523 if T /= 'X' and then not Is_Logical_Operator (N) then
524 Output_Element (N, T);
526 -- Change Last in last table entry to True to mark end of
527 -- sequence, which is this case is only one element long.
529 SCO_Table.Table (SCO_Table.Last).Last := True;
533 end Process_Decisions;
539 procedure SCO_Output is
542 U : Unit_Number_Type;
544 procedure Output_Range (From : Source_Ptr; To : Source_Ptr);
545 -- Outputs Sloc range in line:col-line:col format (for now we do not
546 -- worry about generic instantiations???)
552 procedure Output_Range (From : Source_Ptr; To : Source_Ptr) is
554 Write_Info_Nat (Int (Get_Logical_Line_Number (From)));
555 Write_Info_Char (':');
556 Write_Info_Nat (Int (Get_Column_Number (From)));
557 Write_Info_Char ('-');
558 Write_Info_Nat (Int (Get_Logical_Line_Number (To)));
559 Write_Info_Char (':');
560 Write_Info_Nat (Int (Get_Column_Number (To)));
563 -- Start of processing for SCO_Output
566 if Debug_Flag_Dot_OO then
570 -- Loop through entries in the unit table
572 for J in SCO_Unit_Table.First .. SCO_Unit_Table.Last loop
573 U := SCO_Unit_Table.Table (J).Unit;
575 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
576 Write_Info_Initiate ('C');
577 Write_Info_Char (' ');
578 Write_Info_Nat (Dependency_Num (U));
579 Write_Info_Char (' ');
580 Write_Info_Name (Reference_Name (Source_Index (U)));
581 Write_Info_Terminate;
583 Start := SCO_Unit_Table.Table (J).Index;
585 if J = SCO_Unit_Table.Last then
586 Stop := SCO_Table.Last;
588 Stop := SCO_Unit_Table.Table (J + 1).Index - 1;
591 -- Loop through relevant entries in SCO table, outputting C lines
593 while Start <= Stop loop
595 T : SCO_Table_Entry renames SCO_Table.Table (Start);
598 Write_Info_Initiate ('C');
599 Write_Info_Char (T.C1);
603 -- Statements, entry, exit
605 when 'S' | 'Y' | 'T' =>
606 Write_Info_Char (' ');
607 Output_Range (T.From, T.To);
611 when 'I' | 'E' | 'W' | 'X' =>
616 -- Loop through table entries for this decision
620 T : SCO_Table_Entry renames SCO_Table.Table (Start);
623 Write_Info_Char (' ');
625 if T.C1 = '!' or else
630 Write_Info_Char (T.C1);
633 Write_Info_Char (T.C2);
634 Output_Range (T.From, T.To);
646 Write_Info_Terminate;
649 exit when Start = Stop;
652 pragma Assert (Start <= Stop);
662 procedure SCO_Record (U : Unit_Number_Type) is
663 Cu : constant Node_Id := Cunit (U);
664 Lu : constant Node_Id := Unit (Cu);
667 SCO_Unit_Table.Append ((Unit => U, Index => SCO_Table.Last + 1));
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 -- Ignore subprogram specifications, since nothing to cover.
681 -- Also ignore instantiations, since again, nothing to cover.
682 -- Also for now, ignore generic declarations ???
689 -----------------------
690 -- Set_SCO_Condition --
691 -----------------------
693 procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is
694 Index : constant Nat := Condition_Hash_Table.Get (First_Loc);
697 SCO_Table.Table (Index).C2 := Typ;
699 end Set_SCO_Condition;
701 ---------------------
702 -- Set_Table_Entry --
703 ---------------------
705 procedure Set_Table_Entry
713 SCO_Table.Append ((C1 => C1,
720 -----------------------------------------
721 -- Traverse_Declarations_Or_Statements --
722 -----------------------------------------
724 procedure Traverse_Declarations_Or_Statements (L : List_Id) is
733 -- Set False if current entity terminates statement list
735 procedure Set_Statement_Entry;
736 -- If Start is No_Location, does nothing, otherwise outputs a SCO_Table
737 -- statement entry for the range Start-Stop and then sets both Start
738 -- and Stop to No_Location. Unconditionally sets Term to True. This is
739 -- called when we find a statement or declaration that generates its
740 -- own table entry, so that we must end the current statement sequence.
742 -------------------------
743 -- Set_Statement_Entry --
744 -------------------------
746 procedure Set_Statement_Entry is
750 if Start /= No_Location then
751 Set_Table_Entry ('S', ' ', Start, Stop, False);
752 Start := No_Location;
755 end Set_Statement_Entry;
757 -- Start of processing for Traverse_Declarations_Or_Statements
760 if Is_Non_Empty_List (L) then
762 Start := No_Location;
764 -- Loop through statements or declarations
766 while Present (N) loop
771 -- Package declaration
773 when N_Package_Declaration =>
775 Traverse_Package_Declaration (N);
779 when N_Package_Body =>
781 Traverse_Package_Body (N);
785 when N_Subprogram_Body =>
787 Traverse_Subprogram_Body (N);
791 when N_Exit_Statement =>
793 Process_Decisions (Condition (N), 'E');
795 -- This is an exit point
797 Sloc_Range (N, From, To);
798 Set_Table_Entry ('T', ' ', From, To, False);
802 when N_Block_Statement =>
804 Traverse_Declarations_Or_Statements (Declarations (N));
805 Traverse_Handled_Statement_Sequence
806 (Handled_Statement_Sequence (N));
810 when N_If_Statement =>
812 Process_Decisions (Condition (N), 'I');
813 Traverse_Declarations_Or_Statements (Then_Statements (N));
815 if Present (Elsif_Parts (N)) then
817 Elif : Node_Id := First (Elsif_Parts (N));
819 while Present (Elif) loop
820 Process_Decisions (Condition (Elif), 'I');
821 Traverse_Declarations_Or_Statements
822 (Then_Statements (Elif));
828 Traverse_Declarations_Or_Statements (Else_Statements (N));
830 -- Unconditional exit points
832 when N_Requeue_Statement |
836 Sloc_Range (N, From, To);
837 Set_Table_Entry ('T', ' ', From, To, False);
839 -- Simple return statement
841 when N_Simple_Return_Statement =>
844 -- Process possible return expression
846 Process_Decisions (Expression (N), 'X');
848 -- Return is an exit point
850 Sloc_Range (N, From, To);
851 Set_Table_Entry ('T', ' ', From, To, False);
853 -- Extended return statement
855 when N_Extended_Return_Statement =>
857 Traverse_Declarations_Or_Statements
858 (Return_Object_Declarations (N));
859 Traverse_Handled_Statement_Sequence
860 (Handled_Statement_Sequence (N));
862 -- Return is an exit point
864 Sloc_Range (N, From, To);
865 Set_Table_Entry ('T', ' ', From, To, False);
869 when N_Loop_Statement =>
871 -- Even if not a while loop, we want a new statement seq
875 if Present (Iteration_Scheme (N)) then
877 (Condition (Iteration_Scheme (N)), 'W');
880 Traverse_Declarations_Or_Statements (Statements (N));
885 if Has_Decision (N) then
887 Process_Decisions (N, 'X');
891 -- If that element did not terminate the current sequence of
892 -- statements, then establish or extend this sequence.
895 if Start = No_Location then
896 Sloc_Range (N, Start, Stop);
898 Sloc_Range (N, Dummy, Stop);
907 end Traverse_Declarations_Or_Statements;
909 -----------------------------------------
910 -- Traverse_Handled_Statement_Sequence --
911 -----------------------------------------
913 procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
918 Traverse_Declarations_Or_Statements (Statements (N));
920 if Present (Exception_Handlers (N)) then
921 Handler := First (Exception_Handlers (N));
922 while Present (Handler) loop
923 Traverse_Declarations_Or_Statements (Statements (Handler));
928 end Traverse_Handled_Statement_Sequence;
930 ---------------------------
931 -- Traverse_Package_Body --
932 ---------------------------
934 procedure Traverse_Package_Body (N : Node_Id) is
936 Traverse_Declarations_Or_Statements (Declarations (N));
937 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
938 end Traverse_Package_Body;
940 ----------------------------------
941 -- Traverse_Package_Declaration --
942 ----------------------------------
944 procedure Traverse_Package_Declaration (N : Node_Id) is
945 Spec : constant Node_Id := Specification (N);
947 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
948 Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
949 end Traverse_Package_Declaration;
951 ------------------------------
952 -- Traverse_Subprogram_Body --
953 ------------------------------
955 procedure Traverse_Subprogram_Body (N : Node_Id) is
957 Traverse_Declarations_Or_Statements (Declarations (N));
958 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
959 end Traverse_Subprogram_Body;