path: root/gcc/ada/get_scos.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             G E T _ S C O S                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2009-2016, 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.      --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2005;
--  This unit is not part of the compiler proper, it is used in tools that
--  read SCO information from ALI files (Xcov and sco_test). Ada 2005
--  constructs may therefore be used freely (and are indeed).

with Namet;  use Namet;
with SCOs;   use SCOs;
with Types;  use Types;

with Ada.IO_Exceptions; use Ada.IO_Exceptions;

procedure Get_SCOs is
   Dnum : Nat;
   C    : Character;
   Loc1 : Source_Location;
   Loc2 : Source_Location;
   Cond : Character;
   Dtyp : Character;

   use ASCII;
   --  For CR/LF

   function At_EOL return Boolean;
   --  Skips any spaces, then checks if we are the end of a line. If so,
   --  returns True (but does not skip over the EOL sequence). If not,
   --  then returns False.

   procedure Check (C : Character);
   --  Checks that file is positioned at given character, and if so skips past
   --  it, If not, raises Data_Error.

   function Get_Int return Int;
   --  On entry the file is positioned to a digit. On return, the file is
   --  positioned past the last digit, and the returned result is the decimal
   --  value read. Data_Error is raised for overflow (value greater than
   --  Int'Last), or if the initial character is not a digit.

   procedure Get_Source_Location (Loc : out Source_Location);
   --  Reads a source location in the form line:col and places the source
   --  location in Loc. Raises Data_Error if the format does not match this
   --  requirement. Note that initial spaces are not skipped.

   procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location);
   --  Skips initial spaces, then reads a source location range in the form
   --  line:col-line:col and places the two source locations in Loc1 and Loc2.
   --  Raises Data_Error if format does not match this requirement.

   procedure Skip_EOL;
   --  Called with the current character about to be read being LF or CR. Skips
   --  past CR/LF characters until either a non-CR/LF character is found, or
   --  the end of file is encountered.

   procedure Skip_Spaces;
   --  Skips zero or more spaces at the current position, leaving the file
   --  positioned at the first non-blank character (or Types.EOF).

   ------------
   -- At_EOL --
   ------------

   function At_EOL return Boolean is
   begin
      Skip_Spaces;
      return Nextc = CR or else Nextc = LF;
   end At_EOL;

   -----------
   -- Check --
   -----------

   procedure Check (C : Character) is
   begin
      if Nextc = C then
         Skipc;
      else
         raise Data_Error;
      end if;
   end Check;

   -------------
   -- Get_Int --
   -------------

   function Get_Int return Int is
      Val : Int;
      C   : Character;

   begin
      C := Nextc;
      Val := 0;

      if C not in '0' .. '9' then
         raise Data_Error;
      end if;

      --  Loop to read digits of integer value

      loop
         declare
            pragma Unsuppress (Overflow_Check);
         begin
            Val := Val * 10 + (Character'Pos (C) - Character'Pos ('0'));
         end;

         Skipc;
         C := Nextc;

         exit when C not in '0' .. '9';
      end loop;

      return Val;

   exception
      when Constraint_Error =>
         raise Data_Error;
   end Get_Int;

   -------------------------
   -- Get_Source_Location --
   -------------------------

   procedure Get_Source_Location (Loc : out Source_Location) is
      pragma Unsuppress (Range_Check);
   begin
      Loc.Line := Logical_Line_Number (Get_Int);
      Check (':');
      Loc.Col := Column_Number (Get_Int);
   exception
      when Constraint_Error =>
         raise Data_Error;
   end Get_Source_Location;

   -------------------------------
   -- Get_Source_Location_Range --
   -------------------------------

   procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location) is
   begin
      Skip_Spaces;
      Get_Source_Location (Loc1);
      Check ('-');
      Get_Source_Location (Loc2);
   end Get_Source_Location_Range;

   --------------
   -- Skip_EOL --
   --------------

   procedure Skip_EOL is
      C : Character;

   begin
      loop
         Skipc;
         C := Nextc;
         exit when C /= LF and then C /= CR;

         if C = ' ' then
            Skip_Spaces;
            C := Nextc;
            exit when C /= LF and then C /= CR;
         end if;
      end loop;
   end Skip_EOL;

   -----------------
   -- Skip_Spaces --
   -----------------

   procedure Skip_Spaces is
   begin
      while Nextc = ' ' loop
         Skipc;
      end loop;
   end Skip_Spaces;

   Buf : String (1 .. 32_768);
   N   : Natural;
   --  Scratch buffer, and index into it

   Nam : Name_Id;

--  Start of processing for Get_SCOs

