gcc/ada/put_scos.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P U T _ S C O S                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2009-2011, 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 Par_SCO; use Par_SCO;
  27 with SCOs;    use SCOs;
  28
  29 procedure Put_SCOs is
  30    Ctr : Nat;
  31
  32    procedure Output_Range (T : SCO_Table_Entry);
  33    --  Outputs T.From and T.To in line:col-line:col format
  34
  35    procedure Output_Source_Location (Loc : Source_Location);
  36    --  Output source location in line:col format
  37
  38    ------------------
  39    -- Output_Range --
  40    ------------------
  41
  42    procedure Output_Range (T : SCO_Table_Entry) is
  43    begin
  44       Output_Source_Location (T.From);
  45       Write_Info_Char ('-');
  46       Output_Source_Location (T.To);
  47    end Output_Range;
  48
  49    ----------------------------
  50    -- Output_Source_Location --
  51    ----------------------------
  52
  53    procedure Output_Source_Location (Loc : Source_Location) is
  54    begin
  55       Write_Info_Nat  (Nat (Loc.Line));
  56       Write_Info_Char (':');
  57       Write_Info_Nat  (Nat (Loc.Col));
  58    end Output_Source_Location;
  59
  60 --  Start of processing for Put_SCOs
  61
  62 begin
  63    --  Loop through entries in SCO_Unit_Table
  64
  65    for U in 1 .. SCO_Unit_Table.Last loop
  66       declare
  67          SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (U);
  68
  69          Start : Nat;
  70          Stop  : Nat;
  71
  72       begin
  73          Start := SUT.From;
  74          Stop  := SUT.To;
  75
  76          --  Write unit header (omitted if no SCOs are generated for this unit)
  77
  78          if Start <= Stop then
  79             Write_Info_Initiate ('C');
  80             Write_Info_Char (' ');
  81             Write_Info_Nat (SUT.Dep_Num);
  82             Write_Info_Char (' ');
  83
  84             for N in SUT.File_Name'Range loop
  85                Write_Info_Char (SUT.File_Name (N));
  86             end loop;
  87
  88             Write_Info_Terminate;
  89          end if;
  90
  91          --  Loop through SCO entries for this unit
  92
  93          loop
  94             exit when Start = Stop + 1;
  95             pragma Assert (Start <= Stop);
  96
  97             Output_SCO_Line : declare
  98                T            : SCO_Table_Entry renames SCO_Table.Table (Start);
  99                Continuation : Boolean;
 100
 101             begin
 102                case T.C1 is
 103
 104                   --  Statements
 105
 106                   when 'S' =>
 107                      Ctr := 0;
 108                      Continuation := False;
 109                      loop
 110                         if SCO_Table.Table (Start).C2 = 'P'
 111                              and then SCO_Pragma_Disabled
 112                                         (SCO_Table.Table (Start).Pragma_Sloc)
 113                         then
 114                            goto Next_Statement;
 115                         end if;
 116
 117                         if Ctr = 0 then
 118                            Write_Info_Initiate ('C');
 119                            if not Continuation then
 120                               Write_Info_Char ('S');
 121                               Continuation := True;
 122                            else
 123                               Write_Info_Char ('s');
 124                            end if;
 125                         end if;
 126
 127                         Write_Info_Char (' ');
 128
 129                         if SCO_Table.Table (Start).C2 /= ' ' then
 130                            Write_Info_Char (SCO_Table.Table (Start).C2);
 131                         end if;
 132
 133                         Output_Range (SCO_Table.Table (Start));
 134
 135                         --  Increment entry counter (up to 6 entries per line,
 136                         --  continuation lines are marked Cs).
 137
 138                         Ctr := Ctr + 1;
 139                         if Ctr = 6 then
 140                            Write_Info_Terminate;
 141                            Ctr := 0;
 142                         end if;
 143
 144                      <<Next_Statement>>
 145                         exit when SCO_Table.Table (Start).Last;
 146                         Start := Start + 1;
 147                         pragma Assert (SCO_Table.Table (Start).C1 = 's');
 148                      end loop;
 149
 150                      Write_Info_Terminate;
 151
 152                   --  Statement continuations should not occur since they
 153                   --  are supposed to have been handled in the loop above.
 154
 155                   when 's' =>
 156                      raise Program_Error;
 157
 158                   --  Decision
 159
 160                   when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
 161                      Start := Start + 1;
 162
 163                      --  For disabled pragma, or nested decision nested, skip
 164                      --  decision output.
 165
 166                      if (T.C1 = 'P' and then T.C2 = 'd')
 167                           or else
 168                         SCO_Pragma_Disabled (T.Pragma_Sloc)
 169                      then
 170                         while not SCO_Table.Table (Start).Last loop
 171                            Start := Start + 1;
 172                         end loop;
 173
 174                      --  For all other cases output decision line
 175
 176                      else
 177                         Write_Info_Initiate ('C');
 178                         Write_Info_Char (T.C1);
 179
 180                         if T.C1 /= 'X' then
 181                            Write_Info_Char (' ');
 182                            Output_Source_Location (T.From);
 183                         end if;
 184
 185                         --  Loop through table entries for this decision
 186
 187                         loop
 188                            declare
 189                               T : SCO_Table_Entry
 190                                     renames SCO_Table.Table (Start);
 191
 192                            begin
 193                               Write_Info_Char (' ');
 194
 195                               if T.C1 = '!' or else
 196                                  T.C1 = '&' or else
 197                                  T.C1 = '|'
 198                               then
 199                                  Write_Info_Char (T.C1);
 200                                  Output_Source_Location (T.From);
 201
 202                               else
 203                                  Write_Info_Char (T.C2);
 204                                  Output_Range (T);
 205                               end if;
 206
 207                               exit when T.Last;
 208                               Start := Start + 1;
 209                            end;
 210                         end loop;
 211
 212                         Write_Info_Terminate;
 213                      end if;
 214
 215                   when others =>
 216                      raise Program_Error;
 217                end case;
 218             end Output_SCO_Line;
 219
 220             Start := Start + 1;
 221          end loop;
 222       end;
 223    end loop;
 224 end Put_SCOs;