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