Patchwork [Ada] Improve 'Image accuracy for fixed point types with decimal small

login
register
mail settings
Submitter Arnaud Charlet
Date June 22, 2010, 4:23 p.m.
Message ID <20100622162324.GA25577@adacore.com>
Download mbox | patch
Permalink /patch/56526/
State New
Headers show

Comments

Arnaud Charlet - June 22, 2010, 4:23 p.m.
While generating an image string for ordinary fixed point types
may be tricky for cases of an arbitrary small, for common cases
with decimal smalls accurate output is straightforward. This patch
detects those cases where ordinary fixed point types do in fact
have a decimal small, and reuses the 'Image code for decimal fixed
point types.

--  The following must compile and execute quietly
procedure fi2 is
begin
   if Duration'Image (Duration'Last) /= " 9223372036.854775807" then
      raise Program_Error;
   end if;
end fi2;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-22  Geert Bosch  <bosch@adacore.com>

	* exp_imgv.adb (Expand_Image_Attribute): Treat ordinary fixed point
	with decimal small as decimal types, avoiding floating-point arithmetic.
	(Has_Decimal_Small): New function.
	* einfo.ads, einfo.adb (Aft_Value): New synthesized attributed for
	fixed point types.
	* sem_attr.adb (Eval_Attribute): Remove Aft_Value function and update
	callers to call the new function in Einfo that takes the entity as
	parameter.

Patch

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