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 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 Ctr = 0 then
 143                            Write_SCO_Initiate (U);
 144                            if not Continuation then
 145                               Write_Info_Char ('S');
 146                               Continuation := True;
 147                            else
 148                               Write_Info_Char ('s');
 149                            end if;
 150                         end if;
 151
 152                         Write_Info_Char (' ');
 153
 154                         declare
 155                            Sent : SCO_Table_Entry
 156                                     renames SCO_Table.Table (Start);
 157                         begin
 158                            if Sent.C1 = '>' then
 159                               Write_Info_Char (Sent.C1);
 160                            end if;
 161
 162                            if Sent.C2 /= ' ' then
 163                               Write_Info_Char (Sent.C2);
 164
 165                               if Sent.C1 = 'S'
 166                                 and then (Sent.C2 = 'P' or else Sent.C2 = 'p')
 167                                 and then Sent.Pragma_Name /= Unknown_Pragma
 168                               then
 169                                  --  Strip leading "PRAGMA_"
 170
 171                                  declare
 172                                     Pnam : constant String :=
 173                                              Sent.Pragma_Name'Img;
 174                                  begin
 175                                     Output_String
 176                                       (Pnam (Pnam'First + 7 .. Pnam'Last));
 177                                     Write_Info_Char (':');
 178                                  end;
 179                               end if;
 180                            end if;
 181
 182                            --  For dependence markers (except E), output sloc.
 183                            --  For >E and all statement entries, output sloc
 184                            --  range.
 185
 186                            if Sent.C1 = '>' and then Sent.C2 /= 'E' then
 187                               Output_Source_Location (Sent.From);
 188                            else
 189                               Output_Range (Sent);
 190                            end if;
 191                         end;
 192
 193                         --  Increment entry counter (up to 6 entries per line,
 194                         --  continuation lines are marked Cs).
 195
 196                         Ctr := Ctr + 1;
 197                         if Ctr = 6 then
 198                            Write_Info_Terminate;
 199                            Ctr := 0;
 200                         end if;
 201
 202                         exit when SCO_Table.Table (Start).Last;
 203                         Start := Start + 1;
 204                      end loop;
 205
 206                      if Ctr > 0 then
 207                         Write_Info_Terminate;
 208                      end if;
 209
 210                   --  Decision
 211
 212                   when 'E' | 'G' | 'I' | 'P' | 'W' | 'X' =>
 213                      Start := Start + 1;
 214
 215                      --  For disabled pragma, or nested decision therein, skip
 216                      --  decision output.
 217
 218                      if SCO_Pragma_Disabled (T.Pragma_Sloc) then
 219                         while not SCO_Table.Table (Start).Last loop
 220                            Start := Start + 1;
 221                         end loop;
 222
 223                      --  For all other cases output decision line
 224
 225                      else
 226                         Write_SCO_Initiate (U);
 227                         Write_Info_Char (T.C1);
 228
 229                         if T.C1 /= 'X' then
 230                            Write_Info_Char (' ');
 231                            Output_Source_Location (T.From);
 232                         end if;
 233
 234                         --  Loop through table entries for this decision
 235
 236                         loop
 237                            declare
 238                               T : SCO_Table_Entry
 239                                     renames SCO_Table.Table (Start);
 240
 241                            begin
 242                               Write_Info_Char (' ');
 243
 244                               if T.C1 = '!' or else
 245                                  T.C1 = '&' or else
 246                                  T.C1 = '|'
 247                               then
 248                                  Write_Info_Char (T.C1);
 249                                  Output_Source_Location (T.From);
 250
 251                               else
 252                                  Write_Info_Char (T.C2);
 253                                  Output_Range (T);
 254                               end if;
 255
 256                               exit when T.Last;
 257                               Start := Start + 1;
 258                            end;
 259                         end loop;
 260
 261                         Write_Info_Terminate;
 262                      end if;
 263
 264                   when others =>
 265                      raise Program_Error;
 266                end case;
 267             end Output_SCO_Line;
 268
 269             Start := Start + 1;
 270          end loop;
 271       end;
 272    end loop;
 273 end Put_SCOs;