aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/repinfo.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/repinfo.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/repinfo.adb1403
1 files changed, 0 insertions, 1403 deletions
diff --git a/gcc-4.4.3/gcc/ada/repinfo.adb b/gcc-4.4.3/gcc/ada/repinfo.adb
deleted file mode 100644
index 04ad81758..000000000
--- a/gcc-4.4.3/gcc/ada/repinfo.adb
+++ /dev/null
@@ -1,1403 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- 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 T (Node.Op2));
-
- when Truth_Or_Expr =>
- return B (T (Node.Op1) or 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;