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 begin
  30    --  Loop through entries in SCO_Unit_Table
  31
  32    for U in 1 .. SCO_Unit_Table.Last loop
  33       declare
  34          SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (U);
  35
  36          Start : Nat;
  37          Stop  : Nat;
  38
  39       begin
  40          Start := SUT.From;
  41          Stop  := SUT.To;
  42
  43          --  Write unit header (omitted if no SCOs are generated for this unit)
  44
  45          if Start <= Stop then
  46             Write_Info_Initiate ('C');
  47             Write_Info_Char (' ');
  48             Write_Info_Nat (SUT.Dep_Num);
  49             Write_Info_Char (' ');
  50
  51             for N in SUT.File_Name'Range loop
  52                Write_Info_Char (SUT.File_Name (N));
  53             end loop;
  54
  55             Write_Info_Terminate;
  56          end if;
  57
  58          --  Loop through SCO entries for this unit
  59
  60          loop
  61             exit when Start = Stop + 1;
  62             pragma Assert (Start <= Stop);
  63
  64             Output_SCO_Line : declare
  65                T : SCO_Table_Entry renames SCO_Table.Table (Start);
  66
  67                procedure Output_Range (T : SCO_Table_Entry);
  68                --  Outputs T.From and T.To in line:col-line:col format
  69
  70                ------------------
  71                -- Output_Range --
  72                ------------------
  73
  74                procedure Output_Range (T : SCO_Table_Entry) is
  75                begin
  76                   Write_Info_Nat  (Nat (T.From.Line));
  77                   Write_Info_Char (':');
  78                   Write_Info_Nat  (Nat (T.From.Col));
  79                   Write_Info_Char ('-');
  80                   Write_Info_Nat  (Nat (T.To.Line));
  81                   Write_Info_Char (':');
  82                   Write_Info_Nat  (Nat (T.To.Col));
  83                end Output_Range;
  84
  85             --  Start of processing for Output_SCO_Line
  86
  87             begin
  88                Write_Info_Initiate ('C');
  89                Write_Info_Char (T.C1);
  90
  91                case T.C1 is
  92
  93                   --  Statements
  94
  95                   when 'S' =>
  96                      loop
  97                         Write_Info_Char (' ');
  98
  99                         if SCO_Table.Table (Start).C2 /= ' ' then
 100                            Write_Info_Char (SCO_Table.Table (Start).C2);
 101                         end if;
 102
 103                         Output_Range (SCO_Table.Table (Start));
 104                         exit when SCO_Table.Table (Start).Last;
 105
 106                         Start := Start + 1;
 107                         pragma Assert (SCO_Table.Table (Start).C1 = 's');
 108                      end loop;
 109
 110                   --  Statement continuations should not occur since they
 111                   --  are supposed to have been handled in the loop above.
 112
 113                   when 's' =>
 114                      raise Program_Error;
 115
 116                   --  Decision
 117
 118                   when 'I' | 'E' | 'P' | 'W' | 'X' =>
 119                      if T.C2 = ' ' then
 120                         Start := Start + 1;
 121                      end if;
 122
 123                      --  Loop through table entries for this decision
 124
 125                      loop
 126                         declare
 127                            T : SCO_Table_Entry renames SCO_Table.Table (Start);
 128
 129                         begin
 130                            Write_Info_Char (' ');
 131
 132                            if T.C1 = '!' or else
 133                               T.C1 = '^' or else
 134                               T.C1 = '&' or else
 135                               T.C1 = '|'
 136                            then
 137                               Write_Info_Char (T.C1);
 138
 139                            else
 140                               Write_Info_Char (T.C2);
 141                               Output_Range (T);
 142                            end if;
 143
 144                            exit when T.Last;
 145                            Start := Start + 1;
 146                         end;
 147                      end loop;
 148
 149                   when others =>
 150                      raise Program_Error;
 151                end case;
 152
 153                Write_Info_Terminate;
 154             end Output_SCO_Line;
 155
 156             Start := Start + 1;
 157          end loop;
 158       end;
 159    end loop;
 160 end Put_SCOs;