exp_util.adb (Make_CW_Equivalent_Type): Set the Is_Class_Wide_Equivalent_Type…

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

+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

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);
 

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);

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;

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 :=

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gnat.dg/controlled5.adb

+-- { dg-do run }
+
+with Controlled5_Pkg; use Controlled5_Pkg;
+
+procedure Controlled5 is
+   V : Root'Class := Dummy (300);
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/controlled5_pkg.adb

+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;

gcc/testsuite/gnat.dg/controlled5_pkg.ads

+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;