aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/repinfo.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/repinfo.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/repinfo.adb1452
1 files changed, 1452 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/repinfo.adb b/gcc-4.8.3/gcc/ada/repinfo.adb
new file mode 100644
index 000000000..c3e6772ed
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/repinfo.adb
@@ -0,0 +1,1452 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- R E P I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2011, 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_Ada_Pass_By_Copy =>
+ Write_Line ("Ada_Pass_By_Copy");
+ when Convention_Ada_Pass_By_Reference =>
+ Write_Line ("Ada_Pass_By_Reference");
+ when Convention_Intrinsic =>
+ Write_Line ("Intrinsic");
+ 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 (";");
+
+ -- Special stuff for fixed-point
+
+ if Is_Fixed_Point_Type (Ent) then
+
+ -- Write small (always a static constant)
+
+ Write_Str ("for ");
+ List_Name (Ent);
+ Write_Str ("'Small use ");
+ UR_Write (Small_Value (Ent));
+ Write_Line (";");
+
+ -- Write range if static
+
+ declare
+ R : constant Node_Id := Scalar_Range (Ent);
+
+ begin
+ if Nkind (Low_Bound (R)) = N_Real_Literal
+ and then
+ Nkind (High_Bound (R)) = N_Real_Literal
+ then
+ Write_Str ("for ");
+ List_Name (Ent);
+ Write_Str ("'Range use ");
+ UR_Write (Realval (Low_Bound (R)));
+ Write_Str (" .. ");
+ UR_Write (Realval (High_Bound (R)));
+ Write_Line (";");
+ end if;
+ end;
+ end if;
+ 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;