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