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;
40 with GNAT.HTable; use GNAT.HTable;
41 with GNAT.Heap_Sort_G;
43 package body Par_SCO is
45 -----------------------
46 -- Unit Number Table --
47 -----------------------
49 -- This table parallels the SCO_Unit_Table, keeping track of the unit
50 -- numbers corresponding to the entries made in this table, so that before
51 -- writing out the SCO information to the ALI file, we can fill in the
52 -- proper dependency numbers and file names.
54 -- Note that the zero'th entry is here for convenience in sorting the
55 -- table, the real lower bound is 1.
57 package SCO_Unit_Number_Table is new Table.Table (
58 Table_Component_Type => Unit_Number_Type,
59 Table_Index_Type => SCO_Unit_Index,
60 Table_Low_Bound => 0, -- see note above on sort
62 Table_Increment => 200,
63 Table_Name => "SCO_Unit_Number_Entry");
65 --------------------------
66 -- Condition Hash Table --
67 --------------------------
69 -- We need to be able to get to conditions quickly for handling the calls
70 -- to Set_SCO_Condition efficiently. For this purpose we identify the
71 -- conditions in the table by their starting sloc, and use the following
72 -- hash table to map from these starting sloc values to SCO_Table indexes.
74 type Header_Num is new Integer range 0 .. 996;
75 -- Type for hash table headers
77 function Hash (F : Source_Ptr) return Header_Num;
78 -- Function to Hash source pointer value
80 function Equal (F1, F2 : Source_Ptr) return Boolean;
81 -- Function to test two keys for equality
83 package Condition_Hash_Table is new Simple_HTable
84 (Header_Num, Int, 0, Source_Ptr, Hash, Equal);
85 -- The actual hash table
87 --------------------------
88 -- Internal Subprograms --
89 --------------------------
91 function Has_Decision (N : Node_Id) return Boolean;
92 -- N is the node for a subexpression. Returns True if the subexpression
93 -- contains a nested decision (i.e. either is a logical operator, or
94 -- contains a logical operator in its subtree).
96 function Is_Logical_Operator (N : Node_Id) return Boolean;
97 -- N is the node for a subexpression. This procedure just tests N to see
98 -- if it is a logical operator (including short circuit conditions) and
99 -- returns True if so, False otherwise, it does no other processing.
101 procedure Process_Decisions (N : Node_Id; T : Character);
102 -- If N is Empty, has no effect. Otherwise scans the tree for the node N,
103 -- to output any decisions it contains. T is one of IEWX (for context of
104 -- expresion: if/while/when-exit/expression). If T is other than X, then
105 -- the node is always a decision a decision is always present (at the very
106 -- least a simple decision is present at the top level).
108 procedure Process_Decisions (L : List_Id; T : Character);
109 -- Calls above procedure for each element of the list L
111 procedure Set_Table_Entry
117 -- Append an entry to SCO_Table with fields set as per arguments
119 procedure Traverse_Declarations_Or_Statements (L : List_Id);
120 procedure Traverse_Generic_Package_Declaration (N : Node_Id);
121 procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
122 procedure Traverse_Package_Body (N : Node_Id);
123 procedure Traverse_Package_Declaration (N : Node_Id);
124 procedure Traverse_Subprogram_Body (N : Node_Id);
125 -- Traverse the corresponding construct, generating SCO table entries
127 procedure Write_SCOs_To_ALI_File is new Put_SCOs;
128 -- Write SCO information to the ALI file using routines in Lib.Util
136 -- Dump SCO unit table
138 Write_Line ("SCO Unit Table");
139 Write_Line ("--------------");
141 for Index in 1 .. SCO_Unit_Table.Last loop
143 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
147 Write_Int (Int (Index));
148 Write_Str (". Dep_Num = ");
149 Write_Int (Int (UTE.Dep_Num));
150 Write_Str (" From = ");
151 Write_Int (Int (UTE.From));
152 Write_Str (" To = ");
153 Write_Int (Int (UTE.To));
155 Write_Str (" File_Name = """);
157 if UTE.File_Name /= null then
158 Write_Str (UTE.File_Name.all);
166 -- Dump SCO Unit number table if it contains any entries
168 if SCO_Unit_Number_Table.Last >= 1 then
170 Write_Line ("SCO Unit Number Table");
171 Write_Line ("---------------------");
173 for Index in 1 .. SCO_Unit_Number_Table.Last loop
175 Write_Int (Int (Index));
176 Write_Str (". Unit_Number = ");
177 Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
182 -- Dump SCO table itself
185 Write_Line ("SCO Table");
186 Write_Line ("---------");
188 for Index in 1 .. SCO_Table.Last loop
190 T : SCO_Table_Entry renames SCO_Table.Table (Index);
198 Write_Str (" C1 = '");
204 Write_Str (" C2 = '");
209 if T.From /= No_Source_Location then
210 Write_Str (" From = ");
211 Write_Int (Int (T.From.Line));
213 Write_Int (Int (T.From.Col));
216 if T.To /= No_Source_Location then
217 Write_Str (" To = ");
218 Write_Int (Int (T.To.Line));
220 Write_Int (Int (T.To.Col));
226 Write_Str (" False");
238 function Equal (F1, F2 : Source_Ptr) return Boolean is
247 function Has_Decision (N : Node_Id) return Boolean is
249 function Check_Node (N : Node_Id) return Traverse_Result;
255 function Check_Node (N : Node_Id) return Traverse_Result is
257 if Is_Logical_Operator (N) then
264 function Traverse is new Traverse_Func (Check_Node);
266 -- Start of processing for Has_Decision
269 return Traverse (N) = Abandon;
276 function Hash (F : Source_Ptr) return Header_Num is
278 return Header_Num (Nat (F) mod 997);
285 procedure Initialize is
287 SCO_Unit_Number_Table.Init;
289 -- Set dummy 0'th entry in place for sort
291 SCO_Unit_Number_Table.Increment_Last;
294 -------------------------
295 -- Is_Logical_Operator --
296 -------------------------
298 function Is_Logical_Operator (N : Node_Id) return Boolean is
300 return Nkind_In (N, N_Op_And,
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 and short circuit forms, output table
440 -- entries and then process operands recursively to deal with
441 -- nested conditions.
454 -- If outer level, then type comes from call, otherwise it
455 -- is more deeply nested and counts as X for expression.
457 if N = Process_Decisions.N then
458 T := Process_Decisions.T;
463 -- Output header for sequence
465 Set_Table_Entry (T, ' ', No_Location, No_Location, False);
467 -- Output the decision
469 Output_Decision_Operand (N);
471 -- Change Last in last table entry to True to mark end
473 SCO_Table.Table (SCO_Table.Last).Last := True;
475 -- Process any embedded decisions
477 Process_Decision_Operand (N);
481 -- Conditional expression, processed like an if statement
483 when N_Conditional_Expression =>
485 Cond : constant Node_Id := First (Expressions (N));
486 Thnx : constant Node_Id := Next (Cond);
487 Elsx : constant Node_Id := Next (Thnx);
489 Process_Decisions (Cond, 'I');
490 Process_Decisions (Thnx, 'X');
491 Process_Decisions (Elsx, 'X');
495 -- All other cases, continue scan
503 procedure Traverse is new Traverse_Proc (Process_Node);
505 -- Start of processing for Process_Decisions
512 -- See if we have simple decision at outer level and if so then
513 -- generate the decision entry for this simple decision. A simple
514 -- decision is a boolean expression (which is not a logical operator
515 -- or short circuit form) appearing as the operand of an IF, WHILE
516 -- or EXIT WHEN construct.
518 if T /= 'X' and then not Is_Logical_Operator (N) then
519 Output_Element (N, T);
521 -- Change Last in last table entry to True to mark end of
522 -- sequence, which is this case is only one element long.
524 SCO_Table.Table (SCO_Table.Last).Last := True;
528 end Process_Decisions;
536 procedure Write_Info_Char (C : Character) renames Write_Char;
537 -- Write one character;
539 procedure Write_Info_Initiate (Key : Character) renames Write_Char;
540 -- Start new one and write one character;
542 procedure Write_Info_Nat (N : Nat);
545 procedure Write_Info_Terminate renames Write_Eol;
546 -- Terminate current line
552 procedure Write_Info_Nat (N : Nat) is
557 procedure Debug_Put_SCOs is new Put_SCOs;
559 -- Start of processing for pscos
569 procedure SCO_Output is
571 if Debug_Flag_Dot_OO then
575 -- Sort the unit tables based on dependency numbers
577 Unit_Table_Sort : declare
579 function Lt (Op1, Op2 : Natural) return Boolean;
580 -- Comparison routine for sort call
582 procedure Move (From : Natural; To : Natural);
583 -- Move routine for sort call
589 function Lt (Op1, Op2 : Natural) return Boolean is
593 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
596 (SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
603 procedure Move (From : Natural; To : Natural) is
605 SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
606 SCO_Unit_Table.Table (SCO_Unit_Index (From));
607 SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
608 SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
611 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
613 -- Start of processing for Unit_Table_Sort
616 Sorting.Sort (Integer (SCO_Unit_Table.Last));
619 -- Loop through entries in the unit table to set file name and
620 -- dependency number entries.
622 for J in 1 .. SCO_Unit_Table.Last loop
624 U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
625 UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
627 Get_Name_String (Reference_Name (Source_Index (U)));
628 UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
629 UTE.Dep_Num := Dependency_Num (U);
633 -- Now the tables are all setup for output to the ALI file
635 Write_SCOs_To_ALI_File;
642 procedure SCO_Record (U : Unit_Number_Type) is
647 -- Ignore call if not generating code and generating SCO's
649 if not (Generate_SCO and then Operating_Mode = Generate_Code) then
653 -- Ignore call if this unit already recorded
655 for J in 1 .. SCO_Unit_Number_Table.Last loop
656 if U = SCO_Unit_Number_Table.Table (J) then
661 -- Otherwise record starting entry
663 From := SCO_Table.Last + 1;
665 -- Get Unit (checking case of subunit)
667 Lu := Unit (Cunit (U));
669 if Nkind (Lu) = N_Subunit then
670 Lu := Proper_Body (Lu);
675 if Nkind (Lu) = N_Subprogram_Body then
676 Traverse_Subprogram_Body (Lu);
678 elsif Nkind (Lu) = N_Package_Declaration then
679 Traverse_Package_Declaration (Lu);
681 elsif Nkind (Lu) = N_Package_Body then
682 Traverse_Package_Body (Lu);
684 elsif Nkind (Lu) = N_Generic_Package_Declaration then
685 Traverse_Generic_Package_Declaration (Lu);
687 -- For anything else, the only issue is default expressions for
688 -- parameters, where we have to worry about possible embedded decisions
692 Process_Decisions (Lu, 'X');
695 -- Make entry for new unit in unit tables, we will fill in the file
696 -- name and dependency numbers later.
698 SCO_Unit_Table.Append (
702 To => SCO_Table.Last));
704 SCO_Unit_Number_Table.Append (U);
707 -----------------------
708 -- Set_SCO_Condition --
709 -----------------------
711 procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is
712 Index : constant Nat := Condition_Hash_Table.Get (First_Loc);
715 SCO_Table.Table (Index).C2 := Typ;
717 end Set_SCO_Condition;
719 ---------------------
720 -- Set_Table_Entry --
721 ---------------------
723 procedure Set_Table_Entry
730 function To_Source_Location (S : Source_Ptr) return Source_Location;
731 -- Converts Source_Ptr value to Source_Location (line/col) format
733 ------------------------
734 -- To_Source_Location --
735 ------------------------
737 function To_Source_Location (S : Source_Ptr) return Source_Location is
739 if S = No_Location then
740 return No_Source_Location;
743 (Line => Get_Logical_Line_Number (S),
744 Col => Get_Column_Number (S));
746 end To_Source_Location;
748 -- Start of processing for Set_Table_Entry
754 From => To_Source_Location (From),
755 To => To_Source_Location (To),
759 -----------------------------------------
760 -- Traverse_Declarations_Or_Statements --
761 -----------------------------------------
763 procedure Traverse_Declarations_Or_Statements (L : List_Id) is
772 -- Set False if current entity terminates statement list
774 procedure Set_Statement_Entry;
775 -- If Start is No_Location, does nothing, otherwise outputs a SCO_Table
776 -- statement entry for the range Start-Stop and then sets both Start
777 -- and Stop to No_Location. Unconditionally sets Term to True. This is
778 -- called when we find a statement or declaration that generates its
779 -- own table entry, so that we must end the current statement sequence.
781 -------------------------
782 -- Set_Statement_Entry --
783 -------------------------
785 procedure Set_Statement_Entry is
789 if Start /= No_Location then
790 Set_Table_Entry ('S', ' ', Start, Stop, False);
791 Start := No_Location;
794 end Set_Statement_Entry;
796 -- Start of processing for Traverse_Declarations_Or_Statements
799 if Is_Non_Empty_List (L) then
801 Start := No_Location;
803 -- Loop through statements or declarations
805 while Present (N) loop
810 -- Package declaration
812 when N_Package_Declaration =>
814 Traverse_Package_Declaration (N);
816 -- Generic package declaration
818 when N_Generic_Package_Declaration =>
820 Traverse_Generic_Package_Declaration (N);
824 when N_Package_Body =>
826 Traverse_Package_Body (N);
828 -- Subprogram declaration
830 when N_Subprogram_Declaration =>
833 (Parameter_Specifications (Specification (N)), 'X');
835 -- Generic subprogram declaration
837 when N_Generic_Subprogram_Declaration =>
839 Process_Decisions (Generic_Formal_Declarations (N), 'X');
841 (Parameter_Specifications (Specification (N)), 'X');
845 when N_Subprogram_Body =>
847 Traverse_Subprogram_Body (N);
851 when N_Exit_Statement =>
853 Process_Decisions (Condition (N), 'E');
855 -- This is an exit point
857 Sloc_Range (N, From, To);
858 Set_Table_Entry ('T', ' ', From, To, False);
860 -- Label (breaks statement sequence)
867 when N_Block_Statement =>
869 Traverse_Declarations_Or_Statements (Declarations (N));
870 Traverse_Handled_Statement_Sequence
871 (Handled_Statement_Sequence (N));
875 when N_If_Statement =>
877 Process_Decisions (Condition (N), 'I');
878 Traverse_Declarations_Or_Statements (Then_Statements (N));
880 if Present (Elsif_Parts (N)) then
882 Elif : Node_Id := First (Elsif_Parts (N));
884 while Present (Elif) loop
885 Process_Decisions (Condition (Elif), 'I');
886 Traverse_Declarations_Or_Statements
887 (Then_Statements (Elif));
893 Traverse_Declarations_Or_Statements (Else_Statements (N));
895 -- Unconditional exit points
897 when N_Requeue_Statement |
901 Sloc_Range (N, From, To);
902 Set_Table_Entry ('T', ' ', From, To, False);
904 -- Simple return statement
906 when N_Simple_Return_Statement =>
909 -- Process possible return expression
911 Process_Decisions (Expression (N), 'X');
913 -- Return is an exit point
915 Sloc_Range (N, From, To);
916 Set_Table_Entry ('T', ' ', From, To, False);
918 -- Extended return statement
920 when N_Extended_Return_Statement =>
922 Traverse_Declarations_Or_Statements
923 (Return_Object_Declarations (N));
924 Traverse_Handled_Statement_Sequence
925 (Handled_Statement_Sequence (N));
927 -- Return is an exit point
929 Sloc_Range (N, From, To);
930 Set_Table_Entry ('T', ' ', From, To, False);
934 when N_Loop_Statement =>
936 -- Even if not a while loop, we want a new statement seq
940 if Present (Iteration_Scheme (N)) then
942 (Condition (Iteration_Scheme (N)), 'W');
945 Traverse_Declarations_Or_Statements (Statements (N));
950 if Has_Decision (N) then
952 Process_Decisions (N, 'X');
956 -- If that element did not terminate the current sequence of
957 -- statements, then establish or extend this sequence.
960 if Start = No_Location then
961 Sloc_Range (N, Start, Stop);
963 Sloc_Range (N, Dummy, Stop);
972 end Traverse_Declarations_Or_Statements;
974 ------------------------------------------
975 -- Traverse_Generic_Package_Declaration --
976 ------------------------------------------
978 procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
980 Process_Decisions (Generic_Formal_Declarations (N), 'X');
981 Traverse_Package_Declaration (N);
982 end Traverse_Generic_Package_Declaration;
984 -----------------------------------------
985 -- Traverse_Handled_Statement_Sequence --
986 -----------------------------------------
988 procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
993 -- For package bodies without a statement part, the parser adds an empty
994 -- one, to normalize the representation. The null statement therein,
995 -- which does not come from source, does not get a SCO.
997 if Present (N) and then Comes_From_Source (N) then
998 Traverse_Declarations_Or_Statements (Statements (N));
1000 if Present (Exception_Handlers (N)) then
1001 Handler := First (Exception_Handlers (N));
1002 while Present (Handler) loop
1003 Traverse_Declarations_Or_Statements (Statements (Handler));
1008 end Traverse_Handled_Statement_Sequence;
1010 ---------------------------
1011 -- Traverse_Package_Body --
1012 ---------------------------
1014 procedure Traverse_Package_Body (N : Node_Id) is
1016 Traverse_Declarations_Or_Statements (Declarations (N));
1017 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1018 end Traverse_Package_Body;
1020 ----------------------------------
1021 -- Traverse_Package_Declaration --
1022 ----------------------------------
1024 procedure Traverse_Package_Declaration (N : Node_Id) is
1025 Spec : constant Node_Id := Specification (N);
1027 Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
1028 Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
1029 end Traverse_Package_Declaration;
1031 ------------------------------
1032 -- Traverse_Subprogram_Body --
1033 ------------------------------
1035 procedure Traverse_Subprogram_Body (N : Node_Id) is
1037 Traverse_Declarations_Or_Statements (Declarations (N));
1038 Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
1039 end Traverse_Subprogram_Body;