1236 lines
40 KiB
Ada
1236 lines
40 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P A R _ S C O --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2009, Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Debug; use Debug;
|
|
with Lib; use Lib;
|
|
with Lib.Util; use Lib.Util;
|
|
with Namet; use Namet;
|
|
with Nlists; use Nlists;
|
|
with Opt; use Opt;
|
|
with Output; use Output;
|
|
with Put_SCOs;
|
|
with SCOs; use SCOs;
|
|
with Sinfo; use Sinfo;
|
|
with Sinput; use Sinput;
|
|
with Snames; use Snames;
|
|
with Table;
|
|
|
|
with GNAT.HTable; use GNAT.HTable;
|
|
with GNAT.Heap_Sort_G;
|
|
|
|
package body Par_SCO is
|
|
|
|
-----------------------
|
|
-- Unit Number Table --
|
|
-----------------------
|
|
|
|
-- This table parallels the SCO_Unit_Table, keeping track of the unit
|
|
-- numbers corresponding to the entries made in this table, so that before
|
|
-- writing out the SCO information to the ALI file, we can fill in the
|
|
-- proper dependency numbers and file names.
|
|
|
|
-- Note that the zero'th entry is here for convenience in sorting the
|
|
-- table, the real lower bound is 1.
|
|
|
|
package SCO_Unit_Number_Table is new Table.Table (
|
|
Table_Component_Type => Unit_Number_Type,
|
|
Table_Index_Type => SCO_Unit_Index,
|
|
Table_Low_Bound => 0, -- see note above on sort
|
|
Table_Initial => 20,
|
|
Table_Increment => 200,
|
|
Table_Name => "SCO_Unit_Number_Entry");
|
|
|
|
--------------------------
|
|
-- Condition Hash Table --
|
|
--------------------------
|
|
|
|
-- We need to be able to get to conditions quickly for handling the calls
|
|
-- to Set_SCO_Condition efficiently. For this purpose we identify the
|
|
-- conditions in the table by their starting sloc, and use the following
|
|
-- hash table to map from these starting sloc values to SCO_Table indexes.
|
|
|
|
type Header_Num is new Integer range 0 .. 996;
|
|
-- Type for hash table headers
|
|
|
|
function Hash (F : Source_Ptr) return Header_Num;
|
|
-- Function to Hash source pointer value
|
|
|
|
function Equal (F1, F2 : Source_Ptr) return Boolean;
|
|
-- Function to test two keys for equality
|
|
|
|
package Condition_Hash_Table is new Simple_HTable
|
|
(Header_Num, Int, 0, Source_Ptr, Hash, Equal);
|
|
-- The actual hash table
|
|
|
|
--------------------------
|
|
-- Internal Subprograms --
|
|
--------------------------
|
|
|
|
function Has_Decision (N : Node_Id) return Boolean;
|
|
-- N is the node for a subexpression. Returns True if the subexpression
|
|
-- contains a nested decision (i.e. either is a logical operator, or
|
|
-- contains a logical operator in its subtree).
|
|
|
|
function Is_Logical_Operator (N : Node_Id) return Boolean;
|
|
-- N is the node for a subexpression. This procedure just tests N to see
|
|
-- if it is a logical operator (including short circuit conditions, but
|
|
-- excluding OR and AND) and returns True if so, False otherwise, it does
|
|
-- no other processing.
|
|
|
|
procedure Process_Decisions (N : Node_Id; T : Character);
|
|
-- If N is Empty, has no effect. Otherwise scans the tree for the node N,
|
|
-- to output any decisions it contains. T is one of IEPWX (for context of
|
|
-- expresion: if/exit when/pragma/while/expression). If T is other than X,
|
|
-- then a decision is always present (at the very least a simple decision
|
|
-- is present at the top level).
|
|
|
|
procedure Process_Decisions (L : List_Id; T : Character);
|
|
-- Calls above procedure for each element of the list L
|
|
|
|
procedure Set_Table_Entry
|
|
(C1 : Character;
|
|
C2 : Character;
|
|
From : Source_Ptr;
|
|
To : Source_Ptr;
|
|
Last : Boolean);
|
|
-- Append an entry to SCO_Table with fields set as per arguments
|
|
|
|
procedure Traverse_Declarations_Or_Statements (L : List_Id);
|
|
procedure Traverse_Generic_Package_Declaration (N : Node_Id);
|
|
procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
|
|
procedure Traverse_Package_Body (N : Node_Id);
|
|
procedure Traverse_Package_Declaration (N : Node_Id);
|
|
procedure Traverse_Subprogram_Body (N : Node_Id);
|
|
-- Traverse the corresponding construct, generating SCO table entries
|
|
|
|
procedure Write_SCOs_To_ALI_File is new Put_SCOs;
|
|
-- Write SCO information to the ALI file using routines in Lib.Util
|
|
|
|
----------
|
|
-- dsco --
|
|
----------
|
|
|
|
procedure dsco is
|
|
begin
|
|
-- Dump SCO unit table
|
|
|
|
Write_Line ("SCO Unit Table");
|
|
Write_Line ("--------------");
|
|
|
|
for Index in 1 .. SCO_Unit_Table.Last loop
|
|
declare
|
|
UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (Index);
|
|
|
|
begin
|
|
Write_Str (" ");
|
|
Write_Int (Int (Index));
|
|
Write_Str (". Dep_Num = ");
|
|
Write_Int (Int (UTE.Dep_Num));
|
|
Write_Str (" From = ");
|
|
Write_Int (Int (UTE.From));
|
|
Write_Str (" To = ");
|
|
Write_Int (Int (UTE.To));
|
|
|
|
Write_Str (" File_Name = """);
|
|
|
|
if UTE.File_Name /= null then
|
|
Write_Str (UTE.File_Name.all);
|
|
end if;
|
|
|
|
Write_Char ('"');
|
|
Write_Eol;
|
|
end;
|
|
end loop;
|
|
|
|
-- Dump SCO Unit number table if it contains any entries
|
|
|
|
if SCO_Unit_Number_Table.Last >= 1 then
|
|
Write_Eol;
|
|
Write_Line ("SCO Unit Number Table");
|
|
Write_Line ("---------------------");
|
|
|
|
for Index in 1 .. SCO_Unit_Number_Table.Last loop
|
|
Write_Str (" ");
|
|
Write_Int (Int (Index));
|
|
Write_Str (". Unit_Number = ");
|
|
Write_Int (Int (SCO_Unit_Number_Table.Table (Index)));
|
|
Write_Eol;
|
|
end loop;
|
|
end if;
|
|
|
|
-- Dump SCO table itself
|
|
|
|
Write_Eol;
|
|
Write_Line ("SCO Table");
|
|
Write_Line ("---------");
|
|
|
|
for Index in 1 .. SCO_Table.Last loop
|
|
declare
|
|
T : SCO_Table_Entry renames SCO_Table.Table (Index);
|
|
|
|
begin
|
|
Write_Str (" ");
|
|
Write_Int (Index);
|
|
Write_Char ('.');
|
|
|
|
if T.C1 /= ' ' then
|
|
Write_Str (" C1 = '");
|
|
Write_Char (T.C1);
|
|
Write_Char (''');
|
|
end if;
|
|
|
|
if T.C2 /= ' ' then
|
|
Write_Str (" C2 = '");
|
|
Write_Char (T.C2);
|
|
Write_Char (''');
|
|
end if;
|
|
|
|
if T.From /= No_Source_Location then
|
|
Write_Str (" From = ");
|
|
Write_Int (Int (T.From.Line));
|
|
Write_Char (':');
|
|
Write_Int (Int (T.From.Col));
|
|
end if;
|
|
|
|
if T.To /= No_Source_Location then
|
|
Write_Str (" To = ");
|
|
Write_Int (Int (T.To.Line));
|
|
Write_Char (':');
|
|
Write_Int (Int (T.To.Col));
|
|
end if;
|
|
|
|
if T.Last then
|
|
Write_Str (" True");
|
|
else
|
|
Write_Str (" False");
|
|
end if;
|
|
|
|
Write_Eol;
|
|
end;
|
|
end loop;
|
|
end dsco;
|
|
|
|
-----------
|
|
-- Equal --
|
|
-----------
|
|
|
|
function Equal (F1, F2 : Source_Ptr) return Boolean is
|
|
begin
|
|
return F1 = F2;
|
|
end Equal;
|
|
|
|
------------------
|
|
-- Has_Decision --
|
|
------------------
|
|
|
|
function Has_Decision (N : Node_Id) return Boolean is
|
|
|
|
function Check_Node (N : Node_Id) return Traverse_Result;
|
|
|
|
----------------
|
|
-- Check_Node --
|
|
----------------
|
|
|
|
function Check_Node (N : Node_Id) return Traverse_Result is
|
|
begin
|
|
if Is_Logical_Operator (N) then
|
|
return Abandon;
|
|
else
|
|
return OK;
|
|
end if;
|
|
end Check_Node;
|
|
|
|
function Traverse is new Traverse_Func (Check_Node);
|
|
|
|
-- Start of processing for Has_Decision
|
|
|
|
begin
|
|
return Traverse (N) = Abandon;
|
|
end Has_Decision;
|
|
|
|
----------
|
|
-- Hash --
|
|
----------
|
|
|
|
function Hash (F : Source_Ptr) return Header_Num is
|
|
begin
|
|
return Header_Num (Nat (F) mod 997);
|
|
end Hash;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize is
|
|
begin
|
|
SCO_Unit_Number_Table.Init;
|
|
|
|
-- Set dummy 0'th entry in place for sort
|
|
|
|
SCO_Unit_Number_Table.Increment_Last;
|
|
end Initialize;
|
|
|
|
-------------------------
|
|
-- Is_Logical_Operator --
|
|
-------------------------
|
|
|
|
function Is_Logical_Operator (N : Node_Id) return Boolean is
|
|
begin
|
|
return Nkind_In (N, N_Op_Xor,
|
|
N_Op_Not,
|
|
N_And_Then,
|
|
N_Or_Else);
|
|
end Is_Logical_Operator;
|
|
|
|
-----------------------
|
|
-- Process_Decisions --
|
|
-----------------------
|
|
|
|
-- Version taking a list
|
|
|
|
procedure Process_Decisions (L : List_Id; T : Character) is
|
|
N : Node_Id;
|
|
begin
|
|
if L /= No_List then
|
|
N := First (L);
|
|
while Present (N) loop
|
|
Process_Decisions (N, T);
|
|
Next (N);
|
|
end loop;
|
|
end if;
|
|
end Process_Decisions;
|
|
|
|
-- Version taking a node
|
|
|
|
procedure Process_Decisions (N : Node_Id; T : Character) is
|
|
|
|
function Process_Node (N : Node_Id) return Traverse_Result;
|
|
-- Processes one node in the traversal, looking for logical operators,
|
|
-- and if one is found, outputs the appropriate table entries.
|
|
|
|
procedure Output_Decision_Operand (N : Node_Id);
|
|
-- The node N is the top level logical operator of a decision, or it is
|
|
-- one of the operands of a logical operator belonging to a single
|
|
-- complex decision. This routine outputs the sequence of table entries
|
|
-- corresponding to the node. Note that we do not process the sub-
|
|
-- operands to look for further decisions, that processing is done in
|
|
-- Process_Decision_Operand, because we can't get decisions mixed up in
|
|
-- the global table. Call has no effect if N is Empty.
|
|
|
|
procedure Output_Element (N : Node_Id; T : Character);
|
|
-- Node N is an operand of a logical operator that is not itself a
|
|
-- logical operator, or it is a simple decision. This routine outputs
|
|
-- the table entry for the element, with C1 set to T (' ' for one of
|
|
-- the elements of a complex decision, or 'I'/'W'/'E' for a simple
|
|
-- decision (from an IF, WHILE, or EXIT WHEN). Last is set to False,
|
|
-- and an entry is made in the condition hash table.
|
|
|
|
procedure Process_Decision_Operand (N : Node_Id);
|
|
-- This is called on node N, the top level node of a decision, or on one
|
|
-- of its operands or suboperands after generating the full output for
|
|
-- the complex decision. It process the suboperands of the decision
|
|
-- looking for nested decisions.
|
|
|
|
-----------------------------
|
|
-- Output_Decision_Operand --
|
|
-----------------------------
|
|
|
|
procedure Output_Decision_Operand (N : Node_Id) is
|
|
C : Character;
|
|
L : Node_Id;
|
|
|
|
begin
|
|
if No (N) then
|
|
return;
|
|
|
|
-- Logical operator
|
|
|
|
elsif Is_Logical_Operator (N) then
|
|
if Nkind (N) = N_Op_Not then
|
|
C := '!';
|
|
L := Empty;
|
|
|
|
else
|
|
L := Left_Opnd (N);
|
|
|
|
if Nkind (N) = N_Op_Xor then
|
|
C := '^';
|
|
elsif Nkind_In (N, N_Op_Or, N_Or_Else) then
|
|
C := '|';
|
|
else
|
|
C := '&';
|
|
end if;
|
|
end if;
|
|
|
|
Set_Table_Entry (C, ' ', No_Location, No_Location, False);
|
|
|
|
Output_Decision_Operand (L);
|
|
Output_Decision_Operand (Right_Opnd (N));
|
|
|
|
-- Not a logical operator
|
|
|
|
else
|
|
Output_Element (N, ' ');
|
|
end if;
|
|
end Output_Decision_Operand;
|
|
|
|
--------------------
|
|
-- Output_Element --
|
|
--------------------
|
|
|
|
procedure Output_Element (N : Node_Id; T : Character) is
|
|
FSloc : Source_Ptr;
|
|
LSloc : Source_Ptr;
|
|
begin
|
|
Sloc_Range (N, FSloc, LSloc);
|
|
Set_Table_Entry (T, 'c', FSloc, LSloc, False);
|
|
Condition_Hash_Table.Set (FSloc, SCO_Table.Last);
|
|
end Output_Element;
|
|
|
|
------------------------------
|
|
-- Process_Decision_Operand --
|
|
------------------------------
|
|
|
|
procedure Process_Decision_Operand (N : Node_Id) is
|
|
begin
|
|
if Is_Logical_Operator (N) then
|
|
if Nkind (N) /= N_Op_Not then
|
|
Process_Decision_Operand (Left_Opnd (N));
|
|
end if;
|
|
|
|
Process_Decision_Operand (Right_Opnd (N));
|
|
|
|
else
|
|
Process_Decisions (N, 'X');
|
|
end if;
|
|
end Process_Decision_Operand;
|
|
|
|
------------------
|
|
-- Process_Node --
|
|
------------------
|
|
|
|
function Process_Node (N : Node_Id) return Traverse_Result is
|
|
begin
|
|
case Nkind (N) is
|
|
|
|
-- Logical operators, output table entries and then process
|
|
-- operands recursively to deal with nested conditions.
|
|
|
|
when N_And_Then |
|
|
N_Or_Else |
|
|
N_Op_Not =>
|
|
|
|
declare
|
|
T : Character;
|
|
|
|
begin
|
|
-- If outer level, then type comes from call, otherwise it
|
|
-- is more deeply nested and counts as X for expression.
|
|
|
|
if N = Process_Decisions.N then
|
|
T := Process_Decisions.T;
|
|
else
|
|
T := 'X';
|
|
end if;
|
|
|
|
-- Output header for sequence
|
|
|
|
Set_Table_Entry (T, ' ', No_Location, No_Location, False);
|
|
|
|
-- Output the decision
|
|
|
|
Output_Decision_Operand (N);
|
|
|
|
-- Change Last in last table entry to True to mark end
|
|
|
|
SCO_Table.Table (SCO_Table.Last).Last := True;
|
|
|
|
-- Process any embedded decisions
|
|
|
|
Process_Decision_Operand (N);
|
|
return Skip;
|
|
end;
|
|
|
|
-- Conditional expression, processed like an if statement
|
|
|
|
when N_Conditional_Expression =>
|
|
declare
|
|
Cond : constant Node_Id := First (Expressions (N));
|
|
Thnx : constant Node_Id := Next (Cond);
|
|
Elsx : constant Node_Id := Next (Thnx);
|
|
begin
|
|
Process_Decisions (Cond, 'I');
|
|
Process_Decisions (Thnx, 'X');
|
|
Process_Decisions (Elsx, 'X');
|
|
return Skip;
|
|
end;
|
|
|
|
-- All other cases, continue scan
|
|
|
|
when others =>
|
|
return OK;
|
|
|
|
end case;
|
|
end Process_Node;
|
|
|
|
procedure Traverse is new Traverse_Proc (Process_Node);
|
|
|
|
-- Start of processing for Process_Decisions
|
|
|
|
begin
|
|
if No (N) then
|
|
return;
|
|
end if;
|
|
|
|
-- See if we have simple decision at outer level and if so then
|
|
-- generate the decision entry for this simple decision. A simple
|
|
-- decision is a boolean expression (which is not a logical operator
|
|
-- or short circuit form) appearing as the operand of an IF, WHILE
|
|
-- or EXIT WHEN construct.
|
|
|
|
if T /= 'X' and then not Is_Logical_Operator (N) then
|
|
Output_Element (N, T);
|
|
|
|
-- Change Last in last table entry to True to mark end of
|
|
-- sequence, which is this case is only one element long.
|
|
|
|
SCO_Table.Table (SCO_Table.Last).Last := True;
|
|
end if;
|
|
|
|
Traverse (N);
|
|
end Process_Decisions;
|
|
|
|
-----------
|
|
-- pscos --
|
|
-----------
|
|
|
|
procedure pscos is
|
|
|
|
procedure Write_Info_Char (C : Character) renames Write_Char;
|
|
-- Write one character;
|
|
|
|
procedure Write_Info_Initiate (Key : Character) renames Write_Char;
|
|
-- Start new one and write one character;
|
|
|
|
procedure Write_Info_Nat (N : Nat);
|
|
-- Write value of N
|
|
|
|
procedure Write_Info_Terminate renames Write_Eol;
|
|
-- Terminate current line
|
|
|
|
--------------------
|
|
-- Write_Info_Nat --
|
|
--------------------
|
|
|
|
procedure Write_Info_Nat (N : Nat) is
|
|
begin
|
|
Write_Int (N);
|
|
end Write_Info_Nat;
|
|
|
|
procedure Debug_Put_SCOs is new Put_SCOs;
|
|
|
|
-- Start of processing for pscos
|
|
|
|
begin
|
|
Debug_Put_SCOs;
|
|
end pscos;
|
|
|
|
----------------
|
|
-- SCO_Output --
|
|
----------------
|
|
|
|
procedure SCO_Output is
|
|
begin
|
|
if Debug_Flag_Dot_OO then
|
|
dsco;
|
|
end if;
|
|
|
|
-- Sort the unit tables based on dependency numbers
|
|
|
|
Unit_Table_Sort : declare
|
|
|
|
function Lt (Op1, Op2 : Natural) return Boolean;
|
|
-- Comparison routine for sort call
|
|
|
|
procedure Move (From : Natural; To : Natural);
|
|
-- Move routine for sort call
|
|
|
|
--------
|
|
-- Lt --
|
|
--------
|
|
|
|
function Lt (Op1, Op2 : Natural) return Boolean is
|
|
begin
|
|
return
|
|
Dependency_Num
|
|
(SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op1)))
|
|
<
|
|
Dependency_Num
|
|
(SCO_Unit_Number_Table.Table (SCO_Unit_Index (Op2)));
|
|
end Lt;
|
|
|
|
----------
|
|
-- Move --
|
|
----------
|
|
|
|
procedure Move (From : Natural; To : Natural) is
|
|
begin
|
|
SCO_Unit_Table.Table (SCO_Unit_Index (To)) :=
|
|
SCO_Unit_Table.Table (SCO_Unit_Index (From));
|
|
SCO_Unit_Number_Table.Table (SCO_Unit_Index (To)) :=
|
|
SCO_Unit_Number_Table.Table (SCO_Unit_Index (From));
|
|
end Move;
|
|
|
|
package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
|
|
|
|
-- Start of processing for Unit_Table_Sort
|
|
|
|
begin
|
|
Sorting.Sort (Integer (SCO_Unit_Table.Last));
|
|
end Unit_Table_Sort;
|
|
|
|
-- Loop through entries in the unit table to set file name and
|
|
-- dependency number entries.
|
|
|
|
for J in 1 .. SCO_Unit_Table.Last loop
|
|
declare
|
|
U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
|
|
UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
|
|
begin
|
|
Get_Name_String (Reference_Name (Source_Index (U)));
|
|
UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
|
|
UTE.Dep_Num := Dependency_Num (U);
|
|
end;
|
|
end loop;
|
|
|
|
-- Now the tables are all setup for output to the ALI file
|
|
|
|
Write_SCOs_To_ALI_File;
|
|
end SCO_Output;
|
|
|
|
----------------
|
|
-- SCO_Record --
|
|
----------------
|
|
|
|
procedure SCO_Record (U : Unit_Number_Type) is
|
|
Lu : Node_Id;
|
|
From : Nat;
|
|
|
|
begin
|
|
-- Ignore call if not generating code and generating SCO's
|
|
|
|
if not (Generate_SCO and then Operating_Mode = Generate_Code) then
|
|
return;
|
|
end if;
|
|
|
|
-- Ignore call if this unit already recorded
|
|
|
|
for J in 1 .. SCO_Unit_Number_Table.Last loop
|
|
if U = SCO_Unit_Number_Table.Table (J) then
|
|
return;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Otherwise record starting entry
|
|
|
|
From := SCO_Table.Last + 1;
|
|
|
|
-- Get Unit (checking case of subunit)
|
|
|
|
Lu := Unit (Cunit (U));
|
|
|
|
if Nkind (Lu) = N_Subunit then
|
|
Lu := Proper_Body (Lu);
|
|
end if;
|
|
|
|
-- Traverse the unit
|
|
|
|
if Nkind (Lu) = N_Subprogram_Body then
|
|
Traverse_Subprogram_Body (Lu);
|
|
|
|
elsif Nkind (Lu) = N_Package_Declaration then
|
|
Traverse_Package_Declaration (Lu);
|
|
|
|
elsif Nkind (Lu) = N_Package_Body then
|
|
Traverse_Package_Body (Lu);
|
|
|
|
elsif Nkind (Lu) = N_Generic_Package_Declaration then
|
|
Traverse_Generic_Package_Declaration (Lu);
|
|
|
|
-- For anything else, the only issue is default expressions for
|
|
-- parameters, where we have to worry about possible embedded decisions
|
|
-- but nothing else.
|
|
|
|
else
|
|
Process_Decisions (Lu, 'X');
|
|
end if;
|
|
|
|
-- Make entry for new unit in unit tables, we will fill in the file
|
|
-- name and dependency numbers later.
|
|
|
|
SCO_Unit_Table.Append (
|
|
(Dep_Num => 0,
|
|
File_Name => null,
|
|
From => From,
|
|
To => SCO_Table.Last));
|
|
|
|
SCO_Unit_Number_Table.Append (U);
|
|
end SCO_Record;
|
|
|
|
-----------------------
|
|
-- Set_SCO_Condition --
|
|
-----------------------
|
|
|
|
procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is
|
|
Index : constant Nat := Condition_Hash_Table.Get (First_Loc);
|
|
begin
|
|
if Index /= 0 then
|
|
SCO_Table.Table (Index).C2 := Typ;
|
|
end if;
|
|
end Set_SCO_Condition;
|
|
|
|
---------------------
|
|
-- Set_Table_Entry --
|
|
---------------------
|
|
|
|
procedure Set_Table_Entry
|
|
(C1 : Character;
|
|
C2 : Character;
|
|
From : Source_Ptr;
|
|
To : Source_Ptr;
|
|
Last : Boolean)
|
|
is
|
|
function To_Source_Location (S : Source_Ptr) return Source_Location;
|
|
-- Converts Source_Ptr value to Source_Location (line/col) format
|
|
|
|
------------------------
|
|
-- To_Source_Location --
|
|
------------------------
|
|
|
|
function To_Source_Location (S : Source_Ptr) return Source_Location is
|
|
begin
|
|
if S = No_Location then
|
|
return No_Source_Location;
|
|
else
|
|
return
|
|
(Line => Get_Logical_Line_Number (S),
|
|
Col => Get_Column_Number (S));
|
|
end if;
|
|
end To_Source_Location;
|
|
|
|
-- Start of processing for Set_Table_Entry
|
|
|
|
begin
|
|
Add_SCO
|
|
(C1 => C1,
|
|
C2 => C2,
|
|
From => To_Source_Location (From),
|
|
To => To_Source_Location (To),
|
|
Last => Last);
|
|
end Set_Table_Entry;
|
|
|
|
-----------------------------------------
|
|
-- Traverse_Declarations_Or_Statements --
|
|
-----------------------------------------
|
|
|
|
procedure Traverse_Declarations_Or_Statements (L : List_Id) is
|
|
N : Node_Id;
|
|
Dummy : Source_Ptr;
|
|
|
|
type SC_Entry is record
|
|
From : Source_Ptr;
|
|
To : Source_Ptr;
|
|
Typ : Character;
|
|
end record;
|
|
-- Used to store a single entry in the following array
|
|
|
|
SC_Array : array (Nat range 1 .. 10_000) of SC_Entry;
|
|
SC_Last : Nat;
|
|
-- Used to store statement components for a CS entry to be output
|
|
-- as a result of the call to this procedure. SC_Last is the last
|
|
-- entry stored, so the current statement sequence is represented
|
|
-- by SC_Array (1 .. SC_Last). Extend_Statement_Sequence adds an
|
|
-- entry to this array, and Set_Statement_Entry clears it, copying
|
|
-- the entries to the main SCO output table. The reason that we do
|
|
-- the temporary caching of results in this array is that we want
|
|
-- the SCO table entries for a given CS line to be contiguous, and
|
|
-- the processing may output intermediate entries such as decision
|
|
-- entries. Note that the limit of 10_000 here is arbitrary, but does
|
|
-- not cause any trouble, if we encounter more than 10_000 statements
|
|
-- we simply break the current CS sequence at that point, which is
|
|
-- harmless, since this is only used for back annotation and it is
|
|
-- not critical that back annotation always work in all cases. Anyway
|
|
-- exceeding 10,000 statements in a basic block is very unlikely.
|
|
|
|
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
|
|
-- Extend the current statement sequence to encompass the node N. Typ
|
|
-- is the letter that identifies the type of statement/declaration that
|
|
-- is being added to the sequence.
|
|
|
|
procedure Extend_Statement_Sequence
|
|
(From : Node_Id;
|
|
To : Node_Id;
|
|
Typ : Character);
|
|
-- This version extends the current statement sequence with an entry
|
|
-- that starts with the first token of From, and ends with the last
|
|
-- token of To. It is used for example in a CASE statement to cover
|
|
-- the range from the CASE token to the last token of the expression.
|
|
|
|
procedure Set_Statement_Entry;
|
|
-- If Start is No_Location, does nothing, otherwise outputs a SCO_Table
|
|
-- statement entry for the range Start-Stop and then sets both Start
|
|
-- and Stop to No_Location. Unconditionally sets Term to True. This is
|
|
-- called when we find a statement or declaration that generates its
|
|
-- own table entry, so that we must end the current statement sequence.
|
|
|
|
-------------------------
|
|
-- Set_Statement_Entry --
|
|
-------------------------
|
|
|
|
procedure Set_Statement_Entry is
|
|
C1 : Character;
|
|
|
|
begin
|
|
if SC_Last /= 0 then
|
|
for J in 1 .. SC_Last loop
|
|
if J = 1 then
|
|
C1 := 'S';
|
|
else
|
|
C1 := 's';
|
|
end if;
|
|
|
|
Set_Table_Entry
|
|
(C1 => C1,
|
|
C2 => SC_Array (J).Typ,
|
|
From => SC_Array (J).From,
|
|
To => SC_Array (J).To,
|
|
Last => (J = SC_Last));
|
|
end loop;
|
|
|
|
SC_Last := 0;
|
|
end if;
|
|
end Set_Statement_Entry;
|
|
|
|
-------------------------------
|
|
-- Extend_Statement_Sequence --
|
|
-------------------------------
|
|
|
|
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
|
|
begin
|
|
-- Clear out statement sequence if array full
|
|
|
|
if SC_Last = SC_Array'Last then
|
|
Set_Statement_Entry;
|
|
else
|
|
SC_Last := SC_Last + 1;
|
|
end if;
|
|
|
|
-- Record new entry
|
|
|
|
Sloc_Range
|
|
(N, SC_Array (SC_Last).From, SC_Array (SC_Last).To);
|
|
SC_Array (SC_Last).Typ := Typ;
|
|
end Extend_Statement_Sequence;
|
|
|
|
procedure Extend_Statement_Sequence
|
|
(From : Node_Id;
|
|
To : Node_Id;
|
|
Typ : Character)
|
|
is
|
|
begin
|
|
-- Clear out statement sequence if array full
|
|
|
|
if SC_Last = SC_Array'Last then
|
|
Set_Statement_Entry;
|
|
else
|
|
SC_Last := SC_Last + 1;
|
|
end if;
|
|
|
|
-- Make new entry
|
|
|
|
Sloc_Range (From, SC_Array (SC_Last).From, Dummy);
|
|
Sloc_Range (To, Dummy, SC_Array (SC_Last).To);
|
|
SC_Array (SC_Last).Typ := Typ;
|
|
end Extend_Statement_Sequence;
|
|
|
|
-- Start of processing for Traverse_Declarations_Or_Statements
|
|
|
|
begin
|
|
if Is_Non_Empty_List (L) then
|
|
SC_Last := 0;
|
|
|
|
-- Loop through statements or declarations
|
|
|
|
N := First (L);
|
|
while Present (N) loop
|
|
|
|
-- Initialize or extend current statement sequence. Note that for
|
|
-- special cases such as IF and Case statements we will modify
|
|
-- the range to exclude internal statements that should not be
|
|
-- counted as part of the current statement sequence.
|
|
|
|
case Nkind (N) is
|
|
|
|
-- Package declaration
|
|
|
|
when N_Package_Declaration =>
|
|
Set_Statement_Entry;
|
|
Traverse_Package_Declaration (N);
|
|
|
|
-- Generic package declaration
|
|
|
|
when N_Generic_Package_Declaration =>
|
|
Set_Statement_Entry;
|
|
Traverse_Generic_Package_Declaration (N);
|
|
|
|
-- Package body
|
|
|
|
when N_Package_Body =>
|
|
Set_Statement_Entry;
|
|
Traverse_Package_Body (N);
|
|
|
|
-- Subprogram declaration
|
|
|
|
when N_Subprogram_Declaration =>
|
|
Set_Statement_Entry;
|
|
Process_Decisions
|
|
(Parameter_Specifications (Specification (N)), 'X');
|
|
|
|
-- Generic subprogram declaration
|
|
|
|
when N_Generic_Subprogram_Declaration =>
|
|
Set_Statement_Entry;
|
|
Process_Decisions (Generic_Formal_Declarations (N), 'X');
|
|
Process_Decisions
|
|
(Parameter_Specifications (Specification (N)), 'X');
|
|
|
|
-- Subprogram_Body
|
|
|
|
when N_Subprogram_Body =>
|
|
Set_Statement_Entry;
|
|
Traverse_Subprogram_Body (N);
|
|
|
|
-- Exit statement, which is an exit statement in the SCO sense,
|
|
-- so it is included in the current statement sequence, but
|
|
-- then it terminates this sequence. We also have to process
|
|
-- any decisions in the exit statement expression.
|
|
|
|
when N_Exit_Statement =>
|
|
Extend_Statement_Sequence (N, ' ');
|
|
Set_Statement_Entry;
|
|
Process_Decisions (Condition (N), 'E');
|
|
|
|
-- Label, which breaks the current statement sequence, but the
|
|
-- label itself is not included in the next statement sequence,
|
|
-- since it generates no code.
|
|
|
|
when N_Label =>
|
|
Set_Statement_Entry;
|
|
|
|
-- Block statement, which breaks the current statement sequence
|
|
|
|
when N_Block_Statement =>
|
|
Set_Statement_Entry;
|
|
Traverse_Declarations_Or_Statements (Declarations (N));
|
|
Traverse_Handled_Statement_Sequence
|
|
(Handled_Statement_Sequence (N));
|
|
|
|
-- If statement, which breaks the current statement sequence,
|
|
-- but we include the condition in the current sequence.
|
|
|
|
when N_If_Statement =>
|
|
Extend_Statement_Sequence (N, Condition (N), 'I');
|
|
Set_Statement_Entry;
|
|
Process_Decisions (Condition (N), 'I');
|
|
Traverse_Declarations_Or_Statements (Then_Statements (N));
|
|
|
|
if Present (Elsif_Parts (N)) then
|
|
declare
|
|
Elif : Node_Id := First (Elsif_Parts (N));
|
|
begin
|
|
while Present (Elif) loop
|
|
Process_Decisions (Condition (Elif), 'I');
|
|
Traverse_Declarations_Or_Statements
|
|
(Then_Statements (Elif));
|
|
Next (Elif);
|
|
end loop;
|
|
end;
|
|
end if;
|
|
|
|
Traverse_Declarations_Or_Statements (Else_Statements (N));
|
|
|
|
-- Case statement, which breaks the current statement sequence,
|
|
-- but we include the expression in the current sequence.
|
|
|
|
when N_Case_Statement =>
|
|
Extend_Statement_Sequence (N, Expression (N), 'C');
|
|
Set_Statement_Entry;
|
|
Process_Decisions (Expression (N), 'X');
|
|
|
|
-- Process case branches
|
|
|
|
declare
|
|
Alt : Node_Id;
|
|
|
|
begin
|
|
Alt := First (Alternatives (N));
|
|
while Present (Alt) loop
|
|
Traverse_Declarations_Or_Statements (Statements (Alt));
|
|
Next (Alt);
|
|
end loop;
|
|
end;
|
|
|
|
-- Unconditional exit points, which are included in the current
|
|
-- statement sequence, but then terminate it
|
|
|
|
when N_Requeue_Statement |
|
|
N_Goto_Statement |
|
|
N_Raise_Statement =>
|
|
Extend_Statement_Sequence (N, ' ');
|
|
Set_Statement_Entry;
|
|
|
|
-- Simple return statement. which is an exit point, but we
|
|
-- have to process the return expression for decisions.
|
|
|
|
when N_Simple_Return_Statement =>
|
|
Extend_Statement_Sequence (N, ' ');
|
|
Set_Statement_Entry;
|
|
Process_Decisions (Expression (N), 'X');
|
|
|
|
-- Extended return statement
|
|
|
|
when N_Extended_Return_Statement =>
|
|
declare
|
|
Odecl : constant Node_Id :=
|
|
First (Return_Object_Declarations (N));
|
|
begin
|
|
if Present (Expression (Odecl)) then
|
|
Extend_Statement_Sequence
|
|
(N, Expression (Odecl), 'R');
|
|
Process_Decisions (Expression (Odecl), 'X');
|
|
end if;
|
|
end;
|
|
|
|
Traverse_Handled_Statement_Sequence
|
|
(Handled_Statement_Sequence (N));
|
|
|
|
-- Loop ends the current statement sequence, but we include
|
|
-- the iteration scheme if present in the current sequence.
|
|
-- But the body of the loop starts a new sequence, since it
|
|
-- may not be executed as part of the current sequence.
|
|
|
|
when N_Loop_Statement =>
|
|
if Present (Iteration_Scheme (N)) then
|
|
|
|
-- If iteration scheme present, extend the current
|
|
-- statement sequence to include the iteration scheme
|
|
-- and process any decisions it contains.
|
|
|
|
declare
|
|
ISC : constant Node_Id := Iteration_Scheme (N);
|
|
|
|
begin
|
|
-- While statement
|
|
|
|
if Present (Condition (ISC)) then
|
|
Extend_Statement_Sequence (N, ISC, 'W');
|
|
Process_Decisions (Condition (ISC), 'W');
|
|
|
|
-- For statement
|
|
|
|
else
|
|
Extend_Statement_Sequence (N, ISC, 'F');
|
|
Process_Decisions
|
|
(Loop_Parameter_Specification (ISC), 'X');
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
Set_Statement_Entry;
|
|
Traverse_Declarations_Or_Statements (Statements (N));
|
|
|
|
-- Pragma
|
|
|
|
when N_Pragma =>
|
|
Extend_Statement_Sequence (N, 'P');
|
|
|
|
-- For pragmas Assert, Check, Precondition, and
|
|
-- Postcondition, we generate decision entries for the
|
|
-- condition only if the pragma is enabled. For now, we just
|
|
-- check Assertions_Enabled, which will be set to reflect
|
|
-- the presence of -gnata.
|
|
|
|
-- Later we should move processing of the relevant pragmas
|
|
-- to Par_Prag, and properly set the flag Pragma_Enabled at
|
|
-- parse time, so that we can check this flag instead ???
|
|
|
|
-- For all other pragmas, we always generate decision
|
|
-- entries for any embedded expressions.
|
|
|
|
declare
|
|
Nam : constant Name_Id :=
|
|
Chars (Pragma_Identifier (N));
|
|
Arg : Node_Id := First (Pragma_Argument_Associations (N));
|
|
begin
|
|
case Nam is
|
|
when Name_Assert |
|
|
Name_Check |
|
|
Name_Precondition |
|
|
Name_Postcondition =>
|
|
|
|
if Nam = Name_Check then
|
|
Next (Arg);
|
|
end if;
|
|
|
|
if Assertions_Enabled then
|
|
Process_Decisions (Expression (Arg), 'P');
|
|
end if;
|
|
|
|
when others =>
|
|
Process_Decisions (N, 'X');
|
|
end case;
|
|
end;
|
|
|
|
-- All other cases, which extend the current statement sequence
|
|
-- but do not terminate it, even if they have nested decisions.
|
|
|
|
when others =>
|
|
|
|
-- Determine required type character code
|
|
|
|
declare
|
|
Typ : Character;
|
|
|
|
begin
|
|
case Nkind (N) is
|
|
when N_Full_Type_Declaration |
|
|
N_Incomplete_Type_Declaration |
|
|
N_Private_Type_Declaration |
|
|
N_Private_Extension_Declaration =>
|
|
Typ := 't';
|
|
|
|
when N_Subtype_Declaration =>
|
|
Typ := 's';
|
|
|
|
when N_Object_Declaration =>
|
|
Typ := 'o';
|
|
|
|
when N_Renaming_Declaration =>
|
|
Typ := 'r';
|
|
|
|
when N_Generic_Instantiation =>
|
|
Typ := 'i';
|
|
|
|
when others =>
|
|
Typ := ' ';
|
|
end case;
|
|
|
|
Extend_Statement_Sequence (N, Typ);
|
|
end;
|
|
|
|
-- Process any embedded decisions
|
|
|
|
if Has_Decision (N) then
|
|
Process_Decisions (N, 'X');
|
|
end if;
|
|
end case;
|
|
|
|
Next (N);
|
|
end loop;
|
|
|
|
Set_Statement_Entry;
|
|
end if;
|
|
end Traverse_Declarations_Or_Statements;
|
|
|
|
------------------------------------------
|
|
-- Traverse_Generic_Package_Declaration --
|
|
------------------------------------------
|
|
|
|
procedure Traverse_Generic_Package_Declaration (N : Node_Id) is
|
|
begin
|
|
Process_Decisions (Generic_Formal_Declarations (N), 'X');
|
|
Traverse_Package_Declaration (N);
|
|
end Traverse_Generic_Package_Declaration;
|
|
|
|
-----------------------------------------
|
|
-- Traverse_Handled_Statement_Sequence --
|
|
-----------------------------------------
|
|
|
|
procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
|
|
Handler : Node_Id;
|
|
|
|
begin
|
|
|
|
-- For package bodies without a statement part, the parser adds an empty
|
|
-- one, to normalize the representation. The null statement therein,
|
|
-- which does not come from source, does not get a SCO.
|
|
|
|
if Present (N) and then Comes_From_Source (N) then
|
|
Traverse_Declarations_Or_Statements (Statements (N));
|
|
|
|
if Present (Exception_Handlers (N)) then
|
|
Handler := First (Exception_Handlers (N));
|
|
while Present (Handler) loop
|
|
Traverse_Declarations_Or_Statements (Statements (Handler));
|
|
Next (Handler);
|
|
end loop;
|
|
end if;
|
|
end if;
|
|
end Traverse_Handled_Statement_Sequence;
|
|
|
|
---------------------------
|
|
-- Traverse_Package_Body --
|
|
---------------------------
|
|
|
|
procedure Traverse_Package_Body (N : Node_Id) is
|
|
begin
|
|
Traverse_Declarations_Or_Statements (Declarations (N));
|
|
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
|
|
end Traverse_Package_Body;
|
|
|
|
----------------------------------
|
|
-- Traverse_Package_Declaration --
|
|
----------------------------------
|
|
|
|
procedure Traverse_Package_Declaration (N : Node_Id) is
|
|
Spec : constant Node_Id := Specification (N);
|
|
begin
|
|
Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
|
|
Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
|
|
end Traverse_Package_Declaration;
|
|
|
|
------------------------------
|
|
-- Traverse_Subprogram_Body --
|
|
------------------------------
|
|
|
|
procedure Traverse_Subprogram_Body (N : Node_Id) is
|
|
begin
|
|
Traverse_Declarations_Or_Statements (Declarations (N));
|
|
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
|
|
end Traverse_Subprogram_Body;
|
|
|
|
end Par_SCO;
|