2010-06-22 Thomas Quinot <quinot@adacore.com>

	* exp_aggr.adb (Rewrite_Discriminant): Fix predicate used to identify
	reference to discriminant (can be an expanded name as well as an
	identifier).

2010-06-22  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch6.adb: Clarify comment.

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.



git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@161200 138bc75d-0d04-0410-961f-82ee72b054a4

7 files changed, 72 insertions, 30 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 373ef180b78..c8fda574cf2 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,24 @@
+2010-06-22  Thomas Quinot  <quinot@adacore.com>
+
+	* exp_aggr.adb (Rewrite_Discriminant): Fix predicate used to identify
+	reference to discriminant (can be an expanded name as well as an
+	identifier).
+
+2010-06-22  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch6.adb: Clarify comment.
+
+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.
+
 2010-06-22  Robert Dewar  <dewar@adacore.com>
 
 	* sem_ch3.adb, sem_ch8.adb: Minor reformatting.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 357d0bd9926..e57323a20b7 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -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
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 4912644575b..becf4dca179 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -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;
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 925a7041798..36045190d53 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -2427,7 +2427,7 @@ package body Exp_Aggr is
 
       function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
       begin
-         if Nkind (Expr) = N_Identifier
+         if Is_Entity_Name (Expr)
            and then Present (Entity (Expr))
            and then Ekind (Entity (Expr)) = E_In_Parameter
            and then Present (Discriminal_Link (Entity (Expr)))
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 61a180f55b2..93b884cf2f6 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -4764,8 +4764,9 @@ package body Exp_Ch6 is
 
    function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is
    begin
-      --  This function is called in some rare cases when expansion is off.
-      --  In those cases the build_in_place expansion will not take place.
+      --  This function is called from Expand_Subtype_From_Expr during
+      --  semantic analysis, even when expansion is off. In those cases
+      --  the build_in_place expansion will not take place.
 
       if not Expander_Active then
          return False;
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 1ec4727107e..9c0be21634e 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -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;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2efd558f99d..1b9fcf3ded2 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -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