From patchwork Thu Sep 7 09:33:40 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 810937 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461667-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="o79nW1h6"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3xnwJK0GGgz9sRV for ; Thu, 7 Sep 2017 19:34:08 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=vOoW8P36gFylx4M1HB3CYyaRLNaUo74VkCuk/92uaeKNnuUi3K 0ELlYqhTwOhE9LGpFZSrMpH3NBKOx3B0NrKKjm5GCxx//Xxm3tr8b9PYD1dVPLn0 +qW9c3PLy4131cNot6rxXE3Z788Fx0TS61piwNZ9/5WbBx/SGCP4UK/kw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=oucfDnk6wRfWlH9TNuMqztaBuws=; b=o79nW1h6XNFOmLUQxAZb Viwi9Pzu8YZMCbo3/g2AQ8I9Ioyj7yl/ojNR2ekqVzBA2KIDR/ifbSOn3TCpNJ1P z3FRoB0XCoIf5wdr7q2dmcIADQUGtXW6cpszJysJ1mYgNImDT8UBLeGeSgQ6PPKM cOal1vmaMjuhLb6VagMc8uk= Received: (qmail 88016 invoked by alias); 7 Sep 2017 09:33:45 -0000 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 Received: (qmail 87586 invoked by uid 89); 7 Sep 2017 09:33:44 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=sk:limited, Hx-languages-length:3005, Heck X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 07 Sep 2017 09:33:42 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id D3A4F561AC; Thu, 7 Sep 2017 05:33:40 -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 XvkTFpExmCK2; Thu, 7 Sep 2017 05:33:40 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id C34C8561A2; Thu, 7 Sep 2017 05:33:40 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id C24BB4FC; Thu, 7 Sep 2017 05:33:40 -0400 (EDT) Date: Thu, 7 Sep 2017 05:33:40 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [Ada] Finalization for b-i-p that raises exception Message-ID: <20170907093340.GA75050@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch fixes a bug where if a limited object is initialized with a build-in-place function call, and the call does not return on the secondary stack, and the function raises an exception, so that the object is not (successfully) created, the uninitialized object is incorrectly finalized. The following test should compile and run quietly: with Ada.Finalization; use Ada.Finalization; package BIP_Fin_Uninit is type Inner is new Limited_Controlled with null record; type Outer is limited record Inn: Inner; end record; Heck: exception; function Make_Outer return Outer; procedure Finalize(X: in out Inner); end BIP_Fin_Uninit; package body BIP_Fin_Uninit is function Make_Outer return Outer is begin raise Heck; return Make_Outer; -- Bogus recursive call never happens. end Make_Outer; procedure Finalize(X: in out Inner) is begin -- This should never be called. raise Program_Error with "Finalize called"; end Finalize; end BIP_Fin_Uninit; procedure BIP_Fin_Uninit.Main is begin declare X: Outer := Make_Outer; -- Propagates an exception. begin raise Program_Error; -- Can't get here. end; exception when Heck => null; -- OK end BIP_Fin_Uninit.Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Bob Duff * exp_ch7.adb (Find_Last_Init): Check for the case where a build-in-place function call has been replaced by a 'Reference attribute reference. Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 251773) +++ exp_ch7.adb (working copy) @@ -2763,9 +2763,30 @@ Stmt := Next_Suitable_Statement (Decl); - -- Nothing to do for an object with suppressed initialization + -- For an object with suppressed initialization, we check whether + -- there is in fact no initialization expression. If there is not, + -- then this is an object declaration that has been turned into a + -- different object declaration that calls the build-in-place + -- function in a 'Reference attribute, as in "F(...)'Reference". + -- We search for that later object declaration, so that the + -- Inc_Decl will be inserted after the call. Otherwise, if the + -- call raises an exception, we will finalize the (uninitialized) + -- object, which is wrong. if No_Initialization (Decl) then + if No (Expression (Last_Init)) then + loop + Last_Init := Next (Last_Init); + exit when No (Last_Init); + exit when Nkind (Last_Init) = N_Object_Declaration + and then Nkind (Expression (Last_Init)) = N_Reference + and then Nkind (Prefix (Expression (Last_Init))) = + N_Function_Call + and then Is_Expanded_Build_In_Place_Call + (Prefix (Expression (Last_Init))); + end loop; + end if; + return; -- In all other cases the initialization calls follow the related @@ -2955,7 +2976,7 @@ if No (Finalizer_Insert_Nod) then - -- Insertion after an abort deffered block + -- Insertion after an abort deferred block if Present (Body_Ins) then Finalizer_Insert_Nod := Body_Ins;