From patchwork Tue Jun 12 11:04:11 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 164389 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 6AACEB6FBE for ; Tue, 12 Jun 2012 21:04:30 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1340103871; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=Yvg8JXD7+LTspSKj9zCD tt/iS8o=; b=kAZtBpagfxaEUmcYJ6gnCy6z5njxGlJCef3PeXIwpaFa4S7LCXGa GJUa7KAzwNsiTjhQMKf+bfSqVN6XGbsRFQLORBlhLZa00zFYi2uuFdtXK/RX9aJC OixLRTdrY0RCYKQUjIWMz0Jj/dY0tUZVG6FJ4hAc8TPiw3idFMLnYOM= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=HsvhRZsK/29x+LakT6n/jLdYBg/jpSEMeg/WJDPP//DBCbduA0bD+nr/UFuJ0N rLfkaHNseTxyfd2G+ScOYr9J7jKFvRJLv6IhGVvWT/7Cs+Tqwm5yjwIn78qlsA9h zCprAFVZuZAaewcBXxJnJI4R0OoGCYV1hbjPbuu8ROp+M=; Received: (qmail 8434 invoked by alias); 12 Jun 2012 11:04:28 -0000 Received: (qmail 8421 invoked by uid 22791); 12 Jun 2012 11:04:27 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO 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; Tue, 12 Jun 2012 11:04:12 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 049521C6180; Tue, 12 Jun 2012 07:04:12 -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 yB+g9aQqDwd5; Tue, 12 Jun 2012 07:04:11 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id DD9EC1C6139; Tue, 12 Jun 2012 07:04:11 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id DB7223FEE8; Tue, 12 Jun 2012 07:04:11 -0400 (EDT) Date: Tue, 12 Jun 2012 07:04:11 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Object declarations and finalization of transient variables Message-ID: <20120612110411.GA27450@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 This patch adds code to recognize a scenario where an object is initialized by a sequence of nested function calls where one of them returns a controlled result. This in turn triggers the mechanism which exports such transient objects to the enclosing finalizer on the assumption that one of the calls may raise an exception. ------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Ctrl is new Controlled with null record; procedure Finalize (Obj : in out Ctrl); end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is procedure Finalize (Obj : in out Ctrl) is begin Put_Line ("Finalize"); end Finalize; end Types; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Types; use Types; procedure Main is function Return_Self (Obj : Ctrl) return Ctrl is begin return Obj; end Return_Self; function Blow_Up (Obj : Ctrl) return Boolean is begin raise Constraint_Error; return True; end Blow_Up; Obj : Ctrl; begin Put_Line ("Main"); declare Flag : constant Boolean := Blow_Up (Return_Self (Obj)); begin null; end; Put_Line ("End"); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnat05 main.adb $ ./main $ Main $ Finalize $ Finalize $ $ raised CONSTRAINT_ERROR : main.adb:12 explicit raise Tested on x86_64-pc-linux-gnu, committed on trunk 2012-06-12 Hristian Kirtchev * exp_ch7.adb (Process_Transient_Objects): Renamed constant Requires_Hooking to Must_Hook and replace all occurrences of the name. (Requires_Hooking): New routine. Detect all contexts that require transient variable export to the outer finalizer due to a potential exception. Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 188438) +++ exp_ch7.adb (working copy) @@ -4327,10 +4327,47 @@ Last_Object : Node_Id; Related_Node : Node_Id) is - Requires_Hooking : constant Boolean := - Nkind_In (N, N_Function_Call, - N_Procedure_Call_Statement); + function Requires_Hooking return Boolean; + -- Determine whether the context requires transient variable export + -- to the outer finalizer. This scenario arises when the context may + -- raise an exception. + ---------------------- + -- Requires_Hooking -- + ---------------------- + + function Requires_Hooking return Boolean is + function Is_Subprogram_Call (Nod : Node_Id) return Boolean; + -- Determine whether a particular node is a procedure of function + -- call. + + ------------------------ + -- Is_Subprogram_Call -- + ------------------------ + + function Is_Subprogram_Call (Nod : Node_Id) return Boolean is + begin + return + Nkind_In (Nod, N_Function_Call, N_Procedure_Call_Statement); + end Is_Subprogram_Call; + + -- Start of processing for Requires_Hooking + + begin + -- The context is either a procedure or function call or an object + -- declaration initialized by such a call. In all these cases, the + -- calls are assumed to raise an exception. + + return + Is_Subprogram_Call (N) + or else + (Nkind (N) = N_Object_Declaration + and then Is_Subprogram_Call (Expression (N))); + end Requires_Hooking; + + -- Local variables + + Must_Hook : constant Boolean := Requires_Hooking; Built : Boolean := False; Desig_Typ : Entity_Id; Fin_Block : Node_Id; @@ -4395,7 +4432,7 @@ -- enclosing sequence of statements where their corresponding -- "hooks" are picked up by the finalization machinery. - if Requires_Hooking then + if Must_Hook then declare Expr : Node_Id; Ptr_Id : Entity_Id; @@ -4470,7 +4507,7 @@ -- Generate: -- Temp := null; - if Requires_Hooking then + if Must_Hook then Append_To (Stmts, Make_Assignment_Statement (Loc, Name => New_Reference_To (Temp_Id, Loc),