Skip to content

R
riscv-gcc-1
Commit 0d268911 by Robert Dewar Committed by Arnaud Charlet
Options

exp_vfpt.adb: Handle /= case 

2005-11-14  Robert Dewar  <dewar@adacore.com>

	* exp_vfpt.adb: Handle /= case
	(Expand_Vax_Conversion): Properly recognize Conversion_OK flag
	so that we do not get duplicate scaling for fixed point conversions.

	* s-vaflop.ads, s-vaflop.adb: (Ne_F): New function

From-SVN: r106951
parent f02b8bb8
Showing with 90 additions and 33 deletions
gcc/ada/exp_vfpt.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1997-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1997-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -196,6 +196,13 @@ package body Exp_VFpt is ...@@ -196,6 +196,13 @@ package body Exp_VFpt is
Func := RE_Lt_G; Func := RE_Lt_G;
end if; end if;
when N_Op_Ne =>
if Typc = 'F' then
Func := RE_Ne_F;
else
Func := RE_Ne_G;
end if;
when others => when others =>
Func := RE_Null; Func := RE_Null;
raise Program_Error; raise Program_Error;
...@@ -295,14 +302,16 @@ package body Exp_VFpt is ...@@ -295,14 +302,16 @@ package body Exp_VFpt is
end if; end if;
end Call_Type; end Call_Type;
-------------------------------------------------
-- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
-------------------------------------------------
function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is
begin begin
if Esize (T) = Esize (Standard_Long_Long_Integer) then if Esize (T) = Esize (Standard_Long_Long_Integer) then
return Standard_Long_Long_Integer; return Standard_Long_Long_Integer;
elsif Esize (T) = Esize (Standard_Long_Integer) then elsif Esize (T) = Esize (Standard_Long_Integer) then
return Standard_Long_Integer; return Standard_Long_Integer;
else else
return Standard_Integer; return Standard_Integer;
end if; end if;
...@@ -320,38 +329,62 @@ package body Exp_VFpt is ...@@ -320,38 +329,62 @@ package body Exp_VFpt is
Rewrite (N, Rewrite (N,
Unchecked_Convert_To (T_Typ, Expr)); Unchecked_Convert_To (T_Typ, Expr));
-- Case of conversion of fixed-point type to Vax_Float type
elsif Is_Fixed_Point_Type (S_Typ) then elsif Is_Fixed_Point_Type (S_Typ) then
-- convert the scaled integer value to the target type, and multiply -- If Conversion_OK set, then we introduce an intermediate IEEE
-- by 'Small of type. -- target type since we are expecting the code generator to handle
-- the case of integer to IEEE float.
Rewrite (N, if Conversion_OK (N) then
Make_Op_Multiply (Loc, Rewrite (N,
Left_Opnd => Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr)));
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (T_Typ, Loc), -- Otherwise, convert the scaled integer value to the target type,
Expression => -- and multiply by 'Small of type.
Unchecked_Convert_To (
Equivalent_Integer_Type (S_Typ), Expr)), else
Right_Opnd => Rewrite (N,
Make_Real_Literal (Loc, Realval => Small_Value (S_Typ)))); 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))));
end if;
-- Case of conversion of Vax_Float type to fixed-point type
elsif Is_Fixed_Point_Type (T_Typ) then elsif Is_Fixed_Point_Type (T_Typ) then
-- multiply value by 'small of type, and convert to the corresponding -- If Conversion_OK set, then we introduce an intermediate IEEE
-- integer type. -- target type, since we are expecting the code generator to handle
-- the case of IEEE float to integer.
Rewrite (N, if Conversion_OK (N) then
Unchecked_Convert_To (T_Typ, Rewrite (N,
Make_Type_Conversion (Loc, OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr)));
Subtype_Mark =>
New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc), -- Otherwise, multiply value by 'small of type, and convert to the
Expression => -- corresponding integer type.
Make_Op_Multiply (Loc,
Left_Opnd => Expr, else
Right_Opnd => Rewrite (N,
Make_Real_Literal (Loc, Unchecked_Convert_To (T_Typ,
Realval => Ureal_1 / Small_Value (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))))));
end if;
-- All other cases -- All other cases
......
gcc/ada/s-vaflop.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1997-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1997-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -310,6 +310,24 @@ package body System.Vax_Float_Operations is ...@@ -310,6 +310,24 @@ package body System.Vax_Float_Operations is
return X * Y; return X * Y;
end Mul_G; end Mul_G;
----------
-- Ne_F --
----------
function Ne_F (X, Y : F) return Boolean is
begin
return X /= Y;
end Ne_F;
----------
-- Ne_G --
----------
function Ne_G (X, Y : G) return Boolean is
begin
return X /= Y;
end Ne_G;
----------- -----------
-- Neg_F -- -- Neg_F --
----------- -----------
...@@ -426,7 +444,7 @@ package body System.Vax_Float_Operations is ...@@ -426,7 +444,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice. -- accurate, but is good enough in practice.
function Valid_D (Arg : D) return Boolean is function Valid_D (Arg : D) return Boolean is
Val : T := G_To_T (D_To_G (Arg)); Val : constant T := G_To_T (D_To_G (Arg));
begin begin
return Val'Valid; return Val'Valid;
end Valid_D; end Valid_D;
...@@ -439,7 +457,7 @@ package body System.Vax_Float_Operations is ...@@ -439,7 +457,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice. -- accurate, but is good enough in practice.
function Valid_F (Arg : F) return Boolean is function Valid_F (Arg : F) return Boolean is
Val : S := F_To_S (Arg); Val : constant S := F_To_S (Arg);
begin begin
return Val'Valid; return Val'Valid;
end Valid_F; end Valid_F;
...@@ -452,7 +470,7 @@ package body System.Vax_Float_Operations is ...@@ -452,7 +470,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice. -- accurate, but is good enough in practice.
function Valid_G (Arg : G) return Boolean is function Valid_G (Arg : G) return Boolean is
Val : T := G_To_T (Arg); Val : constant T := G_To_T (Arg);
begin begin
return Val'Valid; return Val'Valid;
end Valid_G; end Valid_G;
......
gcc/ada/s-vaflop.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1997-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1997-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -139,6 +139,10 @@ package System.Vax_Float_Operations is ...@@ -139,6 +139,10 @@ package System.Vax_Float_Operations is
function Lt_G (X, Y : G) return Boolean; function Lt_G (X, Y : G) return Boolean;
-- Compares for X < Y -- Compares for X < Y
function Ne_F (X, Y : F) return Boolean;
function Ne_G (X, Y : G) return Boolean;
-- Compares for X /= Y
---------------------------------- ----------------------------------
-- Routines for Valid Attribute -- -- Routines for Valid Attribute --
---------------------------------- ----------------------------------
...@@ -218,6 +222,8 @@ private ...@@ -218,6 +222,8 @@ private
pragma Inline (Le_G); pragma Inline (Le_G);
pragma Inline (Lt_F); pragma Inline (Lt_F);
pragma Inline (Lt_G); pragma Inline (Lt_G);
pragma Inline (Ne_F);
pragma Inline (Ne_G);
pragma Inline (Valid_D); pragma Inline (Valid_D);
pragma Inline (Valid_F); pragma Inline (Valid_F);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment