Commit b545a0f6 by Javier Miranda Committed by Arnaud Charlet

exp_intr.adb (Expand_Unc_Deallocation): Add missing support for deallocation of…

exp_intr.adb (Expand_Unc_Deallocation): Add missing support for deallocation of class-wide interface objects.

2007-04-20  Javier Miranda  <miranda@adacore.com>

	* exp_intr.adb (Expand_Unc_Deallocation): Add missing support for
	deallocation of class-wide interface objects.
	(Expand_Dispatching_Constructor_Call): Take into account that if the
	result of the dispatching constructor is an interface type, the
	function returns a class-wide interface type; otherwise the returned
	object would be actual. The frontend previously accepted returning
	interface types because Expand_Interface_Actuals silently performed
	the management of the returned type "as if" it were a class-wide
	interface type.
	(Expand_Dispatching_Constructor_Call): Replace call to
	Make_DT_Access_Action by direct call to Make_Function_Call.

From-SVN: r125406
parent cde4a4b1
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -34,7 +34,6 @@ with Exp_Ch4; use Exp_Ch4; ...@@ -34,7 +34,6 @@ with Exp_Ch4; use Exp_Ch4;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11; with Exp_Ch11; use Exp_Ch11;
with Exp_Code; use Exp_Code; with Exp_Code; use Exp_Code;
with Exp_Disp; use Exp_Disp;
with Exp_Fixd; use Exp_Fixd; with Exp_Fixd; use Exp_Fixd;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Freeze; use Freeze; with Freeze; use Freeze;
...@@ -155,6 +154,14 @@ package body Exp_Intr is ...@@ -155,6 +154,14 @@ package body Exp_Intr is
Act_Constr := Entity (Name (Act_Rename)); Act_Constr := Entity (Name (Act_Rename));
Result_Typ := Class_Wide_Type (Etype (Act_Constr)); Result_Typ := Class_Wide_Type (Etype (Act_Constr));
-- Ada 2005 (AI-251): If the result is an interface type, the function
-- returns a class-wide interface type (otherwise the resulting object
-- would be abstract!)
if Is_Interface (Etype (Act_Constr)) then
Set_Etype (Act_Constr, Result_Typ);
end if;
-- Create the call to the actual Constructor function -- Create the call to the actual Constructor function
Cnstr_Call := Cnstr_Call :=
...@@ -215,9 +222,9 @@ package body Exp_Intr is ...@@ -215,9 +222,9 @@ package body Exp_Intr is
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Condition =>
Make_Op_Not (Loc, Make_Op_Not (Loc,
Make_DT_Access_Action (Result_Typ, Make_Function_Call (Loc,
Action => IW_Membership, Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
Args => New_List ( Parameter_Associations => New_List (
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr (Tag_Arg), Prefix => Duplicate_Subexpr (Tag_Arg),
Attribute_Name => Name_Address), Attribute_Name => Name_Address),
...@@ -984,7 +991,27 @@ package body Exp_Intr is ...@@ -984,7 +991,27 @@ package body Exp_Intr is
end if; end if;
end if; end if;
Set_Expression (Free_Node, Free_Arg); -- Ada 2005 (AI-251): In case of abstract interface type we must
-- displace the pointer to reference the base of the object to
-- deallocate its memory.
-- Generate:
-- free (Base_Address (Obj_Ptr))
if Is_Interface (Directly_Designated_Type (Typ)) then
Set_Expression (Free_Node,
Unchecked_Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
-- Generate:
-- free (Obj_Ptr)
else
Set_Expression (Free_Node, Free_Arg);
end if;
-- Only remaining step is to set result to null, or generate a -- Only remaining step is to set result to null, or generate a
-- raise of constraint error if the target object is "not null". -- raise of constraint error if the target object is "not null".
......
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