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 Table; use Table;
with Uname; use Uname;
with Urealp; use Urealp;
package body Repinfo is
SSU : constant := 8;
type Exp_Node is record
Expr : TCode;
Op1 : Node_Ref_Or_Val;
Op2 : Node_Ref_Or_Val;
Op3 : Node_Ref_Or_Val;
end record;
package Rep_Table is new Table.Table (
Table_Component_Type => Exp_Node,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => Alloc.Rep_Table_Initial,
Table_Increment => Alloc.Rep_Table_Increment,
Table_Name => "BE_Rep_Table");
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;
procedure Spaces (N : Natural);
function Back_End_Layout return Boolean;
procedure List_Entities (Ent : Entity_Id);
procedure List_Name (Ent : Entity_Id);
procedure List_Array_Info (Ent : Entity_Id);
procedure List_Object_Info (Ent : Entity_Id);
procedure List_Record_Info (Ent : Entity_Id);
procedure List_Type_Info (Ent : Entity_Id);
function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean;
procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
function Back_End_Layout return Boolean is
begin
return Rep_Table.Last > 0;
end Back_End_Layout;
function Create_Discrim_Ref
(Discr : Entity_Id)
return Node_Ref
is
N : constant Uint := Discriminant_Number (Discr);
T : Nat;
begin
Rep_Table.Increment_Last;
T := Rep_Table.Last;
Rep_Table.Table (T).Expr := Discrim_Val;
Rep_Table.Table (T).Op1 := N;
Rep_Table.Table (T).Op2 := No_Uint;
Rep_Table.Table (T).Op3 := No_Uint;
return UI_From_Int (-T);
end Create_Discrim_Ref;
function Create_Dynamic_SO_Ref
(E : Entity_Id)
return Dynamic_SO_Ref
is
T : Nat;
begin
Dynamic_SO_Entity_Table.Increment_Last;
T := Dynamic_SO_Entity_Table.Last;
Dynamic_SO_Entity_Table.Table (T) := E;
return UI_From_Int (-T);
end Create_Dynamic_SO_Ref;
function Create_Node
(Expr : TCode;
Op1 : Node_Ref_Or_Val;
Op2 : Node_Ref_Or_Val := No_Uint;
Op3 : Node_Ref_Or_Val := No_Uint)
return Node_Ref
is
T : Nat;
begin
Rep_Table.Increment_Last;
T := Rep_Table.Last;
Rep_Table.Table (T).Expr := Expr;
Rep_Table.Table (T).Op1 := Op1;
Rep_Table.Table (T).Op2 := Op2;
Rep_Table.Table (T).Op3 := Op3;
return UI_From_Int (-T);
end Create_Node;
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;
function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
begin
return U < Uint_0;
end Is_Dynamic_SO_Ref;
function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
begin
return U >= Uint_0;
end Is_Static_SO_Ref;
procedure lgx (U : Node_Ref_Or_Val) is
begin
List_GCC_Expression (U);
Write_Eol;
end lgx;
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;
procedure List_Entities (Ent : Entity_Id) is
E : Entity_Id;
begin
if Present (Ent) then
E := First_Entity (Ent);
while Present (E) loop
if Comes_From_Source (E) or else Debug_Flag_AA then
if Is_Record_Type (E) then
List_Record_Info (E);
elsif Is_Array_Type (E) then
List_Array_Info (E);
elsif List_Representation_Info >= 2 then
if Is_Type (E) then
List_Type_Info (E);
elsif Ekind (E) = E_Variable
or else
Ekind (E) = E_Constant
or else
Ekind (E) = E_Loop_Parameter
or else
Is_Formal (E)
then
List_Object_Info (E);
end if;
end if;
if (Ekind (E) = E_Package
and then No (Renamed_Object (E)))
or else
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);
end if;
end if;
E := Next_Entity (E);
end loop;
end if;
end List_Entities;
procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
procedure P (Val : Node_Ref_Or_Val);
procedure P (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);
procedure Binop (S : String) is
begin
Write_Char ('(');
P (Node.Op1);
Write_Str (S);
P (Node.Op2);
Write_Char (')');
end Binop;
begin
case Node.Expr is
when Cond_Expr =>
Write_Str ("(if ");
P (Node.Op1);
Write_Str (" then ");
P (Node.Op2);
Write_Str (" else ");
P (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 ('-');
P (Node.Op1);
when Min_Expr =>
Binop (" min ");
when Max_Expr =>
Binop (" max ");
when Abs_Expr =>
Write_Str ("abs ");
P (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 ");
P (Node.Op1);
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 P;
begin
if U = No_Uint then
Write_Line ("??");
else
P (U);
end if;
end List_GCC_Expression;
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;
procedure List_Object_Info (Ent : Entity_Id) is
begin
Write_Eol;
if Known_Esize (Ent) then
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'Size use ");
Write_Val (Esize (Ent));
Write_Line (";");
end if;
if Known_Alignment (Ent) then
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'Alignment use ");
Write_Val (Alignment (Ent));
Write_Line (";");
end if;
end List_Object_Info;
procedure List_Record_Info (Ent : Entity_Id) is
Comp : Entity_Id;
Esiz : Uint;
Cfbit : Uint;
Sunit : Uint;
Max_Name_Length : Natural;
Max_Suni_Length : Natural;
begin
List_Type_Info (Ent);
Write_Str ("for ");
List_Name (Ent);
Write_Line (" use record");
Max_Name_Length := 0;
Max_Suni_Length := 0;
Comp := First_Entity (Ent);
while Present (Comp) loop
if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant
then
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
Set_Normalized_Position (Comp, Cfbit / SSU);
Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
Esiz := Esize (Comp);
Sunit := Cfbit / SSU;
UI_Image (Sunit);
end if;
if Unknown_Normalized_First_Bit (Comp) then
Set_Normalized_First_Bit (Comp, Uint_0);
end if;
Max_Suni_Length :=
Natural'Max (Max_Suni_Length, UI_Image_Length);
end if;
Comp := Next_Entity (Comp);
end loop;
Comp := First_Entity (Ent);
while Present (Comp) loop
if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant
then
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_Val (Bofs, Paren => True);
Write_Str (" / 8");
elsif Known_Normalized_Position (Comp)
and then List_Representation_Info = 3
then
Spaces (Max_Suni_Length - 2);
Write_Val (Npos);
else
Write_Str ("??");
end if;
Write_Str (" range ");
UI_Write (Fbit);
Write_Str (" .. ");
if not Is_Dynamic_SO_Ref (Esize (Comp)) then
Lbit := Fbit + Esiz - 1;
if Lbit < 10 then
Write_Char (' ');
end if;
UI_Write (Lbit);
elsif List_Representation_Info < 3 then
Write_Str ("??");
else
Write_Val (Esiz, Paren => True);
if not Back_End_Layout then
Write_Str (" * ");
Write_Int (SSU);
end if;
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;
end if;
Comp := Next_Entity (Comp);
end loop;
Write_Line ("end record;");
end List_Record_Info;
procedure List_Rep_Info is
Col : Nat;
begin
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));
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));
end if;
end loop;
end List_Rep_Info;
procedure List_Type_Info (Ent : Entity_Id) is
begin
Write_Eol;
if Esize (Ent) = RM_Size (Ent) then
if Known_Esize (Ent) then
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'Size use ");
Write_Val (Esize (Ent));
Write_Line (";");
end if;
elsif Unknown_RM_Size (Ent) then
if Known_Esize (Ent) then
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'Size use ");
Write_Val (Esize (Ent));
Write_Line (";");
end if;
else
if Known_Esize (Ent) then
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'Object_Size use ");
Write_Val (Esize (Ent));
Write_Line (";");
end if;
if Known_RM_Size (Ent) or else Is_Discrete_Type (Ent) then
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'Value_Size use ");
Write_Val (RM_Size (Ent));
Write_Line (";");
end if;
end if;
if Known_Alignment (Ent) then
Write_Str ("for ");
List_Name (Ent);
Write_Str ("'Alignment use ");
Write_Val (Alignment (Ent));
Write_Line (";");
end if;
end List_Type_Info;
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;
function Rep_Value
(Val : Node_Ref_Or_Val;
D : Discrim_List)
return Uint
is
function B (Val : Boolean) return Uint;
function T (Val : Node_Ref_Or_Val) return Boolean;
function V (Val : Node_Ref_Or_Val) return Uint;
function B (Val : Boolean) return Uint is
begin
if Val then
return Uint_1;
else
return Uint_0;
end if;
end B;
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;
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 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;
begin
if Val = No_Uint then
return No_Uint;
else
return V (Val);
end if;
end Rep_Value;
procedure Spaces (N : Natural) is
begin
for J in 1 .. N loop
Write_Char (' ');
end loop;
end Spaces;
procedure Tree_Read is
begin
Rep_Table.Tree_Read;
end Tree_Read;
procedure Tree_Write is
begin
Rep_Table.Tree_Write;
end Tree_Write;
procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
begin
if Rep_Not_Constant (Val) then
if List_Representation_Info < 3 then
Write_Str ("??");
else
if Back_End_Layout then
Write_Char (' ');
List_GCC_Expression (Val);
Write_Char (' ');
else
Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val)));
end if;
end if;
else
UI_Write (Val);
end if;
end Write_Val;
end Repinfo;