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 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -196,6 +196,13 @@ package body Exp_VFpt is
Func := RE_Lt_G;
end if;
when N_Op_Ne =>
if Typc = 'F' then
Func := RE_Ne_F;
else
Func := RE_Ne_G;
end if;
when others =>
Func := RE_Null;
raise Program_Error;
......@@ -295,14 +302,16 @@ package body Exp_VFpt is
end if;
end Call_Type;
-------------------------------------------------
-- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
-------------------------------------------------
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;
......@@ -320,38 +329,62 @@ package body Exp_VFpt is
Rewrite (N,
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
-- convert the scaled integer value to the target type, and multiply
-- by 'Small of type.
-- If Conversion_OK set, then we introduce an intermediate IEEE
-- target type since we are expecting the code generator to handle
-- the case of integer to IEEE float.
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))));
if Conversion_OK (N) then
Rewrite (N,
Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr)));
-- Otherwise, convert the scaled integer value to the target type,
-- and multiply by 'Small of type.
else
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))));
end if;
-- Case of conversion of Vax_Float type to fixed-point type
elsif Is_Fixed_Point_Type (T_Typ) then
-- multiply value by 'small of type, and convert to the corresponding
-- integer type.
-- If Conversion_OK set, then we introduce an intermediate IEEE
-- target type, since we are expecting the code generator to handle
-- the case of IEEE float to integer.
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))))));
if Conversion_OK (N) then
Rewrite (N,
OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr)));
-- Otherwise, multiply value by 'small of type, and convert to the
-- corresponding integer type.
else
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))))));
end if;
-- All other cases
......
gcc/ada/s-vaflop.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -310,6 +310,24 @@ package body System.Vax_Float_Operations is
return X * Y;
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 --
-----------
......@@ -426,7 +444,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice.
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
return Val'Valid;
end Valid_D;
......@@ -439,7 +457,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice.
function Valid_F (Arg : F) return Boolean is
Val : S := F_To_S (Arg);
Val : constant S := F_To_S (Arg);
begin
return Val'Valid;
end Valid_F;
......@@ -452,7 +470,7 @@ package body System.Vax_Float_Operations is
-- accurate, but is good enough in practice.
function Valid_G (Arg : G) return Boolean is
Val : T := G_To_T (Arg);
Val : constant T := G_To_T (Arg);
begin
return Val'Valid;
end Valid_G;
......
gcc/ada/s-vaflop.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -139,6 +139,10 @@ package System.Vax_Float_Operations is
function Lt_G (X, Y : G) return Boolean;
-- 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 --
----------------------------------
......@@ -218,6 +222,8 @@ private
pragma Inline (Le_G);
pragma Inline (Lt_F);
pragma Inline (Lt_G);
pragma Inline (Ne_F);
pragma Inline (Ne_G);
pragma Inline (Valid_D);
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