From patchwork Thu Jan 11 09:04:27 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 858938 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-470784-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="wDmkRumg"; 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 3zHKhG1JQWz9t3F for ; Thu, 11 Jan 2018 20:04:45 +1100 (AEDT) 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=ZsjFZ8aM2FbFwBvNTOQroZXjbqmAco9DzynMTyEKjXWG/CIQVM /BjE1Ksx29ho+qx+L9hQN8u2IPAZa8EIQm9u6hSbiNRxPbcs08770L9+4CE2Vr5R FnwHQFwJhlLq5uZLewzGINNpfGrGvDGt8fDlzgKdmX0o3qe+yl98PAnfs= 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=HsVsc2CZ4d2LFOLasf0/hE0ptdI=; b=wDmkRumggl6PInBV7vgs xJX4NrXoOTVttp5qacvnFdd4lwYLE+xnCrG2e7YlZLTO/FtHNvc/dy/q5N4QIUpT D51/O4Yog8+mTg6royhrXNBPrHYRTc67ZS6SYtU3fN7UGay+MhwGUCcpi58c+NMc z3u0PwCAG4UAqtqpQnwr/oI= Received: (qmail 11512 invoked by alias); 11 Jan 2018 09:04:38 -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 2841 invoked by uid 89); 11 Jan 2018 09:04:30 -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=Act, TWO, adj, ini 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, 11 Jan 2018 09:04:28 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 6853C117BC2; Thu, 11 Jan 2018 04:04:27 -0500 (EST) 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 NM7Cu-M+k7fo; Thu, 11 Jan 2018 04:04:27 -0500 (EST) 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 572ED117BBE; Thu, 11 Jan 2018 04:04:27 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 55E6C50B; Thu, 11 Jan 2018 04:04:27 -0500 (EST) Date: Thu, 11 Jan 2018 04:04:27 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Missing finalization in case expression Message-ID: <20180111090427.GA102885@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This patch modifies the processing of controlled transient objects within case expressions represented by an Expression_With_Actions node. The inspection of an individual action must continue in case it denotes a complex expression, such as a case statement, which in turn may contain additional transients. ------------ -- Source -- ------------ -- pack.ads with Ada.Finalization; use Ada.Finalization; package Pack is function Next_Id return Natural; type Ctrl is new Controlled with record Id : Natural := 0; end record; procedure Adjust (Obj : in out Ctrl); procedure Finalize (Obj : in out Ctrl); procedure Initialize (Obj : in out Ctrl); function New_Ctrl return Ctrl; Empty : constant Ctrl := (Controlled with Id => 1); type Enum is (One, Two, Three); type Ctrl_Rec is record Comp : Ctrl; Kind : Enum; end record; procedure Proc (Obj : Ctrl_Rec); end Pack; -- pack.adb with Ada.Text_IO; use Ada.Text_IO; package body Pack is Id_Gen : Natural := 1; procedure Adjust (Obj : in out Ctrl) is Old_Id : constant Natural := Obj.Id; New_Id : Natural; begin if Old_Id = 0 then Put_Line (" adj: ERROR already finalized"); else New_Id := Old_Id * 100; Put_Line (" adj: " & Old_Id'Img & " ->" & New_Id'Img); Obj.Id := New_Id; end if; end Adjust; procedure Finalize (Obj : in out Ctrl) is Old_Id : constant Natural := Obj.Id; begin if Old_Id = 0 then Put_Line (" fin: ERROR already finalized"); else Put_Line (" fin: " & Old_Id'Img); Obj.Id := 0; end if; end Finalize; procedure Initialize (Obj : in out Ctrl) is New_Id : constant Natural := Next_Id; begin Put_Line (" ini: " & New_Id'Img); Obj.Id := New_Id; end Initialize; procedure Proc (Obj : Ctrl_Rec) is begin Put_Line ("proc : " & Obj.Comp.Id'Img); end Proc; function Next_Id return Natural is begin Id_Gen := Id_Gen + 1; return Id_Gen; end Next_Id; function New_Ctrl return Ctrl is Obj : Ctrl; begin return Obj; end New_Ctrl; end Pack; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Pack; use Pack; procedure Main is procedure Proc_Case_Expr (Mode : Enum) is begin Put_Line ("proc_case_expr: " & Mode'Img); Proc (case Mode is when One => (Kind => Two, Comp => Empty), when Two => (Kind => Three, Comp => Empty), when Three => (Kind => One, Comp => New_Ctrl)); end Proc_Case_Expr; procedure Proc_If_Expr (Mode : Enum) is begin Put_Line ("proc_if_expr: " & Mode'Img); Proc ((if Mode = One then (Kind => Two, Comp => Empty) elsif Mode = Two then (Kind => Three, Comp => Empty) else (Kind => One, Comp => New_Ctrl))); end Proc_If_Expr; begin Proc_Case_Expr (One); Proc_Case_Expr (Two); Proc_Case_Expr (Three); Proc_If_Expr (One); Proc_If_Expr (Two); Proc_If_Expr (Three); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main proc_case_expr: ONE adj: 1 -> 100 proc : 100 fin: 100 proc_case_expr: TWO adj: 1 -> 100 proc : 100 fin: 100 proc_case_expr: THREE ini: 2 adj: 2 -> 200 fin: 2 adj: 200 -> 20000 proc : 20000 fin: 20000 fin: 200 proc_if_expr: ONE adj: 1 -> 100 proc : 100 fin: 100 proc_if_expr: TWO adj: 1 -> 100 proc : 100 fin: 100 proc_if_expr: THREE ini: 3 adj: 3 -> 300 fin: 3 adj: 300 -> 30000 proc : 30000 fin: 30000 fin: 300 fin: 1 Tested on x86_64-pc-linux-gnu, committed on trunk 2018-01-11 Hristian Kirtchev gcc/ada/ * exp_ch4.adb (Process_Action): Do not abandon the inspection of an individual action because the action may denote a complex expression, such as a case statement, which in turn may contain additional transient objects. --- gcc/ada/exp_ch4.adb +++ gcc/ada/exp_ch4.adb @@ -5340,7 +5340,7 @@ package body Exp_Ch4 is and then Is_Finalizable_Transient (Act, N) then Process_Transient_In_Expression (Act, N, Acts); - return Abandon; + return Skip; -- Avoid processing temporary function results multiple times when -- dealing with nested expression_with_actions.