gcc/ada/alfa.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                 A L F A                                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 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 Atree;    use Atree;
  27 with Output;   use Output;
  28 with Put_ALFA;
  29 with Sinfo;    use Sinfo;
  30
  31 package body ALFA is
  32
  33    -----------
  34    -- dalfa --
  35    -----------
  36
  37    procedure dalfa is
  38    begin
  39       --  Dump ALFA file table
  40
  41       Write_Line ("ALFA File Table");
  42       Write_Line ("---------------");
  43
  44       for Index in 1 .. ALFA_File_Table.Last loop
  45          declare
  46             AFR : ALFA_File_Record renames ALFA_File_Table.Table (Index);
  47
  48          begin
  49             Write_Str ("  ");
  50             Write_Int (Int (Index));
  51             Write_Str (".  File_Num = ");
  52             Write_Int (Int (AFR.File_Num));
  53             Write_Str ("  File_Name = """);
  54
  55             if AFR.File_Name /= null then
  56                Write_Str (AFR.File_Name.all);
  57             end if;
  58
  59             Write_Char ('"');
  60             Write_Str ("  From = ");
  61             Write_Int (Int (AFR.From_Scope));
  62             Write_Str ("  To = ");
  63             Write_Int (Int (AFR.To_Scope));
  64             Write_Eol;
  65          end;
  66       end loop;
  67
  68       --  Dump ALFA scope table
  69
  70       Write_Eol;
  71       Write_Line ("ALFA Scope Table");
  72       Write_Line ("----------------");
  73
  74       for Index in 1 .. ALFA_Scope_Table.Last loop
  75          declare
  76             ASR : ALFA_Scope_Record renames ALFA_Scope_Table.Table (Index);
  77
  78          begin
  79             Write_Str ("  ");
  80             Write_Int (Int (Index));
  81             Write_Str (".  File_Num = ");
  82             Write_Int (Int (ASR.File_Num));
  83             Write_Str ("  Scope_Num = ");
  84             Write_Int (Int (ASR.Scope_Num));
  85             Write_Str ("  Scope_Name = """);
  86
  87             if ASR.Scope_Name /= null then
  88                Write_Str (ASR.Scope_Name.all);
  89             end if;
  90
  91             Write_Char ('"');
  92             Write_Str  ("  Line = ");
  93             Write_Int  (Int (ASR.Line));
  94             Write_Str  ("  Col = ");
  95             Write_Int  (Int (ASR.Col));
  96             Write_Str  ("  Type = ");
  97             Write_Char (ASR.Stype);
  98             Write_Str  ("  From = ");
  99             Write_Int  (Int (ASR.From_Xref));
 100             Write_Str  ("  To = ");
 101             Write_Int  (Int (ASR.To_Xref));
 102             Write_Str  ("  Scope_Entity = ");
 103             Write_Int  (Int (ASR.Scope_Entity));
 104             Write_Eol;
 105          end;
 106       end loop;
 107
 108       --  Dump ALFA cross-reference table
 109
 110       Write_Eol;
 111       Write_Line ("ALFA Xref Table");
 112       Write_Line ("---------------");
 113
 114       for Index in 1 .. ALFA_Xref_Table.Last loop
 115          declare
 116             AXR : ALFA_Xref_Record renames ALFA_Xref_Table.Table (Index);
 117
 118          begin
 119             Write_Str  ("  ");
 120             Write_Int  (Int (Index));
 121             Write_Str (".  Entity_Name = """);
 122
 123             if AXR.Entity_Name /= null then
 124                Write_Str (AXR.Entity_Name.all);
 125             end if;
 126
 127             Write_Char ('"');
 128             Write_Str ("  Entity_Line = ");
 129             Write_Int (Int (AXR.Entity_Line));
 130             Write_Str ("  Entity_Col = ");
 131             Write_Int (Int (AXR.Entity_Col));
 132             Write_Str ("  File_Num = ");
 133             Write_Int (Int (AXR.File_Num));
 134             Write_Str ("  Scope_Num = ");
 135             Write_Int (Int (AXR.Scope_Num));
 136             Write_Str ("  Line = ");
 137             Write_Int (Int (AXR.Line));
 138             Write_Str ("  Col = ");
 139             Write_Int (Int (AXR.Col));
 140             Write_Str ("  Type = ");
 141             Write_Char (AXR.Rtype);
 142             Write_Eol;
 143          end;
 144       end loop;
 145    end dalfa;
 146
 147    -------------------------
 148    -- Get_Entity_For_Decl --
 149    -------------------------
 150
 151    function Get_Entity_For_Decl (N : Node_Id) return Entity_Id is
 152       E : Entity_Id := Empty;
 153
 154    begin
 155       case Nkind (N) is
 156          when N_Subprogram_Declaration |
 157               N_Subprogram_Body        |
 158               N_Package_Declaration    =>
 159             E := Defining_Unit_Name (Specification (N));
 160
 161          when N_Package_Body =>
 162             E := Defining_Unit_Name (N);
 163
 164          when N_Object_Declaration =>
 165             E := Defining_Identifier (N);
 166
 167          when others =>
 168             null;
 169       end case;
 170
 171       if Nkind (E) = N_Defining_Program_Unit_Name then
 172          E := Defining_Identifier (E);
 173       end if;
 174
 175       return E;
 176    end Get_Entity_For_Decl;
 177
 178    --------------------------------
 179    -- Get_Unique_Entity_For_Decl --
 180    --------------------------------
 181
 182    function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id is
 183       E : Entity_Id := Empty;
 184
 185    begin
 186       case Nkind (N) is
 187          when N_Subprogram_Declaration |
 188               N_Package_Declaration    =>
 189             E := Defining_Unit_Name (Specification (N));
 190
 191          when N_Package_Body =>
 192             E := Corresponding_Spec (N);
 193
 194          when N_Subprogram_Body =>
 195             if Acts_As_Spec (N) then
 196                E := Defining_Unit_Name (Specification (N));
 197             else
 198                E := Corresponding_Spec (N);
 199             end if;
 200
 201          when N_Object_Declaration =>
 202             E := Defining_Identifier (N);
 203
 204          when others =>
 205             null;
 206       end case;
 207
 208       if Nkind (E) = N_Defining_Program_Unit_Name then
 209          E := Defining_Identifier (E);
 210       end if;
 211
 212       return E;
 213    end Get_Unique_Entity_For_Decl;
 214
 215    ----------------
 216    -- Initialize --
 217    ----------------
 218
 219    procedure Initialize_ALFA_Tables is
 220    begin
 221       ALFA_File_Table.Init;
 222       ALFA_Scope_Table.Init;
 223       ALFA_Xref_Table.Init;
 224    end Initialize_ALFA_Tables;
 225
 226    -----------
 227    -- palfa --
 228    -----------
 229
 230    procedure palfa is
 231
 232       procedure Write_Info_Char (C : Character) renames Write_Char;
 233       --  Write one character;
 234
 235       function Write_Info_Col return Positive;
 236       --  Return next column for writing
 237
 238       procedure Write_Info_Initiate (Key : Character) renames Write_Char;
 239       --  Start new one and write one character;
 240
 241       procedure Write_Info_Nat (N : Nat);
 242       --  Write value of N
 243
 244       procedure Write_Info_Terminate renames Write_Eol;
 245       --  Terminate current line
 246
 247       --------------------
 248       -- Write_Info_Col --
 249       --------------------
 250
 251       function Write_Info_Col return Positive is
 252       begin
 253          return Positive (Column);
 254       end Write_Info_Col;
 255
 256       --------------------
 257       -- Write_Info_Nat --
 258       --------------------
 259
 260       procedure Write_Info_Nat (N : Nat) is
 261       begin
 262          Write_Int (N);
 263       end Write_Info_Nat;
 264
 265       procedure Debug_Put_ALFA is new Put_ALFA;
 266
 267    --  Start of processing for palfa
 268
 269    begin
 270       Debug_Put_ALFA;
 271    end palfa;
 272
 273 end ALFA;