with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Einfo; use Einfo;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Imgv is
procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (E);
Str : String_Id;
Ind : List_Id;
Lit : Entity_Id;
Nlit : Nat;
Len : Nat;
Estr : Entity_Id;
Eind : Entity_Id;
Ityp : Node_Id;
begin
if E /= Root_Type (E) then
return;
elsif Discard_Names (E) then
return;
end if;
Start_String;
Ind := New_List;
Lit := First_Literal (E);
Len := 1;
Nlit := 0;
loop
Append_To (Ind,
Make_Integer_Literal (Loc, UI_From_Int (Len)));
exit when No (Lit);
Nlit := Nlit + 1;
Get_Unqualified_Decoded_Name_String (Chars (Lit));
if Name_Buffer (1) /= ''' then
Set_Casing (All_Upper_Case);
end if;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
Len := Len + Int (Name_Len);
Next_Literal (Lit);
end loop;
if Len < Int (2 ** (8 - 1)) then
Ityp := Standard_Integer_8;
elsif Len < Int (2 ** (16 - 1)) then
Ityp := Standard_Integer_16;
else
Ityp := Standard_Integer_32;
end if;
Str := End_String;
Estr :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (E), 'S'));
Eind :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (E), 'I'));
Set_Lit_Strings (E, Estr);
Set_Lit_Indexes (E, Eind);
Insert_Actions (N,
New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Estr,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Standard_String, Loc),
Expression =>
Make_String_Literal (Loc,
Strval => Str)),
Make_Object_Declaration (Loc,
Defining_Identifier => Eind,
Constant_Present => True,
Object_Definition =>
Make_Constrained_Array_Definition (Loc,
Discrete_Subtype_Definitions => New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc, 0),
High_Bound => Make_Integer_Literal (Loc, Nlit))),
Subtype_Indication => New_Occurrence_Of (Ityp, Loc)),
Expression =>
Make_Aggregate (Loc,
Expressions => Ind))),
Suppress => All_Checks);
end Build_Enumeration_Image_Tables;
procedure Expand_Image_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Exprs : constant List_Id := Expressions (N);
Pref : constant Node_Id := Prefix (N);
Ptyp : constant Entity_Id := Entity (Pref);
Rtyp : constant Entity_Id := Root_Type (Ptyp);
Expr : constant Node_Id := Relocate_Node (First (Exprs));
Imid : RE_Id;
Tent : Entity_Id;
Arglist : List_Id;
Func : RE_Id;
Ttyp : Entity_Id;
Func_Ent : Entity_Id;
begin
if Rtyp = Standard_Boolean then
Imid := RE_Image_Boolean;
Tent := Rtyp;
elsif Rtyp = Standard_Character then
Imid := RE_Image_Character;
Tent := Rtyp;
elsif Rtyp = Standard_Wide_Character then
Imid := RE_Image_Wide_Character;
Tent := Rtyp;
elsif Is_Signed_Integer_Type (Rtyp) then
if Esize (Rtyp) <= Esize (Standard_Integer) then
Imid := RE_Image_Integer;
Tent := Standard_Integer;
else
Imid := RE_Image_Long_Long_Integer;
Tent := Standard_Long_Long_Integer;
end if;
elsif Is_Modular_Integer_Type (Rtyp) then
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
Imid := RE_Image_Unsigned;
Tent := RTE (RE_Unsigned);
else
Imid := RE_Image_Long_Long_Unsigned;
Tent := RTE (RE_Long_Long_Unsigned);
end if;
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
Imid := RE_Image_Decimal;
Tent := Standard_Integer;
else
Imid := RE_Image_Long_Long_Decimal;
Tent := Standard_Long_Long_Integer;
end if;
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
Imid := RE_Image_Ordinary_Fixed_Point;
Tent := Standard_Long_Long_Float;
elsif Is_Floating_Point_Type (Rtyp) then
Imid := RE_Image_Floating_Point;
Tent := Standard_Long_Long_Float;
else
if Discard_Names (First_Subtype (Ptyp))
or else No (Lit_Strings (Root_Type (Ptyp)))
then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix =>
Make_Attribute_Reference (Loc,
Prefix => Pref,
Attribute_Name => Name_Pos,
Expressions => New_List (Expr)),
Attribute_Name =>
Name_Img));
Analyze_And_Resolve (N, Standard_String);
else
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
if Ttyp = Standard_Integer_8 then
Func := RE_Image_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
Func := RE_Image_Enumeration_16;
else
Func := RE_Image_Enumeration_32;
end if;
if not Expr_Known_Valid (Expr) then
Insert_Valid_Check (Expr);
end if;
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Func), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Expressions => New_List (Expr)),
New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
Attribute_Name => Name_Address))));
Analyze_And_Resolve (N, Standard_String);
end if;
return;
end if;
Func_Ent := RTE (Imid);
if No (Func_Ent) then
return;
end if;
Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr)));
if Is_Floating_Point_Type (Rtyp) then
Append_To (Arglist,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Digits));
elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
Append_To (Arglist,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Aft));
elsif Rtyp = Standard_Wide_Character then
Append_To (Arglist,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
Append_To (Arglist,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Scale));
Set_Conversion_OK (First (Arglist));
Set_Etype (First (Arglist), Tent);
end if;
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Ent, Loc),
Parameter_Associations => Arglist));
Analyze_And_Resolve (N, Standard_String);
end Expand_Image_Attribute;
procedure Expand_Value_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Btyp : constant Entity_Id := Base_Type (Typ);
Rtyp : constant Entity_Id := Root_Type (Typ);
Exprs : constant List_Id := Expressions (N);
Vid : RE_Id;
Args : List_Id;
Func : RE_Id;
Ttyp : Entity_Id;
begin
Args := Exprs;
if Rtyp = Standard_Character then
Vid := RE_Value_Character;
elsif Rtyp = Standard_Boolean then
Vid := RE_Value_Boolean;
elsif Rtyp = Standard_Wide_Character then
Vid := RE_Value_Wide_Character;
Append_To (Args,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
or else Rtyp = Base_Type (Standard_Short_Integer)
or else Rtyp = Base_Type (Standard_Integer)
then
Vid := RE_Value_Integer;
elsif Is_Signed_Integer_Type (Rtyp) then
Vid := RE_Value_Long_Long_Integer;
elsif Is_Modular_Integer_Type (Rtyp) then
if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
Vid := RE_Value_Unsigned;
else
Vid := RE_Value_Long_Long_Unsigned;
end if;
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
Vid := RE_Value_Decimal;
else
Vid := RE_Value_Long_Long_Decimal;
end if;
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Scale));
Rewrite (N,
OK_Convert_To (Btyp,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Vid), Loc),
Parameter_Associations => Args)));
Set_Etype (N, Btyp);
Analyze_And_Resolve (N, Btyp);
return;
elsif Is_Real_Type (Rtyp) then
Vid := RE_Value_Real;
else
pragma Assert (Is_Enumeration_Type (Rtyp));
if Discard_Names (First_Subtype (Typ))
or else No (Lit_Strings (Rtyp))
then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Btyp, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
Attribute_Name => Name_Value,
Expressions => Args))));
Analyze_And_Resolve (N, Btyp);
else
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
if Ttyp = Standard_Integer_8 then
Func := RE_Value_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
Func := RE_Value_Enumeration_16;
else
Func := RE_Value_Enumeration_32;
end if;
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Rtyp, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Rtyp, Loc),
Attribute_Name => Name_Last))));
Prepend_To (Args,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
Attribute_Name => Name_Address));
Prepend_To (Args,
New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (Func), Loc),
Parameter_Associations => Args))));
Analyze_And_Resolve (N, Btyp);
end if;
return;
end if;
Rewrite (N,
Convert_To (Btyp,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Vid), Loc),
Parameter_Associations => Args)));
Analyze_And_Resolve (N, Btyp);
end Expand_Value_Attribute;
procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pref : constant Node_Id := Prefix (N);
Ptyp : constant Entity_Id := Etype (Pref);
Rtyp : constant Entity_Id := Root_Type (Ptyp);
XX : RE_Id;
YY : Entity_Id;
Arglist : List_Id;
Ttyp : Entity_Id;
begin
if Rtyp = Standard_Boolean then
XX := RE_Width_Boolean;
YY := Rtyp;
elsif Rtyp = Standard_Character then
if not Wide then
XX := RE_Width_Character;
else
XX := RE_Wide_Width_Character;
end if;
YY := Rtyp;
elsif Rtyp = Standard_Wide_Character then
if not Wide then
XX := RE_Width_Wide_Character;
else
XX := RE_Wide_Width_Wide_Character;
end if;
YY := Rtyp;
elsif Is_Signed_Integer_Type (Rtyp) then
XX := RE_Width_Long_Long_Integer;
YY := Standard_Long_Long_Integer;
elsif Is_Modular_Integer_Type (Rtyp) then
XX := RE_Width_Long_Long_Unsigned;
YY := RTE (RE_Long_Long_Unsigned);
elsif Is_Real_Type (Rtyp) then
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Gt (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_First),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last)),
Make_Integer_Literal (Loc, 0),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
Attribute_Name => Name_Width))));
Analyze_And_Resolve (N, Typ);
return;
else
pragma Assert (Is_Enumeration_Type (Rtyp));
Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
if not Wide then
if Ttyp = Standard_Integer_8 then
XX := RE_Width_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
XX := RE_Width_Enumeration_16;
else
XX := RE_Width_Enumeration_32;
end if;
else
if Ttyp = Standard_Integer_8 then
XX := RE_Wide_Width_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
XX := RE_Wide_Width_Enumeration_16;
else
XX := RE_Wide_Width_Enumeration_32;
end if;
end if;
Arglist :=
New_List (
New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_First))),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last))));
if Wide then
Append_To (Arglist,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
end if;
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (XX), Loc),
Parameter_Associations => Arglist)));
Analyze_And_Resolve (N, Typ);
return;
end if;
Arglist := New_List (
Convert_To (YY,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_First)),
Convert_To (YY,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last)));
if Rtyp = Standard_Wide_Character and then Wide then
Append_To (Arglist,
Make_Integer_Literal (Loc,
Intval => Int (Wide_Character_Encoding_Method)));
end if;
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (XX), Loc),
Parameter_Associations => Arglist)));
Analyze_And_Resolve (N, Typ);
end Expand_Width_Attribute;
end Exp_Imgv;