| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
