| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- R E P I N F O -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1999-2014, 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 Nlists; use Nlists; |
| with Opt; use Opt; |
| with Output; use Output; |
| with Sem_Aux; use Sem_Aux; |
| with Sinfo; use Sinfo; |
| with Sinput; use Sinput; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Stringt; use Stringt; |
| 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. This is set by List_Rep_Info for |
| -- each unit, before calling subprograms which may read it. |
| |
| 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; Bytes_Big_Endian : Boolean); |
| -- 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; Bytes_Big_Endian : Boolean); |
| -- List representation info for array type Ent |
| |
| procedure List_Linker_Section (Ent : Entity_Id); |
| -- List linker section for Ent (caller has checked that Ent is an entity |
| -- for which the Linker_Section_Pragma field is defined). |
| |
| 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; Bytes_Big_Endian : Boolean); |
| -- List representation info for record type Ent |
| |
| procedure List_Scalar_Storage_Order |
| (Ent : Entity_Id; |
| Bytes_Big_Endian : Boolean); |
| -- List scalar storage order information for record or array type Ent. |
| -- Also includes bit order information for record types, if necessary. |
| |
| 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; Bytes_Big_Endian : Boolean) is |
| begin |
| List_Type_Info (Ent); |
| Write_Str ("for "); |
| List_Name (Ent); |
| Write_Str ("'Component_Size use "); |
| Write_Val (Component_Size (Ent)); |
| Write_Line (";"); |
| |
| List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); |
| end List_Array_Info; |
| |
| ------------------- |
| -- List_Entities -- |
| ------------------- |
| |
| procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean) 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) then |
| List_Linker_Section (E); |
| |
| if List_Representation_Info_Mechanisms then |
| List_Mechanisms (E); |
| end if; |
| |
| elsif Ekind_In (E, E_Entry, |
| E_Entry_Family, |
| 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, Bytes_Big_Endian); |
| end if; |
| |
| List_Linker_Section (E); |
| |
| elsif Is_Array_Type (E) then |
| if List_Representation_Info >= 1 then |
| List_Array_Info (E, Bytes_Big_Endian); |
| end if; |
| |
| List_Linker_Section (E); |
| |
| elsif Is_Type (E) then |
| if List_Representation_Info >= 2 then |
| List_Type_Info (E); |
| List_Linker_Section (E); |
| end if; |
| |
| elsif Ekind_In (E, E_Variable, E_Constant) then |
| if List_Representation_Info >= 2 then |
| List_Object_Info (E); |
| List_Linker_Section (E); |
| end if; |
| |
| elsif 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, Bytes_Big_Endian); |
| end if; |
| |
| -- Recurse into bodies |
| |
| elsif Ekind_In (E, E_Protected_Type, |
| E_Task_Type, |
| E_Subprogram_Body, |
| E_Package_Body, |
| E_Task_Body, |
| E_Protected_Body) |
| then |
| List_Entities (E, Bytes_Big_Endian); |
| |
| -- Recurse into blocks |
| |
| elsif Ekind (E) = E_Block then |
| List_Entities (E, Bytes_Big_Endian); |
| 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, Bytes_Big_Endian); |
| 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_Linker_Section -- |
| ------------------------- |
| |
| procedure List_Linker_Section (Ent : Entity_Id) is |
| Arg : Node_Id; |
| |
| begin |
| if Present (Linker_Section_Pragma (Ent)) then |
| Write_Str ("pragma Linker_Section ("); |
| List_Name (Ent); |
| Write_Str (", """); |
| |
| Arg := |
| Last (Pragma_Argument_Associations (Linker_Section_Pragma (Ent))); |
| |
| if Nkind (Arg) = N_Pragma_Argument_Association then |
| Arg := Expression (Arg); |
| end if; |
| |
| pragma Assert (Nkind (Arg) = N_String_Literal); |
| String_To_Name_Buffer (Strval (Arg)); |
| Write_Str (Name_Buffer (1 .. Name_Len)); |
| Write_Str (""");"); |
| Write_Eol; |
| end if; |
| end List_Linker_Section; |
| |
| --------------------- |
| -- 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; Bytes_Big_Endian : Boolean) 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 |
| |
| -- Skip discriminant in unchecked union (since it is not there!) |
| |
| if Ekind (Comp) = E_Discriminant |
| and then Is_Unchecked_Union (Ent) |
| then |
| null; |
| |
| -- All other cases |
| |
| else |
| 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); |
| end if; |
| |
| 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 |
| |
| -- Skip discriminant in unchecked union (since it is not there!) |
| |
| if Ekind (Comp) = E_Discriminant |
| and then Is_Unchecked_Union (Ent) |
| then |
| goto Continue; |
| end if; |
| |
| -- All other cases |
| |
| 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 an annoying special case. 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 Uint_0 here is an annoying |
| -- special case. 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;"); |
| |
| List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); |
| end List_Record_Info; |
| |
| ------------------- |
| -- List_Rep_Info -- |
| ------------------- |
| |
| procedure List_Rep_Info (Bytes_Big_Endian : Boolean) 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 |
| Unit_Casing := Identifier_Casing (Source_Index (U)); |
| |
| -- Normal case, list to standard output |
| |
| if not List_Representation_Info_To_File then |
| 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), Bytes_Big_Endian); |
| |
| -- 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), Bytes_Big_Endian); |
| Set_Special_Output (null); |
| Close_Repinfo_File_Access.all; |
| end if; |
| end if; |
| end loop; |
| end if; |
| end List_Rep_Info; |
| |
| ------------------------------- |
| -- List_Scalar_Storage_Order -- |
| ------------------------------- |
| |
| procedure List_Scalar_Storage_Order |
| (Ent : Entity_Id; |
| Bytes_Big_Endian : Boolean) |
| is |
| procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean); |
| -- Show attribute definition clause for Attr_Name (an endianness |
| -- attribute), depending on whether or not the endianness is reversed |
| -- compared to native endianness. |
| |
| --------------- |
| -- List_Attr -- |
| --------------- |
| |
| procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is |
| begin |
| Write_Str ("for "); |
| List_Name (Ent); |
| Write_Str ("'" & Attr_Name & " use System."); |
| |
| if Bytes_Big_Endian xor Is_Reversed then |
| Write_Str ("High"); |
| else |
| Write_Str ("Low"); |
| end if; |
| |
| Write_Line ("_Order_First;"); |
| end List_Attr; |
| |
| List_SSO : constant Boolean := |
| Has_Rep_Item (Ent, Name_Scalar_Storage_Order) |
| or else SSO_Set_Low_By_Default (Ent) |
| or else SSO_Set_High_By_Default (Ent); |
| -- Scalar_Storage_Order is displayed if specified explicitly |
| -- or set by Default_Scalar_Storage_Order. |
| |
| -- Start of processing for List_Scalar_Storage_Order |
| |
| begin |
| -- For record types, list Bit_Order if not default, or if SSO is shown |
| |
| if Is_Record_Type (Ent) |
| and then (List_SSO or else Reverse_Bit_Order (Ent)) |
| then |
| List_Attr ("Bit_Order", Reverse_Bit_Order (Ent)); |
| end if; |
| |
| -- List SSO if required. If not, then storage is supposed to be in |
| -- native order. |
| |
| if List_SSO then |
| List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent)); |
| else |
| pragma Assert (not Reverse_Storage_Order (Ent)); |
| null; |
| end if; |
| end List_Scalar_Storage_Order; |
| |
| -------------------- |
| -- 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 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; |
