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-2016, 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
 183          if C = ' ' then
 184             Skip_Spaces;
 185             C := Nextc;
 186             exit when C /= LF and then C /= CR;
 187          end if;
 188       end loop;
 189    end Skip_EOL;
 190
 191    -----------------
 192    -- Skip_Spaces --
 193    -----------------
 194
 195    procedure Skip_Spaces is
 196    begin
 197       while Nextc = ' ' loop
 198          Skipc;
 199       end loop;
 200    end Skip_Spaces;
 201
 202    Buf : String (1 .. 32_768);
 203    N   : Natural;
 204    --  Scratch buffer, and index into it
 205
 206    Nam : Name_Id;
 207
 208 --  Start of processing for Get_SCOs
 209
 210 begin
 211    SCOs.Initialize;
 212
 213    --  Loop through lines of SCO information
 214
 215    while Nextc = 'C' loop
 216       Skipc;
 217
 218       C := Getc;
 219
 220       --  Make sure first line is a header line
 221
 222       if SCO_Unit_Table.Last = 0 and then C /= ' ' then
 223          raise Data_Error;
 224       end if;
 225
 226       --  Otherwise dispatch on type of line
 227
 228       case C is
 229
 230          --  Header or instance table entry
 231
 232          when ' ' =>
 233
 234             --  Complete previous entry if any
 235
 236             if SCO_Unit_Table.Last /= 0 then
 237                SCO_Unit_Table.Table (SCO_Unit_Table.Last).To :=
 238                  SCO_Table.Last;
 239             end if;
 240
 241             Skip_Spaces;
 242
 243             case Nextc is
 244
 245                --  Instance table entry
 246
 247                when 'i' =>
 248                   declare
 249                      Inum : SCO_Instance_Index;
 250                   begin
 251                      Skipc;
 252                      Skip_Spaces;
 253
 254                      Inum := SCO_Instance_Index (Get_Int);
 255                      SCO_Instance_Table.Increment_Last;
 256                      pragma Assert (SCO_Instance_Table.Last = Inum);
 257
 258                      Skip_Spaces;
 259                      declare
 260                         SIE : SCO_Instance_Table_Entry
 261                                 renames SCO_Instance_Table.Table (Inum);
 262                      begin
 263                         SIE.Inst_Dep_Num := Get_Int;
 264                         C := Getc;
 265                         pragma Assert (C = '|');
 266                         Get_Source_Location (SIE.Inst_Loc);
 267
 268                         if At_EOL then
 269                            SIE.Enclosing_Instance := 0;
 270                         else
 271                            Skip_Spaces;
 272                            SIE.Enclosing_Instance :=
 273                              SCO_Instance_Index (Get_Int);
 274                            pragma Assert (SIE.Enclosing_Instance in
 275                                             SCO_Instance_Table.First
 276                                          .. SCO_Instance_Table.Last);
 277                         end if;
 278                      end;
 279                   end;
 280
 281                --  Unit header
 282
 283                when '0' .. '9' =>
 284                   --  Scan out dependency number and file name
 285
 286                   Dnum := Get_Int;
 287
 288                   Skip_Spaces;
 289
 290                   N := 0;
 291                   while Nextc > ' ' loop
 292                      N := N + 1;
 293                      Buf (N) := Getc;
 294                   end loop;
 295
 296                   --  Make new unit table entry (will fill in To later)
 297
 298                   SCO_Unit_Table.Append (
 299                     (File_Name  => new String'(Buf (1 .. N)),
 300                      File_Index => 0,
 301                      Dep_Num    => Dnum,
 302                      From       => SCO_Table.Last + 1,
 303                      To         => 0));
 304
 305                when others =>
 306                   raise Program_Error;
 307             end case;
 308
 309          --  Statement entry
 310
 311          when 'S' | 's' =>
 312             declare
 313                Typ : Character;
 314                Key : Character;
 315
 316             begin
 317                Key := 'S';
 318
 319                --  If continuation, reset Last indication in last entry stored
 320                --  for previous CS or cs line.
 321
 322                if C = 's' then
 323                   SCO_Table.Table (SCO_Table.Last).Last := False;
 324                end if;
 325
 326                --  Initialize to scan items on one line
 327
 328                Skip_Spaces;
 329
 330                --  Loop through items on one line
 331
 332                loop
 333                   Nam := No_Name;
 334                   Typ := Nextc;
 335
 336                   case Typ is
 337                      when '>' =>
 338
 339                         --  Dominance marker may be present only at entry point
 340
 341                         pragma Assert (Key = 'S');
 342
 343                         Skipc;
 344                         Key := '>';
 345                         Typ := Getc;
 346
 347                         --  Sanity check on dominance marker type indication
 348
 349                         pragma Assert (Typ in 'A' .. 'Z');
 350
 351                      when '1' .. '9' =>
 352                         Typ := ' ';
 353
 354                      when others =>
 355                         Skipc;
 356                         if Typ = 'P' or else Typ = 'p' then
 357                            if Nextc not in '1' .. '9' then
 358                               Name_Len := 0;
 359                               loop
 360                                  Name_Len := Name_Len + 1;
 361                                  Name_Buffer (Name_Len) := Getc;
 362                                  exit when Nextc = ':';
 363                               end loop;
 364
 365                               Skipc;  --  Past ':'
 366
 367                               Nam := Name_Find;
 368                            end if;
 369                         end if;
 370                   end case;
 371
 372                   if Key = '>' and then Typ /= 'E' then
 373                      Get_Source_Location (Loc1);
 374                      Loc2 := No_Source_Location;
 375                   else
 376                      Get_Source_Location_Range (Loc1, Loc2);
 377                   end if;
 378
 379                   SCO_Table.Append
 380                     ((C1                 => Key,
 381                       C2                 => Typ,
 382                       From               => Loc1,
 383                       To                 => Loc2,
 384                       Last               => At_EOL,
 385                       Pragma_Sloc        => No_Location,
 386                       Pragma_Aspect_Name => Nam));
 387
 388                   if Key = '>' then
 389                      Key := 'S';
 390                   end if;
 391
 392                   exit when At_EOL;
 393                end loop;
 394             end;
 395
 396          --  Decision entry
 397
 398          when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
 399             Dtyp := C;
 400
 401             if C = 'A' then
 402                Name_Len := 0;
 403                while Nextc /= ' ' loop
 404                   Name_Len := Name_Len + 1;
 405                   Name_Buffer (Name_Len) := Getc;
 406                end loop;
 407
 408                Nam := Name_Find;
 409
 410             else
 411                Nam := No_Name;
 412             end if;
 413
 414             Skip_Spaces;
 415
 416             --  Output header
 417
 418             declare
 419                Loc : Source_Location;
 420
 421             begin
 422                --  Acquire location information
 423
 424                if Dtyp = 'X' then
 425                   Loc := No_Source_Location;
 426                else
 427                   Get_Source_Location (Loc);
 428                end if;
 429
 430                SCO_Table.Append
 431                  ((C1                 => Dtyp,
 432                    C2                 => ' ',
 433                    From               => Loc,
 434                    To                 => No_Source_Location,
 435                    Last               => False,
 436                    Pragma_Aspect_Name => Nam,
 437                    others             => <>));
 438             end;
 439
 440             --  Loop through terms in complex expression
 441
 442             C := Nextc;
 443             while C /= CR and then C /= LF loop
 444                if C = 'c' or else C = 't' or else C = 'f' then
 445                   Cond := C;
 446                   Skipc;
 447                   Get_Source_Location_Range (Loc1, Loc2);
 448                   SCO_Table.Append
 449                     ((C2     => Cond,
 450                       From   => Loc1,
 451                       To     => Loc2,
 452                       Last   => False,
 453                       others => <>));
 454
 455                elsif C = '!' or else
 456                      C = '&' or else
 457                      C = '|'
 458                then
 459                   Skipc;
 460
 461                   declare
 462                      Loc : Source_Location;
 463                   begin
 464                      Get_Source_Location (Loc);
 465                      SCO_Table.Append
 466                        ((C1     => C,
 467                          From   => Loc,
 468                          Last   => False,
 469                          others => <>));
 470                   end;
 471
 472                elsif C = ' ' then
 473                   Skip_Spaces;
 474
 475                elsif C = 'T' or else C = 'F' then
 476
 477                   --  Chaining indicator: skip for now???
 478
 479                   declare
 480                      Loc1, Loc2 : Source_Location;
 481                      pragma Unreferenced (Loc1, Loc2);
 482                   begin
 483                      Skipc;
 484                      Get_Source_Location_Range (Loc1, Loc2);
 485                   end;
 486
 487                else
 488                   raise Data_Error;
 489                end if;
 490
 491                C := Nextc;
 492             end loop;
 493
 494             --  Reset Last indication to True for last entry
 495
 496             SCO_Table.Table (SCO_Table.Last).Last := True;
 497
 498          --  No other SCO lines are possible
 499
 500          when others =>
 501             raise Data_Error;
 502       end case;
 503
 504       Skip_EOL;
 505    end loop;
 506
 507    --  Here with all SCO's stored, complete last SCO Unit table entry
 508
 509    SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last;
 510 end Get_SCOs;