OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [repinfo.adb] - Rev 826

Compare with Previous | Blame | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              R E P I N F O                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1999-2009, 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 3,  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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- 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 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;
 
   --  The following representation clause ensures that the above record
   --  has no holes. We do this so that when instances of this record are
   --  written by Tree_Gen, we do not write uninitialized values to the file.
 
   for Exp_Node use record
      Expr at  0 range 0 .. 31;
      Op1  at  4 range 0 .. 31;
      Op2  at  8 range 0 .. 31;
      Op3  at 12 range 0 .. 31;
   end record;
 
   for Exp_Node'Size use 16 * 8;
   --  This ensures that we did not leave out any fields
 
   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
   begin
      return Create_Node
        (Expr => Discrim_Val,
         Op1  => Discriminant_Number (Discr));
   end Create_Discrim_Ref;
 
   ---------------------------
   -- Create_Dynamic_SO_Ref --
   ---------------------------
 
   function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
   begin
      Dynamic_SO_Entity_Table.Append (E);
      return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
   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
   begin
      Rep_Table.Append (
        (Expr => Expr,
         Op1  => Op1,
         Op2  => Op2,
         Op3  => Op3));
      return UI_From_Int (-Rep_Table.Last);
   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
      --  List entity if we have one, and it is not a renaming declaration.
      --  For renamings, we don't get proper information, and really it makes
      --  sense to restrict the output to the renamed entity.
 
      if Present (Ent)
        and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
      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_CIL       => Write_Line ("CIL");
         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);
 
      Write_Str ("for ");
      List_Name (Ent);
      Write_Line (" use record");
 
      --  First loop finds out max line length and max starting position
      --  length, for the purpose of lining things up nicely.
 
      Max_Name_Length := 0;
      Max_Suni_Length := 0;
 
      Comp := First_Component_Or_Discriminant (Ent);
      while Present (Comp) loop
         Get_Decoded_Name_String (Chars (Comp));
         Max_Name_Length := Natural'Max (Max_Name_Length, Name_Len);
 
         Cfbit := Component_Bit_Offset (Comp);
 
         if Rep_Not_Constant (Cfbit) then
            UI_Image_Length := 2;
 
         else
            --  Complete annotation in case not done
 
            Set_Normalized_Position (Comp, Cfbit / SSU);
            Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
 
            Sunit := Cfbit / SSU;
            UI_Image (Sunit);
         end if;
 
         --  If the record is not packed, then we know that all fields whose
         --  position is not specified have a starting normalized bit position
         --  of zero.
 
         if Unknown_Normalized_First_Bit (Comp)
           and then not Is_Packed (Ent)
         then
            Set_Normalized_First_Bit (Comp, Uint_0);
         end if;
 
         Max_Suni_Length :=
           Natural'Max (Max_Suni_Length, UI_Image_Length);
 
         Next_Component_Or_Discriminant (Comp);
      end loop;
 
      --  Second loop does actual output based on those values
 
      Comp := First_Component_Or_Discriminant (Ent);
      while Present (Comp) loop
         declare
            Esiz : constant Uint := Esize (Comp);
            Bofs : constant Uint := Component_Bit_Offset (Comp);
            Npos : constant Uint := Normalized_Position (Comp);
            Fbit : constant Uint := Normalized_First_Bit (Comp);
            Lbit : Uint;
 
         begin
            Write_Str ("   ");
            Get_Decoded_Name_String (Chars (Comp));
            Set_Casing (Unit_Casing);
            Write_Str (Name_Buffer (1 .. Name_Len));
 
            for J in 1 .. Max_Name_Length - Name_Len loop
               Write_Char (' ');
            end loop;
 
            Write_Str (" at ");
 
            if Known_Static_Normalized_Position (Comp) then
               UI_Image (Npos);
               Spaces (Max_Suni_Length - UI_Image_Length);
               Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
 
            elsif Known_Component_Bit_Offset (Comp)
              and then List_Representation_Info = 3
            then
               Spaces (Max_Suni_Length - 2);
               Write_Str ("bit offset");
               Write_Val (Bofs, Paren => True);
               Write_Str (" size in bits = ");
               Write_Val (Esiz, Paren => True);
               Write_Eol;
               goto Continue;
 
            elsif Known_Normalized_Position (Comp)
              and then List_Representation_Info = 3
            then
               Spaces (Max_Suni_Length - 2);
               Write_Val (Npos);
 
            else
               --  For the packed case, we don't know the bit positions if we
               --  don't know the starting position!
 
               if Is_Packed (Ent) then
                  Write_Line ("?? range  ? .. ??;");
                  goto Continue;
 
               --  Otherwise we can continue
 
               else
                  Write_Str ("??");
               end if;
            end if;
 
            Write_Str (" range  ");
            UI_Write (Fbit);
            Write_Str (" .. ");
 
            --  Allowing Uint_0 here is a kludge, really this should be a
            --  fine Esize value but currently it means unknown, except that
            --  we know after gigi has back annotated that a size of zero is
            --  real, since otherwise gigi back annotates using No_Uint as
            --  the value to indicate unknown).
 
            if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
              and then Known_Static_Normalized_First_Bit (Comp)
            then
               Lbit := Fbit + Esiz - 1;
 
               if Lbit < 10 then
                  Write_Char (' ');
               end if;
 
               UI_Write (Lbit);
 
            --  The test for Esize (Comp) not being Uint_0 here is a kludge.
            --  Officially a value of zero for Esize means unknown, but here
            --  we use the fact that we know that gigi annotates Esize with
            --  No_Uint, not Uint_0. Really everyone should use No_Uint???
 
            elsif List_Representation_Info < 3
              or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp))
            then
               Write_Str ("??");
 
            --  List_Representation >= 3 and Known_Esize (Comp)
 
            else
               Write_Val (Esiz, Paren => True);
 
               --  If in front end layout mode, then dynamic size is stored
               --  in storage units, so renormalize for output
 
               if not Back_End_Layout then
                  Write_Str (" * ");
                  Write_Int (SSU);
               end if;
 
               --  Add appropriate first bit offset
 
               if Fbit = 0 then
                  Write_Str (" - 1");
 
               elsif Fbit = 1 then
                  null;
 
               else
                  Write_Str (" + ");
                  Write_Int (UI_To_Int (Fbit) - 1);
               end if;
            end if;
 
            Write_Line (";");
         end;
 
      <<Continue>>
         Next_Component_Or_Discriminant (Comp);
      end loop;
 
      Write_Line ("end record;");
   end List_Record_Info;
 
   -------------------
   -- List_Rep_Info --
   -------------------
 
   procedure List_Rep_Info is
      Col : Nat;
 
   begin
      if List_Representation_Info /= 0
        or else List_Representation_Info_Mechanisms
      then
         for U in Main_Unit .. Last_Unit loop
            if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
 
               --  Normal case, list to standard output
 
               if not List_Representation_Info_To_File then
                  Unit_Casing := Identifier_Casing (Source_Index (U));
                  Write_Eol;
                  Write_Str ("Representation information for unit ");
                  Write_Unit_Name (Unit_Name (U));
                  Col := Column;
                  Write_Eol;
 
                  for J in 1 .. Col - 1 loop
                     Write_Char ('-');
                  end loop;
 
                  Write_Eol;
                  List_Entities (Cunit_Entity (U));
 
               --  List representation information to file
 
               else
                  Create_Repinfo_File_Access.all
                    (Get_Name_String (File_Name (Source_Index (U))));
                  Set_Special_Output (Write_Info_Line'Access);
                  List_Entities (Cunit_Entity (U));
                  Set_Special_Output (null);
                  Close_Repinfo_File_Access.all;
               end if;
            end if;
         end loop;
      end if;
   end List_Rep_Info;
 
   --------------------
   -- List_Type_Info --
   --------------------
 
   procedure List_Type_Info (Ent : Entity_Id) is
   begin
      Blank_Line;
 
      --  Do not list size info for unconstrained arrays, not meaningful
 
      if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
         null;
 
      else
         --  If Esize and RM_Size are the same and known, list as Size. This
         --  is a common case, which we may as well list in simple form.
 
         if Esize (Ent) = RM_Size (Ent) then
            Write_Str ("for ");
            List_Name (Ent);
            Write_Str ("'Size use ");
            Write_Val (Esize (Ent));
            Write_Line (";");
 
         --  For now, temporary case, to be removed when gigi properly back
         --  annotates RM_Size, if RM_Size is not set, then list Esize as Size.
         --  This avoids odd Object_Size output till we fix things???
 
         elsif Unknown_RM_Size (Ent) then
            Write_Str ("for ");
            List_Name (Ent);
            Write_Str ("'Size use ");
            Write_Val (Esize (Ent));
            Write_Line (";");
 
         --  Otherwise list size values separately if they are set
 
         else
            Write_Str ("for ");
            List_Name (Ent);
            Write_Str ("'Object_Size use ");
            Write_Val (Esize (Ent));
            Write_Line (";");
 
            --  Note on following check: The RM_Size of a discrete type can
            --  legitimately be set to zero, so a special check is needed.
 
            Write_Str ("for ");
            List_Name (Ent);
            Write_Str ("'Value_Size use ");
            Write_Val (RM_Size (Ent));
            Write_Line (";");
         end if;
      end if;
 
      Write_Str ("for ");
      List_Name (Ent);
      Write_Str ("'Alignment use ");
      Write_Val (Alignment (Ent));
      Write_Line (";");
   end List_Type_Info;
 
   ----------------------
   -- Rep_Not_Constant --
   ----------------------
 
   function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is
   begin
      if Val = No_Uint or else Val < 0 then
         return True;
      else
         return False;
      end if;
   end Rep_Not_Constant;
 
   ---------------
   -- Rep_Value --
   ---------------
 
   function Rep_Value
     (Val : Node_Ref_Or_Val;
      D   : Discrim_List) return Uint
   is
      function B (Val : Boolean) return Uint;
      --  Returns Uint_0 for False, Uint_1 for True
 
      function T (Val : Node_Ref_Or_Val) return Boolean;
      --  Returns True for 0, False for any non-zero (i.e. True)
 
      function V (Val : Node_Ref_Or_Val) return Uint;
      --  Internal recursive routine to evaluate tree
 
      function W (Val : Uint) return Word;
      --  Convert Val to Word, assuming Val is always in the Int range. This is
      --  a helper function for the evaluation of bitwise expressions like
      --  Bit_And_Expr, for which there is no direct support in uintp. Uint
      --  values out of the Int range are expected to be seen in such
      --  expressions only with overflowing byte sizes around, introducing
      --  inherent unreliabilities in computations anyway.
 
      -------
      -- B --
      -------
 
      function B (Val : Boolean) return Uint is
      begin
         if Val then
            return Uint_1;
         else
            return Uint_0;
         end if;
      end B;
 
      -------
      -- T --
      -------
 
      function T (Val : Node_Ref_Or_Val) return Boolean is
      begin
         if V (Val) = 0 then
            return False;
         else
            return True;
         end if;
      end T;
 
      -------
      -- V --
      -------
 
      function V (Val : Node_Ref_Or_Val) return Uint is
         L, R, Q : Uint;
 
      begin
         if Val >= 0 then
            return Val;
 
         else
            declare
               Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
 
            begin
               case Node.Expr is
                  when Cond_Expr =>
                     if T (Node.Op1) then
                        return V (Node.Op2);
                     else
                        return V (Node.Op3);
                     end if;
 
                  when Plus_Expr =>
                     return V (Node.Op1) + V (Node.Op2);
 
                  when Minus_Expr =>
                     return V (Node.Op1) - V (Node.Op2);
 
                  when Mult_Expr =>
                     return V (Node.Op1) * V (Node.Op2);
 
                  when Trunc_Div_Expr =>
                     return V (Node.Op1) / V (Node.Op2);
 
                  when Ceil_Div_Expr =>
                     return
                       UR_Ceiling
                         (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
 
                  when Floor_Div_Expr =>
                     return
                       UR_Floor
                         (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
 
                  when Trunc_Mod_Expr =>
                     return V (Node.Op1) rem V (Node.Op2);
 
                  when Floor_Mod_Expr =>
                     return V (Node.Op1) mod V (Node.Op2);
 
                  when Ceil_Mod_Expr =>
                     L := V (Node.Op1);
                     R := V (Node.Op2);
                     Q := UR_Ceiling (L / UR_From_Uint (R));
                     return L - R * Q;
 
                  when Exact_Div_Expr =>
                     return V (Node.Op1) / V (Node.Op2);
 
                  when Negate_Expr =>
                     return -V (Node.Op1);
 
                  when Min_Expr =>
                     return UI_Min (V (Node.Op1), V (Node.Op2));
 
                  when Max_Expr =>
                     return UI_Max (V (Node.Op1), V (Node.Op2));
 
                  when Abs_Expr =>
                     return UI_Abs (V (Node.Op1));
 
                  when Truth_Andif_Expr =>
                     return B (T (Node.Op1) and then T (Node.Op2));
 
                  when Truth_Orif_Expr =>
                     return B (T (Node.Op1) or else T (Node.Op2));
 
                  when Truth_And_Expr =>
                     return B (T (Node.Op1) and then T (Node.Op2));
 
                  when Truth_Or_Expr =>
                     return B (T (Node.Op1) or else T (Node.Op2));
 
                  when Truth_Xor_Expr =>
                     return B (T (Node.Op1) xor T (Node.Op2));
 
                  when Truth_Not_Expr =>
                     return B (not T (Node.Op1));
 
                  when Bit_And_Expr =>
                     L := V (Node.Op1);
                     R := V (Node.Op2);
                     return UI_From_Int (Int (W (L) and W (R)));
 
                  when Lt_Expr =>
                     return B (V (Node.Op1) < V (Node.Op2));
 
                  when Le_Expr =>
                     return B (V (Node.Op1) <= V (Node.Op2));
 
                  when Gt_Expr =>
                     return B (V (Node.Op1) > V (Node.Op2));
 
                  when Ge_Expr =>
                     return B (V (Node.Op1) >= V (Node.Op2));
 
                  when Eq_Expr =>
                     return B (V (Node.Op1) = V (Node.Op2));
 
                  when Ne_Expr =>
                     return B (V (Node.Op1) /= V (Node.Op2));
 
                  when Discrim_Val =>
                     declare
                        Sub : constant Int := UI_To_Int (Node.Op1);
 
                     begin
                        pragma Assert (Sub in D'Range);
                        return D (Sub);
                     end;
 
               end case;
            end;
         end if;
      end V;
 
      -------
      -- W --
      -------
 
      --  We use an unchecked conversion to map Int values to their Word
      --  bitwise equivalent, which we could not achieve with a normal type
      --  conversion for negative Ints. We want bitwise equivalents because W
      --  is used as a helper for bit operators like Bit_And_Expr, and can be
      --  called for negative Ints in the context of aligning expressions like
      --  X+Align & -Align.
 
      function W (Val : Uint) return Word is
         function To_Word is new Ada.Unchecked_Conversion (Int, Word);
      begin
         return To_Word (UI_To_Int (Val));
      end W;
 
   --  Start of processing for Rep_Value
 
   begin
      if Val = No_Uint then
         return No_Uint;
 
      else
         return V (Val);
      end if;
   end Rep_Value;
 
   ------------
   -- Spaces --
   ------------
 
   procedure Spaces (N : Natural) is
   begin
      for J in 1 .. N loop
         Write_Char (' ');
      end loop;
   end Spaces;
 
   ---------------
   -- Tree_Read --
   ---------------
 
   procedure Tree_Read is
   begin
      Rep_Table.Tree_Read;
   end Tree_Read;
 
   ----------------
   -- Tree_Write --
   ----------------
 
   procedure Tree_Write is
   begin
      Rep_Table.Tree_Write;
   end Tree_Write;
 
   ---------------------
   -- Write_Info_Line --
   ---------------------
 
   procedure Write_Info_Line (S : String) is
   begin
      Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
   end Write_Info_Line;
 
   ---------------------
   -- Write_Mechanism --
   ---------------------
 
   procedure Write_Mechanism (M : Mechanism_Type) is
   begin
      case M is
         when 0 =>
            Write_Str ("default");
 
         when -1 =>
            Write_Str ("copy");
 
         when -2 =>
            Write_Str ("reference");
 
         when -3 =>
            Write_Str ("descriptor");
 
         when -4 =>
            Write_Str ("descriptor (UBS)");
 
         when -5 =>
            Write_Str ("descriptor (UBSB)");
 
         when -6 =>
            Write_Str ("descriptor (UBA)");
 
         when -7 =>
            Write_Str ("descriptor (S)");
 
         when -8 =>
            Write_Str ("descriptor (SB)");
 
         when -9 =>
            Write_Str ("descriptor (A)");
 
         when -10 =>
            Write_Str ("descriptor (NCA)");
 
         when others =>
            raise Program_Error;
      end case;
   end Write_Mechanism;
 
   ---------------
   -- Write_Val --
   ---------------
 
   procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
   begin
      if Rep_Not_Constant (Val) then
         if List_Representation_Info < 3 or else Val = No_Uint then
            Write_Str ("??");
 
         else
            if Back_End_Layout then
               Write_Char (' ');
 
               if Paren then
                  Write_Char ('(');
                  List_GCC_Expression (Val);
                  Write_Char (')');
               else
                  List_GCC_Expression (Val);
               end if;
 
               Write_Char (' ');
 
            else
               if Paren then
                  Write_Char ('(');
                  Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
                  Write_Char (')');
               else
                  Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
               end if;
            end if;
         end if;
 
      else
         UI_Write (Val);
      end if;
   end Write_Val;
 
end Repinfo;
 

Compare with Previous | Blame | View Log

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.