2014-11-20 Robert Dewar <dewar@adacore.com>

	* inline.adb, sem_util.adb: Minor reformatting.

2014-11-20  Pierre-Marie Derodat  <derodat@adacore.com>

	* uintp.h (UI_Eq): Declare.
	* urealp.h (Norm_Den): Declare.
	(Norm_Num): Declare.
	* exp_dbug.adb (Is_Handled_Scale_Factor): New.
	(Get_Encoded_Name): Do not output ___XF GNAT encodings
	for fixed-point types when these can be handled by GCC's DWARF
	back-end.

2014-11-20  Thomas Quinot  <quinot@adacore.com>

	* sem_ch13.db (Inherit_Aspects_At_Freeze_Point): Inherit parent
	SSO even if set through a pragma Default_Scalar_Storage_Order.
	* freeze.adb (Set_SSO_From_Default): For a type extension,
	do not let the default SSO override the parent SSO.
	* gnat_rm.texi: document the above



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

9 files changed, 132 insertions, 48 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e43c701f2eb..826d174b81a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,27 @@
 2014-11-20  Robert Dewar  <dewar@adacore.com>
 
+	* inline.adb, sem_util.adb: Minor reformatting.
+
+2014-11-20  Pierre-Marie Derodat  <derodat@adacore.com>
+
+	* uintp.h (UI_Eq): Declare.
+	* urealp.h (Norm_Den): Declare.
+	(Norm_Num): Declare.
+	* exp_dbug.adb (Is_Handled_Scale_Factor): New.
+	(Get_Encoded_Name): Do not output ___XF GNAT encodings
+	for fixed-point types when these can be handled by GCC's DWARF
+	back-end.
+
+2014-11-20  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_ch13.db (Inherit_Aspects_At_Freeze_Point): Inherit parent
+	SSO even if set through a pragma Default_Scalar_Storage_Order.
+	* freeze.adb (Set_SSO_From_Default): For a type extension,
+	do not let the default SSO override the parent SSO.
+	* gnat_rm.texi: document the above
+
+2014-11-20  Robert Dewar  <dewar@adacore.com>
+
 	* a-stream.ads, a-reatim.ads, a-calend.ads, sinfo.ads, s-crtl.ads,
 	interfac.ads, s-taskin.ads: Minor reformatting.
 
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index 0d30f421e5b..fde8c78ac43 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -133,6 +133,10 @@ package body Exp_Dbug is
    --  Determine whether the bounds of E match the size of the type. This is
    --  used to determine whether encoding is required for a discrete type.
 
+   function Is_Handled_Scale_Factor (U : Ureal) return Boolean;
+   --  Determine whether the back-end can handle some scale factor. When it
+   --  cannot, we have to output a GNAT encoding for the correspondig type.
+
    procedure Output_Homonym_Numbers_Suffix;
    --  If homonym numbers are stored, then output them into Name_Buffer
 
@@ -535,6 +539,27 @@ package body Exp_Dbug is
          return Make_Null_Statement (Loc);
    end Debug_Renaming_Declaration;
 
+   -----------------------------
+   -- Is_Handled_Scale_Factor --
+   -----------------------------
+
+   function Is_Handled_Scale_Factor (U : Ureal) return Boolean is
+   begin
+      --  Keep in sync with gigi (see E_*_Fixed_Point_Type handling in
+      --  decl.c:gnat_to_gnu_entity).
+      if UI_Eq (Numerator (U), Uint_1) then
+         if Rbase (U) = 2
+            or else Rbase (U) = 10
+         then
+            return True;
+         end if;
+      end if;
+
+      return
+        (UI_Is_In_Int_Range (Norm_Num (U))
+         and then UI_Is_In_Int_Range (Norm_Den (U)));
+   end Is_Handled_Scale_Factor;
+
    ----------------------
    -- Get_Encoded_Name --
    ----------------------
@@ -593,9 +618,14 @@ package body Exp_Dbug is
 
       Has_Suffix := True;
 
-      --  Fixed-point case
+      --  Fixed-point case: generate GNAT encodings when asked to or when we
+      --  know the back-end will not be able to handle the scale factor.
 
-      if Is_Fixed_Point_Type (E) then
+      if Is_Fixed_Point_Type (E)
+           and then
+         (GNAT_Encodings /= DWARF_GNAT_Encodings_Minimal
+            or else not Is_Handled_Scale_Factor (Small_Value (E)))
+      then
          Get_External_Name (E, True, "XF_");
          Add_Real_To_Buffer (Delta_Value (E));
 
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 85a9cbc5743..6d366f050f9 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -7695,8 +7695,17 @@ package body Freeze is
 
    procedure Set_SSO_From_Default (T : Entity_Id) is
    begin
