From 80fa46179c1975ea1c8eaabaa2ab23d4b0269357 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Thu, 3 Dec 2009 15:10:58 +0000 Subject: [PATCH] exp_util.adb (Make_CW_Equivalent_Type): Set the Is_Class_Wide_Equivalent_Type flag here in lieu of... * exp_util.adb (Make_CW_Equivalent_Type): Set the Is_Class_Wide_Equivalent_Type flag here in lieu of... (Make_Subtype_From_Expr): ...here. * exp_ch3.adb (Expand_Freeze_Record_Type): Do not set Has_Controlled_Component on class-wide equivalent types. * freeze.adb (Freeze_Record_Type): Likewise. * sem_ch3.adb (Record_Type_Definition): Likewise. From-SVN: r154950 --- gcc/ada/ChangeLog | 10 ++++++++++ gcc/ada/exp_ch3.adb | 10 +++++++--- gcc/ada/exp_util.adb | 13 ++++++++----- gcc/ada/freeze.adb | 23 +++++++++++++++-------- gcc/ada/sem_ch3.adb | 10 +++++++--- gcc/testsuite/ChangeLog | 5 +++++ gcc/testsuite/gnat.dg/controlled5.adb | 9 +++++++++ gcc/testsuite/gnat.dg/controlled5_pkg.adb | 18 ++++++++++++++++++ gcc/testsuite/gnat.dg/controlled5_pkg.ads | 19 +++++++++++++++++++ 9 files changed, 98 insertions(+), 19 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/controlled5.adb create mode 100644 gcc/testsuite/gnat.dg/controlled5_pkg.adb create mode 100644 gcc/testsuite/gnat.dg/controlled5_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4c928457077..620b287d015 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2009-12-03 Eric Botcazou + + * exp_util.adb (Make_CW_Equivalent_Type): Set the + Is_Class_Wide_Equivalent_Type flag here in lieu of... + (Make_Subtype_From_Expr): ...here. + * exp_ch3.adb (Expand_Freeze_Record_Type): Do not set + Has_Controlled_Component on class-wide equivalent types. + * freeze.adb (Freeze_Record_Type): Likewise. + * sem_ch3.adb (Record_Type_Definition): Likewise. + 2009-12-01 Pascal Obry * s-osprim-mingw.adb (Get_Base_Time): Make sure that the base time is diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f61a4a5b47b..9420558b9fd 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5715,9 +5715,13 @@ package body Exp_Ch3 is if Has_Task (Comp_Typ) then Set_Has_Task (Def_Id); - elsif Has_Controlled_Component (Comp_Typ) - or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Comp_Typ)) + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + elsif not Is_Class_Wide_Equivalent_Type (Def_Id) + and then (Has_Controlled_Component (Comp_Typ) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Comp_Typ))) then Set_Has_Controlled_Component (Def_Id); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 564c11b6613..c450b677faf 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3811,6 +3811,14 @@ package body Exp_Util is Set_Ekind (Equiv_Type, E_Record_Type); Set_Parent_Subtype (Equiv_Type, Constr_Root); + -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special + -- treatment for this type. In particular, even though _parent's type + -- is a controlled type or contains controlled components, we do not + -- want to set Has_Controlled_Component on it to avoid making it gain + -- an unwanted _controller component. + + Set_Is_Class_Wide_Equivalent_Type (Equiv_Type); + if not Is_Interface (Root_Typ) then Append_To (Comp_List, Make_Component_Declaration (Loc, @@ -4024,11 +4032,6 @@ package body Exp_Util is CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E); Set_Equivalent_Type (CW_Subtype, EQ_Typ); - - if Present (EQ_Typ) then - Set_Is_Class_Wide_Equivalent_Type (EQ_Typ); - end if; - Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ)); return New_Occurrence_Of (CW_Subtype, Loc); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 7f0f7863824..26b821d38d1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2185,14 +2185,21 @@ package body Freeze is Comp := First_Component (Rec); while Present (Comp) loop - if Has_Controlled_Component (Etype (Comp)) - or else (Chars (Comp) /= Name_uParent - and then Is_Controlled (Etype (Comp))) - or else (Is_Protected_Type (Etype (Comp)) - and then Present - (Corresponding_Record_Type (Etype (Comp))) - and then Has_Controlled_Component - (Corresponding_Record_Type (Etype (Comp)))) + + -- Do not set Has_Controlled_Component on a class-wide + -- equivalent type. See Make_CW_Equivalent_Type. + + if not Is_Class_Wide_Equivalent_Type (Rec) + and then (Has_Controlled_Component (Etype (Comp)) + or else (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + or else (Is_Protected_Type (Etype (Comp)) + and then Present + (Corresponding_Record_Type + (Etype (Comp))) + and then Has_Controlled_Component + (Corresponding_Record_Type + (Etype (Comp))))) then Set_Has_Controlled_Component (Rec); exit; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1845e80916c..f0463aaac94 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -18028,9 +18028,13 @@ package body Sem_Ch3 is if Ekind (Component) /= E_Component then null; - elsif Has_Controlled_Component (Etype (Component)) - or else (Chars (Component) /= Name_uParent - and then Is_Controlled (Etype (Component))) + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + elsif not Is_Class_Wide_Equivalent_Type (T) + and then (Has_Controlled_Component (Etype (Component)) + or else (Chars (Component) /= Name_uParent + and then Is_Controlled (Etype (Component)))) then Set_Has_Controlled_Component (T, True); Final_Storage_Only := diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 550c1363305..24b38d2e08e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-12-03 Quentin Ochem + + * gnat.dg/controlled5.adb: New test. + * gnat.dg/controlled5_pkg.ad[sb]: New helper. + 2009-12-03 Dodji Seketeli PR c++/42217 diff --git a/gcc/testsuite/gnat.dg/controlled5.adb b/gcc/testsuite/gnat.dg/controlled5.adb new file mode 100644 index 00000000000..4c54249d439 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled5.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with Controlled5_Pkg; use Controlled5_Pkg; + +procedure Controlled5 is + V : Root'Class := Dummy (300); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/controlled5_pkg.adb b/gcc/testsuite/gnat.dg/controlled5_pkg.adb new file mode 100644 index 00000000000..828f9efec1a --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled5_pkg.adb @@ -0,0 +1,18 @@ +with Ada.Tags; + +package body Controlled5_Pkg is + + type Child is new Root with null record; + + function Dummy (I : Integer) return Root'Class is + A1 : T_Root_Class := new Child; + My_Var : Root'Class := A1.all; + begin + if I = 0 then + return My_Var; + else + return Dummy (I - 1); + end if; + end Dummy; + +end Controlled5_Pkg; diff --git a/gcc/testsuite/gnat.dg/controlled5_pkg.ads b/gcc/testsuite/gnat.dg/controlled5_pkg.ads new file mode 100644 index 00000000000..53720398753 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled5_pkg.ads @@ -0,0 +1,19 @@ +with Ada.Finalization; use Ada.Finalization; + +package Controlled5_Pkg is + + type Root is tagged private; + + type Inner is new Ada.Finalization.Controlled with null record; + + type T_Root_Class is access all Root'Class; + + function Dummy (I : Integer) return Root'Class; + +private + + type Root is tagged record + F2 : Inner; + end record; + +end Controlled5_Pkg;