gcc/ada/get_scos.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             G E T _ S C O S                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2009-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 pragma Ada_2005;
  27 --  This unit is not part of the compiler proper, it is used in tools that
  28 --  read SCO information from ALI files (Xcov and sco_test). Ada 2005
  29 --  constructs may therefore be used freely (and are indeed).
  30
  31 with Namet;  use Namet;
  32 with SCOs;   use SCOs;
  33 with Types;  use Types;
  34
  35 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
  36
  37 procedure Get_SCOs is
  38    Dnum : Nat;
  39    C    : Character;
  40    Loc1 : Source_Location;
  41    Loc2 : Source_Location;
  42    Cond : Character;
  43    Dtyp : Character;
  44
  45    use ASCII;
  46    --  For CR/LF
  47
  48    function At_EOL return Boolean;
  49    --  Skips any spaces, then checks if we are the end of a line. If so,
  50    --  returns True (but does not skip over the EOL sequence). If not,
  51    --  then returns False.
  52
  53    procedure Check (C : Character);
  54    --  Checks that file is positioned at given character, and if so skips past
  55    --  it, If not, raises Data_Error.
  56
  57    function Get_Int return Int;
  58    --  On entry the file is positioned to a digit. On return, the file is
  59    --  positioned past the last digit, and the returned result is the decimal
  60    --  value read. Data_Error is raised for overflow (value greater than
  61    --  Int'Last), or if the initial character is not a digit.
  62
  63    procedure Get_Source_Location (Loc : out Source_Location);
  64    --  Reads a source location in the form line:col and places the source
  65    --  location in Loc. Raises Data_Error if the format does not match this
  66    --  requirement. Note that initial spaces are not skipped.
  67
  68    procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location);
  69    --  Skips initial spaces, then reads a source location range in the form
  70    --  line:col-line:col and places the two source locations in Loc1 and Loc2.
  71    --  Raises Data_Error if format does not match this requirement.
  72
  73    procedure Skip_EOL;
  74    --  Called with the current character about to be read being LF or CR. Skips
  75    --  past CR/LF characters until either a non-CR/LF character is found, or
  76    --  the end of file is encountered.
  77
  78    procedure Skip_Spaces;
  79    --  Skips zero or more spaces at the current position, leaving the file
  80    --  positioned at the first non-blank character (or Types.EOF).
  81
  82    ------------
  83    -- At_EOL --
  84    ------------
  85
  86    function At_EOL return Boolean is
  87    begin
  88       Skip_Spaces;
  89       return Nextc = CR or else Nextc = LF;
  90    end At_EOL;
  91
  92    -----------
  93    -- Check --
  94    -----------
  95
  96    procedure Check (C : Character) is
  97    begin
  98       if Nextc = C then
  99          Skipc;
 100       else
 101          raise Data_Error;
 102       end if;
 103    end Check;
 104
 105    -------------
 106    -- Get_Int --
 107    -------------
 108
 109    function Get_Int return Int is
 110       Val : Int;
 111       C   : Character;
 112
 113    begin
 114       C := Nextc;
 115       Val := 0;
 116
 117       if C not in '0' .. '9' then
 118          raise Data_Error;
 119       end if;
 120
 121       --  Loop to read digits of integer value
 122
 123       loop
 124          declare
 125             pragma Unsuppress (Overflow_Check);
 126          begin
 127             Val := Val * 10 + (Character'Pos (C) - Character'Pos ('0'));
 128          end;
 129
 130          Skipc;
 131          C := Nextc;
 132
 133          exit when C not in '0' .. '9';
 134       end loop;
 135
 136       return Val;
 137
 138    exception
 139       when Constraint_Error =>
 140          raise Data_Error;
 141    end Get_Int;
 142
 143    -------------------------
 144    -- Get_Source_Location --
 145    -------------------------
 146
 147    procedure Get_Source_Location (Loc : out Source_Location) is
 148       pragma Unsuppress (Range_Check);
 149    begin
 150       Loc.Line := Logical_Line_Number (Get_Int);
 151       Check (':');
 152       Loc.Col := Column_Number (Get_Int);
 153    exception
 154       when Constraint_Error =>
 155          raise Data_Error;
 156    end Get_Source_Location;
 157
 158    -------------------------------
 159    -- Get_Source_Location_Range --
 160    -------------------------------
 161
 162    procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location) is
 163    begin
 164       Skip_Spaces;
 165       Get_Source_Location (Loc1);
 166       Check ('-');
 167       Get_Source_Location (Loc2);
 168    end Get_Source_Location_Range;
 169
 170    --------------
 171    -- Skip_EOL --
 172    --------------
 173
 174    procedure Skip_EOL is
 175       C : Character;
 176
 177    begin
 178       loop
 179          Skipc;
 180          C := Nextc;
 181          exit when C /= LF and then C /= CR;
 182       end loop;
 183    end Skip_EOL;
 184
 185    -----------------
 186    -- Skip_Spaces --
 187    -----------------
 188
 189    procedure Skip_Spaces is
 190    begin
 191       while Nextc = ' ' loop
 192          Skipc;
 193       end loop;
 194    end Skip_Spaces;
 195
 196    Buf : String (1 .. 32_768);
 197    N   : Natural;
 198    --  Scratch buffer, and index into it
 199
 200    Nam : Name_Id;
 201
 202 --  Start of processing for Get_SCOs
 203
 204 begin
 205    SCOs.Initialize;
 206
 207    --  Loop through lines of SCO information
 208
 209    while Nextc = 'C' loop
 210       Skipc;
 211
 212       C := Getc;
 213
 214       --  Make sure first line is a header line
 215
 216       if SCO_Unit_Table.Last = 0 and then C /= ' ' then
 217          raise Data_Error;
 218       end if;
 219
 220       --  Otherwise dispatch on type of line
 221
 222       case C is
 223
 224          --  Header or instance table entry
 225
 226          when ' ' =>
 227
 228             --  Complete previous entry if any
 229
 230             if SCO_Unit_Table.Last /= 0 then
 231                SCO_Unit_Table.Table (SCO_Unit_Table.Last).To :=
 232                  SCO_Table.Last;
 233             end if;
 234
 235             Skip_Spaces;
 236
 237             case Nextc is
 238
 239                --  Instance table entry
 240
 241                when 'i' =>
 242                   declare
 243                      Inum : SCO_Instance_Index;
 244                   begin
 245                      Skipc;
 246                      Skip_Spaces;
 247
 248                      Inum := SCO_Instance_Index (Get_Int);
 249                      SCO_Instance_Table.Increment_Last;
 250                      pragma Assert (SCO_Instance_Table.Last = Inum);
 251
 252                      Skip_Spaces;
 253                      declare
 254                         SIE : SCO_Instance_Table_Entry
 255                                 renames SCO_Instance_Table.Table (Inum);
 256                      begin
 257                         SIE.Inst_Dep_Num := Get_Int;
 258                         C := Getc;
 259                         pragma Assert (C = '|');
 260                         Get_Source_Location (SIE.Inst_Loc);
 261
 262                         if At_EOL then
 263                            SIE.Enclosing_Instance := 0;
 264                         else
 265                            Skip_Spaces;
 266                            SIE.Enclosing_Instance :=
 267                              SCO_Instance_Index (Get_Int);
 268                            pragma Assert (SIE.Enclosing_Instance in
 269                                             SCO_Instance_Table.First
 270                                          .. SCO_Instance_Table.Last);
 271                         end if;
 272                      end;
 273                   end;
 274
 275                --  Unit header
 276
 277                when '0' .. '9' =>
 278                   --  Scan out dependency number and file name
 279
 280                   Dnum := Get_Int;
 281
 282                   Skip_Spaces;
 283
 284                   N := 0;
 285                   while Nextc > ' ' loop
 286                      N := N + 1;
 287                      Buf (N) := Getc;
 288                   end loop;
 289
 290                   --  Make new unit table entry (will fill in To later)
 291
 292                   SCO_Unit_Table.Append (
 293                     (File_Name  => new String'(Buf (1 .. N)),
 294                      File_Index => 0,
 295                      Dep_Num    => Dnum,
 296                      From       => SCO_Table.Last + 1,
 297                      To         => 0));
 298
 299                when others =>
 300                   raise Program_Error;
 301             end case;
 302
 303          --  Statement entry
 304
 305          when 'S' | 's' =>
 306             declare
 307                Typ : Character;
 308                Key : Character;
 309
 310             begin
 311                Key := 'S';
 312
 313                --  If continuation, reset Last indication in last entry stored
 314                --  for previous CS or cs line.
 315
 316                if C = 's' then
 317                   SCO_Table.Table (SCO_Table.Last).Last := False;
 318                end if;
 319
 320                --  Initialize to scan items on one line
 321
 322                Skip_Spaces;
 323
 324                --  Loop through items on one line
 325
 326                loop
 327                   Nam := No_Name;
 328                   Typ := Nextc;
 329
 330                   case Typ is
 331                      when '>' =>
 332
 333                         --  Dominance marker may be present only at entry point
 334
 335                         pragma Assert (Key = 'S');
 336
 337                         Skipc;
 338                         Key := '>';
 339                         Typ := Getc;
 340
 341                         --  Sanity check on dominance marker type indication
 342
 343                         pragma Assert (Typ in 'A' .. 'Z');
 344
 345                      when '1' .. '9' =>
 346                         Typ := ' ';
 347
 348                      when others =>
 349                         Skipc;
 350                         if Typ = 'P' or else Typ = 'p' then
 351                            if Nextc not in '1' .. '9' then
 352                               Name_Len := 0;
 353                               loop
 354                                  Name_Len := Name_Len + 1;
 355                                  Name_Buffer (Name_Len) := Getc;
 356                                  exit when Nextc = ':';
 357                               end loop;
 358
 359                               Skipc;  --  Past ':'
 360
 361                               Nam := Name_Find;
 362                            end if;
 363                         end if;
 364                   end case;
 365
 366                   if Key = '>' and then Typ /= 'E' then
 367                      Get_Source_Location (Loc1);
 368                      Loc2 := No_Source_Location;
 369                   else
 370                      Get_Source_Location_Range (Loc1, Loc2);
 371                   end if;
 372
 373                   SCO_Table.Append
 374                     ((C1                 => Key,
 375                       C2                 => Typ,
 376                       From               => Loc1,
 377                       To                 => Loc2,
 378                       Last               => At_EOL,
 379                       Pragma_Sloc        => No_Location,
 380                       Pragma_Aspect_Name => Nam));
 381
 382                   if Key = '>' then
 383                      Key := 'S';
 384                   end if;
 385
 386                   exit when At_EOL;
 387                end loop;
 388             end;
 389
 390          --  Decision entry
 391
 392          when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
 393             Dtyp := C;
 394
 395             if C = 'A' then
 396                Name_Len := 0;
 397                while Nextc /= ' ' loop
 398                   Name_Len := Name_Len + 1;
 399                   Name_Buffer (Name_Len) := Getc;
 400                end loop;
 401
 402                Nam := Name_Find;
 403
 404             else
 405                Nam := No_Name;
 406             end if;
 407
 408             Skip_Spaces;
 409
 410             --  Output header
 411
 412             declare
 413                Loc : Source_Location;
 414
 415             begin
 416                --  Acquire location information
 417
 418                if Dtyp = 'X' then
 419                   Loc := No_Source_Location;
 420                else
 421                   Get_Source_Location (Loc);
 422                end if;
 423
 424                SCO_Table.Append
 425                  ((C1                 => Dtyp,
 426                    C2                 => ' ',
 427                    From               => Loc,
 428                    To                 => No_Source_Location,
 429                    Last               => False,
 430                    Pragma_Aspect_Name => Nam,
 431                    others             => <>));
 432             end;
 433
 434             --  Loop through terms in complex expression
 435
 436             C := Nextc;
 437             while C /= CR and then C /= LF loop
 438                if C = 'c' or else C = 't' or else C = 'f' then
 439                   Cond := C;
 440                   Skipc;
 441                   Get_Source_Location_Range (Loc1, Loc2);
 442                   SCO_Table.Append
 443                     ((C2     => Cond,
 444                       From   => Loc1,
 445                       To     => Loc2,
 446                       Last   => False,
 447                       others => <>));
 448
 449                elsif C = '!' or else
 450                      C = '&' or else
 451                      C = '|'
 452                then
 453                   Skipc;
 454
 455                   declare
 456                      Loc : Source_Location;
 457                   begin
 458                      Get_Source_Location (Loc);
 459                      SCO_Table.Append
 460                        ((C1     => C,
 461                          From   => Loc,
 462                          Last   => False,
 463                          others => <>));
 464                   end;
 465
 466                elsif C = ' ' then
 467                   Skip_Spaces;
 468
 469                elsif C = 'T' or else C = 'F' then
 470
 471                   --  Chaining indicator: skip for now???
 472
 473                   declare
 474                      Loc1, Loc2 : Source_Location;
 475                      pragma Unreferenced (Loc1, Loc2);
 476                   begin
 477                      Skipc;
 478                      Get_Source_Location_Range (Loc1, Loc2);
 479                   end;
 480
 481                else
 482                   raise Data_Error;
 483                end if;
 484
 485                C := Nextc;
 486             end loop;
 487
 488             --  Reset Last indication to True for last entry
 489
 490             SCO_Table.Table (SCO_Table.Last).Last := True;
 491
 492          --  No other SCO lines are possible
 493
 494          when others =>
 495             raise Data_Error;
 496       end case;
 497
 498       Skip_EOL;
 499    end loop;
 500
 501    --  Here with all SCO's stored, complete last SCO Unit table entry
 502
 503    SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last;
 504 end Get_SCOs;