OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_attr.adb: Implement Machine_Rounding attribute 

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

	* sem_attr.adb: Implement Machine_Rounding attribute
	(Analyze_Access_Attribute): The access attribute may appear within an
	aggregate that has been expanded into a loop.
	(Check_Task_Prefix): Add semantic check for attribute 'Callable and
	'Terminated whenever the prefix is of a task interface class-wide type.
	(Analyze_Attribute): Add semantic check for attribute 'Identity whenever
	the prefix is of a task interface class-wide type.

	* s-vaflop-vms-alpha.adb: Valid_D, Valid_F, Valid_G: Make Val constant
	to avoid warnings.

	* s-fatgen.ads, s-fatgen.adb (Machine_Rounding): New function
	Remove pragma Inline for [Unaligned_]Valid.
	Add comments that Valid routines do not work for Vax_Float

	* exp_attr.adb: Implement Machine_Rounding attribute

	* snames.h: Add entry for Machine_Rounding attribute

From-SVN: r106970
This commit is contained in:
Robert Dewar 2005-11-15 14:56:51 +01:00 committed by Arnaud Charlet
parent 7b9d0d6990
commit 65f01153ab
6 changed files with 514 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

340
gcc/ada/exp_attr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 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- --
@ -85,16 +85,17 @@ package body Exp_Attr is
procedure Expand_Fpt_Attribute
(N : Node_Id;
Rtp : Entity_Id;
Pkg : RE_Id;
Nam : Name_Id;
Args : List_Id);
-- This procedure expands a call to a floating-point attribute function.
-- N is the attribute reference node, and Args is a list of arguments to
-- be passed to the function call. Rtp is the root type of the floating
-- point type involved (used to select the proper generic instantiation
-- of the package containing the attribute routines). The Nam argument
-- is the attribute processing routine to be called. This is normally
-- the same as the attribute name, except in the Unaligned_Valid case.
-- be passed to the function call. Pkg identifies the package containing
-- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
-- have already been converted to the floating-point type for which Pkg was
-- instantiated. The Nam argument is the relevant attribute processing
-- routine to be called. This is the same as the attribute name, except in
-- the Unaligned_Valid case.
procedure Expand_Fpt_Attribute_R (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
@ -123,6 +124,15 @@ package body Exp_Attr is
-- A reference to a type within its own scope is resolved to a reference
-- to the current instance of the type in its initialization procedure.
procedure Find_Fat_Info
(T : Entity_Id;
Fat_Type : out Entity_Id;
Fat_Pkg : out RE_Id);
-- Given a floating-point type T, identifies the package containing the
-- attributes for this type (returned in Fat_Pkg), and the corresponding
-- type for which this package was instantiated from Fat_Gen. Error if T
-- is not a floating-point type.
function Find_Stream_Subprogram
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id;
@ -176,7 +186,7 @@ package body Exp_Attr is
if Check then
Insert_Action (N, Decl);
else
Insert_Action (N, Decl, All_Checks);
Insert_Action (N, Decl, Suppress => All_Checks);
end if;
if Installed then
@ -260,18 +270,17 @@ package body Exp_Attr is
procedure Expand_Fpt_Attribute
(N : Node_Id;
Rtp : Entity_Id;
Pkg : RE_Id;
Nam : Name_Id;
Args : List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pkg : RE_Id;
Fnm : Node_Id;
begin
-- The function name is the selected component Fat_xxx.yyy where xxx
-- is the floating-point root type, and yyy is the argument Nam.
-- The function name is the selected component Attr_xxx.yyy where
-- Attr_xxx is the package name, and yyy is the argument Nam.
-- Note: it would be more usual to have separate RE entries for each
-- of the entities in the Fat packages, but first they have identical
@ -279,16 +288,6 @@ package body Exp_Attr is
-- meet the normal RE rule of separate names for all runtime entities),
-- and second there would be an awful lot of them!
if Rtp = Standard_Short_Float then
Pkg := RE_Fat_Short_Float;
elsif Rtp = Standard_Float then
Pkg := RE_Fat_Float;
elsif Rtp = Standard_Long_Float then
Pkg := RE_Fat_Long_Float;
else
Pkg := RE_Fat_Long_Long_Float;
end if;
Fnm :=
Make_Selected_Component (Loc,
Prefix => New_Reference_To (RTE (Pkg), Loc),
@ -302,7 +301,7 @@ package body Exp_Attr is
Rewrite (N,
Unchecked_Convert_To (Base_Type (Etype (N)),
Make_Function_Call (Loc,
Name => Fnm,
Name => Fnm,
Parameter_Associations => Args)));
Analyze_And_Resolve (N, Typ);
@ -318,12 +317,13 @@ package body Exp_Attr is
procedure Expand_Fpt_Attribute_R (N : Node_Id) is
E1 : constant Node_Id := First (Expressions (N));
Rtp : constant Entity_Id := Root_Type (Etype (E1));
Ftp : Entity_Id;
Pkg : RE_Id;
begin
Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
(N, Rtp, Attribute_Name (N),
New_List (Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
(N, Pkg, Attribute_Name (N),
New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
end Expand_Fpt_Attribute_R;
-----------------------------
@ -337,14 +337,15 @@ package body Exp_Attr is
procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
E1 : constant Node_Id := First (Expressions (N));
Rtp : constant Entity_Id := Root_Type (Etype (E1));
Ftp : Entity_Id;
Pkg : RE_Id;
E2 : constant Node_Id := Next (E1);
begin
Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
(N, Rtp, Attribute_Name (N),
(N, Pkg, Attribute_Name (N),
New_List (
Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RI;
@ -358,15 +359,16 @@ package body Exp_Attr is
procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
E1 : constant Node_Id := First (Expressions (N));
Rtp : constant Entity_Id := Root_Type (Etype (E1));
Ftp : Entity_Id;
Pkg : RE_Id;
E2 : constant Node_Id := Next (E1);
begin
Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
(N, Rtp, Attribute_Name (N),
(N, Pkg, Attribute_Name (N),
New_List (
Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RR;
----------------------------------
@ -1011,8 +1013,31 @@ package body Exp_Attr is
when Attribute_Callable => Callable :
begin
Rewrite (N,
Build_Call_With_Task (Pref, RTE (RE_Callable)));
-- We have an object of a task interface class-wide type as a prefix
-- to Callable. Generate:
-- callable (Pref._disp_get_task_id);
if Ada_Version >= Ada_05
and then Ekind (Etype (Pref)) = E_Class_Wide_Type
and then Is_Interface (Etype (Pref))
and then Is_Task_Interface (Etype (Pref))
then
Rewrite (N,
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Callable), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
else
Rewrite (N,
Build_Call_With_Task (Pref, RTE (RE_Callable)));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
end Callable;
@ -1630,8 +1655,8 @@ package body Exp_Attr is
-- expands into
-- Result_Type (System.Fore (Long_Long_Float (Type'First)),
-- Long_Long_Float (Type'Last))
-- Result_Type (System.Fore (Universal_Real (Type'First)),
-- Universal_Real (Type'Last))
-- Note that we know that the type is a non-static subtype, or Fore
-- would have itself been computed dynamically in Eval_Attribute.
@ -1647,12 +1672,12 @@ package body Exp_Attr is
Name => New_Reference_To (RTE (RE_Fore), Loc),
Parameter_Associations => New_List (
Convert_To (Standard_Long_Long_Float,
Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_First)),
Convert_To (Standard_Long_Long_Float,
Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last))))));
@ -2283,6 +2308,17 @@ package body Exp_Attr is
when Attribute_Machine =>
Expand_Fpt_Attribute_R (N);
----------------------
-- Machine_Rounding --
----------------------
-- Transforms 'Machine_Rounding into a call to the floating-point
-- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
-- type).
when Attribute_Machine_Rounding =>
Expand_Fpt_Attribute_R (N);
------------------
-- Machine_Size --
------------------
@ -2425,7 +2461,7 @@ package body Exp_Attr is
end if;
Analyze_And_Resolve (N, Btyp, All_Checks);
Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
end Mod_Case;
-----------
@ -3211,7 +3247,7 @@ package body Exp_Attr is
Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
return;
-- For x'Size applied to an object of a class-wide type, transform
-- For X'Size applied to an object of a class-wide type, transform
-- X'Size into a call to the primitive operation _Size applied to X.
elsif Is_Class_Wide_Type (Ptyp) then
@ -3268,8 +3304,8 @@ package body Exp_Attr is
else
Apply_Universal_Integer_Attribute_Checks (N);
-- If we have Size applied to a formal parameter, that is a
-- packed array subtype, then apply size to the actual subtype.
-- If Size is applied to a formal parameter that is of a packed
-- array subtype, then apply Size to the actual subtype.
if Is_Entity_Name (Pref)
and then Is_Formal (Entity (Pref))
@ -3284,6 +3320,20 @@ package body Exp_Attr is
Analyze_And_Resolve (N, Typ);
end if;
-- If Size is applied to a dereference of an access to
-- unconstrained packed array, GIGI needs to see its
-- unconstrained nominal type, but also a hint to the actual
-- constrained type.
if Nkind (Pref) = N_Explicit_Dereference
and then Is_Array_Type (Etype (Pref))
and then not Is_Constrained (Etype (Pref))
and then Is_Packed (Etype (Pref))
then
Set_Actual_Designated_Subtype (Pref,
Get_Actual_Subtype (Pref));
end if;
return;
end if;
@ -3590,7 +3640,28 @@ package body Exp_Attr is
when Attribute_Terminated => Terminated :
begin
if Restricted_Profile then
-- The prefix of Terminated is of a task interface class-wide type.
-- Generate:
-- terminated (Pref._disp_get_task_id);
if Ada_Version >= Ada_05
and then Ekind (Etype (Pref)) = E_Class_Wide_Type
and then Is_Interface (Etype (Pref))
and then Is_Task_Interface (Etype (Pref))
then
Rewrite (N,
Make_Function_Call (Loc,
Name =>
New_Reference_To (RTE (RE_Terminated), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id)))));
elsif Restricted_Profile then
Rewrite (N,
Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
@ -3641,7 +3712,26 @@ package body Exp_Attr is
----------------------
when Attribute_Unchecked_Access =>
Expand_Access_To_Type (N);
-- Ada 2005 (AI-251): If the designated type is an interface, then
-- rewrite the referenced object as a conversion to force the
-- displacement of the pointer to the secondary dispatch table.
if Is_Interface (Directly_Designated_Type (Btyp)) then
declare
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
Conversion : Node_Id;
begin
Conversion := Convert_To (Typ, New_Copy_Tree (Ref_Object));
Rewrite (N, Conversion);
Analyze_And_Resolve (N, Typ);
end;
-- Otherwise this is like normal Access without a check
else
Expand_Access_To_Type (N);
end if;
-----------------
-- UET_Address --
@ -3687,7 +3777,26 @@ package body Exp_Attr is
-------------------------
when Attribute_Unrestricted_Access =>
Expand_Access_To_Type (N);
-- Ada 2005 (AI-251): If the designated type is an interface, then
-- rewrite the referenced object as a conversion to force the
-- displacement of the pointer to the secondary dispatch table.
if Is_Interface (Directly_Designated_Type (Btyp)) then
declare
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
Conversion : Node_Id;
begin
Conversion := Convert_To (Typ, New_Copy_Tree (Ref_Object));
Rewrite (N, Conversion);
Analyze_And_Resolve (N, Typ);
end;
-- Otherwise this is like Access without a check
else
Expand_Access_To_Type (N);
end if;
---------------
-- VADS_Size --
@ -3824,43 +3933,50 @@ package body Exp_Attr is
if Is_Floating_Point_Type (Ptyp) then
declare
Rtp : constant Entity_Id := Root_Type (Etype (Pref));
Pkg : RE_Id;
Ftp : Entity_Id;
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
if Vax_Float (Btyp) 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).
elsif Is_Possibly_Unaligned_Object (Pref) then
Set_Attribute_Name (N, Name_Unaligned_Valid);
Expand_Fpt_Attribute
(N, Rtp, Name_Unaligned_Valid,
New_List (
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Pref),
Attribute_Name => Name_Address)));
-- In the normal case where we are sure the object is aligned,
-- 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).
-- Non VAX float case
else
Expand_Fpt_Attribute
(N, Rtp, Name_Valid,
New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Rtp, Pref),
Attribute_Name => Name_Unrestricted_Access)));
Find_Fat_Info (Etype (Pref), Ftp, Pkg);
-- 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 Fat_Gen).
if Is_Possibly_Unaligned_Object (Pref) then
Set_Attribute_Name (N, Name_Unaligned_Valid);
Expand_Fpt_Attribute
(N, Pkg, Name_Unaligned_Valid,
New_List (
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Pref),
Attribute_Name => Name_Address)));
-- In the normal case where we are sure the object is
-- aligned, 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).
else
Expand_Fpt_Attribute
(N, Pkg, Name_Valid,
New_List (
Make_Attribute_Reference (Loc,
Prefix => Unchecked_Convert_To (Ftp, Pref),
Attribute_Name => Name_Unrestricted_Access)));
end if;
end if;
-- One more task, we still need a range check. Required
@ -4488,6 +4604,78 @@ package body Exp_Attr is
Reason => CE_Overflow_Check_Failed));
end Expand_Pred_Succ;
-------------------
-- Find_Fat_Info --
-------------------
procedure Find_Fat_Info
(T : Entity_Id;
Fat_Type : out Entity_Id;
Fat_Pkg : out RE_Id)
is
Btyp : constant Entity_Id := Base_Type (T);
Rtyp : constant Entity_Id := Root_Type (T);
Digs : constant Nat := UI_To_Int (Digits_Value (Btyp));
begin
-- If the base type is VAX float, then get appropriate VAX float type
if Vax_Float (Btyp) then
case Digs is
when 6 =>
Fat_Type := RTE (RE_Fat_VAX_F);
Fat_Pkg := RE_Attr_VAX_F_Float;
when 9 =>
Fat_Type := RTE (RE_Fat_VAX_D);
Fat_Pkg := RE_Attr_VAX_D_Float;
when 15 =>
Fat_Type := RTE (RE_Fat_VAX_G);
Fat_Pkg := RE_Attr_VAX_G_Float;
when others =>
raise Program_Error;
end case;
-- If root type is VAX float, this is the case where the library has
-- been recompiled in VAX float mode, and we have an IEEE float type.
-- This is when we use the special IEEE Fat packages.
elsif Vax_Float (Rtyp) then
case Digs is
when 6 =>
Fat_Type := RTE (RE_Fat_IEEE_Short);
Fat_Pkg := RE_Attr_IEEE_Short;
when 15 =>
Fat_Type := RTE (RE_Fat_IEEE_Long);
Fat_Pkg := RE_Attr_IEEE_Long;
when others =>
raise Program_Error;
end case;
-- If neither the base type nor the root type is VAX_Float then VAX
-- float is out of the picture, and we can just use the root type.
else
Fat_Type := Rtyp;
if Fat_Type = Standard_Short_Float then
Fat_Pkg := RE_Attr_Short_Float;
elsif Fat_Type = Standard_Float then
Fat_Pkg := RE_Attr_Float;
elsif Fat_Type = Standard_Long_Float then
Fat_Pkg := RE_Attr_Long_Float;
elsif Fat_Type = Standard_Long_Long_Float then
Fat_Pkg := RE_Attr_Long_Long_Float;
else
raise Program_Error;
end if;
end if;
end Find_Fat_Info;
----------------------------
-- Find_Stream_Subprogram --
----------------------------

