mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-21 05:10:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

exp_attr.adb: Handle vax fpt for 'Valid attribute

Browse Source 
2005-09-01  Robert Dewar  <dewar@adacore.com>
	    Doug Rupp  <rupp@adacore.com>

	* exp_attr.adb: Handle vax fpt for 'Valid attribute
	* exp_vfpt.ads, exp_vfpt.adb: (Expand_Vax_Valid): New procedure
	* s-vaflop-vms-alpha.adb, s-vaflop.ads, s-vaflop.adb
	(Valid_D, Valid_F, Valid_G): New functions

From-SVN: r103860
This commit is contained in:
Robert Dewar 2005-09-05 09:53:10 +02:00 committed by Arnaud Charlet
parent 3711d64615
commit 0f7164706b
6 changed files with 157 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/ada/exp_attr.adb
View File

@ -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).

38
gcc/ada/exp_vfpt.adb
View File

@ -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;

29
gcc/ada/exp_vfpt.ads
View File

@ -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;

41
gcc/ada/s-vaflop-vms-alpha.adb
View File

@ -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;

41
gcc/ada/s-vaflop.adb
View File

@ -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;

15
gcc/ada/s-vaflop.ads
View File

@ -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;