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

9 files changed, 98 insertions, 19 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4c92845..620b287d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2009-12-03  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* 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  <obry@adacore.com>
 
 	* 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 f61a4a5..9420558 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 564c11b..c450b67 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 7f0f786..26b821d 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 1845e80..f0463aa 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 550c136..24b38d2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-12-03  Quentin Ochem  <ochem@adacore.com>
+
+	* gnat.dg/controlled5.adb: New test.
+	* gnat.dg/controlled5_pkg.ad[sb]: New helper.
+
 2009-12-03  Dodji Seketeli  <dodji@redhat.com>
 
 	PR c++/42217
diff --git a/gcc/testsuite/gnat.dg/controlled5.adb b/gcc/testsuite/gnat.dg/controlled5.adb
new file mode 100644
index 0000000..4c54249
--- /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 0000000..828f9ef
--- /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 0000000..5372039
--- /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;