[Ada] Propagate bit order and SSO from root to classwide equivalent type

2018-09-26  Thomas Quinot  <quinot@adacore.com>

gcc/ada/

	* exp_util.adb (Make_CW_Equivalent_Type): Propagate bit order
	and scalar storage order from root type to classwide equivalent
	type, to prevent rejection of the equivalent type by the
	freezing circuitry.

gcc/testsuite/

	* gnat.dg/sso12.adb: New testcase.

From-SVN: r264613

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4ab1bcd54aaff971cad222f9d8857815fba10e18..94f90d3c6ec4c204b7e1f4fdd6d719ce9dd24506 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-09-26  Thomas Quinot  <quinot@adacore.com>
+
+       * exp_util.adb (Make_CW_Equivalent_Type): Propagate bit order
+       and scalar storage order from root type to classwide equivalent
+       type, to prevent rejection of the equivalent type by the
+       freezing circuitry.
+
 2018-09-26  Justin Squirek  <squirek@adacore.com>
 
        * sem_ch5.adb (Analyze_Iterator_Specification): Add conditional

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 314e3ee97cd1e353c351b18ea0b6e9b0cce62985..31e36ee84d2b05f18d4ad166cb307b199a9c4de4 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -9004,12 +9004,17 @@ package body Exp_Util is
    --  Generate the following code:
 
    --   type Equiv_T is record
-   --     _parent :  T (List of discriminant constraints taken from Exp);
+   --     _parent : T (List of discriminant constraints taken from Exp);
    --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
    --   end Equiv_T;
    --
-   --   ??? Note that this type does not guarantee same alignment as all
-   --   derived types
+   --  ??? Note that this type does not guarantee same alignment as all
+   --  derived types
+   --
+   --  Note: for the freezing circuitry, this looks like a record extension,
+   --  and so we need to make sure that the scalar storage order is the same
+   --  as that of the parent type. (This does not change anything for the
+   --  representation of the extension part.)
 
    function Make_CW_Equivalent_Type
      (T : Entity_Id;
@@ -9017,6 +9022,7 @@ package body Exp_Util is
    is
       Loc         : constant Source_Ptr := Sloc (E);
       Root_Typ    : constant Entity_Id  := Root_Type (T);
+      Root_Utyp   : constant Entity_Id  := Underlying_Type (Root_Typ);
       List_Def    : constant List_Id    := Empty_List;
       Comp_List   : constant List_Id    := New_List;
       Equiv_Type  : Entity_Id;
@@ -9147,6 +9153,11 @@ package body Exp_Util is
                Make_Component_Definition (Loc,
                  Aliased_Present    => False,
                  Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
+
+         Set_Reverse_Storage_Order (Equiv_Type,
+           Reverse_Storage_Order (Base_Type (Root_Utyp)));
+         Set_Reverse_Bit_Order (Equiv_Type,
+           Reverse_Bit_Order (Base_Type (Root_Utyp)));
       end if;
 
       Append_To (Comp_List,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f8591aa6db977b546d41af2fc2d2a3a585e74f46..5e7a15dde28f648bcad27ca19e66180f953fe919 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-09-26  Thomas Quinot  <quinot@adacore.com>
+
+       * gnat.dg/sso12.adb: New testcase.
+
 2018-09-26  Justin Squirek  <squirek@adacore.com>
 
        * gnat.dg/expr_func8.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/sso12.adb b/gcc/testsuite/gnat.dg/sso12.adb
new file mode 100644 (file)
index 0000000..c36b1e3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/sso12.adb
@@ -0,0 +1,17 @@
+-- { dg-do compile }
+
+with Ada.Unchecked_Deallocation;
+with System;
+
+procedure SSO12 is
+   type Rec is abstract tagged null record;
+   for Rec'Scalar_Storage_Order use System.High_Order_First;  --  { dg-warning "scalar storage order specified but no component clause" }
+   for Rec'Bit_Order use System.High_Order_First;
+
+   type Rec_Acc is access all Rec'Class;
+
+   procedure Free is new Ada.Unchecked_Deallocation (Rec'Class, Rec_Acc);
+   X : Rec_Acc;
+begin
+   Free (X);
+end SSO12;