[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  <ebotcazou@adacore.com>

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

5 files changed, 48 insertions, 14 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 285d7e4..662c099 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-07-17  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* 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  <bernardi@adacore.com>
 
 	* libgnat/s-memory__mingw.adb: Remove.
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 298265a..2fa990b 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 7c4189e..e24b35d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-07-17  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/sso10.adb, gnat.dg/sso10_pkg.ads: New testcase.
+
 2018-07-17  Patrick Bernardi  <bernardi@adacore.com>
 
 	* 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 0000000..5a796f2
--- /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 0000000..c1c4d5c
--- /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;