-- --
-- 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- --
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
-- 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;
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
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
-- 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),
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);
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;
-----------------------------
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;
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;
----------------------------------
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;
-- 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.
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))))));
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 --
------------------
end if;
- Analyze_And_Resolve (N, Btyp, All_Checks);
+ Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
end Mod_Case;
-----------
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
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))
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;
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)));
----------------------
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 --
-------------------------
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 --
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).
+ -- Non VAX float case
- 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)));
+ else
+ 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).
+ -- 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, Rtp, Name_Valid,
- New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Unchecked_Convert_To (Rtp, Pref),
- Attribute_Name => Name_Unrestricted_Access)));
+ 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
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 --
----------------------------
begin
if Towards = X then
return X;
-
elsif Towards > X then
return Succ (X);
-
else
return Pred (X);
end if;
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;
-- 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;
Ax : T := abs X;
Ex : UI := 0;
- -- Ax * Rad ** Ex is invariant.
+ -- Ax * Rad ** Ex is invariant
begin
if Ax >= 1.0 then
function Exponent (X : T) return UI is
X_Frac : T;
X_Exp : UI;
-
begin
Decompose (X, X_Frac, X_Exp);
return X_Exp;
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;
function Fraction (X : T) return T is
X_Frac : T;
X_Exp : UI;
-
begin
Decompose (X, X_Frac, X_Exp);
return X_Frac;
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 --
-----------
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;
end if;
-- 0 <= Ex < Log_Power (N)
+
end loop;
-- Ex = 0
-- 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)
return X;
end if;
end if;
-
end Truncation;
-----------------------
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;
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:
-- - 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;
(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;
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);
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
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;
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;
-- 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
-- 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;
-- 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;
-- 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;
-- 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;
-- --
-- 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- --
-- 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
loop
Q := Parent (Q);
end loop;
+
if Present (Q) then
Set_Has_Per_Object_Constraint (
Defining_Identifier (Q), True);
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);
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;
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;
-----------
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 --
--------------------
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 --
--------------------
end if;
Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
-
end Type_Class;
-----------------------
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
#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. */
projects / thirdparty / gcc.git / commitdiff
