The code generated by the compiler to handle the initialization of
limited class-wide interface objects initialized by means of an
aggregate erroneously generates a copy of the object (which causes
a runtime exception in the application). After this patch the
following test compiles and executes well.
with Ada.Finalization; use Ada.Finalization;
package Types is
type Iface is limited interface;
type User is new Limited_Controlled and Iface with record
X : Integer := 0;
end record;
overriding
procedure Finalize (Obj : in out User);
end Types;
with GNAT.IO; use GNAT.IO;
package body Types is
overriding
procedure Finalize (Obj : in out User) is
begin
Put_Line ("Finalize");
end Finalize;
end Types;
with Ada.Finalization; use Ada.Finalization;
with Types; use Types;
with System.Address_Image; use System;
procedure Demo is
IW : Iface'Class := User'(Limited_Controlled with X => 42);
Str : constant String := Address_Image (IW'Address);
begin
pragma Assert (Str /= "");
null;
end Demo;
Command:
gnatmake -gnata demo.adb -gnat05
Output:
Finalize
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-09-02 Javier Miranda <mira...@adacore.com>
* exp_ch3.adb (Expand_N_Object_Declaration): Do not copy the
initializing expression of a class-wide interface object declaration
if its type is limited.
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 178456)
+++ exp_ch3.adb (working copy)
@@ -4841,11 +4841,11 @@
return;
-- Ada 2005 (AI-251): Rewrite the expression that initializes a
- -- class-wide object to ensure that we copy the full object,
- -- unless we are targetting a VM where interfaces are handled by
- -- VM itself. Note that if the root type of Typ is an ancestor
- -- of Expr's type, both types share the same dispatch table and
- -- there is no need to displace the pointer.
+ -- class-wide interface object to ensure that we copy the full
+ -- object, unless we are targetting a VM where interfaces are handled
+ -- by VM itself. Note that if the root type of Typ is an ancestor of
+ -- Expr's type, both types share the same dispatch table and there is
+ -- no need to displace the pointer.
elsif Comes_From_Source (N)
and then Is_Interface (Typ)
@@ -4978,14 +4978,32 @@
-- Copy the object
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Object_Definition =>
- New_Occurrence_Of
- (Etype (Object_Definition (N)), Loc),
- Expression => New_Expr));
+ if not Is_Limited_Record (Expr_Typ) then
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Object_Definition =>
+ New_Occurrence_Of
+ (Etype (Object_Definition (N)), Loc),
+ Expression => New_Expr));
+ -- Rename limited type object since they cannot be copied
+ -- This case occurs when the initialization expression
+ -- has been previously expanded into a temporary object.
+
+ else pragma Assert (not Comes_From_Source (Expr_Q));
+
+ Insert_Action (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Obj_Id,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Etype (Object_Definition (N)), Loc),
+ Name =>
+ Unchecked_Convert_To
+ (Etype (Object_Definition (N)), New_Expr)));
+ end if;
+
-- Dynamically reference the tag associated with the
-- interface.
