diff options
| -rw-r--r-- | gcc/ada/exp_attr.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_vfpt.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/exp_vfpt.ads | 29 | ||||
| -rw-r--r-- | gcc/ada/s-vaflop-vms-alpha.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/s-vaflop.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/s-vaflop.ads | 15 |
6 files changed, 157 insertions, 19 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 0c43d595207..b9d7ee1f1df 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -35,6 +35,7 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Exp_VFpt; use Exp_VFpt; with Gnatvsn; use Gnatvsn; with Hostparm; use Hostparm; with Lib; use Lib; @@ -3826,13 +3827,20 @@ package body Exp_Attr is Rtp : constant Entity_Id := Root_Type (Etype (Pref)); begin + -- For vax fpt types, call appropriate routine in special vax + -- floating point unit. We do not have to worry about loads in + -- this case, since these types have no signalling NaN's. + + if Vax_Float (Rtp) then + Expand_Vax_Valid (N); + -- If the floating-point object might be unaligned, we need -- to call the special routine Unaligned_Valid, which makes -- the needed copy, being careful not to load the value into -- any floating-point register. The argument in this case is -- obj'Address (see Unchecked_Valid routine in s-fatgen.ads). - if Is_Possibly_Unaligned_Object (Pref) then + elsif Is_Possibly_Unaligned_Object (Pref) then Set_Attribute_Name (N, Name_Unaligned_Valid); Expand_Fpt_Attribute (N, Rtp, Name_Unaligned_Valid, @@ -3842,7 +3850,7 @@ package body Exp_Attr is Attribute_Name => Name_Address))); -- In the normal case where we are sure the object is aligned, - -- we generate a caqll to Valid, and the argument in this case + -- we generate a call to Valid, and the argument in this case -- is obj'Unrestricted_Access (after converting obj to the -- right floating-point type). diff --git a/gcc/ada/exp_vfpt.adb b/gcc/ada/exp_vfpt.adb index 8a4a9db3b75..98b2b075ce0 100644 --- a/gcc/ada/exp_vfpt.adb +++ b/gcc/ada/exp_vfpt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2002 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- -- @@ -353,7 +353,7 @@ package body Exp_VFpt is Make_Real_Literal (Loc, Realval => Ureal_1 / Small_Value (T_Typ)))))); - -- All other cases. + -- All other cases else -- Compute types for call @@ -499,4 +499,38 @@ package body Exp_VFpt is end if; end Expand_Vax_Real_Literal; + ---------------------- + -- Expand_Vax_Valid -- + ---------------------- + + procedure Expand_Vax_Valid (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Pref : constant Node_Id := Prefix (N); + Ptyp : constant Entity_Id := Root_Type (Etype (Pref)); + Rtyp : constant Entity_Id := Etype (N); + Vtyp : RE_Id; + Func : RE_Id; + + begin + if Digits_Value (Ptyp) = VAXFF_Digits then + Func := RE_Valid_F; + Vtyp := RE_F; + elsif Digits_Value (Ptyp) = VAXDF_Digits then + Func := RE_Valid_D; + Vtyp := RE_D; + else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits); + Func := RE_Valid_G; + Vtyp := RE_G; + end if; + + Rewrite (N, + Convert_To (Rtyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => New_List ( + Convert_To (RTE (Vtyp), Pref))))); + + Analyze_And_Resolve (N); + end Expand_Vax_Valid; + end Exp_VFpt; diff --git a/gcc/ada/exp_vfpt.ads b/gcc/ada/exp_vfpt.ads index f431e1d18a6..fb33b795db9 100644 --- a/gcc/ada/exp_vfpt.ads +++ b/gcc/ada/exp_vfpt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -26,7 +26,7 @@ -- This package contains specialized routines for handling the expansion -- of arithmetic and conversion operations involving Vax format floating- --- point formats as used on the Vax and the Alpha. +-- point formats as used on the Vax and the Alpha and the ia64. with Types; use Types; @@ -34,21 +34,26 @@ package Exp_VFpt is procedure Expand_Vax_Arith (N : Node_Id); -- The node N is an arithmetic node (N_Op_Abs, N_Op_Add, N_Op_Sub, - -- N_Op_Div, N_Op_Mul, N_Op_Minus where the operands are in Vax - -- float format. This procedure expands the necessary call. + -- N_Op_Div, N_Op_Mul, N_Op_Minus where the operands are in Vax float + -- format. This procedure expands the necessary call. procedure Expand_Vax_Comparison (N : Node_Id); - -- The node N is an arithmetic comparison node where the types to - -- be compared are in Vax float format. This procedure expands the - -- necessary call. + -- The node N is an arithmetic comparison node where the types to be + -- compared are in Vax float format. This procedure expands the necessary + -- call. procedure Expand_Vax_Conversion (N : Node_Id); - -- The node N is a type conversion node where either the source or - -- the target type, or both, are Vax floating-point type. + -- The node N is a type conversion node where either the source or the + -- target type, or both, are Vax floating-point type. procedure Expand_Vax_Real_Literal (N : Node_Id); - -- The node N is a real literal node where the type is a Vax - -- floating-point type. This procedure rewrites the node to eliminate - -- the occurrence of such constants. + -- The node N is a real literal node where the type is a Vax floating-point + -- type. This procedure rewrites the node to eliminate the occurrence of + -- such constants. + + procedure Expand_Vax_Valid (N : Node_Id); + -- The node N is an attribute reference node for the Valid attribute where + -- the prefix is of a Vax floating-point type. This procedure expands the + -- necessary call for the validity test. end Exp_VFpt; diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb index d778187ed57..45a39bba08b 100644 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2005 Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- @@ -618,4 +618,43 @@ package body System.Vax_Float_Operations is return R1; end Sub_G; + ------------- + -- Valid_D -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_D (Arg : D) return Boolean is + Val : T := G_To_T (D_To_G (Arg)); + begin + return Val'Valid; + end Valid_D; + + ------------- + -- Valid_F -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_F (Arg : F) return Boolean is + Val : S := F_To_S (Arg); + begin + return Val'Valid; + end Valid_F; + + ------------- + -- Valid_G -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_G (Arg : G) return Boolean is + Val : T := G_To_T (Arg); + begin + return Val'Valid; + end Valid_G; + end System.Vax_Float_Operations; diff --git a/gcc/ada/s-vaflop.adb b/gcc/ada/s-vaflop.adb index 02666de4f8e..ae721cfa33d 100644 --- a/gcc/ada/s-vaflop.adb +++ b/gcc/ada/s-vaflop.adb @@ -41,7 +41,7 @@ with System.IO; use System.IO; package body System.Vax_Float_Operations is pragma Warnings (Off); - -- Warnings about infinite recursion when the -gnatdm switch is used. + -- Warnings about infinite recursion when the -gnatdm switch is used ----------- -- Abs_F -- @@ -418,4 +418,43 @@ package body System.Vax_Float_Operations is return G (X); end T_To_G; + ------------- + -- Valid_D -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_D (Arg : D) return Boolean is + Val : T := G_To_T (D_To_G (Arg)); + begin + return Val'Valid; + end Valid_D; + + ------------- + -- Valid_F -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_F (Arg : F) return Boolean is + Val : S := F_To_S (Arg); + begin + return Val'Valid; + end Valid_F; + + ------------- + -- Valid_G -- + ------------- + + -- For now, convert to IEEE and do Valid test on result. This is not quite + -- accurate, but is good enough in practice. + + function Valid_G (Arg : G) return Boolean is + Val : T := G_To_T (Arg); + begin + return Val'Valid; + end Valid_G; + end System.Vax_Float_Operations; diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads index a3b9d1fdb1d..a7bfc9319ae 100644 --- a/gcc/ada/s-vaflop.ads +++ b/gcc/ada/s-vaflop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-1998 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,15 @@ package System.Vax_Float_Operations is function Lt_G (X, Y : G) return Boolean; -- Compares for X < Y + ---------------------------------- + -- Routines for Valid Attribute -- + ---------------------------------- + + function Valid_D (Arg : D) return Boolean; + function Valid_F (Arg : F) return Boolean; + function Valid_G (Arg : G) return Boolean; + -- Test whether Arg has a valid representation + ---------------------- -- Debug Procedures -- ---------------------- @@ -210,4 +219,8 @@ private pragma Inline (Lt_F); pragma Inline (Lt_G); + pragma Inline (Valid_D); + pragma Inline (Valid_F); + pragma Inline (Valid_G); + end System.Vax_Float_Operations; |