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;
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,
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).
-- --
-- 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- --
Make_Real_Literal (Loc,
Realval => Ureal_1 / Small_Value (T_Typ))))));
- -- All other cases.
+ -- All other cases
else
-- Compute types for call
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;
-- --
-- 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- --
-- 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;
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;
-- --
-- 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 --
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;
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 --
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;
-- --
-- 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- --
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 --
----------------------
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;
projects / gcc.git / commitdiff