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