From patchwork Mon Jun 11 09:21:48 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: 927536 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-479432-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="d0FZQqHI"; 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 4146wm57VNz9ryk for ; Mon, 11 Jun 2018 19:22:16 +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=Fi6yT3eqzeZ4ae0VeduCKuejxnmc33Z/0XvHTh2JS6I+DnzGiL JLQSZb2zhAO8cHyX2XcbACwNLfaPq0KbCZbCOXsheUyLsX/CuCbPJbnQuZayms4t vieGoILkeOxwI4CbnIYgvnSSc7j3XI1HMv1PETWOForX2pG836GVJIbg8= 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=89bOdk3MvL3pMbJKmIlSlb6fTdE=; b=d0FZQqHIpz0/VIYzNkYI ewKOQahS1GxXGNdlOd+EGASuIzsNZkHOBRNX0x9NZGIfNy1A8eE6iZ8fz3qxHmb1 kyrexdgpj4QGs2OkUPQO4jBCbZtBBp5kU/kPb0hHzgzDMoQ27coFuYmURP3DlSEk ckTC3vR0pla/BeTPevzxEZY= Received: (qmail 17868 invoked by alias); 11 Jun 2018 09:21:52 -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 17751 invoked by uid 89); 11 Jun 2018 09:21:51 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=cleared, aggregate, partner 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; Mon, 11 Jun 2018 09:21:50 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 9997C560EF; Mon, 11 Jun 2018 05:21:48 -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 rO37VwFq7+pg; Mon, 11 Jun 2018 05:21:48 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 86C29560EC; Mon, 11 Jun 2018 05:21:48 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 85C3A54C; Mon, 11 Jun 2018 05:21:48 -0400 (EDT) Date: Mon, 11 Jun 2018 05:21:48 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Wrong code in array aggregates of Ada coextensions Message-ID: <20180611092148.GA134854@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes The compiler generates wrong code when an array aggregate with an others choice whose expression has nested object allocations (ie. others => new R (new S)) is used to initialize an array of access to discriminated types whose discriminant is an access type. Tested on x86_64-pc-linux-gnu, committed on trunk 2018-06-11 Javier Miranda gcc/ada/ * sinfo.ads (Is_Dynamic_Coextension): Adding documentation. (Is_Static_Coextension): Adding documentation. * sinfo.adb (Is_Dynamic_Coextension): Extending the assertion. (Is_Static_Coextension): Extending the assertion. * sem_util.adb (Mark_Allocator): Clear Is_Static_Coextension when setting flag Is_Dynamic_Coextension (and vice versa). gcc/testsuite/ * gnat.dg/aggr23.adb, gnat.dg/aggr23_q.adb, gnat.dg/aggr23_tt.ads: New testcase. --- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -18472,6 +18472,7 @@ package body Sem_Util is begin if Nkind (N) = N_Allocator then if Is_Dynamic then + Set_Is_Static_Coextension (N, False); Set_Is_Dynamic_Coextension (N); -- If the allocator expression is potentially dynamic, it may @@ -18482,8 +18483,10 @@ package body Sem_Util is elsif Nkind (Expression (N)) = N_Qualified_Expression and then Nkind (Expression (Expression (N))) = N_Op_Concat then + Set_Is_Static_Coextension (N, False); Set_Is_Dynamic_Coextension (N); else + Set_Is_Dynamic_Coextension (N, False); Set_Is_Static_Coextension (N); end if; end if; --- gcc/ada/sinfo.adb +++ gcc/ada/sinfo.adb @@ -5350,6 +5350,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Allocator); + pragma Assert (not Val + or else not Is_Static_Coextension (N)); Set_Flag18 (N, Val); end Set_Is_Dynamic_Coextension; @@ -5613,6 +5615,8 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Allocator); + pragma Assert (not Val + or else not Is_Dynamic_Coextension (N)); Set_Flag14 (N, Val); end Set_Is_Static_Coextension; --- gcc/ada/sinfo.ads +++ gcc/ada/sinfo.ads @@ -1738,7 +1738,8 @@ package Sinfo is -- Present in allocator nodes, to indicate that this is an allocator -- for an access discriminant of a dynamically allocated object. The -- coextension must be deallocated and finalized at the same time as - -- the enclosing object. + -- the enclosing object. The partner flag Is_Static_Coextension must + -- be cleared before setting this flag to True. -- Is_Effective_Use_Clause (Flag1-Sem) -- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate @@ -1949,7 +1950,9 @@ package Sinfo is -- Is_Static_Coextension (Flag14-Sem) -- Present in N_Allocator nodes. Set if the allocator is a coextension - -- of an object allocated on the stack rather than the heap. + -- of an object allocated on the stack rather than the heap. The partner + -- flag Is_Dynamic_Coextension must be cleared before setting this flag + -- to True. -- Is_Static_Expression (Flag6-Sem) -- Indicates that an expression is a static expression according to the --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/aggr23.adb @@ -0,0 +1,9 @@ +-- { dg-options "-gnatws" } +-- { dg-do run } + +with Aggr23_Q; + +procedure Aggr23 is +begin + Aggr23_Q (2); +end; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/aggr23_q.adb @@ -0,0 +1,14 @@ +-- { dg-options "-gnatws" } + +with Ada.Text_IO; use Ada.Text_IO; + +with Aggr23_TT; use Aggr23_TT; + +procedure Aggr23_Q (Count : Natural) is + Ts : array (1 .. Count) of TA + := (others => new T (new Integer)); -- Test +begin + if Ts (1).D = Ts (2).D then + Put ("ERROR"); + end if; +end; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/aggr23_tt.ads @@ -0,0 +1,4 @@ +package Aggr23_TT is + type T (D : not null access Integer) is null record; + type TA is access T; +end;