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, 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 with SCOs;  use SCOs;
  27 with Types; use Types;
  28
  29 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
  30
  31 procedure Get_SCOs is
  32    Dnum : Nat;
  33    C    : Character;
  34    Loc1 : Source_Location;
  35    Loc2 : Source_Location;
  36    Cond : Character;
  37    Dtyp : Character;
  38
  39    use ASCII;
  40    --  For CR/LF
  41
  42    function At_EOL return Boolean;
  43    --  Skips any spaces, then checks if we are the end of a line. If so,
  44    --  returns True (but does not skip over the EOL sequence). If not,
  45    --  then returns False.
  46
  47    procedure Check (C : Character);
  48    --  Checks that file is positioned at given character, and if so skips past
  49    --  it, If not, raises Data_Error.
  50
  51    function Get_Int return Int;
  52    --  On entry the file is positioned to a digit. On return, the file is
  53    --  positioned past the last digit, and the returned result is the decimal
  54    --  value read. Data_Error is raised for overflow (value greater than
  55    --  Int'Last), or if the initial character is not a digit.
  56
  57    procedure Get_Sloc_Range (Loc1, Loc2 : out Source_Location);
  58    --  Skips initial spaces, then reads a source location range in the form
  59    --  line:col-line:col and places the two source locations in Loc1 and Loc2.
  60    --  Raises Data_Error if format does not match this requirement.
  61
  62    procedure Skip_EOL;
  63    --  Called with the current character about to be read being LF or CR. Skips
  64    --  past CR/LF characters until either a non-CR/LF character is found, or
  65    --  the end of file is encountered.
  66
  67    procedure Skip_Spaces;
  68    --  Skips zero or more spaces at the current position, leaving the file
  69    --  positioned at the first non-blank character (or Types.EOF).
  70
  71    ------------
  72    -- At_EOL --
  73    ------------
  74
  75    function At_EOL return Boolean is
  76    begin
  77       Skip_Spaces;
  78       return Nextc = CR or else Nextc = LF;
  79    end At_EOL;
  80
  81    -----------
  82    -- Check --
  83    -----------
  84
  85    procedure Check (C : Character) is
  86    begin
  87       if Nextc = C then
  88          Skipc;
  89       else
  90          raise Data_Error;
  91       end if;
  92    end Check;
  93
  94    -------------
  95    -- Get_Int --
  96    -------------
  97
  98    function Get_Int return Int is
  99       Val : Int;
 100       C   : Character;
 101
 102    begin
 103       C := Nextc;
 104       Val := 0;
 105
 106       if C not in '0' .. '9' then
 107          raise Data_Error;
 108       end if;
 109
 110       --  Loop to read digits of integer value
 111
 112       loop
 113          declare
 114             pragma Unsuppress (Overflow_Check);
 115          begin
 116             Val := Val * 10 + (Character'Pos (C) - Character'Pos ('0'));
 117          end;
 118
 119          Skipc;
 120          C := Nextc;
 121
 122          exit when C not in '0' .. '9';
 123       end loop;
 124
 125       return Val;
 126
 127    exception
 128       when Constraint_Error =>
 129          raise Data_Error;
 130    end Get_Int;
 131
 132    --------------------
 133    -- Get_Sloc_Range --
 134    --------------------
 135
 136    procedure Get_Sloc_Range (Loc1, Loc2 : out Source_Location) is
 137       pragma Unsuppress (Range_Check);
 138
 139    begin
 140       Skip_Spaces;
 141
 142       Loc1.Line := Logical_Line_Number (Get_Int);
 143       Check (':');
 144       Loc1.Col := Column_Number (Get_Int);
 145
 146       Check ('-');
 147
 148       Loc2.Line := Logical_Line_Number (Get_Int);
 149       Check (':');
 150       Loc2.Col := Column_Number (Get_Int);
 151
 152    exception
 153       when Constraint_Error =>
 154          raise Data_Error;
 155    end Get_Sloc_Range;
 156
 157    --------------
 158    -- Skip_EOL --
 159    --------------
 160
 161    procedure Skip_EOL is
 162       C : Character;
 163
 164    begin
 165       loop
 166          Skipc;
 167          C := Nextc;
 168          exit when C /= LF and then C /= CR;
 169
 170          if C = ' ' then
 171             Skip_Spaces;
 172             C := Nextc;
 173             exit when C /= LF and then C /= CR;
 174          end if;
 175       end loop;
 176    end Skip_EOL;
 177
 178    -----------------
 179    -- Skip_Spaces --
 180    -----------------
 181
 182    procedure Skip_Spaces is
 183    begin
 184       while Nextc = ' ' loop
 185          Skipc;
 186       end loop;
 187    end Skip_Spaces;
 188
 189 --  Start of processing for Get_Scos
 190
 191 begin
 192    SCOs.Initialize;
 193
 194    --  Loop through lines of SCO information
 195
 196    while Nextc = 'C' loop
 197       Skipc;
 198
 199       C := Getc;
 200
 201       --  Make sure first line is a header line
 202
 203       if SCO_Unit_Table.Last = 0 and then C /= ' ' then
 204          raise Data_Error;
 205       end if;
 206
 207       --  Otherwise dispatch on type of line
 208
 209       case C is
 210
 211          --  Header entry
 212
 213          when ' ' =>
 214
 215             --  Complete previous entry if any
 216
 217             if SCO_Unit_Table.Last /= 0 then
 218                SCO_Unit_Table.Table (SCO_Unit_Table.Last).To :=
 219                  SCO_Table.Last;
 220             end if;
 221
 222             --  Scan out dependency number and file name
 223
 224             declare
 225                Ptr  : String_Ptr := new String (1 .. 32768);
 226                N    : Integer;
 227
 228             begin
 229                Skip_Spaces;
 230                Dnum := Get_Int;
 231
 232                Skip_Spaces;
 233
 234                N := 0;
 235                while Nextc > ' ' loop
 236                   N := N + 1;
 237                   Ptr.all (N) := Getc;
 238                end loop;
 239
 240                --  Make new unit table entry (will fill in To later)
 241
 242                SCO_Unit_Table.Append (
 243                  (File_Name => new String'(Ptr.all (1 .. N)),
 244                   Dep_Num   => Dnum,
 245                   From      => SCO_Table.Last + 1,
 246                   To        => 0));
 247
 248                Free (Ptr);
 249             end;
 250
 251          --  Statement entry
 252
 253          when 'S' =>
 254             declare
 255                Typ : Character;
 256                Key : Character;
 257
 258             begin
 259                Skip_Spaces;
 260                Key := 'S';
 261
 262                loop
 263                   Typ := Nextc;
 264
 265                   if Typ in '1' .. '9' then
 266                      Typ := ' ';
 267                   else
 268                      Skipc;
 269                   end if;
 270
 271                   Get_Sloc_Range (Loc1, Loc2);
 272
 273                   Add_SCO
 274                     (C1   => Key,
 275                      C2   => Typ,
 276                      From => Loc1,
 277                      To   => Loc2,
 278                      Last => At_EOL);
 279
 280                   exit when At_EOL;
 281                   Key := 's';
 282                end loop;
 283             end;
 284
 285          --  Decision entry
 286
 287          when 'I' | 'E' | 'P' | 'W' | 'X' =>
 288             Dtyp := C;
 289             Skip_Spaces;
 290             C := Getc;
 291
 292             --  Case of simple condition
 293
 294             if C = 'c' or else C = 't' or else C = 'f' then
 295                Cond := C;
 296                Get_Sloc_Range (Loc1, Loc2);
 297                Add_SCO
 298                  (C1   => Dtyp,
 299                   C2   => Cond,
 300                   From => Loc1,
 301                   To   => Loc2,
 302                   Last => True);
 303
 304             --  Complex expression
 305
 306             else
 307                Add_SCO (C1 => Dtyp, Last => False);
 308
 309                --  Loop through terms in complex expression
 310
 311                while C /= CR and then C /= LF loop
 312                   if C = 'c' or else C = 't' or else C = 'f' then
 313                      Cond := C;
 314                      Skipc;
 315                      Get_Sloc_Range (Loc1, Loc2);
 316                      Add_SCO
 317                        (C2   => Cond,
 318                         From => Loc1,
 319                         To   => Loc2,
 320                         Last => False);
 321
 322                   elsif C = '!' or else
 323                         C = '^' or else
 324                         C = '&' or else
 325                         C = '|'
 326                   then
 327                      Skipc;
 328                      Add_SCO (C1 => C, Last => False);
 329
 330                   elsif C = ' ' then
 331                      Skip_Spaces;
 332
 333                   else
 334                      raise Data_Error;
 335                   end if;
 336
 337                   C := Nextc;
 338                end loop;
 339
 340                --  Reset Last indication to True for last entry
 341
 342                SCO_Table.Table (SCO_Table.Last).Last := True;
 343             end if;
 344
 345          when others =>
 346             raise Data_Error;
 347       end case;
 348
 349       Skip_EOL;
 350    end loop;
 351
 352    --  Here with all SCO's stored, complete last SCO Unit table entry
 353
 354    SCO_Unit_Table.Table (SCO_Unit_Table.Last).To := SCO_Table.Last;
 355 end Get_SCOs;