Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              R E P I N F O                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1999-2005 Free Software Foundation, Inc.          --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 2,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT;  see file COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- As a special exception,  if other files  instantiate  generics from this --

-- unit, or you link  this unit with other files  to produce an executable, --

-- this  unit  does not  by itself cause  the resulting  executable  to  be --

-- covered  by the  GNU  General  Public  License.  This exception does not --

-- however invalidate  any other reasons why  the executable file  might be --

-- covered by the  GNU Public License.                                      --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Alloc;  use Alloc;

with Atree;  use Atree;

with Casing; use Casing;

with Debug;  use Debug;

with Einfo;  use Einfo;

with Lib;    use Lib;

with Namet;  use Namet;

with Opt;    use Opt;

with Output; use Output;

with Sinfo;  use Sinfo;

with Sinput; use Sinput;

with Snames; use Snames;

with Stand;  use Stand;

with Table;  use Table;

with Uname;  use Uname;

with Urealp; use Urealp;

with Ada.Unchecked_Conversion;

package body Repinfo is

   SSU : constant := 8;

   --  Value for Storage_Unit, we do not want to get this from TTypes, since

   --  this introduces problematic dependencies in ASIS, and in any case this

   --  value is assumed to be 8 for the implementation of the DDA.

   --  This is wrong for AAMP???

   ---------------------------------------

   -- Representation of gcc Expressions --

   ---------------------------------------

   --    This table is used only if Frontend_Layout_On_Target is False, so that

   --    gigi lays out dynamic size/offset fields using encoded gcc

   --    expressions.

   --    A table internal to this unit is used to hold the values of back

   --    annotated expressions. This table is written out by -gnatt and read

   --    back in for ASIS processing.

   --    Node values are stored as Uint values using the negative of the node

   --    index in this table. Constants appear as non-negative Uint values.

   type Exp_Node is record

      Expr : TCode;

      Op1  : Node_Ref_Or_Val;

      Op2  : Node_Ref_Or_Val;

      Op3  : Node_Ref_Or_Val;

   end record;

   package Rep_Table is new Table.Table (

      Table_Component_Type => Exp_Node,

      Table_Index_Type     => Nat,

      Table_Low_Bound      => 1,

      Table_Initial        => Alloc.Rep_Table_Initial,

      Table_Increment      => Alloc.Rep_Table_Increment,

      Table_Name           => "BE_Rep_Table");

   --------------------------------------------------------------

   -- Representation of Front-End Dynamic Size/Offset Entities --

   --------------------------------------------------------------

   package Dynamic_SO_Entity_Table is new Table.Table (

      Table_Component_Type => Entity_Id,

      Table_Index_Type     => Nat,

      Table_Low_Bound      => 1,

      Table_Initial        => Alloc.Rep_Table_Initial,

      Table_Increment      => Alloc.Rep_Table_Increment,

      Table_Name           => "FE_Rep_Table");

   Unit_Casing : Casing_Type;

   --  Identifier casing for current unit

   Need_Blank_Line : Boolean;

   --  Set True if a blank line is needed before outputting any information for

   --  the current entity. Set True when a new entity is processed, and false

   --  when the blank line is output.

   -----------------------

   -- Local Subprograms --

   -----------------------

   function Back_End_Layout return Boolean;

   --  Test for layout mode, True = back end, False = front end. This function

   --  is used rather than checking the configuration parameter because we do

   --  not want Repinfo to depend on Targparm (for ASIS)

   procedure Blank_Line;

   --  Called before outputting anything for an entity. Ensures that

   --  a blank line precedes the output for a particular entity.

   procedure List_Entities (Ent : Entity_Id);

   --  This procedure lists the entities associated with the entity E, starting

   --  with the First_Entity and using the Next_Entity link. If a nested

   --  package is found, entities within the package are recursively processed.

   procedure List_Name (Ent : Entity_Id);

   --  List name of entity Ent in appropriate case. The name is listed with

   --  full qualification up to but not including the compilation unit name.

   procedure List_Array_Info (Ent : Entity_Id);

   --  List representation info for array type Ent

   procedure List_Mechanisms (Ent : Entity_Id);

   --  List mechanism information for parameters of Ent, which is subprogram,

   --  subprogram type, or an entry or entry family.

   procedure List_Object_Info (Ent : Entity_Id);

   --  List representation info for object Ent

   procedure List_Record_Info (Ent : Entity_Id);

   --  List representation info for record type Ent

   procedure List_Type_Info (Ent : Entity_Id);

   --  List type info for type Ent

   function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;

   --  Returns True if Val represents a variable value, and False if it

   --  represents a value that is fixed at compile time.

   procedure Spaces (N : Natural);

   --  Output given number of spaces

   procedure Write_Info_Line (S : String);

   --  Routine to write a line to Repinfo output file. This routine is passed

   --  as a special output procedure to Output.Set_Special_Output. Note that

   --  Write_Info_Line is called with an EOL character at the end of each line,

   --  as per the Output spec, but the internal call to the appropriate routine

   --  in Osint requires that the end of line sequence be stripped off.

   procedure Write_Mechanism (M : Mechanism_Type);

   --  Writes symbolic string for mechanism represented by M

   procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);

   --  Given a representation value, write it out. No_Uint values or values

   --  dependent on discriminants are written as two question marks. If the

   --  flag Paren is set, then the output is surrounded in parentheses if it is

   --  other than a simple value.

   ---------------------

   -- Back_End_Layout --

   ---------------------

   function Back_End_Layout return Boolean is

   begin

      --  We have back end layout if the back end has made any entries in the

      --  table of GCC expressions, otherwise we have front end layout.

      return Rep_Table.Last > 0;

   end Back_End_Layout;

   ----------------

   -- Blank_Line --

   ----------------

   procedure Blank_Line is

   begin

      if Need_Blank_Line then

         Write_Eol;

         Need_Blank_Line := False;

      end if;

   end Blank_Line;

   ------------------------

   -- Create_Discrim_Ref --

   ------------------------

   function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is

      N : constant Uint := Discriminant_Number (Discr);

      T : Nat;

   begin

      Rep_Table.Increment_Last;

      T := Rep_Table.Last;

      Rep_Table.Table (T).Expr := Discrim_Val;

      Rep_Table.Table (T).Op1  := N;

      Rep_Table.Table (T).Op2  := No_Uint;

      Rep_Table.Table (T).Op3  := No_Uint;

      return UI_From_Int (-T);

   end Create_Discrim_Ref;

   ---------------------------

   -- Create_Dynamic_SO_Ref --

   ---------------------------

   function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is

      T : Nat;

   begin

      Dynamic_SO_Entity_Table.Increment_Last;

      T := Dynamic_SO_Entity_Table.Last;

      Dynamic_SO_Entity_Table.Table (T) := E;

      return UI_From_Int (-T);

   end Create_Dynamic_SO_Ref;

   -----------------

   -- Create_Node --

   -----------------

   function Create_Node

     (Expr : TCode;

      Op1  : Node_Ref_Or_Val;

      Op2  : Node_Ref_Or_Val := No_Uint;

      Op3  : Node_Ref_Or_Val := No_Uint) return Node_Ref

   is

      T : Nat;

   begin

      Rep_Table.Increment_Last;

      T := Rep_Table.Last;

      Rep_Table.Table (T).Expr := Expr;

      Rep_Table.Table (T).Op1  := Op1;

      Rep_Table.Table (T).Op2  := Op2;

      Rep_Table.Table (T).Op3  := Op3;

      return UI_From_Int (-T);

   end Create_Node;

   ---------------------------

   -- Get_Dynamic_SO_Entity --

   ---------------------------

   function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is

   begin

      return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));

   end Get_Dynamic_SO_Entity;

   -----------------------

   -- Is_Dynamic_SO_Ref --

   -----------------------

   function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is

   begin

      return U < Uint_0;

   end Is_Dynamic_SO_Ref;

   ----------------------

   -- Is_Static_SO_Ref --

   ----------------------

   function Is_Static_SO_Ref (U : SO_Ref) return Boolean is

   begin

      return U >= Uint_0;

   end Is_Static_SO_Ref;

   ---------

   -- lgx --

   ---------

   procedure lgx (U : Node_Ref_Or_Val) is

   begin

      List_GCC_Expression (U);

      Write_Eol;

   end lgx;

   ----------------------

   -- List_Array_Info --

   ----------------------

   procedure List_Array_Info (Ent : Entity_Id) is

   begin

      List_Type_Info (Ent);

      Write_Str ("for ");

      List_Name (Ent);

      Write_Str ("'Component_Size use ");

      Write_Val (Component_Size (Ent));

      Write_Line (";");

   end List_Array_Info;

   -------------------

   -- List_Entities --

   -------------------

   procedure List_Entities (Ent : Entity_Id) is

      Body_E : Entity_Id;

      E      : Entity_Id;

      function Find_Declaration (E : Entity_Id) return Node_Id;

      --  Utility to retrieve declaration node for entity in the

      --  case of package bodies and subprograms.

      ----------------------

      -- Find_Declaration --

      ----------------------

      function Find_Declaration (E : Entity_Id) return Node_Id is

         Decl : Node_Id;

      begin

         Decl := Parent (E);

         while Present (Decl)

           and then  Nkind (Decl) /= N_Package_Body

           and then Nkind (Decl) /= N_Subprogram_Declaration

           and then Nkind (Decl) /= N_Subprogram_Body

         loop

            Decl := Parent (Decl);

         end loop;

         return Decl;

      end Find_Declaration;

   --  Start of processing for List_Entities

   begin

      if Present (Ent) then

         --  If entity is a subprogram and we are listing mechanisms,

         --  then we need to list mechanisms for this entity.

         if List_Representation_Info_Mechanisms

           and then (Is_Subprogram (Ent)

                       or else Ekind (Ent) = E_Entry

                       or else Ekind (Ent) = E_Entry_Family)

         then

            Need_Blank_Line := True;

            List_Mechanisms (Ent);

         end if;

         E := First_Entity (Ent);

         while Present (E) loop

            Need_Blank_Line := True;

            --  We list entities that come from source (excluding private or

            --  incomplete types or deferred constants, where we will list the

            --  info for the full view). If debug flag A is set, then all

            --  entities are listed

            if (Comes_From_Source (E)

              and then not Is_Incomplete_Or_Private_Type (E)

              and then not (Ekind (E) = E_Constant

                              and then Present (Full_View (E))))

              or else Debug_Flag_AA

            then

               if Is_Subprogram (E)

                       or else

                     Ekind (E) = E_Entry

                       or else

                     Ekind (E) = E_Entry_Family

                       or else

                     Ekind (E) = E_Subprogram_Type

               then

                  if List_Representation_Info_Mechanisms then

                     List_Mechanisms (E);

                  end if;

               elsif Is_Record_Type (E) then

                  if List_Representation_Info >= 1 then

                     List_Record_Info (E);

                  end if;

               elsif Is_Array_Type (E) then

                  if List_Representation_Info >= 1 then

                     List_Array_Info (E);

                  end if;

               elsif Is_Type (E) then

                  if List_Representation_Info >= 2 then

                     List_Type_Info (E);

                  end if;

               elsif Ekind (E) = E_Variable

                       or else

                     Ekind (E) = E_Constant

                       or else

                     Ekind (E) = E_Loop_Parameter

                       or else

                     Is_Formal (E)

               then

                  if List_Representation_Info >= 2 then

                     List_Object_Info (E);

                  end if;

               end if;

               --  Recurse into nested package, but not if they are package

               --  renamings (in particular renamings of the enclosing package,

               --  as for some Java bindings and for generic instances).

               if Ekind (E) = E_Package then

                  if No (Renamed_Object (E)) then

                     List_Entities (E);

                  end if;

               --  Recurse into bodies

               elsif Ekind (E) = E_Protected_Type

                       or else

                     Ekind (E) = E_Task_Type

                       or else

                     Ekind (E) = E_Subprogram_Body

                       or else

                     Ekind (E) = E_Package_Body

                       or else

                     Ekind (E) = E_Task_Body

                       or else

                     Ekind (E) = E_Protected_Body

               then

                  List_Entities (E);

               --  Recurse into blocks

               elsif Ekind (E) = E_Block then

                  List_Entities (E);

               end if;

            end if;

            E := Next_Entity (E);

         end loop;

         --  For a package body, the entities of the visible subprograms are

         --  declared in the corresponding spec. Iterate over its entities in

         --  order to handle properly the subprogram bodies. Skip bodies in

         --  subunits, which are listed independently.

         if Ekind (Ent) = E_Package_Body

           and then Present (Corresponding_Spec (Find_Declaration (Ent)))

         then

            E := First_Entity (Corresponding_Spec (Find_Declaration (Ent)));

            while Present (E) loop

               if Is_Subprogram (E)

                 and then

                   Nkind (Find_Declaration (E)) = N_Subprogram_Declaration

               then

                  Body_E := Corresponding_Body (Find_Declaration (E));

                  if Present (Body_E)

                    and then

                      Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit

                  then

                     List_Entities (Body_E);

                  end if;

               end if;

               Next_Entity (E);

            end loop;

         end if;

      end if;

   end List_Entities;

   -------------------------

   -- List_GCC_Expression --

   -------------------------

   procedure List_GCC_Expression (U : Node_Ref_Or_Val) is

      procedure Print_Expr (Val : Node_Ref_Or_Val);

      --  Internal recursive procedure to print expression

      ----------------

      -- Print_Expr --

      ----------------

      procedure Print_Expr (Val : Node_Ref_Or_Val) is

      begin

         if Val >= 0 then

            UI_Write (Val, Decimal);

         else

            declare

               Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));

               procedure Binop (S : String);

               --  Output text for binary operator with S being operator name

               -----------

               -- Binop --

               -----------

               procedure Binop (S : String) is

               begin

                  Write_Char ('(');

                  Print_Expr (Node.Op1);

                  Write_Str (S);

                  Print_Expr (Node.Op2);

                  Write_Char (')');

               end Binop;

            --  Start of processing for Print_Expr

            begin

               case Node.Expr is

                  when Cond_Expr =>

                     Write_Str ("(if ");

                     Print_Expr (Node.Op1);

                     Write_Str (" then ");

                     Print_Expr (Node.Op2);

                     Write_Str (" else ");

                     Print_Expr (Node.Op3);

                     Write_Str (" end)");

                  when Plus_Expr =>

                     Binop (" + ");

                  when Minus_Expr =>

                     Binop (" - ");

                  when Mult_Expr =>

                     Binop (" * ");

                  when Trunc_Div_Expr =>

                     Binop (" /t ");

                  when Ceil_Div_Expr =>

                     Binop (" /c ");

                  when Floor_Div_Expr =>

                     Binop (" /f ");

                  when Trunc_Mod_Expr =>

                     Binop (" modt ");

                  when Floor_Mod_Expr =>

                     Binop (" modf ");

                  when Ceil_Mod_Expr =>

                     Binop (" modc ");

                  when Exact_Div_Expr =>

                     Binop (" /e ");

                  when Negate_Expr =>

                     Write_Char ('-');

                     Print_Expr (Node.Op1);

                  when Min_Expr =>

                     Binop (" min ");

                  when Max_Expr =>

                     Binop (" max ");

                  when Abs_Expr =>

                     Write_Str ("abs ");

                     Print_Expr (Node.Op1);

                  when Truth_Andif_Expr =>

                     Binop (" and if ");

                  when Truth_Orif_Expr =>

                     Binop (" or if ");

                  when Truth_And_Expr =>

                     Binop (" and ");

                  when Truth_Or_Expr =>

                     Binop (" or ");

                  when Truth_Xor_Expr =>

                     Binop (" xor ");

                  when Truth_Not_Expr =>

                     Write_Str ("not ");

                     Print_Expr (Node.Op1);

                  when Bit_And_Expr =>

                     Binop (" & ");

                  when Lt_Expr =>

                     Binop (" < ");

                  when Le_Expr =>

                     Binop (" <= ");

                  when Gt_Expr =>

                     Binop (" > ");

                  when Ge_Expr =>

                     Binop (" >= ");

                  when Eq_Expr =>

                     Binop (" == ");

                  when Ne_Expr =>

                     Binop (" != ");

                  when Discrim_Val =>

                     Write_Char ('#');

                     UI_Write (Node.Op1);

               end case;

            end;

         end if;

      end Print_Expr;

   --  Start of processing for List_GCC_Expression

   begin

      if U = No_Uint then

         Write_Str ("??");

      else

         Print_Expr (U);

      end if;

   end List_GCC_Expression;

   ---------------------

   -- List_Mechanisms --

   ---------------------

   procedure List_Mechanisms (Ent : Entity_Id) is

      Plen : Natural;

      Form : Entity_Id;

   begin

      Blank_Line;

      case Ekind (Ent) is

         when E_Function =>

            Write_Str ("function ");

         when E_Operator =>

            Write_Str ("operator ");

         when E_Procedure =>

            Write_Str ("procedure ");

         when E_Subprogram_Type =>

            Write_Str ("type ");

         when E_Entry | E_Entry_Family =>

            Write_Str ("entry ");

         when others =>

            raise Program_Error;

      end case;

      Get_Unqualified_Decoded_Name_String (Chars (Ent));

      Write_Str (Name_Buffer (1 .. Name_Len));

      Write_Str (" declared at ");

      Write_Location (Sloc (Ent));

      Write_Eol;

      Write_Str ("  convention : ");

      case Convention (Ent) is

         when Convention_Ada       => Write_Line ("Ada");

         when Convention_Intrinsic => Write_Line ("InLineinsic");

         when Convention_Entry     => Write_Line ("Entry");

         when Convention_Protected => Write_Line ("Protected");

         when Convention_Assembler => Write_Line ("Assembler");

         when Convention_C         => Write_Line ("C");

         when Convention_COBOL     => Write_Line ("COBOL");

         when Convention_CPP       => Write_Line ("C++");

         when Convention_Fortran   => Write_Line ("Fortran");

         when Convention_Java      => Write_Line ("Java");

         when Convention_Stdcall   => Write_Line ("Stdcall");

         when Convention_Stubbed   => Write_Line ("Stubbed");

      end case;

      --  Find max length of formal name

      Plen := 0;

      Form := First_Formal (Ent);

      while Present (Form) loop

         Get_Unqualified_Decoded_Name_String (Chars (Form));

         if Name_Len > Plen then

            Plen := Name_Len;

         end if;

         Next_Formal (Form);

      end loop;

      --  Output formals and mechanisms

      Form := First_Formal (Ent);

      while Present (Form) loop

         Get_Unqualified_Decoded_Name_String (Chars (Form));

         while Name_Len <= Plen loop

            Name_Len := Name_Len + 1;

            Name_Buffer (Name_Len) := ' ';

         end loop;

         Write_Str ("  ");

         Write_Str (Name_Buffer (1 .. Plen + 1));

         Write_Str (": passed by ");

         Write_Mechanism (Mechanism (Form));

         Write_Eol;

         Next_Formal (Form);

      end loop;

      if Etype (Ent) /= Standard_Void_Type then

         Write_Str ("  returns by ");

         Write_Mechanism (Mechanism (Ent));

         Write_Eol;

      end if;

   end List_Mechanisms;

   ---------------

   -- List_Name --

   ---------------

   procedure List_Name (Ent : Entity_Id) is

   begin

      if not Is_Compilation_Unit (Scope (Ent)) then

         List_Name (Scope (Ent));

         Write_Char ('.');

      end if;

      Get_Unqualified_Decoded_Name_String (Chars (Ent));

      Set_Casing (Unit_Casing);

      Write_Str (Name_Buffer (1 .. Name_Len));

   end List_Name;

   ---------------------

   -- List_Object_Info --

   ---------------------

   procedure List_Object_Info (Ent : Entity_Id) is

   begin

      Blank_Line;

      Write_Str ("for ");

      List_Name (Ent);

      Write_Str ("'Size use ");

      Write_Val (Esize (Ent));

      Write_Line (";");

      Write_Str ("for ");

      List_Name (Ent);

      Write_Str ("'Alignment use ");

      Write_Val (Alignment (Ent));

      Write_Line (";");

   end List_Object_Info;

   ----------------------

   -- List_Record_Info --

   ----------------------

   procedure List_Record_Info (Ent : Entity_Id) is

      Comp  : Entity_Id;

      Cfbit : Uint;

      Sunit : Uint;

      Max_Name_Length : Natural;

      Max_Suni_Length : Natural;

   begin

      Blank_Line;

      List_Type_Info (Ent);