begin
   SCOs.Initialize;

   --  Loop through lines of SCO information

   while Nextc = 'C' loop
      Skipc;

      C := Getc;

      --  Make sure first line is a header line

      if SCO_Unit_Table.Last = 0 and then C /= ' ' then
         raise Data_Error;
      end if;

      --  Otherwise dispatch on type of line

      case C is

         --  Header or instance table entry

         when ' ' =>

            --  Complete previous entry if any

            if SCO_Unit_Table.Last /= 0 then
               SCO_Unit_Table.Table (SCO_Unit_Table.Last).To :=
                 SCO_Table.Last;
            end if;

            Skip_Spaces;

            case Nextc is

               --  Instance table entry

               when 'i' =>
                  declare
                     Inum : SCO_Instance_Index;
                  begin
                     Skipc;
                     Skip_Spaces;

                     Inum := SCO_Instance_Index (Get_Int);
                     SCO_Instance_Table.Increment_Last;
                     pragma Assert (SCO_Instance_Table.Last = Inum);

                     Skip_Spaces;
                     declare
                        SIE : SCO_Instance_Table_Entry
                                renames SCO_Instance_Table.Table (Inum);
                     begin
                        SIE.Inst_Dep_Num := Get_Int;
                        C := Getc;
                        pragma Assert (C = '|');
                        Get_Source_Location (SIE.Inst_Loc);

                        if At_EOL then
                           SIE.Enclosing_Instance := 0;
                        else
                           Skip_Spaces;
                           SIE.Enclosing_Instance :=
                             SCO_Instance_Index (Get_Int);
                           pragma Assert (SIE.Enclosing_Instance in
                                            SCO_Instance_Table.First
                                         .. SCO_Instance_Table.Last);
                        end if;
                     end;
                  end;

               --  Unit header

               when '0' .. '9' =>
                  --  Scan out dependency number and file name

                  Dnum := Get_Int;

                  Skip_Spaces;

                  N := 0;
                  while Nextc > ' ' loop
                     N := N + 1;
                     Buf (N) := Getc;
                  end loop;

                  --  Make new unit table entry (will fill in To later)

                  SCO_Unit_Table.Append (
                    (File_Name  => new String'(Buf (1 .. N)),
                     File_Index => 0,
                     Dep_Num    => Dnum,
                     From       => SCO_Table.Last + 1,
                     To         => 0));

               when others =>
                  raise Program_Error;
            end case;

         --  Statement entry

         when 'S' | 's' =>
            declare
               Typ : Character;
               Key : Character;

            begin
               Key := 'S';

               --  If continuation, reset Last indication in last entry stored
               --  for previous CS or cs line.

               if C = 's' then
                  SCO_Table.Table (SCO_Table.Last).Last := False;
               end if;

               --  Initialize to scan items on one line

               Skip_Spaces;

               --  Loop through items on one line

               loop
                  Nam := No_Name;
                  Typ := Nextc;

                  case Typ is
                     when '>' =>

                        --  Dominance marker may be present only at entry point

                        pragma Assert (Key = 'S');

                        Skipc;
                        Key := '>';
                        Typ := Getc;

                        --  Sanity check on dominance marker type indication

                        pragma Assert (Typ in 'A' .. 'Z');

                     when '1' .. '9' =>
                        Typ := ' ';

                     when others =>
                        Skipc;
                        if Typ = 'P' or else Typ = 'p' then
                           if Nextc not in '1' .. '9' then
                              Name_Len := 0;
                              loop
                                 Name_Len := Name_Len + 1;
                                 Name_Buffer (Name_Len) := Getc;
                                 exit when Nextc = ':';
                              end loop;

                              Skipc;  --  Past ':'

                              Nam := Name_Find;
                           end if;
                        end if;
                  end case;

                  if Key = '>' and then Typ /= 'E' then
                     Get_Source_Location (Loc1);
                     Loc2 := No_Source_Location;
                  else
                     Get_Source_Location_Range (Loc1, Loc2);
                  end if;

                  SCO_Table.Append
                    ((C1                 => Key,
                      C2                 => Typ,
                      From               => Loc1,
                      To                 => Loc2,
                      Last               => At_EOL,
                      Pragma_Sloc        => No_Location,
                      Pragma_Aspect_Name => Nam));

                  if Key = '>' then
                     Key := 'S';
                  end if;

                  exit when At_EOL;
               end loop;
            end;

         --  Decision entry

         when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
            Dtyp := C;

            if C = 'A' then
               Name_Len := 0;
               while Nextc /= ' ' loop
                  Name_Len := Name_Len + 1;
                  Name_Buffer (Name_Len) := Getc;
               end loop;

               Nam := Name_Find;

            else
               Nam := No_Name;
            end if;

            Skip_Spaces;

            --  Output header

            declare
               Loc : Source_Location;

            begin
               --  Acquire location information

               if Dtyp = 'X' then
                  Loc := No_Source_Location;
               else
                  Get_Source_Location (Loc);
               end if;

               SCO_Table.Append
                 ((C1                 => Dtyp,
                   C2                 => ' ',
                   From               => Loc,
                   To                 => No_Source_Location,
                   Last               => False,
                   Pragma_Aspect_Name => Nam,
                   others             => <>));
            end;

            --  Loop through terms in complex expression

            C := Nextc;
            while C /= CR and then C /= LF loop
               if C = 'c' or else C = 't' or else C = 'f' then
                  Cond := C;
                  Skipc;
                  Get_Source_Location_Range (Loc1, Loc2);
                  SCO_Table.Append
                    ((C2     => Cond,
                      From   => Loc1,
                      To     => Loc2,
                      Last   => False,
                      others => <>));

               elsif C = '!' or else
                     C = '&' or else
                     C = '|'
               then
                  Skipc;

                  declare
                     Loc : Source_Location;
                  begin
                     Get_Source_Location (Loc);
                     SCO_Table.Append
                       ((C1     => C,
                         From   => Loc,
                         Last   => False,
                         others => <>));
                  end;

               elsif C = ' ' then
                  Skip_Spaces;

               elsif C = 'T' or else C = 'F' then

                  --  Chaining indicator: skip for now???

                  declare
                     Loc1, Loc2 : Source_Location;
                     pragma Unreferenced (Loc1, Loc2);
                  begin
                     Skipc;
                     Get_Source_Location_Range (Loc1, Loc2);
                  end;

               else
                  raise Data_Error;
               end if;

               C := Nextc;
            end loop;

            --  Reset Last indication to True for last entry

            SCO_Table.Table (SCO_Table.Last).Last := True;

         --  No other SCO lines are possible

         when others =>
            raise Data_Error;
      end case;

      Skip_EOL;
   end loop;

   --  Here with all SCO's stored, complete last SCO Unit table entry

   SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last;
end Get_SCOs;