[Ada] Wrong initialization of limited class-wide interface objects

[Ada] Wrong initialization of limited class-wide interface objects

[Arnaud Charlet]

[-- Attachment #1: Type: text/plain, Size: 1372 bytes --]

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  <miranda@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.


[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 2920 bytes --]

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.