mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-21 23:30:59 +08:00
Code Issues Packages Projects Releases Wiki Activity

exp_util.adb (Make_CW_Equivalent_Type): Set the Is_Class_Wide_Equivalent_Type flag here in lieu of...

Browse Source 
* 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
This commit is contained in:
Eric Botcazou 2009-12-03 15:10:58 +00:00
parent cf9eb56580
commit 80fa46179c
9 changed files with 98 additions and 19 deletions

10
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

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

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

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

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

5
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

9
gcc/testsuite/gnat.dg/controlled5.adb Normal file

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

18
gcc/testsuite/gnat.dg/controlled5_pkg.adb Normal file

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

19
gcc/testsuite/gnat.dg/controlled5_pkg.ads Normal file

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