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