Commit 02fd37f5 by Eric Botcazou Committed by Pierre-Marie de Rodat

[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
parent c343f1dc
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> 2018-07-17 Patrick Bernardi <bernardi@adacore.com>
* libgnat/s-memory__mingw.adb: Remove. * libgnat/s-memory__mingw.adb: Remove.
......
...@@ -7179,7 +7179,7 @@ package body Exp_Disp is ...@@ -7179,7 +7179,7 @@ package body Exp_Disp is
Analyze_List (Result); Analyze_List (Result);
-- Generate: -- 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; -- type Typ_DT_Acc is access Typ_DT;
else else
...@@ -7196,20 +7196,19 @@ package body Exp_Disp is ...@@ -7196,20 +7196,19 @@ package body Exp_Disp is
Name_DT_Prims_Acc); Name_DT_Prims_Acc);
begin begin
Append_To (Result, Append_To (Result,
Make_Full_Type_Declaration (Loc, Make_Subtype_Declaration (Loc,
Defining_Identifier => DT_Prims, Defining_Identifier => DT_Prims,
Type_Definition => Subtype_Indication =>
Make_Constrained_Array_Definition (Loc, Make_Subtype_Indication (Loc,
Discrete_Subtype_Definitions => New_List ( Subtype_Mark =>
Make_Range (Loc, New_Occurrence_Of (RTE (RE_Address_Array), Loc),
Low_Bound => Make_Integer_Literal (Loc, 1), Constraint =>
High_Bound => Make_Integer_Literal (Loc, Make_Index_Or_Discriminant_Constraint (Loc, New_List (
DT_Entry_Count Make_Range (Loc,
(First_Tag_Component (Typ))))), Low_Bound => Make_Integer_Literal (Loc, 1),
Component_Definition => High_Bound => Make_Integer_Literal (Loc,
Make_Component_Definition (Loc, DT_Entry_Count
Subtype_Indication => (First_Tag_Component (Typ)))))))));
New_Occurrence_Of (RTE (RE_Prim_Ptr), Loc)))));
Append_To (Result, Append_To (Result,
Make_Full_Type_Declaration (Loc, Make_Full_Type_Declaration (Loc,
......
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> 2018-07-17 Patrick Bernardi <bernardi@adacore.com>
* gnat.dg/memorytest.adb: New testcase. * gnat.dg/memorytest.adb: New testcase.
......
-- { 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;
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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment