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-2014, 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
 308             end case;
 309
 310          --  Statement entry
 311
 312          when 'S' | 's' =>
 313             declare
 314                Typ : Character;
 315                Key : Character;
 316
 317             begin
 318                Key := 'S';
 319
 320                --  If continuation, reset Last indication in last entry stored
 321                --  for previous CS or cs line.
 322
 323                if C = 's' then
 324                   SCO_Table.Table (SCO_Table.Last).Last := False;
 325                end if;
 326
 327                --  Initialize to scan items on one line
 328
 329                Skip_Spaces;
 330
 331                --  Loop through items on one line
 332
 333                loop
 334                   Nam := No_Name;
 335                   Typ := Nextc;
 336
 337                   case Typ is
 338                      when '>' =>
 339
 340                         --  Dominance marker may be present only at entry point
 341
 342                         pragma Assert (Key = 'S');
 343
 344                         Skipc;
 345                         Key := '>';
 346                         Typ := Getc;
 347
 348                         --  Sanity check on dominance marker type indication
 349
 350                         pragma Assert (Typ in 'A' .. 'Z');
 351
 352                      when '1' .. '9' =>
 353                         Typ := ' ';
 354
 355                      when others =>
 356                         Skipc;
 357                         if Typ = 'P' or else Typ = 'p' then
 358                            if Nextc not in '1' .. '9' then
 359                               Name_Len := 0;
 360                               loop
 361                                  Name_Len := Name_Len + 1;
 362                                  Name_Buffer (Name_Len) := Getc;
 363                                  exit when Nextc = ':';
 364                               end loop;
 365
 366                               Skipc;  --  Past ':'
 367
 368                               Nam := Name_Find;
 369                            end if;
 370                         end if;
 371                   end case;
 372
 373                   if Key = '>' and then Typ /= 'E' then
 374                      Get_Source_Location (Loc1);
 375                      Loc2 := No_Source_Location;
 376                   else
 377                      Get_Source_Location_Range (Loc1, Loc2);
 378                   end if;
 379
 380                   SCO_Table.Append
 381                     ((C1                 => Key,
 382                       C2                 => Typ,
 383                       From               => Loc1,
 384                       To                 => Loc2,
 385                       Last               => At_EOL,
 386                       Pragma_Sloc        => No_Location,
 387                       Pragma_Aspect_Name => Nam));
 388
 389                   if Key = '>' then
 390                      Key := 'S';
 391                   end if;
 392
 393                   exit when At_EOL;
 394                end loop;
 395             end;
 396
 397          --  Decision entry
 398
 399          when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' | 'A' =>
 400             Dtyp := C;
 401
 402             if C = 'A' then
 403                Name_Len := 0;
 404                while Nextc /= ' ' loop
 405                   Name_Len := Name_Len + 1;
 406                   Name_Buffer (Name_Len) := Getc;
 407                end loop;
 408
 409                Nam := Name_Find;
 410
 411             else
 412                Nam := No_Name;
 413             end if;
 414
 415             Skip_Spaces;
 416
 417             --  Output header
 418
 419             declare
 420                Loc : Source_Location;
 421
 422             begin
 423                --  Acquire location information
 424
 425                if Dtyp = 'X' then
 426                   Loc := No_Source_Location;
 427                else
 428                   Get_Source_Location (Loc);
 429                end if;
 430
 431                SCO_Table.Append
 432                  ((C1                 => Dtyp,
 433                    C2                 => ' ',
 434                    From               => Loc,
 435                    To                 => No_Source_Location,
 436                    Last               => False,
 437                    Pragma_Aspect_Name => Nam,
 438                    others             => <>));
 439             end;
 440
 441             --  Loop through terms in complex expression
 442
 443             C := Nextc;
 444             while C /= CR and then C /= LF loop
 445                if C = 'c' or else C = 't' or else C = 'f' then
 446                   Cond := C;
 447                   Skipc;
 448                   Get_Source_Location_Range (Loc1, Loc2);
 449                   SCO_Table.Append
 450                     ((C2     => Cond,
 451                       From   => Loc1,
 452                       To     => Loc2,
 453                       Last   => False,
 454                       others => <>));
 455
 456                elsif C = '!' or else
 457                      C = '&' or else
 458                      C = '|'
 459                then
 460                   Skipc;
 461
 462                   declare
 463                      Loc : Source_Location;
 464                   begin
 465                      Get_Source_Location (Loc);
 466                      SCO_Table.Append
 467                        ((C1     => C,
 468                          From   => Loc,
 469                          Last   => False,
 470                          others => <>));
 471                   end;
 472
 473                elsif C = ' ' then
 474                   Skip_Spaces;
 475
 476                elsif C = 'T' or else C = 'F' then
 477
 478                   --  Chaining indicator: skip for now???
 479
 480                   declare
 481                      Loc1, Loc2 : Source_Location;
 482                      pragma Unreferenced (Loc1, Loc2);
 483                   begin
 484                      Skipc;
 485                      Get_Source_Location_Range (Loc1, Loc2);
 486                   end;
 487
 488                else
 489                   raise Data_Error;
 490                end if;
 491
 492                C := Nextc;
 493             end loop;
 494
 495             --  Reset Last indication to True for last entry
 496
 497             SCO_Table.Table (SCO_Table.Last).Last := True;
 498
 499          --  No other SCO lines are possible
 500
 501          when others =>
 502             raise Data_Error;
 503       end case;
 504
 505       Skip_EOL;
 506    end loop;
 507
 508    --  Here with all SCO's stored, complete last SCO Unit table entry
 509
 510    SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last;
 511 end Get_SCOs;