From patchwork Wed Sep 18 08:39:45 2019 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: 1163845 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-509184-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="pbXvq8/C"; 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 46YD6L6sBtz9s4Y for ; Wed, 18 Sep 2019 18:43:54 +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=Yrep2iGjAJxO35WRLXpf5aIF3goGJxekvjs22PDAHtr9p2VFFE Q+HYV69soiOV7gG59igzv0hMQ6CdtloSXgkj5b9q0mIx7NStBWZll8Q/YXTKEAVC CIHRdmH9SAdw+iZFoIpbmmqXGHfG96uB3HovECl8X7MMRmfvjlZL70Y6Q= 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=l06rKaSgRvCRKa2c2Pt3vSidDJw=; b=pbXvq8/CuN5TMtuBO7S6 XasAF1gxLLp6ZzoxarcFYIPECGe7X//O0osyHhjzPByXWaqhWZLXFzV4VD+cY0nm iWgnl4mT6qRpoNF6CqN9Ze5s+txytLK+VY3gHBMG8yrDOEz97/z/JaeI3GIGQBu8 FWa3z9XAwPtU/tnya7rYP8s= Received: (qmail 109416 invoked by alias); 18 Sep 2019 08:41:02 -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 109354 invoked by uid 89); 18 Sep 2019 08:41:01 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy= X-HELO: eggs.gnu.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (209.51.188.92) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 18 Sep 2019 08:41:00 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1iAVVE-0008Jd-Ks for gcc-patches@gcc.gnu.org; Wed, 18 Sep 2019 04:39:57 -0400 Received: from rock.gnat.com ([2620:20:4000:0:a9e:1ff:fe9b:1d1]:53807) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1iAVVC-0008HZ-8W for gcc-patches@gcc.gnu.org; Wed, 18 Sep 2019 04:39:55 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A252C117D20; Wed, 18 Sep 2019 04:39:45 -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 uPY0tuG77VGX; Wed, 18 Sep 2019 04:39:45 -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 68364117D0C; Wed, 18 Sep 2019 04:39:45 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 671AD702; Wed, 18 Sep 2019 04:39:45 -0400 (EDT) Date: Wed, 18 Sep 2019 04:39:45 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Crash on aggregate with dscriminant in if-expression as default Message-ID: <20190918083945.GA145250@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [fuzzy] X-Received-From: 2620:20:4000:0:a9e:1ff:fe9b:1d1 X-IsSubscribed: yes This patch fixes a crash on a an aggregate for a discriminated type, when a component of the aggregate is also a discriminated type constrained by a discriminant of the enclosing object, and the default value for the component is a conditional expression that includes references to that outer discriminant. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-09-18 Ed Schonberg gcc/ada/ * exp_aggr.adb (Expand_Record_Aggregate, Rewrite_Discriminant): After rewriting a reference to an outer discriminant as a selected component of the enclosing object, analyze the selected component to ensure that the entity of the selector name is properly set. This is necessary when the aggregate appears within an expression that may have been analyzed already. gcc/testsuite/ * gnat.dg/discr58.adb: New testcase. --- gcc/ada/exp_aggr.adb +++ gcc/ada/exp_aggr.adb @@ -3103,6 +3103,13 @@ package body Exp_Aggr is Make_Selected_Component (Loc, Prefix => New_Copy_Tree (Lhs), Selector_Name => Make_Identifier (Loc, Chars (Expr)))); + + -- The generated code will be reanalyzed, but if the reference + -- to the discriminant appears within an already analyzed + -- expression (e.g. a conditional) we must set its proper entity + -- now. Context is an initialization procedure. + + Analyze (Expr); end if; return OK; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/discr58.adb @@ -0,0 +1,33 @@ +-- { dg-do compile } + +with Ada.Text_IO; use Ada.Text_IO; + +procedure Discr58 is + + type Field(Flag : Boolean := True) is record + case Flag is + when True => Param1 : Boolean := False; + when False => Param2 : Boolean := True; + end case; + end record; + + type Header(Flag : Boolean := True) is record + Param3 : Integer := 0; + Params : Field(Flag) := (if Flag = True then + (Flag => True, others => <>) + else + (Flag => False, others => <>)); + end record; + + type Message(Flag : Boolean) is record + + -- This assignment crashes GNAT + The_Header : Header(Flag) := Header'(Flag => True, others => <>); + end record; + + It : Message (True); +begin + Put_Line("Hello World"); + Put_Line (Boolean'Image (It.The_Header.Flag)); + Put_Line (Boolean'Image (It.The_Header.Params.Flag)); +end Discr58; \ No newline at end of file