From 02fd37f505a164d921432503748a6f772a8f08c5 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 17 Jul 2018 08:11:43 +0000 Subject: [PATCH] [Ada] Fix incompatibility Default_Scalar_Storage_Order/tagged types The pragma Default_Scalar_Storage_Order cannot reliably be used to set the non-default scalar storage order for a program that declares tagged types, if it also declares user-defined primitives. This is fixed by making Make_Tags use the same base array type as Make_DT and Make_Secondary_DT when accessing the array of user-defined primitives. 2018-07-17 Eric Botcazou gcc/ada/ * exp_disp.adb (Make_Tags): When the type has user-defined primitives, build the access type that is later used by Build_Get_Prim_Op_Address as pointing to a subtype of Ada.Tags.Address_Array. gcc/testsuite/ * gnat.dg/sso10.adb, gnat.dg/sso10_pkg.ads: New testcase. From-SVN: r262797 --- gcc/ada/ChangeLog | 6 ++++++ gcc/ada/exp_disp.adb | 27 +++++++++++++-------------- gcc/testsuite/ChangeLog | 4 ++++ gcc/testsuite/gnat.dg/sso10.adb | 16 ++++++++++++++++ gcc/testsuite/gnat.dg/sso10_pkg.ads | 9 +++++++++ 5 files changed, 48 insertions(+), 14 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/sso10.adb create mode 100644 gcc/testsuite/gnat.dg/sso10_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 285d7e435fc..662c099e167 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-07-17 Eric Botcazou + + * exp_disp.adb (Make_Tags): When the type has user-defined primitives, + build the access type that is later used by Build_Get_Prim_Op_Address + as pointing to a subtype of Ada.Tags.Address_Array. + 2018-07-17 Patrick Bernardi * libgnat/s-memory__mingw.adb: Remove. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 298265aa813..2fa990bc11b 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -7179,7 +7179,7 @@ package body Exp_Disp is Analyze_List (Result); -- Generate: - -- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr; + -- subtype Typ_DT is Address_Array (1 .. Nb_Prims); -- type Typ_DT_Acc is access Typ_DT; else @@ -7196,20 +7196,19 @@ package body Exp_Disp is Name_DT_Prims_Acc); begin Append_To (Result, - Make_Full_Type_Declaration (Loc, + Make_Subtype_Declaration (Loc, Defining_Identifier => DT_Prims, - Type_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => Make_Integer_Literal (Loc, - DT_Entry_Count - (First_Tag_Component (Typ))))), - Component_Definition => - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc))))); + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Address_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, + DT_Entry_Count + (First_Tag_Component (Typ))))))))); Append_To (Result, Make_Full_Type_Declaration (Loc, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7c4189e84c8..e24b35d5d19 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-07-17 Eric Botcazou + + * gnat.dg/sso10.adb, gnat.dg/sso10_pkg.ads: New testcase. + 2018-07-17 Patrick Bernardi * gnat.dg/memorytest.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/sso10.adb b/gcc/testsuite/gnat.dg/sso10.adb new file mode 100644 index 00000000000..5a796f2d493 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sso10.adb @@ -0,0 +1,16 @@ +-- { dg-do run } + +with SSO10_Pkg; use SSO10_Pkg; + +procedure SSO10 is + + procedure Inner (R : Root'Class) is + begin + Run (R); + end; + + R : Root; + +begin + Inner (R); +end; diff --git a/gcc/testsuite/gnat.dg/sso10_pkg.ads b/gcc/testsuite/gnat.dg/sso10_pkg.ads new file mode 100644 index 00000000000..c1c4d5cfe41 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sso10_pkg.ads @@ -0,0 +1,9 @@ +pragma Default_Scalar_Storage_Order (High_Order_First); + +package SSO10_Pkg is + + type Root is tagged null record; + + procedure Run (R : Root) is null; + +end SSO10_Pkg; -- 2.30.2