From 65f01153ab91c1e9e5e5273b8cb7e85e2a105b24 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 15 Nov 2005 14:56:51 +0100 Subject: [PATCH] sem_attr.adb: Implement Machine_Rounding attribute 2005-11-14 Robert Dewar Hristian Kirtchev * 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 --- gcc/ada/exp_attr.adb | 340 +++++++++++++++++++++++++-------- gcc/ada/s-fatgen.adb | 121 +++++++----- gcc/ada/s-fatgen.ads | 13 +- gcc/ada/s-vaflop-vms-alpha.adb | 6 +- gcc/ada/sem_attr.adb | 93 +++++++-- gcc/ada/snames.h | 171 ++++++++--------- 6 files changed, 514 insertions(+), 230 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b9d7ee1f1df..11bc258d86e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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 -- ---------------------------- diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index 2bdb9363bc3..9d4b5042d69 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -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; diff --git a/gcc/ada/s-fatgen.ads b/gcc/ada/s-fatgen.ads index c1bc8204058..83b6f064461 100644 --- a/gcc/ada/s-fatgen.ads +++ b/gcc/ada/s-fatgen.ads @@ -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; diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb index 45a39bba08b..5ab772d4477 100644 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -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; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1306779d12a..e0c05fd62ae 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h index 0ff742e816d..7b0c2ee5d0a 100644 --- a/gcc/ada/snames.h +++ b/gcc/ada/snames.h @@ -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. */