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 with Snames;  use Snames;
  29
  30 procedure Put_SCOs is
  31    Current_SCO_Unit : SCO_Unit_Index := 0;
  32    --  Initial value must not be a valid unit index
  33
  34    procedure Write_SCO_Initiate (SU : SCO_Unit_Index);
  35    --  Start SCO line for unit SU, also emitting SCO unit header if necessary
  36
  37    procedure Output_Range (T : SCO_Table_Entry);
  38    --  Outputs T.From and T.To in line:col-line:col format
  39
  40    procedure Output_Source_Location (Loc : Source_Location);
  41    --  Output source location in line:col format
  42
  43    procedure Output_String (S : String);
  44    --  Output S
  45
  46    ------------------
  47    -- Output_Range --
  48    ------------------
  49
  50    procedure Output_Range (T : SCO_Table_Entry) is
  51    begin
  52       Output_Source_Location (T.From);
  53       Write_Info_Char ('-');
  54       Output_Source_Location (T.To);
  55    end Output_Range;
  56
  57    ----------------------------
  58    -- Output_Source_Location --
  59    ----------------------------
  60
  61    procedure Output_Source_Location (Loc : Source_Location) is
  62    begin
  63       Write_Info_Nat  (Nat (Loc.Line));
  64       Write_Info_Char (':');
  65       Write_Info_Nat  (Nat (Loc.Col));
  66    end Output_Source_Location;
  67
  68    -------------------
  69    -- Output_String --
  70    -------------------
  71
  72    procedure Output_String (S : String) is
  73    begin
  74       for J in S'Range loop
  75          Write_Info_Char (S (J));
  76       end loop;
  77    end Output_String;
  78
  79    ------------------------
  80    -- Write_SCO_Initiate --
  81    ------------------------
  82
  83    procedure Write_SCO_Initiate (SU : SCO_Unit_Index) is
  84       SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (SU);
  85
  86    begin
  87       if Current_SCO_Unit /= SU then
  88          Write_Info_Initiate ('C');
  89          Write_Info_Char (' ');
  90          Write_Info_Nat (SUT.Dep_Num);
  91          Write_Info_Char (' ');
  92
  93          Output_String (SUT.File_Name.all);
  94
  95          Write_Info_Terminate;
  96
  97          Current_SCO_Unit := SU;
  98       end if;
  99
 100       Write_Info_Initiate ('C');
 101    end Write_SCO_Initiate;
 102
 103 --  Start of processing for Put_SCOs
 104
 105 begin
 106    --  Loop through entries in SCO_Unit_Table. Note that entry 0 is by
 107    --  convention present but unused.
 108
 109    for U in 1 .. SCO_Unit_Table.Last loop
 110       declare
 111          SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (U);
 112
 113          Start : Nat;
 114          Stop  : Nat;
 115
 116       begin
 117          Start := SUT.From;
 118          Stop  := SUT.To;
 119
 120          --  Loop through SCO entries for this unit
 121
 122          loop
 123             exit when Start = Stop + 1;
 124             pragma Assert (Start <= Stop);
 125
 126             Output_SCO_Line : declare
 127                T            : SCO_Table_Entry renames SCO_Table.Table (Start);
 128                Continuation : Boolean;
 129
 130                Ctr : Nat;
 131                --  Counter for statement entries
 132
 133             begin
 134                case T.C1 is
 135
 136                   --  Statements (and dominance markers)
 137
 138                   when 'S' | '>' =>
 139                      Ctr := 0;
 140                      Continuation := False;
 141                      loop
 142                         if SCO_Pragma_Disabled
 143                              (SCO_Table.Table (Start).Pragma_Sloc)
 144                         then
 145                            goto Next_Statement;
 146                         end if;
 147
 148                         if Ctr = 0 then
 149                            Write_SCO_Initiate (U);
 150                            if not Continuation then
 151                               Write_Info_Char ('S');
 152                               Continuation := True;
 153                            else
 154                               Write_Info_Char ('s');
 155                            end if;
 156                         end if;
 157
 158                         Write_Info_Char (' ');
 159
 160                         declare
 161                            Sent : SCO_Table_Entry
 162                                     renames SCO_Table.Table (Start);
 163                         begin
 164                            if Sent.C1 = '>' then
 165                               Write_Info_Char (Sent.C1);
 166                            end if;
 167
 168                            if Sent.C2 /= ' ' then
 169                               Write_Info_Char (Sent.C2);
 170
 171                               if Sent.C1 = 'S'
 172                                 and then Sent.C2 = 'P'
 173                                 and then Sent.Pragma_Name /= Unknown_Pragma
 174                               then
 175                                  --  Strip leading "PRAGMA_"
 176
 177                                  declare
 178                                     Pnam : constant String :=
 179                                              Sent.Pragma_Name'Img;
 180                                  begin
 181                                     Output_String
 182                                       (Pnam (Pnam'First + 7 .. Pnam'Last));
 183                                     Write_Info_Char (':');
 184                                  end;
 185                               end if;
 186                            end if;
 187
 188                            --  For dependence markers (except E), output sloc.
 189                            --  For >E and all statement entries, output sloc
 190                            --  range.
 191
 192                            if Sent.C1 = '>' and then Sent.C2 /= 'E' then
 193                               Output_Source_Location (Sent.From);
 194                            else
 195                               Output_Range (Sent);
 196                            end if;
 197                         end;
 198
 199                         --  Increment entry counter (up to 6 entries per line,
 200                         --  continuation lines are marked Cs).
 201
 202                         Ctr := Ctr + 1;
 203                         if Ctr = 6 then
 204                            Write_Info_Terminate;
 205                            Ctr := 0;
 206                         end if;
 207
 208                      <<Next_Statement>>
 209                         exit when SCO_Table.Table (Start).Last;
 210                         Start := Start + 1;
 211                      end loop;
 212
 213                      if Ctr > 0 then
 214                         Write_Info_Terminate;
 215                      end if;
 216
 217                   --  Decision
 218
 219                   when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' =>
 220                      Start := Start + 1;
 221
 222                      --  For disabled pragma, or nested decision therein, skip
 223                      --  decision output.
 224
 225                      if SCO_Pragma_Disabled (T.Pragma_Sloc) then
 226                         while not SCO_Table.Table (Start).Last loop
 227                            Start := Start + 1;
 228                         end loop;
 229
 230                      --  For all other cases output decision line
 231
 232                      else
 233                         Write_SCO_Initiate (U);
 234                         Write_Info_Char (T.C1);
 235
 236                         if T.C1 /= 'X' then
 237                            Write_Info_Char (' ');
 238                            Output_Source_Location (T.From);
 239                         end if;
 240
 241                         --  Loop through table entries for this decision
 242
 243                         loop
 244                            declare
 245                               T : SCO_Table_Entry
 246                                     renames SCO_Table.Table (Start);
 247
 248                            begin
 249                               Write_Info_Char (' ');
 250
 251                               if T.C1 = '!' or else
 252                                  T.C1 = '&' or else
 253                                  T.C1 = '|'
 254                               then
 255                                  Write_Info_Char (T.C1);
 256                                  Output_Source_Location (T.From);
 257
 258                               else
 259                                  Write_Info_Char (T.C2);
 260                                  Output_Range (T);
 261                               end if;
 262
 263                               exit when T.Last;
 264                               Start := Start + 1;
 265                            end;
 266                         end loop;
 267
 268                         Write_Info_Terminate;
 269                      end if;
 270
 271                   when others =>
 272                      raise Program_Error;
 273                end case;
 274             end Output_SCO_Line;
 275
 276             Start := Start + 1;
 277          end loop;
 278       end;
 279    end loop;
 280 end Put_SCOs;