From 52ba224d888aead9a9f00ce04b14200f2f4ef8a5 Mon Sep 17 00:00:00 2001 From: Thomas Quinot Date: Wed, 26 Sep 2018 09:17:26 +0000 Subject: [PATCH] [Ada] Propagate bit order and SSO from root to classwide equivalent type 2018-09-26 Thomas Quinot 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 --- gcc/ada/ChangeLog | 7 +++++++ gcc/ada/exp_util.adb | 17 ++++++++++++++--- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/sso12.adb | 17 +++++++++++++++++ 4 files changed, 42 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/sso12.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ab1bcd54aa..94f90d3c6ec 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-09-26 Thomas Quinot + + * 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 * sem_ch5.adb (Analyze_Iterator_Specification): Add conditional diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 314e3ee97cd..31e36ee84d2 100644 --- 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 f8591aa6db9..5e7a15dde28 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-09-26 Thomas Quinot + + * gnat.dg/sso12.adb: New testcase. + 2018-09-26 Justin Squirek * 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 index 00000000000..c36b1e38a18 --- /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; -- 2.30.2