Index: exp_imgv.adb =================================================================== --- exp_imgv.adb (revision 161073) +++ exp_imgv.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -43,9 +43,15 @@ with Stringt; use Stringt; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; +with Urealp; use Urealp; package body Exp_Imgv is + function Has_Decimal_Small (E : Entity_Id) return Boolean; + -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an + -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. + -- Shouldn't this be in einfo.adb or sem_aux.adb??? + ------------------------------------ -- Build_Enumeration_Image_Tables -- ------------------------------------ @@ -330,7 +336,7 @@ package body Exp_Imgv is Tent := RTE (RE_Long_Long_Unsigned); end if; - elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then Imid := RE_Image_Decimal; Tent := Standard_Integer; @@ -451,6 +457,11 @@ package body Exp_Imgv is Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Aft)); + if Has_Decimal_Small (Rtyp) then + Set_Conversion_OK (First (Arg_List)); + Set_Etype (First (Arg_List), Tent); + end if; + -- For decimal, append Scale and also set to do literal conversion elsif Is_Decimal_Fixed_Point_Type (Rtyp) then @@ -1240,4 +1251,16 @@ package body Exp_Imgv is Analyze_And_Resolve (N, Typ); end Expand_Width_Attribute; + ----------------------- + -- Has_Decimal_Small -- + ----------------------- + + function Has_Decimal_Small (E : Entity_Id) return Boolean is + begin + return Is_Decimal_Fixed_Point_Type (E) + or else + (Is_Ordinary_Fixed_Point_Type (E) + and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); + end Has_Decimal_Small; + end Exp_Imgv; Index: einfo.adb =================================================================== --- einfo.adb (revision 161181) +++ einfo.adb (working copy) @@ -570,6 +570,18 @@ package body Einfo is return Flag104 (Id); end Address_Taken; + function Aft_Value (Id : E) return U is + Result : Nat := 1; + Delta_Val : Ureal := Delta_Value (Id); + begin + while Delta_Val < Ureal_Tenth loop + Delta_Val := Delta_Val * Ureal_10; + Result := Result + 1; + end loop; + + return UI_From_Int (Result); + end Aft_Value; + function Alias (Id : E) return E is begin pragma Assert Index: einfo.ads =================================================================== --- einfo.ads (revision 161183) +++ einfo.ads (working copy) @@ -350,6 +350,10 @@ package Einfo is -- make sure that the address can be meaningfully taken, and also in -- the case of subprograms to control output of certain warnings. +-- Aft_Value (synthesized) +-- Applies to fixed and decimal types. Computes a universal integer +-- that holds value of the Aft attribute for the type. + -- Alias (Node18) -- Present in overloaded entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface @@ -4832,6 +4836,7 @@ package Einfo is -- Small_Value (Ureal21) -- Has_Machine_Radix_Clause (Flag83) -- Machine_Radix_10 (Flag84) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5114,6 +5119,7 @@ package Einfo is -- Scalar_Range (Node20) -- Small_Value (Ureal21) -- Has_Small_Clause (Flag67) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -6113,6 +6119,7 @@ package Einfo is -- so they do not correspond to defined fields in the entity itself. function Address_Clause (Id : E) return N; + function Aft_Value (Id : E) return U; function Alignment_Clause (Id : E) return N; function Base_Type (Id : E) return E; function Declaration_Node (Id : E) return N; Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 161184) +++ sem_attr.adb (working copy) @@ -4805,10 +4805,6 @@ package body Sem_Attr is -- processing, since otherwise gigi might see an attribute which it is -- unprepared to deal with. - function Aft_Value return Nat; - -- Computes Aft value for current attribute prefix (used by Aft itself - -- and also by Width for computing the Width of a fixed point type). - procedure Check_Concurrent_Discriminant (Bound : Node_Id); -- If Bound is a reference to a discriminant of a task or protected type -- occurring within the object's body, rewrite attribute reference into @@ -4880,25 +4876,6 @@ package body Sem_Attr is -- Verify that the prefix of a potentially static array attribute -- satisfies the conditions of 4.9 (14). - --------------- - -- Aft_Value -- - --------------- - - function Aft_Value return Nat is - Result : Nat; - Delta_Val : Ureal; - - begin - Result := 1; - Delta_Val := Delta_Value (P_Type); - while Delta_Val < Ureal_Tenth loop - Delta_Val := Delta_Val * Ureal_10; - Result := Result + 1; - end loop; - - return Result; - end Aft_Value; - ----------------------------------- -- Check_Concurrent_Discriminant -- ----------------------------------- @@ -5786,7 +5763,7 @@ package body Sem_Attr is --------- when Attribute_Aft => - Fold_Uint (N, UI_From_Int (Aft_Value), True); + Fold_Uint (N, Aft_Value (P_Type), True); --------------- -- Alignment -- @@ -7364,7 +7341,8 @@ package body Sem_Attr is -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) Fold_Uint - (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True); + (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), + True); end if; -- Discrete types