121
gcc/ada/s-fatgen.adb
View File

@ -99,10 +99,8 @@ package body System.Fat_Gen is
begin
if Towards = X then
return X;
elsif Towards > X then
return Succ (X);
else
return Pred (X);
end if;
@ -114,14 +112,11 @@ package body System.Fat_Gen is
function Ceiling (X : T) return T is
XT : constant T := Truncation (X);
begin
if X <= 0.0 then
return XT;
elsif X = XT then
return X;
else
return XT + 1.0;
end if;
@ -175,7 +170,7 @@ package body System.Fat_Gen is
-- T'Machine_Emin - T'Machine_Mantissa, which would preserve
-- monotonicity of the exponent function ???
-- Check for infinities, transfinites, whatnot.
-- Check for infinities, transfinites, whatnot
elsif X > T'Safe_Last then
Frac := Invrad;
@ -193,7 +188,7 @@ package body System.Fat_Gen is
Ax : T := abs X;
Ex : UI := 0;
-- Ax * Rad ** Ex is invariant.
-- Ax * Rad ** Ex is invariant
begin
if Ax >= 1.0 then
@ -256,7 +251,6 @@ package body System.Fat_Gen is
function Exponent (X : T) return UI is
X_Frac : T;
X_Exp : UI;
begin
Decompose (X, X_Frac, X_Exp);
return X_Exp;
@ -268,14 +262,11 @@ package body System.Fat_Gen is
function Floor (X : T) return T is
XT : constant T := Truncation (X);
begin
if X >= 0.0 then
return XT;
elsif XT = X then
return X;
else
return XT - 1.0;
end if;
@ -288,7 +279,6 @@ package body System.Fat_Gen is
function Fraction (X : T) return T is
X_Frac : T;
X_Exp : UI;
begin
Decompose (X, X_Frac, X_Exp);
return X_Frac;
@ -366,6 +356,38 @@ package body System.Fat_Gen is
return Temp;
end Machine;
----------------------
-- Machine_Rounding --
----------------------
-- For now, the implementation is identical to that of Rounding, which is
-- a permissible behavior, but is not the most efficient possible approach.
function Machine_Rounding (X : T) return T is
Result : T;
Tail : T;
begin
Result := Truncation (abs X);
Tail := abs X - Result;
if Tail >= 0.5 then
Result := Result + 1.0;
end if;
if X > 0.0 then
return Result;
elsif X < 0.0 then
return -Result;
-- For zero case, make sure sign of zero is preserved
else
return X;
end if;
end Machine_Rounding;
-----------
-- Model --
-----------
@ -542,7 +564,7 @@ package body System.Fat_Gen is
return X;
end if;
-- Nonzero x. essentially, just multiply repeatedly by Rad ** (+-2**n).
-- Nonzero x. essentially, just multiply repeatedly by Rad ** (+-2**n)
declare
Y : T := X;
@ -587,6 +609,7 @@ package body System.Fat_Gen is
end if;
-- 0 <= Ex < Log_Power (N)
end loop;
-- Ex = 0
@ -652,7 +675,7 @@ package body System.Fat_Gen is
-- The basic approach is to compute
-- T'Machine (RM1 + N) - RM1.
-- T'Machine (RM1 + N) - RM1
-- where N >= 0.0 and RM1 = radix ** (mantissa - 1)
@ -693,7 +716,6 @@ package body System.Fat_Gen is
return X;
end if;
end if;
end Truncation;
-----------------------
@ -727,13 +749,16 @@ package body System.Fat_Gen is
else
return X;
end if;
end Unbiased_Rounding;
-----------
-- Valid --
-----------
-- Note: this routine does not work for VAX float. We compensate for this
-- in Exp_Attr by using the Valid functions in Vax_Float_Operations rather
-- than the corresponding instantiation of this function.
function Valid (X : access T) return Boolean is
IEEE_Emin : constant Integer := T'Machine_Emin - 1;
@ -744,17 +769,17 @@ package body System.Fat_Gen is
subtype IEEE_Exponent_Range is
Integer range IEEE_Emin - 1 .. IEEE_Emax + 1;
-- The implementation of this floating point attribute uses
-- a representation type Float_Rep that allows direct access to
-- the exponent and mantissa parts of a floating point number.
-- The implementation of this floating point attribute uses a
-- representation type Float_Rep that allows direct access to the
-- exponent and mantissa parts of a floating point number.
-- The Float_Rep type is an array of Float_Word elements. This
-- representation is chosen to make it possible to size the
-- type based on a generic parameter. Since the array size is
-- known at compile-time, efficient code can still be generated.
-- The size of Float_Word elements should be large enough to allow
-- accessing the exponent in one read, but small enough so that all
-- floating point object sizes are a multiple of the Float_Word'Size.
-- representation is chosen to make it possible to size the type based
-- on a generic parameter. Since the array size is known at compile
-- time, efficient code can still be generated. The size of Float_Word
-- elements should be large enough to allow accessing the exponent in
-- one read, but small enough so that all floating point object sizes
-- are a multiple of the Float_Word'Size.
-- The following conditions must be met for all possible
-- instantiations of the attributes package:
@ -764,9 +789,9 @@ package body System.Fat_Gen is
-- - The exponent and sign are completely contained in a single
-- component of Float_Rep, named Most_Significant_Word (MSW).
-- - The sign occupies the most significant bit of the MSW
-- and the exponent is in the following bits.
-- Unused bits (if any) are in the least significant part.
-- - The sign occupies the most significant bit of the MSW and the
-- exponent is in the following bits. Unused bits (if any) are in
-- the least significant part.
type Float_Word is mod 2**Positive'Min (System.Word_Size, 32);
type Rep_Index is range 0 .. 7;
@ -775,12 +800,12 @@ package body System.Fat_Gen is
(T'Size + Float_Word'Size - 1) / Float_Word'Size;
Rep_Last : constant Rep_Index := Rep_Index'Min
(Rep_Index (Rep_Words - 1), (T'Mantissa + 16) / Float_Word'Size);
-- Determine the number of Float_Words needed for representing
-- the entire floating-poinit value. Do not take into account
-- excessive padding, as occurs on IA-64 where 80 bits floats get
-- padded to 128 bits. In general, the exponent field cannot
-- be larger than 15 bits, even for 128-bit floating-poin t types,
-- so the final format size won't be larger than T'Mantissa + 16.
-- Determine the number of Float_Words needed for representing the
-- entire floating-point value. Do not take into account excessive
-- padding, as occurs on IA-64 where 80 bits floats get padded to 128
-- bits. In general, the exponent field cannot be larger than 15 bits,
-- even for 128-bit floating-poin t types, so the final format size
-- won't be larger than T'Mantissa + 16.
type Float_Rep is
array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word;
@ -794,26 +819,26 @@ package body System.Fat_Gen is
Most_Significant_Word : constant Rep_Index :=
Rep_Last * Standard'Default_Bit_Order;
-- Finding the location of the Exponent_Word is a bit tricky.
-- In general we assume Word_Order = Bit_Order.
-- This expression needs to be refined for VMS.
-- Finding the location of the Exponent_Word is a bit tricky. In general
-- we assume Word_Order = Bit_Order. This expression needs to be refined
-- for VMS.
Exponent_Factor : constant Float_Word :=
2**(Float_Word'Size - 1) /
Float_Word (IEEE_Emax - IEEE_Emin + 3) *
Boolean'Pos (Most_Significant_Word /= 2) +
Boolean'Pos (Most_Significant_Word = 2);
-- Factor that the extracted exponent needs to be divided by
-- to be in range 0 .. IEEE_Emax - IEEE_Emin + 2.
-- Special kludge: Exponent_Factor is 1 for x86/IA64 double extended
-- as GCC adds unused bits to the type.
-- Factor that the extracted exponent needs to be divided by to be in
-- range 0 .. IEEE_Emax - IEEE_Emin + 2. Special kludge: Exponent_Factor
-- is 1 for x86/IA64 double extended as GCC adds unused bits to the
-- type.
Exponent_Mask : constant Float_Word :=
Float_Word (IEEE_Emax - IEEE_Emin + 2) *
Exponent_Factor;
-- Value needed to mask out the exponent field.
-- This assumes that the range IEEE_Emin - 1 .. IEEE_Emax + 1
-- contains 2**N values, for some N in Natural.
-- Value needed to mask out the exponent field. This assumes that the
-- range IEEE_Emin - 1 .. IEEE_Emax + contains 2**N values, for some N
-- in Natural.
function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T);
@ -834,8 +859,8 @@ package body System.Fat_Gen is
Integer ((R (Most_Significant_Word) and Exponent_Mask) /
Exponent_Factor)
- IEEE_Bias;
-- Mask/Shift T to only get bits from the exponent
-- Then convert biased value to integer value.
-- Mask/Shift T to only get bits from the exponent. Then convert biased
-- value to integer value.
SR : Float_Rep;
-- Float_Rep representation of significant of X.all
@ -843,8 +868,8 @@ package body System.Fat_Gen is
begin
if T'Denorm then
-- All denormalized numbers are valid, so only invalid numbers
-- are overflows and NaN's, both with exponent = Emax + 1.
-- All denormalized numbers are valid, so only invalid numbers are
-- overflows and NaN's, both with exponent = Emax + 1.
return E /= IEEE_Emax + 1;

13
gcc/ada/s-fatgen.ads
View File

@ -71,6 +71,8 @@ package System.Fat_Gen is
function Machine (X : T) return T;
function Machine_Rounding (X : T) return T;
function Model (X : T) return T;
function Pred (X : T) return T;
@ -95,6 +97,8 @@ package System.Fat_Gen is
-- register, and the whole point of 'Valid is to prevent exceptions.
-- Note that the object of type T must have the natural alignment
-- for type T. See Unaligned_Valid for further discussion.
--
-- Note: this routine does not work for Vax_Float ???
function Unaligned_Valid (A : System.Address) return Boolean;
-- This version of Valid is used if the floating-point value to
@ -112,11 +116,16 @@ package System.Fat_Gen is
-- not require strict alignment (e.g. the ia32/x86), since on a
-- target not requiring strict alignment, it is fine to pass a
-- non-aligned value to the standard Valid routine.
--
-- Note: this routine does not work for Vax_Float ???
private
pragma Inline (Machine);
pragma Inline (Model);
pragma Inline_Always (Valid);
pragma Inline_Always (Unaligned_Valid);
-- Note: previously the validity checking subprograms (Unaligned_Valid and
-- Valid) were also inlined, but this was changed since there were some
-- problems with this inlining in optimized mode, and in any case it seems
-- better to avoid this inlining (space and robustness considerations).
end System.Fat_Gen;

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

@ -626,7 +626,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;
@ -639,7 +639,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;
@ -652,7 +652,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;

93
gcc/ada/sem_attr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 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- --
@ -492,9 +492,16 @@ package body Sem_Attr is
-- accesses are allowed (references to the current type instance).
if Is_Entity_Name (P) then
Scop := Current_Scope;
Typ := Entity (P);
-- The reference may appear in an aggregate that has been expanded
-- into a loop. Locate scope of type definition, if any.
Scop := Current_Scope;
while Ekind (Scop) = E_Loop loop
Scop := Scope (Scop);
end loop;
if Is_Type (Typ) then
-- OK if we are within the scope of a limited type
@ -516,6 +523,7 @@ package body Sem_Attr is
loop
Q := Parent (Q);
end loop;
if Present (Q) then
Set_Has_Per_Object_Constraint (
Defining_Identifier (Q), True);
@ -585,11 +593,9 @@ package body Sem_Attr is
declare
Index : Interp_Index;
It : Interp;
begin
Set_Etype (N, Any_Type);
Get_First_Interp (P, Index, It);
while Present (It.Typ) loop
Acc_Type := Build_Access_Object_Type (It.Typ);
Add_One_Interp (N, Acc_Type, Acc_Type);
@ -1373,13 +1379,27 @@ package body Sem_Attr is
begin
Analyze (P);
-- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
-- task interface class-wide types.
if Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
and then Is_Task_Type (Designated_Type (Etype (P))))
or else (Ada_Version >= Ada_05
and then Ekind (Etype (P)) = E_Class_Wide_Type
and then Is_Interface (Etype (P))
and then Is_Task_Interface (Etype (P)))
then
Resolve (P);
else
Error_Attr ("prefix of % attribute must be a task", P);
if Ada_Version >= Ada_05 then
Error_Attr ("prefix of % attribute must be a task or a task "
& "interface class-wide object", P);
else
Error_Attr ("prefix of % attribute must be a task", P);
end if;
end if;
end Check_Task_Prefix;
@ -2793,16 +2813,28 @@ package body Sem_Attr is
if Etype (P) = Standard_Exception_Type then
Set_Etype (N, RTE (RE_Exception_Id));
-- Ada 2005 (AI-345): Attribute 'Identity may be applied to
-- task interface class-wide types.
elsif Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
and then Is_Task_Type (Designated_Type (Etype (P))))
or else (Ada_Version >= Ada_05
and then Ekind (Etype (P)) = E_Class_Wide_Type
and then Is_Interface (Etype (P))
and then Is_Task_Interface (Etype (P)))
then
Resolve (P);
Set_Etype (N, RTE (RO_AT_Task_Id));
else
Error_Attr ("prefix of % attribute must be a task or an "
& "exception", P);
if Ada_Version >= Ada_05 then
Error_Attr ("prefix of % attribute must be an exception, a "
& "task or a task interface class-wide object", P);
else
Error_Attr ("prefix of % attribute must be a task or an "
& "exception", P);
end if;
end if;
-----------
@ -2962,6 +2994,15 @@ package body Sem_Attr is
Check_E0;
Set_Etype (N, Universal_Integer);
----------------------
-- Machine_Rounding --
----------------------
when Attribute_Machine_Rounding =>
Check_Floating_Point_Type_1;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
--------------------
-- Machine_Rounds --
--------------------
@ -5481,6 +5522,20 @@ package body Sem_Attr is
Fold_Uint (N, Uint_2, True);
end if;
----------------------
-- Machine_Rounding --
----------------------
-- Note: for the folding case, it is fine to treat Machine_Rounding
-- exactly the same way as Rounding, since this is one of the allowed
-- behaviors, and performance is not an issue here. It might be a bit
-- better to give the same result as it would give at run-time, even
-- though the non-determinism is certainly permitted.
when Attribute_Machine_Rounding =>
Fold_Ureal (N,
Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
--------------------
-- Machine_Rounds --
--------------------
@ -6243,7 +6298,6 @@ package body Sem_Attr is
end if;
Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
end Type_Class;
-----------------------
@ -7685,12 +7739,19 @@ package body Sem_Attr is
return True;
end if;
if Nam = TSS_Stream_Input then
return Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Read);
elsif Nam = TSS_Stream_Output then
return Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Write);
-- In Ada 2005, Input can invoke Read, and Output can invoke Write
if Nam = TSS_Stream_Input
and then Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
then
return True;
elsif Nam = TSS_Stream_Output
and then Ada_Version >= Ada_05
and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
then
return True;
end if;
-- Case of Read and Write: check for attribute definition clause that