-      if (Is_Record_Type (T) or else Is_Array_Type (T))
-        and then Is_Base_Type (T)
+      --  Set default SSO for an array or record base type, except in the case
+      --  of a type extension (which always inherits the SSO of its parent
+      --  type).
+
+      if Is_Base_Type (T)
+        and then (Is_Array_Type (T)
+                    or else
+                  (Is_Record_Type (T)
+                     and then not (Is_Tagged_Type (T)
+                                     and then
+                                   Is_Derived_Type (T))))
       then
          if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
                or else
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index e0f6b3fcf3b..0320a0b46d0 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -2552,10 +2552,12 @@ pragma Default_Scalar_Storage_Order (High_Order_First | Low_Order_First);
 
 @noindent
 Normally if no explicit @code{Scalar_Storage_Order} is given for a record
-type or array type, then the scalar storage order defaults to the ordinary
-default for the target. But this default may be overridden using this pragma.
-The pragma may appear as a configuration pragma, or locally within a package
-spec or declarative part. In the latter case, it applies to all subsequent
+type or array type, then the scalar storage order defaults to the native
+order for the target. However, this default may be overridden using
+this pragma (except for derived tagged types, which always default to
+inheriting the scalar storage order of their parent). The pragma may
+appear as a configuration pragma, or locally within a package spec or
+declarative part.  In the latter case, it applies to all subsequent
 types declared within that package spec or declarative part.
 
 If this pragma is used as a configuration pragma which appears within a
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index 9e97e8305fe..d5e9ae99e8d 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -1655,8 +1655,7 @@ package body Inline is
             Body_To_Inline := Copy_Separate_Tree (N);
          end if;
 
-         --  Remove all aspects/pragmas that have no meaining in an inlined
-         --  body.
+         --  Remove all aspects/pragmas that have no meaning in an inlined body
 
          Remove_Aspects_And_Pragmas (Body_To_Inline);
 
@@ -3938,25 +3937,6 @@ package body Inline is
       Append_New_Elmt (N, To => Backend_Calls);
    end Register_Backend_Call;
 
-   --------------------------
-   -- Remove_Dead_Instance --
-   --------------------------
-
-   procedure Remove_Dead_Instance (N : Node_Id) is
-      J : Int;
-
-   begin
-      J := 0;
-      while J <= Pending_Instantiations.Last loop
-         if Pending_Instantiations.Table (J).Inst_Node = N then
-            Pending_Instantiations.Table (J).Inst_Node := Empty;
-            return;
-         end if;
-
-         J := J + 1;
-      end loop;
-   end Remove_Dead_Instance;
-
    --------------------------------
    -- Remove_Aspects_And_Pragmas --
    --------------------------------
@@ -4016,4 +3996,23 @@ package body Inline is
       Remove_Items (Declarations          (Body_Decl));
    end Remove_Aspects_And_Pragmas;
 
+   --------------------------
+   -- Remove_Dead_Instance --
+   --------------------------
+
+   procedure Remove_Dead_Instance (N : Node_Id) is
+      J : Int;
+
+   begin
+      J := 0;
+      while J <= Pending_Instantiations.Last loop
+         if Pending_Instantiations.Table (J).Inst_Node = N then
+            Pending_Instantiations.Table (J).Inst_Node := Empty;
+            return;
+         end if;
+
+         J := J + 1;
+      end loop;
+   end Remove_Dead_Instance;
+
 end Inline;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 2ca48ef46dd..9c119a35f8b 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3035,7 +3035,8 @@ package body Sem_Ch13 is
                         --  evaluation of this aspect should be delayed to the
                         --  freeze point (why???)
 
-                        if No (Expr) or else Is_True (Static_Boolean (Expr))
+                        if No (Expr)
+                          or else Is_True (Static_Boolean (Expr))
                         then
                            Set_Uses_Lock_Free (E);
                         end if;
@@ -3725,8 +3726,7 @@ package body Sem_Ch13 is
                end if;
             end if;
 
-            if not Check_Primitive_Function (Subp)
-            then
+            if not Check_Primitive_Function (Subp) then
                Illegal_Indexing
                  ("Indexing aspect requires a function that applies to type&");
                return;
@@ -3798,7 +3798,8 @@ package body Sem_Ch13 is
                      ("variable indexing must return a reference type");
                   return;
 
