with Atree; use Atree;
with Einfo; use Einfo;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Ttypef; use Ttypef;
with Uintp; use Uintp;
with Urealp; use Urealp;
package body Exp_VFpt is
procedure Expand_Vax_Arith (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Base_Type (Etype (N));
Typc : Character;
Atyp : Entity_Id;
Func : RE_Id;
Args : List_Id;
begin
if Digits_Value (Typ) = VAXFF_Digits then
Typc := 'F';
Atyp := RTE (RE_F);
else
Typc := 'G';
Atyp := RTE (RE_G);
end if;
case Nkind (N) is
when N_Op_Abs =>
if Typc = 'F' then
Func := RE_Abs_F;
else
Func := RE_Abs_G;
end if;
when N_Op_Add =>
if Typc = 'F' then
Func := RE_Add_F;
else
Func := RE_Add_G;
end if;
when N_Op_Divide =>
if Typc = 'F' then
Func := RE_Div_F;
else
Func := RE_Div_G;
end if;
when N_Op_Multiply =>
if Typc = 'F' then
Func := RE_Mul_F;
else
Func := RE_Mul_G;
end if;
when N_Op_Minus =>
if Typc = 'F' then
Func := RE_Neg_F;
else
Func := RE_Neg_G;
end if;
when N_Op_Subtract =>
if Typc = 'F' then
Func := RE_Sub_F;
else
Func := RE_Sub_G;
end if;
when others =>
Func := RE_Null;
raise Program_Error;
end case;
Args := New_List;
if Nkind (N) in N_Binary_Op then
Append_To (Args,
Convert_To (Atyp, Left_Opnd (N)));
end if;
Append_To (Args,
Convert_To (Atyp, Right_Opnd (N)));
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Func), Loc),
Parameter_Associations => Args)));
Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
end Expand_Vax_Arith;
procedure Expand_Vax_Comparison (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N)));
Typc : Character;
Func : RE_Id;
Atyp : Entity_Id;
Revrs : Boolean := False;
Args : List_Id;
begin
if Digits_Value (Typ) = VAXFF_Digits then
Typc := 'F';
Atyp := RTE (RE_F);
else
Typc := 'G';
Atyp := RTE (RE_G);
end if;
case Nkind (N) is
when N_Op_Eq =>
if Typc = 'F' then
Func := RE_Eq_F;
else
Func := RE_Eq_G;
end if;
when N_Op_Ge =>
if Typc = 'F' then
Func := RE_Le_F;
else
Func := RE_Le_G;
end if;
Revrs := True;
when N_Op_Gt =>
if Typc = 'F' then
Func := RE_Lt_F;
else
Func := RE_Lt_G;
end if;
Revrs := True;
when N_Op_Le =>
if Typc = 'F' then
Func := RE_Le_F;
else
Func := RE_Le_G;
end if;
when N_Op_Lt =>
if Typc = 'F' then
Func := RE_Lt_F;
else
Func := RE_Lt_G;
end if;
when others =>
Func := RE_Null;
raise Program_Error;
end case;
if not Revrs then
Args := New_List (
Convert_To (Atyp, Left_Opnd (N)),
Convert_To (Atyp, Right_Opnd (N)));
else
Args := New_List (
Convert_To (Atyp, Right_Opnd (N)),
Convert_To (Atyp, Left_Opnd (N)));
end if;
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Func), Loc),
Parameter_Associations => Args));
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end Expand_Vax_Comparison;
procedure Expand_Vax_Conversion (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Expr : constant Node_Id := Expression (N);
S_Typ : constant Entity_Id := Base_Type (Etype (Expr));
T_Typ : constant Entity_Id := Base_Type (Etype (N));
CallS : RE_Id;
CallT : RE_Id;
Func : RE_Id;
function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id;
function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id;
function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is
begin
if Vax_Float (T) then
if Digits_Value (T) = VAXFF_Digits then
return RE_F;
elsif Digits_Value (T) = VAXGF_Digits then
return RE_G;
else pragma Assert (Digits_Value (T) = VAXDF_Digits);
if Vax_Float (Otyp)
and then Digits_Value (Otyp) = VAXGF_Digits
then
return RE_D;
else
return RE_G;
end if;
end if;
elsif Is_Discrete_Type (T) then
return RE_Q;
else pragma Assert (Is_Real_Type (T));
if Digits_Value (Otyp) = VAXFF_Digits then
return RE_S;
else
return RE_T;
end if;
end if;
end Call_Type;
function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is
begin
if Esize (T) = Esize (Standard_Long_Long_Integer) then
return Standard_Long_Long_Integer;
elsif Esize (T) = Esize (Standard_Long_Integer) then
return Standard_Long_Integer;
else
return Standard_Integer;
end if;
end Equivalent_Integer_Type;
begin
if Vax_Float (S_Typ) and then Vax_Float (T_Typ)
and then Digits_Value (S_Typ) = Digits_Value (T_Typ)
then
Rewrite (N,
Unchecked_Convert_To (T_Typ, Expr));
elsif Is_Fixed_Point_Type (S_Typ) then
Rewrite (N,
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (T_Typ, Loc),
Expression =>
Unchecked_Convert_To (
Equivalent_Integer_Type (S_Typ), Expr)),
Right_Opnd =>
Make_Real_Literal (Loc, Realval => Small_Value (S_Typ))));
elsif Is_Fixed_Point_Type (T_Typ) then
Rewrite (N,
Unchecked_Convert_To (T_Typ,
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc),
Expression =>
Make_Op_Multiply (Loc,
Left_Opnd => Expr,
Right_Opnd =>
Make_Real_Literal (Loc,
Realval => Ureal_1 / Small_Value (T_Typ))))));
else
CallS := Call_Type (S_Typ, T_Typ);
CallT := Call_Type (T_Typ, S_Typ);
if CallS = RE_D and then CallT = RE_G then
Func := RE_D_To_G;
elsif CallS = RE_G and then CallT = RE_D then
Func := RE_G_To_D;
elsif CallS = RE_G and then CallT = RE_F then
Func := RE_G_To_F;
elsif CallS = RE_F and then CallT = RE_G then
Func := RE_F_To_G;
elsif CallS = RE_F and then CallT = RE_S then
Func := RE_F_To_S;
elsif CallS = RE_S and then CallT = RE_F then
Func := RE_S_To_F;
elsif CallS = RE_G and then CallT = RE_T then
Func := RE_G_To_T;
elsif CallS = RE_T and then CallT = RE_G then
Func := RE_T_To_G;
elsif CallS = RE_F and then CallT = RE_Q then
Func := RE_F_To_Q;
elsif CallS = RE_Q and then CallT = RE_F then
Func := RE_Q_To_F;
elsif CallS = RE_G and then CallT = RE_Q then
Func := RE_G_To_Q;
else pragma Assert (CallS = RE_Q and then CallT = RE_G);
Func := RE_Q_To_G;
end if;
Rewrite (N,
Convert_To (T_Typ,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Func), Loc),
Parameter_Associations => New_List (
Convert_To (RTE (CallS), Expr)))));
end if;
Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks);
end Expand_Vax_Conversion;
procedure Expand_Vax_Real_Literal (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Btyp : constant Entity_Id := Base_Type (Typ);
Stat : constant Boolean := Is_Static_Expression (N);
Nod : Node_Id;
RE_Source : RE_Id;
RE_Target : RE_Id;
RE_Fncall : RE_Id;
begin
if Vax_Float (Btyp) then
if Digits_Value (Btyp) = VAXFF_Digits then
RE_Source := RE_S;
RE_Target := RE_F;
RE_Fncall := RE_S_To_F;
elsif Digits_Value (Btyp) = VAXDF_Digits then
RE_Source := RE_T;
RE_Target := RE_D;
RE_Fncall := RE_T_To_D;
else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits);
RE_Source := RE_T;
RE_Target := RE_G;
RE_Fncall := RE_T_To_G;
end if;
Nod := Relocate_Node (N);
Set_Etype (Nod, RTE (RE_Source));
Set_Analyzed (Nod, True);
Nod :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_Fncall), Loc),
Parameter_Associations => New_List (Nod));
Set_Etype (Nod, RTE (RE_Target));
Set_Analyzed (Nod, True);
Nod :=
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Expression => Nod);
Set_Etype (Nod, Typ);
Set_Analyzed (Nod, True);
Rewrite (N, Nod);
Set_Is_Static_Expression (N, Stat);
end if;
end Expand_Vax_Real_Literal;
end Exp_VFpt;