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-2012, 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 SCOs;   use SCOs;
  32 with Snames; use Snames;
  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 --  Start of processing for Get_Scos
 207
 208 begin
 209    SCOs.Initialize;
 210
 211    --  Loop through lines of SCO information
 212
 213    while Nextc = 'C' loop
 214       Skipc;
 215
 216       C := Getc;
 217
 218       --  Make sure first line is a header line
 219
 220       if SCO_Unit_Table.Last = 0 and then C /= ' ' then
 221          raise Data_Error;
 222       end if;
 223
 224       --  Otherwise dispatch on type of line
 225
 226       case C is
 227
 228          --  Header entry
 229
 230          when ' ' =>
 231
 232             --  Complete previous entry if any
 233
 234             if SCO_Unit_Table.Last /= 0 then
 235                SCO_Unit_Table.Table (SCO_Unit_Table.Last).To :=
 236                  SCO_Table.Last;
 237             end if;
 238
 239             --  Scan out dependency number and file name
 240
 241             Skip_Spaces;
 242             Dnum := Get_Int;
 243
 244             Skip_Spaces;
 245
 246             N := 0;
 247             while Nextc > ' ' loop
 248                N := N + 1;
 249                Buf (N) := Getc;
 250             end loop;
 251
 252             --  Make new unit table entry (will fill in To later)
 253
 254             SCO_Unit_Table.Append (
 255               (File_Name => new String'(Buf (1 .. N)),
 256                Dep_Num   => Dnum,
 257                From      => SCO_Table.Last + 1,
 258                To        => 0));
 259
 260          --  Statement entry
 261
 262          when 'S' | 's' =>
 263             declare
 264                Typ : Character;
 265                Key : Character;
 266                Pid : Pragma_Id;
 267
 268             begin
 269                Key := 'S';
 270
 271                --  If continuation, reset Last indication in last entry stored
 272                --  for previous CS or cs line.
 273
 274                if C = 's' then
 275                   SCO_Table.Table (SCO_Table.Last).Last := False;
 276                end if;
 277
 278                --  Initialize to scan items on one line
 279
 280                Skip_Spaces;
 281
 282                --  Loop through items on one line
 283
 284                loop
 285                   Pid := Unknown_Pragma;
 286                   Typ := Nextc;
 287
 288                   case Typ is
 289                      when '>' =>
 290
 291                         --  Dominance marker may be present only at entry point
 292
 293                         pragma Assert (Key = 'S');
 294
 295                         Skipc;
 296                         Key := '>';
 297                         Typ := Getc;
 298
 299                      when '1' .. '9' =>
 300                         Typ := ' ';
 301
 302                      when others =>
 303                         Skipc;
 304                         if Typ = 'P' or else Typ = 'p' then
 305                            if Nextc not in '1' .. '9' then
 306                               N := 1;
 307                               loop
 308                                  Buf (N) := Getc;
 309                                  exit when Nextc = ':';
 310                                  N := N + 1;
 311                               end loop;
 312
 313                               Skipc;
 314
 315                               begin
 316                                  Pid :=
 317                                    Pragma_Id'Value ("pragma_" & Buf (1 .. N));
 318                               exception
 319                                  when Constraint_Error =>
 320
 321                                     --  Pid remains set to Unknown_Pragma
 322
 323                                     null;
 324                               end;
 325                            end if;
 326                         end if;
 327                   end case;
 328
 329                   if Key = '>' and then Typ /= 'E' then
 330                      Get_Source_Location (Loc1);
 331                      Loc2 := No_Source_Location;
 332                   else
 333                      Get_Source_Location_Range (Loc1, Loc2);
 334                   end if;
 335
 336                   SCO_Table.Append
 337                     ((C1          => Key,
 338                       C2          => Typ,
 339                       From        => Loc1,
 340                       To          => Loc2,
 341                       Last        => At_EOL,
 342                       Pragma_Sloc => No_Location,
 343                       Pragma_Name => Pid));
 344
 345                   if Key = '>' then
 346                      Key := 'S';
 347                   end if;
 348
 349                   exit when At_EOL;
 350                end loop;
 351             end;
 352
 353          --  Decision entry
 354
 355          when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' =>
 356             Dtyp := C;
 357             Skip_Spaces;
 358
 359             --  Output header
 360
 361             declare
 362                Loc : Source_Location;
 363
 364             begin
 365                --  Acquire location information
 366
 367                if Dtyp = 'X' then
 368                   Loc := No_Source_Location;
 369                else
 370                   Get_Source_Location (Loc);
 371                end if;
 372
 373                SCO_Table.Append
 374                  ((C1     => Dtyp,
 375                    C2     => ' ',
 376                    From   => Loc,
 377                    To     => No_Source_Location,
 378                    Last   => False,
 379                    others => <>));
 380             end;
 381
 382             --  Loop through terms in complex expression
 383
 384             C := Nextc;
 385             while C /= CR and then C /= LF loop
 386                if C = 'c' or else C = 't' or else C = 'f' then
 387                   Cond := C;
 388                   Skipc;
 389                   Get_Source_Location_Range (Loc1, Loc2);
 390                   SCO_Table.Append
 391                     ((C2     => Cond,
 392                       From   => Loc1,
 393                       To     => Loc2,
 394                       Last   => False,
 395                       others => <>));
 396
 397                elsif C = '!' or else
 398                      C = '&' or else
 399                      C = '|'
 400                then
 401                   Skipc;
 402
 403                   declare
 404                      Loc : Source_Location;
 405                   begin
 406                      Get_Source_Location (Loc);
 407                      SCO_Table.Append
 408                        ((C1     => C,
 409                          From   => Loc,
 410                          Last   => False,
 411                          others => <>));
 412                   end;
 413
 414                elsif C = ' ' then
 415                   Skip_Spaces;
 416
 417                elsif C = 'T' or else C = 'F' then
 418
 419                   --  Chaining indicator: skip for now???
 420
 421                   declare
 422                      Loc1, Loc2 : Source_Location;
 423                      pragma Unreferenced (Loc1, Loc2);
 424                   begin
 425                      Skipc;
 426                      Get_Source_Location_Range (Loc1, Loc2);
 427                   end;
 428
 429                else
 430                   raise Data_Error;
 431                end if;
 432
 433                C := Nextc;
 434             end loop;
 435
 436             --  Reset Last indication to True for last entry
 437
 438             SCO_Table.Table (SCO_Table.Last).Last := True;
 439
 440          --  No other SCO lines are possible
 441
 442          when others =>
 443             raise Data_Error;
 444       end case;
 445
 446       Skip_EOL;
 447    end loop;
 448
 449    --  Here with all SCO's stored, complete last SCO Unit table entry
 450
 451    SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last;
 452 end Get_SCOs;