-               elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
+               elsif Is_Access_Constant
+                       (Etype (First_Discriminant (Ret_Type)))
                then
                   Illegal_Indexing
                     ("variable indexing must return an access to variable");
@@ -10882,7 +10883,7 @@ package body Sem_Ch13 is
                Set_Has_Volatile_Components (Imp_Bas_Typ);
             end if;
 
-            --  Finalize_Storage_Only.
+            --  Finalize_Storage_Only
 
             if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
               and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
@@ -10900,12 +10901,9 @@ package body Sem_Ch13 is
                Set_Universal_Aliasing (Imp_Bas_Typ);
             end if;
 
-            --  Record type specific aspects
+            --  Bit_Order
 
             if Is_Record_Type (Typ) then
-
-               --  Bit_Order
-
                if not Has_Rep_Item (Typ, Name_Bit_Order, False)
                  and then Has_Rep_Item (Typ, Name_Bit_Order)
                then
@@ -10913,15 +10911,29 @@ package body Sem_Ch13 is
                     Reverse_Bit_Order (Entity (Name
                       (Get_Rep_Item (Typ, Name_Bit_Order)))));
                end if;
+            end if;
+
+            --  Scalar_Storage_Order (first subtypes only)
+
+            if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
+                 and then
+               Is_First_Subtype (Typ)
+            then
 
-               --  Scalar_Storage_Order
+               --  For a type extension, always inherit from parent; otherwise
+               --  inherit if no default applies. Note: we do not check for
+               --  an explicit rep item on the parent type when inheriting,
+               --  because the parent SSO may itself have been set by default.
 
                if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False)
-                 and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order)
+                 and then (Is_Tagged_Type (Bas_Typ)
+                             or else
+                           not (SSO_Set_Low_By_Default  (Bas_Typ)
+                                  or else
+                                SSO_Set_High_By_Default (Bas_Typ)))
                then
                   Set_Reverse_Storage_Order (Bas_Typ,
-                    Reverse_Storage_Order (Entity (Name
-                      (Get_Rep_Item (Typ, Name_Scalar_Storage_Order)))));
+                    Reverse_Storage_Order (First_Subtype (Etype (Bas_Typ))));
 
                   --  Clear default SSO indications, since the inherited aspect
                   --  which was set explicitly overrides the default.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index ba2135daa70..45d306600ad 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5966,10 +5966,10 @@ package body Sem_Util is
             --  no longer a source construct, but it must still be recognized.
 
             elsif Comes_From_Source (Decl)
-              or else (Nkind_In (Decl, N_Subprogram_Body,
-                                       N_Subprogram_Declaration)
-                         and then Is_Expression_Function
-                                    (Defining_Entity (Decl)))
+              or else
+                (Nkind_In (Decl, N_Subprogram_Body,
+                                 N_Subprogram_Declaration)
+                  and then Is_Expression_Function (Defining_Entity (Decl)))
             then
                exit;
             end if;
diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h
index b950a88cbfb..1f4e7a3e7bf 100644
--- a/gcc/ada/uintp.h
+++ b/gcc/ada/uintp.h
@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *            Copyright (C) 1992-2011, Free Software Foundation, Inc.       *
+ *            Copyright (C) 1992-2014, 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- *
@@ -79,6 +79,10 @@ typedef struct {const int *Array; Vector_Template *Bounds; }
 #define Vector_To_Uint uintp__vector_to_uint
 extern Uint Vector_To_Uint		(Int_Vector, Boolean);
 
+/* Compare integer values for equality.  */
+#define UI_Eq uintp__ui_eq
+extern Boolean UI_Eq			(Uint, Uint);
+
 /* Compare integer values for less than.  */
 #define UI_Lt uintp__ui_lt
 extern Boolean UI_Lt			(Uint, Uint);
diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h
index fbb87608133..b8ddc172f83 100644
--- a/gcc/ada/urealp.h
+++ b/gcc/ada/urealp.h
@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *            Copyright (C) 1992-2011, Free Software Foundation, Inc.       *
+ *            Copyright (C) 1992-2014, 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- *
@@ -41,6 +41,12 @@ extern Uint Denominator		(Ureal);
 #define Rbase urealp__rbase
 extern Nat Rbase		(Ureal);
 
+#define Norm_Den urealp__norm_den
+extern Uint Norm_Den		(Ureal);
+
+#define Norm_Num urealp__norm_num
+extern Uint Norm_Num		(Ureal);
+
 #define UR_Is_Negative urealp__ur_is_negative
 extern Boolean UR_Is_Negative	(Ureal);