171
gcc/ada/snames.h
View File

@ -95,91 +95,92 @@ extern unsigned char Get_Attribute_Id (int);
#define Attr_Machine_Mantissa 47
#define Attr_Machine_Overflows 48
#define Attr_Machine_Radix 49
#define Attr_Machine_Rounds 50
#define Attr_Machine_Size 51
#define Attr_Mantissa 52
#define Attr_Max_Size_In_Storage_Elements 53
#define Attr_Maximum_Alignment 54
#define Attr_Mechanism_Code 55
#define Attr_Mod 56
#define Attr_Model_Emin 57
#define Attr_Model_Epsilon 58
#define Attr_Model_Mantissa 59
#define Attr_Model_Small 60
#define Attr_Modulus 61
#define Attr_Null_Parameter 62
#define Attr_Object_Size 63
#define Attr_Partition_ID 64
#define Attr_Passed_By_Reference 65
#define Attr_Pool_Address 66
#define Attr_Pos 67
#define Attr_Position 68
#define Attr_Range 69
#define Attr_Range_Length 70
#define Attr_Round 71
#define Attr_Safe_Emax 72
#define Attr_Safe_First 73
#define Attr_Safe_Large 74
#define Attr_Safe_Last 75
#define Attr_Safe_Small 76
#define Attr_Scale 77
#define Attr_Scaling 78
#define Attr_Signed_Zeros 79
#define Attr_Size 80
#define Attr_Small 81
#define Attr_Storage_Size 82
#define Attr_Storage_Unit 83
#define Attr_Stream_Size 84
#define Attr_Tag 85
#define Attr_Target_Name 86
#define Attr_Terminated 87
#define Attr_To_Address 88
#define Attr_Type_Class 89
#define Attr_UET_Address 90
#define Attr_Unbiased_Rounding 91
#define Attr_Unchecked_Access 92
#define Attr_Unconstrained_Array 93
#define Attr_Universal_Literal_String 94
#define Attr_Unrestricted_Access 95
#define Attr_VADS_Size 96
#define Attr_Val 97
#define Attr_Valid 98
#define Attr_Value_Size 99
#define Attr_Version 100
#define Attr_Wchar_T_Size 101
#define Attr_Wide_Wide_Width 102
#define Attr_Wide_Width 103
#define Attr_Width 104
#define Attr_Word_Size 105
#define Attr_Adjacent 106
#define Attr_Ceiling 107
#define Attr_Copy_Sign 108
#define Attr_Floor 109
#define Attr_Fraction 110
#define Attr_Image 111
#define Attr_Input 112
#define Attr_Machine 113
#define Attr_Max 114
#define Attr_Min 115
#define Attr_Model 116
#define Attr_Pred 117
#define Attr_Remainder 118
#define Attr_Rounding 119
#define Attr_Succ 120
#define Attr_Truncation 121
#define Attr_Value 122
#define Attr_Wide_Image 123
#define Attr_Wide_Wide_Image 124
#define Attr_Wide_Value 125
#define Attr_Wide_Wide_Value 126
#define Attr_Output 127
#define Attr_Read 128
#define Attr_Write 129
#define Attr_Elab_Body 130
#define Attr_Elab_Spec 131
#define Attr_Storage_Pool 132
#define Attr_Base 133
#define Attr_Class 134
#define Attr_Machine_Rounding 50
#define Attr_Machine_Rounds 51
#define Attr_Machine_Size 52
#define Attr_Mantissa 53
#define Attr_Max_Size_In_Storage_Elements 54
#define Attr_Maximum_Alignment 55
#define Attr_Mechanism_Code 56
#define Attr_Mod 57
#define Attr_Model_Emin 58
#define Attr_Model_Epsilon 59
#define Attr_Model_Mantissa 60
#define Attr_Model_Small 61
#define Attr_Modulus 62
#define Attr_Null_Parameter 63
#define Attr_Object_Size 64
#define Attr_Partition_ID 65
#define Attr_Passed_By_Reference 66
#define Attr_Pool_Address 67
#define Attr_Pos 68
#define Attr_Position 69
#define Attr_Range 70
#define Attr_Range_Length 71
#define Attr_Round 72
#define Attr_Safe_Emax 73
#define Attr_Safe_First 74
#define Attr_Safe_Large 75
#define Attr_Safe_Last 76
#define Attr_Safe_Small 77
#define Attr_Scale 78
#define Attr_Scaling 79
#define Attr_Signed_Zeros 80
#define Attr_Size 81
#define Attr_Small 82
#define Attr_Storage_Size 83
#define Attr_Storage_Unit 84
#define Attr_Stream_Size 85
#define Attr_Tag 86
#define Attr_Target_Name 87
#define Attr_Terminated 88
#define Attr_To_Address 89
#define Attr_Type_Class 90
#define Attr_UET_Address 91
#define Attr_Unbiased_Rounding 92
#define Attr_Unchecked_Access 93
#define Attr_Unconstrained_Array 94
#define Attr_Universal_Literal_String 95
#define Attr_Unrestricted_Access 96
#define Attr_VADS_Size 97
#define Attr_Val 98
#define Attr_Valid 99
#define Attr_Value_Size 100
#define Attr_Version 101
#define Attr_Wchar_T_Size 102
#define Attr_Wide_Wide_Width 103
#define Attr_Wide_Width 104
#define Attr_Width 105
#define Attr_Word_Size 106
#define Attr_Adjacent 107
#define Attr_Ceiling 108
#define Attr_Copy_Sign 109
#define Attr_Floor 110
#define Attr_Fraction 111
#define Attr_Image 112
#define Attr_Input 113
#define Attr_Machine 114
#define Attr_Max 115
#define Attr_Min 116
#define Attr_Model 117
#define Attr_Pred 118
#define Attr_Remainder 119
#define Attr_Rounding 120
#define Attr_Succ 121
#define Attr_Truncation 122
#define Attr_Value 123
#define Attr_Wide_Image 124
#define Attr_Wide_Wide_Image 125
#define Attr_Wide_Value 126
#define Attr_Wide_Wide_Value 127
#define Attr_Output 128
#define Attr_Read 129
#define Attr_Write 130
#define Attr_Elab_Body 131
#define Attr_Elab_Spec 132
#define Attr_Storage_Pool 133
#define Attr_Base 134
#define Attr_Class 135
/* Define the numeric values for the conventions. */