From patchwork Fri Sep 2 09:54:04 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 113077 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 9B99FB6F71 for ; Fri, 2 Sep 2011 19:54:26 +1000 (EST) Received: (qmail 8653 invoked by alias); 2 Sep 2011 09:54:22 -0000 Received: (qmail 8462 invoked by uid 22791); 2 Sep 2011 09:54:20 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 02 Sep 2011 09:54:05 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id C55152BAB79; Fri, 2 Sep 2011 05:54:04 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id vdN-3bWVkAI0; Fri, 2 Sep 2011 05:54:04 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id A7DD22BAB5D; Fri, 2 Sep 2011 05:54:04 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id A6C783FEE8; Fri, 2 Sep 2011 05:54:04 -0400 (EDT) Date: Fri, 2 Sep 2011 05:54:04 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Wrong initialization of limited class-wide interface objects Message-ID: <20110902095404.GA31382@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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.