mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-13 08:29:53 +00:00
298 lines
9.9 KiB
Ada
298 lines
9.9 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P U T _ S C O S --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2009-2022, 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 Namet;
|
|
with Opt;
|
|
with SCOs; use SCOs;
|
|
|
|
procedure Put_SCOs is
|
|
Current_SCO_Unit : SCO_Unit_Index := 0;
|
|
-- Initial value must not be a valid unit index
|
|
|
|
procedure Write_SCO_Initiate (SU : SCO_Unit_Index);
|
|
-- Start SCO line for unit SU, also emitting SCO unit header if necessary
|
|
|
|
procedure Write_Instance_Table;
|
|
-- Output the SCO table of instances
|
|
|
|
procedure Output_Range (T : SCO_Table_Entry);
|
|
-- Outputs T.From and T.To in line:col-line:col format
|
|
|
|
procedure Output_Source_Location (Loc : Source_Location);
|
|
-- Output source location in line:col format
|
|
|
|
procedure Output_String (S : String);
|
|
-- Output S
|
|
|
|
------------------
|
|
-- Output_Range --
|
|
------------------
|
|
|
|
procedure Output_Range (T : SCO_Table_Entry) is
|
|
begin
|
|
Output_Source_Location (T.From);
|
|
Write_Info_Char ('-');
|
|
Output_Source_Location (T.To);
|
|
end Output_Range;
|
|
|
|
----------------------------
|
|
-- Output_Source_Location --
|
|
----------------------------
|
|
|
|
procedure Output_Source_Location (Loc : Source_Location) is
|
|
begin
|
|
Write_Info_Nat (Nat (Loc.Line));
|
|
Write_Info_Char (':');
|
|
Write_Info_Nat (Nat (Loc.Col));
|
|
end Output_Source_Location;
|
|
|
|
-------------------
|
|
-- Output_String --
|
|
-------------------
|
|
|
|
procedure Output_String (S : String) is
|
|
begin
|
|
for J in S'Range loop
|
|
Write_Info_Char (S (J));
|
|
end loop;
|
|
end Output_String;
|
|
|
|
--------------------------
|
|
-- Write_Instance_Table --
|
|
--------------------------
|
|
|
|
procedure Write_Instance_Table is
|
|
begin
|
|
for J in 1 .. SCO_Instance_Table.Last loop
|
|
declare
|
|
SIE : SCO_Instance_Table_Entry
|
|
renames SCO_Instance_Table.Table (J);
|
|
begin
|
|
Output_String ("C i ");
|
|
Write_Info_Nat (Nat (J));
|
|
Write_Info_Char (' ');
|
|
Write_Info_Nat (SIE.Inst_Dep_Num);
|
|
Write_Info_Char ('|');
|
|
Output_Source_Location (SIE.Inst_Loc);
|
|
|
|
if SIE.Enclosing_Instance > 0 then
|
|
Write_Info_Char (' ');
|
|
Write_Info_Nat (Nat (SIE.Enclosing_Instance));
|
|
end if;
|
|
Write_Info_Terminate;
|
|
end;
|
|
end loop;
|
|
end Write_Instance_Table;
|
|
|
|
------------------------
|
|
-- Write_SCO_Initiate --
|
|
------------------------
|
|
|
|
procedure Write_SCO_Initiate (SU : SCO_Unit_Index) is
|
|
SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (SU);
|
|
|
|
begin
|
|
if Current_SCO_Unit /= SU then
|
|
Write_Info_Initiate ('C');
|
|
Write_Info_Char (' ');
|
|
Write_Info_Nat (SUT.Dep_Num);
|
|
Write_Info_Char (' ');
|
|
|
|
Output_String (SUT.File_Name.all);
|
|
|
|
Write_Info_Terminate;
|
|
|
|
Current_SCO_Unit := SU;
|
|
end if;
|
|
|
|
Write_Info_Initiate ('C');
|
|
end Write_SCO_Initiate;
|
|
|
|
-- Start of processing for Put_SCOs
|
|
|
|
begin
|
|
-- Loop through entries in SCO_Unit_Table. Note that entry 0 is by
|
|
-- convention present but unused.
|
|
|
|
for U in 1 .. SCO_Unit_Table.Last loop
|
|
declare
|
|
SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (U);
|
|
|
|
Start : Nat;
|
|
Stop : Nat;
|
|
|
|
begin
|
|
Start := SUT.From;
|
|
Stop := SUT.To;
|
|
|
|
-- Loop through SCO entries for this unit
|
|
|
|
loop
|
|
exit when Start = Stop + 1;
|
|
pragma Assert (Start <= Stop);
|
|
|
|
Output_SCO_Line : declare
|
|
T : SCO_Table_Entry renames SCO_Table.Table (Start);
|
|
Continuation : Boolean;
|
|
|
|
Ctr : Nat;
|
|
-- Counter for statement entries
|
|
|
|
begin
|
|
case T.C1 is
|
|
|
|
-- Statements (and dominance markers)
|
|
|
|
when 'S' | '>' =>
|
|
Ctr := 0;
|
|
Continuation := False;
|
|
loop
|
|
if Ctr = 0 then
|
|
Write_SCO_Initiate (U);
|
|
if not Continuation then
|
|
Write_Info_Char ('S');
|
|
Continuation := True;
|
|
else
|
|
Write_Info_Char ('s');
|
|
end if;
|
|
end if;
|
|
|
|
Write_Info_Char (' ');
|
|
|
|
declare
|
|
Sent : SCO_Table_Entry
|
|
renames SCO_Table.Table (Start);
|
|
begin
|
|
if Sent.C1 = '>' then
|
|
Write_Info_Char (Sent.C1);
|
|
end if;
|
|
|
|
if Sent.C2 /= ' ' then
|
|
Write_Info_Char (Sent.C2);
|
|
|
|
if Sent.C1 = 'S'
|
|
and then (Sent.C2 = 'P' or else Sent.C2 = 'p')
|
|
and then Sent.Pragma_Aspect_Name /= No_Name
|
|
then
|
|
Write_Info_Name (Sent.Pragma_Aspect_Name);
|
|
Write_Info_Char (':');
|
|
end if;
|
|
end if;
|
|
|
|
-- For dependence markers (except E), output sloc.
|
|
-- For >E and all statement entries, output sloc
|
|
-- range.
|
|
|
|
if Sent.C1 = '>' and then Sent.C2 /= 'E' then
|
|
Output_Source_Location (Sent.From);
|
|
else
|
|
Output_Range (Sent);
|
|
end if;
|
|
end;
|
|
|
|
-- Increment entry counter (up to 6 entries per line,
|
|
-- continuation lines are marked Cs).
|
|
|
|
Ctr := Ctr + 1;
|
|
if Ctr = 6 then
|
|
Write_Info_Terminate;
|
|
Ctr := 0;
|
|
end if;
|
|
|
|
exit when SCO_Table.Table (Start).Last;
|
|
Start := Start + 1;
|
|
end loop;
|
|
|
|
if Ctr > 0 then
|
|
Write_Info_Terminate;
|
|
end if;
|
|
|
|
-- Decision
|
|
|
|
when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
|
|
Start := Start + 1;
|
|
|
|
Write_SCO_Initiate (U);
|
|
Write_Info_Char (T.C1);
|
|
|
|
if T.C1 = 'A' then
|
|
Write_Info_Name (T.Pragma_Aspect_Name);
|
|
end if;
|
|
|
|
if T.C1 /= 'X' then
|
|
Write_Info_Char (' ');
|
|
Output_Source_Location (T.From);
|
|
end if;
|
|
|
|
-- Loop through table entries for this decision
|
|
|
|
loop
|
|
declare
|
|
T : SCO_Table_Entry renames SCO_Table.Table (Start);
|
|
|
|
begin
|
|
Write_Info_Char (' ');
|
|
|
|
if T.C1 = '!' or else
|
|
T.C1 = '&' or else
|
|
T.C1 = '|'
|
|
then
|
|
Write_Info_Char (T.C1);
|
|
pragma Assert (T.C2 /= '?');
|
|
Output_Source_Location (T.From);
|
|
|
|
else
|
|
Write_Info_Char (T.C2);
|
|
Output_Range (T);
|
|
end if;
|
|
|
|
exit when T.Last;
|
|
Start := Start + 1;
|
|
end;
|
|
end loop;
|
|
|
|
Write_Info_Terminate;
|
|
|
|
when ASCII.NUL =>
|
|
|
|
-- Nullified entry: skip
|
|
|
|
null;
|
|
|
|
when others =>
|
|
raise Program_Error;
|
|
end case;
|
|
end Output_SCO_Line;
|
|
|
|
Start := Start + 1;
|
|
end loop;
|
|
end;
|
|
end loop;
|
|
|
|
if Opt.Generate_SCO_Instance_Table then
|
|
Write_Instance_Table;
|
|
end if;
|
|
end Put_SCOs;
|